diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+The Glasgow Haskell Compiler License
+
+Copyright 2002, The University Court of the University of Glasgow. 
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+ 
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+ 
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
new file mode 100644
--- /dev/null
+++ b/compiler/HsVersions.h
@@ -0,0 +1,65 @@
+#pragma once
+
+#if 0
+
+IMPORTANT!  If you put extra tabs/spaces in these macro definitions,
+you will screw up the layout where they are used in case expressions!
+
+(This is cpp-dependent, of course)
+
+#endif
+
+/* Useful in the headers that we share with the RTS */
+#define COMPILING_GHC 1
+
+/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */
+#include "ghc_boot_platform.h"
+
+/* Pull in the autoconf defines (HAVE_FOO), but don't include
+ * ghcconfig.h, because that will include ghcplatform.h which has the
+ * wrong platform settings for the compiler (it has the platform
+ * settings for the target plat instead). */
+#include "ghcautoconf.h"
+
+#define GLOBAL_VAR(name,value,ty)  \
+{-# NOINLINE name #-};             \
+name :: IORef (ty);                \
+name = Util.global (value);
+
+#define GLOBAL_VAR_M(name,value,ty) \
+{-# NOINLINE name #-};              \
+name :: IORef (ty);                 \
+name = Util.globalM (value);
+
+
+#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \
+{-# NOINLINE name #-};                                      \
+name :: IORef (ty);                                         \
+name = Util.sharedGlobal (value) (accessor);                \
+foreign import ccall unsafe saccessor                       \
+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));
+
+#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \
+{-# NOINLINE name #-};                                         \
+name :: IORef (ty);                                            \
+name = Util.sharedGlobalM (value) (accessor);                  \
+foreign import ccall unsafe saccessor                          \
+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));
+
+
+#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else
+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
+
+-- Examples:   Assuming   flagSet :: String -> m Bool
+--
+--    do { c   <- getChar; MASSERT( isUpper c ); ... }
+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }
+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }
+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }
+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }
+#define MASSERT(e)      ASSERT(e) return ()
+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()
+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }
+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }
+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
diff --git a/compiler/Unique.h b/compiler/Unique.h
new file mode 100644
--- /dev/null
+++ b/compiler/Unique.h
@@ -0,0 +1,5 @@
+/* unique has the following structure:
+ * HsInt unique =
+ *    (unique_tag << (sizeof (HsInt) - UNIQUE_TAG_BITS)) | unique_number
+ */
+#define UNIQUE_TAG_BITS 8
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
new file mode 100644
--- /dev/null
+++ b/compiler/backpack/DriverBkp.hs
@@ -0,0 +1,830 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+
+-- | This is the driver for the 'ghc --backpack' mode, which
+-- is a reimplementation of the "package manager" bits of
+-- Backpack directly in GHC.  The basic method of operation
+-- is to compile packages and then directly insert them into
+-- GHC's in memory database.
+--
+-- The compilation products of this mode aren't really suitable
+-- for Cabal, because GHC makes up component IDs for the things
+-- it builds and doesn't serialize out the database contents.
+-- But it's still handy for constructing tests.
+
+module DriverBkp (doBackpack) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+-- In a separate module because it hooks into the parser.
+import BkpSyn
+
+import GHC hiding (Failed, Succeeded)
+import Packages
+import Parser
+import Lexer
+import GhcMonad
+import DynFlags
+import TcRnMonad
+import TcRnDriver
+import Module
+import HscTypes
+import StringBuffer
+import FastString
+import ErrUtils
+import SrcLoc
+import HscMain
+import UniqFM
+import UniqDFM
+import Outputable
+import Maybes
+import HeaderInfo
+import MkIface
+import GhcMake
+import UniqDSet
+import PrelNames
+import BasicTypes hiding (SuccessFlag(..))
+import Finder
+import Util
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Panic
+import Data.List
+import System.Exit
+import Control.Monad
+import System.FilePath
+import Data.Version
+
+-- for the unification
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- | Entry point to compile a Backpack file.
+doBackpack :: [FilePath] -> Ghc ()
+doBackpack [src_filename] = do
+    -- Apply options from file to dflags
+    dflags0 <- getDynFlags
+    let dflags1 = dflags0
+    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
+    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
+    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
+    -- Cribbed from: preprocessFile / DriverPipeline
+    liftIO $ checkProcessArgsResult dflags unhandled_flags
+    liftIO $ handleFlagWarnings dflags warns
+    -- TODO: Preprocessing not implemented
+
+    buf <- liftIO $ hGetStringBuffer src_filename
+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
+    case unP parseBackpack (mkPState dflags buf loc) of
+        PFailed pst -> throwErrors (getErrorMessages pst dflags)
+        POk _ pkgname_bkp -> do
+            -- OK, so we have an LHsUnit PackageName, but we want an
+            -- LHsUnit HsComponentId.  So let's rename it.
+            let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
+            initBkpM src_filename bkp $
+                forM_ (zip [1..] bkp) $ \(i, lunit) -> do
+                    let comp_name = unLoc (hsunitName (unLoc lunit))
+                    msgTopPackage (i,length bkp) comp_name
+                    innerBkpM $ do
+                        let (cid, insts) = computeUnitId lunit
+                        if null insts
+                            then if cid == ComponentId (fsLit "main")
+                                    then compileExe lunit
+                                    else compileUnit cid []
+                            else typecheckUnit cid insts
+doBackpack _ =
+    throwGhcException (CmdLineError "--backpack can only process a single file")
+
+computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
+computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
+  where
+    cid = hsComponentId (unLoc (hsunitName unit))
+    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
+    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
+    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
+    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
+        unitIdFreeHoles (convertHsUnitId hsuid)
+
+-- | Tiny enum for all types of Backpack operations we may do.
+data SessionType
+    -- | A compilation operation which will result in a
+    -- runnable executable being produced.
+    = ExeSession
+    -- | A type-checking operation which produces only
+    -- interface files, no object files.
+    | TcSession
+    -- | A compilation operation which produces both
+    -- interface files and object files.
+    | CompSession
+    deriving (Eq)
+
+-- | Create a temporary Session to do some sort of type checking or
+-- compilation.
+withBkpSession :: ComponentId
+               -> [(ModuleName, Module)]
+               -> [(UnitId, ModRenaming)]
+               -> SessionType   -- what kind of session are we doing
+               -> BkpM a        -- actual action to run
+               -> BkpM a
+withBkpSession cid insts deps session_type do_this = do
+    dflags <- getDynFlags
+    let (ComponentId cid_fs) = cid
+        is_primary = False
+        uid_str = unpackFS (hashUnitId cid insts)
+        cid_str = unpackFS cid_fs
+        -- There are multiple units in a single Backpack file, so we
+        -- need to separate out the results in those cases.  Right now,
+        -- we follow this hierarchy:
+        --      $outputdir/$compid          --> typecheck results
+        --      $outputdir/$compid/$unitid  --> compile results
+        key_base p | Just f <- p dflags = f
+                   | otherwise          = "."
+        sub_comp p | is_primary = p
+                   | otherwise = p </> cid_str
+        outdir p | CompSession <- session_type
+                 -- Special case when package is definite
+                 , not (null insts) = sub_comp (key_base p) </> uid_str
+                 | otherwise = sub_comp (key_base p)
+    withTempSession (overHscDynFlags (\dflags ->
+      -- If we're type-checking an indefinite package, we want to
+      -- turn on interface writing.  However, if the user also
+      -- explicitly passed in `-fno-code`, we DON'T want to write
+      -- interfaces unless the user also asked for `-fwrite-interface`.
+      -- See Note [-fno-code mode]
+      (case session_type of
+        -- Make sure to write interfaces when we are type-checking
+        -- indefinite packages.
+        TcSession | hscTarget dflags /= HscNothing
+                  -> flip gopt_set Opt_WriteInterface
+                  | otherwise -> id
+        CompSession -> id
+        ExeSession -> id) $
+      dflags {
+        hscTarget   = case session_type of
+                        TcSession -> HscNothing
+                        _ -> hscTarget dflags,
+        thisUnitIdInsts_ = Just insts,
+        thisComponentId_ = Just cid,
+        thisInstalledUnitId =
+            case session_type of
+                TcSession -> newInstalledUnitId cid Nothing
+                -- No hash passed if no instances
+                _ | null insts -> newInstalledUnitId cid Nothing
+                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
+        -- Setup all of the output directories according to our hierarchy
+        objectDir   = Just (outdir objectDir),
+        hiDir       = Just (outdir hiDir),
+        stubDir     = Just (outdir stubDir),
+        -- Unset output-file for non exe builds
+        outputFile  = if session_type == ExeSession
+                        then outputFile dflags
+                        else Nothing,
+        -- Clear the import path so we don't accidentally grab anything
+        importPaths = [],
+        -- Synthesized the flags
+        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
+          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
+          in ExposePackage
+            (showSDoc dflags
+                (text "-unit-id" <+> ppr uid <+> ppr rn))
+            (UnitIdArg uid) rn) deps
+      } )) $ do
+        dflags <- getSessionDynFlags
+        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
+        -- Calls initPackages
+        _ <- setSessionDynFlags dflags
+        do_this
+
+withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
+withBkpExeSession deps do_this = do
+    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
+
+getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
+getSource cid = do
+    bkp_env <- getBkpEnv
+    case Map.lookup cid (bkp_table bkp_env) of
+        Nothing -> pprPanic "missing needed dependency" (ppr cid)
+        Just lunit -> return lunit
+
+typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+typecheckUnit cid insts = do
+    lunit <- getSource cid
+    buildUnit TcSession cid insts lunit
+
+compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+compileUnit cid insts = do
+    -- Let everyone know we're building this unit ID
+    msgUnitId (newUnitId cid insts)
+    lunit <- getSource cid
+    buildUnit CompSession cid insts lunit
+
+-- | Compute the dependencies with instantiations of a syntactic
+-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
+-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
+-- The @include_sigs@ parameter controls whether or not we also
+-- include @dependency signature@ declarations in this calculation.
+--
+-- Invariant: this NEVER returns InstalledUnitId.
+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
+  where
+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
+        | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
+        | otherwise = []
+      where
+        go Nothing = ModRenaming True []
+        go (Just lrns) = ModRenaming False (map convRn lrns)
+          where
+            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)
+            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
+    get_dep _ = []
+
+buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
+buildUnit session cid insts lunit = do
+    -- NB: include signature dependencies ONLY when typechecking.
+    -- If we're compiling, it's not necessary to recursively
+    -- compile a signature since it isn't going to produce
+    -- any object files.
+    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
+        raw_deps = map fst deps_w_rns
+    dflags <- getDynFlags
+    -- The compilation dependencies are just the appropriately filled
+    -- in unit IDs which must be compiled before we can compile.
+    let hsubst = listToUFM insts
+        deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
+
+    -- Build dependencies OR make sure they make sense. BUT NOTE,
+    -- we can only check the ones that are fully filled; the rest
+    -- we have to defer until we've typechecked our local signature.
+    -- TODO: work this into GhcMake!!
+    forM_ (zip [1..] deps0) $ \(i, dep) ->
+        case session of
+            TcSession -> return ()
+            _ -> compileInclude (length deps0) (i, dep)
+
+    dflags <- getDynFlags
+    -- IMPROVE IT
+    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
+
+    mb_old_eps <- case session of
+                    TcSession -> fmap Just getEpsGhc
+                    _ -> return Nothing
+
+    conf <- withBkpSession cid insts deps_w_rns session $ do
+
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
+
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
+            export_mod ms = (ms_mod_name ms, ms_mod ms)
+            -- Export everything!
+            mods = [ export_mod ms | ms <- mgModSummaries mod_graph
+                                   , ms_hsc_src ms == HsSrcFile ]
+
+        -- Compile relevant only
+        hsc_env <- getSession
+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
+            linkables = map (expectJust "bkp link" . hm_linkable)
+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
+                      $ home_mod_infos
+            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+            obj_files = concatMap getOfiles linkables
+
+        let compat_fs = (case cid of ComponentId fs -> fs)
+            compat_pn = PackageName compat_fs
+
+        return InstalledPackageInfo {
+            -- Stub data
+            abiHash = "",
+            sourcePackageId = SourcePackageId compat_fs,
+            packageName = compat_pn,
+            packageVersion = makeVersion [0],
+            unitId = toInstalledUnitId (thisPackage dflags),
+            sourceLibName = Nothing,
+            componentId = cid,
+            instantiatedWith = insts,
+            -- Slight inefficiency here haha
+            exposedModules = map (\(m,n) -> (m,Just n)) mods,
+            hiddenModules = [], -- TODO: doc only
+            depends = case session of
+                        -- Technically, we should state that we depend
+                        -- on all the indefinite libraries we used to
+                        -- typecheck this.  However, this field isn't
+                        -- really used for anything, so we leave it
+                        -- blank for now.
+                        TcSession -> []
+                        _ -> map (toInstalledUnitId . unwireUnitId dflags)
+                                $ deps ++ [ moduleUnitId mod
+                                          | (_, mod) <- insts
+                                          , not (isHoleModule mod) ],
+            abiDepends = [],
+            ldOptions = case session of
+                            TcSession -> []
+                            _ -> obj_files,
+            importDirs = [ hi_dir ],
+            exposed = False,
+            indefinite = case session of
+                            TcSession -> True
+                            _ -> False,
+            -- nope
+            hsLibraries = [],
+            extraLibraries = [],
+            extraGHCiLibraries = [],
+            libraryDynDirs = [],
+            libraryDirs = [],
+            frameworks = [],
+            frameworkDirs = [],
+            ccOptions = [],
+            includes = [],
+            includeDirs = [],
+            haddockInterfaces = [],
+            haddockHTMLs = [],
+            trusted = False
+            }
+
+
+    addPackage conf
+    case mb_old_eps of
+        Just old_eps -> updateEpsGhc_ (const old_eps)
+        _ -> return ()
+
+compileExe :: LHsUnit HsComponentId -> BkpM ()
+compileExe lunit = do
+    msgUnitId mainUnitId
+    let deps_w_rns = hsunitDeps False (unLoc lunit)
+        deps = map fst deps_w_rns
+        -- no renaming necessary
+    forM_ (zip [1..] deps) $ \(i, dep) ->
+        compileInclude (length deps) (i, dep)
+    withBkpExeSession deps_w_rns $ do
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+addPackage :: GhcMonad m => PackageConfig -> m ()
+addPackage pkg = do
+    dflags0 <- GHC.getSessionDynFlags
+    case pkgDatabase dflags0 of
+        Nothing -> panic "addPackage: called too early"
+        Just pkgs -> do let dflags = dflags0 { pkgDatabase =
+                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
+                        _ <- GHC.setSessionDynFlags dflags
+                        -- By this time, the global ref has probably already
+                        -- been forced, in which case doing this isn't actually
+                        -- going to do you any good.
+                        -- dflags <- GHC.getSessionDynFlags
+                        -- liftIO $ setUnsafeGlobalDynFlags dflags
+                        return ()
+
+-- Precondition: UnitId is NOT InstalledUnitId
+compileInclude :: Int -> (Int, UnitId) -> BkpM ()
+compileInclude n (i, uid) = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+    msgInclude (i, n) uid
+    -- Check if we've compiled it already
+    case lookupPackage dflags uid of
+        Nothing -> do
+            case splitUnitIdInsts uid of
+                (_, Just indef) ->
+                    innerBkpM $ compileUnit (indefUnitIdComponentId indef)
+                                            (indefUnitIdInsts indef)
+                _ -> return ()
+        Just _ -> return ()
+
+-- ----------------------------------------------------------------------------
+-- Backpack monad
+
+-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
+-- beyond the 'Session', c.f. 'BkpEnv'.
+type BkpM = IOEnv BkpEnv
+
+-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
+-- because we are going to update the 'HscEnv' as we go.
+data BkpEnv
+    = BkpEnv {
+        -- | The session
+        bkp_session :: Session,
+        -- | The filename of the bkp file we're compiling
+        bkp_filename :: FilePath,
+        -- | Table of source units which we know how to compile
+        bkp_table :: Map ComponentId (LHsUnit HsComponentId),
+        -- | When a package we are compiling includes another package
+        -- which has not been compiled, we bump the level and compile
+        -- that.
+        bkp_level :: Int
+    }
+
+-- Blah, to get rid of the default instance for IOEnv
+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
+instance {-# OVERLAPPING #-} HasDynFlags BkpM where
+    getDynFlags = fmap hsc_dflags getSession
+
+instance GhcMonad BkpM where
+    getSession = do
+        Session s <- fmap bkp_session getEnv
+        readMutVar s
+    setSession hsc_env = do
+        Session s <- fmap bkp_session getEnv
+        writeMutVar s hsc_env
+
+-- | Get the current 'BkpEnv'.
+getBkpEnv :: BkpM BkpEnv
+getBkpEnv = getEnv
+
+-- | Get the nesting level, when recursively compiling modules.
+getBkpLevel :: BkpM Int
+getBkpLevel = bkp_level `fmap` getBkpEnv
+
+-- | Apply a function on 'DynFlags' on an 'HscEnv'
+overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
+overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
+
+-- | Run a 'BkpM' computation, with the nesting level bumped one.
+innerBkpM :: BkpM a -> BkpM a
+innerBkpM do_this = do
+    -- NB: withTempSession mutates, so we don't have to worry
+    -- about bkp_session being stale.
+    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
+
+-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
+updateEpsGhc_ f = do
+    hsc_env <- getSession
+    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
+
+-- | Get the EPS from a 'GhcMonad'.
+getEpsGhc :: GhcMonad m => m ExternalPackageState
+getEpsGhc = do
+    hsc_env <- getSession
+    liftIO $ readIORef (hsc_EPS hsc_env)
+
+-- | Run 'BkpM' in 'Ghc'.
+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
+initBkpM file bkp m = do
+    reifyGhc $ \session -> do
+    let env = BkpEnv {
+                    bkp_session = session,
+                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
+                    bkp_filename = file,
+                    bkp_level = 0
+                }
+    runIOEnv env m
+
+-- ----------------------------------------------------------------------------
+-- Messaging
+
+-- | Print a compilation progress message, but with indentation according
+-- to @level@ (for nested compilation).
+backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
+backpackProgressMsg level dflags msg =
+    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
+
+-- | Creates a 'Messager' for Backpack compilation; this is basically
+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
+-- handles indentation.
+mkBackpackMsg :: BkpM Messager
+mkBackpackMsg = do
+    level <- getBkpLevel
+    return $ \hsc_env mod_index recomp mod_summary ->
+      let dflags = hsc_dflags hsc_env
+          showMsg msg reason =
+            backpackProgressMsg level dflags $
+                showModuleIndex mod_index ++
+                msg ++ showModMsg dflags (hscTarget dflags)
+                                  (recompileRequired recomp) mod_summary
+                    ++ reason
+      in case recomp of
+            MustCompile -> showMsg "Compiling " ""
+            UpToDate
+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+                | otherwise -> return ()
+            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+
+-- | 'PprStyle' for Backpack messages; here we usually want the module to
+-- be qualified (so we can tell how it was instantiated.) But we try not
+-- to qualify packages so we can use simple names for them.
+backpackStyle :: DynFlags -> PprStyle
+backpackStyle dflags =
+    mkUserStyle dflags
+        (QueryQualify neverQualifyNames
+                      alwaysQualifyModules
+                      neverQualifyPackages) AllTheWay
+
+-- | Message when we initially process a Backpack unit.
+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
+
+-- | Message when we instantiate a Backpack unit.
+msgUnitId :: UnitId -> BkpM ()
+msgUnitId pk = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
+                                (backpackStyle dflags)
+
+-- | Message when we include a Backpack unit.
+msgInclude :: (Int,Int) -> UnitId -> BkpM ()
+msgInclude (i,n) uid = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ showModuleIndex (i, n) ++ "Including " ++
+          renderWithStyle dflags (ppr uid) (backpackStyle dflags)
+
+-- ----------------------------------------------------------------------------
+-- Conversion from PackageName to HsComponentId
+
+type PackageNameMap a = Map PackageName a
+
+-- For now, something really simple, since we're not actually going
+-- to use this for anything
+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+    = (pn, HsComponentId pn (ComponentId fs))
+
+packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
+packageNameMap units = Map.fromList (map unitDefines units)
+
+renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
+renameHsUnits dflags m units = map (fmap renameHsUnit) units
+  where
+
+    renamePackageName :: PackageName -> HsComponentId
+    renamePackageName pn =
+        case Map.lookup pn m of
+            Nothing ->
+                case lookupPackageName dflags pn of
+                    Nothing -> error "no package name"
+                    Just cid -> HsComponentId pn cid
+            Just hscid -> hscid
+
+    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
+    renameHsUnit u =
+        HsUnit {
+            hsunitName = fmap renamePackageName (hsunitName u),
+            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
+        }
+
+    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
+    renameHsUnitDecl (DeclD a b c) = DeclD a b c
+    renameHsUnitDecl (IncludeD idecl) =
+        IncludeD IncludeDecl {
+            idUnitId = fmap renameHsUnitId (idUnitId idecl),
+            idModRenaming = idModRenaming idecl,
+            idSignatureInclude = idSignatureInclude idecl
+        }
+
+    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
+    renameHsUnitId (HsUnitId ln subst)
+        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
+
+    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
+    renameHsModuleSubst (lk, lm)
+        = (lk, fmap renameHsModuleId lm)
+
+    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
+    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
+    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
+
+convertHsUnitId :: HsUnitId HsComponentId -> UnitId
+convertHsUnitId (HsUnitId (L _ hscid) subst)
+    = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
+
+convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
+
+convertHsModuleId :: HsModuleId HsComponentId -> Module
+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Module graph construction
+*                                                                      *
+************************************************************************
+-}
+
+-- | This is our version of GhcMake.downsweep, but with a few modifications:
+--
+--  1. Every module is required to be mentioned, so we don't do any funny
+--     business with targets or recursively grabbing dependencies.  (We
+--     could support this in principle).
+--  2. We support inline modules, whose summary we have to synthesize ourself.
+--
+-- We don't bother trying to support GhcMake for now, it's more trouble
+-- than it's worth for inline modules.
+hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
+hsunitModuleGraph dflags unit = do
+    let decls = hsunitBody unit
+        pn = hsPackageName (unLoc (hsunitName unit))
+
+    --  1. Create a HsSrcFile/HsigFile summary for every
+    --  explicitly mentioned module/signature.
+    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
+          let hsc_src = case dt of
+                          ModuleD    -> HsSrcFile
+                          SignatureD -> HsigFile
+          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
+        get_decl _ = return Nothing
+    nodes <- catMaybes `fmap` mapM get_decl decls
+
+    --  2. For each hole which does not already have an hsig file,
+    --  create an "empty" hsig file to induce compilation for the
+    --  requirement.
+    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
+                                | n <- nodes ]
+    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
+        let has_local = Map.member (mod_name, True) node_map
+        in if has_local
+            then return Nothing
+            else fmap Just $ summariseRequirement pn mod_name
+
+    -- 3. Return the kaboodle
+    return $ mkModuleGraph $ nodes ++ req_nodes
+
+summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
+summariseRequirement pn mod_name = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+
+    let PackageName pn_fs = pn
+    location <- liftIO $ mkHomeModLocation2 dflags mod_name
+                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+
+    env <- getBkpEnv
+    time <- liftIO $ getModificationUTCTime (bkp_filename env)
+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
+
+    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
+
+    return ModSummary {
+        ms_mod = mod,
+        ms_hsc_src = HsigFile,
+        ms_location = location,
+        ms_hs_date = time,
+        ms_obj_date = Nothing,
+        ms_iface_date = hi_timestamp,
+        ms_hie_date = hie_timestamp,
+        ms_srcimps = [],
+        ms_textual_imps = extra_sig_imports,
+        ms_parsed_mod = Just (HsParsedModule {
+                hpm_module = L loc (HsModule {
+                        hsmodName = Just (L loc mod_name),
+                        hsmodExports = Nothing,
+                        hsmodImports = [],
+                        hsmodDecls = [],
+                        hsmodDeprecMessage = Nothing,
+                        hsmodHaddockModHeader = Nothing
+                    }),
+                hpm_src_files = [],
+                hpm_annotations = (Map.empty, Map.empty)
+            }),
+        ms_hspp_file = "", -- none, it came inline
+        ms_hspp_opts = dflags,
+        ms_hspp_buf = Nothing
+        }
+
+summariseDecl :: PackageName
+              -> HscSource
+              -> Located ModuleName
+              -> Maybe (Located (HsModule GhcPs))
+              -> BkpM ModSummary
+summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
+summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
+    = do hsc_env <- getSession
+         let dflags = hsc_dflags hsc_env
+         -- TODO: this looks for modules in the wrong place
+         r <- liftIO $ summariseModule hsc_env
+                         Map.empty -- GHC API recomp not supported
+                         (hscSourceToIsBoot hsc_src)
+                         lmodname
+                         True -- Target lets you disallow, but not here
+                         Nothing -- GHC API buffer support not supported
+                         [] -- No exclusions
+         case r of
+            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
+            Just (Left err) -> throwOneError err
+            Just (Right summary) -> return summary
+
+-- | Up until now, GHC has assumed a single compilation target per source file.
+-- Backpack files with inline modules break this model, since a single file
+-- may generate multiple output files.  How do we decide to name these files?
+-- Should there only be one output file? This function our current heuristic,
+-- which is we make a "fake" module and use that.
+hsModuleToModSummary :: PackageName
+                     -> HscSource
+                     -> ModuleName
+                     -> Located (HsModule GhcPs)
+                     -> BkpM ModSummary
+hsModuleToModSummary pn hsc_src modname
+                     hsmod = do
+    let imps = hsmodImports (unLoc hsmod)
+        loc  = getLoc hsmod
+    hsc_env <- getSession
+    -- Sort of the same deal as in DriverPipeline's getLocation
+    -- Use the PACKAGE NAME to find the location
+    let PackageName unit_fs = pn
+        dflags = hsc_dflags hsc_env
+    -- Unfortunately, we have to define a "fake" location in
+    -- order to appease the various code which uses the file
+    -- name to figure out where to put, e.g. object files.
+    -- To add insult to injury, we don't even actually use
+    -- these filenames to figure out where the hi files go.
+    -- A travesty!
+    location0 <- liftIO $ mkHomeModLocation2 dflags modname
+                             (unpackFS unit_fs </>
+                              moduleNameSlashes modname)
+                              (case hsc_src of
+                                HsigFile -> "hsig"
+                                HsBootFile -> "hs-boot"
+                                HsSrcFile -> "hs")
+    -- DANGEROUS: bootifying can POISON the module finder cache
+    let location = case hsc_src of
+                        HsBootFile -> addBootSuffixLocnOut location0
+                        _ -> location0
+    -- This duplicates a pile of logic in GhcMake
+    env <- getBkpEnv
+    time <- liftIO $ getModificationUTCTime (bkp_filename env)
+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+
+    -- Also copied from 'getImports'
+    let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+
+             -- GHC.Prim doesn't exist physically, so don't go looking for it.
+        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
+                               ord_idecls
+
+        implicit_prelude = xopt LangExt.ImplicitPrelude dflags
+        implicit_imports = mkPrelImports modname loc
+                                         implicit_prelude imps
+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+
+    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
+
+    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
+    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
+
+    -- So that Finder can find it, even though it doesn't exist...
+    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
+    return ModSummary {
+            ms_mod = this_mod,
+            ms_hsc_src = hsc_src,
+            ms_location = location,
+            ms_hspp_file = (case hiDir dflags of
+                            Nothing -> ""
+                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
+            ms_hspp_opts = dflags,
+            ms_hspp_buf = Nothing,
+            ms_srcimps = map convImport src_idecls,
+            ms_textual_imps = normal_imports
+                           -- We have to do something special here:
+                           -- due to merging, requirements may end up with
+                           -- extra imports
+                           ++ extra_sig_imports
+                           ++ required_by_imports,
+            -- This is our hack to get the parse tree to the right spot
+            ms_parsed_mod = Just (HsParsedModule {
+                    hpm_module = hsmod,
+                    hpm_src_files = [], -- TODO if we preprocessed it
+                    hpm_annotations = (Map.empty, Map.empty) -- BOGUS
+                }),
+            ms_hs_date = time,
+            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
+            ms_iface_date = hi_timestamp,
+            ms_hie_date = hie_timestamp
+        }
+
+-- | Create a new, externally provided hashed unit id from
+-- a hash.
+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
+newInstalledUnitId (ComponentId cid_fs) (Just fs)
+    = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newInstalledUnitId (ComponentId cid_fs) Nothing
+    = InstalledUnitId cid_fs
diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs
new file mode 100644
--- /dev/null
+++ b/compiler/backpack/NameShape.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE CPP #-}
+
+module NameShape(
+    NameShape(..),
+    emptyNameShape,
+    mkNameShape,
+    extendNameShape,
+    nameShapeExports,
+    substNameShape,
+    maybeSubstNameShape,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import FieldLabel
+
+import Name
+import NameEnv
+import TcRnMonad
+import Util
+import IfaceEnv
+
+import Control.Monad
+
+-- Note [NameShape]
+-- ~~~~~~~~~~~~~~~~
+-- When we write a declaration in a signature, e.g., data T, we
+-- ascribe to it a *name variable*, e.g., {m.T}.  This
+-- name variable may be substituted with an actual original
+-- name when the signature is implemented (or even if we
+-- merge the signature with one which reexports this entity
+-- from another module).
+
+-- When we instantiate a signature m with a module M,
+-- we also need to substitute over names.  To do so, we must
+-- compute the *name substitution* induced by the *exports*
+-- of the module in question.  A NameShape represents
+-- such a name substitution for a single module instantiation.
+-- The "shape" in the name comes from the fact that the computation
+-- of a name substitution is essentially the *shaping pass* from
+-- Backpack'14, but in a far more restricted form.
+
+-- The name substitution for an export list is easy to explain.  If we are
+-- filling the module variable <m>, given an export N of the form
+-- M.n or {m'.n} (where n is an OccName), the induced name
+-- substitution is from {m.n} to N.  So, for example, if we have
+-- A=impl:B, and the exports of impl:B are impl:B.f and
+-- impl:C.g, then our name substitution is {A.f} to impl:B.f
+-- and {A.g} to impl:C.g
+
+
+
+
+-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
+-- needs to refer to NameShape, and having TcRnTypes import
+-- NameShape (even by SOURCE) would cause a large number of
+-- modules to be pulled into the DynFlags cycle.
+{-
+data NameShape = NameShape {
+        ns_mod_name :: ModuleName,
+        ns_exports :: [AvailInfo],
+        ns_map :: OccEnv Name
+    }
+-}
+
+-- NB: substitution functions need 'HscEnv' since they need the name cache
+-- to allocate new names if we change the 'Module' of a 'Name'
+
+-- | Create an empty 'NameShape' (i.e., the renaming that
+-- would occur with an implementing module with no exports)
+-- for a specific hole @mod_name@.
+emptyNameShape :: ModuleName -> NameShape
+emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
+
+-- | Create a 'NameShape' corresponding to an implementing
+-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
+mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
+mkNameShape mod_name as =
+    NameShape mod_name as $ mkOccEnv $ do
+        a <- as
+        n <- availName a : availNamesWithSelectors a
+        return (occName n, n)
+
+-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
+-- with Backpack style mix-in linking.  This is used solely when merging
+-- signatures together: we successively merge the exports of each
+-- signature until we have the final, full exports of the merged signature.
+--
+-- What makes this operation nontrivial is what we are supposed to do when
+-- we want to merge in an export for M.T when we already have an existing
+-- export {H.T}.  What should happen in this case is that {H.T} should be
+-- unified with @M.T@: we've determined a more *precise* identity for the
+-- export at 'OccName' @T@.
+--
+-- Note that we don't do unrestricted unification: only name holes from
+-- @ns_mod_name ns@ are flexible.  This is because we have a much more
+-- restricted notion of shaping than in Backpack'14: we do shaping
+-- *as* we do type-checking.  Thus, once we shape a signature, its
+-- exports are *final* and we're not allowed to refine them further,
+extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
+extendNameShape hsc_env ns as =
+    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
+        Left err -> return (Left err)
+        Right nsubst -> do
+            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
+            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
+            let new_avails = mergeAvails as1 as2
+            return . Right $ ns {
+                ns_exports = new_avails,
+                -- TODO: stop repeatedly rebuilding the OccEnv
+                ns_map = mkOccEnv $ do
+                            a <- new_avails
+                            n <- availName a : availNames a
+                            return (occName n, n)
+                }
+
+-- | The export list associated with this 'NameShape' (i.e., what
+-- the exports of an implementing module which induces this 'NameShape'
+-- would be.)
+nameShapeExports :: NameShape -> [AvailInfo]
+nameShapeExports = ns_exports
+
+-- | Given a 'Name', substitute it according to the 'NameShape' implied
+-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
+-- exports @M.T@.
+substNameShape :: NameShape -> Name -> Name
+substNameShape ns n | nameModule n == ns_module ns
+                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)
+                    = n'
+                    | otherwise
+                    = n
+
+-- | Like 'substNameShape', but returns @Nothing@ if no substitution
+-- works.
+maybeSubstNameShape :: NameShape -> Name -> Maybe Name
+maybeSubstNameShape ns n
+    | nameModule n == ns_module ns
+    = lookupOccEnv (ns_map ns) (occName n)
+    | otherwise
+    = Nothing
+
+-- | The 'Module' of any 'Name's a 'NameShape' has action over.
+ns_module :: NameShape -> Module
+ns_module = mkHoleModule . ns_mod_name
+
+{-
+************************************************************************
+*                                                                      *
+                        Name substitutions
+*                                                                      *
+************************************************************************
+-}
+
+-- | Substitution on @{A.T}@.  We enforce the invariant that the
+-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
+-- (meaning that if we have a hole substitution, the keys of the map
+-- are never affected.)  Alternatively, this is isomorphic to
+-- @Map ('ModuleName', 'OccName') 'Name'@.
+type ShNameSubst = NameEnv Name
+
+-- NB: In this module, we actually only ever construct 'ShNameSubst'
+-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
+-- work with.
+
+-- | Substitute names in a 'Name'.
+substName :: ShNameSubst -> Name -> Name
+substName env n | Just n' <- lookupNameEnv env n = n'
+                | otherwise                      = n
+
+-- | Substitute names in an 'AvailInfo'.  This has special behavior
+-- for type constructors, where it is sufficient to substitute the 'availName'
+-- to induce a substitution on 'availNames'.
+substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
+substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))
+substNameAvailInfo hsc_env env (AvailTC n ns fs) =
+    let mb_mod = fmap nameModule (lookupNameEnv env n)
+    in AvailTC (substName env n)
+        <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
+        <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
+
+-- | Set the 'Module' of a 'FieldSelector'
+setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
+setNameFieldSelector _ Nothing f = return f
+setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do
+    sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
+    return (FieldLabel l b sel')
+
+{-
+************************************************************************
+*                                                                      *
+                        AvailInfo merging
+*                                                                      *
+************************************************************************
+-}
+
+-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
+-- already been unified ('uAvailInfos').
+mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
+mergeAvails as1 as2 =
+    let mkNE as = mkNameEnv [(availName a, a) | a <- as]
+    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
+
+{-
+************************************************************************
+*                                                                      *
+                        AvailInfo unification
+*                                                                      *
+************************************************************************
+-}
+
+-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
+uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
+    let mkOE as = listToUFM $ do a <- as
+                                 n <- availNames a
+                                 return (nameOccName n, a)
+    in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
+             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
+             -- Edward: I have to say, this is pretty clever.
+
+-- | Unify two 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
+           -> Either SDoc ShNameSubst
+uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2
+uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
+uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
+                           <+> ppr a1 <+> text "with" <+> ppr a2
+                           <+> parens (text "one is a type, the other is a plain identifier")
+
+-- | Unify two 'Name's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
+uName flexi subst n1 n2
+    | n1 == n2      = Right subst
+    | isFlexi n1    = uHoleName flexi subst n1 n2
+    | isFlexi n2    = uHoleName flexi subst n2 n1
+    | otherwise     = Left (text "While merging export lists, could not unify"
+                         <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
+  where
+    isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
+    extra | isHoleName n1 || isHoleName n2
+          = text "Neither name variable originates from the current signature."
+          | otherwise
+          = empty
+
+-- | Unify a name @h@ which 'isHoleName' with another name, given an existing
+-- substitution @subst@, with only name holes from @flexi@ unifiable (all
+-- other name holes rigid.)
+uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
+          -> Either SDoc ShNameSubst
+uHoleName flexi subst h n =
+    ASSERT( isHoleName h )
+    case lookupNameEnv subst h of
+        Just n' -> uName flexi subst n' n
+                -- Do a quick check if the other name is substituted.
+        Nothing | Just n' <- lookupNameEnv subst n ->
+                    ASSERT( isHoleName n ) uName flexi subst h n'
+                | otherwise ->
+                    Right (extendNameEnv subst h n)
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/backpack/RnModIface.hs
@@ -0,0 +1,743 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | This module implements interface renaming, which is
+-- used to rewrite interface files on the fly when we
+-- are doing indefinite typechecking and need instantiations
+-- of modules which do not necessarily exist yet.
+
+module RnModIface(
+    rnModIface,
+    rnModExports,
+    tcRnModIface,
+    tcRnModExports,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import SrcLoc
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import IfaceSyn
+import FieldLabel
+import Var
+import ErrUtils
+
+import Name
+import TcRnMonad
+import Util
+import Fingerprint
+import BasicTypes
+
+-- a bit vexing
+import {-# SOURCE #-} LoadIface
+import DynFlags
+
+import qualified Data.Traversable as T
+
+import Bag
+import Data.IORef
+import NameShape
+import IfaceEnv
+
+tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a
+tcRnMsgMaybe do_this = do
+    r <- liftIO $ do_this
+    case r of
+        Left errs -> do
+            addMessages (emptyBag, errs)
+            failM
+        Right x -> return x
+
+tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
+tcRnModIface x y z = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModIface hsc_env x y z
+
+tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
+tcRnModExports x y = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModExports hsc_env x y
+
+failWithRn :: SDoc -> ShIfM a
+failWithRn doc = do
+    errs_var <- fmap sh_if_errs getGblEnv
+    dflags <- getDynFlags
+    errs <- readTcRef errs_var
+    -- TODO: maybe associate this with a source location?
+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
+    failM
+
+-- | What we have is a generalized ModIface, which corresponds to
+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.
+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load
+-- up (either to merge it, or to just use during typechecking).
+--
+-- Suppose we have:
+--
+--  p[A=<A>]:M  ==>  p[A=q():A]:M
+--
+-- Substitute all occurrences of <A> with q():A (renameHoleModule).
+-- Then, for any Name of form {A.T}, replace the Name with
+-- the Name according to the exports of the implementing module.
+-- This works even for p[A=<B>]:M, since we just read in the
+-- exports of B.hi, which is assumed to be ready now.
+--
+-- This function takes an optional 'NameShape', which can be used
+-- to further refine the identities in this interface: suppose
+-- we read a declaration for {H.T} but we actually know that this
+-- should be Foo.T; then we'll also rename this (this is used
+-- when loading an interface to merge it into a requirement.)
+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
+           -> ModIface -> IO (Either ErrorMessages ModIface)
+rnModIface hsc_env insts nsubst iface = do
+    initRnIface hsc_env iface insts nsubst $ do
+        mod <- rnModule (mi_module iface)
+        sig_of <- case mi_sig_of iface of
+                    Nothing -> return Nothing
+                    Just x  -> fmap Just (rnModule x)
+        exports <- mapM rnAvailInfo (mi_exports iface)
+        decls <- mapM rnIfaceDecl' (mi_decls iface)
+        insts <- mapM rnIfaceClsInst (mi_insts iface)
+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
+        deps <- rnDependencies (mi_deps iface)
+        -- TODO:
+        -- mi_rules
+        return iface { mi_module = mod
+                     , mi_sig_of = sig_of
+                     , mi_insts = insts
+                     , mi_fam_insts = fams
+                     , mi_exports = exports
+                     , mi_decls = decls
+                     , mi_deps = deps }
+
+-- | Rename just the exports of a 'ModIface'.  Useful when we're doing
+-- shaping prior to signature merging.
+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])
+rnModExports hsc_env insts iface
+    = initRnIface hsc_env iface insts Nothing
+    $ mapM rnAvailInfo (mi_exports iface)
+
+rnDependencies :: Rename Dependencies
+rnDependencies deps = do
+    orphs  <- rnDepModules dep_orphs deps
+    finsts <- rnDepModules dep_finsts deps
+    return deps { dep_orphs = orphs, dep_finsts = finsts }
+
+rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]
+rnDepModules sel deps = do
+    hsc_env <- getTopEnv
+    hmap <- getHoleSubst
+    -- NB: It's not necessary to test if we're doing signature renaming,
+    -- because ModIface will never contain module reference for itself
+    -- in these dependencies.
+    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do
+        dflags <- getDynFlags
+        -- For holes, its necessary to "see through" the instantiation
+        -- of the hole to get accurate family instance dependencies.
+        -- For example, if B imports <A>, and <A> is instantiated with
+        -- F, we must grab and include all of the dep_finsts from
+        -- F to have an accurate transitive dep_finsts list.
+        --
+        -- However, we MUST NOT do this for regular modules.
+        -- First, for efficiency reasons, doing this
+        -- bloats the the dep_finsts list, because we *already* had
+        -- those modules in the list (it wasn't a hole module, after
+        -- all). But there's a second, more important correctness
+        -- consideration: we perform module renaming when running
+        -- --abi-hash.  In this case, GHC's contract to the user is that
+        -- it will NOT go and read out interfaces of any dependencies
+        -- (https://github.com/haskell/cabal/issues/3633); the point of
+        -- --abi-hash is just to get a hash of the on-disk interfaces
+        -- for this *specific* package.  If we go off and tug on the
+        -- interface for /everything/ in dep_finsts, we're gonna have a
+        -- bad time.  (It's safe to do do this for hole modules, though,
+        -- because the hmap for --abi-hash is always trivial, so the
+        -- interface we request is local.  Though, maybe we ought
+        -- not to do it in this case either...)
+        --
+        -- This mistake was bug #15594.
+        let mod' = renameHoleModule dflags hmap mod
+        if isHoleModule mod
+          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
+                                  $ loadSysInterface (text "rnDepModule") mod'
+                  return (mod' : sel (mi_deps iface))
+          else return [mod']
+
+{-
+************************************************************************
+*                                                                      *
+                        ModIface substitution
+*                                                                      *
+************************************************************************
+-}
+
+-- | Run a computation in the 'ShIfM' monad.
+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
+            -> ShIfM a -> IO (Either ErrorMessages a)
+initRnIface hsc_env iface insts nsubst do_this = do
+    errs_var <- newIORef emptyBag
+    let dflags = hsc_dflags hsc_env
+        hsubst = listToUFM insts
+        rn_mod = renameHoleModule dflags hsubst
+        env = ShIfEnv {
+            sh_if_module = rn_mod (mi_module iface),
+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),
+            sh_if_hole_subst = listToUFM insts,
+            sh_if_shape = nsubst,
+            sh_if_errs = errs_var
+        }
+    -- Modeled off of 'initTc'
+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
+    msgs <- readIORef errs_var
+    case res of
+        Left _                          -> return (Left msgs)
+        Right r | not (isEmptyBag msgs) -> return (Left msgs)
+                | otherwise             -> return (Right r)
+
+-- | Environment for 'ShIfM' monads.
+data ShIfEnv = ShIfEnv {
+        -- What we are renaming the ModIface to.  It assumed that
+        -- the original mi_module of the ModIface is
+        -- @generalizeModule (mi_module iface)@.
+        sh_if_module :: Module,
+        -- The semantic module that we are renaming to
+        sh_if_semantic_module :: Module,
+        -- Cached hole substitution, e.g.
+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@
+        sh_if_hole_subst :: ShHoleSubst,
+        -- An optional name substitution to be applied when renaming
+        -- the names in the interface.  If this is 'Nothing', then
+        -- we just load the target interface and look at the export
+        -- list to determine the renaming.
+        sh_if_shape :: Maybe NameShape,
+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')
+        sh_if_errs :: IORef ErrorMessages
+    }
+
+getHoleSubst :: ShIfM ShHoleSubst
+getHoleSubst = fmap sh_if_hole_subst getGblEnv
+
+type ShIfM = TcRnIf ShIfEnv ()
+type Rename a = a -> ShIfM a
+
+
+rnModule :: Rename Module
+rnModule mod = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    return (renameHoleModule dflags hmap mod)
+
+rnAvailInfo :: Rename AvailInfo
+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n
+rnAvailInfo (AvailTC n ns fs) = do
+    -- Why don't we rnIfaceGlobal the availName itself?  It may not
+    -- actually be exported by the module it putatively is from, in
+    -- which case we won't be able to tell what the name actually
+    -- is.  But for the availNames they MUST be exported, so they
+    -- will rename fine.
+    ns' <- mapM rnIfaceGlobal ns
+    fs' <- mapM rnFieldLabel fs
+    case ns' ++ map flSelector fs' of
+        [] -> panic "rnAvailInfoEmpty AvailInfo"
+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+                         n' <- setNameModule (Just (nameModule rep)) n
+                         return (AvailTC n' ns' fs')
+
+rnFieldLabel :: Rename FieldLabel
+rnFieldLabel (FieldLabel l b sel) = do
+    sel' <- rnIfaceGlobal sel
+    return (FieldLabel l b sel')
+
+
+
+
+-- | The key function.  This gets called on every Name embedded
+-- inside a ModIface.  Our job is to take a Name from some
+-- generalized unit ID p[A=<A>, B=<B>], and change
+-- it to the correct name for a (partially) instantiated unit
+-- ID, e.g. p[A=q[]:A, B=<B>].
+--
+-- There are two important things to do:
+--
+-- If a hole is substituted with a real module implementation,
+-- we need to look at that actual implementation to determine what
+-- the true identity of this name should be.  We'll do this by
+-- loading that module's interface and looking at the mi_exports.
+--
+-- However, there is one special exception: when we are loading
+-- the interface of a requirement.  In this case, we may not have
+-- the "implementing" interface, because we are reading this
+-- interface precisely to "merge it in".
+--
+--     External case:
+--         p[A=<B>]:A (and thisUnitId is something else)
+--     We are loading this in order to determine B.hi!  So
+--     don't load B.hi to find the exports.
+--
+--     Local case:
+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])
+--     This should not happen, because the rename is not necessary
+--     in this case, but if it does we shouldn't load A.hi!
+--
+-- Compare me with 'tcIfaceGlobal'!
+
+-- In effect, this function needs compute the name substitution on the
+-- fly.  What it has is the name that we would like to substitute.
+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then
+-- no renaming can take place (although the inner hole structure must
+-- be updated to account for the hole module renaming.)
+rnIfaceGlobal :: Name -> ShIfM Name
+rnIfaceGlobal n = do
+    hsc_env <- getTopEnv
+    let dflags = hsc_dflags hsc_env
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    mb_nsubst <- fmap sh_if_shape getGblEnv
+    hmap <- getHoleSubst
+    let m = nameModule n
+        m' = renameHoleModule dflags hmap m
+    case () of
+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,
+       -- do NOT assume B.hi is available.
+       -- In this case, rename {A.T} to {B.T} but don't look up exports.
+     _ | m' == iface_semantic_mod
+       , isHoleModule m'
+      -- NB: this could be Nothing for computeExports, we have
+      -- nothing to say.
+      -> do n' <- setNameModule (Just m') n
+            case mb_nsubst of
+                Nothing -> return n'
+                Just nsubst ->
+                    case maybeSubstNameShape nsubst n' of
+                        -- TODO: would love to have context
+                        -- TODO: This will give an unpleasant message if n'
+                        -- is a constructor; then we'll suggest adding T
+                        -- but it won't work.
+                        Nothing -> failWithRn $ vcat [
+                            text "The identifier" <+> ppr (occName n') <+>
+                                text "does not exist in the local signature.",
+                            parens (text "Try adding it to the export list of the hsig file.")
+                            ]
+                        Just n'' -> return n''
+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
+       -- export list is irrelevant.
+       | not (isHoleModule m)
+      -> setNameModule (Just m') n
+       -- The substitution was from <A> to p[]:A.
+       -- But this does not mean {A.T} goes to p[]:A.T:
+       -- p[]:A may reexport T from somewhere else.  Do the name
+       -- substitution.  Furthermore, we need
+       -- to make sure we pick the accurate name NOW,
+       -- or we might accidentally reject a merge.
+       | otherwise
+      -> do -- Make sure we look up the local interface if substitution
+            -- went from <A> to <B>.
+            let m'' = if isHoleModule m'
+                        -- Pull out the local guy!!
+                        then mkModule (thisPackage dflags) (moduleName m')
+                        else m'
+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
+                            $ loadSysInterface (text "rnIfaceGlobal") m''
+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)
+            case maybeSubstNameShape nsubst n of
+                Nothing -> failWithRn $ vcat [
+                    text "The identifier" <+> ppr (occName n) <+>
+                        -- NB: report m' because it's more user-friendly
+                        text "does not exist in the signature for" <+> ppr m',
+                    parens (text "Try adding it to the export list in that hsig file.")
+                    ]
+                Just n' -> return n'
+
+-- | Rename an implicit name, e.g., a DFun or coercion axiom.
+-- Here is where we ensure that DFuns have the correct module as described in
+-- Note [rnIfaceNeverExported].
+rnIfaceNeverExported :: Name -> ShIfM Name
+rnIfaceNeverExported name = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    let m = renameHoleModule dflags hmap $ nameModule name
+    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+    setNameModule (Just m) name
+
+-- Note [rnIfaceNeverExported]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For the high-level overview, see
+-- Note [Handling never-exported TyThings under Backpack]
+--
+-- When we see a reference to an entity that was defined in a signature,
+-- 'rnIfaceGlobal' relies on the identifier in question being part of the
+-- exports of the implementing 'ModIface', so that we can use the exports to
+-- decide how to rename the identifier.  Unfortunately, references to 'DFun's
+-- and 'CoAxiom's will run into trouble under this strategy, because they are
+-- never exported.
+--
+-- Let us consider first what should happen in the absence of promotion.  In
+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside
+-- the signature *that is defining it* (as there are no Core terms in
+-- typechecked-only interface files, there's no way for a reference to occur
+-- besides from the defining 'ClsInst' or closed type family).  Thus,
+-- it doesn't really matter what names we give the DFun/CoAxiom, as long
+-- as it's consistent between the declaration site and the use site.
+--
+-- We have to make sure that these bogus names don't get propagated,
+-- but it is fine: see Note [Signature merging DFuns] for the fixups
+-- to the names we do before writing out the merged interface.
+-- (It's even easier for instantiation, since the DFuns all get
+-- dropped entirely; the instances are reexported implicitly.)
+--
+-- Unfortunately, this strategy is not enough in the presence of promotion
+-- (see bug #13149), where modules which import the signature may make
+-- reference to their coercions.  It's not altogether clear how to
+-- fix this case, but it is definitely a bug!
+
+-- PILES AND PILES OF BOILERPLATE
+
+-- | Rename an 'IfaceClsInst', with special handling for an associated
+-- dictionary function.
+rnIfaceClsInst :: Rename IfaceClsInst
+rnIfaceClsInst cls_inst = do
+    n <- rnIfaceGlobal (ifInstCls cls_inst)
+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
+
+    dfun <- rnIfaceNeverExported (ifDFun cls_inst)
+    return cls_inst { ifInstCls = n
+                    , ifInstTys = tys
+                    , ifDFun = dfun
+                    }
+
+rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
+rnMaybeIfaceTyCon Nothing = return Nothing
+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc
+
+rnIfaceFamInst :: Rename IfaceFamInst
+rnIfaceFamInst d = do
+    fam <- rnIfaceGlobal (ifFamInstFam d)
+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)
+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
+
+rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
+
+rnIfaceDecl :: Rename IfaceDecl
+rnIfaceDecl d@IfaceId{} = do
+            name <- case ifIdDetails d of
+                      IfDFunId -> rnIfaceNeverExported (ifName d)
+                      _ | isDefaultMethodOcc (occName (ifName d))
+                        -> rnIfaceNeverExported (ifName d)
+                      -- Typeable bindings. See Note [Grand plan for Typeable].
+                      _ | isTypeableBindOcc (occName (ifName d))
+                        -> rnIfaceNeverExported (ifName d)
+                        | otherwise -> rnIfaceGlobal (ifName d)
+            ty <- rnIfaceType (ifType d)
+            details <- rnIfaceIdDetails (ifIdDetails d)
+            info <- rnIfaceIdInfo (ifIdInfo d)
+            return d { ifName = name
+                     , ifType = ty
+                     , ifIdDetails = details
+                     , ifIdInfo = info
+                     }
+rnIfaceDecl d@IfaceData{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            ctxt <- mapM rnIfaceType (ifCtxt d)
+            cons <- rnIfaceConDecls (ifCons d)
+            res_kind <- rnIfaceType (ifResKind d)
+            parent <- rnIfaceTyConParent (ifParent d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifCtxt = ctxt
+                     , ifCons = cons
+                     , ifResKind = res_kind
+                     , ifParent = parent
+                     }
+rnIfaceDecl d@IfaceSynonym{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            syn_kind <- rnIfaceType (ifResKind d)
+            syn_rhs <- rnIfaceType (ifSynRhs d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifResKind = syn_kind
+                     , ifSynRhs = syn_rhs
+                     }
+rnIfaceDecl d@IfaceFamily{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            fam_kind <- rnIfaceType (ifResKind d)
+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifResKind = fam_kind
+                     , ifFamFlav = fam_flav
+                     }
+rnIfaceDecl d@IfaceClass{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            body <- rnIfaceClassBody (ifBody d)
+            return d { ifName    = name
+                     , ifBinders = binders
+                     , ifBody    = body
+                     }
+rnIfaceDecl d@IfaceAxiom{} = do
+            name <- rnIfaceNeverExported (ifName d)
+            tycon <- rnIfaceTyCon (ifTyCon d)
+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
+            return d { ifName = name
+                     , ifTyCon = tycon
+                     , ifAxBranches = ax_branches
+                     }
+rnIfaceDecl d@IfacePatSyn{} =  do
+            name <- rnIfaceGlobal (ifName d)
+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
+            pat_matcher <- rnPat (ifPatMatcher d)
+            pat_builder <- T.traverse rnPat (ifPatBuilder d)
+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
+            pat_args <- mapM rnIfaceType (ifPatArgs d)
+            pat_ty <- rnIfaceType (ifPatTy d)
+            return d { ifName = name
+                     , ifPatMatcher = pat_matcher
+                     , ifPatBuilder = pat_builder
+                     , ifPatUnivBndrs = pat_univ_bndrs
+                     , ifPatExBndrs = pat_ex_bndrs
+                     , ifPatProvCtxt = pat_prov_ctxt
+                     , ifPatReqCtxt = pat_req_ctxt
+                     , ifPatArgs = pat_args
+                     , ifPatTy = pat_ty
+                     }
+
+rnIfaceClassBody :: Rename IfaceClassBody
+rnIfaceClassBody IfAbstractClass = return IfAbstractClass
+rnIfaceClassBody d@IfConcreteClass{} = do
+    ctxt <- mapM rnIfaceType (ifClassCtxt d)
+    ats <- mapM rnIfaceAT (ifATs d)
+    sigs <- mapM rnIfaceClassOp (ifSigs d)
+    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
+
+rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
+                                                <*> mapM rnIfaceAxBranch axs)
+rnIfaceFamTyConFlav flav = pure flav
+
+rnIfaceAT :: Rename IfaceAT
+rnIfaceAT (IfaceAT decl mb_ty)
+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty
+
+rnIfaceTyConParent :: Rename IfaceTyConParent
+rnIfaceTyConParent (IfDataInstance n tc args)
+    = IfDataInstance <$> rnIfaceGlobal n
+                     <*> rnIfaceTyCon tc
+                     <*> rnIfaceAppArgs args
+rnIfaceTyConParent IfNoParent = pure IfNoParent
+
+rnIfaceConDecls :: Rename IfaceConDecls
+rnIfaceConDecls (IfDataTyCon ds)
+    = IfDataTyCon <$> mapM rnIfaceConDecl ds
+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
+rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon
+
+rnIfaceConDecl :: Rename IfaceConDecl
+rnIfaceConDecl d = do
+    con_name <- rnIfaceGlobal (ifConName d)
+    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)
+    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)
+    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
+    con_fields <- mapM rnFieldLabel (ifConFields d)
+    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
+        rnIfaceBang bang = pure bang
+    con_stricts <- mapM rnIfaceBang (ifConStricts d)
+    return d { ifConName = con_name
+             , ifConExTCvs = con_ex_tvs
+             , ifConUserTvBinders = con_user_tvbs
+             , ifConEqSpec = con_eq_spec
+             , ifConCtxt = con_ctxt
+             , ifConArgTys = con_arg_tys
+             , ifConFields = con_fields
+             , ifConStricts = con_stricts
+             }
+
+rnIfaceClassOp :: Rename IfaceClassOp
+rnIfaceClassOp (IfaceClassOp n ty dm) =
+    IfaceClassOp <$> rnIfaceGlobal n
+                 <*> rnIfaceType ty
+                 <*> rnMaybeDefMethSpec dm
+
+rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
+rnMaybeDefMethSpec mb = return mb
+
+rnIfaceAxBranch :: Rename IfaceAxBranch
+rnIfaceAxBranch d = do
+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
+    lhs <- rnIfaceAppArgs (ifaxbLHS d)
+    rhs <- rnIfaceType (ifaxbRHS d)
+    return d { ifaxbTyVars = ty_vars
+             , ifaxbLHS = lhs
+             , ifaxbRHS = rhs }
+
+rnIfaceIdInfo :: Rename IfaceIdInfo
+rnIfaceIdInfo NoInfo = pure NoInfo
+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is
+
+rnIfaceInfoItem :: Rename IfaceInfoItem
+rnIfaceInfoItem (HsUnfold lb if_unf)
+    = HsUnfold lb <$> rnIfaceUnfolding if_unf
+rnIfaceInfoItem i
+    = pure i
+
+rnIfaceUnfolding :: Rename IfaceUnfolding
+rnIfaceUnfolding (IfCoreUnfold stable if_expr)
+    = IfCoreUnfold stable <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfCompulsory if_expr)
+    = IfCompulsory <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)
+    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfDFunUnfold bs ops)
+    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
+
+rnIfaceExpr :: Rename IfaceExpr
+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)
+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl
+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty
+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co
+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args
+rnIfaceExpr (IfaceLam lam_bndr expr)
+    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
+rnIfaceExpr (IfaceApp fun arg)
+    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceCase scrut case_bndr alts)
+    = IfaceCase <$> rnIfaceExpr scrut
+                <*> pure case_bndr
+                <*> mapM rnIfaceAlt alts
+rnIfaceExpr (IfaceECase scrut ty)
+    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty
+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)
+               <*> rnIfaceExpr body
+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)
+    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->
+                                        (,) <$> rnIfaceLetBndr bndr
+                                            <*> rnIfaceExpr rhs) pairs)
+               <*> rnIfaceExpr body
+rnIfaceExpr (IfaceCast expr co)
+    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co
+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)
+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty
+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr
+
+rnIfaceBndrs :: Rename [IfaceBndr]
+rnIfaceBndrs = mapM rnIfaceBndr
+
+rnIfaceBndr :: Rename IfaceBndr
+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)
+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr
+
+rnIfaceTvBndr :: Rename IfaceTvBndr
+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
+
+rnIfaceTyConBinder :: Rename IfaceTyConBinder
+rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
+
+rnIfaceAlt :: Rename IfaceAlt
+rnIfaceAlt (conalt, names, rhs)
+     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs
+
+rnIfaceConAlt :: Rename IfaceConAlt
+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ
+rnIfaceConAlt alt = pure alt
+
+rnIfaceLetBndr :: Rename IfaceLetBndr
+rnIfaceLetBndr (IfLetBndr fs ty info jpi)
+    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi
+
+rnIfaceLamBndr :: Rename IfaceLamBndr
+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
+
+rnIfaceMCo :: Rename IfaceMCoercion
+rnIfaceMCo IfaceMRefl    = pure IfaceMRefl
+rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
+
+rnIfaceCo :: Rename IfaceCoercion
+rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
+rnIfaceCo (IfaceGReflCo role ty mco)
+  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
+rnIfaceCo (IfaceFunCo role co1 co2)
+    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceTyConAppCo role tc cos)
+    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
+rnIfaceCo (IfaceAppCo co1 co2)
+    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceForAllCo bndr co1 co2)
+    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl
+rnIfaceCo (IfaceAxiomInstCo n i cs)
+    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
+rnIfaceCo (IfaceUnivCo s r t1 t2)
+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceCo (IfaceSymCo c)
+    = IfaceSymCo <$> rnIfaceCo c
+rnIfaceCo (IfaceTransCo c1 c2)
+    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceInstCo c1 c2)
+    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c
+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c
+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
+rnIfaceCo (IfaceAxiomRuleCo ax cos)
+    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
+
+rnIfaceTyCon :: Rename IfaceTyCon
+rnIfaceTyCon (IfaceTyCon n info)
+    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info
+
+rnIfaceExprs :: Rename [IfaceExpr]
+rnIfaceExprs = mapM rnIfaceExpr
+
+rnIfaceIdDetails :: Rename IfaceIdDetails
+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b
+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b
+rnIfaceIdDetails details = pure details
+
+rnIfaceType :: Rename IfaceType
+rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
+rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)
+rnIfaceType (IfaceAppTy t1 t2)
+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
+rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)
+rnIfaceType (IfaceFunTy af t1 t2)
+    = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceTupleTy s i tks)
+    = IfaceTupleTy s i <$> rnIfaceAppArgs tks
+rnIfaceType (IfaceTyConApp tc tks)
+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
+rnIfaceType (IfaceForAllTy tv t)
+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
+rnIfaceType (IfaceCoercionTy co)
+    = IfaceCoercionTy <$> rnIfaceCo co
+rnIfaceType (IfaceCastTy ty co)
+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
+
+rnIfaceForAllBndr :: Rename IfaceForAllBndr
+rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
+
+rnIfaceAppArgs :: Rename IfaceAppArgs
+rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a
+                                        <*> rnIfaceAppArgs ts
+rnIfaceAppArgs IA_Nil = pure IA_Nil
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Bitmap.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE BangPatterns #-}
+
+--
+-- (c) The University of Glasgow 2003-2006
+--
+
+-- Functions for constructing bitmaps, which are used in various
+-- places in generated code (stack frame liveness masks, function
+-- argument liveness masks, SRT bitmaps).
+
+module Bitmap (
+        Bitmap, mkBitmap,
+        intsToBitmap, intsToReverseBitmap,
+        mAX_SMALL_BITMAP_SIZE,
+        seqBitmap,
+  ) where
+
+import GhcPrelude
+
+import SMRep
+import DynFlags
+import Util
+
+import Data.Bits
+
+{-|
+A bitmap represented by a sequence of 'StgWord's on the /target/
+architecture.  These are used for bitmaps in info tables and other
+generated code which need to be emitted as sequences of StgWords.
+-}
+type Bitmap = [StgWord]
+
+-- | Make a bitmap from a sequence of bits
+mkBitmap :: DynFlags -> [Bool] -> Bitmap
+mkBitmap _ [] = []
+mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest
+  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
+
+chunkToBitmap :: DynFlags -> [Bool] -> StgWord
+chunkToBitmap dflags chunk =
+  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]
+  where
+    oneAt :: Int -> StgWord
+    oneAt i = toStgWord dflags 1 `shiftL` i
+
+-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.
+-- eg. @[0,1,3], size 4 ==> 0xb@.
+--
+-- The list of @Int@s /must/ be already sorted.
+intsToBitmap :: DynFlags
+             -> Int        -- ^ size in bits
+             -> [Int]      -- ^ sorted indices of ones
+             -> Bitmap
+intsToBitmap dflags size = go 0
+  where
+    word_sz = wORD_SIZE_IN_BITS dflags
+    oneAt :: Int -> StgWord
+    oneAt i = toStgWord dflags 1 `shiftL` i
+
+    -- It is important that we maintain strictness here.
+    -- See Note [Strictness when building Bitmaps].
+    go :: Int -> [Int] -> Bitmap
+    go !pos slots
+      | size <= pos = []
+      | otherwise =
+        (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) :
+          go (pos + word_sz) rest
+      where
+        (these,rest) = span (< (pos + word_sz)) slots
+
+-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
+-- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,
+-- just to make the bitmap easier to read).
+--
+-- The list of @Int@s /must/ be already sorted and duplicate-free.
+intsToReverseBitmap :: DynFlags
+                    -> Int      -- ^ size in bits
+                    -> [Int]    -- ^ sorted indices of zeros free of duplicates
+                    -> Bitmap
+intsToReverseBitmap dflags size = go 0
+  where
+    word_sz = wORD_SIZE_IN_BITS dflags
+    oneAt :: Int -> StgWord
+    oneAt i = toStgWord dflags 1 `shiftL` i
+
+    -- It is important that we maintain strictness here.
+    -- See Note [Strictness when building Bitmaps].
+    go :: Int -> [Int] -> Bitmap
+    go !pos slots
+      | size <= pos = []
+      | otherwise =
+        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :
+          go (pos + word_sz) rest
+      where
+        (these,rest) = span (< (pos + word_sz)) slots
+        remain = size - pos
+        init
+          | remain >= word_sz = -1
+          | otherwise         = (1 `shiftL` remain) - 1
+
+{-
+
+Note [Strictness when building Bitmaps]
+========================================
+
+One of the places where @Bitmap@ is used is in in building Static Reference
+Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed
+that some test cases (particularly those whose C-- have large numbers of CAFs)
+produced large quantities of allocations from this function.
+
+The source traced back to 'intsToBitmap', which was lazily subtracting the word
+size from the elements of the tail of the @slots@ list and recursively invoking
+itself with the result. This resulted in large numbers of subtraction thunks
+being built up. Here we take care to avoid passing new thunks to the recursive
+call. Instead we pass the unmodified tail along with an explicit position
+accumulator, which get subtracted in the fold when we compute the Word.
+
+-}
+
+{- |
+Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
+Some kinds of bitmap pack a size\/bitmap into a single word if
+possible, or fall back to an external pointer when the bitmap is too
+large.  This value represents the largest size of bitmap that can be
+packed into a single word.
+-}
+mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int
+mAX_SMALL_BITMAP_SIZE dflags
+ | wORD_SIZE dflags == 4 = 27
+ | otherwise             = 58
+
+seqBitmap :: Bitmap -> a -> a
+seqBitmap = seqList
+
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/BlockId.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- BlockId module should probably go away completely, being superseded by Label -}
+module BlockId
+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+  , newBlockId
+  , blockLbl, infoTblLbl
+  ) where
+
+import GhcPrelude
+
+import CLabel
+import IdInfo
+import Name
+import Unique
+import UniqSupply
+
+import Hoopl.Label (Label, mkHooplLabel)
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit.  The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the entire
+compilation unit in which it appears.
+-}
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
+mkBlockId unique = mkHooplLabel $ getKey unique
+
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
+blockLbl :: BlockId -> CLabel
+blockLbl label = mkLocalBlockLabel (getUnique label)
+
+infoTblLbl :: BlockId -> CLabel
+infoTblLbl label
+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
diff --git a/compiler/cmm/BlockId.hs-boot b/compiler/cmm/BlockId.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/BlockId.hs-boot
@@ -0,0 +1,8 @@
+module BlockId (BlockId, mkBlockId) where
+
+import Hoopl.Label (Label)
+import Unique (Unique)
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CLabel.hs
@@ -0,0 +1,1567 @@
+-----------------------------------------------------------------------------
+--
+-- Object-file symbols (called CLabel for histerical raisins).
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+module CLabel (
+        CLabel, -- abstract type
+        ForeignLabelSource(..),
+        pprDebugCLabel,
+
+        mkClosureLabel,
+        mkSRTLabel,
+        mkInfoTableLabel,
+        mkEntryLabel,
+        mkRednCountsLabel,
+        mkConInfoTableLabel,
+        mkApEntryLabel,
+        mkApInfoTableLabel,
+        mkClosureTableLabel,
+        mkBytesLabel,
+
+        mkLocalBlockLabel,
+        mkLocalClosureLabel,
+        mkLocalInfoTableLabel,
+        mkLocalClosureTableLabel,
+
+        mkBlockInfoTableLabel,
+
+        mkBitmapLabel,
+        mkStringLitLabel,
+
+        mkAsmTempLabel,
+        mkAsmTempDerivedLabel,
+        mkAsmTempEndLabel,
+        mkAsmTempDieLabel,
+
+        mkDirty_MUT_VAR_Label,
+        mkUpdInfoLabel,
+        mkBHUpdInfoLabel,
+        mkIndStaticInfoLabel,
+        mkMainCapabilityLabel,
+        mkMAP_FROZEN_CLEAN_infoLabel,
+        mkMAP_FROZEN_DIRTY_infoLabel,
+        mkMAP_DIRTY_infoLabel,
+        mkSMAP_FROZEN_CLEAN_infoLabel,
+        mkSMAP_FROZEN_DIRTY_infoLabel,
+        mkSMAP_DIRTY_infoLabel,
+        mkBadAlignmentLabel,
+        mkArrWords_infoLabel,
+        mkSRTInfoLabel,
+
+        mkTopTickyCtrLabel,
+        mkCAFBlackHoleInfoTableLabel,
+        mkRtsPrimOpLabel,
+        mkRtsSlowFastTickyCtrLabel,
+
+        mkSelectorInfoLabel,
+        mkSelectorEntryLabel,
+
+        mkCmmInfoLabel,
+        mkCmmEntryLabel,
+        mkCmmRetInfoLabel,
+        mkCmmRetLabel,
+        mkCmmCodeLabel,
+        mkCmmDataLabel,
+        mkCmmClosureLabel,
+
+        mkRtsApFastLabel,
+
+        mkPrimCallLabel,
+
+        mkForeignLabel,
+        addLabelSize,
+
+        foreignLabelStdcallInfo,
+        isBytesLabel,
+        isForeignLabel,
+        isSomeRODataLabel,
+        isStaticClosureLabel,
+        mkCCLabel, mkCCSLabel,
+
+        DynamicLinkerLabelInfo(..),
+        mkDynamicLinkerLabel,
+        dynamicLinkerLabelInfo,
+
+        mkPicBaseLabel,
+        mkDeadStripPreventer,
+
+        mkHpcTicksLabel,
+
+        -- * Predicates
+        hasCAF,
+        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
+        isMathFun,
+        isCFunctionLabel, isGcPtrLabel, labelDynamic,
+        isLocalCLabel, mayRedirectTo,
+
+        -- * Conversions
+        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
+
+        pprCLabel,
+        isInfoTableLabel,
+        isConInfoTableLabel
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import IdInfo
+import BasicTypes
+import {-# SOURCE #-} BlockId (BlockId, mkBlockId)
+import Packages
+import Module
+import Name
+import Unique
+import PrimOp
+import CostCentre
+import Outputable
+import FastString
+import DynFlags
+import Platform
+import UniqSet
+import Util
+import PprCore ( {- instances -} )
+
+-- -----------------------------------------------------------------------------
+-- The CLabel type
+
+{- |
+  'CLabel' is an abstract type that supports the following operations:
+
+  - Pretty printing
+
+  - In a C file, does it need to be declared before use?  (i.e. is it
+    guaranteed to be already in scope in the places we need to refer to it?)
+
+  - If it needs to be declared, what type (code or data) should it be
+    declared to have?
+
+  - Is it visible outside this object file or not?
+
+  - Is it "dynamic" (see details below)
+
+  - Eq and Ord, so that we can make sets of CLabels (currently only
+    used in outputting C as far as I can tell, to avoid generating
+    more than one declaration for any given label).
+
+  - Converting an info table label into an entry label.
+
+  CLabel usage is a bit messy in GHC as they are used in a number of different
+  contexts:
+
+  - By the C-- AST to identify labels
+
+  - By the unregisterised C code generator ("PprC") for naming functions (hence
+    the name 'CLabel')
+
+  - By the native and LLVM code generators to identify labels
+
+  For extra fun, each of these uses a slightly different subset of constructors
+  (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and
+  LLVM backends).
+
+  In general, we use 'IdLabel' to represent Haskell things early in the
+  pipeline. However, later optimization passes will often represent blocks they
+  create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the
+  label.
+-}
+
+data CLabel
+  = -- | A label related to the definition of a particular Id or Con in a .hs file.
+    IdLabel
+        Name
+        CafInfo
+        IdLabelInfo             -- encodes the suffix of the label
+
+  -- | A label from a .cmm file that is not associated with a .hs level Id.
+  | CmmLabel
+        UnitId               -- what package the label belongs to.
+        FastString              -- identifier giving the prefix of the label
+        CmmLabelInfo            -- encodes the suffix of the label
+
+  -- | A label with a baked-in \/ algorithmically generated name that definitely
+  --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so
+  --    If it doesn't have an algorithmically generated name then use a CmmLabel
+  --    instead and give it an appropriate UnitId argument.
+  | RtsLabel
+        RtsLabelInfo
+
+  -- | A label associated with a block. These aren't visible outside of the
+  -- compilation unit in which they are defined. These are generally used to
+  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,
+  -- where we don't have a 'Name' to associate the label to and therefore can't
+  -- use 'IdLabel'.
+  | LocalBlockLabel
+        {-# UNPACK #-} !Unique
+
+  -- | A 'C' (or otherwise foreign) label.
+  --
+  | ForeignLabel
+        FastString              -- name of the imported label.
+
+        (Maybe Int)             -- possible '@n' suffix for stdcall functions
+                                -- When generating C, the '@n' suffix is omitted, but when
+                                -- generating assembler we must add it to the label.
+
+        ForeignLabelSource      -- what package the foreign label is in.
+
+        FunctionOrData
+
+  -- | Local temporary label used for native (or LLVM) code generation; must not
+  -- appear outside of these contexts. Use primarily for debug information
+  | AsmTempLabel
+        {-# UNPACK #-} !Unique
+
+  -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.
+  -- Must not occur outside of the NCG or LLVM code generators.
+  | AsmTempDerivedLabel
+        CLabel
+        FastString              -- suffix
+
+  | StringLitLabel
+        {-# UNPACK #-} !Unique
+
+  | CC_Label  CostCentre
+  | CCS_Label CostCentreStack
+
+
+  -- | These labels are generated and used inside the NCG only.
+  --    They are special variants of a label used for dynamic linking
+  --    see module PositionIndependentCode for details.
+  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
+
+  -- | This label is generated and used inside the NCG only.
+  --    It is used as a base for PIC calculations on some platforms.
+  --    It takes the form of a local numeric assembler label '1'; and
+  --    is pretty-printed as 1b, referring to the previous definition
+  --    of 1: in the assembler source file.
+  | PicBaseLabel
+
+  -- | A label before an info table to prevent excessive dead-stripping on darwin
+  | DeadStripPreventer CLabel
+
+
+  -- | Per-module table of tick locations
+  | HpcTicksLabel Module
+
+  -- | Static reference table
+  | SRTLabel
+        {-# UNPACK #-} !Unique
+
+  -- | A bitmap (function or case return)
+  | LargeBitmapLabel
+        {-# UNPACK #-} !Unique
+
+  deriving Eq
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord CLabel where
+  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2
+  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2
+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
+  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2 `thenCmp`
+    compare d1 d2
+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2
+  compare (StringLitLabel u1) (StringLitLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (CC_Label a1) (CC_Label a2) =
+    compare a1 a2
+  compare (CCS_Label a1) (CCS_Label a2) =
+    compare a1 a2
+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2
+  compare PicBaseLabel PicBaseLabel = EQ
+  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =
+    compare a1 a2
+  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =
+    compare a1 a2
+  compare (SRTLabel u1) (SRTLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare IdLabel{} _ = LT
+  compare _ IdLabel{} = GT
+  compare CmmLabel{} _ = LT
+  compare _ CmmLabel{} = GT
+  compare RtsLabel{} _ = LT
+  compare _ RtsLabel{} = GT
+  compare LocalBlockLabel{} _ = LT
+  compare _ LocalBlockLabel{} = GT
+  compare ForeignLabel{} _ = LT
+  compare _ ForeignLabel{} = GT
+  compare AsmTempLabel{} _ = LT
+  compare _ AsmTempLabel{} = GT
+  compare AsmTempDerivedLabel{} _ = LT
+  compare _ AsmTempDerivedLabel{} = GT
+  compare StringLitLabel{} _ = LT
+  compare _ StringLitLabel{} = GT
+  compare CC_Label{} _ = LT
+  compare _ CC_Label{} = GT
+  compare CCS_Label{} _ = LT
+  compare _ CCS_Label{} = GT
+  compare DynamicLinkerLabel{} _ = LT
+  compare _ DynamicLinkerLabel{} = GT
+  compare PicBaseLabel{} _ = LT
+  compare _ PicBaseLabel{} = GT
+  compare DeadStripPreventer{} _ = LT
+  compare _ DeadStripPreventer{} = GT
+  compare HpcTicksLabel{} _ = LT
+  compare _ HpcTicksLabel{} = GT
+  compare SRTLabel{} _ = LT
+  compare _ SRTLabel{} = GT
+
+-- | Record where a foreign label is stored.
+data ForeignLabelSource
+
+   -- | Label is in a named package
+   = ForeignLabelInPackage      UnitId
+
+   -- | Label is in some external, system package that doesn't also
+   --   contain compiled Haskell code, and is not associated with any .hi files.
+   --   We don't have to worry about Haskell code being inlined from
+   --   external packages. It is safe to treat the RTS package as "external".
+   | ForeignLabelInExternalPackage
+
+   -- | Label is in the package currenly being compiled.
+   --   This is only used for creating hacky tmp labels during code generation.
+   --   Don't use it in any code that might be inlined across a package boundary
+   --   (ie, core code) else the information will be wrong relative to the
+   --   destination module.
+   | ForeignLabelInThisPackage
+
+   deriving (Eq, Ord)
+
+
+-- | For debugging problems with the CLabel representation.
+--      We can't make a Show instance for CLabel because lots of its components don't have instances.
+--      The regular Outputable instance only shows the label name, and not its other info.
+--
+pprDebugCLabel :: CLabel -> SDoc
+pprDebugCLabel lbl
+ = case lbl of
+        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"
+                                       <> whenPprDebug (text ":" <> text (show info)))
+        CmmLabel pkg _name _info
+         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+
+        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")
+
+        ForeignLabel _name mSuffix src funOrData
+            -> ppr lbl <> (parens $ text "ForeignLabel"
+                                <+> ppr mSuffix
+                                <+> ppr src
+                                <+> ppr funOrData)
+
+        _               -> ppr lbl <> (parens $ text "other CLabel")
+
+
+data IdLabelInfo
+  = Closure             -- ^ Label for closure
+  | InfoTable           -- ^ Info tables for closures; always read-only
+  | Entry               -- ^ Entry point
+  | Slow                -- ^ Slow entry point
+
+  | LocalInfoTable      -- ^ Like InfoTable but not externally visible
+  | LocalEntry          -- ^ Like Entry but not externally visible
+
+  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id
+
+  | ConEntry            -- ^ Constructor entry point
+  | ConInfoTable        -- ^ Corresponding info table
+
+  | ClosureTable        -- ^ Table of closures for Enum tycons
+
+  | Bytes               -- ^ Content of a string literal. See
+                        -- Note [Bytes label].
+  | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block
+                        -- instead of a closure entry-point.
+                        -- See Note [Proc-point local block entry-point].
+
+  deriving (Eq, Ord, Show)
+
+
+data RtsLabelInfo
+  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks
+  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}
+
+  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks
+  | RtsApEntry           Bool{-updatable-} Int{-arity-}
+
+  | RtsPrimOp PrimOp
+  | RtsApFast     FastString    -- ^ _fast versions of generic apply
+  | RtsSlowFastTickyCtr String
+
+  deriving (Eq, Ord)
+  -- NOTE: Eq on PtrString compares the pointer only, so this isn't
+  -- a real equality.
+
+
+-- | What type of Cmm label we're dealing with.
+--      Determines the suffix appended to the name when a CLabel.CmmLabel
+--      is pretty printed.
+data CmmLabelInfo
+  = CmmInfo                     -- ^ misc rts info tables,      suffix _info
+  | CmmEntry                    -- ^ misc rts entry points,     suffix _entry
+  | CmmRetInfo                  -- ^ misc rts ret info tables,  suffix _info
+  | CmmRet                      -- ^ misc rts return points,    suffix _ret
+  | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure
+  | CmmCode                     -- ^ misc rts code
+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure
+  | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code
+  deriving (Eq, Ord)
+
+data DynamicLinkerLabelInfo
+  = CodeStub                    -- MachO: Lfoo$stub, ELF: foo@plt
+  | SymbolPtr                   -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+  | GotSymbolPtr                -- ELF: foo@got
+  | GotSymbolOffset             -- ELF: foo@gotoff
+
+  deriving (Eq, Ord)
+
+
+-- -----------------------------------------------------------------------------
+-- Constructing CLabels
+-- -----------------------------------------------------------------------------
+
+-- Constructing IdLabels
+-- These are always local:
+
+mkSRTLabel     :: Unique -> CLabel
+mkSRTLabel u = SRTLabel u
+
+mkRednCountsLabel :: Name -> CLabel
+mkRednCountsLabel       name    =
+  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]
+
+-- These have local & (possibly) external variants:
+mkLocalClosureLabel      :: Name -> CafInfo -> CLabel
+mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel
+mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel
+mkLocalClosureLabel     name c  = IdLabel name  c Closure
+mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable
+mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable
+
+mkClosureLabel              :: Name -> CafInfo -> CLabel
+mkInfoTableLabel            :: Name -> CafInfo -> CLabel
+mkEntryLabel                :: Name -> CafInfo -> CLabel
+mkClosureTableLabel         :: Name -> CafInfo -> CLabel
+mkConInfoTableLabel         :: Name -> CafInfo -> CLabel
+mkBytesLabel                :: Name -> CLabel
+mkClosureLabel name         c     = IdLabel name c Closure
+mkInfoTableLabel name       c     = IdLabel name c InfoTable
+mkEntryLabel name           c     = IdLabel name c Entry
+mkClosureTableLabel name    c     = IdLabel name c ClosureTable
+mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable
+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes
+
+mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel
+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
+                               -- See Note [Proc-point local block entry-point].
+
+-- Constructing Cmm Labels
+mkDirty_MUT_VAR_Label, mkUpdInfoLabel,
+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
+    mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
+    mkMAP_DIRTY_infoLabel,
+    mkArrWords_infoLabel,
+    mkTopTickyCtrLabel,
+    mkCAFBlackHoleInfoTableLabel,
+    mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
+    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
+mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
+mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData
+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData
+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo
+mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo
+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry
+
+mkSRTInfoLabel :: Int -> CLabel
+mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
+ where
+   lbl =
+     case n of
+       1 -> fsLit "stg_SRT_1"
+       2 -> fsLit "stg_SRT_2"
+       3 -> fsLit "stg_SRT_3"
+       4 -> fsLit "stg_SRT_4"
+       5 -> fsLit "stg_SRT_5"
+       6 -> fsLit "stg_SRT_6"
+       7 -> fsLit "stg_SRT_7"
+       8 -> fsLit "stg_SRT_8"
+       9 -> fsLit "stg_SRT_9"
+       10 -> fsLit "stg_SRT_10"
+       11 -> fsLit "stg_SRT_11"
+       12 -> fsLit "stg_SRT_12"
+       13 -> fsLit "stg_SRT_13"
+       14 -> fsLit "stg_SRT_14"
+       15 -> fsLit "stg_SRT_15"
+       16 -> fsLit "stg_SRT_16"
+       _ -> panic "mkSRTInfoLabel"
+
+-----
+mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
+        :: UnitId -> FastString -> CLabel
+
+mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo
+mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry
+mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo
+mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet
+mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
+mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
+
+mkLocalBlockLabel :: Unique -> CLabel
+mkLocalBlockLabel u = LocalBlockLabel u
+
+-- Constructing RtsLabels
+mkRtsPrimOpLabel :: PrimOp -> CLabel
+mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
+
+mkSelectorInfoLabel  :: Bool -> Int -> CLabel
+mkSelectorEntryLabel :: Bool -> Int -> CLabel
+mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)
+mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)
+
+mkApInfoTableLabel :: Bool -> Int -> CLabel
+mkApEntryLabel     :: Bool -> Int -> CLabel
+mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)
+mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)
+
+
+-- A call to some primitive hand written Cmm code
+mkPrimCallLabel :: PrimCall -> CLabel
+mkPrimCallLabel (PrimCall str pkg)
+        = CmmLabel pkg str CmmPrimCall
+
+
+-- Constructing ForeignLabels
+
+-- | Make a foreign label
+mkForeignLabel
+        :: FastString           -- name
+        -> Maybe Int            -- size prefix
+        -> ForeignLabelSource   -- what package it's in
+        -> FunctionOrData
+        -> CLabel
+
+mkForeignLabel str mb_sz src fod
+    = ForeignLabel str mb_sz src  fod
+
+
+-- | Update the label size field in a ForeignLabel
+addLabelSize :: CLabel -> Int -> CLabel
+addLabelSize (ForeignLabel str _ src  fod) sz
+    = ForeignLabel str (Just sz) src fod
+addLabelSize label _
+    = label
+
+-- | Whether label is a top-level string literal
+isBytesLabel :: CLabel -> Bool
+isBytesLabel (IdLabel _ _ Bytes) = True
+isBytesLabel _lbl = False
+
+-- | Whether label is a non-haskell label (defined in C code)
+isForeignLabel :: CLabel -> Bool
+isForeignLabel (ForeignLabel _ _ _ _) = True
+isForeignLabel _lbl = False
+
+-- | Whether label is a static closure label (can come from haskell or cmm)
+isStaticClosureLabel :: CLabel -> Bool
+-- Closure defined in haskell (.hs)
+isStaticClosureLabel (IdLabel _ _ Closure) = True
+-- Closure defined in cmm
+isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True
+isStaticClosureLabel _lbl = False
+
+-- | Whether label is a .rodata label
+isSomeRODataLabel :: CLabel -> Bool
+-- info table defined in haskell (.hs)
+isSomeRODataLabel (IdLabel _ _ ClosureTable) = True
+isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ InfoTable) = True
+isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
+-- info table defined in cmm (.cmm)
+isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
+isSomeRODataLabel _lbl = False
+
+-- | Whether label is points to some kind of info table
+isInfoTableLabel :: CLabel -> Bool
+isInfoTableLabel (IdLabel _ _ InfoTable)      = True
+isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True
+isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True
+isInfoTableLabel _                            = False
+
+-- | Whether label is points to constructor info table
+isConInfoTableLabel :: CLabel -> Bool
+isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isConInfoTableLabel _                            = False
+
+-- | Get the label size field from a ForeignLabel
+foreignLabelStdcallInfo :: CLabel -> Maybe Int
+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
+foreignLabelStdcallInfo _lbl = Nothing
+
+
+-- Constructing Large*Labels
+mkBitmapLabel   :: Unique -> CLabel
+mkBitmapLabel   uniq            = LargeBitmapLabel uniq
+
+-- Constructing Cost Center Labels
+mkCCLabel  :: CostCentre      -> CLabel
+mkCCSLabel :: CostCentreStack -> CLabel
+mkCCLabel           cc          = CC_Label cc
+mkCCSLabel          ccs         = CCS_Label ccs
+
+mkRtsApFastLabel :: FastString -> CLabel
+mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+
+mkRtsSlowFastTickyCtrLabel :: String -> CLabel
+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)
+
+
+-- Constructing Code Coverage Labels
+mkHpcTicksLabel :: Module -> CLabel
+mkHpcTicksLabel                = HpcTicksLabel
+
+
+-- Constructing labels used for dynamic linking
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel            = DynamicLinkerLabel
+
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _        = Nothing
+
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel                  = PicBaseLabel
+
+
+-- Constructing miscellaneous other labels
+mkDeadStripPreventer :: CLabel -> CLabel
+mkDeadStripPreventer lbl        = DeadStripPreventer lbl
+
+mkStringLitLabel :: Unique -> CLabel
+mkStringLitLabel                = StringLitLabel
+
+mkAsmTempLabel :: Uniquable a => a -> CLabel
+mkAsmTempLabel a                = AsmTempLabel (getUnique a)
+
+mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel
+mkAsmTempDerivedLabel = AsmTempDerivedLabel
+
+mkAsmTempEndLabel :: CLabel -> CLabel
+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")
+
+-- | Construct a label for a DWARF Debug Information Entity (DIE)
+-- describing another symbol.
+mkAsmTempDieLabel :: CLabel -> CLabel
+mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
+
+-- -----------------------------------------------------------------------------
+-- Convert between different kinds of label
+
+toClosureLbl :: CLabel -> CLabel
+toClosureLbl (IdLabel n c _) = IdLabel n c Closure
+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
+toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
+
+toSlowEntryLbl :: CLabel -> CLabel
+toSlowEntryLbl (IdLabel n _ BlockInfoTable)
+  = pprPanic "toSlowEntryLbl" (ppr n)
+toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow
+toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)
+
+toEntryLbl :: CLabel -> CLabel
+toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry
+toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry
+toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)
+                              -- See Note [Proc-point local block entry-point].
+toEntryLbl (IdLabel n c _)               = IdLabel n c Entry
+toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry
+toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet
+toEntryLbl l = pprPanic "toEntryLbl" (ppr l)
+
+toInfoLbl :: CLabel -> CLabel
+toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable
+toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable
+toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable
+toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo
+toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo
+toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)
+
+hasHaskellName :: CLabel -> Maybe Name
+hasHaskellName (IdLabel n _ _) = Just n
+hasHaskellName _               = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel's referent itself refer to a CAF?
+hasCAF :: CLabel -> Bool
+hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]
+hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF _                            = False
+
+-- Note [ticky for LNE]
+-- ~~~~~~~~~~~~~~~~~~~~~
+
+-- Until 14 Feb 2013, every ticky counter was associated with a
+-- closure. Thus, ticky labels used IdLabel. It is odd that
+-- CmmBuildInfoTables.cafTransfers would consider such a ticky label
+-- reason to add the name to the CAFEnv (and thus eventually the SRT),
+-- but it was harmless because the ticky was only used if the closure
+-- was also.
+--
+-- Since we now have ticky counters for LNEs, it is no longer the case
+-- that every ticky counter has an actual closure. So I changed the
+-- generation of ticky counters' CLabels to not result in their
+-- associated id ending up in the SRT.
+--
+-- NB IdLabel is still appropriate for ticky ids (as opposed to
+-- CmmLabel) because the LNE's counter is still related to an .hs Id,
+-- that Id just isn't for a proper closure.
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need declaring before use or not?
+--
+-- See wiki:commentary/compiler/backends/ppr-c#prototypes
+
+needsCDecl :: CLabel -> Bool
+  -- False <=> it's pre-declared; don't bother
+  -- don't bother declaring Bitmap labels, we always make sure
+  -- they are defined before use.
+needsCDecl (SRTLabel _)                 = True
+needsCDecl (LargeBitmapLabel _)         = False
+needsCDecl (IdLabel _ _ _)              = True
+needsCDecl (LocalBlockLabel _)          = True
+
+needsCDecl (StringLitLabel _)           = False
+needsCDecl (AsmTempLabel _)             = False
+needsCDecl (AsmTempDerivedLabel _ _)    = False
+needsCDecl (RtsLabel _)                 = False
+
+needsCDecl (CmmLabel pkgId _ _)
+        -- Prototypes for labels defined in the runtime system are imported
+        --      into HC files via includes/Stg.h.
+        | pkgId == rtsUnitId         = False
+
+        -- For other labels we inline one into the HC file directly.
+        | otherwise                     = True
+
+needsCDecl l@(ForeignLabel{})           = not (isMathFun l)
+needsCDecl (CC_Label _)                 = True
+needsCDecl (CCS_Label _)                = True
+needsCDecl (HpcTicksLabel _)            = True
+needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
+needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
+needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"
+
+-- | If a label is a local block label then return just its 'BlockId', otherwise
+-- 'Nothing'.
+maybeLocalBlockLabel :: CLabel -> Maybe BlockId
+maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq
+maybeLocalBlockLabel _                     = Nothing
+
+
+-- | Check whether a label corresponds to a C function that has
+--      a prototype in a system header somehere, or is built-in
+--      to the C compiler. For these labels we avoid generating our
+--      own C prototypes.
+isMathFun :: CLabel -> Bool
+isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs
+isMathFun _ = False
+
+math_funs :: UniqSet FastString
+math_funs = mkUniqSet [
+        -- _ISOC99_SOURCE
+        (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),
+        (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),
+        (fsLit "asin"),         (fsLit "asinf"),        (fsLit "asinl"),
+        (fsLit "asinh"),        (fsLit "asinhf"),       (fsLit "asinhl"),
+        (fsLit "atan"),         (fsLit "atanf"),        (fsLit "atanl"),
+        (fsLit "atan2"),        (fsLit "atan2f"),       (fsLit "atan2l"),
+        (fsLit "atanh"),        (fsLit "atanhf"),       (fsLit "atanhl"),
+        (fsLit "cbrt"),         (fsLit "cbrtf"),        (fsLit "cbrtl"),
+        (fsLit "ceil"),         (fsLit "ceilf"),        (fsLit "ceill"),
+        (fsLit "copysign"),     (fsLit "copysignf"),    (fsLit "copysignl"),
+        (fsLit "cos"),          (fsLit "cosf"),         (fsLit "cosl"),
+        (fsLit "cosh"),         (fsLit "coshf"),        (fsLit "coshl"),
+        (fsLit "erf"),          (fsLit "erff"),         (fsLit "erfl"),
+        (fsLit "erfc"),         (fsLit "erfcf"),        (fsLit "erfcl"),
+        (fsLit "exp"),          (fsLit "expf"),         (fsLit "expl"),
+        (fsLit "exp2"),         (fsLit "exp2f"),        (fsLit "exp2l"),
+        (fsLit "expm1"),        (fsLit "expm1f"),       (fsLit "expm1l"),
+        (fsLit "fabs"),         (fsLit "fabsf"),        (fsLit "fabsl"),
+        (fsLit "fdim"),         (fsLit "fdimf"),        (fsLit "fdiml"),
+        (fsLit "floor"),        (fsLit "floorf"),       (fsLit "floorl"),
+        (fsLit "fma"),          (fsLit "fmaf"),         (fsLit "fmal"),
+        (fsLit "fmax"),         (fsLit "fmaxf"),        (fsLit "fmaxl"),
+        (fsLit "fmin"),         (fsLit "fminf"),        (fsLit "fminl"),
+        (fsLit "fmod"),         (fsLit "fmodf"),        (fsLit "fmodl"),
+        (fsLit "frexp"),        (fsLit "frexpf"),       (fsLit "frexpl"),
+        (fsLit "hypot"),        (fsLit "hypotf"),       (fsLit "hypotl"),
+        (fsLit "ilogb"),        (fsLit "ilogbf"),       (fsLit "ilogbl"),
+        (fsLit "ldexp"),        (fsLit "ldexpf"),       (fsLit "ldexpl"),
+        (fsLit "lgamma"),       (fsLit "lgammaf"),      (fsLit "lgammal"),
+        (fsLit "llrint"),       (fsLit "llrintf"),      (fsLit "llrintl"),
+        (fsLit "llround"),      (fsLit "llroundf"),     (fsLit "llroundl"),
+        (fsLit "log"),          (fsLit "logf"),         (fsLit "logl"),
+        (fsLit "log10l"),       (fsLit "log10"),        (fsLit "log10f"),
+        (fsLit "log1pl"),       (fsLit "log1p"),        (fsLit "log1pf"),
+        (fsLit "log2"),         (fsLit "log2f"),        (fsLit "log2l"),
+        (fsLit "logb"),         (fsLit "logbf"),        (fsLit "logbl"),
+        (fsLit "lrint"),        (fsLit "lrintf"),       (fsLit "lrintl"),
+        (fsLit "lround"),       (fsLit "lroundf"),      (fsLit "lroundl"),
+        (fsLit "modf"),         (fsLit "modff"),        (fsLit "modfl"),
+        (fsLit "nan"),          (fsLit "nanf"),         (fsLit "nanl"),
+        (fsLit "nearbyint"),    (fsLit "nearbyintf"),   (fsLit "nearbyintl"),
+        (fsLit "nextafter"),    (fsLit "nextafterf"),   (fsLit "nextafterl"),
+        (fsLit "nexttoward"),   (fsLit "nexttowardf"),  (fsLit "nexttowardl"),
+        (fsLit "pow"),          (fsLit "powf"),         (fsLit "powl"),
+        (fsLit "remainder"),    (fsLit "remainderf"),   (fsLit "remainderl"),
+        (fsLit "remquo"),       (fsLit "remquof"),      (fsLit "remquol"),
+        (fsLit "rint"),         (fsLit "rintf"),        (fsLit "rintl"),
+        (fsLit "round"),        (fsLit "roundf"),       (fsLit "roundl"),
+        (fsLit "scalbln"),      (fsLit "scalblnf"),     (fsLit "scalblnl"),
+        (fsLit "scalbn"),       (fsLit "scalbnf"),      (fsLit "scalbnl"),
+        (fsLit "sin"),          (fsLit "sinf"),         (fsLit "sinl"),
+        (fsLit "sinh"),         (fsLit "sinhf"),        (fsLit "sinhl"),
+        (fsLit "sqrt"),         (fsLit "sqrtf"),        (fsLit "sqrtl"),
+        (fsLit "tan"),          (fsLit "tanf"),         (fsLit "tanl"),
+        (fsLit "tanh"),         (fsLit "tanhf"),        (fsLit "tanhl"),
+        (fsLit "tgamma"),       (fsLit "tgammaf"),      (fsLit "tgammal"),
+        (fsLit "trunc"),        (fsLit "truncf"),       (fsLit "truncl"),
+        -- ISO C 99 also defines these function-like macros in math.h:
+        -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,
+        -- isgreaterequal, isless, islessequal, islessgreater, isunordered
+
+        -- additional symbols from _BSD_SOURCE
+        (fsLit "drem"),         (fsLit "dremf"),        (fsLit "dreml"),
+        (fsLit "finite"),       (fsLit "finitef"),      (fsLit "finitel"),
+        (fsLit "gamma"),        (fsLit "gammaf"),       (fsLit "gammal"),
+        (fsLit "isinf"),        (fsLit "isinff"),       (fsLit "isinfl"),
+        (fsLit "isnan"),        (fsLit "isnanf"),       (fsLit "isnanl"),
+        (fsLit "j0"),           (fsLit "j0f"),          (fsLit "j0l"),
+        (fsLit "j1"),           (fsLit "j1f"),          (fsLit "j1l"),
+        (fsLit "jn"),           (fsLit "jnf"),          (fsLit "jnl"),
+        (fsLit "lgamma_r"),     (fsLit "lgammaf_r"),    (fsLit "lgammal_r"),
+        (fsLit "scalb"),        (fsLit "scalbf"),       (fsLit "scalbl"),
+        (fsLit "significand"),  (fsLit "significandf"), (fsLit "significandl"),
+        (fsLit "y0"),           (fsLit "y0f"),          (fsLit "y0l"),
+        (fsLit "y1"),           (fsLit "y1f"),          (fsLit "y1l"),
+        (fsLit "yn"),           (fsLit "ynf"),          (fsLit "ynl"),
+
+        -- These functions are described in IEEE Std 754-2008 -
+        -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661
+        (fsLit "nextup"),       (fsLit "nextupf"),      (fsLit "nextupl"),
+        (fsLit "nextdown"),     (fsLit "nextdownf"),    (fsLit "nextdownl")
+    ]
+
+-- -----------------------------------------------------------------------------
+-- | Is a CLabel visible outside this object file or not?
+--      From the point of view of the code generator, a name is
+--      externally visible if it has to be declared as exported
+--      in the .o file's symbol table; that is, made non-static.
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+externallyVisibleCLabel (StringLitLabel _)      = False
+externallyVisibleCLabel (AsmTempLabel _)        = False
+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
+externallyVisibleCLabel (RtsLabel _)            = True
+externallyVisibleCLabel (LocalBlockLabel _)     = False
+externallyVisibleCLabel (CmmLabel _ _ _)        = True
+externallyVisibleCLabel (ForeignLabel{})        = True
+externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info
+externallyVisibleCLabel (CC_Label _)            = True
+externallyVisibleCLabel (CCS_Label _)           = True
+externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
+externallyVisibleCLabel (HpcTicksLabel _)       = True
+externallyVisibleCLabel (LargeBitmapLabel _)    = False
+externallyVisibleCLabel (SRTLabel _)            = False
+externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
+externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
+
+externallyVisibleIdLabel :: IdLabelInfo -> Bool
+externallyVisibleIdLabel LocalInfoTable  = False
+externallyVisibleIdLabel LocalEntry      = False
+externallyVisibleIdLabel BlockInfoTable  = False
+externallyVisibleIdLabel _               = True
+
+-- -----------------------------------------------------------------------------
+-- Finding the "type" of a CLabel
+
+-- For generating correct types in label declarations:
+
+data CLabelType
+  = CodeLabel   -- Address of some executable instructions
+  | DataLabel   -- Address of data, not a GC ptr
+  | GcPtrLabel  -- Address of a (presumably static) GC object
+
+isCFunctionLabel :: CLabel -> Bool
+isCFunctionLabel lbl = case labelType lbl of
+                        CodeLabel -> True
+                        _other    -> False
+
+isGcPtrLabel :: CLabel -> Bool
+isGcPtrLabel lbl = case labelType lbl of
+                        GcPtrLabel -> True
+                        _other     -> False
+
+
+-- | Work out the general type of data at the address of this label
+--    whether it be code, data, or static GC object.
+labelType :: CLabel -> CLabelType
+labelType (IdLabel _ _ info)                    = idInfoLabelType info
+labelType (CmmLabel _ _ CmmData)                = DataLabel
+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel
+labelType (CmmLabel _ _ CmmCode)                = CodeLabel
+labelType (CmmLabel _ _ CmmInfo)                = DataLabel
+labelType (CmmLabel _ _ CmmEntry)               = CodeLabel
+labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel
+labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel
+labelType (CmmLabel _ _ CmmRet)                 = CodeLabel
+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
+labelType (RtsLabel (RtsApFast _))              = CodeLabel
+labelType (RtsLabel _)                          = DataLabel
+labelType (LocalBlockLabel _)                   = CodeLabel
+labelType (SRTLabel _)                          = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
+labelType (ForeignLabel _ _ _ IsData)           = DataLabel
+labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"
+labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"
+labelType (StringLitLabel _)                    = DataLabel
+labelType (CC_Label _)                          = DataLabel
+labelType (CCS_Label _)                         = DataLabel
+labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?
+labelType PicBaseLabel                          = DataLabel
+labelType (DeadStripPreventer _)                = DataLabel
+labelType (HpcTicksLabel _)                     = DataLabel
+labelType (LargeBitmapLabel _)                  = DataLabel
+
+idInfoLabelType :: IdLabelInfo -> CLabelType
+idInfoLabelType info =
+  case info of
+    InfoTable     -> DataLabel
+    LocalInfoTable -> DataLabel
+    BlockInfoTable -> DataLabel
+    Closure       -> GcPtrLabel
+    ConInfoTable  -> DataLabel
+    ClosureTable  -> DataLabel
+    RednCounts    -> DataLabel
+    Bytes         -> DataLabel
+    _             -> CodeLabel
+
+
+-- -----------------------------------------------------------------------------
+
+-- | Is a 'CLabel' defined in the current module being compiled?
+--
+-- Sometimes we can optimise references within a compilation unit in ways that
+-- we couldn't for inter-module references. This provides a conservative
+-- estimate of whether a 'CLabel' lives in the current module.
+isLocalCLabel :: Module -> CLabel -> Bool
+isLocalCLabel this_mod lbl =
+  case lbl of
+    IdLabel name _ _
+      | isInternalName name -> True
+      | otherwise           -> nameModule name == this_mod
+    LocalBlockLabel _       -> True
+    _                       -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | Does a 'CLabel' need dynamic linkage?
+--
+-- When referring to data in code, we need to know whether
+-- that data resides in a DLL or not. [Win32 only.]
+-- @labelDynamic@ returns @True@ if the label is located
+-- in a DLL, be it a data reference or not.
+labelDynamic :: DynFlags -> Module -> CLabel -> Bool
+labelDynamic dflags this_mod lbl =
+  case lbl of
+   -- is the RTS in a DLL or not?
+   RtsLabel _ ->
+     externalDynamicRefs && (this_pkg /= rtsUnitId)
+
+   IdLabel n _ _ ->
+     isDllName dflags this_mod n
+
+   -- When compiling in the "dyn" way, each package is to be linked into
+   -- its own shared library.
+   CmmLabel pkg _ _
+    | os == OSMinGW32 ->
+       externalDynamicRefs && (this_pkg /= pkg)
+    | otherwise ->
+       gopt Opt_ExternalDynamicRefs dflags
+
+   LocalBlockLabel _    -> False
+
+   ForeignLabel _ _ source _  ->
+       if os == OSMinGW32
+       then case source of
+            -- Foreign label is in some un-named foreign package (or DLL).
+            ForeignLabelInExternalPackage -> True
+
+            -- Foreign label is linked into the same package as the
+            -- source file currently being compiled.
+            ForeignLabelInThisPackage -> False
+
+            -- Foreign label is in some named package.
+            -- When compiling in the "dyn" way, each package is to be
+            -- linked into its own DLL.
+            ForeignLabelInPackage pkgId ->
+                externalDynamicRefs && (this_pkg /= pkgId)
+
+       else -- On Mac OS X and on ELF platforms, false positives are OK,
+            -- so we claim that all foreign imports come from dynamic
+            -- libraries
+            True
+
+   CC_Label cc ->
+     externalDynamicRefs && not (ccFromThisModule cc this_mod)
+
+   -- CCS_Label always contains a CostCentre defined in the current module
+   CCS_Label _ -> False
+
+   HpcTicksLabel m ->
+     externalDynamicRefs && this_mod /= m
+
+   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
+   _                 -> False
+  where
+    externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+    os = platformOS (targetPlatform dflags)
+    this_pkg = moduleUnitId this_mod
+
+
+-----------------------------------------------------------------------------
+-- Printing out CLabels.
+
+{-
+Convention:
+
+      <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+         info                   Info table
+         srt                    Static reference table
+         entry                  Entry code (function, closure)
+         slow                   Slow entry code (if any)
+         ret                    Direct return address
+         vtbl                   Vector table
+         <n>_alt                Case alternative (tag n)
+         dflt                   Default case alternative
+         btm                    Large bitmap vector
+         closure                Static closure
+         con_entry              Dynamic Constructor entry code
+         con_info               Dynamic Constructor info table
+         static_entry           Static Constructor entry code
+         static_info            Static Constructor info table
+         sel_info               Selector info table
+         sel_entry              Selector entry code
+         cc                     Cost centre
+         ccs                    Cost centre stack
+
+Many of these distinctions are only for documentation reasons.  For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+
+Note [Closure and info labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a function 'foo, we have:
+   foo_info    : Points to the info table describing foo's closure
+                 (and entry code for foo with tables next to code)
+   foo_closure : Static (no-free-var) closure only:
+                 points to the statically-allocated closure
+
+For a data constructor (such as Just or Nothing), we have:
+    Just_con_info: Info table for the data constructor itself
+                   the first word of a heap-allocated Just
+    Just_info:     Info table for the *worker function*, an
+                   ordinary Haskell function of arity 1 that
+                   allocates a (Just x) box:
+                      Just = \x -> Just x
+    Just_closure:  The closure for this worker
+
+    Nothing_closure: a statically allocated closure for Nothing
+    Nothing_static_info: info table for Nothing_closure
+
+All these must be exported symbol, EXCEPT Just_info.  We don't need to
+export this because in other modules we either have
+       * A reference to 'Just'; use Just_closure
+       * A saturated call 'Just x'; allocate using Just_con_info
+Not exporting these Just_info labels reduces the number of symbols
+somewhat.
+
+Note [Bytes label]
+~~~~~~~~~~~~~~~~~~
+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
+points to a static data block containing the content of the literal.
+
+Note [Proc-point local block entry-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A label for a proc-point local block entry-point has no "_entry" suffix. With
+`infoTblLbl` we derive an info table label from a proc-point block ID. If
+we convert such an info table label into an entry label we must produce
+the label without an "_entry" suffix. So an info table label records
+the fact that it was derived from a block ID in `IdLabelInfo` as
+`BlockInfoTable`.
+
+The info table label and the local block label are both local labels
+and are not externally visible.
+-}
+
+instance Outputable CLabel where
+  ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c
+
+pprCLabel :: DynFlags -> CLabel -> SDoc
+
+pprCLabel _ (LocalBlockLabel u)
+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
+pprCLabel dynFlags (AsmTempLabel u)
+ | not (platformUnregisterised $ targetPlatform dynFlags)
+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
+pprCLabel dynFlags (AsmTempDerivedLabel l suf)
+ | sGhcWithNativeCodeGen $ settings dynFlags
+   = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)
+     <> case l of AsmTempLabel u    -> pprUniqueAlways u
+                  LocalBlockLabel u -> pprUniqueAlways u
+                  _other            -> pprCLabel dynFlags l
+     <> ftext suf
+
+pprCLabel dynFlags (DynamicLinkerLabel info lbl)
+ | sGhcWithNativeCodeGen $ settings dynFlags
+   = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl
+
+pprCLabel dynFlags PicBaseLabel
+ | sGhcWithNativeCodeGen $ settings dynFlags
+   = text "1b"
+
+pprCLabel dynFlags (DeadStripPreventer lbl)
+ | sGhcWithNativeCodeGen $ settings dynFlags
+   =
+   {-
+      `lbl` can be temp one but we need to ensure that dsp label will stay
+      in the final binary so we prepend non-temp prefix ("dsp_") and
+      optional `_` (underscore) because this is how you mark non-temp symbols
+      on some platforms (Darwin)
+   -}
+   maybe_underscore dynFlags $ text "dsp_"
+   <> pprCLabel dynFlags lbl <> text "_dsp"
+
+pprCLabel dynFlags (StringLitLabel u)
+ | sGhcWithNativeCodeGen $ settings dynFlags
+  = pprUniqueAlways u <> ptext (sLit "_str")
+
+pprCLabel dynFlags lbl
+   = getPprStyle $ \ sty ->
+     if sGhcWithNativeCodeGen (settings dynFlags) && asmStyle sty
+     then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl
+     else pprCLbl lbl
+
+maybe_underscore :: DynFlags -> SDoc -> SDoc
+maybe_underscore dynFlags doc =
+  if sLeadingUnderscore $ settings dynFlags
+  then pp_cSEP <> doc
+  else doc
+
+pprAsmCLbl :: Platform -> CLabel -> SDoc
+pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)
+ | platformOS platform == OSMinGW32
+    -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+    -- (The C compiler does this itself).
+    = ftext fs <> char '@' <> int sz
+pprAsmCLbl _ lbl
+   = pprCLbl lbl
+
+pprCLbl :: CLabel -> SDoc
+pprCLbl (StringLitLabel u)
+  = pprUniqueAlways u <> text "_str"
+
+pprCLbl (SRTLabel u)
+  = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+
+pprCLbl (LargeBitmapLabel u)  =
+  tempLabelPrefixOrUnderscore
+  <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
+-- until that gets resolved we'll just force them to start
+-- with a letter so the label will be legal assembly code.
+
+
+pprCLbl (CmmLabel _ str CmmCode)        = ftext str
+pprCLbl (CmmLabel _ str CmmData)        = ftext str
+pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
+
+pprCLbl (LocalBlockLabel u)             =
+    tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
+
+pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"
+
+pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+    hcat [text "stg_sel_", text (show offset),
+          ptext (if upd_reqd
+                 then (sLit "_upd_info")
+                 else (sLit "_noupd_info"))
+        ]
+
+pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+    hcat [text "stg_sel_", text (show offset),
+                ptext (if upd_reqd
+                        then (sLit "_upd_entry")
+                        else (sLit "_noupd_entry"))
+        ]
+
+pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+    hcat [text "stg_ap_", text (show arity),
+                ptext (if upd_reqd
+                        then (sLit "_upd_info")
+                        else (sLit "_noupd_info"))
+        ]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+    hcat [text "stg_ap_", text (show arity),
+                ptext (if upd_reqd
+                        then (sLit "_upd_entry")
+                        else (sLit "_noupd_entry"))
+        ]
+
+pprCLbl (CmmLabel _ fs CmmInfo)
+  = ftext fs <> text "_info"
+
+pprCLbl (CmmLabel _ fs CmmEntry)
+  = ftext fs <> text "_entry"
+
+pprCLbl (CmmLabel _ fs CmmRetInfo)
+  = ftext fs <> text "_info"
+
+pprCLbl (CmmLabel _ fs CmmRet)
+  = ftext fs <> text "_ret"
+
+pprCLbl (CmmLabel _ fs CmmClosure)
+  = ftext fs <> text "_closure"
+
+pprCLbl (RtsLabel (RtsPrimOp primop))
+  = text "stg_" <> ppr primop
+
+pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))
+  = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+
+pprCLbl (ForeignLabel str _ _ _)
+  = ftext str
+
+pprCLbl (IdLabel name _cafs flavor) =
+  internalNamePrefix name <> ppr name <> ppIdFlavor flavor
+
+pprCLbl (CC_Label cc)           = ppr cc
+pprCLbl (CCS_Label ccs)         = ppr ccs
+
+pprCLbl (HpcTicksLabel mod)
+  = text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")
+
+pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"
+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"
+pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"
+pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"
+pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <> text
+               (case x of
+                       Closure          -> "closure"
+                       InfoTable        -> "info"
+                       LocalInfoTable   -> "info"
+                       Entry            -> "entry"
+                       LocalEntry       -> "entry"
+                       Slow             -> "slow"
+                       RednCounts       -> "ct"
+                       ConEntry         -> "con_entry"
+                       ConInfoTable     -> "con_info"
+                       ClosureTable     -> "closure_tbl"
+                       Bytes            -> "bytes"
+                       BlockInfoTable   -> "info"
+                      )
+
+
+pp_cSEP :: SDoc
+pp_cSEP = char '_'
+
+
+instance Outputable ForeignLabelSource where
+ ppr fs
+  = case fs of
+        ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId
+        ForeignLabelInThisPackage       -> parens $ text "this package"
+        ForeignLabelInExternalPackage   -> parens $ text "external package"
+
+internalNamePrefix :: Name -> SDoc
+internalNamePrefix name = getPprStyle $ \ sty ->
+  if asmStyle sty && isRandomGenerated then
+    sdocWithPlatform $ \platform ->
+      ptext (asmTempLabelPrefix platform)
+  else
+    empty
+  where
+    isRandomGenerated = not $ isExternalName name
+
+tempLabelPrefixOrUnderscore :: SDoc
+tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->
+  getPprStyle $ \ sty ->
+   if asmStyle sty then
+      ptext (asmTempLabelPrefix platform)
+   else
+      char '_'
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels
+asmTempLabelPrefix platform = case platformOS platform of
+    OSDarwin -> sLit "L"
+    OSAIX    -> sLit "__L" -- follow IBM XL C's convention
+    _        -> sLit ".L"
+
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo lbl =
+    case platformOS platform of
+      OSDarwin
+        | platformArch platform == ArchX86_64 ->
+          case dllInfo of
+            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"
+            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"
+            GotSymbolOffset -> ppr lbl
+        | otherwise ->
+          case dllInfo of
+            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"
+            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      OSAIX ->
+          case dllInfo of
+            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      _ | osElfTarget (platformOS platform) -> elfLabel
+
+      OSMinGW32 ->
+          case dllInfo of
+            SymbolPtr -> text "__imp_" <> ppr lbl
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      _ -> panic "pprDynamicLinkerAsmLabel"
+  where
+    elfLabel
+      | platformArch platform == ArchPPC
+      = case dllInfo of
+          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]
+                       ppr lbl <> text "+32768@plt"
+          SymbolPtr -> text ".LC_" <> ppr lbl
+          _         -> panic "pprDynamicLinkerAsmLabel"
+
+      | platformArch platform == ArchX86_64
+      = case dllInfo of
+          CodeStub        -> ppr lbl <> text "@plt"
+          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"
+          GotSymbolOffset -> ppr lbl
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+
+      | platformArch platform == ArchPPC_64 ELF_V1
+        || platformArch platform == ArchPPC_64 ELF_V2
+      = case dllInfo of
+          GotSymbolPtr    -> text ".LC_"  <> ppr lbl
+                                  <> text "@toc"
+          GotSymbolOffset -> ppr lbl
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+          _               -> panic "pprDynamicLinkerAsmLabel"
+
+      | otherwise
+      = case dllInfo of
+          CodeStub        -> ppr lbl <> text "@plt"
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+          GotSymbolPtr    -> ppr lbl <> text "@got"
+          GotSymbolOffset -> ppr lbl <> text "@gotoff"
+
+-- Figure out whether `symbol` may serve as an alias
+-- to `target` within one compilation unit.
+--
+-- This is true if any of these holds:
+-- * `target` is a module-internal haskell name.
+-- * `target` is an exported name, but comes from the same
+--   module as `symbol`
+--
+-- These are sufficient conditions for establishing e.g. a
+-- GNU assembly alias ('.equiv' directive). Sadly, there is
+-- no such thing as an alias to an imported symbol (conf.
+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)
+-- See note [emit-time elimination of static indirections].
+--
+-- Precondition is that both labels represent the
+-- same semantic value.
+
+mayRedirectTo :: CLabel -> CLabel -> Bool
+mayRedirectTo symbol target
+ | Just nam <- haskellName
+ , staticClosureLabel
+ , isExternalName nam
+ , Just mod <- nameModule_maybe nam
+ , Just anam <- hasHaskellName symbol
+ , Just amod <- nameModule_maybe anam
+ = amod == mod
+
+ | Just nam <- haskellName
+ , staticClosureLabel
+ , isInternalName nam
+ = True
+
+ | otherwise = False
+   where staticClosureLabel = isStaticClosureLabel target
+         haskellName = hasHaskellName target
+
+
+{-
+Note [emit-time elimination of static indirections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in #15155, certain static values are repesentationally
+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).
+
+             newtype A = A Int
+             {-# NOINLINE a #-}
+             a = A 42
+
+a1_rYB :: Int
+[GblId, Caf=NoCafRefs, Unf=OtherCon []]
+a1_rYB = GHC.Types.I# 42#
+
+a [InlPrag=NOINLINE] :: A
+[GblId, Unf=OtherCon []]
+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)
+
+Formerly we created static indirections for these (IND_STATIC), which
+consist of a statically allocated forwarding closure that contains
+the (possibly tagged) indirectee. (See CMM/assembly below.)
+This approach is suboptimal for two reasons:
+  (a) they occupy extra space,
+  (b) they need to be entered in order to obtain the indirectee,
+      thus they cannot be tagged.
+
+Fortunately there is a common case where static indirections can be
+eliminated while emitting assembly (native or LLVM), viz. when the
+indirectee is in the same module (object file) as the symbol that
+points to it. In this case an assembly-level identification can
+be created ('.equiv' directive), and as such the same object will
+be assigned two names in the symbol table. Any of the identified
+symbols can be referenced by a tagged pointer.
+
+Currently the 'mayRedirectTo' predicate will
+give a clue whether a label can be equated with another, already
+emitted, label (which can in turn be an alias). The general mechanics
+is that we identify data (IND_STATIC closures) that are amenable
+to aliasing while pretty-printing of assembly output, and emit the
+'.equiv' directive instead of static data in such a case.
+
+Here is a sketch how the output is massaged:
+
+                     Consider
+newtype A = A Int
+{-# NOINLINE a #-}
+a = A 42                                -- I# 42# is the indirectee
+                                        -- 'a' is exported
+
+                 results in STG
+
+a1_rXq :: GHC.Types.Int
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+    CCS_DONT_CARE GHC.Types.I#! [42#];
+
+T15155.a [InlPrag=NOINLINE] :: T15155.A
+[GblId, Unf=OtherCon []] =
+    CAF_ccs  \ u  []  a1_rXq;
+
+                 and CMM
+
+[section ""data" . a1_rXq_closure" {
+     a1_rXq_closure:
+         const GHC.Types.I#_con_info;
+         const 42;
+ }]
+
+[section ""data" . T15155.a_closure" {
+     T15155.a_closure:
+         const stg_IND_STATIC_info;
+         const a1_rXq_closure+1;
+         const 0;
+         const 0;
+ }]
+
+The emitted assembly is
+
+#### INDIRECTEE
+a1_rXq_closure:                         -- module local haskell value
+        .quad   GHC.Types.I#_con_info   -- an Int
+        .quad   42
+
+#### BEFORE
+.globl T15155.a_closure                 -- exported newtype wrapped value
+T15155.a_closure:
+        .quad   stg_IND_STATIC_info     -- the closure info
+        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)
+        .quad   0
+        .quad   0
+
+#### AFTER
+.globl T15155.a_closure                 -- exported newtype wrapped value
+.equiv a1_rXq_closure,T15155.a_closure  -- both are shared
+
+The transformation is performed because
+     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
+returns True.
+-}
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Cmm.hs
@@ -0,0 +1,229 @@
+-- Cmm representations using Hoopl's Graph CmmNode e x.
+{-# LANGUAGE GADTs #-}
+
+module Cmm (
+     -- * Cmm top-level datatypes
+     CmmProgram, CmmGroup, GenCmmGroup,
+     CmmDecl, GenCmmDecl(..),
+     CmmGraph, GenCmmGraph(..),
+     CmmBlock,
+     RawCmmDecl, RawCmmGroup,
+     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
+     isSecConstant,
+
+     -- ** Blocks containing lists
+     GenBasicBlock(..), blockId,
+     ListGraph(..), pprBBlock,
+
+     -- * Info Tables
+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+     ClosureTypeInfo(..),
+     ProfilingInfo(..), ConstrDescription,
+
+     -- * Statements, expressions and types
+     module CmmNode,
+     module CmmExpr,
+  ) where
+
+import GhcPrelude
+
+import Id
+import CostCentre
+import CLabel
+import BlockId
+import CmmNode
+import SMRep
+import CmmExpr
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import Outputable
+import Data.ByteString (ByteString)
+
+-----------------------------------------------------------------------------
+--  Cmm, GenCmm
+-----------------------------------------------------------------------------
+
+-- A CmmProgram is a list of CmmGroups
+-- A CmmGroup is a list of top-level declarations
+
+-- When object-splitting is on, each group is compiled into a separate
+-- .o file. So typically we put closely related stuff in a CmmGroup.
+-- Section-splitting follows suit and makes one .text subsection for each
+-- CmmGroup.
+
+type CmmProgram = [CmmGroup]
+
+type GenCmmGroup d h g = [GenCmmDecl d h g]
+type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
+type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph
+
+-----------------------------------------------------------------------------
+--  CmmDecl, GenCmmDecl
+-----------------------------------------------------------------------------
+
+-- GenCmmDecl is abstracted over
+--   d, the type of static data elements in CmmData
+--   h, the static info preceding the code of a CmmProc
+--   g, the control-flow graph of a CmmProc
+--
+-- We expect there to be two main instances of this type:
+--   (a) C--, i.e. populated with various C-- constructs
+--   (b) Native code, populated with data/instructions
+
+-- | A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmDecl d h g
+  = CmmProc     -- A procedure
+     h                 -- Extra header such as the info table
+     CLabel            -- Entry label
+     [GlobalReg]       -- Registers live on entry. Note that the set of live
+                       -- registers will be correct in generated C-- code, but
+                       -- not in hand-written C-- code. However,
+                       -- splitAtProcPoints calculates correct liveness
+                       -- information for CmmProcs.
+     g                 -- Control-flow graph for the procedure's code
+
+  | CmmData     -- Static data
+        Section
+        d
+
+type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
+
+type RawCmmDecl
+   = GenCmmDecl
+        CmmStatics
+        (LabelMap CmmStatics)
+        CmmGraph
+
+-----------------------------------------------------------------------------
+--     Graphs
+-----------------------------------------------------------------------------
+
+type CmmGraph = GenCmmGraph CmmNode
+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
+type CmmBlock = Block CmmNode C C
+
+-----------------------------------------------------------------------------
+--     Info Tables
+-----------------------------------------------------------------------------
+
+data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable
+                            , stack_info :: CmmStackInfo }
+
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
+topInfoTable _                     = Nothing
+
+data CmmStackInfo
+   = StackInfo {
+       arg_space :: ByteOff,
+               -- number of bytes of arguments on the stack on entry to the
+               -- the proc.  This is filled in by StgCmm.codeGen, and used
+               -- by the stack allocator later.
+       updfr_space :: Maybe ByteOff,
+               -- XXX: this never contains anything useful, but it should.
+               -- See comment in CmmLayoutStack.
+       do_layout :: Bool
+               -- Do automatic stack layout for this proc.  This is
+               -- True for all code generated by the code generator,
+               -- but is occasionally False for hand-written Cmm where
+               -- we want to do the stack manipulation manually.
+  }
+
+-- | Info table as a haskell data type
+data CmmInfoTable
+  = CmmInfoTable {
+      cit_lbl  :: CLabel, -- Info table label
+      cit_rep  :: SMRep,
+      cit_prof :: ProfilingInfo,
+      cit_srt  :: Maybe CLabel,   -- empty, or a closure address
+      cit_clo  :: Maybe (Id, CostCentreStack)
+        -- Just (id,ccs) <=> build a static closure later
+        -- Nothing <=> don't build a static closure
+        --
+        -- Static closures for FUNs and THUNKs are *not* generated by
+        -- the code generator, because we might want to add SRT
+        -- entries to them later (for FUNs at least; THUNKs are
+        -- treated the same for consistency). See Note [SRTs] in
+        -- CmmBuildInfoTables, in particular the [FUN] optimisation.
+        --
+        -- This is strictly speaking not a part of the info table that
+        -- will be finally generated, but it's the only convenient
+        -- place to convey this information from the code generator to
+        -- where we build the static closures in
+        -- CmmBuildInfoTables.doSRTs.
+    }
+
+data ProfilingInfo
+  = NoProfilingInfo
+  | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
+
+-----------------------------------------------------------------------------
+--              Static Data
+-----------------------------------------------------------------------------
+
+data SectionType
+  = Text
+  | Data
+  | ReadOnlyData
+  | RelocatableReadOnlyData
+  | UninitialisedData
+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+  | CString
+  | OtherSection String
+  deriving (Show)
+
+-- | Should a data in this section be considered constant
+isSecConstant :: Section -> Bool
+isSecConstant (Section t _) = case t of
+    Text                    -> True
+    ReadOnlyData            -> True
+    RelocatableReadOnlyData -> True
+    ReadOnlyData16          -> True
+    CString                 -> True
+    Data                    -> False
+    UninitialisedData       -> False
+    (OtherSection _)        -> False
+
+data Section = Section SectionType CLabel
+
+data CmmStatic
+  = CmmStaticLit CmmLit
+        -- a literal value, size given by cmmLitRep of the literal.
+  | CmmUninitialised Int
+        -- uninitialised data, N bytes long
+  | CmmString ByteString
+        -- string of 8-bit values only, not zero terminated.
+
+data CmmStatics
+   = Statics
+       CLabel      -- Label of statics
+       [CmmStatic] -- The static data itself
+
+-- -----------------------------------------------------------------------------
+-- Basic blocks consisting of lists
+
+-- These are used by the LLVM and NCG backends, when populating Cmm
+-- with lists of instructions.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+
+-- | The branch block id is that of the first block in
+-- the branch, which is that branch's entry point
+blockId :: GenBasicBlock i -> BlockId
+blockId (BasicBlock blk_id _ ) = blk_id
+
+newtype ListGraph i = ListGraph [GenBasicBlock i]
+
+instance Outputable instr => Outputable (ListGraph instr) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance Outputable instr => Outputable (GenBasicBlock instr) where
+    ppr = pprBBlock
+
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -0,0 +1,896 @@
+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}
+
+module CmmBuildInfoTables
+  ( CAFSet, CAFEnv, cafAnal
+  , doSRTs, ModuleSRTInfo, emptySRT
+  ) where
+
+import GhcPrelude hiding (succ)
+
+import Id
+import BlockId
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Module
+import Platform
+import Digraph
+import CLabel
+import PprCmmDecl ()
+import Cmm
+import CmmUtils
+import DynFlags
+import Maybes
+import Outputable
+import SMRep
+import UniqSupply
+import CostCentre
+import StgCmmHeap
+
+import PprCmm()
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Tuple
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+
+
+{- Note [SRTs]
+
+SRTs are the mechanism by which the garbage collector can determine
+the live CAFs in the program.
+
+Representation
+^^^^^^^^^^^^^^
+
++------+
+| info |
+|      |     +-----+---+---+---+
+|   -------->|SRT_2| | | | | 0 |
+|------|     +-----+-|-+-|-+---+
+|      |             |   |
+| code |             |   |
+|      |             v   v
+
+An SRT is simply an object in the program's data segment. It has the
+same representation as a static constructor.  There are 16
+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
+representing SRT objects with 1-16 pointers, respectively.
+
+The entries of an SRT object point to static closures, which are either
+- FUN_STATIC, THUNK_STATIC or CONSTR
+- Another SRT (actually just a CONSTR)
+
+The final field of the SRT is the static link field, used by the
+garbage collector to chain together static closures that it visits and
+to determine whether a static closure has been visited or not. (see
+Note [STATIC_LINK fields])
+
+By traversing the transitive closure of an SRT, the GC will reach all
+of the CAFs that are reachable from the code associated with this SRT.
+
+If we need to create an SRT with more than 16 entries, we build a
+chain of SRT objects with all but the last having 16 entries.
+
++-----+---+- -+---+---+
+|SRT16| | |   | | | 0 |
++-----+-|-+- -+-|-+---+
+        |       |
+        v       v
+              +----+---+---+---+
+              |SRT2| | | | | 0 |
+              +----+-|-+-|-+---+
+                     |   |
+                     |   |
+                     v   v
+
+Referring to an SRT from the info table
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The following things have SRTs:
+
+- Static functions (FUN)
+- Static thunks (THUNK), ie. CAFs
+- Continuations (RET_SMALL, etc.)
+
+In each case, the info table points to the SRT.
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt == 1 and info->f.srt_offset points to the SRT
+
+e.g. for a FUN with an SRT:
+
+StgFunInfoTable       +------+
+  info->f.srt_offset  |  ------------> offset to SRT object
+StgStdInfoTable       +------+
+  info->layout.ptrs   | ...  |
+  info->layout.nptrs  | ...  |
+  info->srt           |  1   |
+  info->type          | ...  |
+                      |------|
+
+On x86_64, we optimise the info table representation further.  The
+offset to the SRT can be stored in 32 bits (all code lives within a
+2GB region in x86_64's small memory model), so we can save a word in
+the info table by storing the srt_offset in the srt field, which is
+half a word.
+
+On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt is an offset from the info pointer to the SRT object
+
+StgStdInfoTable       +------+
+  info->layout.ptrs   |      |
+  info->layout.nptrs  |      |
+  info->srt           |  ------------> offset to SRT object
+                      |------|
+
+
+EXAMPLE
+^^^^^^^
+
+f = \x. ... g ...
+  where
+    g = \y. ... h ... c1 ...
+    h = \z. ... c2 ...
+
+c1 & c2 are CAFs
+
+g and h are local functions, but they have no static closures.  When
+we generate code for f, we start with a CmmGroup of four CmmDecls:
+
+   [ f_closure, f_entry, g_entry, h_entry ]
+
+we process each CmmDecl separately in cpsTop, giving us a list of
+CmmDecls. e.g. for f_entry, we might end up with
+
+   [ f_entry, f1_ret, f2_proc ]
+
+where f1_ret is a return point, and f2_proc is a proc-point.  We have
+a CAFSet for each of these CmmDecls, let's suppose they are
+
+   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
+   [ g_entry{h_info, c1_closure} ]
+   [ h_entry{c2_closure} ]
+
+Next, we make an SRT for each of these functions:
+
+  f_srt : [g_info]
+  g_srt : [h_info, c1_closure]
+  h_srt : [c2_closure]
+
+Now, for g_info and h_info, we want to refer to the SRTs for g and h
+respectively, which we'll label g_srt and h_srt:
+
+  f_srt : [g_srt]
+  g_srt : [h_srt, c1_closure]
+  h_srt : [c2_closure]
+
+Now, when an SRT has a single entry, we don't actually generate an SRT
+closure for it, instead we just replace references to it with its
+single element.  So, since h_srt == c2_closure, we have
+
+  f_srt : [g_srt]
+  g_srt : [c2_closure, c1_closure]
+  h_srt : [c2_closure]
+
+and the only SRT closure we generate is
+
+  g_srt = SRT_2 [c2_closure, c1_closure]
+
+
+Optimisations
+^^^^^^^^^^^^^
+
+To reduce the code size overhead and the cost of traversing SRTs in
+the GC, we want to simplify SRTs where possible. We therefore apply
+the following optimisations.  Each has a [keyword]; search for the
+keyword in the code below to see where the optimisation is
+implemented.
+
+1. [Inline] we never create an SRT with a single entry, instead we
+   point to the single entry directly from the info table.
+
+   i.e. instead of
+
+    +------+
+    | info |
+    |      |     +-----+---+---+
+    |   -------->|SRT_1| | | 0 |
+    |------|     +-----+-|-+---+
+    |      |             |
+    | code |             |
+    |      |             v
+                         C
+
+   we can point directly to the closure:
+
+    +------+
+    | info |
+    |      |
+    |   -------->C
+    |------|
+    |      |
+    | code |
+    |      |
+
+
+   Furthermore, the SRT for any code that refers to this info table
+   can point directly to C.
+
+   The exception to this is when we're doing dynamic linking. In that
+   case, if the closure is not locally defined then we can't point to
+   it directly from the info table, because this is the text section
+   which cannot contain runtime relocations. In this case we skip this
+   optimisation and generate the singleton SRT, becase SRTs are in the
+   data section and *can* have relocatable references.
+
+2. [FUN] A static function closure can also be an SRT, we simply put
+   the SRT entries as fields in the static closure.  This makes a lot
+   of sense: the static references are just like the free variables of
+   the FUN closure.
+
+   i.e. instead of
+
+   f_closure:
+   +-----+---+
+   |  |  | 0 |
+   +- |--+---+
+      |            +------+
+      |            | info |     f_srt:
+      |            |      |     +-----+---+---+---+
+      |            |   -------->|SRT_2| | | | + 0 |
+      `----------->|------|     +-----+-|-+-|-+---+
+                   |      |             |   |
+                   | code |             |   |
+                   |      |             v   v
+
+
+   We can generate:
+
+   f_closure:
+   +-----+---+---+---+
+   |  |  | | | | | 0 |
+   +- |--+-|-+-|-+---+
+      |    |   |   +------+
+      |    v   v   | info |
+      |            |      |
+      |            |   0  |
+      `----------->|------|
+                   |      |
+                   | code |
+                   |      |
+
+
+   (note: we can't do this for THUNKs, because the thunk gets
+   overwritten when it is entered, so we wouldn't be able to share
+   this SRT with other info tables that want to refer to it (see
+   [Common] below). FUNs are immutable so don't have this problem.)
+
+3. [Common] Identical SRTs can be commoned up.
+
+4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
+   refers to C (perhaps transitively), then we can omit the reference
+   to C from A.
+
+
+Note that there are many other optimisations that we could do, but
+aren't implemented. In general, we could omit any reference from an
+SRT if everything reachable from it is also reachable from the other
+fields in the SRT. Our [Filter] optimisation is a special case of
+this.
+
+Another opportunity we don't exploit is this:
+
+A = {X,Y,Z}
+B = {Y,Z}
+C = {X,B}
+
+Here we could use C = {A} and therefore [Inline] C = A.
+-}
+
+-- ---------------------------------------------------------------------
+{- Note [Invalid optimisation: shortcutting]
+
+You might think that if we have something like
+
+A's SRT = {B}
+B's SRT = {X}
+
+that we could replace the reference to B in A's SRT with X.
+
+A's SRT = {X}
+B's SRT = {X}
+
+and thereby perhaps save a little work at runtime, because we don't
+have to visit B.
+
+But this is NOT valid.
+
+Consider these cases:
+
+0. B can't be a constructor, because constructors don't have SRTs
+
+1. B is a CAF. This is the easy one. Obviously we want A's SRT to
+   point to B, so that it keeps B alive.
+
+2. B is a function.  This is the tricky one. The reason we can't
+shortcut in this case is that we aren't allowed to resurrect static
+objects.
+
+== How does this cause a problem? ==
+
+The particular case that cropped up when we tried this was #15544.
+- A is a thunk
+- B is a static function
+- X is a CAF
+- suppose we GC when A is alive, and B is not otherwise reachable.
+- B is "collected", meaning that it doesn't make it onto the static
+  objects list during this GC, but nothing bad happens yet.
+- Next, suppose we enter A, and then call B. (remember that A refers to B)
+  At the entry point to B, we GC. This puts B on the stack, as part of the
+  RET_FUN stack frame that gets pushed when we GC at a function entry point.
+- This GC will now reach B
+- But because B was previous "collected", it breaks the assumption
+  that static objects are never resurrected. See Note [STATIC_LINK
+  fields] in rts/sm/Storage.h for why this is bad.
+- In practice, the GC thinks that B has already been visited, and so
+  doesn't visit X, and catastrophe ensues.
+
+== Isn't this caused by the RET_FUN business? ==
+
+Maybe, but could you prove that RET_FUN is the only way that
+resurrection can occur?
+
+So, no shortcutting.
+-}
+
+-- ---------------------------------------------------------------------
+-- Label types
+
+-- Labels that come from cafAnal can be:
+--   - _closure labels for static functions or CAFs
+--   - _info labels for dynamic functions, thunks, or continuations
+--   - _entry labels for functions or thunks
+--
+-- Meanwhile the labels on top-level blocks are _entry labels.
+--
+-- To put everything in the same namespace we convert all labels to
+-- closure labels using toClosureLbl.  Note that some of these
+-- labels will not actually exist; that's ok because we're going to
+-- map them to SRTEntry later, which ranges over labels that do exist.
+--
+newtype CAFLabel = CAFLabel CLabel
+  deriving (Eq,Ord,Outputable)
+
+type CAFSet = Set CAFLabel
+type CAFEnv = LabelMap CAFSet
+
+mkCAFLabel :: CLabel -> CAFLabel
+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+
+-- This is a label that we can put in an SRT.  It *must* be a closure label,
+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
+newtype SRTEntry = SRTEntry CLabel
+  deriving (Eq, Ord, Outputable)
+
+-- ---------------------------------------------------------------------
+-- CAF analysis
+
+-- |
+-- For each code block:
+--   - collect the references reachable from this code block to FUN,
+--     THUNK or RET labels for which hasCAF == True
+--
+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
+--
+cafAnal
+  :: LabelSet   -- The blocks representing continuations, ie. those
+                -- that will get RET info tables.  These labels will
+                -- get their own SRTs, so we don't aggregate CAFs from
+                -- references to these labels, we just use the label.
+  -> CLabel     -- The top label of the proc
+  -> CmmGraph
+  -> CAFEnv
+cafAnal contLbls topLbl cmmGraph =
+  analyzeCmmBwd cafLattice
+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+
+
+cafLattice :: DataflowLattice CAFSet
+cafLattice = DataflowLattice Set.empty add
+  where
+    add (OldFact old) (NewFact new) =
+        let !new' = old `Set.union` new
+        in changedIf (Set.size new' > Set.size old) new'
+
+
+cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers contLbls entry topLbl
+  (BlockCC eNode middle xNode) fBase =
+    let joined = cafsInNode xNode $! live'
+        !result = foldNodesBwdOO cafsInNode middle joined
+
+        facts = mapMaybe successorFact (successors xNode)
+        live' = joinFacts cafLattice facts
+
+        successorFact s
+          -- If this is a loop back to the entry, we can refer to the
+          -- entry label.
+          | s == entry = Just (add topLbl Set.empty)
+          -- If this is a continuation, we want to refer to the
+          -- SRT for the continuation's info table
+          | s `setMember` contLbls
+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
+          -- Otherwise, takes the CAF references from the destination
+          | otherwise
+          = lookupFact s fBase
+
+        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+        cafsInNode node set = foldExpDeep addCaf node set
+
+        addCaf expr !set =
+          case expr of
+              CmmLit (CmmLabel c) -> add c set
+              CmmLit (CmmLabelOff c _) -> add c set
+              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set
+              _ -> set
+        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s
+                | otherwise = s
+
+    in mapSingleton (entryLabel eNode) result
+
+
+-- -----------------------------------------------------------------------------
+-- ModuleSRTInfo
+
+data ModuleSRTInfo = ModuleSRTInfo
+  { thisModule :: Module
+    -- ^ Current module being compiled. Required for calling labelDynamic.
+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
+    -- ^ previous SRTs we've emitted, so we can de-duplicate.
+    -- Used to implement the [Common] optimisation.
+  , flatSRTs :: Map SRTEntry (Set SRTEntry)
+    -- ^ The reverse mapping, so that we can remove redundant
+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
+    -- points to [c,d], we can omit c and emit [a,b].
+    -- Used to implement the [Filter] optimisation.
+  }
+instance Outputable ModuleSRTInfo where
+  ppr ModuleSRTInfo{..} =
+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
+
+emptySRT :: Module -> ModuleSRTInfo
+emptySRT mod =
+  ModuleSRTInfo
+    { thisModule = mod
+    , dedupSRTs = Map.empty
+    , flatSRTs = Map.empty }
+
+-- -----------------------------------------------------------------------------
+-- Constructing SRTs
+
+{- Implementation notes
+
+- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
+
+- The entry in info_tbls corresponding to g_entry is the closure info
+  table, the rest are continuations.
+
+- Each entry in info_tbls possibly needs an SRT.  We need to make a
+  label for each of these.
+
+- We get the CAFSet for each entry from the CAFEnv
+
+-}
+
+-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
+--   where the label is
+--   - the info label for a continuation or dynamic closure
+--   - the closure label for a top-level function (not a CAF)
+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
+getLabelledBlocks (CmmData _ _) = []
+getLabelledBlocks (CmmProc top_info _ _ _) =
+  [ (blockId, mkCAFLabel (cit_lbl info))
+  | (blockId, info) <- mapToList (info_tbls top_info)
+  , let rep = cit_rep info
+  , not (isStaticRep rep) || not (isThunkRep rep)
+  ]
+
+
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order.  This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs. CAFs themselves are not included here; see getCAFs below.
+depAnalSRTs
+  :: CAFEnv
+  -> [CmmDecl]
+  -> [SCC (Label, CAFLabel, Set CAFLabel)]
+depAnalSRTs cafEnv decls =
+  srtTrace "depAnalSRTs" (ppr graph) graph
+ where
+  labelledBlocks = concatMap getLabelledBlocks decls
+  labelToBlock = Map.fromList (map swap labelledBlocks)
+  graph = stronglyConnCompFromEdgedVerticesOrd
+             [ let cafs' = Set.delete lbl cafs in
+               DigraphNode (l,lbl,cafs') l
+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+             | (l, lbl) <- labelledBlocks
+             , Just cafs <- [mapLookup l cafEnv] ]
+
+
+-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
+-- These are treated differently from other labelled blocks:
+--  - we never shortcut a reference to a CAF to the contents of its
+--    SRT, since the point of SRTs is to keep CAFs alive.
+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
+--    instead we generate their SRTs after everything else.
+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs cafEnv decls =
+  [ (g_entry g, mkCAFLabel topLbl, cafs)
+  | CmmProc top_info topLbl _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , let rep = cit_rep info
+  , isStaticRep rep && isThunkRep rep
+  , Just cafs <- [mapLookup (g_entry g) cafEnv]
+  ]
+
+
+-- | Get the list of blocks that correspond to the entry points for
+-- FUN_STATIC closures.  These are the blocks for which if we have an
+-- SRT we can merge it with the static closure. [FUN]
+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
+getStaticFuns decls =
+  [ (g_entry g, lbl)
+  | CmmProc top_info _ _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , Just (id, _) <- [cit_clo info]
+  , let rep = cit_rep info
+  , isStaticRep rep && isFunRep rep
+  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+  ]
+
+
+-- | Maps labels from 'cafAnal' to the final CLabel that will appear
+-- in the SRT.
+--   - closures with singleton SRTs resolve to their single entry
+--   - closures with larger SRTs map to the label for that SRT
+--   - CAFs must not map to anything!
+--   - if a labels maps to Nothing, we found that this label's SRT
+--     is empty, so we don't need to refer to it from other SRTs.
+type SRTMap = Map CAFLabel (Maybe SRTEntry)
+
+-- | resolve a CAFLabel to its SRTEntry using the SRTMap
+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF srtMap lbl@(CAFLabel l) =
+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
+
+
+-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
+-- declarations to the ModuleSRTInfo.
+--
+doSRTs
+  :: DynFlags
+  -> ModuleSRTInfo
+  -> [(CAFEnv, [CmmDecl])]
+  -> IO (ModuleSRTInfo, [CmmDecl])
+
+doSRTs dflags moduleSRTInfo tops = do
+  us <- mkSplitUniqSupply 'u'
+
+  -- Ignore the original grouping of decls, and combine all the
+  -- CAFEnvs into a single CAFEnv.
+  let (cafEnvs, declss) = unzip tops
+      cafEnv = mapUnions cafEnvs
+      decls = concat declss
+      staticFuns = mapFromList (getStaticFuns decls)
+
+  -- Put the decls in dependency order. Why? So that we can implement
+  -- [Inline] and [Filter].  If we need to refer to an SRT that has
+  -- a single entry, we use the entry itself, which means that we
+  -- don't need to generate the singleton SRT in the first place.  But
+  -- to do this we need to process blocks before things that depend on
+  -- them.
+  let
+    sccs = depAnalSRTs cafEnv decls
+    cafsWithSRTs = getCAFs cafEnv decls
+
+  -- On each strongly-connected group of decls, construct the SRT
+  -- closures and the SRT fields for info tables.
+  let result ::
+        [ ( [CmmDecl]              -- generated SRTs
+          , [(Label, CLabel)]      -- SRT fields for info tables
+          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+          ) ]
+      ((result, _srtMap), moduleSRTInfo') =
+        initUs_ us $
+        flip runStateT moduleSRTInfo $
+        flip runStateT Map.empty $ do
+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs
+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs
+          return (nonCAFs ++ cAFs)
+
+      (declss, pairs, funSRTs) = unzip3 result
+
+  -- Next, update the info tables with the SRTs
+  let
+    srtFieldMap = mapFromList (concat pairs)
+    funSRTMap = mapFromList (concat funSRTs)
+    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls
+
+  return (moduleSRTInfo', concat declss ++ decls')
+
+
+-- | Build the SRT for a strongly-connected component of blocks
+doSCC
+  :: DynFlags
+  -> LabelMap CLabel           -- which blocks are static function entry points
+  -> SCC (Label, CAFLabel, Set CAFLabel)
+  -> StateT SRTMap
+        (StateT ModuleSRTInfo UniqSM)
+        ( [CmmDecl]              -- generated SRTs
+        , [(Label, CLabel)]      -- SRT fields for info tables
+        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+        )
+
+doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =
+  oneSRT dflags staticFuns [l] [cafLbl] False cafs
+
+doSCC dflags staticFuns (CyclicSCC nodes) = do
+  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
+  let (blockids, lbls, cafsets) = unzip3 nodes
+      cafs = Set.unions cafsets
+  oneSRT dflags staticFuns blockids lbls False cafs
+
+
+{- Note [recursive SRTs]
+
+If the dependency analyser has found us a recursive group of
+declarations, then we build a single SRT for the whole group, on the
+grounds that everything in the group is reachable from everything
+else, so we lose nothing by having a single SRT.
+
+However, there are a couple of wrinkles to be aware of.
+
+* The Set CAFLabel for this SRT will contain labels in the group
+itself. The SRTMap will therefore not contain entries for these labels
+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
+can just remove recursive references from the Set CAFLabel before
+generating the SRT - the SRT will still contain all the CAFLabels that
+we need to refer to from this group's SRT.
+
+* That is, EXCEPT for static function closures. For the same reason
+described in Note [Invalid optimisation: shortcutting], we cannot omit
+references to static function closures.
+  - But, since we will merge the SRT with one of the static function
+    closures (see [FUN]), we can omit references to *that* static
+    function closure from the SRT.
+-}
+
+-- | Build an SRT for a set of blocks
+oneSRT
+  :: DynFlags
+  -> LabelMap CLabel            -- which blocks are static function entry points
+  -> [Label]                    -- blocks in this set
+  -> [CAFLabel]                 -- labels for those blocks
+  -> Bool                       -- True <=> this SRT is for a CAF
+  -> Set CAFLabel               -- SRT for this set
+  -> StateT SRTMap
+       (StateT ModuleSRTInfo UniqSM)
+       ( [CmmDecl]                    -- SRT objects we built
+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
+       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
+       )
+
+oneSRT dflags staticFuns blockids lbls isCAF cafs = do
+  srtMap <- get
+  topSRT <- lift get
+  let
+    -- Can we merge this SRT with a FUN_STATIC closure?
+    (maybeFunClosure, otherFunLabels) =
+      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
+        [] -> (Nothing, [])
+        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)
+
+    -- Remove recursive references from the SRT, except for (all but
+    -- one of the) static functions. See Note [recursive SRTs].
+    nonRec = cafs `Set.difference`
+      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)
+
+    -- First resolve all the CAFLabels to SRTEntries
+    -- Implements the [Inline] optimisation.
+    resolved =
+       Set.fromList $
+       catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))
+
+    -- The set of all SRTEntries in SRTs that we refer to from here.
+    allBelow =
+      Set.unions [ lbls | caf <- Set.toList resolved
+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
+
+    -- Remove SRTEntries that are also in an SRT that we refer to.
+    -- Implements the [Filter] optimisation.
+    filtered = Set.difference resolved allBelow
+
+  srtTrace "oneSRT:"
+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
+
+  let
+    isStaticFun = isJust maybeFunClosure
+
+    -- For a label without a closure (e.g. a continuation), we must
+    -- update the SRTMap for the label to point to a closure. It's
+    -- 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
+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
+        put (Map.union newSRTMap srtMap)
+
+    this_mod = thisModule topSRT
+
+  case Set.toList filtered of
+    [] -> do
+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()
+      updateSRTMap Nothing
+      return ([], [], [])
+
+    -- [Inline] - when we have only one entry there is no need to
+    -- build an SRT object at all, instead we put the singleton SRT
+    -- entry in the info table.
+    [one@(SRTEntry lbl)]
+      | -- Info tables refer to SRTs by offset (as noted in the section
+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,
+        -- when dynamic linking is used we cannot guarantee that the offset
+        -- between the SRT and the info table will fit in the offset field.
+        -- Consequently we build a singleton SRT in in this case.
+        not (labelDynamic dflags this_mod lbl)
+
+        -- MachO relocations can't express offsets between compilation units at
+        -- all, so we are always forced to build a singleton SRT in this case.
+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)
+             || isLocalCLabel this_mod lbl) -> do
+
+        -- If we have a static function closure, then it becomes the
+        -- SRT object, and everything else points to it. (the only way
+        -- we could have multiple labels here is if this is a
+        -- recursive group, see Note [recursive SRTs])
+        case maybeFunClosure of
+          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])
+            where
+              withLabels =
+                [ (b, if b == staticFunBlock then lbl else staticFunLbl)
+                | b <- blockids ]
+          Nothing -> do
+            updateSRTMap (Just one)
+            return ([], map (,lbl) blockids, [])
+
+    cafList ->
+      -- Check whether an SRT with the same entries has been emitted already.
+      -- Implements the [Common] optimisation.
+      case Map.lookup filtered (dedupSRTs topSRT) of
+        Just srtEntry@(SRTEntry srtLbl)  -> do
+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
+          updateSRTMap (Just srtEntry)
+          return ([], map (,srtLbl) blockids, [])
+        Nothing -> do
+          -- No duplicates: we have to build a new SRT object
+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
+          (decls, funSRTs, srtEntry) <-
+            case maybeFunClosure of
+              Just (fun,block) ->
+                return ( [], [(block, cafList)], SRTEntry fun )
+              Nothing -> do
+                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList
+                return (decls, [], entry)
+          updateSRTMap (Just srtEntry)
+          let allBelowThis = Set.union allBelow filtered
+              oldFlatSRTs = flatSRTs topSRT
+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
+          lift (put (topSRT { dedupSRTs = newDedupSRTs
+                            , flatSRTs = newFlatSRTs }))
+          let SRTEntry lbl = srtEntry
+          return (decls, map (,lbl) blockids, funSRTs)
+
+
+-- | build a static SRT object (or a chain of objects) from a list of
+-- SRTEntries.
+buildSRTChain
+   :: DynFlags
+   -> [SRTEntry]
+   -> UniqSM
+        ( [CmmDecl]    -- The SRT object(s)
+        , SRTEntry     -- label to use in the info table
+        )
+buildSRTChain _ [] = panic "buildSRT: empty"
+buildSRTChain dflags cafSet =
+  case splitAt mAX_SRT_SIZE cafSet of
+    (these, []) -> do
+      (decl,lbl) <- buildSRT dflags these
+      return ([decl], lbl)
+    (these,those) -> do
+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
+      return (decl:rest, lbl)
+  where
+    mAX_SRT_SIZE = 16
+
+
+buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
+buildSRT dflags refs = do
+  id <- getUniqueM
+  let
+    lbl = mkSRTLabel id
+    srt_n_info = mkSRTInfoLabel (length refs)
+    fields =
+      mkStaticClosure dflags srt_n_info dontCareCCS
+        [ CmmLabel lbl | SRTEntry lbl <- refs ]
+        [] -- no padding
+        [mkIntCLit dflags 0] -- link field
+        [] -- no saved info
+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
+
+
+-- | Update info tables with references to their SRTs. Also generate
+-- static closures, splicing in SRT fields as necessary.
+updInfoSRTs
+  :: DynFlags
+  -> LabelMap CLabel               -- SRT labels for each block
+  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
+  -> CmmDecl
+  -> [CmmDecl]
+
+updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)
+  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
+  | otherwise = [ proc ]
+  where
+    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
+    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
+    updInfoTbl l info_tbl
+      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
+      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }
+
+    -- Generate static closures [FUN].  Note that this also generates
+    -- static closures for thunks (CAFs), because it's easier to treat
+    -- them uniformly in the code generator.
+    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
+    maybeStaticClosure
+      | Just info_tbl@CmmInfoTable{..} <-
+           mapLookup (g_entry g) (info_tbls top_info)
+      , Just (id, ccs) <- cit_clo
+      , isStaticRep cit_rep =
+        let
+          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
+            Nothing ->
+              -- if we don't add SRT entries to this closure, then we
+              -- want to set the srt field in its info table as usual
+              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
+            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
+              (info_tbl { cit_rep = new_rep }, res)
+              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
+          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)
+            srtEntries
+          new_rep = case cit_rep of
+             HeapRep sta ptrs nptrs ty ->
+               HeapRep sta (ptrs + length srtEntries) nptrs ty
+             _other -> panic "maybeStaticFun"
+          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+        in
+          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
+      | otherwise = Nothing
+
+updInfoSRTs _ _ _ t = [t]
+
+
+srtTrace :: String -> SDoc -> b -> b
+-- srtTrace = pprTrace
+srtTrace _ _ b = b
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmCallConv.hs
@@ -0,0 +1,212 @@
+module CmmCallConv (
+  ParamLocation(..),
+  assignArgumentsPos,
+  assignStack,
+  realArgRegsCover
+) where
+
+import GhcPrelude
+
+import CmmExpr
+import SMRep
+import Cmm (Convention(..))
+import PprCmm ()
+
+import DynFlags
+import Platform
+import Outputable
+
+-- Calculate the 'GlobalReg' or stack locations for function call
+-- parameters as used by the Cmm calling convention.
+
+data ParamLocation
+  = RegisterParam GlobalReg
+  | StackParam ByteOff
+
+instance Outputable ParamLocation where
+  ppr (RegisterParam g) = ppr g
+  ppr (StackParam p)    = ppr p
+
+-- |
+-- Given a list of arguments, and a function that tells their types,
+-- return a list showing where each argument is passed
+--
+assignArgumentsPos :: DynFlags
+                   -> ByteOff           -- stack offset to start with
+                   -> Convention
+                   -> (a -> CmmType)    -- how to get a type from an arg
+                   -> [a]               -- args
+                   -> (
+                        ByteOff              -- bytes of stack args
+                      , [(a, ParamLocation)] -- args and locations
+                      )
+
+assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
+    where
+      regs = case (reps, conv) of
+               (_,   NativeNodeCall)   -> getRegsWithNode dflags
+               (_,   NativeDirectCall) -> getRegsWithoutNode dflags
+               ([_], NativeReturn)     -> allRegs dflags
+               (_,   NativeReturn)     -> getRegsWithNode dflags
+               -- GC calling convention *must* put values in registers
+               (_,   GC)               -> allRegs dflags
+               (_,   Slow)             -> nodeOnly
+      -- The calling conventions first assign arguments to registers,
+      -- then switch to the stack when we first run out of registers
+      -- (even if there are still available registers for args of a
+      -- different type).  When returning an unboxed tuple, we also
+      -- separate the stack arguments by pointerhood.
+      (reg_assts, stk_args)  = assign_regs [] reps regs
+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args
+      assignments = reg_assts ++ stk_assts
+
+      assign_regs assts []     _    = (assts, [])
+      assign_regs assts (r:rs) regs | isVecType ty   = vec
+                                    | isFloatType ty = float
+                                    | otherwise      = int
+        where vec = case (w, regs) of
+                      (W128, (vs, fs, ds, ls, s:ss))
+                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
+                      (W256, (vs, fs, ds, ls, s:ss))
+                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
+                      (W512, (vs, fs, ds, ls, s:ss))
+                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
+                      _ -> (assts, (r:rs))
+              float = case (w, regs) of
+                        (W32, (vs, fs, ds, ls, s:ss))
+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
+                        (W32, (vs, f:fs, ds, ls, ss))
+                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))
+                        (W64, (vs, fs, ds, ls, s:ss))
+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
+                        (W64, (vs, fs, d:ds, ls, ss))
+                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))
+                        _ -> (assts, (r:rs))
+              int = case (w, regs) of
+                      (W128, _) -> panic "W128 unsupported register type"
+                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
+                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
+                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
+                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))
+                      _   -> (assts, (r:rs))
+              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
+              ty = arg_ty r
+              w  = typeWidth ty
+              gcp | isGcPtrType ty = VGcPtr
+                  | otherwise      = VNonGcPtr
+              passFloatInXmm = passFloatArgsInXmm dflags
+
+passFloatArgsInXmm :: DynFlags -> Bool
+passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
+                              ArchX86_64 -> True
+                              ArchX86    -> False
+                              _          -> False
+
+-- We used to spill vector registers to the stack since the LLVM backend didn't
+-- support vector registers in its calling convention. However, this has now
+-- been fixed. This function remains only as a convenient way to re-enable
+-- spilling when debugging code generation.
+passVectorInReg :: Width -> DynFlags -> Bool
+passVectorInReg _ _ = True
+
+assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+            -> (
+                 ByteOff              -- bytes of stack args
+               , [(a, ParamLocation)] -- args and locations
+               )
+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+ where
+      assign_stk offset assts [] = (offset, assts)
+      assign_stk offset assts (r:rs)
+        = assign_stk off' ((r, StackParam off') : assts) rs
+        where w    = typeWidth (arg_ty r)
+              off' = offset + size
+              -- Stack arguments always take a whole number of words, we never
+              -- pack them unlike constructor fields.
+              size = roundUpToWords dflags (widthInBytes w)
+
+-----------------------------------------------------------------------------
+-- Local information about the registers available
+
+type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
+                 , [GlobalReg]   -- floats
+                 , [GlobalReg]   -- doubles
+                 , [GlobalReg]   -- longs (int64 and word64)
+                 , [Int]         -- XMM (floats and doubles)
+                 )
+
+-- Vanilla registers can contain pointers, Ints, Chars.
+-- Floats and doubles have separate register supplies.
+--
+-- We take these register supplies from the *real* registers, i.e. those
+-- that are guaranteed to map to machine registers.
+
+getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
+getRegsWithoutNode dflags =
+  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
+  , realFloatRegs dflags
+  , realDoubleRegs dflags
+  , realLongRegs dflags
+  , realXmmRegNos dflags)
+
+-- getRegsWithNode uses R1/node even if it isn't a register
+getRegsWithNode dflags =
+  ( if null (realVanillaRegs dflags)
+    then [VanillaReg 1]
+    else realVanillaRegs dflags
+  , realFloatRegs dflags
+  , realDoubleRegs dflags
+  , realLongRegs dflags
+  , realXmmRegNos dflags)
+
+allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
+allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+allXmmRegs :: DynFlags -> [Int]
+
+allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
+allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)
+allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)
+allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)
+allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)
+
+realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
+realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+realXmmRegNos :: DynFlags -> [Int]
+
+realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
+realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)
+realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)
+realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)
+
+realXmmRegNos dflags
+    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)
+    | otherwise            = []
+
+regList :: Int -> [Int]
+regList n = [1 .. n]
+
+allRegs :: DynFlags -> AvailRegs
+allRegs dflags = (allVanillaRegs dflags,
+                  allFloatRegs dflags,
+                  allDoubleRegs dflags,
+                  allLongRegs dflags,
+                  allXmmRegs dflags)
+
+nodeOnly :: AvailRegs
+nodeOnly = ([VanillaReg 1], [], [], [], [])
+
+-- This returns the set of global registers that *cover* the machine registers
+-- used for argument passing. On platforms where registers can overlap---right
+-- now just x86-64, where Float and Double registers overlap---passing this set
+-- of registers is guaranteed to preserve the contents of all live registers. We
+-- only use this functionality in hand-written C-- code in the RTS.
+realArgRegsCover :: DynFlags -> [GlobalReg]
+realArgRegsCover dflags
+    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
+                                  realLongRegs dflags ++
+                                  map XmmReg (realXmmRegNos dflags)
+    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++
+                                  realFloatRegs dflags ++
+                                  realDoubleRegs dflags ++
+                                  realLongRegs dflags ++
+                                  map XmmReg (realXmmRegNos dflags)
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -0,0 +1,321 @@
+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+
+module CmmCommonBlockElim
+  ( elimCommonBlocks
+  )
+where
+
+
+import GhcPrelude hiding (iterate, succ, unzip, zip)
+
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch (eqSwitchTargetWith)
+import CmmContFlowOpt
+-- import PprCmm ()
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+import Data.Bits
+import Data.Maybe (mapMaybe)
+import qualified Data.List as List
+import Data.Word
+import qualified Data.Map as M
+import Outputable
+import qualified TrieMap as TM
+import UniqFM
+import Unique
+import Control.Arrow (first, second)
+
+-- -----------------------------------------------------------------------------
+-- Eliminate common blocks
+
+-- If two blocks are identical except for the label on the first node,
+-- then we can eliminate one of the blocks. To ensure that the semantics
+-- of the program are preserved, we have to rewrite each predecessor of the
+-- eliminated block to proceed with the block we keep.
+
+-- The algorithm iterates over the blocks in the graph,
+-- checking whether it has seen another block that is equal modulo labels.
+-- If so, then it adds an entry in a map indicating that the new block
+-- is made redundant by the old block.
+-- Otherwise, it is added to the useful blocks.
+
+-- To avoid comparing every block with every other block repeatedly, we group
+-- them by
+--   * a hash of the block, ignoring labels (explained below)
+--   * the list of outgoing labels
+-- The hash is invariant under relabeling, so we only ever compare within
+-- the same group of blocks.
+--
+-- The list of outgoing labels is updated as we merge blocks (that is why they
+-- are not included in the hash, which we want to calculate only once).
+--
+-- All in all, two blocks should never be compared if they have different
+-- hashes, and at most once otherwise. Previously, we were slower, and people
+-- rightfully complained: #10397
+
+-- TODO: Use optimization fuel
+elimCommonBlocks :: CmmGraph -> CmmGraph
+elimCommonBlocks g = replaceLabels env $ copyTicks env g
+  where
+     env = iterate mapEmpty blocks_with_key
+     -- The order of blocks doesn't matter here. While we could use
+     -- revPostorder which drops unreachable blocks this is done in
+     -- ContFlowOpt already which runs before this pass. So we use
+     -- toBlockList since it is faster.
+     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
+
+-- Invariant: The blocks in the list are pairwise distinct
+-- (so avoid comparing them again)
+type DistinctBlocks = [CmmBlock]
+type Key = [Label]
+type Subst = LabelMap BlockId
+
+-- The outer list groups by hash. We retain this grouping throughout.
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
+    | mapNull new_substs = subst
+    | otherwise = iterate subst' updated_blocks
+  where
+    grouped_blocks :: [[(Key, [DistinctBlocks])]]
+    grouped_blocks = map groupByLabel blocks
+
+    merged_blocks :: [[(Key, DistinctBlocks)]]
+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+      where
+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
+          where
+            (new_subst2, db) = mergeBlockList subst dbs
+
+    subst' = subst `mapUnion` new_substs
+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
+
+-- Combine two lists of blocks.
+-- While they are internally distinct they can still share common blocks.
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
+  where
+    go [] = (mapEmpty, existing)
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
+mergeBlockList _ [] = pprPanic "mergeBlockList" empty
+mergeBlockList subst (b:bs) = go mapEmpty b bs
+  where
+    go !new_subst1 b [] = (new_subst1, b)
+    go !new_subst1 b1 (b2:bs) = go new_subst b bs
+      where
+        (new_subst2, b) =  mergeBlocks subst b1 b2
+        new_subst = new_subst1 `mapUnion` new_subst2
+
+
+-- -----------------------------------------------------------------------------
+-- Hashing and equality on blocks
+
+-- Below here is mostly boilerplate: hashing blocks ignoring labels,
+-- and comparing blocks modulo a label mapping.
+
+-- To speed up comparisons, we hash each basic block modulo jump labels.
+-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
+-- but it should be fast and good enough.
+
+-- We want to get as many small buckets as possible, as comparing blocks is
+-- expensive. So include as much as possible in the hash. Ideally everything
+-- that is compared with (==) in eqBlockBodyWith.
+
+type HashCode = Int
+
+hash_block :: CmmBlock -> HashCode
+hash_block block =
+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
+  -- UniqFM doesn't like negative Ints
+  where hash_fst _ h = h
+        hash_mid m h = hash_node m + h `shiftL` 1
+        hash_lst m h = hash_node m + h `shiftL` 1
+
+        hash_node :: CmmNode O x -> Word32
+        hash_node n | dont_care n = 0 -- don't care
+        hash_node (CmmAssign r e) = hash_reg r + hash_e e
+        hash_node (CmmStore e e') = hash_e e + hash_e e'
+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
+        hash_node (CmmBranch _) = 23 -- NB. ignore the label
+        hash_node (CmmCondBranch p _ _ _) = hash_e p
+        hash_node (CmmCall e _ _ _ _ _) = hash_e e
+        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
+        hash_node (CmmSwitch e _) = hash_e e
+        hash_node _ = error "hash_node: unknown Cmm node!"
+
+        hash_reg :: CmmReg -> Word32
+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
+        hash_reg   (CmmGlobal _)    = 19
+
+        hash_e :: CmmExpr -> Word32
+        hash_e (CmmLit l) = hash_lit l
+        hash_e (CmmLoad e _) = 67 + hash_e e
+        hash_e (CmmReg r) = hash_reg r
+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
+        hash_e (CmmRegOff r i) = hash_reg r + cvt i
+        hash_e (CmmStackSlot _ _) = 13
+
+        hash_lit :: CmmLit -> Word32
+        hash_lit (CmmInt i _) = fromInteger i
+        hash_lit (CmmFloat r _) = truncate r
+        hash_lit (CmmVec ls) = hash_list hash_lit ls
+        hash_lit (CmmLabel _) = 119 -- ugh
+        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
+        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i
+        hash_lit (CmmBlock _) = 191 -- ugh
+        hash_lit (CmmHighStackMark) = cvt 313
+
+        hash_tgt (ForeignTarget e _) = hash_e e
+        hash_tgt (PrimTarget _) = 31 -- lots of these
+
+        hash_list f = foldl' (\z x -> f x + z) (0::Word32)
+
+        cvt = fromInteger . toInteger
+
+        hash_unique :: Uniquable a => a -> Word32
+        hash_unique = cvt . getKey . getUnique
+
+-- | Ignore these node types for equality
+dont_care :: CmmNode O x -> Bool
+dont_care CmmComment {}  = True
+dont_care CmmTick {}     = True
+dont_care CmmUnwind {}   = True
+dont_care _other         = False
+
+-- Utilities: equality and substitution on the graph.
+
+-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
+eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
+eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
+lookupBid :: LabelMap BlockId -> BlockId -> BlockId
+lookupBid subst bid = case mapLookup bid subst of
+                        Just bid  -> lookupBid subst bid
+                        Nothing -> bid
+
+-- Middle nodes and expressions can contain BlockIds, in particular in
+-- CmmStackSlot and CmmBlock, so we have to use a special equality for
+-- these.
+--
+eqMiddleWith :: (BlockId -> BlockId -> Bool)
+             -> CmmNode O O -> CmmNode O O -> Bool
+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
+  = r1 == r2 && eqExprWith eqBid e1 e2
+eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
+  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
+eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
+                   (CmmUnsafeForeignCall t2 r2 a2)
+  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2
+eqMiddleWith _ _ _ = False
+
+eqExprWith :: (BlockId -> BlockId -> Bool)
+           -> CmmExpr -> CmmExpr -> Bool
+eqExprWith eqBid = eq
+ where
+  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
+  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
+  CmmReg r1          `eq` CmmReg r2          = r1==r2
+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
+  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
+  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
+  _e1                `eq` _e2                = False
+
+  xs `eqs` ys = eqListWith eq xs ys
+
+  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
+  eqLit l1 l2 = l1 == l2
+
+  eqArea Old Old = True
+  eqArea (Young id1) (Young id2) = eqBid id1 id2
+  eqArea _ _ = False
+
+-- Equality on the body of a block, modulo a function mapping block
+-- IDs to block IDs.
+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
+eqBlockBodyWith eqBid block block'
+  {-
+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
+  -}
+  = equal
+  where (_,m,l)   = blockSplit block
+        nodes     = filter (not . dont_care) (blockToList m)
+        (_,m',l') = blockSplit block'
+        nodes'    = filter (not . dont_care) (blockToList m')
+
+        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&
+                eqLastWith eqBid l l'
+
+
+eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
+eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
+eqLastWith _ _ _ = False
+
+eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
+eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
+eqMaybeWith _ Nothing Nothing = True
+eqMaybeWith _ _ _ = False
+
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs
+eqListWith _ []       []       = True
+eqListWith _ _        _        = False
+
+-- | Given a block map, ensure that all "target" blocks are covered by
+-- the same ticks as the respective "source" blocks. This not only
+-- means copying ticks, but also adjusting tick scopes where
+-- necessary.
+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
+copyTicks env g
+  | mapNull env = g
+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
+  where -- Reverse block merge map
+        blockMap = toBlockMap g
+        revEnv = mapFoldlWithKey insertRev M.empty env
+        insertRev m k x = M.insertWith (const (k:)) x [k] m
+        -- Copy ticks and scopes into the given block
+        copyTo block = case M.lookup (entryLabel block) revEnv of
+          Nothing -> block
+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
+        copy from to =
+          let ticks = blockTicks from
+              CmmEntry  _   scp0        = firstNode from
+              (CmmEntry lbl scp1, code) = blockSplitHead to
+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
+             foldr blockCons code (map CmmTick ticks)
+
+-- Group by [Label]
+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
+groupByLabel =
+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
+    where
+      go !m [] = TM.foldTM (:) m []
+      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
+        where --k' = map (getKey . getUnique) k
+              adjust Nothing       = Just (k,[v])
+              adjust (Just (_,vs)) = Just (k,v:vs)
+
+groupByInt :: (a -> Int) -> [a] -> [[a]]
+groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
+   -- See Note [Unique Determinism and code generation]
+  where
+    go m x = alterUFM addEntry m (f x)
+      where
+        addEntry xs = Just $! maybe [x] (x:) xs
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -0,0 +1,444 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+module CmmContFlowOpt
+    ( cmmCfgOpts
+    , cmmCfgOptsProc
+    , removeUnreachableBlocksProc
+    , replaceLabels
+    )
+where
+
+import GhcPrelude hiding (succ, unzip, zip)
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch (mapSwitchTargets)
+import Maybes
+import Panic
+import Util
+
+import Control.Monad
+
+
+-- Note [What is shortcutting]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider this Cmm code:
+--
+-- L1: ...
+--     goto L2;
+-- L2: goto L3;
+-- L3: ...
+--
+-- Here L2 is an empty block and contains only an unconditional branch
+-- to L3. In this situation any block that jumps to L2 can jump
+-- directly to L3:
+--
+-- L1: ...
+--     goto L3;
+-- L2: goto L3;
+-- L3: ...
+--
+-- In this situation we say that we shortcut L2 to L3. One of
+-- consequences of shortcutting is that some blocks of code may become
+-- unreachable (in the example above this is true for L2).
+
+
+-- Note [Control-flow optimisations]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- This optimisation does three things:
+--
+--   - If a block finishes in an unconditional branch to another block
+--     and that is the only jump to that block we concatenate the
+--     destination block at the end of the current one.
+--
+--   - If a block finishes in a call whose continuation block is a
+--     goto, then we can shortcut the destination, making the
+--     continuation block the destination of the goto - but see Note
+--     [Shortcut call returns].
+--
+--   - For any block that is not a call we try to shortcut the
+--     destination(s). Additionally, if a block ends with a
+--     conditional branch we try to invert the condition.
+--
+-- Blocks are processed using postorder DFS traversal. A side effect
+-- of determining traversal order with a graph search is elimination
+-- of any blocks that are unreachable.
+--
+-- Transformations are improved by working from the end of the graph
+-- towards the beginning, because we may be able to perform many
+-- shortcuts in one go.
+
+
+-- Note [Shortcut call returns]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We are going to maintain the "current" graph (LabelMap CmmBlock) as
+-- we go, and also a mapping from BlockId to BlockId, representing
+-- continuation labels that we have renamed.  This latter mapping is
+-- important because we might shortcut a CmmCall continuation.  For
+-- example:
+--
+--    Sp[0] = L
+--    call g returns to L
+--    L: goto M
+--    M: ...
+--
+-- So when we shortcut the L block, we need to replace not only
+-- the continuation of the call, but also references to L in the
+-- code (e.g. the assignment Sp[0] = L):
+--
+--    Sp[0] = M
+--    call g returns to M
+--    M: ...
+--
+-- So we keep track of which labels we have renamed and apply the mapping
+-- at the end with replaceLabels.
+
+
+-- Note [Shortcut call returns and proc-points]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider this code that you might get from a recursive
+-- let-no-escape:
+--
+--       goto L1
+--      L1:
+--       if (Hp > HpLim) then L2 else L3
+--      L2:
+--       call stg_gc_noregs returns to L4
+--      L4:
+--       goto L1
+--      L3:
+--       ...
+--       goto L1
+--
+-- Then the control-flow optimiser shortcuts L4.  But that turns L1
+-- into the call-return proc point, and every iteration of the loop
+-- has to shuffle variables to and from the stack.  So we must *not*
+-- shortcut L4.
+--
+-- Moreover not shortcutting call returns is probably fine.  If L4 can
+-- concat with its branch target then it will still do so.  And we
+-- save some compile time because we don't have to traverse all the
+-- code in replaceLabels.
+--
+-- However, we probably do want to do this if we are splitting proc
+-- points, because L1 will be a proc-point anyway, so merging it with
+-- L4 reduces the number of proc points.  Unfortunately recursive
+-- let-no-escapes won't generate very good code with proc-point
+-- splitting on - we should probably compile them to explicitly use
+-- the native calling convention instead.
+
+cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
+cmmCfgOpts split g = fst (blockConcat split g)
+
+cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
+cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
+    where (g', env) = blockConcat split g
+          info' = info{ info_tbls = new_info_tbls }
+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
+
+          -- If we changed any labels, then we have to update the info tables
+          -- too, except for the top-level info table because that might be
+          -- referred to by other procs.
+          upd_info (k,info)
+             | Just k' <- mapLookup k env
+             = (k', if k' == g_entry g'
+                       then info
+                       else info{ cit_lbl = infoTblLbl k' })
+             | otherwise
+             = (k,info)
+cmmCfgOptsProc _ top = top
+
+
+blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
+blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
+  where
+     -- We might be able to shortcut the entry BlockId itself.
+     -- Remember to update the shortcut_map, since we also have to
+     -- update the info_tbls mapping now.
+     (new_entry, shortcut_map')
+       | Just entry_blk <- mapLookup entry_id new_blocks
+       , Just dest      <- canShortcut entry_blk
+       = (dest, mapInsert entry_id dest shortcut_map)
+       | otherwise
+       = (entry_id, shortcut_map)
+
+     -- blocks are sorted in reverse postorder, but we want to go from the exit
+     -- towards beginning, so we use foldr below.
+     blocks = revPostorder g
+     blockmap = foldl' (flip addBlock) emptyBody blocks
+
+     -- Accumulator contains three components:
+     --  * map of blocks in a graph
+     --  * map of shortcut labels. See Note [Shortcut call returns]
+     --  * map containing number of predecessors for each block. We discard
+     --    it after we process all blocks.
+     (new_blocks, shortcut_map, _) =
+           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks
+
+     -- Map of predecessors for initial graph. We increase number of
+     -- predecessors for entry block by one to denote that it is
+     -- target of a jump, even if no block in the current graph jumps
+     -- to it.
+     initialBackEdges = incPreds entry_id (predMap blocks)
+
+     maybe_concat :: CmmBlock
+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+     maybe_concat block (!blocks, !shortcut_map, !backEdges)
+        -- If:
+        --   (1) current block ends with unconditional branch to b' and
+        --   (2) it has exactly one predecessor (namely, current block)
+        --
+        -- Then:
+        --   (1) append b' block at the end of current block
+        --   (2) remove b' from the map of blocks
+        --   (3) remove information about b' from predecessors map
+        --
+        -- Since we know that the block has only one predecessor we call
+        -- mapDelete directly instead of calling decPreds.
+        --
+        -- Note that we always maintain an up-to-date list of predecessors, so
+        -- we can ignore the contents of shortcut_map
+        | CmmBranch b' <- last
+        , hasOnePredecessor b'
+        , Just blk' <- mapLookup b' blocks
+        = let bid' = entryLabel blk'
+          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks
+             , shortcut_map
+             , mapDelete b' backEdges )
+
+        -- If:
+        --   (1) we are splitting proc points (see Note
+        --       [Shortcut call returns and proc-points]) and
+        --   (2) current block is a CmmCall or CmmForeignCall with
+        --       continuation b' and
+        --   (3) we can shortcut that continuation to dest
+        -- Then:
+        --   (1) we change continuation to point to b'
+        --   (2) create mapping from b' to dest
+        --   (3) increase number of predecessors of dest by 1
+        --   (4) decrease number of predecessors of b' by 1
+        --
+        -- Later we will use replaceLabels to substitute all occurrences of b'
+        -- with dest.
+        | splitting_procs
+        , Just b'   <- callContinuation_maybe last
+        , Just blk' <- mapLookup b' blocks
+        , Just dest <- canShortcut blk'
+        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks
+          , mapInsert b' dest shortcut_map
+          , decPreds b' $ incPreds dest backEdges )
+
+        -- If:
+        --   (1) a block does not end with a call
+        -- Then:
+        --   (1) if it ends with a conditional attempt to invert the
+        --       conditional
+        --   (2) attempt to shortcut all destination blocks
+        --   (3) if new successors of a block are different from the old ones
+        --       update the of predecessors accordingly
+        --
+        -- A special case of this is a situation when a block ends with an
+        -- unconditional jump to a block that can be shortcut.
+        | Nothing <- callContinuation_maybe last
+        = let oldSuccs = successors last
+              newSuccs = successors rewrite_last
+          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks
+             , shortcut_map
+             , if oldSuccs == newSuccs
+               then backEdges
+               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )
+
+        -- Otherwise don't do anything
+        | otherwise
+        = ( blocks, shortcut_map, backEdges )
+        where
+          (head, last) = blockSplitTail block
+          bid = entryLabel block
+
+          -- Changes continuation of a call to a specified label
+          update_cont dest =
+              case last of
+                CmmCall{}        -> last { cml_cont = Just dest }
+                CmmForeignCall{} -> last { succ = dest }
+                _                -> panic "Can't shortcut continuation."
+
+          -- Attempts to shortcut successors of last node
+          shortcut_last = mapSuccessors shortcut last
+            where
+              shortcut l =
+                 case mapLookup l blocks of
+                   Just b | Just dest <- canShortcut b -> dest
+                   _otherwise -> l
+
+          rewrite_last
+            -- Sometimes we can get rid of the conditional completely.
+            | CmmCondBranch _cond t f _l <- shortcut_last
+            , t == f
+            = CmmBranch t
+
+            -- See Note [Invert Cmm conditionals]
+            | CmmCondBranch cond t f l <- shortcut_last
+            , hasOnePredecessor t -- inverting will make t a fallthrough
+            , likelyTrue l || (numPreds f > 1)
+            , Just cond' <- maybeInvertCmmExpr cond
+            = CmmCondBranch cond' f t (invertLikeliness l)
+
+            | otherwise
+            = shortcut_last
+
+          likelyTrue (Just True)   = True
+          likelyTrue _             = False
+
+          invertLikeliness :: Maybe Bool -> Maybe Bool
+          invertLikeliness         = fmap not
+
+          -- Number of predecessors for a block
+          numPreds bid = mapLookup bid backEdges `orElse` 0
+
+          hasOnePredecessor b = numPreds b == 1
+
+{-
+  Note [Invert Cmm conditionals]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  The native code generator always produces jumps to the true branch.
+  Falling through to the false branch is however faster. So we try to
+  arrange for that to happen.
+  This means we invert the condition if:
+  * The likely path will become a fallthrough.
+  * We can't guarantee a fallthrough for the false branch but for the
+    true branch.
+
+  In some cases it's faster to avoid inverting when the false branch is likely.
+  However determining when that is the case is neither easy nor cheap so for
+  now we always invert as this produces smaller binaries and code that is
+  equally fast on average. (On an i7-6700K)
+
+  TODO:
+  There is also the edge case when both branches have multiple predecessors.
+  In this case we could assume that we will end up with a jump for BOTH
+  branches. In this case it might be best to put the likely path in the true
+  branch especially if there are large numbers of predecessors as this saves
+  us the jump thats not taken. However I haven't tested this and as of early
+  2018 we almost never generate cmm where this would apply.
+-}
+
+-- Functions for incrementing and decrementing number of predecessors. If
+-- decrementing would set the predecessor count to 0, we remove entry from the
+-- map.
+-- Invariant: if a block has no predecessors it should be dropped from the
+-- graph because it is unreachable. maybe_concat is constructed to maintain
+-- that invariant, but calling replaceLabels may introduce unreachable blocks.
+-- We rely on subsequent passes in the Cmm pipeline to remove unreachable
+-- blocks.
+incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
+incPreds bid edges = mapInsertWith (+) bid 1 edges
+decPreds bid edges = case mapLookup bid edges of
+                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges
+                       Just _                 -> mapDelete bid edges
+                       _                      -> edges
+
+
+-- Checks if a block consists only of "goto dest". If it does than we return
+-- "Just dest" label. See Note [What is shortcutting]
+canShortcut :: CmmBlock -> Maybe BlockId
+canShortcut block
+    | (_, middle, CmmBranch dest) <- blockSplit block
+    , all dont_care $ blockToList middle
+    = Just dest
+    | otherwise
+    = Nothing
+    where dont_care CmmComment{} = True
+          dont_care CmmTick{}    = True
+          dont_care _other       = False
+
+-- Concatenates two blocks. First one is assumed to be open on exit, the second
+-- is assumed to be closed on entry (i.e. it has a label attached to it, which
+-- the splice function removes by calling snd on result of blockSplitHead).
+splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1
+  where (CmmEntry lbl sc0, code0) = blockSplitHead head
+        (CmmEntry _   sc1, code1) = blockSplitHead rest
+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)
+
+-- If node is a call with continuation call return Just label of that
+-- continuation. Otherwise return Nothing.
+callContinuation_maybe :: CmmNode O C -> Maybe BlockId
+callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
+callContinuation_maybe (CmmForeignCall { succ = b })   = Just b
+callContinuation_maybe _ = Nothing
+
+
+-- Map over the CmmGraph, replacing each label with its mapping in the
+-- supplied LabelMap.
+replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceLabels env g
+  | mapNull env = g
+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
+   where
+     replace_eid g = g {g_entry = lookup (g_entry g)}
+     lookup id = mapLookup id env `orElse` id
+
+     txnode :: CmmNode e x -> CmmNode e x
+     txnode (CmmBranch bid) = CmmBranch (lookup bid)
+     txnode (CmmCondBranch p t f l) =
+       mkCmmCondBranch (exp p) (lookup t) (lookup f) l
+     txnode (CmmSwitch e ids) =
+       CmmSwitch (exp e) (mapSwitchTargets lookup ids)
+     txnode (CmmCall t k rg a res r) =
+       CmmCall (exp t) (liftM lookup k) rg a res r
+     txnode fc@CmmForeignCall{} =
+       fc{ args = map exp (args fc), succ = lookup (succ fc) }
+     txnode other = mapExpDeep exp other
+
+     exp :: CmmExpr -> CmmExpr
+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
+     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
+     exp e                                      = e
+
+mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
+mkCmmCondBranch p t f l =
+  if t == f then CmmBranch t else CmmCondBranch p t f l
+
+-- Build a map from a block to its set of predecessors.
+predMap :: [CmmBlock] -> LabelMap Int
+predMap blocks = foldr add_preds mapEmpty blocks
+  where
+    add_preds block env = foldr add env (successors block)
+      where add lbl env = mapInsertWith (+) lbl 1 env
+
+-- Removing unreachable blocks
+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
+removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
+   | used_blocks `lengthLessThan` mapSize (toBlockMap g)
+   = CmmProc info' lbl live g'
+   | otherwise
+   = proc
+   where
+     g'    = ofBlockList (g_entry g) used_blocks
+     info' = info { info_tbls = keep_used (info_tbls info) }
+             -- Remove any info_tbls for unreachable
+
+     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
+     keep_used bs = mapFoldlWithKey keep mapEmpty bs
+
+     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
+     keep env l i | l `setMember` used_lbls = mapInsert l i env
+                  | otherwise               = env
+
+     used_blocks :: [CmmBlock]
+     used_blocks = revPostorder g
+
+     used_lbls :: LabelSet
+     used_lbls = setFromList $ map entryLabel used_blocks
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmExpr.hs
@@ -0,0 +1,619 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module CmmExpr
+    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
+    , CmmReg(..), cmmRegType, cmmRegWidth
+    , CmmLit(..), cmmLitType
+    , LocalReg(..), localRegType
+    , GlobalReg(..), isArgReg, globalRegType
+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+    , node, baseReg
+    , VGcPtr(..)
+
+    , DefinerOfRegs, UserOfRegs
+    , foldRegsDefd, foldRegsUsed
+    , foldLocalRegsDefd, foldLocalRegsUsed
+
+    , RegSet, LocalRegSet, GlobalRegSet
+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
+    , regSetToList
+
+    , Area(..)
+    , module CmmMachOp
+    , module CmmType
+    )
+where
+
+import GhcPrelude
+
+import BlockId
+import CLabel
+import CmmMachOp
+import CmmType
+import DynFlags
+import Outputable (panic)
+import Unique
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import BasicTypes (Alignment, mkAlignment, alignmentOf)
+
+-----------------------------------------------------------------------------
+--              CmmExpr
+-- An expression.  Expressions have no side effects.
+-----------------------------------------------------------------------------
+
+data CmmExpr
+  = CmmLit CmmLit               -- Literal
+  | CmmLoad !CmmExpr !CmmType   -- Read memory location
+  | CmmReg !CmmReg              -- Contents of register
+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
+  | CmmStackSlot Area {-# UNPACK #-} !Int
+                                -- addressing expression of a stack slot
+                                -- See Note [CmmStackSlot aliasing]
+  | CmmRegOff !CmmReg Int
+        -- CmmRegOff reg i
+        --        ** is shorthand only, meaning **
+        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+        --      where rep = typeWidth (cmmRegType reg)
+
+instance Eq CmmExpr where       -- Equality ignores the types
+  CmmLit l1          == CmmLit l2          = l1==l2
+  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2
+  CmmReg r1          == CmmReg r2          = r1==r2
+  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2
+  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2
+  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
+  _e1                == _e2                = False
+
+data CmmReg
+  = CmmLocal  {-# UNPACK #-} !LocalReg
+  | CmmGlobal GlobalReg
+  deriving( Eq, Ord )
+
+-- | A stack area is either the stack slot where a variable is spilled
+-- or the stack space where function arguments and results are passed.
+data Area
+  = Old            -- See Note [Old Area]
+  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId
+                   -- See Note [Continuation BlockId] in CmmNode.
+  deriving (Eq, Ord)
+
+{- Note [Old Area]
+~~~~~~~~~~~~~~~~~~
+There is a single call area 'Old', allocated at the extreme old
+end of the stack frame (ie just younger than the return address)
+which holds:
+  * incoming (overflow) parameters,
+  * outgoing (overflow) parameter to tail calls,
+  * outgoing (overflow) result values
+  * the update frame (if any)
+
+Its size is the max of all these requirements.  On entry, the stack
+pointer will point to the youngest incoming parameter, which is not
+necessarily at the young end of the Old area.
+
+End of note -}
+
+
+{- Note [CmmStackSlot aliasing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When do two CmmStackSlots alias?
+
+ - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M
+ - T[old+N] aliases with U[old+M] only if the areas actually overlap
+
+Or more informally, different Areas may overlap with each other.
+
+An alternative semantics, that we previously had, was that different
+Areas do not overlap.  The problem that lead to redefining the
+semantics of stack areas is described below.
+
+e.g. if we had
+
+    x = Sp[old + 8]
+    y = Sp[old + 16]
+
+    Sp[young(L) + 8]  = L
+    Sp[young(L) + 16] = y
+    Sp[young(L) + 24] = x
+    call f() returns to L
+
+if areas semantically do not overlap, then we might optimise this to
+
+    Sp[young(L) + 8]  = L
+    Sp[young(L) + 16] = Sp[old + 8]
+    Sp[young(L) + 24] = Sp[old + 16]
+    call f() returns to L
+
+and now young(L) cannot be allocated at the same place as old, and we
+are doomed to use more stack.
+
+  - old+8  conflicts with young(L)+8
+  - old+16 conflicts with young(L)+16 and young(L)+8
+
+so young(L)+8 == old+24 and we get
+
+    Sp[-8]  = L
+    Sp[-16] = Sp[8]
+    Sp[-24] = Sp[0]
+    Sp -= 24
+    call f() returns to L
+
+However, if areas are defined to be "possibly overlapping" in the
+semantics, then we cannot commute any loads/stores of old with
+young(L), and we will be able to re-use both old+8 and old+16 for
+young(L).
+
+    x = Sp[8]
+    y = Sp[0]
+
+    Sp[8] = L
+    Sp[0] = y
+    Sp[-8] = x
+    Sp = Sp - 8
+    call f() returns to L
+
+Now, the assignments of y go away,
+
+    x = Sp[8]
+    Sp[8] = L
+    Sp[-8] = x
+    Sp = Sp - 8
+    call f() returns to L
+-}
+
+data CmmLit
+  = CmmInt !Integer  Width
+        -- Interpretation: the 2's complement representation of the value
+        -- is truncated to the specified size.  This is easier than trying
+        -- to keep the value within range, because we don't know whether
+        -- it will be used as a signed or unsigned value (the CmmType doesn't
+        -- distinguish between signed & unsigned).
+  | CmmFloat  Rational Width
+  | CmmVec [CmmLit]                     -- Vector literal
+  | CmmLabel    CLabel                  -- Address of label
+  | CmmLabelOff CLabel Int              -- Address of label + byte offset
+
+        -- Due to limitations in the C backend, the following
+        -- MUST ONLY be used inside the info table indicated by label2
+        -- (label2 must be the info label), and label1 must be an
+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+        -- Don't use it at all unless tablesNextToCode.
+        -- It is also used inside the NCG during when generating
+        -- position-independent code.
+  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset
+        -- In an expression, the width just has the effect of MO_SS_Conv
+        -- from wordWidth to the desired width.
+        --
+        -- In a static literal, the supported Widths depend on the
+        -- architecture: wordWidth is supported on all
+        -- architectures. Additionally W32 is supported on x86_64 when
+        -- using the small memory model.
+
+  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
+        -- Invariant: must be a continuation BlockId
+        -- See Note [Continuation BlockId] in CmmNode.
+
+  | CmmHighStackMark -- A late-bound constant that stands for the max
+                     -- #bytes of stack space used during a procedure.
+                     -- During the stack-layout pass, CmmHighStackMark
+                     -- is replaced by a CmmInt for the actual number
+                     -- of bytes used
+  deriving Eq
+
+cmmExprType :: DynFlags -> CmmExpr -> CmmType
+cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit
+cmmExprType _      (CmmLoad _ rep)     = rep
+cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg
+cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
+cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg
+cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address
+-- Careful though: what is stored at the stack slot may be bigger than
+-- an address
+
+cmmLitType :: DynFlags -> CmmLit -> CmmType
+cmmLitType _      (CmmInt _ width)     = cmmBits  width
+cmmLitType _      (CmmFloat _ width)   = cmmFloat width
+cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"
+cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l
+                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
+                                            then cmmVec (1+length ls) ty
+                                            else panic "cmmLitType: CmmVec"
+cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl
+cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl
+cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width
+cmmLitType dflags (CmmBlock _)         = bWord dflags
+cmmLitType dflags (CmmHighStackMark)   = bWord dflags
+
+cmmLabelType :: DynFlags -> CLabel -> CmmType
+cmmLabelType dflags lbl
+ | isGcPtrLabel lbl = gcWord dflags
+ | otherwise        = bWord dflags
+
+cmmExprWidth :: DynFlags -> CmmExpr -> Width
+cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
+
+-- | Returns an alignment in bytes of a CmmExpr when it's a statically
+-- known integer constant, otherwise returns an alignment of 1 byte.
+-- The caller is responsible for using with a sensible CmmExpr
+-- argument.
+cmmExprAlignment :: CmmExpr -> Alignment
+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)
+cmmExprAlignment _                          = mkAlignment 1
+--------
+--- Negation for conditional branches
+
+maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
+                                            return (CmmMachOp op' args)
+maybeInvertCmmExpr _ = Nothing
+
+-----------------------------------------------------------------------------
+--              Local registers
+-----------------------------------------------------------------------------
+
+data LocalReg
+  = LocalReg {-# UNPACK #-} !Unique CmmType
+    -- ^ Parameters:
+    --   1. Identifier
+    --   2. Type
+
+instance Eq LocalReg where
+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord LocalReg where
+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
+
+instance Uniquable LocalReg where
+  getUnique (LocalReg uniq _) = uniq
+
+cmmRegType :: DynFlags -> CmmReg -> CmmType
+cmmRegType _      (CmmLocal  reg) = localRegType reg
+cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
+
+cmmRegWidth :: DynFlags -> CmmReg -> Width
+cmmRegWidth dflags = typeWidth . cmmRegType dflags
+
+localRegType :: LocalReg -> CmmType
+localRegType (LocalReg _ rep) = rep
+
+-----------------------------------------------------------------------------
+--    Register-use information for expressions and other types
+-----------------------------------------------------------------------------
+
+-- | Sets of registers
+
+-- These are used for dataflow facts, and a common operation is taking
+-- the union of two RegSets and then asking whether the union is the
+-- same as one of the inputs.  UniqSet isn't good here, because
+-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
+-- Sets.
+
+type RegSet r     = Set r
+type LocalRegSet  = RegSet LocalReg
+type GlobalRegSet = RegSet GlobalReg
+
+emptyRegSet             :: RegSet r
+nullRegSet              :: RegSet r -> Bool
+elemRegSet              :: Ord r => r -> RegSet r -> Bool
+extendRegSet            :: Ord r => RegSet r -> r -> RegSet r
+deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r
+mkRegSet                :: Ord r => [r] -> RegSet r
+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
+sizeRegSet              :: RegSet r -> Int
+regSetToList            :: RegSet r -> [r]
+
+emptyRegSet      = Set.empty
+nullRegSet       = Set.null
+elemRegSet       = Set.member
+extendRegSet     = flip Set.insert
+deleteFromRegSet = flip Set.delete
+mkRegSet         = Set.fromList
+minusRegSet      = Set.difference
+plusRegSet       = Set.union
+timesRegSet      = Set.intersection
+sizeRegSet       = Set.size
+regSetToList     = Set.toList
+
+class Ord r => UserOfRegs r a where
+  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsUsed :: UserOfRegs LocalReg a
+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsUsed = foldRegsUsed
+
+class Ord r => DefinerOfRegs r a where
+  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsDefd :: DefinerOfRegs LocalReg a
+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsDefd = foldRegsDefd
+
+instance UserOfRegs LocalReg CmmReg where
+    foldRegsUsed _ f z (CmmLocal reg) = f z reg
+    foldRegsUsed _ _ z (CmmGlobal _)  = z
+
+instance DefinerOfRegs LocalReg CmmReg where
+    foldRegsDefd _ f z (CmmLocal reg) = f z reg
+    foldRegsDefd _ _ z (CmmGlobal _)  = z
+
+instance UserOfRegs GlobalReg CmmReg where
+    foldRegsUsed _ _ z (CmmLocal _)    = z
+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg
+
+instance DefinerOfRegs GlobalReg CmmReg where
+    foldRegsDefd _ _ z (CmmLocal _)    = z
+    foldRegsDefd _ f z (CmmGlobal reg) = f z reg
+
+instance Ord r => UserOfRegs r r where
+    foldRegsUsed _ f z r = f z r
+
+instance Ord r => DefinerOfRegs r r where
+    foldRegsDefd _ f z r = f z r
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
+  foldRegsUsed dflags f !z e = expr z e
+    where expr z (CmmLit _)          = z
+          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr
+          expr z (CmmReg r)          = foldRegsUsed dflags f z r
+          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
+          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r
+          expr z (CmmStackSlot _ _)  = z
+
+instance UserOfRegs r a => UserOfRegs r [a] where
+  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as
+  {-# INLINABLE foldRegsUsed #-}
+
+instance DefinerOfRegs r a => DefinerOfRegs r [a] where
+  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as
+  {-# INLINABLE foldRegsDefd #-}
+
+-----------------------------------------------------------------------------
+--              Global STG registers
+-----------------------------------------------------------------------------
+
+data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
+
+-----------------------------------------------------------------------------
+--              Global STG registers
+-----------------------------------------------------------------------------
+{-
+Note [Overlapping global registers]
+
+The backend might not faithfully implement the abstraction of the STG
+machine with independent registers for different values of type
+GlobalReg. Specifically, certain pairs of registers (r1, r2) may
+overlap in the sense that a store to r1 invalidates the value in r2,
+and vice versa.
+
+Currently this occurs only on the x86_64 architecture where FloatReg n
+and DoubleReg n are assigned the same microarchitectural register, in
+order to allow functions to receive more Float# or Double# arguments
+in registers (as opposed to on the stack).
+
+There are no specific rules about which registers might overlap with
+which other registers, but presumably it's safe to assume that nothing
+will overlap with special registers like Sp or BaseReg.
+
+Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap
+on a particular platform. The instance Eq GlobalReg is syntactic
+equality of STG registers and does not take overlap into
+account. However it is still used in UserOfRegs/DefinerOfRegs and
+there are likely still bugs there, beware!
+-}
+
+data GlobalReg
+  -- Argument and return registers
+  = VanillaReg                  -- pointers, unboxed ints and chars
+        {-# UNPACK #-} !Int     -- its number
+        VGcPtr
+
+  | FloatReg            -- single-precision floating-point registers
+        {-# UNPACK #-} !Int     -- its number
+
+  | DoubleReg           -- double-precision floating-point registers
+        {-# UNPACK #-} !Int     -- its number
+
+  | LongReg             -- long int registers (64-bit, really)
+        {-# UNPACK #-} !Int     -- its number
+
+  | XmmReg                      -- 128-bit SIMD vector register
+        {-# UNPACK #-} !Int     -- its number
+
+  | YmmReg                      -- 256-bit SIMD vector register
+        {-# UNPACK #-} !Int     -- its number
+
+  | ZmmReg                      -- 512-bit SIMD vector register
+        {-# UNPACK #-} !Int     -- its number
+
+  -- STG registers
+  | Sp                  -- Stack ptr; points to last occupied stack location.
+  | SpLim               -- Stack limit
+  | Hp                  -- Heap ptr; points to last occupied heap location.
+  | HpLim               -- Heap limit register
+  | CCCS                -- Current cost-centre stack
+  | CurrentTSO          -- pointer to current thread's TSO
+  | CurrentNursery      -- pointer to allocation area
+  | HpAlloc             -- allocation count for heap check failure
+
+                -- We keep the address of some commonly-called
+                -- functions in the register table, to keep code
+                -- size down:
+  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
+  | GCEnter1            -- stg_gc_enter_1
+  | GCFun               -- stg_gc_fun
+
+  -- Base offset for the register table, used for accessing registers
+  -- which do not have real registers assigned to them.  This register
+  -- will only appear after we have expanded GlobalReg into memory accesses
+  -- (where necessary) in the native code generator.
+  | BaseReg
+
+  -- The register used by the platform for the C stack pointer. This is
+  -- a break in the STG abstraction used exclusively to setup stack unwinding
+  -- information.
+  | MachSp
+
+  -- The is a dummy register used to indicate to the stack unwinder where
+  -- a routine would return to.
+  | UnwindReturnReg
+
+  -- Base Register for PIC (position-independent code) calculations
+  -- Only used inside the native code generator. It's exact meaning differs
+  -- from platform to platform (see module PositionIndependentCode).
+  | PicBaseReg
+
+  deriving( Show )
+
+instance Eq GlobalReg where
+   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
+   FloatReg i == FloatReg j = i==j
+   DoubleReg i == DoubleReg j = i==j
+   LongReg i == LongReg j = i==j
+   -- NOTE: XMM, YMM, ZMM registers actually are the same registers
+   -- at least with respect to store at YMM i and then read from XMM i
+   -- and similarly for ZMM etc.
+   XmmReg i == XmmReg j = i==j
+   YmmReg i == YmmReg j = i==j
+   ZmmReg i == ZmmReg j = i==j
+   Sp == Sp = True
+   SpLim == SpLim = True
+   Hp == Hp = True
+   HpLim == HpLim = True
+   CCCS == CCCS = True
+   CurrentTSO == CurrentTSO = True
+   CurrentNursery == CurrentNursery = True
+   HpAlloc == HpAlloc = True
+   EagerBlackholeInfo == EagerBlackholeInfo = True
+   GCEnter1 == GCEnter1 = True
+   GCFun == GCFun = True
+   BaseReg == BaseReg = True
+   MachSp == MachSp = True
+   UnwindReturnReg == UnwindReturnReg = True
+   PicBaseReg == PicBaseReg = True
+   _r1 == _r2 = False
+
+instance Ord GlobalReg where
+   compare (VanillaReg i _) (VanillaReg j _) = compare i j
+     -- Ignore type when seeking clashes
+   compare (FloatReg i)  (FloatReg  j) = compare i j
+   compare (DoubleReg i) (DoubleReg j) = compare i j
+   compare (LongReg i)   (LongReg   j) = compare i j
+   compare (XmmReg i)    (XmmReg    j) = compare i j
+   compare (YmmReg i)    (YmmReg    j) = compare i j
+   compare (ZmmReg i)    (ZmmReg    j) = compare i j
+   compare Sp Sp = EQ
+   compare SpLim SpLim = EQ
+   compare Hp Hp = EQ
+   compare HpLim HpLim = EQ
+   compare CCCS CCCS = EQ
+   compare CurrentTSO CurrentTSO = EQ
+   compare CurrentNursery CurrentNursery = EQ
+   compare HpAlloc HpAlloc = EQ
+   compare EagerBlackholeInfo EagerBlackholeInfo = EQ
+   compare GCEnter1 GCEnter1 = EQ
+   compare GCFun GCFun = EQ
+   compare BaseReg BaseReg = EQ
+   compare MachSp MachSp = EQ
+   compare UnwindReturnReg UnwindReturnReg = EQ
+   compare PicBaseReg PicBaseReg = EQ
+   compare (VanillaReg _ _) _ = LT
+   compare _ (VanillaReg _ _) = GT
+   compare (FloatReg _) _     = LT
+   compare _ (FloatReg _)     = GT
+   compare (DoubleReg _) _    = LT
+   compare _ (DoubleReg _)    = GT
+   compare (LongReg _) _      = LT
+   compare _ (LongReg _)      = GT
+   compare (XmmReg _) _       = LT
+   compare _ (XmmReg _)       = GT
+   compare (YmmReg _) _       = LT
+   compare _ (YmmReg _)       = GT
+   compare (ZmmReg _) _       = LT
+   compare _ (ZmmReg _)       = GT
+   compare Sp _ = LT
+   compare _ Sp = GT
+   compare SpLim _ = LT
+   compare _ SpLim = GT
+   compare Hp _ = LT
+   compare _ Hp = GT
+   compare HpLim _ = LT
+   compare _ HpLim = GT
+   compare CCCS _ = LT
+   compare _ CCCS = GT
+   compare CurrentTSO _ = LT
+   compare _ CurrentTSO = GT
+   compare CurrentNursery _ = LT
+   compare _ CurrentNursery = GT
+   compare HpAlloc _ = LT
+   compare _ HpAlloc = GT
+   compare GCEnter1 _ = LT
+   compare _ GCEnter1 = GT
+   compare GCFun _ = LT
+   compare _ GCFun = GT
+   compare BaseReg _ = LT
+   compare _ BaseReg = GT
+   compare MachSp _ = LT
+   compare _ MachSp = GT
+   compare UnwindReturnReg _ = LT
+   compare _ UnwindReturnReg = GT
+   compare EagerBlackholeInfo _ = LT
+   compare _ EagerBlackholeInfo = GT
+
+-- convenient aliases
+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg
+baseReg = CmmGlobal BaseReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
+spLimReg = CmmGlobal SpLim
+nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
+
+node :: GlobalReg
+node = VanillaReg 1 VGcPtr
+
+globalRegType :: DynFlags -> GlobalReg -> CmmType
+globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags
+globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
+globalRegType _      (FloatReg _)      = cmmFloat W32
+globalRegType _      (DoubleReg _)     = cmmFloat W64
+globalRegType _      (LongReg _)       = cmmBits W64
+-- TODO: improve the internal model of SIMD/vectorized registers
+-- the right design SHOULd improve handling of float and double code too.
+-- see remarks in "NOTE [SIMD Design for the future]"" in StgCmmPrim
+globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)
+globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)
+globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)
+
+globalRegType dflags Hp                = gcWord dflags
+                                            -- The initialiser for all
+                                            -- dynamically allocated closures
+globalRegType dflags _                 = bWord dflags
+
+isArgReg :: GlobalReg -> Bool
+isArgReg (VanillaReg {}) = True
+isArgReg (FloatReg {})   = True
+isArgReg (DoubleReg {})  = True
+isArgReg (LongReg {})    = True
+isArgReg (XmmReg {})     = True
+isArgReg (YmmReg {})     = True
+isArgReg (ZmmReg {})     = True
+isArgReg _               = False
diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmImplementSwitchPlans.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE GADTs #-}
+module CmmImplementSwitchPlans
+  ( cmmImplementSwitchPlans
+  )
+where
+
+import GhcPrelude
+
+import Hoopl.Block
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch
+import UniqSupply
+import DynFlags
+
+--
+-- This module replaces Switch statements as generated by the Stg -> Cmm
+-- transformation, which might be huge and sparse and hence unsuitable for
+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).
+--
+-- The actual, abstract strategy is determined by createSwitchPlan in
+-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in
+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.
+--
+-- This division into different modules is both to clearly separate concerns,
+-- but also because createSwitchPlan needs access to the constructors of
+-- SwitchTargets, a data type exported abstractly by CmmSwitch.
+--
+
+-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
+-- code generation.
+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans dflags g
+    | targetSupportsSwitch (hscTarget dflags) = return g
+    | otherwise = do
+    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)
+    return $ ofBlockList (g_entry g) blocks'
+
+visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches dflags block
+  | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block
+  = do
+    let plan = createSwitchPlan ids
+
+    (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan
+
+    let block' = entry `blockJoinHead` middle `blockAppend` newTail
+
+    return $ block' : newBlocks
+
+  | otherwise
+  = return [block]
+
+
+-- Implementing a switch plan (returning a tail block)
+implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan dflags scope expr = go
+  where
+    go (Unconditionally l)
+      = return (emptyBlock `blockJoinTail` CmmBranch l, [])
+    go (JumpTable ids)
+      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
+    go (IfLT signed i ids1 ids2)
+      = do
+        (bid1, newBlocks1) <- go' ids1
+        (bid2, newBlocks2) <- go' ids2
+
+        let lt | signed    = cmmSLtWord
+               | otherwise = cmmULtWord
+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
+            lastNode = CmmCondBranch scrut bid1 bid2 Nothing
+            lastBlock = emptyBlock `blockJoinTail` lastNode
+        return (lastBlock, newBlocks1++newBlocks2)
+    go (IfEqual i l ids2)
+      = do
+        (bid2, newBlocks2) <- go' ids2
+
+        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
+            lastNode = CmmCondBranch scrut bid2 l Nothing
+            lastBlock = emptyBlock `blockJoinTail` lastNode
+        return (lastBlock, newBlocks2)
+
+    -- Same but returning a label to branch to
+    go' (Unconditionally l)
+      = return (l, [])
+    go' p
+      = do
+        bid <- mkBlockId `fmap` getUniqueM
+        (last, newBlocks) <- go p
+        let block = CmmEntry bid scope `blockJoinHead` last
+        return (bid, block: newBlocks)
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmInfo.hs
@@ -0,0 +1,586 @@
+{-# LANGUAGE CPP #-}
+module CmmInfo (
+  mkEmptyContInfoTable,
+  cmmToRawCmm,
+  mkInfoTable,
+  srtEscape,
+
+  -- info table accessors
+  closureInfoPtr,
+  entryCode,
+  getConstrTag,
+  cmmGetClosureType,
+  infoTable,
+  infoTableConstrTag,
+  infoTableSrtBitmap,
+  infoTableClosureType,
+  infoTablePtrs,
+  infoTableNonPtrs,
+  funInfoTable,
+  funInfoArity,
+
+  -- info table sizes and offsets
+  stdInfoTableSizeW,
+  fixedInfoTableSizeW,
+  profInfoTableSizeW,
+  maxStdInfoTableSizeW,
+  maxRetInfoTableSizeW,
+  stdInfoTableSizeB,
+  conInfoTableSizeB,
+  stdSrtBitmapOffset,
+  stdClosureTypeOffset,
+  stdPtrsOffset, stdNonPtrsOffset,
+) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Cmm
+import CmmUtils
+import CLabel
+import SMRep
+import Bitmap
+import Stream (Stream)
+import qualified Stream
+import Hoopl.Collections
+
+import Platform
+import Maybes
+import DynFlags
+import Panic
+import UniqSupply
+import MonadUtils
+import Util
+import Outputable
+
+import Data.ByteString (ByteString)
+import Data.Bits
+
+-- When we split at proc points, we need an empty info table.
+mkEmptyContInfoTable :: CLabel -> CmmInfoTable
+mkEmptyContInfoTable info_lbl
+  = CmmInfoTable { cit_lbl  = info_lbl
+                 , cit_rep  = mkStackRep []
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
+            -> IO (Stream IO RawCmmGroup ())
+cmmToRawCmm dflags cmms
+  = do { uniqs <- mkSplitUniqSupply 'i'
+       ; let do_one uniqs cmm = do
+                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
+                  (b,uniqs') -> return (uniqs',b)
+                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
+       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
+       }
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+--      <reversed variable part>
+--      <normal forward StgInfoTable, but without
+--              an entry point at the front>
+--      <code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+--      <entry label>
+--      <normal forward rest of StgInfoTable>
+--      <forward variable part>
+--
+--      See includes/rts/storage/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+--                      <srt slot>
+--                      <standard info table>
+--      ret-addr -->    <entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+--      ret-addr -->    <ptr to entry code>
+--                      <standard info table>
+--                      <srt slot>
+--
+--  * The SRT slot is only there if there is SRT info to record
+
+mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
+mkInfoTable _ (CmmData sec dat)
+  = return [CmmData sec dat]
+
+mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
+  --
+  -- in the non-tables-next-to-code case, procs can have at most a
+  -- single info table associated with the entry label of the proc.
+  --
+  | not (tablesNextToCode dflags)
+  = case topInfoTable proc of   --  must be at most one
+      -- no info table
+      Nothing ->
+         return [CmmProc mapEmpty entry_lbl live blocks]
+
+      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
+        (top_decls, (std_info, extra_bits)) <-
+             mkInfoTableContents dflags info Nothing
+        let
+          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
+          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+        --
+        -- Separately emit info table (with the function entry
+        -- point as first entry) and the entry code
+        --
+        return (top_decls ++
+                [CmmProc mapEmpty entry_lbl live blocks,
+                 mkRODataLits info_lbl
+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+
+  --
+  -- With tables-next-to-code, we can have many info tables,
+  -- associated with some of the BlockIds of the proc.  For each info
+  -- table we need to turn it into CmmStatics, and collect any new
+  -- CmmDecls that arise from doing so.
+  --
+  | otherwise
+  = do
+    (top_declss, raw_infos) <-
+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
+    return (concat top_declss ++
+            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
+
+  where
+   do_one_info (lbl,itbl) = do
+     (top_decls, (std_info, extra_bits)) <-
+         mkInfoTableContents dflags itbl Nothing
+     let
+        info_lbl = cit_lbl itbl
+        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
+        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+     --
+     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
+                              reverse rel_extra_bits ++ rel_std_info))
+
+-----------------------------------------------------
+type InfoTableContents = ( [CmmLit]          -- The standard part
+                         , [CmmLit] )        -- The "extra bits"
+-- These Lits have *not* had mkRelativeTo applied to them
+
+mkInfoTableContents :: DynFlags
+                    -> CmmInfoTable
+                    -> Maybe Int               -- Override default RTS type tag?
+                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
+                               InfoTableContents)       -- Info tbl + extra bits
+
+mkInfoTableContents dflags
+                    info@(CmmInfoTable { cit_lbl  = info_lbl
+                                       , cit_rep  = smrep
+                                       , cit_prof = prof
+                                       , cit_srt = srt })
+                    mb_rts_tag
+  | RTSRep rts_tag rep <- smrep
+  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
+    -- Completely override the rts_tag that mkInfoTableContents would
+    -- otherwise compute, with the rts_tag stored in the RTSRep
+    -- (which in turn came from a handwritten .cmm file)
+
+  | StackRep frame <- smrep
+  = do { (prof_lits, prof_data) <- mkProfLits dflags prof
+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
+       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
+       ; let
+             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
+             rts_tag | Just tag <- mb_rts_tag = tag
+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
+                     | otherwise              = rET_BIG   -- Does not; extra_bits is
+                                                          -- a label
+       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
+
+  | HeapRep _ ptrs nonptrs closure_type <- smrep
+  = do { let layout  = packIntsCLit dflags ptrs nonptrs
+       ; (prof_lits, prof_data) <- mkProfLits dflags prof
+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
+                                <- mk_pieces closure_type srt_label
+       ; let std_info = mkStdInfoTable dflags prof_lits
+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
+                                       (mb_srt_field `orElse` srt_bitmap)
+                                       (mb_layout    `orElse` layout)
+       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
+  where
+    mk_pieces :: ClosureTypeInfo -> [CmmLit]
+              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this
+                        , Maybe CmmLit  -- Override the layout field with this
+                        , [CmmLit]           -- "Extra bits" for info table
+                        , [RawCmmDecl])      -- Auxiliary data decls
+    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
+      = do { (descr_lit, decl) <- newStringLit con_descr
+           ; return ( Just (CmmInt (fromIntegral con_tag)
+                                   (halfWordWidth dflags))
+                    , Nothing, [descr_lit], [decl]) }
+
+    mk_pieces Thunk srt_label
+      = return (Nothing, Nothing, srt_label, [])
+
+    mk_pieces (ThunkSelector offset) _no_srt
+      = return (Just (CmmInt 0 (halfWordWidth dflags)),
+                Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+         -- Layout known (one free var); we use the layout field for offset
+
+    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
+      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
+           ; return (Nothing, Nothing,  extra_bits, []) }
+
+    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
+      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
+           ; let fun_type | null liveness_data = aRG_GEN
+                          | otherwise          = aRG_GEN_BIG
+                 extra_bits = [ packIntsCLit dflags fun_type arity ]
+                           ++ (if inlineSRT dflags then [] else [ srt_lit ])
+                           ++ [ liveness_lit, slow_entry ]
+           ; return (Nothing, Nothing, extra_bits, liveness_data) }
+      where
+        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
+        srt_lit = case srt_label of
+                    []          -> mkIntCLit dflags 0
+                    (lit:_rest) -> ASSERT( null _rest ) lit
+
+    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
+
+mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
+
+packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
+packIntsCLit dflags a b = packHalfWordsCLit dflags
+                           (toStgHalfWord dflags (fromIntegral a))
+                           (toStgHalfWord dflags (fromIntegral b))
+
+
+mkSRTLit :: DynFlags
+         -> CLabel
+         -> Maybe CLabel
+         -> ([CmmLit],    -- srt_label, if any
+             CmmLit)      -- srt_bitmap
+mkSRTLit dflags info_lbl (Just lbl)
+  | inlineSRT dflags
+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))
+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+
+
+-- | Is the SRT offset field inline in the info table on this platform?
+--
+-- See the section "Referring to an SRT from the info table" in
+-- Note [SRTs] in CmmBuildInfoTables.hs
+inlineSRT :: DynFlags -> Bool
+inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
+  && tablesNextToCode dflags
+
+-------------------------------------------------------------------------
+--
+--      Lay out the info table and handle relative offsets
+--
+-------------------------------------------------------------------------
+
+-- This function takes
+--   * the standard info table portion (StgInfoTable)
+--   * the "extra bits" (StgFunInfoExtraRev etc.)
+--   * the entry label
+--   * the code
+-- and lays them out in memory, producing a list of RawCmmDecl
+
+-------------------------------------------------------------------------
+--
+--      Position independent code
+--
+-------------------------------------------------------------------------
+-- In order to support position independent code, we mustn't put absolute
+-- references into read-only space. Info tables in the tablesNextToCode
+-- case must be in .text, which is read-only, so we doctor the CmmLits
+-- to use relative offsets instead.
+
+-- Note that this is done even when the -fPIC flag is not specified,
+-- as we want to keep binary compatibility between PIC and non-PIC.
+
+makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
+
+makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
+  | tablesNextToCode dflags
+  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)
+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
+  | tablesNextToCode dflags
+  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
+makeRelativeRefTo _ _ lit = lit
+
+
+-------------------------------------------------------------------------
+--
+--              Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+--      - pointer variables (bound in the environment)
+--      - non-pointer variables (bound in the environment)
+--      - free slots (recorded in the stack free list)
+--      - non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
+mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
+              -- ^ Returns:
+              --   1. The bitmap (literal value or label)
+              --   2. Large bitmap CmmData if needed
+
+mkLivenessBits dflags liveness
+  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
+  = do { uniq <- getUniqueM
+       ; let bitmap_lbl = mkBitmapLabel uniq
+       ; return (CmmLabel bitmap_lbl,
+                 [mkRODataLits bitmap_lbl lits]) }
+
+  | otherwise -- Fits in one word
+  = return (mkStgWordCLit dflags bitmap_word, [])
+  where
+    n_bits = length liveness
+
+    bitmap :: Bitmap
+    bitmap = mkBitmap dflags liveness
+
+    small_bitmap = case bitmap of
+                     []  -> toStgWord dflags 0
+                     [b] -> b
+                     _   -> panic "mkLiveness"
+    bitmap_word = toStgWord dflags (fromIntegral n_bits)
+              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
+
+    lits = mkWordCLit dflags (fromIntegral n_bits)
+         : map (mkStgWordCLit dflags) bitmap
+      -- The first word is the size.  The structure must match
+      -- StgLargeBitmap in includes/rts/storage/InfoTable.h
+
+-------------------------------------------------------------------------
+--
+--      Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table.  This part of the info table
+-- corresponds to the StgInfoTable type defined in
+-- includes/rts/storage/InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+   :: DynFlags
+   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
+   -> Int               -- Closure RTS tag
+   -> CmmLit            -- SRT length
+   -> CmmLit            -- layout field
+   -> [CmmLit]
+
+mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
+ =      -- Parallel revertible-black hole field
+    prof_info
+        -- Ticky info (none at present)
+        -- Debug info (none at present)
+ ++ [layout_lit, tag, srt]
+
+ where
+    prof_info
+        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+        | otherwise = []
+
+    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
+
+-------------------------------------------------------------------------
+--
+--      Making string literals
+--
+-------------------------------------------------------------------------
+
+mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits _ (ProfilingInfo td cd)
+  = do { (td_lit, td_decl) <- newStringLit td
+       ; (cd_lit, cd_decl) <- newStringLit cd
+       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
+
+newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
+newStringLit bytes
+  = do { uniq <- getUniqueM
+       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
+
+
+-- Misc utils
+
+-- | Value of the srt field of an info table when using an StgLargeSRT
+srtEscape :: DynFlags -> StgHalfWord
+srtEscape dflags = toStgHalfWord dflags (-1)
+
+-------------------------------------------------------------------------
+--
+--      Accessing fields of an info table
+--
+-------------------------------------------------------------------------
+
+-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
+-- enabled.
+wordAligned :: DynFlags -> CmmExpr -> CmmExpr
+wordAligned dflags e
+  | gopt Opt_AlignmentSanitisation dflags
+  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+  | otherwise
+  = e
+
+closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer and returns the info table pointer
+closureInfoPtr dflags e =
+    CmmLoad (wordAligned dflags e) (bWord dflags)
+
+entryCode :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns its entry code
+entryCode dflags e
+ | tablesNextToCode dflags = e
+ | otherwise               = CmmLoad e (bWord dflags)
+
+getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the *zero-indexed*
+-- constructor tag obtained from the info table
+-- This lives in the SRT field of the info table
+-- (constructors don't need SRTs).
+getConstrTag dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
+  where
+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+
+cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the closure type
+-- obtained from the info table
+cmmGetClosureType dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
+  where
+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+
+infoTable :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns a pointer to the first word of the standard-form
+-- info table, excluding the entry-code word (if present)
+infoTable dflags info_ptr
+  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
+  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
+
+infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the constr tag
+-- field of the info table (same as the srt_bitmap field)
+infoTableConstrTag = infoTableSrtBitmap
+
+infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
+-- field of the info table
+infoTableSrtBitmap dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
+
+infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the closure type
+-- field of the info table.
+infoTableClosureType dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
+
+infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTablePtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
+
+infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTableNonPtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
+
+funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes the info pointer of a function,
+-- and returns a pointer to the first word of the StgFunInfoExtra struct
+-- in the info table.
+funInfoTable dflags info_ptr
+  | tablesNextToCode dflags
+  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+  | otherwise
+  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
+                                -- Past the entry code pointer
+
+-- Takes the info pointer of a function, returns the function's arity
+funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
+funInfoArity dflags iptr
+  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
+  where
+   fun_info = funInfoTable dflags iptr
+   rep = cmmBits (widthFromBytes rep_bytes)
+
+   (rep_bytes, offset)
+    | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc
+                                , oFFSET_StgFunInfoExtraRev_arity dflags )
+    | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc
+                                , oFFSET_StgFunInfoExtraFwd_arity dflags )
+
+   pc = sPlatformConstants (settings dflags)
+
+-----------------------------------------------------------------------------
+--
+--      Info table sizes & offsets
+--
+-----------------------------------------------------------------------------
+
+stdInfoTableSizeW :: DynFlags -> WordOff
+-- The size of a standard info table varies with profiling/ticky etc,
+-- so we can't get it from Constants
+-- It must vary in sync with mkStdInfoTable
+stdInfoTableSizeW dflags
+  = fixedInfoTableSizeW
+  + if gopt Opt_SccProfilingOn dflags
+       then profInfoTableSizeW
+       else 0
+
+fixedInfoTableSizeW :: WordOff
+fixedInfoTableSizeW = 2 -- layout, type
+
+profInfoTableSizeW :: WordOff
+profInfoTableSizeW = 2
+
+maxStdInfoTableSizeW :: WordOff
+maxStdInfoTableSizeW =
+  1 {- entry, when !tablesNextToCode -}
+  + fixedInfoTableSizeW
+  + profInfoTableSizeW
+
+maxRetInfoTableSizeW :: WordOff
+maxRetInfoTableSizeW =
+  maxStdInfoTableSizeW
+  + 1 {- srt label -}
+
+stdInfoTableSizeB  :: DynFlags -> ByteOff
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
+
+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
+
+stdClosureTypeOffset :: DynFlags -> ByteOff
+-- Byte offset of the closure type half-word
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
+
+stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
+
+conInfoTableSizeB :: DynFlags -> Int
+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -0,0 +1,1237 @@
+{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
+module CmmLayoutStack (
+       cmmLayoutStack, setInfoTableStackMap
+  ) where
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
+import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
+
+import BasicTypes
+import Cmm
+import CmmInfo
+import BlockId
+import CLabel
+import CmmUtils
+import MkGraph
+import ForeignCall
+import CmmLive
+import CmmProcPoint
+import SMRep
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
+import UniqSupply
+import StgCmmUtils      ( newTemp )
+import Maybes
+import UniqFM
+import Util
+
+import DynFlags
+import FastString
+import Outputable hiding ( isEmpty )
+import qualified Data.Set as Set
+import Control.Monad.Fix
+import Data.Array as Array
+import Data.Bits
+import Data.List (nub)
+
+{- Note [Stack Layout]
+
+The job of this pass is to
+
+ - replace references to abstract stack Areas with fixed offsets from Sp.
+
+ - replace the CmmHighStackMark constant used in the stack check with
+   the maximum stack usage of the proc.
+
+ - save any variables that are live across a call, and reload them as
+   necessary.
+
+Before stack allocation, local variables remain live across native
+calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local
+variables are clobbered by native calls.
+
+We want to do stack allocation so that as far as possible
+ - stack use is minimized, and
+ - unnecessary stack saves and loads are avoided.
+
+The algorithm we use is a variant of linear-scan register allocation,
+where the stack is our register file.
+
+We proceed in two passes, see Note [Two pass approach] for why they are not easy
+to merge into one.
+
+Pass 1:
+
+ - First, we do a liveness analysis, which annotates every block with
+   the variables live on entry to the block.
+
+ - We traverse blocks in reverse postorder DFS; that is, we visit at
+   least one predecessor of a block before the block itself.  The
+   stack layout flowing from the predecessor of the block will
+   determine the stack layout on entry to the block.
+
+ - We maintain a data structure
+
+     Map Label StackMap
+
+   which describes the contents of the stack and the stack pointer on
+   entry to each block that is a successor of a block that we have
+   visited.
+
+ - For each block we visit:
+
+    - Look up the StackMap for this block.
+
+    - If this block is a proc point (or a call continuation, if we aren't
+      splitting proc points), we need to reload all the live variables from the
+      stack - but this is done in Pass 2, which calculates more precise liveness
+      information (see description of Pass 2).
+
+    - Walk forwards through the instructions:
+      - At an assignment  x = Sp[loc]
+        - Record the fact that Sp[loc] contains x, so that we won't
+          need to save x if it ever needs to be spilled.
+      - At an assignment  x = E
+        - If x was previously on the stack, it isn't any more
+      - At the last node, if it is a call or a jump to a proc point
+        - Lay out the stack frame for the call (see setupStackFrame)
+        - emit instructions to save all the live variables
+        - Remember the StackMaps for all the successors
+        - emit an instruction to adjust Sp
+      - If the last node is a branch, then the current StackMap is the
+        StackMap for the successors.
+
+    - Manifest Sp: replace references to stack areas in this block
+      with real Sp offsets. We cannot do this until we have laid out
+      the stack area for the successors above.
+
+      In this phase we also eliminate redundant stores to the stack;
+      see elimStackStores.
+
+  - There is one important gotcha: sometimes we'll encounter a control
+    transfer to a block that we've already processed (a join point),
+    and in that case we might need to rearrange the stack to match
+    what the block is expecting. (exactly the same as in linear-scan
+    register allocation, except here we have the luxury of an infinite
+    supply of temporary variables).
+
+  - Finally, we update the magic CmmHighStackMark constant with the
+    stack usage of the function, and eliminate the whole stack check
+    if there was no stack use. (in fact this is done as part of the
+    main traversal, by feeding the high-water-mark output back in as
+    an input. I hate cyclic programming, but it's just too convenient
+    sometimes.)
+
+  There are plenty of tricky details: update frames, proc points, return
+  addresses, foreign calls, and some ad-hoc optimisations that are
+  convenient to do here and effective in common cases.  Comments in the
+  code below explain these.
+
+Pass 2:
+
+- Calculate live registers, but taking into account that nothing is live at the
+  entry to a proc point.
+
+- At each proc point and call continuation insert reloads of live registers from
+  the stack (they were saved by Pass 1).
+
+
+Note [Two pass approach]
+
+The main reason for Pass 2 is being able to insert only the reloads that are
+needed and the fact that the two passes need different liveness information.
+Let's consider an example:
+
+  .....
+   \ /
+    D   <- proc point
+   / \
+  E   F
+   \ /
+    G   <- proc point
+    |
+    X
+
+Pass 1 needs liveness assuming that local variables are preserved across calls.
+This is important because it needs to save any local registers to the stack
+(e.g., if register a is used in block X, it must be saved before any native
+call).
+However, for Pass 2, where we want to reload registers from stack (in a proc
+point), this is overly conservative and would lead us to generate reloads in D
+for things used in X, even though we're going to generate reloads in G anyway
+(since it's also a proc point).
+So Pass 2 calculates liveness knowing that nothing is live at the entry to a
+proc point. This means that in D we only need to reload things used in E or F.
+This can be quite important, for an extreme example see testcase for #3294.
+
+Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1
+is a forward one. Furthermore, Pass 1 is creating code that uses local registers
+(saving them before a call), which the liveness analysis for Pass 2 must see to
+be correct.
+
+-}
+
+
+-- All stack locations are expressed as positive byte offsets from the
+-- "base", which is defined to be the address above the return address
+-- on the stack on entry to this CmmProc.
+--
+-- Lower addresses have higher StackLocs.
+--
+type StackLoc = ByteOff
+
+{-
+ A StackMap describes the stack at any given point.  At a continuation
+ it has a particular layout, like this:
+
+         |             | <- base
+         |-------------|
+         |     ret0    | <- base + 8
+         |-------------|
+         .  upd frame  . <- base + sm_ret_off
+         |-------------|
+         |             |
+         .    vars     .
+         . (live/dead) .
+         |             | <- base + sm_sp - sm_args
+         |-------------|
+         |    ret1     |
+         .  ret vals   . <- base + sm_sp    (<--- Sp points here)
+         |-------------|
+
+Why do we include the final return address (ret0) in our stack map?  I
+have absolutely no idea, but it seems to be done that way consistently
+in the rest of the code generator, so I played along here. --SDM
+
+Note that we will be constructing an info table for the continuation
+(ret1), which needs to describe the stack down to, but not including,
+the update frame (or ret0, if there is no update frame).
+-}
+
+data StackMap = StackMap
+ {  sm_sp   :: StackLoc
+       -- ^ the offset of Sp relative to the base on entry
+       -- to this block.
+ ,  sm_args :: ByteOff
+       -- ^ the number of bytes of arguments in the area for this block
+       -- Defn: the offset of young(L) relative to the base is given by
+       -- (sm_sp - sm_args) of the StackMap for block L.
+ ,  sm_ret_off :: ByteOff
+       -- ^ Number of words of stack that we do not describe with an info
+       -- table, because it contains an update frame.
+ ,  sm_regs :: UniqFM (LocalReg,StackLoc)
+       -- ^ regs on the stack
+ }
+
+instance Outputable StackMap where
+  ppr StackMap{..} =
+     text "Sp = " <> int sm_sp $$
+     text "sm_args = " <> int sm_args $$
+     text "sm_ret_off = " <> int sm_ret_off $$
+     text "sm_regs = " <> pprUFM sm_regs ppr
+
+
+cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
+               -> UniqSM (CmmGraph, LabelMap StackMap)
+cmmLayoutStack dflags procpoints entry_args
+               graph@(CmmGraph { g_entry = entry })
+  = do
+    -- We need liveness info. Dead assignments are removed later
+    -- by the sinking pass.
+    let liveness = cmmLocalLiveness dflags graph
+        blocks = revPostorder graph
+
+    (final_stackmaps, _final_high_sp, new_blocks) <-
+          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
+            layout dflags procpoints liveness entry entry_args
+                   rec_stackmaps rec_high_sp blocks
+
+    blocks_with_reloads <-
+        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks
+    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads
+    return (ofBlockList entry new_blocks', final_stackmaps)
+
+-- -----------------------------------------------------------------------------
+-- Pass 1
+-- -----------------------------------------------------------------------------
+
+layout :: DynFlags
+       -> LabelSet                      -- proc points
+       -> LabelMap CmmLocalLive         -- liveness
+       -> BlockId                       -- entry
+       -> ByteOff                       -- stack args on entry
+
+       -> LabelMap StackMap             -- [final] stack maps
+       -> ByteOff                       -- [final] Sp high water mark
+
+       -> [CmmBlock]                    -- [in] blocks
+
+       -> UniqSM
+          ( LabelMap StackMap           -- [out] stack maps
+          , ByteOff                     -- [out] Sp high water mark
+          , [CmmBlock]                  -- [out] new blocks
+          )
+
+layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
+  = go blocks init_stackmap entry_args []
+  where
+    (updfr, cont_info)  = collectContInfo blocks
+
+    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args
+                                               , sm_args = entry_args
+                                               , sm_ret_off = updfr
+                                               , sm_regs = emptyUFM
+                                               }
+
+    go [] acc_stackmaps acc_hwm acc_blocks
+      = return (acc_stackmaps, acc_hwm, acc_blocks)
+
+    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
+      = do
+       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
+
+       let stack0@StackMap { sm_sp = sp0 }
+               = mapFindWithDefault
+                     (pprPanic "no stack map for" (ppr entry_lbl))
+                     entry_lbl acc_stackmaps
+
+       -- (a) Update the stack map to include the effects of
+       --     assignments in this block
+       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0
+
+       -- (b) Look at the last node and if we are making a call or
+       --     jumping to a proc point, we must save the live
+       --     variables, adjust Sp, and construct the StackMaps for
+       --     each of the successor blocks.  See handleLastNode for
+       --     details.
+       (middle1, sp_off, last1, fixup_blocks, out)
+           <- handleLastNode dflags procpoints liveness cont_info
+                             acc_stackmaps stack1 tscope middle0 last0
+
+       -- (c) Manifest Sp: run over the nodes in the block and replace
+       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
+       --
+       -- our block:
+       --    middle0          -- the original middle nodes
+       --    middle1          -- live variable saves from handleLastNode
+       --    Sp = Sp + sp_off -- Sp adjustment goes here
+       --    last1            -- the last node
+       --
+       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1
+
+       let final_blocks =
+               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high
+                          entry0 middle_pre sp_off last1 fixup_blocks
+
+       let acc_stackmaps' = mapUnion acc_stackmaps out
+
+           -- If this block jumps to the GC, then we do not take its
+           -- stack usage into account for the high-water mark.
+           -- Otherwise, if the only stack usage is in the stack-check
+           -- failure block itself, we will do a redundant stack
+           -- check.  The stack has a buffer designed to accommodate
+           -- the largest amount of stack needed for calling the GC.
+           --
+           this_sp_hwm | isGcJump last0 = 0
+                       | otherwise      = sp0 - sp_off
+
+           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
+
+       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
+
+
+-- -----------------------------------------------------------------------------
+
+-- Not foolproof, but GCFun is the culprit we most want to catch
+isGcJump :: CmmNode O C -> Bool
+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
+  = l == GCFun || l == GCEnter1
+isGcJump _something_else = False
+
+-- -----------------------------------------------------------------------------
+
+-- This doesn't seem right somehow.  We need to find out whether this
+-- proc will push some update frame material at some point, so that we
+-- can avoid using that area of the stack for spilling.  The
+-- updfr_space field of the CmmProc *should* tell us, but it doesn't
+-- (I think maybe it gets filled in later when we do proc-point
+-- splitting).
+--
+-- So we'll just take the max of all the cml_ret_offs.  This could be
+-- unnecessarily pessimistic, but probably not in the code we
+-- generate.
+
+collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
+collectContInfo blocks
+  = (maximum ret_offs, mapFromList (catMaybes mb_argss))
+ where
+  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks
+
+  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
+  get_cont b =
+     case lastNode b of
+        CmmCall { cml_cont = Just l, .. }
+           -> (Just (l, cml_ret_args), cml_ret_off)
+        CmmForeignCall { .. }
+           -> (Just (succ, ret_args), ret_off)
+        _other -> (Nothing, 0)
+
+
+-- -----------------------------------------------------------------------------
+-- Updating the StackMap from middle nodes
+
+-- Look for loads from stack slots, and update the StackMap.  This is
+-- purely for optimisation reasons, so that we can avoid saving a
+-- variable back to a different stack slot if it is already on the
+-- stack.
+--
+-- This happens a lot: for example when function arguments are passed
+-- on the stack and need to be immediately saved across a call, we
+-- want to just leave them where they are on the stack.
+--
+procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
+procMiddle stackmaps node sm
+  = case node of
+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
+       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
+        where loc = getStackLoc area off stackmaps
+     CmmAssign (CmmLocal r) _other
+       -> sm { sm_regs = delFromUFM (sm_regs sm) r }
+     _other
+       -> sm
+
+getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
+getStackLoc Old       n _         = n
+getStackLoc (Young l) n stackmaps =
+  case mapLookup l stackmaps of
+    Nothing -> pprPanic "getStackLoc" (ppr l)
+    Just sm -> sm_sp sm - sm_args sm + n
+
+
+-- -----------------------------------------------------------------------------
+-- Handling stack allocation for a last node
+
+-- We take a single last node and turn it into:
+--
+--    C1 (some statements)
+--    Sp = Sp + N
+--    C2 (some more statements)
+--    call f()          -- the actual last node
+--
+-- plus possibly some more blocks (we may have to add some fixup code
+-- between the last node and the continuation).
+--
+-- C1: is the code for saving the variables across this last node onto
+-- the stack, if the continuation is a call or jumps to a proc point.
+--
+-- C2: if the last node is a safe foreign call, we have to inject some
+-- extra code that goes *after* the Sp adjustment.
+
+handleLastNode
+   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
+   -> LabelMap StackMap -> StackMap -> CmmTickScope
+   -> Block CmmNode O O
+   -> CmmNode O C
+   -> UniqSM
+      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment
+      , ByteOff            -- amount to adjust Sp
+      , CmmNode O C        -- new last node
+      , [CmmBlock]         -- new blocks
+      , LabelMap StackMap  -- stackmaps for the continuations
+      )
+
+handleLastNode dflags procpoints liveness cont_info stackmaps
+               stack0@StackMap { sm_sp = sp0 } tscp middle last
+ = case last of
+    --  At each return / tail call,
+    --  adjust Sp to point to the last argument pushed, which
+    --  is cml_args, after popping any other junk from the stack.
+    CmmCall{ cml_cont = Nothing, .. } -> do
+      let sp_off = sp0 - cml_args
+      return ([], sp_off, last, [], mapEmpty)
+
+    --  At each CmmCall with a continuation:
+    CmmCall{ cml_cont = Just cont_lbl, .. } ->
+       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
+
+    CmmForeignCall{ succ = cont_lbl, .. } -> do
+       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+            -- one word of args: the return address
+
+    CmmBranch {}     ->  handleBranches
+    CmmCondBranch {} ->  handleBranches
+    CmmSwitch {}     ->  handleBranches
+
+  where
+     -- Calls and ForeignCalls are handled the same way:
+     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
+              -> ( [CmmNode O O]
+                 , ByteOff
+                 , CmmNode O C
+                 , [CmmBlock]
+                 , LabelMap StackMap
+                 )
+     lastCall lbl cml_args cml_ret_args cml_ret_off
+      =  ( assignments
+         , spOffsetForCall sp0 cont_stack cml_args
+         , last
+         , [] -- no new blocks
+         , mapSingleton lbl cont_stack )
+      where
+         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off
+
+
+     prepareStack lbl cml_ret_args cml_ret_off
+       | Just cont_stack <- mapLookup lbl stackmaps
+             -- If we have already seen this continuation before, then
+             -- we just have to make the stack look the same:
+       = (fixupStack stack0 cont_stack, cont_stack)
+             -- Otherwise, we have to allocate the stack frame
+       | otherwise
+       = (save_assignments, new_cont_stack)
+       where
+        (new_cont_stack, save_assignments)
+           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
+
+
+     -- For other last nodes (branches), if any of the targets is a
+     -- proc point, we have to set up the stack to match what the proc
+     -- point is expecting.
+     --
+     handleBranches :: UniqSM ( [CmmNode O O]
+                                , ByteOff
+                                , CmmNode O C
+                                , [CmmBlock]
+                                , LabelMap StackMap )
+
+     handleBranches
+         -- Note [diamond proc point]
+       | Just l <- futureContinuation middle
+       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
+       = do
+         let cont_args = mapFindWithDefault 0 l cont_info
+             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)
+             out = mapFromList [ (l', cont_stack)
+                               | l' <- successors last ]
+         return ( assigs
+                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
+                , last
+                , []
+                , out)
+
+        | otherwise = do
+          pps <- mapM handleBranch (successors last)
+          let lbl_map :: LabelMap Label
+              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
+              fix_lbl l = mapFindWithDefault l l lbl_map
+          return ( []
+                 , 0
+                 , mapSuccessors fix_lbl last
+                 , concat [ blk | (_,_,_,blk) <- pps ]
+                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
+
+     -- For each successor of this block
+     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
+     handleBranch l
+        --   (a) if the successor already has a stackmap, we need to
+        --       shuffle the current stack to make it look the same.
+        --       We have to insert a new block to make this happen.
+        | Just stack2 <- mapLookup l stackmaps
+        = do
+             let assigs = fixupStack stack0 stack2
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
+             return (l, tmp_lbl, stack2, block)
+
+        --   (b) if the successor is a proc point, save everything
+        --       on the stack.
+        | l `setMember` procpoints
+        = do
+             let cont_args = mapFindWithDefault 0 l cont_info
+                 (stack2, assigs) =
+                      setupStackFrame dflags l liveness (sm_ret_off stack0)
+                                                        cont_args stack0
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
+             return (l, tmp_lbl, stack2, block)
+
+        --   (c) otherwise, the current StackMap is the StackMap for
+        --       the continuation.  But we must remember to remove any
+        --       variables from the StackMap that are *not* live at
+        --       the destination, because this StackMap might be used
+        --       by fixupStack if this is a join point.
+        | otherwise = return (l, l, stack1, [])
+        where live = mapFindWithDefault (panic "handleBranch") l liveness
+              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
+              is_live (r,_) = r `elemRegSet` live
+
+
+makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
+               -> CmmTickScope -> [CmmNode O O]
+               -> UniqSM (Label, [CmmBlock])
+makeFixupBlock dflags sp0 l stack tscope assigs
+  | null assigs && sp0 == sm_sp stack = return (l, [])
+  | otherwise = do
+    tmp_lbl <- newBlockId
+    let sp_off = sp0 - sm_sp stack
+        block = blockJoin (CmmEntry tmp_lbl tscope)
+                          ( maybeAddSpAdj dflags sp0 sp_off
+                           $ blockFromList assigs )
+                          (CmmBranch l)
+    return (tmp_lbl, [block])
+
+
+-- Sp is currently pointing to current_sp,
+-- we want it to point to
+--    (sm_sp cont_stack - sm_args cont_stack + args)
+-- so the difference is
+--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)
+spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
+spOffsetForCall current_sp cont_stack args
+  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)
+
+
+-- | create a sequence of assignments to establish the new StackMap,
+-- given the old StackMap.
+fixupStack :: StackMap -> StackMap -> [CmmNode O O]
+fixupStack old_stack new_stack = concatMap move new_locs
+ where
+     old_map  = sm_regs old_stack
+     new_locs = stackSlotRegs new_stack
+
+     move (r,n)
+       | Just (_,m) <- lookupUFM old_map r, n == m = []
+       | otherwise = [CmmStore (CmmStackSlot Old n)
+                               (CmmReg (CmmLocal r))]
+
+
+
+setupStackFrame
+             :: DynFlags
+             -> BlockId                 -- label of continuation
+             -> LabelMap CmmLocalLive   -- liveness
+             -> ByteOff      -- updfr
+             -> ByteOff      -- bytes of return values on stack
+             -> StackMap     -- current StackMap
+             -> (StackMap, [CmmNode O O])
+
+setupStackFrame dflags lbl liveness updfr_off ret_args stack0
+  = (cont_stack, assignments)
+  where
+      -- get the set of LocalRegs live in the continuation
+      live = mapFindWithDefault Set.empty lbl liveness
+
+      -- the stack from the base to updfr_off is off-limits.
+      -- our new stack frame contains:
+      --   * saved live variables
+      --   * the return address [young(C) + 8]
+      --   * the args for the call,
+      --     which are replaced by the return values at the return
+      --     point.
+
+      -- everything up to updfr_off is off-limits
+      -- stack1 contains updfr_off, plus everything we need to save
+      (stack1, assignments) = allocate dflags updfr_off live stack0
+
+      -- And the Sp at the continuation is:
+      --   sm_sp stack1 + ret_args
+      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args
+                         , sm_args = ret_args
+                         , sm_ret_off = updfr_off
+                         }
+
+
+-- -----------------------------------------------------------------------------
+-- Note [diamond proc point]
+--
+-- This special case looks for the pattern we get from a typical
+-- tagged case expression:
+--
+--    Sp[young(L1)] = L1
+--    if (R1 & 7) != 0 goto L1 else goto L2
+--  L2:
+--    call [R1] returns to L1
+--  L1: live: {y}
+--    x = R1
+--
+-- If we let the generic case handle this, we get
+--
+--    Sp[-16] = L1
+--    if (R1 & 7) != 0 goto L1a else goto L2
+--  L2:
+--    Sp[-8] = y
+--    Sp = Sp - 16
+--    call [R1] returns to L1
+--  L1a:
+--    Sp[-8] = y
+--    Sp = Sp - 16
+--    goto L1
+--  L1:
+--    x = R1
+--
+-- The code for saving the live vars is duplicated in each branch, and
+-- furthermore there is an extra jump in the fast path (assuming L1 is
+-- a proc point, which it probably is if there is a heap check).
+--
+-- So to fix this we want to set up the stack frame before the
+-- conditional jump.  How do we know when to do this, and when it is
+-- safe?  The basic idea is, when we see the assignment
+--
+--   Sp[young(L)] = L
+--
+-- we know that
+--   * we are definitely heading for L
+--   * there can be no more reads from another stack area, because young(L)
+--     overlaps with it.
+--
+-- We don't necessarily know that everything live at L is live now
+-- (some might be assigned between here and the jump to L).  So we
+-- simplify and only do the optimisation when we see
+--
+--   (1) a block containing an assignment of a return address L
+--   (2) ending in a branch where one (and only) continuation goes to L,
+--       and no other continuations go to proc points.
+--
+-- then we allocate the stack frame for L at the end of the block,
+-- before the branch.
+--
+-- We could generalise (2), but that would make it a bit more
+-- complicated to handle, and this currently catches the common case.
+
+futureContinuation :: Block CmmNode O O -> Maybe BlockId
+futureContinuation middle = foldBlockNodesB f middle Nothing
+   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
+         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _
+               = Just l
+         f _ r = r
+
+-- -----------------------------------------------------------------------------
+-- Saving live registers
+
+-- | Given a set of live registers and a StackMap, save all the registers
+-- on the stack and return the new StackMap and the assignments to do
+-- the saving.
+--
+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
+         -> (StackMap, [CmmNode O O])
+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+                                              , sm_regs = regs0 }
+ =
+   -- we only have to save regs that are not already in a slot
+   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
+       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0
+   in
+
+   -- make a map of the stack
+   let stack = reverse $ Array.elems $
+               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
+                 ret_words ++ live_words
+            where ret_words =
+                   [ (x, Occupied)
+                   | x <- [ 1 .. toWords dflags ret_off] ]
+                  live_words =
+                   [ (toWords dflags x, Occupied)
+                   | (r,off) <- nonDetEltsUFM regs1,
+                   -- See Note [Unique Determinism and code generation]
+                     let w = localRegBytes dflags r,
+                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
+   in
+
+   -- Pass over the stack: find slots to save all the new live variables,
+   -- choosing the oldest slots first (hence a foldr).
+   let
+       save slot ([], stack, n, assigs, regs) -- no more regs to save
+          = ([], slot:stack, plusW dflags n 1, assigs, regs)
+       save slot (to_save, stack, n, assigs, regs)
+          = case slot of
+               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
+               Empty
+                 | Just (stack', r, to_save') <-
+                       select_save to_save (slot:stack)
+                 -> let assig = CmmStore (CmmStackSlot Old n')
+                                         (CmmReg (CmmLocal r))
+                        n' = plusW dflags n 1
+                   in
+                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)
+
+                 | otherwise
+                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
+
+       -- we should do better here: right now we'll fit the smallest first,
+       -- but it would make more sense to fit the biggest first.
+       select_save :: [LocalReg] -> [StackSlot]
+                   -> Maybe ([StackSlot], LocalReg, [LocalReg])
+       select_save regs stack = go regs []
+         where go []     _no_fit = Nothing
+               go (r:rs) no_fit
+                 | Just rest <- dropEmpty words stack
+                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)
+                 | otherwise
+                 = go rs (r:no_fit)
+                 where words = localRegWords dflags r
+
+       -- fill in empty slots as much as possible
+       (still_to_save, save_stack, n, save_assigs, save_regs)
+          = foldr save (to_save, [], 0, [], []) stack
+
+       -- push any remaining live vars on the stack
+       (push_sp, push_assigs, push_regs)
+          = foldr push (n, [], []) still_to_save
+          where
+              push r (n, assigs, regs)
+                = (n', assig : assigs, (r,(r,n')) : regs)
+                where
+                  n' = n + localRegBytes dflags r
+                  assig = CmmStore (CmmStackSlot Old n')
+                                   (CmmReg (CmmLocal r))
+
+       trim_sp
+          | not (null push_regs) = push_sp
+          | otherwise
+          = plusW dflags n (- length (takeWhile isEmpty save_stack))
+
+       final_regs = regs1 `addListToUFM` push_regs
+                          `addListToUFM` save_regs
+
+   in
+  -- XXX should be an assert
+   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
+
+   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+
+   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
+   , push_assigs ++ save_assigs )
+
+
+-- -----------------------------------------------------------------------------
+-- Manifesting Sp
+
+-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The
+-- block looks like this:
+--
+--    middle_pre       -- the middle nodes
+--    Sp = Sp + sp_off -- Sp adjustment goes here
+--    last             -- the last node
+--
+-- And we have some extra blocks too (that don't contain Sp adjustments)
+--
+-- The adjustment for middle_pre will be different from that for
+-- middle_post, because the Sp adjustment intervenes.
+--
+manifestSp
+   :: DynFlags
+   -> LabelMap StackMap  -- StackMaps for other blocks
+   -> StackMap           -- StackMap for this block
+   -> ByteOff            -- Sp on entry to the block
+   -> ByteOff            -- SpHigh
+   -> CmmNode C O        -- first node
+   -> [CmmNode O O]      -- middle
+   -> ByteOff            -- sp_off
+   -> CmmNode O C        -- last node
+   -> [CmmBlock]         -- new blocks
+   -> [CmmBlock]         -- final blocks with Sp manifest
+
+manifestSp dflags stackmaps stack0 sp0 sp_high
+           first middle_pre sp_off last fixup_blocks
+  = final_block : fixup_blocks'
+  where
+    area_off = getAreaOff stackmaps
+
+    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
+
+    final_middle = maybeAddSpAdj dflags sp0 sp_off
+                 . blockFromList
+                 . map adj_pre_sp
+                 . elimStackStores stack0 stackmaps area_off
+                 $ middle_pre
+    final_last    = optStackCheck (adj_post_sp last)
+
+    final_block   = blockJoin first final_middle final_last
+
+    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
+
+getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
+getAreaOff _ Old = 0
+getAreaOff stackmaps (Young l) =
+  case mapLookup l stackmaps of
+    Just sm -> sm_sp sm - sm_args sm
+    Nothing -> pprPanic "getAreaOff" (ppr l)
+
+
+maybeAddSpAdj
+  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
+maybeAddSpAdj dflags sp0 sp_off block =
+  add_initial_unwind $ add_adj_unwind $ adj block
+  where
+    adj block
+      | sp_off /= 0
+      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
+      | otherwise = block
+    -- Add unwind pseudo-instruction at the beginning of each block to
+    -- document Sp level for debugging
+    add_initial_unwind block
+      | debugLevel dflags > 0
+      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
+      | otherwise
+      = block
+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
+
+    -- Add unwind pseudo-instruction right after the Sp adjustment
+    -- if there is one.
+    add_adj_unwind block
+      | debugLevel dflags > 0
+      , sp_off /= 0
+      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
+      | otherwise
+      = block
+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
+
+{- Note [SP old/young offsets]
+
+Sp(L) is the Sp offset on entry to block L relative to the base of the
+OLD area.
+
+SpArgs(L) is the size of the young area for L, i.e. the number of
+arguments.
+
+ - in block L, each reference to [old + N] turns into
+   [Sp + Sp(L) - N]
+
+ - in block L, each reference to [young(L') + N] turns into
+   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]
+
+ - be careful with the last node of each block: Sp has already been adjusted
+   to be Sp + Sp(L) - Sp(L')
+-}
+
+areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+
+areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
+  = cmmOffset dflags spExpr (sp_old - area_off area - n)
+    -- Replace (CmmStackSlot area n) with an offset from Sp
+
+areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
+  = mkIntExpr dflags sp_hwm
+    -- Replace CmmHighStackMark with the number of bytes of stack used,
+    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap
+
+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
+  | falseStackCheck args
+  = zeroExpr dflags
+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
+  | falseStackCheck args
+  = mkIntExpr dflags 1
+    -- Replace a stack-overflow test that cannot fail with a no-op
+    -- See Note [Always false stack check]
+
+areaToSp _ _ _ _ other = other
+
+-- | Determine whether a stack check cannot fail.
+falseStackCheck :: [CmmExpr] -> Bool
+falseStackCheck [ CmmMachOp (MO_Sub _)
+                      [ CmmRegOff (CmmGlobal Sp) x_off
+                      , CmmLit (CmmInt y_lit _)]
+                , CmmReg (CmmGlobal SpLim)]
+  = fromIntegral x_off >= y_lit
+falseStackCheck _ = False
+
+-- Note [Always false stack check]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- We can optimise stack checks of the form
+--
+--   if ((Sp + x) - y < SpLim) then .. else ..
+--
+-- where are non-negative integer byte offsets.  Since we know that
+-- SpLim <= Sp (remember the stack grows downwards), this test must
+-- yield False if (x >= y), so we can rewrite the comparison to False.
+-- A subsequent sinking pass will later drop the dead code.
+-- Optimising this away depends on knowing that SpLim <= Sp, so it is
+-- really the job of the stack layout algorithm, hence we do it now.
+--
+-- The control flow optimiser may negate a conditional to increase
+-- the likelihood of a fallthrough if the branch is not taken.  But
+-- not every conditional is inverted as the control flow optimiser
+-- places some requirements on the predecessors of both branch targets.
+-- So we better look for the inverted comparison too.
+
+optStackCheck :: CmmNode O C -> CmmNode O C
+optStackCheck n = -- Note [Always false stack check]
+ case n of
+   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false
+   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true
+   other -> other
+
+
+-- -----------------------------------------------------------------------------
+
+-- | Eliminate stores of the form
+--
+--    Sp[area+n] = r
+--
+-- when we know that r is already in the same slot as Sp[area+n].  We
+-- could do this in a later optimisation pass, but that would involve
+-- a separate analysis and we already have the information to hand
+-- here.  It helps clean up some extra stack stores in common cases.
+--
+-- Note that we may have to modify the StackMap as we walk through the
+-- code using procMiddle, since an assignment to a variable in the
+-- StackMap will invalidate its mapping there.
+--
+elimStackStores :: StackMap
+                -> LabelMap StackMap
+                -> (Area -> ByteOff)
+                -> [CmmNode O O]
+                -> [CmmNode O O]
+elimStackStores stackmap stackmaps area_off nodes
+  = go stackmap nodes
+  where
+    go _stackmap [] = []
+    go stackmap (n:ns)
+     = case n of
+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
+            | Just (_,off) <- lookupUFM (sm_regs stackmap) r
+            , area_off area + m == off
+            -> go stackmap ns
+         _otherwise
+            -> n : go (procMiddle stackmaps n stackmap) ns
+
+
+-- -----------------------------------------------------------------------------
+-- Update info tables to include stack liveness
+
+
+setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
+  where
+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
+       info_tbl { cit_rep = StackRep (get_liveness lbl) }
+    fix_info _ other = other
+
+    get_liveness :: BlockId -> Liveness
+    get_liveness lbl
+      = case mapLookup lbl stackmaps of
+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
+          Just sm -> stackMapToLiveness dflags sm
+
+setInfoTableStackMap _ _ d = d
+
+
+stackMapToLiveness :: DynFlags -> StackMap -> Liveness
+stackMapToLiveness dflags StackMap{..} =
+   reverse $ Array.elems $
+        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
+                                     toWords dflags (sm_sp - sm_args)) live_words
+   where
+     live_words =  [ (toWords dflags off, False)
+                   | (r,off) <- nonDetEltsUFM sm_regs
+                   , isGcPtrType (localRegType r) ]
+                   -- See Note [Unique Determinism and code generation]
+
+-- -----------------------------------------------------------------------------
+-- Pass 2
+-- -----------------------------------------------------------------------------
+
+insertReloadsAsNeeded
+    :: DynFlags
+    -> ProcPointSet
+    -> LabelMap StackMap
+    -> BlockId
+    -> [CmmBlock]
+    -> UniqSM [CmmBlock]
+insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
+    toBlockList . fst <$>
+        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
+  where
+    rewriteCC :: RewriteFun CmmLocalLive
+    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
+        let entry_label = entryLabel e_node
+            stackmap = case mapLookup entry_label final_stackmaps of
+                Just sm -> sm
+                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
+
+            -- Merge the liveness from successor blocks and analyse the last
+            -- node.
+            joined = gen_kill dflags x_node $!
+                         joinOutFacts liveLattice x_node fact_base0
+            -- What is live at the start of middle0.
+            live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined
+
+            -- If this is a procpoint we need to add the reloads, but only if
+            -- they're actually live. Furthermore, nothing is live at the entry
+            -- to a proc point.
+            (middle1, live_with_reloads)
+                | entry_label `setMember` procpoints
+                = let reloads = insertReloads dflags stackmap live_at_middle0
+                  in (foldr blockCons middle0 reloads, emptyRegSet)
+                | otherwise
+                = (middle0, live_at_middle0)
+
+            -- Final liveness for this block.
+            !fact_base2 = mapSingleton entry_label live_with_reloads
+
+        return (BlockCC e_node middle1 x_node, fact_base2)
+
+insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
+insertReloads dflags stackmap live =
+     [ CmmAssign (CmmLocal reg)
+                 -- This cmmOffset basically corresponds to manifesting
+                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
+                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
+                          (localRegType reg))
+     | (reg, reg_off) <- stackSlotRegs stackmap
+     , reg `elemRegSet` live
+     ]
+   where
+     sp_off = sm_sp stackmap
+
+-- -----------------------------------------------------------------------------
+-- Lowering safe foreign calls
+
+{-
+Note [Lower safe foreign calls]
+
+We start with
+
+   Sp[young(L1)] = L1
+ ,-----------------------
+ | r1 = foo(x,y,z) returns to L1
+ '-----------------------
+ L1:
+   R1 = r1 -- copyIn, inserted by mkSafeCall
+   ...
+
+the stack layout algorithm will arrange to save and reload everything
+live across the call.  Our job now is to expand the call so we get
+
+   Sp[young(L1)] = L1
+ ,-----------------------
+ | SAVE_THREAD_STATE()
+ | token = suspendThread(BaseReg, interruptible)
+ | r = foo(x,y,z)
+ | BaseReg = resumeThread(token)
+ | LOAD_THREAD_STATE()
+ | R1 = r  -- copyOut
+ | jump Sp[0]
+ '-----------------------
+ L1:
+   r = R1 -- copyIn, inserted by mkSafeCall
+   ...
+
+Note the copyOut, which saves the results in the places that L1 is
+expecting them (see Note [safe foreign call convention]). Note also
+that safe foreign call is replace by an unsafe one in the Cmm graph.
+-}
+
+lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall dflags block
+  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
+  = do
+    -- Both 'id' and 'new_base' are KindNonPtr because they're
+    -- RTS-only objects and are not subject to garbage collection
+    id <- newTemp (bWord dflags)
+    new_base <- newTemp (cmmRegType dflags baseReg)
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+    save_state_code <- saveThreadState dflags
+    load_state_code <- loadThreadState dflags
+    let suspend = save_state_code  <*>
+                  caller_save <*>
+                  mkMiddle (callSuspendThread dflags id intrbl)
+        midCall = mkUnsafeCall tgt res args
+        resume  = mkMiddle (callResumeThread new_base id) <*>
+                  -- Assign the result to BaseReg: we
+                  -- might now have a different Capability!
+                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>
+                  caller_load <*>
+                  load_state_code
+
+        (_, regs, copyout) =
+             copyOutOflow dflags NativeReturn Jump (Young succ)
+                            (map (CmmReg . CmmLocal) res)
+                            ret_off []
+
+        -- NB. after resumeThread returns, the top-of-stack probably contains
+        -- the stack frame for succ, but it might not: if the current thread
+        -- received an exception during the call, then the stack might be
+        -- different.  Hence we continue by jumping to the top stack frame,
+        -- not by jumping to succ.
+        jump = CmmCall { cml_target    = entryCode dflags $
+                                         CmmLoad spExpr (bWord dflags)
+                       , cml_cont      = Just succ
+                       , cml_args_regs = regs
+                       , cml_args      = widthInBytes (wordWidth dflags)
+                       , cml_ret_args  = ret_args
+                       , cml_ret_off   = ret_off }
+
+    graph' <- lgraphOfAGraph ( suspend <*>
+                               midCall <*>
+                               resume  <*>
+                               copyout <*>
+                               mkLast jump, tscp)
+
+    case toBlockList graph' of
+      [one] -> let (_, middle', last) = blockSplit one
+               in return (blockJoin entry (middle `blockAppend` middle') last)
+      _ -> panic "lowerSafeForeignCall0"
+
+  -- Block doesn't end in a safe foreign call:
+  | otherwise = return block
+
+
+foreignLbl :: FastString -> CmmExpr
+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
+
+callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread dflags id intrbl =
+  CmmUnsafeForeignCall
+       (ForeignTarget (foreignLbl (fsLit "suspendThread"))
+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
+       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
+
+callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
+callResumeThread new_base id =
+  CmmUnsafeForeignCall
+       (ForeignTarget (foreignLbl (fsLit "resumeThread"))
+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
+       [new_base] [CmmReg (CmmLocal id)]
+
+-- -----------------------------------------------------------------------------
+
+plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
+plusW dflags b w = b + w * wORD_SIZE dflags
+
+data StackSlot = Occupied | Empty
+     -- Occupied: a return address or part of an update frame
+
+instance Outputable StackSlot where
+  ppr Occupied = text "XXX"
+  ppr Empty    = text "---"
+
+dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
+dropEmpty 0 ss           = Just ss
+dropEmpty n (Empty : ss) = dropEmpty (n-1) ss
+dropEmpty _ _            = Nothing
+
+isEmpty :: StackSlot -> Bool
+isEmpty Empty = True
+isEmpty _ = False
+
+localRegBytes :: DynFlags -> LocalReg -> ByteOff
+localRegBytes dflags r
+    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
+
+localRegWords :: DynFlags -> LocalReg -> WordOff
+localRegWords dflags = toWords dflags . localRegBytes dflags
+
+toWords :: DynFlags -> ByteOff -> WordOff
+toWords dflags x = x `quot` wORD_SIZE dflags
+
+
+stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
+stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)
+  -- See Note [Unique Determinism and code generation]
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLex.x
@@ -0,0 +1,368 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004-2006
+--
+-- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there
+-- are a few minor differences:
+--
+--   * extra keywords for our macros, and float32/float64 types
+--   * global registers (Sp,Hp, etc.)
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmLex (
+   CmmToken(..), cmmlex,
+  ) where
+
+import GhcPrelude
+
+import CmmExpr
+
+import Lexer
+import CmmMonad
+import SrcLoc
+import UniqFM
+import StringBuffer
+import FastString
+import Ctype
+import Util
+--import TRACE
+
+import Data.Word
+import Data.Char
+}
+
+$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space
+$white_no_nl = $whitechar # \n
+
+$ascdigit  = 0-9
+$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
+$digit     = [$ascdigit $unidigit]
+$octit     = 0-7
+$hexit     = [$digit A-F a-f]
+
+$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
+$large     = [$asclarge $unilarge]
+
+$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
+$small     = [$ascsmall $unismall \_]
+
+$namebegin = [$large $small \. \$ \@]
+$namechar  = [$namebegin $digit]
+
+@decimal     = $digit+
+@octal       = $octit+
+@hexadecimal = $hexit+
+@exponent    = [eE] [\-\+]? @decimal
+
+@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+
+@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})
+@strchar     = ($printable # [\"\\]) | @escape
+
+cmm :-
+
+$white_no_nl+           ;
+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
+
+^\# (line)?             { begin line_prag }
+
+-- single-line line pragmas, of the form
+--    # <line> "<file>" <extra-stuff> \n
+<line_prag> $digit+                     { setLine line_prag1 }
+<line_prag1> \" [^\"]* \"       { setFile line_prag2 }
+<line_prag2> .*                         { pop }
+
+<0> {
+  \n                    ;
+
+  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }
+
+  ".."                  { kw CmmT_DotDot }
+  "::"                  { kw CmmT_DoubleColon }
+  ">>"                  { kw CmmT_Shr }
+  "<<"                  { kw CmmT_Shl }
+  ">="                  { kw CmmT_Ge }
+  "<="                  { kw CmmT_Le }
+  "=="                  { kw CmmT_Eq }
+  "!="                  { kw CmmT_Ne }
+  "&&"                  { kw CmmT_BoolAnd }
+  "||"                  { kw CmmT_BoolOr }
+
+  "True"                { kw CmmT_True  }
+  "False"               { kw CmmT_False }
+  "likely"              { kw CmmT_likely}
+
+  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }
+  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }
+  F@decimal             { global_regN FloatReg }
+  D@decimal             { global_regN DoubleReg }
+  L@decimal             { global_regN LongReg }
+  Sp                    { global_reg Sp }
+  SpLim                 { global_reg SpLim }
+  Hp                    { global_reg Hp }
+  HpLim                 { global_reg HpLim }
+  CCCS                  { global_reg CCCS }
+  CurrentTSO            { global_reg CurrentTSO }
+  CurrentNursery        { global_reg CurrentNursery }
+  HpAlloc               { global_reg HpAlloc }
+  BaseReg               { global_reg BaseReg }
+  MachSp                { global_reg MachSp }
+  UnwindReturnReg       { global_reg UnwindReturnReg }
+
+  $namebegin $namechar* { name }
+
+  0 @octal              { tok_octal }
+  @decimal              { tok_decimal }
+  0[xX] @hexadecimal    { tok_hexadecimal }
+  @floating_point       { strtoken tok_float }
+
+  \" @strchar* \"       { strtoken tok_string }
+}
+
+{
+data CmmToken
+  = CmmT_SpecChar  Char
+  | CmmT_DotDot
+  | CmmT_DoubleColon
+  | CmmT_Shr
+  | CmmT_Shl
+  | CmmT_Ge
+  | CmmT_Le
+  | CmmT_Eq
+  | CmmT_Ne
+  | CmmT_BoolAnd
+  | CmmT_BoolOr
+  | CmmT_CLOSURE
+  | CmmT_INFO_TABLE
+  | CmmT_INFO_TABLE_RET
+  | CmmT_INFO_TABLE_FUN
+  | CmmT_INFO_TABLE_CONSTR
+  | CmmT_INFO_TABLE_SELECTOR
+  | CmmT_else
+  | CmmT_export
+  | CmmT_section
+  | CmmT_goto
+  | CmmT_if
+  | CmmT_call
+  | CmmT_jump
+  | CmmT_foreign
+  | CmmT_never
+  | CmmT_prim
+  | CmmT_reserve
+  | CmmT_return
+  | CmmT_returns
+  | CmmT_import
+  | CmmT_switch
+  | CmmT_case
+  | CmmT_default
+  | CmmT_push
+  | CmmT_unwind
+  | CmmT_bits8
+  | CmmT_bits16
+  | CmmT_bits32
+  | CmmT_bits64
+  | CmmT_bits128
+  | CmmT_bits256
+  | CmmT_bits512
+  | CmmT_float32
+  | CmmT_float64
+  | CmmT_gcptr
+  | CmmT_GlobalReg GlobalReg
+  | CmmT_Name      FastString
+  | CmmT_String    String
+  | CmmT_Int       Integer
+  | CmmT_Float     Rational
+  | CmmT_EOF
+  | CmmT_False
+  | CmmT_True
+  | CmmT_likely
+  deriving (Show)
+
+-- -----------------------------------------------------------------------------
+-- Lexer actions
+
+type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
+
+begin :: Int -> Action
+begin code _span _str _len = do liftP (pushLexState code); lexToken
+
+pop :: Action
+pop _span _buf _len = liftP popLexState >> lexToken
+
+special_char :: Action
+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
+
+kw :: CmmToken -> Action
+kw tok span _buf _len = return (L span tok)
+
+global_regN :: (Int -> GlobalReg) -> Action
+global_regN con span buf len
+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
+  where buf' = stepOn buf
+        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
+
+global_reg :: GlobalReg -> Action
+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))
+
+strtoken :: (String -> CmmToken) -> Action
+strtoken f span buf len =
+  return (L span $! (f $! lexemeToString buf len))
+
+name :: Action
+name span buf len =
+  case lookupUFM reservedWordsFM fs of
+        Just tok -> return (L span tok)
+        Nothing  -> return (L span (CmmT_Name fs))
+  where
+        fs = lexemeToFastString buf len
+
+reservedWordsFM = listToUFM $
+        map (\(x, y) -> (mkFastString x, y)) [
+        ( "CLOSURE",            CmmT_CLOSURE ),
+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),
+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),
+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),
+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),
+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
+        ( "else",               CmmT_else ),
+        ( "export",             CmmT_export ),
+        ( "section",            CmmT_section ),
+        ( "goto",               CmmT_goto ),
+        ( "if",                 CmmT_if ),
+        ( "call",               CmmT_call ),
+        ( "jump",               CmmT_jump ),
+        ( "foreign",            CmmT_foreign ),
+        ( "never",              CmmT_never ),
+        ( "prim",               CmmT_prim ),
+        ( "reserve",            CmmT_reserve ),
+        ( "return",             CmmT_return ),
+        ( "returns",            CmmT_returns ),
+        ( "import",             CmmT_import ),
+        ( "switch",             CmmT_switch ),
+        ( "case",               CmmT_case ),
+        ( "default",            CmmT_default ),
+        ( "push",               CmmT_push ),
+        ( "unwind",             CmmT_unwind ),
+        ( "bits8",              CmmT_bits8 ),
+        ( "bits16",             CmmT_bits16 ),
+        ( "bits32",             CmmT_bits32 ),
+        ( "bits64",             CmmT_bits64 ),
+        ( "bits128",            CmmT_bits128 ),
+        ( "bits256",            CmmT_bits256 ),
+        ( "bits512",            CmmT_bits512 ),
+        ( "float32",            CmmT_float32 ),
+        ( "float64",            CmmT_float64 ),
+-- New forms
+        ( "b8",                 CmmT_bits8 ),
+        ( "b16",                CmmT_bits16 ),
+        ( "b32",                CmmT_bits32 ),
+        ( "b64",                CmmT_bits64 ),
+        ( "b128",               CmmT_bits128 ),
+        ( "b256",               CmmT_bits256 ),
+        ( "b512",               CmmT_bits512 ),
+        ( "f32",                CmmT_float32 ),
+        ( "f64",                CmmT_float64 ),
+        ( "gcptr",              CmmT_gcptr ),
+        ( "likely",             CmmT_likely),
+        ( "True",               CmmT_True  ),
+        ( "False",              CmmT_False )
+        ]
+
+tok_decimal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))
+
+tok_octal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
+
+tok_hexadecimal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
+
+tok_float str = CmmT_Float $! readRational str
+
+tok_string str = CmmT_String (read str)
+                 -- urk, not quite right, but it'll do for now
+
+-- -----------------------------------------------------------------------------
+-- Line pragmas
+
+setLine :: Int -> Action
+setLine code span buf len = do
+  let line = parseUnsignedInteger buf len 10 octDecDigit
+  liftP $ do
+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+          -- subtract one: the line number refers to the *following* line
+    -- trace ("setLine "  ++ show line) $ do
+    popLexState >> pushLexState code
+  lexToken
+
+setFile :: Int -> Action
+setFile code span buf len = do
+  let file = lexemeToFastString (stepOn buf) (len-2)
+  liftP $ do
+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+    popLexState >> pushLexState code
+  lexToken
+
+-- -----------------------------------------------------------------------------
+-- This is the top-level function: called from the parser each time a
+-- new token is to be read from the input.
+
+cmmlex :: (Located CmmToken -> PD a) -> PD a
+cmmlex cont = do
+  (L span tok) <- lexToken
+  --trace ("token: " ++ show tok) $ do
+  cont (L (RealSrcSpan span) tok)
+
+lexToken :: PD (RealLocated CmmToken)
+lexToken = do
+  inp@(loc1,buf) <- getInput
+  sc <- liftP getLexState
+  case alexScan inp sc of
+    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
+                  liftP (setLastToken span 0)
+                  return (L span CmmT_EOF)
+    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
+    AlexSkip inp2 _ -> do
+        setInput inp2
+        lexToken
+    AlexToken inp2@(end,_buf2) len t -> do
+        setInput inp2
+        let span = mkRealSrcSpan loc1 end
+        span `seq` liftP (setLastToken span len)
+        t span buf len
+
+-- -----------------------------------------------------------------------------
+-- Monad stuff
+
+-- Stuff that Alex needs to know about our input type:
+type AlexInput = (RealSrcLoc,StringBuffer)
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (_,s) = prevChar s '\n'
+
+-- backwards compatibility for Alex 2.x
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar inp = case alexGetByte inp of
+                    Nothing    -> Nothing
+                    Just (b,i) -> c `seq` Just (c,i)
+                       where c = chr $ fromIntegral b
+
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (loc,s)
+  | atEnd s   = Nothing
+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))
+  where c    = currentChar s
+        b    = fromIntegral $ ord $ c
+        loc' = advanceSrcLoc loc c
+        s'   = stepOn s
+
+getInput :: PD AlexInput
+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)
+
+setInput :: AlexInput -> PD ()
+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()
+}
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLint.hs
@@ -0,0 +1,262 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2011
+--
+-- CmmLint: checking the correctness of Cmm statements and expressions
+--
+-----------------------------------------------------------------------------
+{-# LANGUAGE GADTs #-}
+module CmmLint (
+    cmmLint, cmmLintGraph
+  ) where
+
+import GhcPrelude
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import Cmm
+import CmmUtils
+import CmmLive
+import CmmSwitch (switchTargetsToList)
+import PprCmm ()
+import Outputable
+import DynFlags
+
+import Control.Monad (liftM, ap)
+
+-- Things to check:
+--     - invariant on CmmBlock in CmmExpr (see comment there)
+--     - check for branches to blocks that don't exist
+--     - check types
+
+-- -----------------------------------------------------------------------------
+-- Exported entry points:
+
+cmmLint :: (Outputable d, Outputable h)
+        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
+
+cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
+
+runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint dflags l p =
+   case unCL (l p) dflags of
+     Left err -> Just (vcat [text "Cmm lint error:",
+                             nest 2 err,
+                             text "Program was:",
+                             nest 2 (ppr p)])
+     Right _  -> Nothing
+
+lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl dflags (CmmProc _ lbl _ g)
+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
+lintCmmDecl _ (CmmData {})
+  = return ()
+
+
+lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
+lintCmmGraph dflags g =
+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
+    -- cmmLiveness throws an error if there are registers
+    -- live on entry to the graph (i.e. undefined
+    -- variables)
+  where
+       blocks = toBlockList g
+       labels = setFromList (map entryLabel blocks)
+
+
+lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
+lintCmmBlock labels block
+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
+        let (_, middle, last) = blockSplit block
+        mapM_ lintCmmMiddle (blockToList middle)
+        lintCmmLast labels last
+
+-- -----------------------------------------------------------------------------
+-- lintCmmExpr
+
+-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
+-- byte/word mismatches.
+
+lintCmmExpr :: CmmExpr -> CmmLint CmmType
+lintCmmExpr (CmmLoad expr rep) = do
+  _ <- lintCmmExpr expr
+  -- Disabled, if we have the inlining phase before the lint phase,
+  -- we can have funny offsets due to pointer tagging. -- EZY
+  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
+  --   cmmCheckWordAddress expr
+  return rep
+lintCmmExpr expr@(CmmMachOp op args) = do
+  dflags <- getDynFlags
+  tys <- mapM lintCmmExpr args
+  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+        then cmmCheckMachOp op args tys
+        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
+lintCmmExpr (CmmRegOff reg offset)
+  = do dflags <- getDynFlags
+       let rep = typeWidth (cmmRegType dflags reg)
+       lintCmmExpr (CmmMachOp (MO_Add rep)
+                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
+lintCmmExpr expr =
+  do dflags <- getDynFlags
+     return (cmmExprType dflags expr)
+
+-- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
+  = cmmCheckMachOp op [reg, lit] tys
+cmmCheckMachOp op _ tys
+  = do dflags <- getDynFlags
+       return (machOpResultType dflags op tys)
+
+{-
+isOffsetOp :: MachOp -> Bool
+isOffsetOp (MO_Add _) = True
+isOffsetOp (MO_Sub _) = True
+isOffsetOp _ = False
+
+-- This expression should be an address from which a word can be loaded:
+-- check for funny-looking sub-word offsets.
+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
+  = cmmLintDubiousWordOffset e
+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
+  = cmmLintDubiousWordOffset e
+_cmmCheckWordAddress _
+  = return ()
+
+-- No warnings for unaligned arithmetic with the node register,
+-- which is used to extract fields from tagged constructor closures.
+notNodeReg :: CmmExpr -> Bool
+notNodeReg (CmmReg reg) | reg == nodeReg = False
+notNodeReg _                             = True
+-}
+
+lintCmmMiddle :: CmmNode O O -> CmmLint ()
+lintCmmMiddle node = case node of
+  CmmComment _ -> return ()
+  CmmTick _    -> return ()
+  CmmUnwind{}  -> return ()
+
+  CmmAssign reg expr -> do
+            dflags <- getDynFlags
+            erep <- lintCmmExpr expr
+            let reg_ty = cmmRegType dflags reg
+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
+                then return ()
+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
+
+  CmmStore l r -> do
+            _ <- lintCmmExpr l
+            _ <- lintCmmExpr r
+            return ()
+
+  CmmUnsafeForeignCall target _formals actuals -> do
+            lintTarget target
+            mapM_ lintCmmExpr actuals
+
+
+lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
+lintCmmLast labels node = case node of
+  CmmBranch id -> checkTarget id
+
+  CmmCondBranch e t f _ -> do
+            dflags <- getDynFlags
+            mapM_ checkTarget [t,f]
+            _ <- lintCmmExpr e
+            checkCond dflags e
+
+  CmmSwitch e ids -> do
+            dflags <- getDynFlags
+            mapM_ checkTarget $ switchTargetsToList ids
+            erep <- lintCmmExpr e
+            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
+              then return ()
+              else cmmLintErr (text "switch scrutinee is not a word: " <>
+                               ppr e <> text " :: " <> ppr erep)
+
+  CmmCall { cml_target = target, cml_cont = cont } -> do
+          _ <- lintCmmExpr target
+          maybe (return ()) checkTarget cont
+
+  CmmForeignCall tgt _ args succ _ _ _ -> do
+          lintTarget tgt
+          mapM_ lintCmmExpr args
+          checkTarget succ
+ where
+  checkTarget id
+     | setMember id labels = return ()
+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+
+lintTarget :: ForeignTarget -> CmmLint ()
+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
+lintTarget (PrimTarget {})     = return ()
+
+
+checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond _ expr
+    = cmmLintErr (hang (text "expression is not a conditional:") 2
+                         (ppr expr))
+
+-- -----------------------------------------------------------------------------
+-- CmmLint monad
+
+-- just a basic error monad:
+
+newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
+
+instance Functor CmmLint where
+      fmap = liftM
+
+instance Applicative CmmLint where
+      pure a = CmmLint (\_ -> Right a)
+      (<*>) = ap
+
+instance Monad CmmLint where
+  CmmLint m >>= k = CmmLint $ \dflags ->
+                                case m dflags of
+                                Left e -> Left e
+                                Right a -> unCL (k a) dflags
+
+instance HasDynFlags CmmLint where
+    getDynFlags = CmmLint (\dflags -> Right dflags)
+
+cmmLintErr :: SDoc -> CmmLint a
+cmmLintErr msg = CmmLint (\_ -> Left msg)
+
+addLintInfo :: SDoc -> CmmLint a -> CmmLint a
+addLintInfo info thing = CmmLint $ \dflags ->
+   case unCL thing dflags of
+        Left err -> Left (hang info 2 err)
+        Right a  -> Right a
+
+cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
+cmmLintMachOpErr expr argsRep opExpectsRep
+     = cmmLintErr (text "in MachOp application: " $$
+                   nest 2 (ppr  expr) $$
+                      (text "op is expecting: " <+> ppr opExpectsRep) $$
+                      (text "arguments provide: " <+> ppr argsRep))
+
+cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
+cmmLintAssignErr stmt e_ty r_ty
+  = cmmLintErr (text "in assignment: " $$
+                nest 2 (vcat [ppr stmt,
+                              text "Reg ty:" <+> ppr r_ty,
+                              text "Rhs ty:" <+> ppr e_ty]))
+
+
+{-
+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
+cmmLintDubiousWordOffset expr
+   = cmmLintErr (text "offset is not a multiple of words: " $$
+                 nest 2 (ppr expr))
+-}
+
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLive.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CmmLive
+    ( CmmLocalLive
+    , cmmLocalLiveness
+    , cmmGlobalLiveness
+    , liveLattice
+    , gen_kill
+    )
+where
+
+import GhcPrelude
+
+import DynFlags
+import BlockId
+import Cmm
+import PprCmmExpr ()
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Label
+
+import Maybes
+import Outputable
+
+-----------------------------------------------------------------------------
+-- Calculating what variables are live on entry to a basic block
+-----------------------------------------------------------------------------
+
+-- | The variables live on entry to a block
+type CmmLive r = RegSet r
+type CmmLocalLive = CmmLive LocalReg
+
+-- | The dataflow lattice
+liveLattice :: Ord r => DataflowLattice (CmmLive r)
+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
+liveLattice = DataflowLattice emptyRegSet add
+  where
+    add (OldFact old) (NewFact new) =
+        let !join = plusRegSet old new
+        in changedIf (sizeRegSet join > sizeRegSet old) join
+
+-- | A mapping from block labels to the variables live on entry
+type BlockEntryLiveness r = LabelMap (CmmLive r)
+
+-----------------------------------------------------------------------------
+-- | Calculated liveness info for a CmmGraph
+-----------------------------------------------------------------------------
+
+cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
+cmmLocalLiveness dflags graph =
+    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+  where
+    entry = g_entry graph
+    check facts =
+        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
+
+cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
+cmmGlobalLiveness dflags graph =
+    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
+noLiveOnEntry bid in_fact x =
+  if nullRegSet in_fact then x
+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
+
+gen_kill
+    :: (DefinerOfRegs r n, UserOfRegs r n)
+    => DynFlags -> n -> CmmLive r -> CmmLive r
+gen_kill dflags node set =
+    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node
+    in foldRegsUsed dflags extendRegSet afterKill node
+{-# INLINE gen_kill #-}
+
+xferLive
+    :: forall r.
+       ( UserOfRegs r (CmmNode O O)
+       , DefinerOfRegs r (CmmNode O O)
+       , UserOfRegs r (CmmNode O C)
+       , DefinerOfRegs r (CmmNode O C)
+       )
+    => DynFlags -> TransferFun (CmmLive r)
+xferLive dflags (BlockCC eNode middle xNode) fBase =
+    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase
+        !result = foldNodesBwdOO (gen_kill dflags) middle joined
+    in mapSingleton (entryLabel eNode) result
+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}
+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmMachOp.hs
@@ -0,0 +1,658 @@
+module CmmMachOp
+    ( MachOp(..)
+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp
+    , isComparisonMachOp, maybeIntComparison, machOpResultType
+    , machOpArgReps, maybeInvertComparison, isFloatComparison
+
+    -- MachOp builders
+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot
+    , mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord
+    , mo_u_32ToWord, mo_s_32ToWord
+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+
+    -- CallishMachOp
+    , CallishMachOp(..), callishMachOpHints
+    , pprCallishMachOp
+    , machOpMemcpyishAlign
+
+    -- Atomic read-modify-write
+    , AtomicMachOp(..)
+   )
+where
+
+import GhcPrelude
+
+import CmmType
+import Outputable
+import DynFlags
+
+-----------------------------------------------------------------------------
+--              MachOp
+-----------------------------------------------------------------------------
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle.
+
+Most operations are parameterised by the 'Width' that they operate on.
+Some operations have separate signed and unsigned versions, and float
+and integer versions.
+-}
+
+data MachOp
+  -- Integer operations (insensitive to signed/unsigned)
+  = MO_Add Width
+  | MO_Sub Width
+  | MO_Eq  Width
+  | MO_Ne  Width
+  | MO_Mul Width                -- low word of multiply
+
+  -- Signed multiply/divide
+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows
+  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)
+  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)
+  | MO_S_Neg  Width             -- unary -
+
+  -- Unsigned multiply/divide
+  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows
+  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)
+  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)
+
+  -- Signed comparisons
+  | MO_S_Ge Width
+  | MO_S_Le Width
+  | MO_S_Gt Width
+  | MO_S_Lt Width
+
+  -- Unsigned comparisons
+  | MO_U_Ge Width
+  | MO_U_Le Width
+  | MO_U_Gt Width
+  | MO_U_Lt Width
+
+  -- Floating point arithmetic
+  | MO_F_Add  Width
+  | MO_F_Sub  Width
+  | MO_F_Neg  Width             -- unary -
+  | MO_F_Mul  Width
+  | MO_F_Quot Width
+
+  -- Floating point comparison
+  | MO_F_Eq Width
+  | MO_F_Ne Width
+  | MO_F_Ge Width
+  | MO_F_Le Width
+  | MO_F_Gt Width
+  | MO_F_Lt Width
+
+  -- Bitwise operations.  Not all of these may be supported
+  -- at all sizes, and only integral Widths are valid.
+  | MO_And   Width
+  | MO_Or    Width
+  | MO_Xor   Width
+  | MO_Not   Width
+  | MO_Shl   Width
+  | MO_U_Shr Width      -- unsigned shift right
+  | MO_S_Shr Width      -- signed shift right
+
+  -- Conversions.  Some of these will be NOPs.
+  -- Floating-point conversions use the signed variant.
+  | MO_SF_Conv Width Width      -- Signed int -> Float
+  | MO_FS_Conv Width Width      -- Float -> Signed int
+  | MO_SS_Conv Width Width      -- Signed int -> Signed int
+  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int
+  | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the
+                                -- contents of upper bits when extending;
+                                -- narrowing is simply truncation; the only
+                                -- expectation is that we can recover the
+                                -- original value by applying the opposite
+                                -- MO_XX_Conv, e.g.,
+                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)
+                                -- is equivalent to just x.
+  | MO_FF_Conv Width Width      -- Float -> Float
+
+  -- Vector element insertion and extraction operations
+  | MO_V_Insert  Length Width   -- Insert scalar into vector
+  | MO_V_Extract Length Width   -- Extract scalar from vector
+
+  -- Integer vector operations
+  | MO_V_Add Length Width
+  | MO_V_Sub Length Width
+  | MO_V_Mul Length Width
+
+  -- Signed vector multiply/divide
+  | MO_VS_Quot Length Width
+  | MO_VS_Rem  Length Width
+  | MO_VS_Neg  Length Width
+
+  -- Unsigned vector multiply/divide
+  | MO_VU_Quot Length Width
+  | MO_VU_Rem  Length Width
+
+  -- Floting point vector element insertion and extraction operations
+  | MO_VF_Insert  Length Width   -- Insert scalar into vector
+  | MO_VF_Extract Length Width   -- Extract scalar from vector
+
+  -- Floating point vector operations
+  | MO_VF_Add  Length Width
+  | MO_VF_Sub  Length Width
+  | MO_VF_Neg  Length Width      -- unary negation
+  | MO_VF_Mul  Length Width
+  | MO_VF_Quot Length Width
+
+  -- Alignment check (for -falignment-sanitisation)
+  | MO_AlignmentCheck Int Width
+  deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr#
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+    , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+    :: DynFlags -> MachOp
+
+mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_32To8, mo_32To16
+    :: MachOp
+
+mo_wordAdd      dflags = MO_Add (wordWidth dflags)
+mo_wordSub      dflags = MO_Sub (wordWidth dflags)
+mo_wordEq       dflags = MO_Eq  (wordWidth dflags)
+mo_wordNe       dflags = MO_Ne  (wordWidth dflags)
+mo_wordMul      dflags = MO_Mul (wordWidth dflags)
+mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)
+mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)
+mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)
+mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)
+mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)
+
+mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)
+mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)
+mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)
+mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)
+
+mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)
+mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)
+mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)
+mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)
+
+mo_wordAnd      dflags = MO_And (wordWidth dflags)
+mo_wordOr       dflags = MO_Or  (wordWidth dflags)
+mo_wordXor      dflags = MO_Xor (wordWidth dflags)
+mo_wordNot      dflags = MO_Not (wordWidth dflags)
+mo_wordShl      dflags = MO_Shl (wordWidth dflags)
+mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)
+mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)
+
+mo_u_8To32             = MO_UU_Conv W8 W32
+mo_s_8To32             = MO_SS_Conv W8 W32
+mo_u_16To32            = MO_UU_Conv W16 W32
+mo_s_16To32            = MO_SS_Conv W16 W32
+
+mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)
+mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)
+mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)
+mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)
+mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)
+mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)
+
+mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8
+mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16
+mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32
+mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64
+
+mo_32To8               = MO_UU_Conv W32 W8
+mo_32To16              = MO_UU_Conv W32 W16
+
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments.  This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop =
+  case mop of
+        MO_Add _                -> True
+        MO_Eq _                 -> True
+        MO_Ne _                 -> True
+        MO_Mul _                -> True
+        MO_S_MulMayOflo _       -> True
+        MO_U_MulMayOflo _       -> True
+        MO_And _                -> True
+        MO_Or _                 -> True
+        MO_Xor _                -> True
+        MO_F_Add _              -> True
+        MO_F_Mul _              -> True
+        _other                  -> False
+
+-- ----------------------------------------------------------------------------
+-- isAssociativeMachOp
+
+{- |
+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
+This is used in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isAssociativeMachOp :: MachOp -> Bool
+isAssociativeMachOp mop =
+  case mop of
+        MO_Add {} -> True       -- NB: does not include
+        MO_Mul {} -> True --     floatint point!
+        MO_And {} -> True
+        MO_Or  {} -> True
+        MO_Xor {} -> True
+        _other    -> False
+
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- |
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop =
+  case mop of
+    MO_Eq   _  -> True
+    MO_Ne   _  -> True
+    MO_S_Ge _  -> True
+    MO_S_Le _  -> True
+    MO_S_Gt _  -> True
+    MO_S_Lt _  -> True
+    MO_U_Ge _  -> True
+    MO_U_Le _  -> True
+    MO_U_Gt _  -> True
+    MO_U_Lt _  -> True
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
+{- |
+Returns @Just w@ if the operation is an integer comparison with width
+@w@, or @Nothing@ otherwise.
+-}
+maybeIntComparison :: MachOp -> Maybe Width
+maybeIntComparison mop =
+  case mop of
+    MO_Eq   w  -> Just w
+    MO_Ne   w  -> Just w
+    MO_S_Ge w  -> Just w
+    MO_S_Le w  -> Just w
+    MO_S_Gt w  -> Just w
+    MO_S_Lt w  -> Just w
+    MO_U_Ge w  -> Just w
+    MO_U_Le w  -> Just w
+    MO_U_Gt w  -> Just w
+    MO_U_Lt w  -> Just w
+    _ -> Nothing
+
+isFloatComparison :: MachOp -> Bool
+isFloatComparison mop =
+  case mop of
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition.  Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+  = case op of  -- None of these Just cases include floating point
+        MO_Eq r   -> Just (MO_Ne r)
+        MO_Ne r   -> Just (MO_Eq r)
+        MO_U_Lt r -> Just (MO_U_Ge r)
+        MO_U_Gt r -> Just (MO_U_Le r)
+        MO_U_Le r -> Just (MO_U_Gt r)
+        MO_U_Ge r -> Just (MO_U_Lt r)
+        MO_S_Lt r -> Just (MO_S_Ge r)
+        MO_S_Gt r -> Just (MO_S_Le r)
+        MO_S_Le r -> Just (MO_S_Gt r)
+        MO_S_Ge r -> Just (MO_S_Lt r)
+        _other    -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- machOpResultType
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType
+machOpResultType dflags mop tys =
+  case mop of
+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood
+    MO_Sub {}           -> ty1  -- of first arg
+    MO_Mul    r         -> cmmBits r
+    MO_S_MulMayOflo r   -> cmmBits r
+    MO_S_Quot r         -> cmmBits r
+    MO_S_Rem  r         -> cmmBits r
+    MO_S_Neg  r         -> cmmBits r
+    MO_U_MulMayOflo r   -> cmmBits r
+    MO_U_Quot r         -> cmmBits r
+    MO_U_Rem  r         -> cmmBits r
+
+    MO_Eq {}            -> comparisonResultRep dflags
+    MO_Ne {}            -> comparisonResultRep dflags
+    MO_S_Ge {}          -> comparisonResultRep dflags
+    MO_S_Le {}          -> comparisonResultRep dflags
+    MO_S_Gt {}          -> comparisonResultRep dflags
+    MO_S_Lt {}          -> comparisonResultRep dflags
+
+    MO_U_Ge {}          -> comparisonResultRep dflags
+    MO_U_Le {}          -> comparisonResultRep dflags
+    MO_U_Gt {}          -> comparisonResultRep dflags
+    MO_U_Lt {}          -> comparisonResultRep dflags
+
+    MO_F_Add r          -> cmmFloat r
+    MO_F_Sub r          -> cmmFloat r
+    MO_F_Mul r          -> cmmFloat r
+    MO_F_Quot r         -> cmmFloat r
+    MO_F_Neg r          -> cmmFloat r
+    MO_F_Eq  {}         -> comparisonResultRep dflags
+    MO_F_Ne  {}         -> comparisonResultRep dflags
+    MO_F_Ge  {}         -> comparisonResultRep dflags
+    MO_F_Le  {}         -> comparisonResultRep dflags
+    MO_F_Gt  {}         -> comparisonResultRep dflags
+    MO_F_Lt  {}         -> comparisonResultRep dflags
+
+    MO_And {}           -> ty1  -- Used for pointer masking
+    MO_Or {}            -> ty1
+    MO_Xor {}           -> ty1
+    MO_Not   r          -> cmmBits r
+    MO_Shl   r          -> cmmBits r
+    MO_U_Shr r          -> cmmBits r
+    MO_S_Shr r          -> cmmBits r
+
+    MO_SS_Conv _ to     -> cmmBits to
+    MO_UU_Conv _ to     -> cmmBits to
+    MO_XX_Conv _ to     -> cmmBits to
+    MO_FS_Conv _ to     -> cmmBits to
+    MO_SF_Conv _ to     -> cmmFloat to
+    MO_FF_Conv _ to     -> cmmFloat to
+
+    MO_V_Insert  l w    -> cmmVec l (cmmBits w)
+    MO_V_Extract _ w    -> cmmBits w
+
+    MO_V_Add l w        -> cmmVec l (cmmBits w)
+    MO_V_Sub l w        -> cmmVec l (cmmBits w)
+    MO_V_Mul l w        -> cmmVec l (cmmBits w)
+
+    MO_VS_Quot l w      -> cmmVec l (cmmBits w)
+    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)
+    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)
+
+    MO_VU_Quot l w      -> cmmVec l (cmmBits w)
+    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)
+
+    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)
+    MO_VF_Extract _ w   -> cmmFloat w
+
+    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)
+
+    MO_AlignmentCheck _ _ -> ty1
+  where
+    (ty1:_) = tys
+
+comparisonResultRep :: DynFlags -> CmmType
+comparisonResultRep = bWord  -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects.  This is used when
+-- linting a CmmExpr.
+
+machOpArgReps :: DynFlags -> MachOp -> [Width]
+machOpArgReps dflags op =
+  case op of
+    MO_Add    r         -> [r,r]
+    MO_Sub    r         -> [r,r]
+    MO_Eq     r         -> [r,r]
+    MO_Ne     r         -> [r,r]
+    MO_Mul    r         -> [r,r]
+    MO_S_MulMayOflo r   -> [r,r]
+    MO_S_Quot r         -> [r,r]
+    MO_S_Rem  r         -> [r,r]
+    MO_S_Neg  r         -> [r]
+    MO_U_MulMayOflo r   -> [r,r]
+    MO_U_Quot r         -> [r,r]
+    MO_U_Rem  r         -> [r,r]
+
+    MO_S_Ge r           -> [r,r]
+    MO_S_Le r           -> [r,r]
+    MO_S_Gt r           -> [r,r]
+    MO_S_Lt r           -> [r,r]
+
+    MO_U_Ge r           -> [r,r]
+    MO_U_Le r           -> [r,r]
+    MO_U_Gt r           -> [r,r]
+    MO_U_Lt r           -> [r,r]
+
+    MO_F_Add r          -> [r,r]
+    MO_F_Sub r          -> [r,r]
+    MO_F_Mul r          -> [r,r]
+    MO_F_Quot r         -> [r,r]
+    MO_F_Neg r          -> [r]
+    MO_F_Eq  r          -> [r,r]
+    MO_F_Ne  r          -> [r,r]
+    MO_F_Ge  r          -> [r,r]
+    MO_F_Le  r          -> [r,r]
+    MO_F_Gt  r          -> [r,r]
+    MO_F_Lt  r          -> [r,r]
+
+    MO_And   r          -> [r,r]
+    MO_Or    r          -> [r,r]
+    MO_Xor   r          -> [r,r]
+    MO_Not   r          -> [r]
+    MO_Shl   r          -> [r, wordWidth dflags]
+    MO_U_Shr r          -> [r, wordWidth dflags]
+    MO_S_Shr r          -> [r, wordWidth dflags]
+
+    MO_SS_Conv from _   -> [from]
+    MO_UU_Conv from _   -> [from]
+    MO_XX_Conv from _   -> [from]
+    MO_SF_Conv from _   -> [from]
+    MO_FS_Conv from _   -> [from]
+    MO_FF_Conv from _   -> [from]
+
+    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]
+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]
+
+    MO_V_Add _ r        -> [r,r]
+    MO_V_Sub _ r        -> [r,r]
+    MO_V_Mul _ r        -> [r,r]
+
+    MO_VS_Quot _ r      -> [r,r]
+    MO_VS_Rem  _ r      -> [r,r]
+    MO_VS_Neg  _ r      -> [r]
+
+    MO_VU_Quot _ r      -> [r,r]
+    MO_VU_Rem  _ r      -> [r,r]
+
+    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]
+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]
+
+    MO_VF_Add  _ r      -> [r,r]
+    MO_VF_Sub  _ r      -> [r,r]
+    MO_VF_Mul  _ r      -> [r,r]
+    MO_VF_Quot _ r      -> [r,r]
+    MO_VF_Neg  _ r      -> [r]
+
+    MO_AlignmentCheck _ r -> [r]
+
+-----------------------------------------------------------------------------
+-- CallishMachOp
+-----------------------------------------------------------------------------
+
+-- CallishMachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out.  In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+  = MO_F64_Pwr
+  | MO_F64_Sin
+  | MO_F64_Cos
+  | MO_F64_Tan
+  | MO_F64_Sinh
+  | MO_F64_Cosh
+  | MO_F64_Tanh
+  | MO_F64_Asin
+  | MO_F64_Acos
+  | MO_F64_Atan
+  | MO_F64_Asinh
+  | MO_F64_Acosh
+  | MO_F64_Atanh
+  | MO_F64_Log
+  | MO_F64_Exp
+  | MO_F64_Fabs
+  | MO_F64_Sqrt
+  | MO_F32_Pwr
+  | MO_F32_Sin
+  | MO_F32_Cos
+  | MO_F32_Tan
+  | MO_F32_Sinh
+  | MO_F32_Cosh
+  | MO_F32_Tanh
+  | MO_F32_Asin
+  | MO_F32_Acos
+  | MO_F32_Atan
+  | MO_F32_Asinh
+  | MO_F32_Acosh
+  | MO_F32_Atanh
+  | MO_F32_Log
+  | MO_F32_Exp
+  | MO_F32_Fabs
+  | MO_F32_Sqrt
+
+  | MO_UF_Conv Width
+
+  | MO_S_QuotRem Width
+  | MO_U_QuotRem Width
+  | MO_U_QuotRem2 Width
+  | MO_Add2      Width
+  | MO_AddWordC  Width
+  | MO_SubWordC  Width
+  | MO_AddIntC   Width
+  | MO_SubIntC   Width
+  | MO_U_Mul2    Width
+
+  | MO_WriteBarrier
+  | MO_Touch         -- Keep variables live (when using interior pointers)
+
+  -- Prefetch
+  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not
+                     -- program behavior.
+                     -- the Int can be 0-3. Needs to be known at compile time
+                     -- to interact with code generation correctly.
+                     --  TODO: add support for prefetch WRITES,
+                     --  currently only exposes prefetch reads, which
+                     -- would the majority of use cases in ghc anyways
+
+
+  -- These three MachOps are parameterised by the known alignment
+  -- of the destination and source (for memcpy/memmove) pointers.
+  -- This information may be used for optimisation in backends.
+  | MO_Memcpy Int
+  | MO_Memset Int
+  | MO_Memmove Int
+  | MO_Memcmp Int
+
+  | MO_PopCnt Width
+  | MO_Pdep Width
+  | MO_Pext Width
+  | MO_Clz Width
+  | MO_Ctz Width
+
+  | MO_BSwap Width
+  | MO_BRev Width
+
+  -- Atomic read-modify-write.
+  | MO_AtomicRMW Width AtomicMachOp
+  | MO_AtomicRead Width
+  | MO_AtomicWrite Width
+  | MO_Cmpxchg Width
+  deriving (Eq, Show)
+
+-- | The operation to perform atomically.
+data AtomicMachOp =
+      AMO_Add
+    | AMO_Sub
+    | AMO_And
+    | AMO_Nand
+    | AMO_Or
+    | AMO_Xor
+      deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
+
+callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
+callishMachOpHints op = case op of
+  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])
+  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])
+  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
+  MO_Memcmp _  -> ([], [AddrHint, AddrHint, NoHint])
+  _            -> ([],[])
+  -- empty lists indicate NoHint
+
+-- | The alignment of a 'memcpy'-ish operation.
+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int
+machOpMemcpyishAlign op = case op of
+  MO_Memcpy  align -> Just align
+  MO_Memset  align -> Just align
+  MO_Memmove align -> Just align
+  MO_Memcmp  align -> Just align
+  _                -> Nothing
diff --git a/compiler/cmm/CmmMonad.hs b/compiler/cmm/CmmMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmMonad.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- A Parser monad with access to the 'DynFlags'.
+--
+-- The 'P' monad  only has access to the subset of of 'DynFlags'
+-- required for parsing Haskell.
+
+-- The parser for C-- requires access to a lot more of the 'DynFlags',
+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
+-----------------------------------------------------------------------------
+module CmmMonad (
+    PD(..)
+  , liftP
+  ) where
+
+import GhcPrelude
+
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+
+import DynFlags
+import Lexer
+
+newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
+
+instance Functor PD where
+  fmap = liftM
+
+instance Applicative PD where
+  pure = returnPD
+  (<*>) = ap
+
+instance Monad PD where
+  (>>=) = thenPD
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail PD where
+  fail = failPD
+
+liftP :: P a -> PD a
+liftP (P f) = PD $ \_ s -> f s
+
+returnPD :: a -> PD a
+returnPD = liftP . return
+
+thenPD :: PD a -> (a -> PD b) -> PD b
+(PD m) `thenPD` k = PD $ \d s ->
+        case m d s of
+                POk s1 a         -> unPD (k a) d s1
+                PFailed s1 -> PFailed s1
+
+failPD :: String -> PD a
+failPD = liftP . fail
+
+instance HasDynFlags PD where
+   getDynFlags = PD $ \d s -> POk s d
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmNode.hs
@@ -0,0 +1,724 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+-- CmmNode type for representation using Hoopl graphs.
+
+module CmmNode (
+     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
+     UpdFrameOffset, Convention(..),
+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
+     CmmReturnInfo(..),
+     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
+
+     -- * Tick scopes
+     CmmTickScope(..), isTickSubScope, combineTickScopes,
+  ) where
+
+import GhcPrelude hiding (succ)
+
+import CodeGen.Platform
+import CmmExpr
+import CmmSwitch
+import DynFlags
+import FastString
+import ForeignCall
+import Outputable
+import SMRep
+import CoreSyn (Tickish)
+import qualified Unique as U
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+import Data.Maybe
+import Data.List (tails,sortBy)
+import Unique (nonDetCmpUnique)
+import Util
+
+
+------------------------
+-- CmmNode
+
+#define ULabel {-# UNPACK #-} !Label
+
+data CmmNode e x where
+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
+
+  CmmComment :: FastString -> CmmNode O O
+
+    -- Tick annotation, covering Cmm code in our tick scope. We only
+    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
+    -- See Note [CmmTick scoping details]
+  CmmTick :: !CmmTickish -> CmmNode O O
+
+    -- Unwind pseudo-instruction, encoding stack unwinding
+    -- instructions for a debugger. This describes how to reconstruct
+    -- the "old" value of a register if we want to navigate the stack
+    -- up one frame. Having unwind information for @Sp@ will allow the
+    -- debugger to "walk" the stack.
+    --
+    -- See Note [What is this unwinding business?] in Debug
+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
+
+  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
+    -- Assign to register
+
+  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
+    -- Assign to memory location.  Size is
+    -- given by cmmExprType of the rhs.
+
+  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
+                                -- see Note [Foreign calls]
+                                -- Like a "fat machine instruction"; can occur
+                                -- in the middle of a block
+      ForeignTarget ->          -- call target
+      [CmmFormal] ->            -- zero or more results
+      [CmmActual] ->            -- zero or more arguments
+      CmmNode O O
+      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
+      -- See Note [Unsafe foreign calls clobber caller-save registers]
+      --
+      -- Invariant: the arguments and the ForeignTarget must not
+      -- mention any registers for which CodeGen.Platform.callerSaves
+      -- is True.  See Note [Register Parameter Passing].
+
+  CmmBranch :: ULabel -> CmmNode O C
+                                   -- Goto another block in the same procedure
+
+  CmmCondBranch :: {                 -- conditional branch
+      cml_pred :: CmmExpr,
+      cml_true, cml_false :: ULabel,
+      cml_likely :: Maybe Bool       -- likely result of the conditional,
+                                     -- if known
+  } -> CmmNode O C
+
+  CmmSwitch
+    :: CmmExpr       -- Scrutinee, of some integral type
+    -> SwitchTargets -- Cases. See [Note SwitchTargets]
+    -> CmmNode O C
+
+  CmmCall :: {                -- A native call or tail call
+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
+
+      cml_cont :: Maybe Label,
+          -- Label of continuation (Nothing for return or tail call)
+          --
+          -- Note [Continuation BlockId]: these BlockIds are called
+          -- Continuation BlockIds, and are the only BlockIds that can
+          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
+          -- (CmmStackSlot (Young b) _).
+
+      cml_args_regs :: [GlobalReg],
+          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
+          -- to the call.  This is essential information for the
+          -- native code generator's register allocator; without
+          -- knowing which GlobalRegs are live it has to assume that
+          -- they are all live.  This list should only include
+          -- GlobalRegs that are mapped to real machine registers on
+          -- the target platform.
+
+      cml_args :: ByteOff,
+          -- Byte offset, from the *old* end of the Area associated with
+          -- the Label (if cml_cont = Nothing, then Old area), of
+          -- youngest outgoing arg.  Set the stack pointer to this before
+          -- transferring control.
+          -- (NB: an update frame might also have been stored in the Old
+          --      area, but it'll be in an older part than the args.)
+
+      cml_ret_args :: ByteOff,
+          -- For calls *only*, the byte offset for youngest returned value
+          -- This is really needed at the *return* point rather than here
+          -- at the call, but in practice it's convenient to record it here.
+
+      cml_ret_off :: ByteOff
+        -- For calls *only*, the byte offset of the base of the frame that
+        -- must be described by the info table for the return point.
+        -- The older words are an update frames, which have their own
+        -- info-table and layout information
+
+        -- From a liveness point of view, the stack words older than
+        -- cml_ret_off are treated as live, even if the sequel of
+        -- the call goes into a loop.
+  } -> CmmNode O C
+
+  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
+                                -- Always the last node of a block
+      tgt   :: ForeignTarget,   -- call target and convention
+      res   :: [CmmFormal],     -- zero or more results
+      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
+      succ  :: ULabel,          -- Label of continuation
+      ret_args :: ByteOff,      -- same as cml_ret_args
+      ret_off :: ByteOff,       -- same as cml_ret_off
+      intrbl:: Bool             -- whether or not the call is interruptible
+  } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction".  In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.)  However, see [Register parameter passing].
+
+Safe ones are trickier.  A safe foreign call
+     r = f(x)
+ultimately expands to
+     push "return address"      -- Never used to return to;
+                                -- just points an info table
+     save registers into TSO
+     call suspendThread
+     r = f(x)                   -- Make the call
+     call resumeThread
+     restore registers
+     pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+
+Note that a safe foreign call needs an info table.
+
+So Safe Foreign Calls must remain as last nodes until the stack is
+made manifest in CmmLayoutStack, where they are lowered into the above
+sequence.
+-}
+
+{- Note [Unsafe foreign calls clobber caller-save registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A foreign call is defined to clobber any GlobalRegs that are mapped to
+caller-saves machine registers (according to the prevailing C ABI).
+StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.
+
+This is a design choice that makes it easier to generate code later.
+We could instead choose to say that foreign calls do *not* clobber
+caller-saves regs, but then we would have to figure out which regs
+were live across the call later and insert some saves/restores.
+
+Furthermore when we generate code we never have any GlobalRegs live
+across a call, because they are always copied-in to LocalRegs and
+copied-out again before making a call/jump.  So all we have to do is
+avoid any code motion that would make a caller-saves GlobalReg live
+across a foreign call during subsequent optimisations.
+-}
+
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention.  For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing.  These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call.  This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments.  This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently.  We should fix this!
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+
+deriving instance Eq (CmmNode e x)
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+  entryLabel (CmmEntry l _) = l
+
+  successors (CmmBranch l) = [l]
+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+  successors (CmmSwitch _ ids) = switchTargetsToList ids
+  successors (CmmCall {cml_cont=l}) = maybeToList l
+  successors (CmmForeignCall {succ=l}) = [l]
+
+
+--------------------------------------------------
+-- Various helper types
+
+type CmmActual = CmmExpr
+type CmmFormal = LocalReg
+
+type UpdFrameOffset = ByteOff
+
+-- | A convention maps a list of values (function arguments or return
+-- values) to registers or stack locations.
+data Convention
+  = NativeDirectCall
+       -- ^ top-level Haskell functions use @NativeDirectCall@, which
+       -- maps arguments to registers starting with R2, according to
+       -- how many registers are available on the platform.  This
+       -- convention ignores R1, because for a top-level function call
+       -- the function closure is implicit, and doesn't need to be passed.
+  | NativeNodeCall
+       -- ^ non-top-level Haskell functions, which pass the address of
+       -- the function closure in R1 (regardless of whether R1 is a
+       -- real register or not), and the rest of the arguments in
+       -- registers or on the stack.
+  | NativeReturn
+       -- ^ a native return.  The convention for returns depends on
+       -- how many values are returned: for just one value returned,
+       -- the appropriate register is used (R1, F1, etc.). regardless
+       -- of whether it is a real register or not.  For multiple
+       -- values returned, they are mapped to registers or the stack.
+  | Slow
+       -- ^ Slow entry points: all args pushed on the stack
+  | GC
+       -- ^ Entry to the garbage collector: uses the node reg!
+       -- (TODO: I don't think we need this --SDM)
+  deriving( Eq )
+
+data ForeignConvention
+  = ForeignConvention
+        CCallConv               -- Which foreign-call convention
+        [ForeignHint]           -- Extra info about the args
+        [ForeignHint]           -- Extra info about the result
+        CmmReturnInfo
+  deriving Eq
+
+data CmmReturnInfo
+  = CmmMayReturn
+  | CmmNeverReturns
+  deriving ( Eq )
+
+data ForeignTarget        -- The target of a foreign call
+  = ForeignTarget                -- A foreign procedure
+        CmmExpr                  -- Its address
+        ForeignConvention        -- Its calling convention
+  | PrimTarget            -- A possibly-side-effecting machine operation
+        CallishMachOp            -- Which one
+  deriving Eq
+
+foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+foreignTargetHints target
+  = ( res_hints ++ repeat NoHint
+    , arg_hints ++ repeat NoHint )
+  where
+    (res_hints, arg_hints) =
+       case target of
+          PrimTarget op -> callishMachOpHints op
+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
+             (res_hints, arg_hints)
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfRegs LocalReg (CmmNode e x) where
+  foldRegsUsed dflags f !z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt} -> fold f z tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b. UserOfRegs LocalReg a
+               => (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
+
+instance UserOfRegs GlobalReg (CmmNode e x) where
+  foldRegsUsed dflags f !z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b.  UserOfRegs GlobalReg a
+               => (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
+  foldRegsUsed _      _ !z (PrimTarget _)      = z
+  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e
+
+instance DefinerOfRegs LocalReg (CmmNode e x) where
+  foldRegsDefd dflags f !z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall _ fs _ -> fold f z fs
+    CmmForeignCall {res=res} -> fold f z res
+    _ -> z
+    where fold :: forall a b. DefinerOfRegs LocalReg a
+               => (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+instance DefinerOfRegs GlobalReg (CmmNode e x) where
+  foldRegsDefd dflags f !z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
+    CmmCall        {} -> fold f z activeRegs
+    CmmForeignCall {} -> fold f z activeRegs
+                      -- See Note [Safe foreign calls clobber STG registers]
+    _ -> z
+    where fold :: forall a b. DefinerOfRegs GlobalReg a
+               => (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+          platform = targetPlatform dflags
+          activeRegs = activeStgRegs platform
+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs
+
+          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
+          foreignTargetRegs _ = activeCallerSavesRegs
+
+-- Note [Safe foreign calls clobber STG registers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During stack layout phase every safe foreign call is expanded into a block
+-- that contains unsafe foreign call (instead of safe foreign call) and ends
+-- with a normal call (See Note [Foreign calls]). This means that we must
+-- treat safe foreign call as if it was a normal call (because eventually it
+-- will be). This is important if we try to run sinking pass before stack
+-- layout phase. Consider this example of what might go wrong (this is cmm
+-- code from stablename001 test). Here is code after common block elimination
+-- (before stack layout):
+--
+--  c1q6:
+--      _s1pf::P64 = R1;
+--      _c1q8::I64 = performMajorGC;
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- If we run sinking pass now (still before stack layout) we will get this:
+--
+--  c1q6:
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
+-- safe call to performMajorGC will be turned into:
+--
+--  c1q6:
+--      _s1pc::P64 = P64[Sp + 8];
+--      I64[Sp - 8] = c1q9;
+--      Sp = Sp - 8;
+--      I64[I64[CurrentTSO + 24] + 16] = Sp;
+--      P64[CurrentNursery + 8] = Hp + 8;
+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
+--      BaseReg = _u1qJ::I64;
+--      _u1qK::P64 = CurrentTSO;
+--      _u1qL::P64 = I64[_u1qK::P64 + 24];
+--      Sp = I64[_u1qL::P64 + 16];
+--      SpLim = _u1qL::P64 + 192;
+--      HpAlloc = 0;
+--      Hp = I64[CurrentNursery + 8] - 8;
+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ INCORRECT!
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
+-- call is clearly incorrect. This is what would happen if we assumed that
+-- safe foreign call has the same semantics as unsafe foreign call. To prevent
+-- this we need to treat safe foreign call as if was normal call.
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _   m@(PrimTarget _)      = m
+
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+-- Take a transformer on expressions and apply it recursively.
+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
+--                  then  uses f to rewrite the resulting expression
+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e                    = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry{})                          = f
+mapExp _ m@(CmmComment _)                        = m
+mapExp _ m@(CmmTick _)                           = m
+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)
+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _)                         = l
+mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l
+mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids
+mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}
+mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+------------------------------------------------------------------------
+-- mapping Expr in CmmNode, but not performing allocation if no changes
+
+mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
+mapForeignTargetM _ (PrimTarget _)      = Nothing
+
+wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
+--                   then  gives f a chance to rewrite the resulting expression
+wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
+wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
+wrapRecExpM f e                    = f e
+
+mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpM _ (CmmEntry{})              = Nothing
+mapExpM _ (CmmComment _)            = Nothing
+mapExpM _ (CmmTick _)               = Nothing
+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
+mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
+mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
+mapExpM _ (CmmBranch _)             = Nothing
+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
+mapExpM f (CmmUnsafeForeignCall tgt fs as)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
+
+-- share as much as possible
+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
+mapListM f xs = let (b, r) = mapListT f xs
+                in if b then Just r else Nothing
+
+mapListJ :: (a -> Maybe a) -> [a] -> [a]
+mapListJ f xs = snd (mapListT f xs)
+
+mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
+          g (ys', _, Nothing) (False, _)  = (False, ys')
+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)
+
+mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpDeepM f = mapExpM $ wrapRecExpM f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _   (PrimTarget _)      z = z
+
+-- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e                  z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z                         = z
+foldExp _ (CmmComment {}) z                       = z
+foldExp _ (CmmTick {}) z                          = z
+foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)
+foldExp f (CmmAssign _ e) z                       = f e z
+foldExp f (CmmStore addr e) z                     = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z                         = z
+foldExp f (CmmCondBranch e _ _ _) z               = f e z
+foldExp f (CmmSwitch e _) z                       = f e z
+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp (wrapRecExpf f)
+
+-- -----------------------------------------------------------------------------
+
+mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
+mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)
+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
+mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)
+mapSuccessors _ n = n
+
+mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
+                     -> (CmmNode O C, [a])
+mapCollectSuccessors f (CmmBranch bid)
+  = let (bid', acc) = f bid in (CmmBranch bid', [acc])
+mapCollectSuccessors f (CmmCondBranch p y n l)
+  = let (bidt, acct) = f y
+        (bidf, accf) = f n
+    in  (CmmCondBranch p bidt bidf l, [accf, acct])
+mapCollectSuccessors f (CmmSwitch e ids)
+  = let lbls = switchTargetsToList ids :: [Label]
+        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
+    in ( CmmSwitch e
+          (mapSwitchTargets
+            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
+          , map snd (mapElems lblMap)
+        )
+mapCollectSuccessors _ n = (n, [])
+
+-- -----------------------------------------------------------------------------
+
+-- | Tickish in Cmm context (annotations only)
+type CmmTickish = Tickish ()
+
+-- | Tick scope identifier, allowing us to reason about what
+-- annotations in a Cmm block should scope over. We especially take
+-- care to allow optimisations to reorganise blocks without losing
+-- tick association in the process.
+data CmmTickScope
+  = GlobalScope
+    -- ^ The global scope is the "root" of the scope graph. Every
+    -- scope is a sub-scope of the global scope. It doesn't make sense
+    -- to add ticks to this scope. On the other hand, this means that
+    -- setting this scope on a block means no ticks apply to it.
+
+  | SubScope !U.Unique CmmTickScope
+    -- ^ Constructs a new sub-scope to an existing scope. This allows
+    -- us to translate Core-style scoping rules (see @tickishScoped@)
+    -- into the Cmm world. Suppose the following code:
+    --
+    --   tick<1> case ... of
+    --             A -> tick<2> ...
+    --             B -> tick<3> ...
+    --
+    -- We want the top-level tick annotation to apply to blocks
+    -- generated for the A and B alternatives. We can achieve that by
+    -- generating tick<1> into a block with scope a, while the code
+    -- for alternatives A and B gets generated into sub-scopes a/b and
+    -- a/c respectively.
+
+  | CombinedScope CmmTickScope CmmTickScope
+    -- ^ A combined scope scopes over everything that the two given
+    -- scopes cover. It is therefore a sub-scope of either scope. This
+    -- is required for optimisations. Consider common block elimination:
+    --
+    --   A -> tick<2> case ... of
+    --     C -> [common]
+    --   B -> tick<3> case ... of
+    --     D -> [common]
+    --
+    -- We will generate code for the C and D alternatives, and figure
+    -- out afterwards that it's actually common code. Scoping rules
+    -- dictate that the resulting common block needs to be covered by
+    -- both tick<2> and tick<3>, therefore we need to construct a
+    -- scope that is a child to *both* scope. Now we can do that - if
+    -- we assign the scopes a/c and b/d to the common-ed up blocks,
+    -- the new block could have a combined tick scope a/c+b/d, which
+    -- both tick<2> and tick<3> apply to.
+
+-- Note [CmmTick scoping details]:
+--
+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
+-- same block. Note that as a result of this, optimisations making
+-- tick scopes more specific can *reduce* the amount of code a tick
+-- scopes over. Fixing this would require a separate @CmmTickScope@
+-- field for @CmmTick@. Right now we do not do this simply because I
+-- couldn't find an example where it actually mattered -- multiple
+-- blocks within the same scope generally jump to each other, which
+-- prevents common block elimination from happening in the first
+-- place. But this is no strong reason, so if Cmm optimisations become
+-- more involved in future this might have to be revisited.
+
+-- | Output all scope paths.
+scopeToPaths :: CmmTickScope -> [[U.Unique]]
+scopeToPaths GlobalScope           = [[]]
+scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)
+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
+
+-- | Returns the head uniques of the scopes. This is based on the
+-- assumption that the @Unique@ of @SubScope@ identifies the
+-- underlying super-scope. Used for efficient equality and comparison,
+-- see below.
+scopeUniques :: CmmTickScope -> [U.Unique]
+scopeUniques GlobalScope           = []
+scopeUniques (SubScope u _)        = [u]
+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
+
+-- Equality and order is based on the head uniques defined above. We
+-- take care to short-cut the (extremly) common cases.
+instance Eq CmmTickScope where
+  GlobalScope    == GlobalScope     = True
+  GlobalScope    == _               = False
+  _              == GlobalScope     = False
+  (SubScope u _) == (SubScope u' _) = u == u'
+  (SubScope _ _) == _               = False
+  _              == (SubScope _ _)  = False
+  scope          == scope'          =
+    sortBy nonDetCmpUnique (scopeUniques scope) ==
+    sortBy nonDetCmpUnique (scopeUniques scope')
+    -- This is still deterministic because
+    -- the order is the same for equal lists
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord CmmTickScope where
+  compare GlobalScope    GlobalScope     = EQ
+  compare GlobalScope    _               = LT
+  compare _              GlobalScope     = GT
+  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
+  compare scope scope'                   = cmpList nonDetCmpUnique
+     (sortBy nonDetCmpUnique $ scopeUniques scope)
+     (sortBy nonDetCmpUnique $ scopeUniques scope')
+
+instance Outputable CmmTickScope where
+  ppr GlobalScope     = text "global"
+  ppr (SubScope us GlobalScope)
+                      = ppr us
+  ppr (SubScope us s) = ppr s <> char '/' <> ppr us
+  ppr combined        = parens $ hcat $ punctuate (char '+') $
+                        map (hcat . punctuate (char '/') . map ppr . reverse) $
+                        scopeToPaths combined
+
+-- | Checks whether two tick scopes are sub-scopes of each other. True
+-- if the two scopes are equal.
+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
+isTickSubScope = cmp
+  where cmp _              GlobalScope             = True
+        cmp GlobalScope    _                       = False
+        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'
+        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
+        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'
+
+-- | Combine two tick scopes. The new scope should be sub-scope of
+-- both parameters. We simplfy automatically if one tick scope is a
+-- sub-scope of the other already.
+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
+combineTickScopes s1 s2
+  | s1 `isTickSubScope` s2 = s1
+  | s2 `isTickSubScope` s1 = s2
+  | otherwise              = CombinedScope s1 s2
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmOpt.hs
@@ -0,0 +1,427 @@
+-- The default iteration limit is a bit too low for the definitions
+-- in this module.
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
+
+-----------------------------------------------------------------------------
+--
+-- Cmm optimisation
+--
+-- (c) The University of Glasgow 2006
+--
+-----------------------------------------------------------------------------
+
+module CmmOpt (
+        constantFoldNode,
+        constantFoldExpr,
+        cmmMachOpFold,
+        cmmMachOpFoldM
+ ) where
+
+import GhcPrelude
+
+import CmmUtils
+import Cmm
+import DynFlags
+import Util
+
+import Outputable
+import Platform
+
+import Data.Bits
+import Data.Maybe
+
+
+constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x
+constantFoldNode dflags = mapExp (constantFoldExpr dflags)
+
+constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr
+constantFoldExpr dflags = wrapRecExp f
+  where f (CmmMachOp op args) = cmmMachOpFold dflags op args
+        f (CmmRegOff r 0) = CmmReg r
+        f e = e
+
+-- -----------------------------------------------------------------------------
+-- MachOp constant folder
+
+-- Now, try to constant-fold the MachOps.  The arguments have already
+-- been optimized and folded.
+
+cmmMachOpFold
+    :: DynFlags
+    -> MachOp       -- The operation from an CmmMachOp
+    -> [CmmExpr]    -- The optimized arguments
+    -> CmmExpr
+
+cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)
+
+-- Returns Nothing if no changes, useful for Hoopl, also reduces
+-- allocation!
+cmmMachOpFoldM
+    :: DynFlags
+    -> MachOp
+    -> [CmmExpr]
+    -> Maybe CmmExpr
+
+cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
+  = Just $ case op of
+      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)
+      MO_Not _   -> CmmLit (CmmInt (complement x) rep)
+
+        -- these are interesting: we must first narrow to the
+        -- "from" type, in order to truncate to the correct size.
+        -- The final narrow/widen to the destination type
+        -- is implicit in the CmmLit.
+      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
+      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)
+      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)
+
+      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
+
+
+-- Eliminate conversion NOPs
+cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
+cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
+
+-- Eliminate nested conversions where possible
+cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
+  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
+    Just (_,   rep3,signed2) <- isIntConversion conv_outer
+  = case () of
+        -- widen then narrow to the same size is a nop
+      _ | rep1 < rep2 && rep1 == rep3 -> Just x
+        -- Widen then narrow to different size: collapse to single conversion
+        -- but remember to use the signedness from the widening, just in case
+        -- the final conversion is a widen.
+        | rep1 < rep2 && rep2 > rep3 ->
+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+        -- Nested widenings: collapse if the signedness is the same
+        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+        -- Nested narrowings: collapse
+        | rep1 > rep2 && rep2 > rep3 ->
+            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]
+        | otherwise ->
+            Nothing
+  where
+        isIntConversion (MO_UU_Conv rep1 rep2)
+          = Just (rep1,rep2,False)
+        isIntConversion (MO_SS_Conv rep1 rep2)
+          = Just (rep1,rep2,True)
+        isIntConversion _ = Nothing
+
+        intconv True  = MO_SS_Conv
+        intconv False = MO_UU_Conv
+
+-- ToDo: a narrow of a load can be collapsed into a narrow load, right?
+-- but what if the architecture only supports word-sized loads, should
+-- we do the transformation anyway?
+
+cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+  = case mop of
+        -- for comparisons: don't forget to narrow the arguments before
+        -- comparing, since they might be out of range.
+        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
+        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))
+
+        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))
+        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
+        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))
+        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))
+
+        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))
+        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
+        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))
+        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))
+
+        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
+        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
+        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)
+        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)
+        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)
+        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)
+        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)
+
+        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)
+        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)
+        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)
+
+        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
+        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
+        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
+
+        _          -> Nothing
+
+   where
+        x_u = narrowU xrep x
+        y_u = narrowU xrep y
+        x_s = narrowS xrep x
+        y_s = narrowS xrep y
+
+
+-- When possible, shift the constants to the right-hand side, so that we
+-- can match for strength reductions.  Note that the code generator will
+-- also assume that constants have been shifted to the right when
+-- possible.
+
+cmmMachOpFoldM dflags op [x@(CmmLit _), y]
+   | not (isLit y) && isCommutableMachOp op
+   = Just (cmmMachOpFold dflags op [y, x])
+
+-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
+-- moved to the right, it is more likely that we will find
+-- opportunities for constant folding when the expression is
+-- right-associated.
+--
+-- ToDo: this appears to introduce a quadratic behaviour due to the
+-- nested cmmMachOpFold.  Can we fix this?
+--
+-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
+-- is also a lit (otherwise arg1 would be on the right).  If we
+-- put arg1 on the left of the rearranged expression, we'll get into a
+-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
+--
+-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
+-- PicBaseReg from the corresponding label (or label difference).
+--
+cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+   | mop2 `associates_with` mop1
+     && not (isLit arg1) && not (isPicReg arg1)
+   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])
+   where
+     MO_Add{} `associates_with` MO_Sub{} = True
+     mop1 `associates_with` mop2 =
+        mop1 == mop2 && isAssociativeMachOp mop1
+
+-- special case: (a - b) + c  ==>  a + (c - b)
+cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
+   | not (isLit arg1) && not (isPicReg arg1)
+   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
+
+-- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)
+--
+-- this is better because lit+N is a single link-time constant (e.g. a
+-- CmmLabelOff), so the right-hand expression needs only one
+-- instruction, whereas the left needs two.  This happens when pointer
+-- tagging gives us label+offset, and PIC turns the label into
+-- PicBaseReg + label.
+--
+cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]
+                          , CmmLit (CmmInt n rep) ]
+  | isPicReg pic
+  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]
+  where off = fromIntegral (narrowS rep n)
+
+-- Make a RegOff if we can
+cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))
+cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))
+cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))
+cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))
+
+-- Fold label(+/-)offset into a CmmLit where possible
+
+cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))
+
+
+-- Comparison of literal with widened operand: perform the comparison
+-- at the smaller width, as long as the literal is within range.
+
+-- We can't do the reverse trick, when the operand is narrowed:
+-- narrowing throws away bits from the operand, there's no way to do
+-- the same comparison at the larger size.
+
+cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
+    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
+        -- if the operand is widened:
+    Just (rep, signed, narrow_fn) <- maybe_conversion conv,
+        -- and this is a comparison operation:
+    Just narrow_cmp <- maybe_comparison cmp rep signed,
+        -- and the literal fits in the smaller size:
+    i == narrow_fn rep i
+        -- then we can do the comparison at the smaller size
+  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
+ where
+    maybe_conversion (MO_UU_Conv from to)
+        | to > from
+        = Just (from, False, narrowU)
+    maybe_conversion (MO_SS_Conv from to)
+        | to > from
+        = Just (from, True, narrowS)
+
+        -- don't attempt to apply this optimisation when the source
+        -- is a float; see #1916
+    maybe_conversion _ = Nothing
+
+        -- careful (#2080): if the original comparison was signed, but
+        -- we were doing an unsigned widen, then we must do an
+        -- unsigned comparison at the smaller size.
+    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)
+    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)
+    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)
+    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)
+    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)
+    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)
+    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)
+    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)
+    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)
+    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)
+    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)
+    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)
+    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)
+    maybe_comparison _ _ _ = Nothing
+
+-- We can often do something with constants of 0 and 1 ...
+-- See Note [Comparison operators]
+
+cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
+  = case mop of
+        -- Arithmetic
+        MO_Add   _ -> Just x   -- x + 0 = x
+        MO_Sub   _ -> Just x   -- x - 0 = x
+        MO_Mul   _ -> Just y   -- x * 0 = 0
+
+        -- Logical operations
+        MO_And   _ -> Just y   -- x &     0 = 0
+        MO_Or    _ -> Just x   -- x |     0 = x
+        MO_Xor   _ -> Just x   -- x `xor` 0 = x
+
+        -- Shifts
+        MO_Shl   _ -> Just x   -- x << 0 = x
+        MO_S_Shr _ -> Just x   -- ditto shift-right
+        MO_U_Shr _ -> Just x
+
+        -- Comparisons; these ones are trickier
+        -- See Note [Comparison operators]
+        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y
+        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y
+        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y
+        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto
+        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0
+        MO_S_Lt  _ | isComparisonExpr x -> Just zero
+        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1
+        MO_S_Ge  _ | isComparisonExpr x -> Just one
+
+        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y
+        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'
+        _ -> Nothing
+  where
+    zero = CmmLit (CmmInt 0 (wordWidth dflags))
+    one  = CmmLit (CmmInt 1 (wordWidth dflags))
+
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
+  = case mop of
+        -- Arithmetic: x*1 = x, etc
+        MO_Mul    _ -> Just x
+        MO_S_Quot _ -> Just x
+        MO_U_Quot _ -> Just x
+        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
+        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
+
+        -- Comparisons; trickier
+        -- See Note [Comparison operators]
+        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y
+        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y
+        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y
+        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto
+        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0
+        MO_S_Gt  _ | isComparisonExpr x -> Just zero
+        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1
+        MO_S_Le  _ | isComparisonExpr x -> Just one
+        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y
+        MO_S_Ge  _ | isComparisonExpr x -> Just x
+        _ -> Nothing
+  where
+    zero = CmmLit (CmmInt 0 (wordWidth dflags))
+    one  = CmmLit (CmmInt 1 (wordWidth dflags))
+
+-- Now look for multiplication/division by powers of 2 (integers).
+
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
+  = case mop of
+        MO_Mul rep
+           | Just p <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
+        MO_U_Quot rep
+           | Just p <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+        MO_U_Rem rep
+           | Just _ <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
+        MO_S_Quot rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                Just (cmmMachOpFold dflags (MO_S_Shr rep)
+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
+        MO_S_Rem rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
+                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
+                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
+                Just (cmmMachOpFold dflags (MO_Sub rep)
+                    [x, cmmMachOpFold dflags (MO_And rep)
+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
+        _ -> Nothing
+  where
+    -- In contrast with unsigned integers, for signed ones
+    -- shift right is not the same as quot, because it rounds
+    -- to minus infinity, whereas quot rounds toward zero.
+    -- To fix this up, we add one less than the divisor to the
+    -- dividend if it is a negative number.
+    --
+    -- to avoid a test/jump, we use the following sequence:
+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
+    --      x2 = y & (divisor-1)
+    --      result = x + x2
+    -- this could be done a bit more simply using conditional moves,
+    -- but we're processor independent here.
+    --
+    -- we optimise the divide by 2 case slightly, generating
+    --      x1 = x >> word_size-1  (unsigned)
+    --      return = x + x1
+    signedQuotRemHelper :: Width -> Integer -> CmmExpr
+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
+      where
+        bits = fromIntegral (widthInBits rep) - 1
+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
+        x2 = if p == 1 then x1 else
+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
+
+-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
+-- Unfortunately this needs a unique supply because x might not be a
+-- register.  See #2253 (program 6) for an example.
+
+
+-- Anything else is just too hard.
+
+cmmMachOpFoldM _ _ _ = Nothing
+
+{- Note [Comparison operators]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+   CmmCondBranch ((x>#y) == 1) t f
+we really want to convert to
+   CmmCondBranch (x>#y) t f
+
+That's what the constant-folding operations on comparison operators do above.
+-}
+
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+isPicReg :: CmmExpr -> Bool
+isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
+isPicReg _ = False
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmParse.y
@@ -0,0 +1,1439 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004-2012
+--
+-- Parser for concrete Cmm.
+--
+-----------------------------------------------------------------------------
+
+{- -----------------------------------------------------------------------------
+Note [Syntax of .cmm files]
+
+NOTE: You are very much on your own in .cmm.  There is very little
+error checking at all:
+
+  * Type errors are detected by the (optional) -dcmm-lint pass, if you
+    don't turn this on then a type error will likely result in a panic
+    from the native code generator.
+
+  * Passing the wrong number of arguments or arguments of the wrong
+    type is not detected.
+
+There are two ways to write .cmm code:
+
+ (1) High-level Cmm code delegates the stack handling to GHC, and
+     never explicitly mentions Sp or registers.
+
+ (2) Low-level Cmm manages the stack itself, and must know about
+     calling conventions.
+
+Whether you want high-level or low-level Cmm is indicated by the
+presence of an argument list on a procedure.  For example:
+
+foo ( gcptr a, bits32 b )
+{
+  // this is high-level cmm code
+
+  if (b > 0) {
+     // we can make tail calls passing arguments:
+     jump stg_ap_0_fast(a);
+  }
+
+  push (stg_upd_frame_info, a) {
+    // stack frames can be explicitly pushed
+
+    (x,y) = call wibble(a,b,3,4);
+      // calls pass arguments and return results using the native
+      // Haskell calling convention.  The code generator will automatically
+      // construct a stack frame and an info table for the continuation.
+
+    return (x,y);
+      // we can return multiple values from the current proc
+  }
+}
+
+bar
+{
+  // this is low-level cmm code, indicated by the fact that we did not
+  // put an argument list on bar.
+
+  x = R1;  // the calling convention is explicit: better be careful
+           // that this works on all platforms!
+
+  jump %ENTRY_CODE(Sp(0))
+}
+
+Here is a list of rules for high-level and low-level code.  If you
+break the rules, you get a panic (for using a high-level construct in
+a low-level proc), or wrong code (when using low-level code in a
+high-level proc).  This stuff isn't checked! (TODO!)
+
+High-level only:
+
+  - tail-calls with arguments, e.g.
+    jump stg_fun (arg1, arg2);
+
+  - function calls:
+    (ret1,ret2) = call stg_fun (arg1, arg2);
+
+    This makes a call with the NativeNodeCall convention, and the
+    values are returned to the following code using the NativeReturn
+    convention.
+
+  - returning:
+    return (ret1, ret2)
+
+    These use the NativeReturn convention to return zero or more
+    results to the caller.
+
+  - pushing stack frames:
+    push (info_ptr, field1, ..., fieldN) { ... statements ... }
+
+  - reserving temporary stack space:
+
+      reserve N = x { ... }
+
+    this reserves an area of size N (words) on the top of the stack,
+    and binds its address to x (a local register).  Typically this is
+    used for allocating temporary storage for passing to foreign
+    functions.
+
+    Note that if you make any native calls or invoke the GC in the
+    scope of the reserve block, you are responsible for ensuring that
+    the stack you reserved is laid out correctly with an info table.
+
+Low-level only:
+
+  - References to Sp, R1-R8, F1-F4 etc.
+
+    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
+    etc., so ensure they are saved into variables around foreign
+    calls.
+
+  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
+    directly.
+
+Both high-level and low-level code can use a raw tail-call:
+
+    jump stg_fun [R1,R2]
+
+NB. you *must* specify the list of GlobalRegs that are passed via a
+jump, otherwise the register allocator will assume that all the
+GlobalRegs are dead at the jump.
+
+
+Calling Conventions
+-------------------
+
+High-level procedures use the NativeNode calling convention, or the
+NativeReturn convention if the 'return' keyword is used (see Stack
+Frames below).
+
+Low-level procedures implement their own calling convention, so it can
+be anything at all.
+
+If a low-level procedure implements the NativeNode calling convention,
+then it can be called by high-level code using an ordinary function
+call.  In general this is hard to arrange because the calling
+convention depends on the number of physical registers available for
+parameter passing, but there are two cases where the calling
+convention is platform-independent:
+
+ - Zero arguments.
+
+ - One argument of pointer or non-pointer word type; this is always
+   passed in R1 according to the NativeNode convention.
+
+ - Returning a single value; these conventions are fixed and platform
+   independent.
+
+
+Stack Frames
+------------
+
+A stack frame is written like this:
+
+INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
+               return ( arg1, ..., argM )
+{
+  ... code ...
+}
+
+where field1 ... fieldN are the fields of the stack frame (with types)
+arg1...argN are the values returned to the stack frame (with types).
+The return values are assumed to be passed according to the
+NativeReturn convention.
+
+On entry to the code, the stack frame looks like:
+
+   |----------|
+   | fieldN   |
+   |   ...    |
+   | field1   |
+   |----------|
+   | info_ptr |
+   |----------|
+   |  argN    |
+   |   ...    | <- Sp
+
+and some of the args may be in registers.
+
+We prepend the code by a copyIn of the args, and assign all the stack
+frame fields to their formals.  The initial "arg offset" for stack
+layout purposes consists of the whole stack frame plus any args that
+might be on the stack.
+
+A tail-call may pass a stack frame to the callee using the following
+syntax:
+
+jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
+
+where info_ptr and field1..fieldN describe the stack frame, and
+arg1..argN are the arguments passed to f using the NativeNodeCall
+convention. Note if a field is longer than a word (e.g. a D_ on
+a 32-bit machine) then the call will push as many words as
+necessary to the stack to accommodate it (e.g. 2).
+
+
+----------------------------------------------------------------------------- -}
+
+{
+module CmmParse ( parseCmmFile ) where
+
+import GhcPrelude
+
+import StgCmmExtCode
+import CmmCallConv
+import StgCmmProf
+import StgCmmHeap
+import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
+                          , emitAssign, emitOutOfLine, withUpdFrameOff
+                          , getUpdFrameOff )
+import qualified StgCmmMonad as F
+import StgCmmUtils
+import StgCmmForeign
+import StgCmmExpr
+import StgCmmClosure
+import StgCmmLayout     hiding (ArgRep(..))
+import StgCmmTicky
+import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
+import CoreSyn          ( Tickish(SourceNote) )
+
+import CmmOpt
+import MkGraph
+import Cmm
+import CmmUtils
+import CmmSwitch        ( mkSwitchTargets )
+import CmmInfo
+import BlockId
+import CmmLex
+import CLabel
+import SMRep
+import Lexer
+import CmmMonad
+
+import CostCentre
+import ForeignCall
+import Module
+import Platform
+import Literal
+import Unique
+import UniqFM
+import SrcLoc
+import DynFlags
+import ErrUtils
+import StringBuffer
+import FastString
+import Panic
+import Constants
+import Outputable
+import BasicTypes
+import Bag              ( emptyBag, unitBag )
+import Var
+
+import Control.Monad
+import Data.Array
+import Data.Char        ( ord )
+import System.Exit
+import Data.Maybe
+import qualified Data.Map as M
+import qualified Data.ByteString.Char8 as BS8
+
+#include "HsVersions.h"
+}
+
+%expect 0
+
+%token
+        ':'     { L _ (CmmT_SpecChar ':') }
+        ';'     { L _ (CmmT_SpecChar ';') }
+        '{'     { L _ (CmmT_SpecChar '{') }
+        '}'     { L _ (CmmT_SpecChar '}') }
+        '['     { L _ (CmmT_SpecChar '[') }
+        ']'     { L _ (CmmT_SpecChar ']') }
+        '('     { L _ (CmmT_SpecChar '(') }
+        ')'     { L _ (CmmT_SpecChar ')') }
+        '='     { L _ (CmmT_SpecChar '=') }
+        '`'     { L _ (CmmT_SpecChar '`') }
+        '~'     { L _ (CmmT_SpecChar '~') }
+        '/'     { L _ (CmmT_SpecChar '/') }
+        '*'     { L _ (CmmT_SpecChar '*') }
+        '%'     { L _ (CmmT_SpecChar '%') }
+        '-'     { L _ (CmmT_SpecChar '-') }
+        '+'     { L _ (CmmT_SpecChar '+') }
+        '&'     { L _ (CmmT_SpecChar '&') }
+        '^'     { L _ (CmmT_SpecChar '^') }
+        '|'     { L _ (CmmT_SpecChar '|') }
+        '>'     { L _ (CmmT_SpecChar '>') }
+        '<'     { L _ (CmmT_SpecChar '<') }
+        ','     { L _ (CmmT_SpecChar ',') }
+        '!'     { L _ (CmmT_SpecChar '!') }
+
+        '..'    { L _ (CmmT_DotDot) }
+        '::'    { L _ (CmmT_DoubleColon) }
+        '>>'    { L _ (CmmT_Shr) }
+        '<<'    { L _ (CmmT_Shl) }
+        '>='    { L _ (CmmT_Ge) }
+        '<='    { L _ (CmmT_Le) }
+        '=='    { L _ (CmmT_Eq) }
+        '!='    { L _ (CmmT_Ne) }
+        '&&'    { L _ (CmmT_BoolAnd) }
+        '||'    { L _ (CmmT_BoolOr) }
+
+        'True'  { L _ (CmmT_True ) }
+        'False' { L _ (CmmT_False) }
+        'likely'{ L _ (CmmT_likely)}
+
+        'CLOSURE'       { L _ (CmmT_CLOSURE) }
+        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
+        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
+        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
+        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
+        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
+        'else'          { L _ (CmmT_else) }
+        'export'        { L _ (CmmT_export) }
+        'section'       { L _ (CmmT_section) }
+        'goto'          { L _ (CmmT_goto) }
+        'if'            { L _ (CmmT_if) }
+        'call'          { L _ (CmmT_call) }
+        'jump'          { L _ (CmmT_jump) }
+        'foreign'       { L _ (CmmT_foreign) }
+        'never'         { L _ (CmmT_never) }
+        'prim'          { L _ (CmmT_prim) }
+        'reserve'       { L _ (CmmT_reserve) }
+        'return'        { L _ (CmmT_return) }
+        'returns'       { L _ (CmmT_returns) }
+        'import'        { L _ (CmmT_import) }
+        'switch'        { L _ (CmmT_switch) }
+        'case'          { L _ (CmmT_case) }
+        'default'       { L _ (CmmT_default) }
+        'push'          { L _ (CmmT_push) }
+        'unwind'        { L _ (CmmT_unwind) }
+        'bits8'         { L _ (CmmT_bits8) }
+        'bits16'        { L _ (CmmT_bits16) }
+        'bits32'        { L _ (CmmT_bits32) }
+        'bits64'        { L _ (CmmT_bits64) }
+        'bits128'       { L _ (CmmT_bits128) }
+        'bits256'       { L _ (CmmT_bits256) }
+        'bits512'       { L _ (CmmT_bits512) }
+        'float32'       { L _ (CmmT_float32) }
+        'float64'       { L _ (CmmT_float64) }
+        'gcptr'         { L _ (CmmT_gcptr) }
+
+        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
+        NAME            { L _ (CmmT_Name        $$) }
+        STRING          { L _ (CmmT_String      $$) }
+        INT             { L _ (CmmT_Int         $$) }
+        FLOAT           { L _ (CmmT_Float       $$) }
+
+%monad { PD } { >>= } { return }
+%lexer { cmmlex } { L _ CmmT_EOF }
+%name cmmParse cmm
+%tokentype { Located CmmToken }
+
+-- C-- operator precedences, taken from the C-- spec
+%right '||'     -- non-std extension, called %disjoin in C--
+%right '&&'     -- non-std extension, called %conjoin in C--
+%right '!'
+%nonassoc '>=' '>' '<=' '<' '!=' '=='
+%left '|'
+%left '^'
+%left '&'
+%left '>>' '<<'
+%left '-' '+'
+%left '/' '*' '%'
+%right '~'
+
+%%
+
+cmm     :: { CmmParse () }
+        : {- empty -}                   { return () }
+        | cmmtop cmm                    { do $1; $2 }
+
+cmmtop  :: { CmmParse () }
+        : cmmproc                       { $1 }
+        | cmmdata                       { $1 }
+        | decl                          { $1 } 
+        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
+                {% liftP . withThisPackage $ \pkg ->
+                   do lits <- sequence $6;
+                      staticClosure pkg $3 $5 (map getLit lits) }
+
+-- The only static closures in the RTS are dummy closures like
+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
+-- to provide the full generality of static closures here.
+-- In particular:
+--      * CCS can always be CCS_DONT_CARE
+--      * closure is always extern
+--      * payload is always empty
+--      * we can derive closure and info table labels from a single NAME
+
+cmmdata :: { CmmParse () }
+        : 'section' STRING '{' data_label statics '}' 
+                { do lbl <- $4;
+                     ss <- sequence $5;
+                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
+
+data_label :: { CmmParse CLabel }
+    : NAME ':'  
+                {% liftP . withThisPackage $ \pkg ->
+                   return (mkCmmDataLabel pkg $1) }
+
+statics :: { [CmmParse [CmmStatic]] }
+        : {- empty -}                   { [] }
+        | static statics                { $1 : $2 }
+    
+static  :: { CmmParse [CmmStatic] }
+        : type expr ';' { do e <- $2;
+                             return [CmmStaticLit (getLit e)] }
+        | type ';'                      { return [CmmUninitialised
+                                                        (widthInBytes (typeWidth $1))] }
+        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
+                                                        (fromIntegral $3)] }
+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
+                                                (widthInBytes (typeWidth $1) * 
+                                                        fromIntegral $3)] }
+        | 'CLOSURE' '(' NAME lits ')'
+                { do { lits <- sequence $4
+                ; dflags <- getDynFlags
+                     ; return $ map CmmStaticLit $
+                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
+                         -- mkForeignLabel because these are only used
+                         -- for CHARLIKE and INTLIKE closures in the RTS.
+                        dontCareCCS (map getLit lits) [] [] [] } }
+        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
+
+lits    :: { [CmmParse CmmExpr] }
+        : {- empty -}           { [] }
+        | ',' expr lits         { $2 : $3 }
+
+cmmproc :: { CmmParse () }
+        : info maybe_conv maybe_formals maybe_body
+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
+                       getCodeScoped $ loopDecls $ do {
+                         (entry_ret_label, info, stk_formals) <- $1;
+                         dflags <- getDynFlags;
+                         formals <- sequence (fromMaybe [] $3);
+                         withName (showSDoc dflags (ppr entry_ret_label))
+                           $4;
+                         return (entry_ret_label, info, stk_formals, formals) }
+                     let do_layout = isJust $3
+                     code (emitProcWithStackFrame $2 info
+                                entry_ret_label stk_formals formals agraph
+                                do_layout ) }
+
+maybe_conv :: { Convention }
+           : {- empty -}        { NativeNodeCall }
+           | 'return'           { NativeReturn }
+
+maybe_body :: { CmmParse () }
+           : ';'                { return () }
+           | '{' body '}'       { withSourceNote $1 $3 $2 }
+
+info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
+        : NAME
+                {% liftP . withThisPackage $ \pkg ->
+                   do   newFunctionName $1 pkg
+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }
+
+
+        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+                -- ptrs, nptrs, closure type, description, type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $11 $13
+                          rep  = mkRTSRep (fromIntegral $9) $
+                                   mkHeapRep dflags False (fromIntegral $5)
+                                                   (fromIntegral $7) Thunk
+                              -- not really Thunk, but that makes the info table
+                              -- we want.
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+        
+        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
+                -- ptrs, nptrs, closure type, description, type, fun type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $11 $13
+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
+                                -- Arity zero, arg_type $15
+                          rep = mkRTSRep (fromIntegral $9) $
+                                    mkHeapRep dflags False (fromIntegral $5)
+                                                    (fromIntegral $7) ty
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+                -- we leave most of the fields zero here.  This is only used
+                -- to generate the BCO info table in the RTS at the moment.
+
+        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+                -- ptrs, nptrs, tag, closure type, description, type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $13 $15
+                          ty  = Constr (fromIntegral $9)  -- Tag
+                                       (BS8.pack $13)
+                          rep = mkRTSRep (fromIntegral $11) $
+                                  mkHeapRep dflags False (fromIntegral $5)
+                                                  (fromIntegral $7) ty
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
+                              []) }
+
+                     -- If profiling is on, this string gets duplicated,
+                     -- but that's the way the old code did it we can fix it some other time.
+        
+        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
+                -- selector, closure type, description, type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $9 $11
+                          ty  = ThunkSelector (fromIntegral $5)
+                          rep = mkRTSRep (fromIntegral $7) $
+                                   mkHeapRep dflags False 0 0 ty
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
+                -- closure type (no live regs)
+                {% liftP . withThisPackage $ \pkg ->
+                   do let prof = NoProfilingInfo
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
+                      return (mkCmmRetLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
+                -- closure type, live regs
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      live <- sequence $7
+                      let prof = NoProfilingInfo
+                          -- drop one for the info pointer
+                          bitmap = mkLiveness dflags (drop 1 live)
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
+                      return (mkCmmRetLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              live) }
+
+body    :: { CmmParse () }
+        : {- empty -}                   { return () }
+        | decl body                     { do $1; $2 }
+        | stmt body                     { do $1; $2 }
+
+decl    :: { CmmParse () }
+        : type names ';'                { mapM_ (newLocal $1) $2 }
+        | 'import' importNames ';'      { mapM_ newImport $2 }
+        | 'export' names ';'            { return () }  -- ignore exports
+
+
+-- an imported function name, with optional packageId
+importNames
+        :: { [(FastString, CLabel)] }
+        : importName                    { [$1] }
+        | importName ',' importNames    { $1 : $3 }
+
+importName
+        :: { (FastString,  CLabel) }
+
+        -- A label imported without an explicit packageId.
+        --      These are taken to come frome some foreign, unnamed package.
+        : NAME  
+        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
+
+        -- as previous 'NAME', but 'IsData'
+        | 'CLOSURE' NAME
+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
+
+        -- A label imported with an explicit packageId.
+        | STRING NAME
+        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
+        
+        
+names   :: { [FastString] }
+        : NAME                          { [$1] }
+        | NAME ',' names                { $1 : $3 }
+
+stmt    :: { CmmParse () }
+        : ';'                                   { return () }
+
+        | NAME ':'
+                { do l <- newLabel $1; emitLabel l }
+
+
+
+        | lreg '=' expr ';'
+                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
+        | type '[' expr ']' '=' expr ';'
+                { withSourceNote $2 $7 (doStore $1 $3 $6) }
+
+        -- Gah! We really want to say "foreign_results" but that causes
+        -- a shift/reduce conflict with assignment.  We either
+        -- we expand out the no-result and single result cases or
+        -- we tweak the syntax to avoid the conflict.  The later
+        -- option is taken here because the other way would require
+        -- multiple levels of expanding and get unwieldy.
+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
+                {% foreignCall $3 $1 $4 $6 $8 $9 }
+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
+                {% primCall $1 $4 $6 }
+        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
+        -- Perhaps we ought to use the %%-form?
+        | NAME '(' exprs0 ')' ';'
+                {% stmtMacro $1 $3  }
+        | 'switch' maybe_range expr '{' arms default '}'
+                { do as <- sequence $5; doSwitch $2 $3 as $6 }
+        | 'goto' NAME ';'
+                { do l <- lookupLabel $2; emit (mkBranch l) }
+        | 'return' '(' exprs0 ')' ';'
+                { doReturn $3 }
+        | 'jump' expr vols ';'
+                { doRawJump $2 $3 }
+        | 'jump' expr '(' exprs0 ')' ';'
+                { doJumpWithStack $2 [] $4 }
+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
+                { doJumpWithStack $2 $4 $7 }
+        | 'call' expr '(' exprs0 ')' ';'
+                { doCall $2 [] $4 }
+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
+                { doCall $6 $2 $8 }
+        | 'if' bool_expr cond_likely 'goto' NAME
+                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
+        | 'if' bool_expr cond_likely '{' body '}' else
+                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }
+        | 'push' '(' exprs0 ')' maybe_body
+                { pushStackFrame $3 $5 }
+        | 'reserve' expr '=' lreg maybe_body
+                { reserveStackFrame $2 $4 $5 }
+        | 'unwind' unwind_regs ';'
+                { $2 >>= code . emitUnwind }
+
+unwind_regs
+        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
+        : GLOBALREG '=' expr_or_unknown ',' unwind_regs
+                { do e <- $3; rest <- $5; return (($1, e) : rest) }
+        | GLOBALREG '=' expr_or_unknown
+                { do e <- $3; return [($1, e)] }
+
+-- | Used by unwind to indicate unknown unwinding values.
+expr_or_unknown
+        :: { CmmParse (Maybe CmmExpr) }
+        : 'return'
+                { do return Nothing }
+        | expr
+                { do e <- $1; return (Just e) }
+
+foreignLabel     :: { CmmParse CmmExpr }
+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
+
+opt_never_returns :: { CmmReturnInfo }
+        :                               { CmmMayReturn }
+        | 'never' 'returns'             { CmmNeverReturns }
+
+bool_expr :: { CmmParse BoolExpr }
+        : bool_op                       { $1 }
+        | expr                          { do e <- $1; return (BoolTest e) }
+
+bool_op :: { CmmParse BoolExpr }
+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
+                                          return (BoolAnd e1 e2) }
+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
+                                          return (BoolOr e1 e2)  }
+        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
+        | '(' bool_op ')'               { $2 }
+
+safety  :: { Safety }
+        : {- empty -}                   { PlayRisky }
+        | STRING                        {% parseSafety $1 }
+
+vols    :: { [GlobalReg] }
+        : '[' ']'                       { [] }
+        | '[' '*' ']'                   {% do df <- getDynFlags
+                                         ; return (realArgRegsCover df) }
+                                           -- All of them. See comment attached
+                                           -- to realArgRegsCover
+        | '[' globals ']'               { $2 }
+
+globals :: { [GlobalReg] }
+        : GLOBALREG                     { [$1] }
+        | GLOBALREG ',' globals         { $1 : $3 }
+
+maybe_range :: { Maybe (Integer,Integer) }
+        : '[' INT '..' INT ']'  { Just ($2, $4) }
+        | {- empty -}           { Nothing }
+
+arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
+        : {- empty -}                   { [] }
+        | arm arms                      { $1 : $2 }
+
+arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
+        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
+
+arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
+        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
+        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
+
+ints    :: { [Integer] }
+        : INT                           { [ $1 ] }
+        | INT ',' ints                  { $1 : $3 }
+
+default :: { Maybe (CmmParse ()) }
+        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
+        -- taking a few liberties with the C-- syntax here; C-- doesn't have
+        -- 'default' branches
+        | {- empty -}                   { Nothing }
+
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
+else    :: { CmmParse () }
+        : {- empty -}                   { return () }
+        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
+
+cond_likely :: { Maybe Bool }
+        : '(' 'likely' ':' 'True'  ')'  { Just True  }
+        | '(' 'likely' ':' 'False' ')'  { Just False }
+        | {- empty -}                   { Nothing }
+
+
+-- we have to write this out longhand so that Happy's precedence rules
+-- can kick in.
+expr    :: { CmmParse CmmExpr }
+        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
+        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
+        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
+        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
+        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
+        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
+        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
+        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
+        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
+        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
+        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
+        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
+        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
+        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
+        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
+        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
+        | '~' expr                      { mkMachOp MO_Not [$2] }
+        | '-' expr                      { mkMachOp MO_S_Neg [$2] }
+        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
+                                                return (mkMachOp mo [$1,$5]) } }
+        | expr0                         { $1 }
+
+expr0   :: { CmmParse CmmExpr }
+        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
+        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
+        | STRING                 { do s <- code (newStringCLit $1); 
+                                      return (CmmLit s) }
+        | reg                    { $1 }
+        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
+        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
+        | '(' expr ')'           { $2 }
+
+
+-- leaving out the type of a literal gives you the native word size in C--
+maybe_ty :: { CmmType }
+        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
+        | '::' type                     { $2 }
+
+cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
+        : {- empty -}                   { [] }
+        | cmm_hint_exprs                { $1 }
+
+cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
+        : cmm_hint_expr                 { [$1] }
+        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
+
+cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
+        : expr                          { do e <- $1;
+                                             return (e, inferCmmHint e) }
+        | expr STRING                   {% do h <- parseCmmHint $2;
+                                              return $ do
+                                                e <- $1; return (e, h) }
+
+exprs0  :: { [CmmParse CmmExpr] }
+        : {- empty -}                   { [] }
+        | exprs                         { $1 }
+
+exprs   :: { [CmmParse CmmExpr] }
+        : expr                          { [ $1 ] }
+        | expr ',' exprs                { $1 : $3 }
+
+reg     :: { CmmParse CmmExpr }
+        : NAME                  { lookupName $1 }
+        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
+
+foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
+        : {- empty -}                   { [] }
+        | '(' foreign_formals ')' '='   { $2 }
+
+foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
+        : foreign_formal                        { [$1] }
+        | foreign_formal ','                    { [$1] }
+        | foreign_formal ',' foreign_formals    { $1 : $3 }
+
+foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
+        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
+        | STRING local_lreg     {% do h <- parseCmmHint $1;
+                                      return $ do
+                                         e <- $2; return (e,h) }
+
+local_lreg :: { CmmParse LocalReg }
+        : NAME                  { do e <- lookupName $1;
+                                     return $
+                                       case e of 
+                                        CmmReg (CmmLocal r) -> r
+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
+
+lreg    :: { CmmParse CmmReg }
+        : NAME                  { do e <- lookupName $1;
+                                     return $
+                                       case e of 
+                                        CmmReg r -> r
+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
+        | GLOBALREG             { return (CmmGlobal $1) }
+
+maybe_formals :: { Maybe [CmmParse LocalReg] }
+        : {- empty -}           { Nothing }
+        | '(' formals0 ')'      { Just $2 }
+
+formals0 :: { [CmmParse LocalReg] }
+        : {- empty -}           { [] }
+        | formals               { $1 }
+
+formals :: { [CmmParse LocalReg] }
+        : formal ','            { [$1] }
+        | formal                { [$1] }
+        | formal ',' formals       { $1 : $3 }
+
+formal :: { CmmParse LocalReg }
+        : type NAME             { newLocal $1 $2 }
+
+type    :: { CmmType }
+        : 'bits8'               { b8 }
+        | typenot8              { $1 }
+
+typenot8 :: { CmmType }
+        : 'bits16'              { b16 }
+        | 'bits32'              { b32 }
+        | 'bits64'              { b64 }
+        | 'bits128'             { b128 }
+        | 'bits256'             { b256 }
+        | 'bits512'             { b512 }
+        | 'float32'             { f32 }
+        | 'float64'             { f64 }
+        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
+
+{
+section :: String -> SectionType
+section "text"      = Text
+section "data"      = Data
+section "rodata"    = ReadOnlyData
+section "relrodata" = RelocatableReadOnlyData
+section "bss"       = UninitialisedData
+section s           = OtherSection s
+
+mkString :: String -> CmmStatic
+mkString s = CmmString (BS8.pack s)
+
+-- |
+-- Given an info table, decide what the entry convention for the proc
+-- is.  That is, for an INFO_TABLE_RET we want the return convention,
+-- otherwise it is a NativeNodeCall.
+--
+infoConv :: Maybe CmmInfoTable -> Convention
+infoConv Nothing = NativeNodeCall
+infoConv (Just info)
+  | isStackRep (cit_rep info) = NativeReturn
+  | otherwise                 = NativeNodeCall
+
+-- mkMachOp infers the type of the MachOp from the type of its first
+-- argument.  We assume that this is correct: for MachOps that don't have
+-- symmetrical args (e.g. shift ops), the first arg determines the type of
+-- the op.
+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
+mkMachOp fn args = do
+  dflags <- getDynFlags
+  arg_exprs <- sequence args
+  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
+
+getLit :: CmmExpr -> CmmLit
+getLit (CmmLit l) = l
+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
+getLit _ = panic "invalid literal" -- TODO messy failure
+
+nameToMachOp :: FastString -> PD (Width -> MachOp)
+nameToMachOp name =
+  case lookupUFM machOps name of
+        Nothing -> fail ("unknown primitive " ++ unpackFS name)
+        Just m  -> return m
+
+exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
+exprOp name args_code = do
+  dflags <- getDynFlags
+  case lookupUFM (exprMacros dflags) name of
+     Just f  -> return $ do
+        args <- sequence args_code
+        return (f args)
+     Nothing -> do
+        mo <- nameToMachOp name
+        return $ mkMachOp mo args_code
+
+exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
+exprMacros dflags = listToUFM [
+  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
+  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
+  ]
+
+-- we understand a subset of C-- primitives:
+machOps = listToUFM $
+        map (\(x, y) -> (mkFastString x, y)) [
+        ( "add",        MO_Add ),
+        ( "sub",        MO_Sub ),
+        ( "eq",         MO_Eq ),
+        ( "ne",         MO_Ne ),
+        ( "mul",        MO_Mul ),
+        ( "neg",        MO_S_Neg ),
+        ( "quot",       MO_S_Quot ),
+        ( "rem",        MO_S_Rem ),
+        ( "divu",       MO_U_Quot ),
+        ( "modu",       MO_U_Rem ),
+
+        ( "ge",         MO_S_Ge ),
+        ( "le",         MO_S_Le ),
+        ( "gt",         MO_S_Gt ),
+        ( "lt",         MO_S_Lt ),
+
+        ( "geu",        MO_U_Ge ),
+        ( "leu",        MO_U_Le ),
+        ( "gtu",        MO_U_Gt ),
+        ( "ltu",        MO_U_Lt ),
+
+        ( "and",        MO_And ),
+        ( "or",         MO_Or ),
+        ( "xor",        MO_Xor ),
+        ( "com",        MO_Not ),
+        ( "shl",        MO_Shl ),
+        ( "shrl",       MO_U_Shr ),
+        ( "shra",       MO_S_Shr ),
+
+        ( "fadd",       MO_F_Add ),
+        ( "fsub",       MO_F_Sub ),
+        ( "fneg",       MO_F_Neg ),
+        ( "fmul",       MO_F_Mul ),
+        ( "fquot",      MO_F_Quot ),
+
+        ( "feq",        MO_F_Eq ),
+        ( "fne",        MO_F_Ne ),
+        ( "fge",        MO_F_Ge ),
+        ( "fle",        MO_F_Le ),
+        ( "fgt",        MO_F_Gt ),
+        ( "flt",        MO_F_Lt ),
+
+        ( "lobits8",  flip MO_UU_Conv W8  ),
+        ( "lobits16", flip MO_UU_Conv W16 ),
+        ( "lobits32", flip MO_UU_Conv W32 ),
+        ( "lobits64", flip MO_UU_Conv W64 ),
+
+        ( "zx16",     flip MO_UU_Conv W16 ),
+        ( "zx32",     flip MO_UU_Conv W32 ),
+        ( "zx64",     flip MO_UU_Conv W64 ),
+
+        ( "sx16",     flip MO_SS_Conv W16 ),
+        ( "sx32",     flip MO_SS_Conv W32 ),
+        ( "sx64",     flip MO_SS_Conv W64 ),
+
+        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
+        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
+        ( "f2i8",     flip MO_FS_Conv W8 ),
+        ( "f2i16",    flip MO_FS_Conv W16 ),
+        ( "f2i32",    flip MO_FS_Conv W32 ),
+        ( "f2i64",    flip MO_FS_Conv W64 ),
+        ( "i2f32",    flip MO_SF_Conv W32 ),
+        ( "i2f64",    flip MO_SF_Conv W64 )
+        ]
+
+callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
+callishMachOps = listToUFM $
+        map (\(x, y) -> (mkFastString x, y)) [
+        ( "write_barrier", (,) MO_WriteBarrier ),
+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
+        ( "memset", memcpyLikeTweakArgs MO_Memset ),
+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
+        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
+
+        ("prefetch0", (,) $ MO_Prefetch_Data 0),
+        ("prefetch1", (,) $ MO_Prefetch_Data 1),
+        ("prefetch2", (,) $ MO_Prefetch_Data 2),
+        ("prefetch3", (,) $ MO_Prefetch_Data 3),
+
+        ( "popcnt8",  (,) $ MO_PopCnt W8  ),
+        ( "popcnt16", (,) $ MO_PopCnt W16 ),
+        ( "popcnt32", (,) $ MO_PopCnt W32 ),
+        ( "popcnt64", (,) $ MO_PopCnt W64 ),
+
+        ( "pdep8",  (,) $ MO_Pdep W8  ),
+        ( "pdep16", (,) $ MO_Pdep W16 ),
+        ( "pdep32", (,) $ MO_Pdep W32 ),
+        ( "pdep64", (,) $ MO_Pdep W64 ),
+
+        ( "pext8",  (,) $ MO_Pext W8  ),
+        ( "pext16", (,) $ MO_Pext W16 ),
+        ( "pext32", (,) $ MO_Pext W32 ),
+        ( "pext64", (,) $ MO_Pext W64 ),
+
+        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
+        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
+        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
+        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
+
+        -- ToDo: the rest, maybe
+        -- edit: which rest?
+        -- also: how do we tell CMM Lint how to type check callish macops?
+    ]
+  where
+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
+    memcpyLikeTweakArgs op args@(_:_) =
+        (op align, args')
+      where
+        args' = init args
+        align = case last args of
+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
+          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
+        -- The alignment of memcpy-ish operations must be a
+        -- compile-time constant. We verify this here, passing it around
+        -- in the MO_* constructor. In order to do this, however, we
+        -- must intercept the arguments in primCall.
+
+parseSafety :: String -> PD Safety
+parseSafety "safe"   = return PlaySafe
+parseSafety "unsafe" = return PlayRisky
+parseSafety "interruptible" = return PlayInterruptible
+parseSafety str      = fail ("unrecognised safety: " ++ str)
+
+parseCmmHint :: String -> PD ForeignHint
+parseCmmHint "ptr"    = return AddrHint
+parseCmmHint "signed" = return SignedHint
+parseCmmHint str      = fail ("unrecognised hint: " ++ str)
+
+-- labels are always pointers, so we might as well infer the hint
+inferCmmHint :: CmmExpr -> ForeignHint
+inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
+inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
+inferCmmHint _ = NoHint
+
+isPtrGlobalReg Sp                    = True
+isPtrGlobalReg SpLim                 = True
+isPtrGlobalReg Hp                    = True
+isPtrGlobalReg HpLim                 = True
+isPtrGlobalReg CCCS                  = True
+isPtrGlobalReg CurrentTSO            = True
+isPtrGlobalReg CurrentNursery        = True
+isPtrGlobalReg (VanillaReg _ VGcPtr) = True
+isPtrGlobalReg _                     = False
+
+happyError :: PD a
+happyError = PD $ \_ s -> unP srcParseFail s
+
+-- -----------------------------------------------------------------------------
+-- Statement-level macros
+
+stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
+stmtMacro fun args_code = do
+  case lookupUFM stmtMacros fun of
+    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
+    Just fcode -> return $ do
+        args <- sequence args_code
+        code (fcode args)
+
+stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
+stmtMacros = listToUFM [
+  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
+
+  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
+  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
+
+  -- completely generic heap and stack checks, for use in high-level cmm.
+  ( fsLit "HP_CHK_GEN",            \[bytes] ->
+                                      heapStackCheckGen Nothing (Just bytes) ),
+  ( fsLit "STK_CHK_GEN",           \[] ->
+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
+
+  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
+  -- we use the stack for a bit of temporary storage in a couple of primops
+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
+                                      heapStackCheckGen (Just bytes) Nothing ),
+
+  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
+
+  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
+
+  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
+
+  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
+  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
+                                        emitSetDynHdr ptr info ccs ),
+  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
+                                        tickyAllocPrim hdr goods slop ),
+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
+                                        tickyAllocPAP goods slop ),
+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
+                                        tickyAllocThunk goods slop ),
+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
+ ]
+
+emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
+emitPushUpdateFrame sp e = do
+  dflags <- getDynFlags
+  emitUpdateFrame dflags sp mkUpdInfoLabel e
+
+pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
+pushStackFrame fields body = do
+  dflags <- getDynFlags
+  exprs <- sequence fields
+  updfr_off <- getUpdFrameOff
+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
+                                           [] updfr_off exprs
+  emit g
+  withUpdFrameOff new_updfr_off body
+
+reserveStackFrame
+  :: CmmParse CmmExpr
+  -> CmmParse CmmReg
+  -> CmmParse ()
+  -> CmmParse ()
+reserveStackFrame psize preg body = do
+  dflags <- getDynFlags
+  old_updfr_off <- getUpdFrameOff
+  reg <- preg
+  esize <- psize
+  let size = case constantFoldExpr dflags esize of
+               CmmLit (CmmInt n _) -> n
+               _other -> pprPanic "CmmParse: not a compile-time integer: "
+                            (ppr esize)
+  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
+  emitAssign reg (CmmStackSlot Old frame)
+  withUpdFrameOff frame body
+
+profilingInfo dflags desc_str ty_str
+  = if not (gopt Opt_SccProfilingOn dflags)
+    then NoProfilingInfo
+    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
+
+staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
+staticClosure pkg cl_label info payload
+  = do dflags <- getDynFlags
+       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
+
+foreignCall
+        :: String
+        -> [CmmParse (LocalReg, ForeignHint)]
+        -> CmmParse CmmExpr
+        -> [CmmParse (CmmExpr, ForeignHint)]
+        -> Safety
+        -> CmmReturnInfo
+        -> PD (CmmParse ())
+foreignCall conv_string results_code expr_code args_code safety ret
+  = do  conv <- case conv_string of
+          "C" -> return CCallConv
+          "stdcall" -> return StdCallConv
+          _ -> fail ("unknown calling convention: " ++ conv_string)
+        return $ do
+          dflags <- getDynFlags
+          results <- sequence results_code
+          expr <- expr_code
+          args <- sequence args_code
+          let
+                  expr' = adjCallTarget dflags conv expr args
+                  (arg_exprs, arg_hints) = unzip args
+                  (res_regs,  res_hints) = unzip results
+                  fc = ForeignConvention conv arg_hints res_hints ret
+                  target = ForeignTarget expr' fc
+          _ <- code $ emitForeignCall safety res_regs target arg_exprs
+          return ()
+
+
+doReturn :: [CmmParse CmmExpr] -> CmmParse ()
+doReturn exprs_code = do
+  dflags <- getDynFlags
+  exprs <- sequence exprs_code
+  updfr_off <- getUpdFrameOff
+  emit (mkReturnSimple dflags exprs updfr_off)
+
+mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple dflags actuals updfr_off =
+  mkReturn dflags e actuals updfr_off
+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
+                             (gcWord dflags))
+
+doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
+doRawJump expr_code vols = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  updfr_off <- getUpdFrameOff
+  emit (mkRawJump dflags expr updfr_off vols)
+
+doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
+                -> [CmmParse CmmExpr] -> CmmParse ()
+doJumpWithStack expr_code stk_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  stk_args <- sequence stk_code
+  args <- sequence args_code
+  updfr_off <- getUpdFrameOff
+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
+
+doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
+       -> CmmParse ()
+doCall expr_code res_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  args <- sequence args_code
+  ress <- sequence res_code
+  updfr_off <- getUpdFrameOff
+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
+  emit c
+
+adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
+              -> CmmExpr
+-- On Windows, we have to add the '@N' suffix to the label when making
+-- a call with the stdcall calling convention.
+adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
+ | platformOS (targetPlatform dflags) == OSMinGW32
+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+                 -- c.f. CgForeignCall.emitForeignCall
+adjCallTarget _ _ expr _
+  = expr
+
+primCall
+        :: [CmmParse (CmmFormal, ForeignHint)]
+        -> FastString
+        -> [CmmParse CmmExpr]
+        -> PD (CmmParse ())
+primCall results_code name args_code
+  = case lookupUFM callishMachOps name of
+        Nothing -> fail ("unknown primitive " ++ unpackFS name)
+        Just f  -> return $ do
+                results <- sequence results_code
+                args <- sequence args_code
+                let (p, args') = f args
+                code (emitPrimCall (map fst results) p args')
+
+doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
+doStore rep addr_code val_code
+  = do dflags <- getDynFlags
+       addr <- addr_code
+       val <- val_code
+        -- if the specified store type does not match the type of the expr
+        -- on the rhs, then we insert a coercion that will cause the type
+        -- mismatch to be flagged by cmm-lint.  If we don't do this, then
+        -- the store will happen at the wrong type, and the error will not
+        -- be noticed.
+       let val_width = typeWidth (cmmExprType dflags val)
+           rep_width = typeWidth rep
+       let coerce_val
+                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
+                | otherwise              = val
+       emitStore addr coerce_val
+
+-- -----------------------------------------------------------------------------
+-- If-then-else and boolean expressions
+
+data BoolExpr
+  = BoolExpr `BoolAnd` BoolExpr
+  | BoolExpr `BoolOr`  BoolExpr
+  | BoolNot BoolExpr
+  | BoolTest CmmExpr
+
+-- ToDo: smart constructors which simplify the boolean expression.
+
+cmmIfThenElse cond then_part else_part likely = do
+     then_id <- newBlockId
+     join_id <- newBlockId
+     c <- cond
+     emitCond c then_id likely
+     else_part
+     emit (mkBranch join_id)
+     emitLabel then_id
+     then_part
+     -- fall through to join
+     emitLabel join_id
+
+cmmRawIf cond then_id likely = do
+    c <- cond
+    emitCond c then_id likely
+
+-- 'emitCond cond true_id'  emits code to test whether the cond is true,
+-- branching to true_id if so, and falling through otherwise.
+emitCond (BoolTest e) then_id likely = do
+  else_id <- newBlockId
+  emit (mkCbranch e then_id else_id likely)
+  emitLabel else_id
+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely
+  | Just op' <- maybeInvertComparison op
+  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)
+emitCond (BoolNot e) then_id likely = do
+  else_id <- newBlockId
+  emitCond e else_id likely
+  emit (mkBranch then_id)
+  emitLabel else_id
+emitCond (e1 `BoolOr` e2) then_id likely = do
+  emitCond e1 then_id likely
+  emitCond e2 then_id likely
+emitCond (e1 `BoolAnd` e2) then_id likely = do
+        -- we'd like to invert one of the conditionals here to avoid an
+        -- extra branch instruction, but we can't use maybeInvertComparison
+        -- here because we can't look too closely at the expression since
+        -- we're in a loop.
+  and_id <- newBlockId
+  else_id <- newBlockId
+  emitCond e1 and_id likely
+  emit (mkBranch else_id)
+  emitLabel and_id
+  emitCond e2 then_id likely
+  emitLabel else_id
+
+-- -----------------------------------------------------------------------------
+-- Source code notes
+
+-- | Generate a source note spanning from "a" to "b" (inclusive), then
+-- proceed with parsing. This allows debugging tools to reason about
+-- locations in Cmm code.
+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
+withSourceNote a b parse = do
+  name <- getName
+  case combineSrcSpans (getLoc a) (getLoc b) of
+    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
+    _other           -> parse
+
+-- -----------------------------------------------------------------------------
+-- Table jumps
+
+-- We use a simplified form of C-- switch statements for now.  A
+-- switch statement always compiles to a table jump.  Each arm can
+-- specify a list of values (not ranges), and there can be a single
+-- default branch.  The range of the table is given either by the
+-- optional range on the switch (eg. switch [0..7] {...}), or by
+-- the minimum/maximum values from the branches.
+
+doSwitch :: Maybe (Integer,Integer)
+         -> CmmParse CmmExpr
+         -> [([Integer],Either BlockId (CmmParse ()))]
+         -> Maybe (CmmParse ()) -> CmmParse ()
+doSwitch mb_range scrut arms deflt
+   = do
+        -- Compile code for the default branch
+        dflt_entry <- 
+                case deflt of
+                  Nothing -> return Nothing
+                  Just e  -> do b <- forkLabelledCode e; return (Just b)
+
+        -- Compile each case branch
+        table_entries <- mapM emitArm arms
+        let table = M.fromList (concat table_entries)
+
+        dflags <- getDynFlags
+        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
+
+        expr <- scrut
+        -- ToDo: check for out of range and jump to default if necessary
+        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
+   where
+        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
+        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+        emitArm (ints,Right code) = do
+           blockid <- forkLabelledCode code
+           return [ (i,blockid) | i <- ints ]
+
+forkLabelledCode :: CmmParse () -> CmmParse BlockId
+forkLabelledCode p = do
+  (_,ag) <- getCodeScoped p
+  l <- newBlockId
+  emitOutOfLine l ag
+  return l
+
+-- -----------------------------------------------------------------------------
+-- Putting it all together
+
+-- The initial environment: we define some constants that the compiler
+-- knows about here.
+initEnv :: DynFlags -> Env
+initEnv dflags = listToUFM [
+  ( fsLit "SIZEOF_StgHeader",
+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
+  ( fsLit "SIZEOF_StgInfoTable",
+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
+  ]
+
+parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
+parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
+  buf <- hGetStringBuffer filename
+  let
+        init_loc = mkRealSrcLoc (mkFastString filename) 1 1
+        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
+                -- reset the lex_state: the Lexer monad leaves some stuff
+                -- in there we don't want.
+  case unPD cmmParse dflags init_state of
+    PFailed pst ->
+        return (getMessages pst dflags, Nothing)
+    POk pst code -> do
+        st <- initC
+        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
+            (cmm,_) = runC dflags no_module st fcode
+        let ms = getMessages pst dflags
+        if (errorsFound dflags ms)
+         then return (ms, Nothing)
+         else return (ms, Just cmm)
+  where
+        no_module = panic "parseCmmFile: no module"
+}
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmPipeline.hs
@@ -0,0 +1,360 @@
+{-# LANGUAGE BangPatterns #-}
+
+module CmmPipeline (
+  -- | Converts C-- with an implicit stack and native C-- calls into
+  -- optimized, CPS converted and native-call-less C--.  The latter
+  -- C-- can be used to generate assembly.
+  cmmPipeline
+) where
+
+import GhcPrelude
+
+import Cmm
+import CmmLint
+import CmmBuildInfoTables
+import CmmCommonBlockElim
+import CmmImplementSwitchPlans
+import CmmProcPoint
+import CmmContFlowOpt
+import CmmLayoutStack
+import CmmSink
+import Hoopl.Collections
+
+import UniqSupply
+import DynFlags
+import ErrUtils
+import HscTypes
+import Control.Monad
+import Outputable
+import Platform
+
+-----------------------------------------------------------------------------
+-- | Top level driver for C-- pipeline
+-----------------------------------------------------------------------------
+
+cmmPipeline
+ :: HscEnv -- Compilation env including
+           -- dynamic flags: -dcmm-lint -ddump-cmm-cps
+ -> ModuleSRTInfo        -- Info about SRTs generated so far
+ -> CmmGroup             -- Input C-- with Procedures
+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
+
+cmmPipeline hsc_env srtInfo prog =
+  do let dflags = hsc_dflags hsc_env
+
+     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
+
+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
+
+     return (srtInfo, cmms)
+
+
+cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
+cpsTop hsc_env proc =
+    do
+       ----------- Control-flow optimisations ----------------------------------
+
+       -- The first round of control-flow optimisation speeds up the
+       -- later passes by removing lots of empty blocks, so we do it
+       -- even when optimisation isn't turned on.
+       --
+       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
+            return $ cmmCfgOptsProc splitting_proc_points proc
+       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
+                                          , do_layout = do_layout }} = h
+
+       ----------- Eliminate common blocks -------------------------------------
+       g <- {-# SCC "elimCommonBlocks" #-}
+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
+                          Opt_D_dump_cmm_cbe "Post common block elimination"
+
+       -- Any work storing block Labels must be performed _after_
+       -- elimCommonBlocks
+
+       g <- {-# SCC "createSwitchPlans" #-}
+            runUniqSM $ cmmImplementSwitchPlans dflags g
+       dump Opt_D_dump_cmm_switch "Post switch plan" g
+
+       ----------- Proc points -------------------------------------------------
+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
+       proc_points <-
+          if splitting_proc_points
+             then do
+               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
+                  minimalProcPointSet (targetPlatform dflags) call_pps g
+               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
+                     (ppr l $$ ppr pp $$ ppr g)
+               return pp
+             else
+               return call_pps
+
+       ----------- Layout the stack and manifest Sp ----------------------------
+       (g, stackmaps) <-
+            {-# SCC "layoutStack" #-}
+            if do_layout
+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
+               else return (g, mapEmpty)
+       dump Opt_D_dump_cmm_sp "Layout Stack" g
+
+       ----------- Sink and inline assignments  --------------------------------
+       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
+            condPass Opt_CmmSink (cmmSink dflags) g
+                     Opt_D_dump_cmm_sink "Sink assignments"
+
+       ------------- CAF analysis ----------------------------------------------
+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
+
+       g <- if splitting_proc_points
+            then do
+               ------------- Split into separate procedures -----------------------
+               let pp_map = {-# SCC "procPointAnalysis" #-}
+                            procPointAnalysis proc_points g
+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
+                    ppr pp_map
+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+                    splitAtProcPoints dflags l call_pps proc_points pp_map
+                                      (CmmProc h l v g)
+               dumps Opt_D_dump_cmm_split "Post splitting" g
+               return g
+             else do
+               -- attach info tables to return points
+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]
+
+       ------------- Populate info tables with stack info -----------------
+       g <- {-# SCC "setInfoTableStackMap" #-}
+            return $ map (setInfoTableStackMap dflags stackmaps) g
+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
+
+       ----------- Control-flow optimisations -----------------------------
+       g <- {-# SCC "cmmCfgOpts(2)" #-}
+            return $ if optLevel dflags >= 1
+                     then map (cmmCfgOptsProc splitting_proc_points) g
+                     else g
+       g <- return (map removeUnreachableBlocksProc g)
+            -- See Note [unreachable blocks]
+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+       return (cafEnv, g)
+
+  where dflags = hsc_dflags hsc_env
+        platform = targetPlatform dflags
+        dump = dumpGraph dflags
+
+        dumps flag name
+           = mapM_ (dumpWith dflags flag name . ppr)
+
+        condPass flag pass g dumpflag dumpname =
+            if gopt flag dflags
+               then do
+                    g <- return $ pass g
+                    dump dumpflag dumpname g
+                    return g
+               else return g
+
+        -- we don't need to split proc points for the NCG, unless
+        -- tablesNextToCode is off.  The latter is because we have no
+        -- label to put on info tables for basic blocks that are not
+        -- the entry point.
+        splitting_proc_points = hscTarget dflags /= HscAsm
+                             || not (tablesNextToCode dflags)
+                             || -- Note [inconsistent-pic-reg]
+                                usingInconsistentPicReg
+        usingInconsistentPicReg
+           = case (platformArch platform, platformOS platform, positionIndependent dflags)
+             of   (ArchX86, OSDarwin, pic) -> pic
+                  _                        -> False
+
+-- Note [Sinking after stack layout]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- In the past we considered running sinking pass also before stack
+-- layout, but after making some measurements we realized that:
+--
+--   a) running sinking only before stack layout produces slower
+--      code than running sinking only before stack layout
+--
+--   b) running sinking both before and after stack layout produces
+--      code that has the same performance as when running sinking
+--      only after stack layout.
+--
+-- In other words sinking before stack layout doesn't buy as anything.
+--
+-- An interesting question is "why is it better to run sinking after
+-- stack layout"? It seems that the major reason are stores and loads
+-- generated by stack layout. Consider this code before stack layout:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[(young<c1D> + 8)] = c1D;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Stack layout pass will save all local variables live across a call
+-- (_c1C, _c1B and _c1A in this example) on the stack just before
+-- making a call and reload them from the stack after returning from a
+-- call:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = _c1A::P64;
+--      P64[Sp - 16] = _c1B::P64;
+--      P64[Sp - 8] = _c1C::P64;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      _c1A::P64 = P64[Sp + 8];
+--      _c1B::P64 = P64[Sp + 16];
+--      _c1C::P64 = P64[Sp + 24];
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- If we don't run sinking pass after stack layout we are basically
+-- left with such code. However, running sinking on this code can lead
+-- to significant improvements:
+--
+--  c1E:
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = R1;
+--      P64[Sp - 16] = R2;
+--      P64[Sp - 8] = R3;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = P64[Sp + 24];
+--      R2 = P64[Sp + 16];
+--      R1 = P64[Sp + 8];
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Now we only have 9 assignments instead of 15.
+--
+-- There is one case when running sinking before stack layout could
+-- be beneficial. Consider this:
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...x...y...
+--
+-- Since both x and y are live across a call to f, they will be stored
+-- on the stack during stack layout and restored after the call:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 24] = L2
+--      P64[Sp - 16] = x
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 24
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 16]
+--      x = P64[Sp + 8]
+--      Sp = Sp + 24
+--      ...x...y...
+--
+-- However, if we run sinking before stack layout we would propagate x
+-- to its usage place (both x and y must be local register for this to
+-- be possible - global registers cannot be floated past a call):
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...y...y...
+--
+-- Thus making x dead at the call to f(). If we ran stack layout now
+-- we would generate less stores and loads:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 16] = L2
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 16
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 8]
+--      Sp = Sp + 16
+--      ...y...y...
+--
+-- But since we don't see any benefits from running sinking befroe stack
+-- layout, this situation probably doesn't arise too often in practice.
+--
+
+{- Note [inconsistent-pic-reg]
+
+On x86/Darwin, PIC is implemented by inserting a sequence like
+
+    call 1f
+ 1: popl %reg
+
+at the proc entry point, and then referring to labels as offsets from
+%reg.  If we don't split proc points, then we could have many entry
+points in a proc that would need this sequence, and each entry point
+would then get a different value for %reg.  If there are any join
+points, then at the join point we don't have a consistent value for
+%reg, so we don't know how to refer to labels.
+
+Hence, on x86/Darwin, we have to split proc points, and then each proc
+point will get its own PIC initialisation sequence.
+
+This isn't an issue on x86/ELF, where the sequence is
+
+    call 1f
+ 1: popl %reg
+    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
+
+so %reg always has a consistent value: the address of
+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
+
+-}
+
+{- Note [unreachable blocks]
+
+The control-flow optimiser sometimes leaves unreachable blocks behind
+containing junk code.  These aren't necessarily a problem, but
+removing them is good because it might save time in the native code
+generator later.
+
+-}
+
+runUniqSM :: UniqSM a -> IO a
+runUniqSM m = do
+  us <- mkSplitUniqSupply 'u'
+  return (initUs_ us m)
+
+
+dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
+dumpGraph dflags flag name g = do
+  when (gopt Opt_DoCmmLinting dflags) $ do_lint g
+  dumpWith dflags flag name (ppr g)
+ where
+  do_lint g = case cmmLintGraph dflags g of
+                 Just err -> do { fatalErrorMsg dflags err
+                                ; ghcExit dflags 1
+                                }
+                 Nothing  -> return ()
+
+dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
+dumpWith dflags flag txt sdoc = do
+         -- ToDo: No easy way of say "dump all the cmm, *and* split
+         -- them into files."  Also, -ddump-cmm-verbose doesn't play
+         -- nicely with -ddump-to-file, since the headers get omitted.
+   dumpIfSet_dyn dflags flag txt sdoc
+   when (not (dopt flag dflags)) $
+      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -0,0 +1,496 @@
+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
+
+module CmmProcPoint
+    ( ProcPointSet, Status(..)
+    , callProcPoints, minimalProcPointSet
+    , splitAtProcPoints, procPointAnalysis
+    , attachContInfoTables
+    )
+where
+
+import GhcPrelude hiding (last, unzip, succ, zip)
+
+import DynFlags
+import BlockId
+import CLabel
+import Cmm
+import PprCmm ()
+import CmmUtils
+import CmmInfo
+import CmmLive
+import CmmSwitch
+import Data.List (sortBy)
+import Maybes
+import Control.Monad
+import Outputable
+import Platform
+import UniqSupply
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
+
+-- Compute a minimal set of proc points for a control-flow graph.
+
+-- Determine a protocol for each proc point (which live variables will
+-- be passed as arguments and which will be on the stack).
+
+{-
+A proc point is a basic block that, after CPS transformation, will
+start a new function.  The entry block of the original function is a
+proc point, as is the continuation of each function call.
+A third kind of proc point arises if we want to avoid copying code.
+Suppose we have code like the following:
+
+  f() {
+    if (...) { ..1..; call foo(); ..2..}
+    else     { ..3..; call bar(); ..4..}
+    x = y + z;
+    return x;
+  }
+
+The statement 'x = y + z' can be reached from two different proc
+points: the continuations of foo() and bar().  We would prefer not to
+put a copy in each continuation; instead we would like 'x = y + z' to
+be the start of a new procedure to which the continuations can jump:
+
+  f_cps () {
+    if (...) { ..1..; push k_foo; jump foo_cps(); }
+    else     { ..3..; push k_bar; jump bar_cps(); }
+  }
+  k_foo() { ..2..; jump k_join(y, z); }
+  k_bar() { ..4..; jump k_join(y, z); }
+  k_join(y, z) { x = y + z; return x; }
+
+You might think then that a criterion to make a node a proc point is
+that it is directly reached by two distinct proc points.  (Note
+[Direct reachability].)  But this criterion is a bit too simple; for
+example, 'return x' is also reached by two proc points, yet there is
+no point in pulling it out of k_join.  A good criterion would be to
+say that a node should be made a proc point if it is reached by a set
+of proc points that is different than its immediate dominator.  NR
+believes this criterion can be shown to produce a minimum set of proc
+points, and given a dominator tree, the proc points can be chosen in
+time linear in the number of blocks.  Lacking a dominator analysis,
+however, we turn instead to an iterative solution, starting with no
+proc points and adding them according to these rules:
+
+  1. The entry block is a proc point.
+  2. The continuation of a call is a proc point.
+  3. A node is a proc point if it is directly reached by more proc
+     points than one of its predecessors.
+
+Because we don't understand the problem very well, we apply rule 3 at
+most once per iteration, then recompute the reachability information.
+(See Note [No simple dataflow].)  The choice of the new proc point is
+arbitrary, and I don't know if the choice affects the final solution,
+so I don't know if the number of proc points chosen is the
+minimum---but the set will be minimal.
+
+
+
+Note [Proc-point analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given a specified set of proc-points (a set of block-ids), "proc-point
+analysis" figures out, for every block, which proc-point it belongs to.
+All the blocks belonging to proc-point P will constitute a single
+top-level C procedure.
+
+A non-proc-point block B "belongs to" a proc-point P iff B is
+reachable from P without going through another proc-point.
+
+Invariant: a block B should belong to at most one proc-point; if it
+belongs to two, that's a bug.
+
+Note [Non-existing proc-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+On some architectures it might happen that the list of proc-points
+computed before stack layout pass will be invalidated by the stack
+layout. This will happen if stack layout removes from the graph
+blocks that were determined to be proc-points. Later on in the pipeline
+we use list of proc-points to perform [Proc-point analysis], but
+if a proc-point does not exist anymore then we will get compiler panic.
+See #8205.
+-}
+
+type ProcPointSet = LabelSet
+
+data Status
+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
+  | ProcPoint               -- this block is itself a proc point
+
+instance Outputable Status where
+  ppr (ReachedBy ps)
+      | setNull ps = text "<not-reached>"
+      | otherwise = text "reached by" <+>
+                    (hsep $ punctuate comma $ map ppr $ setElems ps)
+  ppr ProcPoint = text "<procpt>"
+
+--------------------------------------------------
+-- Proc point analysis
+
+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from
+-- See Note [Proc-point analysis]
+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
+  where
+    initProcPoints =
+        mkFactBase
+            procPointLattice
+            [ (id, ProcPoint)
+            | id <- setElems procPoints
+            -- See Note [Non-existing proc-points]
+            , id `setMember` labelsInGraph
+            ]
+    labelsInGraph = labelsDefined graph
+
+procPointTransfer :: TransferFun Status
+procPointTransfer block facts =
+    let label = entryLabel block
+        !fact = case getFact procPointLattice label facts of
+            ProcPoint -> ReachedBy $! setSingleton label
+            f -> f
+        result = map (\id -> (id, fact)) (successors block)
+    in mkFactBase procPointLattice result
+
+procPointLattice :: DataflowLattice Status
+procPointLattice = DataflowLattice unreached add_to
+  where
+    unreached = ReachedBy setEmpty
+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
+        | setSize union > setSize p = Changed (ReachedBy union)
+        | otherwise = NotChanged (ReachedBy p)
+      where
+        union = setUnion p' p
+
+----------------------------------------------------------------------
+
+-- It is worth distinguishing two sets of proc points: those that are
+-- induced by calls in the original graph and those that are
+-- introduced because they're reachable from multiple proc points.
+--
+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
+callProcPoints      :: CmmGraph -> ProcPointSet
+callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
+  where add :: LabelSet -> CmmBlock -> LabelSet
+        add set b = case lastNode b of
+                      CmmCall {cml_cont = Just k} -> setInsert k set
+                      CmmForeignCall {succ=k}     -> setInsert k set
+                      _ -> set
+
+minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
+                    -> UniqSM ProcPointSet
+-- Given the set of successors of calls (which must be proc-points)
+-- figure out the minimal set of necessary proc-points
+minimalProcPointSet platform callProcPoints g
+  = extendPPSet platform g (revPostorder g) callProcPoints
+
+extendPPSet
+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
+extendPPSet platform g blocks procPoints =
+    let env = procPointAnalysis procPoints g
+        add pps block = let id = entryLabel block
+                        in  case mapLookup id env of
+                              Just ProcPoint -> setInsert id pps
+                              _ -> pps
+        procPoints' = foldlGraphBlocks add setEmpty g
+        newPoints = mapMaybe ppSuccessor blocks
+        newPoint  = listToMaybe newPoints
+        ppSuccessor b =
+            let nreached id = case mapLookup id env `orElse`
+                                    pprPanic "no ppt" (ppr id <+> ppr b) of
+                                ProcPoint -> 1
+                                ReachedBy ps -> setSize ps
+                block_procpoints = nreached (entryLabel b)
+                -- | Looking for a successor of b that is reached by
+                -- more proc points than b and is not already a proc
+                -- point.  If found, it can become a proc point.
+                newId succ_id = not (setMember succ_id procPoints') &&
+                                nreached succ_id > block_procpoints
+            in  listToMaybe $ filter newId $ successors b
+
+    in case newPoint of
+         Just id ->
+             if setMember id procPoints'
+                then panic "added old proc pt"
+                else extendPPSet platform g blocks (setInsert id procPoints')
+         Nothing -> return procPoints'
+
+
+-- At this point, we have found a set of procpoints, each of which should be
+-- the entry point of a procedure.
+-- Now, we create the procedure for each proc point,
+-- which requires that we:
+-- 1. build a map from proc points to the blocks reachable from the proc point
+-- 2. turn each branch to a proc point into a jump
+-- 3. turn calls and returns into jumps
+-- 4. build info tables for the procedures -- and update the info table for
+--    the SRTs in the entry procedure as well.
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
+                     CmmDecl -> UniqSM [CmmDecl]
+splitAtProcPoints dflags entry_label callPPs procPoints procMap
+                  (CmmProc (TopInfo {info_tbls = info_tbls})
+                           top_l _ g@(CmmGraph {g_entry=entry})) =
+  do -- Build a map from procpoints to the blocks they reach
+     let add_block
+             :: LabelMap (LabelMap CmmBlock)
+             -> CmmBlock
+             -> LabelMap (LabelMap CmmBlock)
+         add_block graphEnv b =
+           case mapLookup bid procMap of
+             Just ProcPoint -> add graphEnv bid bid b
+             Just (ReachedBy set) ->
+               case setElems set of
+                 []   -> graphEnv
+                 [id] -> add graphEnv id bid b
+                 _    -> panic "Each block should be reachable from only one ProcPoint"
+             Nothing -> graphEnv
+           where bid = entryLabel b
+         add graphEnv procId bid b = mapInsert procId graph' graphEnv
+               where graph  = mapLookup procId graphEnv `orElse` mapEmpty
+                     graph' = mapInsert bid b graph
+
+     let liveness = cmmGlobalLiveness dflags g
+     let ppLiveness pp = filter isArgReg $
+                         regSetToList $
+                         expectJust "ppLiveness" $ mapLookup pp liveness
+
+     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
+
+     -- Build a map from proc point BlockId to pairs of:
+     --  * Labels for their new procedures
+     --  * Labels for the info tables of their new procedures (only if
+     --    the proc point is a callPP)
+     -- Due to common blockification, we may overestimate the set of procpoints.
+     let add_label map pp = mapInsert pp lbls map
+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
+                                                    Just info_table_lbl)
+                      where block_lbl      = blockLbl pp
+                            info_table_lbl = infoTblLbl pp
+
+         procLabels :: LabelMap (CLabel, Maybe CLabel)
+         procLabels = foldl' add_label mapEmpty
+                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+
+     -- In each new graph, add blocks jumping off to the new procedures,
+     -- and replace branches to procpoints with branches to the jump-off blocks
+     let add_jump_block
+             :: (LabelMap Label, [CmmBlock])
+             -> (Label, CLabel)
+             -> UniqSM (LabelMap Label, [CmmBlock])
+         add_jump_block (env, bs) (pp, l) =
+           do bid <- liftM mkBlockId getUniqueM
+              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
+                  live = ppLiveness pp
+                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
+              return (mapInsert pp bid env, b : bs)
+
+         add_jumps
+             :: LabelMap CmmGraph
+             -> (Label, LabelMap CmmBlock)
+             -> UniqSM (LabelMap CmmGraph)
+         add_jumps newGraphEnv (ppId, blockEnv) =
+           do let needed_jumps = -- find which procpoints we currently branch to
+                    mapFoldr add_if_branch_to_pp [] blockEnv
+                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
+                  add_if_branch_to_pp block rst =
+                    case lastNode block of
+                      CmmBranch id          -> add_if_pp id rst
+                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
+                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids
+                      _                     -> rst
+
+                  -- when jumping to a PP that has an info table, if
+                  -- tablesNextToCode is off we must jump to the entry
+                  -- label instead.
+                  jump_label (Just info_lbl) _
+                             | tablesNextToCode dflags = info_lbl
+                             | otherwise               = toEntryLbl info_lbl
+                  jump_label Nothing         block_lbl = block_lbl
+
+                  add_if_pp id rst = case mapLookup id procLabels of
+                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
+                                       Nothing                 -> rst
+              (jumpEnv, jumpBlocks) <-
+                 foldM add_jump_block (mapEmpty, []) needed_jumps
+                  -- update the entry block
+              let b = expectJust "block in env" $ mapLookup ppId blockEnv
+                  blockEnv' = mapInsert ppId b blockEnv
+                  -- replace branches to procpoints with branches to jumps
+                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
+                  -- add the jump blocks to the graph
+                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
+              let g' = ofBlockMap ppId blockEnv'''
+              -- pprTrace "g' pre jumps" (ppr g') $ do
+              return (mapInsert ppId g' newGraphEnv)
+
+     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
+
+     let to_proc (bid, g)
+             | bid == entry
+             =  CmmProc (TopInfo {info_tbls  = info_tbls,
+                                  stack_info = stack_info})
+                        top_l live g'
+             | otherwise
+             = case expectJust "pp label" $ mapLookup bid procLabels of
+                 (lbl, Just info_lbl)
+                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
+                                        , stack_info=stack_info})
+                               lbl live g'
+                 (lbl, Nothing)
+                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
+                               lbl live g'
+                where
+                 g' = replacePPIds g
+                 live = ppLiveness (g_entry g')
+                 stack_info = StackInfo { arg_space = 0
+                                        , updfr_space =  Nothing
+                                        , do_layout = True }
+                               -- cannot use panic, this is printed by -ddump-cmm
+
+         -- References to procpoint IDs can now be replaced with the
+         -- infotable's label
+         replacePPIds g = {-# SCC "replacePPIds" #-}
+                          mapGraphNodes (id, mapExp repl, mapExp repl) g
+           where repl e@(CmmLit (CmmBlock bid)) =
+                   case mapLookup bid procLabels of
+                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
+                     _ -> e
+                 repl e = e
+
+     -- The C back end expects to see return continuations before the
+     -- call sites.  Here, we sort them in reverse order -- it gets
+     -- reversed later.
+     let (_, block_order) =
+             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
+                   (revPostorder g)
+         add_block_num (i, map) block =
+           (i + 1, mapInsert (entryLabel block) i map)
+         sort_fn (bid, _) (bid', _) =
+           compare (expectJust "block_order" $ mapLookup bid  block_order)
+                   (expectJust "block_order" $ mapLookup bid' block_order)
+     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+     return -- pprTrace "procLabels" (ppr procLabels)
+            -- pprTrace "splitting graphs" (ppr procs)
+            procs
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
+
+-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
+-- recursive lookup, see comment below.
+replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceBranches env cmmg
+  = {-# SCC "replaceBranches" #-}
+    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
+  where
+    f block = replaceLastNode block $ last (lastNode block)
+
+    last :: CmmNode O C -> CmmNode O C
+    last (CmmBranch id)          = CmmBranch (lookup id)
+    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l
+    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)
+    last l@(CmmCall {})          = l { cml_cont = Nothing }
+            -- NB. remove the continuation of a CmmCall, since this
+            -- label will now be in a different CmmProc.  Not only
+            -- is this tidier, it stops CmmLint from complaining.
+    last l@(CmmForeignCall {})   = l
+    lookup id = fmap lookup (mapLookup id env) `orElse` id
+            -- XXX: this is a recursive lookup, it follows chains
+            -- until the lookup returns Nothing, at which point we
+            -- return the last BlockId
+
+-- --------------------------------------------------------------
+-- Not splitting proc points: add info tables for continuations
+
+attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
+attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
+ = CmmProc top_info{info_tbls = info_tbls'} top_l live g
+ where
+   info_tbls' = mapUnion (info_tbls top_info) $
+                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
+                            | l <- setElems call_proc_points
+                            , l /= g_entry g ]
+attachContInfoTables _ other_decl
+ = other_decl
+
+----------------------------------------------------------------
+
+{-
+Note [Direct reachability]
+
+Block B is directly reachable from proc point P iff control can flow
+from P to B without passing through an intervening proc point.
+-}
+
+----------------------------------------------------------------
+
+{-
+Note [No simple dataflow]
+
+Sadly, it seems impossible to compute the proc points using a single
+dataflow pass.  One might attempt to use this simple lattice:
+
+  data Location = Unknown
+                | InProc BlockId -- node is in procedure headed by the named proc point
+                | ProcPoint      -- node is itself a proc point
+
+At a join, a node in two different blocks becomes a proc point.
+The difficulty is that the change of information during iterative
+computation may promote a node prematurely.  Here's a program that
+illustrates the difficulty:
+
+  f () {
+  entry:
+    ....
+  L1:
+    if (...) { ... }
+    else { ... }
+
+  L2: if (...) { g(); goto L1; }
+      return x + y;
+  }
+
+The only proc-point needed (besides the entry) is L1.  But in an
+iterative analysis, consider what happens to L2.  On the first pass
+through, it rises from Unknown to 'InProc entry', but when L1 is
+promoted to a proc point (because it's the successor of g()), L1's
+successors will be promoted to 'InProc L1'.  The problem hits when the
+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
+The join operation makes it a proc point when in fact it needn't be,
+because its immediate dominator L1 is already a proc point and there
+are no other proc points that directly reach L2.
+-}
+
+
+
+{- Note [Separate Adams optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It may be worthwhile to attempt the Adams optimization by rewriting
+the graph before the assignment of proc-point protocols.  Here are a
+couple of rules:
+
+  g() returns to k;                    g() returns to L;
+  k: CopyIn c ress; goto L:
+   ...                        ==>        ...
+  L: // no CopyIn node here            L: CopyIn c ress;
+
+
+And when c == c' and ress == ress', this also:
+
+  g() returns to k;                    g() returns to L;
+  k: CopyIn c ress; goto L:
+   ...                        ==>        ...
+  L: CopyIn c' ress'                   L: CopyIn c' ress' ;
+
+In both cases the goal is to eliminate k.
+-}
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmSink.hs
@@ -0,0 +1,855 @@
+{-# LANGUAGE GADTs #-}
+module CmmSink (
+     cmmSink
+  ) where
+
+import GhcPrelude
+
+import Cmm
+import CmmOpt
+import CmmLive
+import CmmUtils
+import Hoopl.Block
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Graph
+import CodeGen.Platform
+import Platform (isARM, platformArch)
+
+import DynFlags
+import Unique
+import UniqFM
+import PprCmm ()
+
+import qualified Data.IntSet as IntSet
+import Data.List (partition)
+import qualified Data.Set as Set
+import Data.Maybe
+
+-- Compact sets for membership tests of local variables.
+
+type LRegSet = IntSet.IntSet
+
+emptyLRegSet :: LRegSet
+emptyLRegSet = IntSet.empty
+
+nullLRegSet :: LRegSet -> Bool
+nullLRegSet = IntSet.null
+
+insertLRegSet :: LocalReg -> LRegSet -> LRegSet
+insertLRegSet l = IntSet.insert (getKey (getUnique l))
+
+elemLRegSet :: LocalReg -> LRegSet -> Bool
+elemLRegSet l = IntSet.member (getKey (getUnique l))
+
+-- -----------------------------------------------------------------------------
+-- Sinking and inlining
+
+-- This is an optimisation pass that
+--  (a) moves assignments closer to their uses, to reduce register pressure
+--  (b) pushes assignments into a single branch of a conditional if possible
+--  (c) inlines assignments to registers that are mentioned only once
+--  (d) discards dead assignments
+--
+-- This tightens up lots of register-heavy code.  It is particularly
+-- helpful in the Cmm generated by the Stg->Cmm code generator, in
+-- which every function starts with a copyIn sequence like:
+--
+--    x1 = R1
+--    x2 = Sp[8]
+--    x3 = Sp[16]
+--    if (Sp - 32 < SpLim) then L1 else L2
+--
+-- we really want to push the x1..x3 assignments into the L2 branch.
+--
+-- Algorithm:
+--
+--  * Start by doing liveness analysis.
+--
+--  * Keep a list of assignments A; earlier ones may refer to later ones.
+--    Currently we only sink assignments to local registers, because we don't
+--    have liveness information about global registers.
+--
+--  * Walk forwards through the graph, look at each node N:
+--
+--    * If it is a dead assignment, i.e. assignment to a register that is
+--      not used after N, discard it.
+--
+--    * Try to inline based on current list of assignments
+--      * If any assignments in A (1) occur only once in N, and (2) are
+--        not live after N, inline the assignment and remove it
+--        from A.
+--
+--      * If an assignment in A is cheap (RHS is local register), then
+--        inline the assignment and keep it in A in case it is used afterwards.
+--
+--      * Otherwise don't inline.
+--
+--    * If N is assignment to a local register pick up the assignment
+--      and add it to A.
+--
+--    * If N is not an assignment to a local register:
+--      * remove any assignments from A that conflict with N, and
+--        place them before N in the current block.  We call this
+--        "dropping" the assignments.
+--
+--      * An assignment conflicts with N if it:
+--        - assigns to a register mentioned in N
+--        - mentions a register assigned by N
+--        - reads from memory written by N
+--      * do this recursively, dropping dependent assignments
+--
+--    * At an exit node:
+--      * drop any assignments that are live on more than one successor
+--        and are not trivial
+--      * if any successor has more than one predecessor (a join-point),
+--        drop everything live in that successor. Since we only propagate
+--        assignments that are not dead at the successor, we will therefore
+--        eliminate all assignments dead at this point. Thus analysis of a
+--        join-point will always begin with an empty list of assignments.
+--
+--
+-- As a result of above algorithm, sinking deletes some dead assignments
+-- (transitively, even).  This isn't as good as removeDeadAssignments,
+-- but it's much cheaper.
+
+-- -----------------------------------------------------------------------------
+-- things that we aren't optimising very well yet.
+--
+-- -----------
+-- (1) From GHC's FastString.hashStr:
+--
+--  s2ay:
+--      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;
+--  c2gn:
+--      R1 = _s2au::I64;
+--      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;
+--  c2gp:
+--      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,
+--                                 4091);
+--      _s2an::I64 = _s2an::I64 + 1;
+--      _s2au::I64 = _s2cO::I64;
+--      goto s2ay;
+--
+-- a nice loop, but we didn't eliminate the silly assignment at the end.
+-- See Note [dependent assignments], which would probably fix this.
+-- This is #8336.
+--
+-- -----------
+-- (2) From stg_atomically_frame in PrimOps.cmm
+--
+-- We have a diamond control flow:
+--
+--     x = ...
+--       |
+--      / \
+--     A   B
+--      \ /
+--       |
+--    use of x
+--
+-- Now x won't be sunk down to its use, because we won't push it into
+-- both branches of the conditional.  We certainly do have to check
+-- that we can sink it past all the code in both A and B, but having
+-- discovered that, we could sink it to its use.
+--
+
+-- -----------------------------------------------------------------------------
+
+type Assignment = (LocalReg, CmmExpr, AbsMem)
+  -- Assignment caches AbsMem, an abstraction of the memory read by
+  -- the RHS of the assignment.
+
+type Assignments = [Assignment]
+  -- A sequence of assignments; kept in *reverse* order
+  -- So the list [ x=e1, y=e2 ] means the sequence of assignments
+  --     y = e2
+  --     x = e1
+
+cmmSink :: DynFlags -> CmmGraph -> CmmGraph
+cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
+  where
+  liveness = cmmLocalLiveness dflags graph
+  getLive l = mapFindWithDefault Set.empty l liveness
+
+  blocks = revPostorder graph
+
+  join_pts = findJoinPoints blocks
+
+  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
+  sink _ [] = []
+  sink sunk (b:bs) =
+    -- pprTrace "sink" (ppr lbl) $
+    blockJoin first final_middle final_last : sink sunk' bs
+    where
+      lbl = entryLabel b
+      (first, middle, last) = blockSplit b
+
+      succs = successors last
+
+      -- Annotate the middle nodes with the registers live *after*
+      -- the node.  This will help us decide whether we can inline
+      -- an assignment in the current node or not.
+      live = Set.unions (map getLive succs)
+      live_middle = gen_kill dflags last live
+      ann_middles = annotate dflags live_middle (blockToList middle)
+
+      -- Now sink and inline in this block
+      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
+      fold_last = constantFoldNode dflags last
+      (final_last, assigs') = tryToInline dflags live fold_last assigs
+
+      -- We cannot sink into join points (successors with more than
+      -- one predecessor), so identify the join points and the set
+      -- of registers live in them.
+      (joins, nonjoins) = partition (`mapMember` join_pts) succs
+      live_in_joins = Set.unions (map getLive joins)
+
+      -- We do not want to sink an assignment into multiple branches,
+      -- so identify the set of registers live in multiple successors.
+      -- This is made more complicated because when we sink an assignment
+      -- into one branch, this might change the set of registers that are
+      -- now live in multiple branches.
+      init_live_sets = map getLive nonjoins
+      live_in_multi live_sets r =
+         case filter (Set.member r) live_sets of
+           (_one:_two:_) -> True
+           _ -> False
+
+      -- Now, drop any assignments that we will not sink any further.
+      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'
+
+      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
+          where
+            should_drop =  conflicts dflags a final_last
+                        || not (isTrivial dflags rhs) && live_in_multi live_sets r
+                        || r `Set.member` live_in_joins
+
+            live_sets' | should_drop = live_sets
+                       | otherwise   = map upd live_sets
+
+            upd set | r `Set.member` set = set `Set.union` live_rhs
+                    | otherwise          = set
+
+            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs
+
+      final_middle = foldl' blockSnoc middle' dropped_last
+
+      sunk' = mapUnion sunk $
+                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
+                             | l <- succs ]
+
+{- TODO: enable this later, when we have some good tests in place to
+   measure the effect and tune it.
+
+-- small: an expression we don't mind duplicating
+isSmall :: CmmExpr -> Bool
+isSmall (CmmReg (CmmLocal _)) = True  --
+isSmall (CmmLit _) = True
+isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y
+isSmall (CmmRegOff (CmmLocal _) _) = True
+isSmall _ = False
+-}
+
+--
+-- We allow duplication of trivial expressions: registers (both local and
+-- global) and literals.
+--
+isTrivial :: DynFlags -> CmmExpr -> Bool
+isTrivial _ (CmmReg (CmmLocal _)) = True
+isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]
+  if isARM (platformArch (targetPlatform dflags))
+  then True -- CodeGen.Platform.ARM does not have globalRegMaybe
+  else isJust (globalRegMaybe (targetPlatform dflags) r)
+  -- GlobalRegs that are loads from BaseReg are not trivial
+isTrivial _ (CmmLit _) = True
+isTrivial _ _          = False
+
+--
+-- annotate each node with the set of registers live *after* the node
+--
+annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]
+annotate dflags live nodes = snd $ foldr ann (live,[]) nodes
+  where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)
+
+--
+-- Find the blocks that have multiple successors (join points)
+--
+findJoinPoints :: [CmmBlock] -> LabelMap Int
+findJoinPoints blocks = mapFilter (>1) succ_counts
+ where
+  all_succs = concatMap successors blocks
+
+  succ_counts :: LabelMap Int
+  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
+
+--
+-- filter the list of assignments to remove any assignments that
+-- are not live in a continuation.
+--
+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments
+filterAssignments dflags live assigs = reverse (go assigs [])
+  where go []             kept = kept
+        go (a@(r,_,_):as) kept | needed    = go as (a:kept)
+                               | otherwise = go as kept
+           where
+              needed = r `Set.member` live
+                       || any (conflicts dflags a) (map toNode kept)
+                       --  Note that we must keep assignments that are
+                       -- referred to by other assignments we have
+                       -- already kept.
+
+-- -----------------------------------------------------------------------------
+-- Walk through the nodes of a block, sinking and inlining assignments
+-- as we go.
+--
+-- On input we pass in a:
+--    * list of nodes in the block
+--    * a list of assignments that appeared *before* this block and
+--      that are being sunk.
+--
+-- On output we get:
+--    * a new block
+--    * a list of assignments that will be placed *after* that block.
+--
+
+walk :: DynFlags
+     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with
+                                        -- the set of registers live *after*
+                                        -- this node.
+
+     -> Assignments                     -- The current list of
+                                        -- assignments we are sinking.
+                                        -- Earlier assignments may refer
+                                        -- to later ones.
+
+     -> ( Block CmmNode O O             -- The new block
+        , Assignments                   -- Assignments to sink further
+        )
+
+walk dflags nodes assigs = go nodes emptyBlock assigs
+ where
+   go []               block as = (block, as)
+   go ((live,node):ns) block as
+    | shouldDiscard node live           = go ns block as
+       -- discard dead assignment
+    | Just a <- shouldSink dflags node2 = go ns block (a : as1)
+    | otherwise                         = go ns block' as'
+    where
+      node1 = constantFoldNode dflags node
+
+      (node2, as1) = tryToInline dflags live node1 as
+
+      (dropped, as') = dropAssignmentsSimple dflags
+                          (\a -> conflicts dflags a node2) as1
+
+      block' = foldl' blockSnoc block dropped `blockSnoc` node2
+
+
+--
+-- Heuristic to decide whether to pick up and sink an assignment
+-- Currently we pick up all assignments to local registers.  It might
+-- be profitable to sink assignments to global regs too, but the
+-- liveness analysis doesn't track those (yet) so we can't.
+--
+shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
+shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)
+  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
+shouldSink _ _other = Nothing
+
+--
+-- discard dead assignments.  This doesn't do as good a job as
+-- removeDeadAssignments, because it would need multiple passes
+-- to get all the dead code, but it catches the common case of
+-- superfluous reloads from the stack that the stack allocator
+-- leaves behind.
+--
+-- Also we catch "r = r" here.  You might think it would fall
+-- out of inlining, but the inliner will see that r is live
+-- after the instruction and choose not to inline r in the rhs.
+--
+shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool
+shouldDiscard node live
+   = case node of
+       CmmAssign r (CmmReg r') | r == r' -> True
+       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)
+       _otherwise -> False
+
+
+toNode :: Assignment -> CmmNode O O
+toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
+
+dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments
+                      -> ([CmmNode O O], Assignments)
+dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()
+
+dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
+                -> ([CmmNode O O], Assignments)
+dropAssignments dflags should_drop state assigs
+ = (dropped, reverse kept)
+ where
+   (dropped,kept) = go state assigs [] []
+
+   go _ []             dropped kept = (dropped, kept)
+   go state (assig : rest) dropped kept
+      | conflict  = go state' rest (toNode assig : dropped) kept
+      | otherwise = go state' rest dropped (assig:kept)
+      where
+        (dropit, state') = should_drop assig state
+        conflict = dropit || any (conflicts dflags assig) dropped
+
+
+-- -----------------------------------------------------------------------------
+-- Try to inline assignments into a node.
+-- This also does constant folding for primpops, since
+-- inlining opens up opportunities for doing so.
+
+tryToInline
+   :: DynFlags
+   -> LocalRegSet               -- set of registers live after this
+                                -- node.  We cannot inline anything
+                                -- that is live after the node, unless
+                                -- it is small enough to duplicate.
+   -> CmmNode O x               -- The node to inline into
+   -> Assignments               -- Assignments to inline
+   -> (
+        CmmNode O x             -- New node
+      , Assignments             -- Remaining assignments
+      )
+
+tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
+ where
+  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
+  usages = foldLocalRegsUsed dflags addUsage emptyUFM node
+
+  go _usages node _skipped [] = (node, [])
+
+  go usages node skipped (a@(l,rhs,_) : rest)
+   | cannot_inline           = dont_inline
+   | occurs_none             = discard  -- Note [discard during inlining]
+   | occurs_once             = inline_and_discard
+   | isTrivial dflags rhs    = inline_and_keep
+   | otherwise               = dont_inline
+   where
+        inline_and_discard = go usages' inl_node skipped rest
+          where usages' = foldLocalRegsUsed dflags addUsage usages rhs
+
+        discard = go usages node skipped rest
+
+        dont_inline        = keep node  -- don't inline the assignment, keep it
+        inline_and_keep    = keep inl_node -- inline the assignment, keep it
+
+        keep node' = (final_node, a : rest')
+          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest
+                usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)
+                                            usages rhs
+                -- we must not inline anything that is mentioned in the RHS
+                -- of a binding that we have already skipped, so we set the
+                -- usages of the regs on the RHS to 2.
+
+        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]
+                        || l `elemLRegSet` skipped
+                        || not (okToInline dflags rhs node)
+
+        l_usages = lookupUFM usages l
+        l_live   = l `elemRegSet` live
+
+        occurs_once = not l_live && l_usages == Just 1
+        occurs_none = not l_live && l_usages == Nothing
+
+        inl_node = improveConditional (mapExpDeep inl_exp node)
+
+        inl_exp :: CmmExpr -> CmmExpr
+        -- inl_exp is where the inlining actually takes place!
+        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs
+        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
+                    = cmmOffset dflags rhs off
+                    -- re-constant fold after inlining
+        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
+        inl_exp other = other
+
+
+{- Note [improveConditional]
+
+cmmMachOpFold tries to simplify conditionals to turn things like
+  (a == b) != 1
+into
+  (a != b)
+but there's one case it can't handle: when the comparison is over
+floating-point values, we can't invert it, because floating-point
+comparisons aren't invertible (because of NaNs).
+
+But we *can* optimise this conditional by swapping the true and false
+branches. Given
+  CmmCondBranch ((a >## b) != 1) t f
+we can turn it into
+  CmmCondBranch (a >## b) f t
+
+So here we catch conditionals that weren't optimised by cmmMachOpFold,
+and apply above transformation to eliminate the comparison against 1.
+
+It's tempting to just turn every != into == and then let cmmMachOpFold
+do its thing, but that risks changing a nice fall-through conditional
+into one that requires two jumps. (see swapcond_last in
+CmmContFlowOpt), so instead we carefully look for just the cases where
+we can eliminate a comparison.
+-}
+improveConditional :: CmmNode O x -> CmmNode O x
+improveConditional
+  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)
+  | neLike mop, isComparisonExpr x
+  = CmmCondBranch x f t (fmap not l)
+  where
+    neLike (MO_Ne _) = True
+    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike _ = False
+improveConditional other = other
+
+-- Note [dependent assignments]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- If our assignment list looks like
+--
+--    [ y = e,  x = ... y ... ]
+--
+-- We cannot inline x.  Remember this list is really in reverse order,
+-- so it means  x = ... y ...; y = e
+--
+-- Hence if we inline x, the outer assignment to y will capture the
+-- reference in x's right hand side.
+--
+-- In this case we should rename the y in x's right-hand side,
+-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]
+-- Now we can go ahead and inline x.
+--
+-- For now we do nothing, because this would require putting
+-- everything inside UniqSM.
+--
+-- One more variant of this (#7366):
+--
+--   [ y = e, y = z ]
+--
+-- If we don't want to inline y = e, because y is used many times, we
+-- might still be tempted to inline y = z (because we always inline
+-- trivial rhs's).  But of course we can't, because y is equal to e,
+-- not z.
+
+-- Note [discard during inlining]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Opportunities to discard assignments sometimes appear after we've
+-- done some inlining.  Here's an example:
+--
+--      x = R1;
+--      y = P64[x + 7];
+--      z = P64[x + 15];
+--      /* z is dead */
+--      R1 = y & (-8);
+--
+-- The x assignment is trivial, so we inline it in the RHS of y, and
+-- keep both x and y.  z gets dropped because it is dead, then we
+-- inline y, and we have a dead assignment to x.  If we don't notice
+-- that x is dead in tryToInline, we end up retaining it.
+
+addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
+addUsage m r = addToUFM_C (+) m r 1
+
+regsUsedIn :: LRegSet -> CmmExpr -> Bool
+regsUsedIn ls _ | nullLRegSet ls = False
+regsUsedIn ls e = wrapRecExpf f e False
+  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True
+        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True
+        f _ z = z
+
+-- we don't inline into CmmUnsafeForeignCall if the expression refers
+-- to global registers.  This is a HACK to avoid global registers
+-- clashing with C argument-passing registers, really the back-end
+-- ought to be able to handle it properly, but currently neither PprC
+-- nor the NCG can do it.  See Note [Register parameter passing]
+-- See also StgCmmForeign:load_args_into_temps.
+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+okToInline dflags expr node@(CmmUnsafeForeignCall{}) =
+    not (globalRegistersConflict dflags expr node)
+okToInline _ _ _ = True
+
+-- -----------------------------------------------------------------------------
+
+-- | @conflicts (r,e) node@ is @False@ if and only if the assignment
+-- @r = e@ can be safely commuted past statement @node@.
+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
+conflicts dflags (r, rhs, addr) node
+
+  -- (1) node defines registers used by rhs of assignment. This catches
+  -- assignments and all three kinds of calls. See Note [Sinking and calls]
+  | globalRegistersConflict dflags rhs node                       = True
+  | localRegistersConflict  dflags rhs node                       = True
+
+  -- (2) node uses register defined by assignment
+  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True
+
+  -- (3) a store to an address conflicts with a read of the same memory
+  | CmmStore addr' e <- node
+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+
+  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
+  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True
+  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
+  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
+
+  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]
+  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True
+
+  -- (6) native calls clobber any memory
+  | CmmCall{} <- node, memConflicts addr AnyMem                   = True
+
+  -- (7) otherwise, no conflict
+  | otherwise = False
+
+-- Returns True if node defines any global registers that are used in the
+-- Cmm expression
+globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+globalRegistersConflict dflags expr node =
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+                 False node
+
+-- Returns True if node defines any local registers that are used in the
+-- Cmm expression
+localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+localRegistersConflict dflags expr node =
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)
+                 False node
+
+-- Note [Sinking and calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)
+-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after
+-- stack layout (see Note [Sinking after stack layout]) which leads to two
+-- invariants related to calls:
+--
+--   a) during stack layout phase all safe foreign calls are turned into
+--      unsafe foreign calls (see Note [Lower safe foreign calls]). This
+--      means that we will never encounter CmmForeignCall node when running
+--      sinking after stack layout
+--
+--   b) stack layout saves all variables live across a call on the stack
+--      just before making a call (remember we are not sinking assignments to
+--      stack):
+--
+--       L1:
+--          x = R1
+--          P64[Sp - 16] = L2
+--          P64[Sp - 8]  = x
+--          Sp = Sp - 16
+--          call f() returns L2
+--       L2:
+--
+--      We will attempt to sink { x = R1 } but we will detect conflict with
+--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even
+--      checking whether it conflicts with { call f() }. In this way we will
+--      never need to check any assignment conflicts with CmmCall. Remember
+--      that we still need to check for potential memory conflicts.
+--
+-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes
+-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).
+-- This assumption holds only when we do sinking after stack layout. If we run
+-- it before stack layout we need to check for possible conflicts with all three
+-- kinds of calls. Our `conflicts` function does that by using a generic
+-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and
+-- UserOfRegs typeclasses.
+--
+
+-- An abstraction of memory read or written.
+data AbsMem
+  = NoMem            -- no memory accessed
+  | AnyMem           -- arbitrary memory
+  | HeapMem          -- definitely heap memory
+  | StackMem         -- definitely stack memory
+  | SpMem            -- <size>[Sp+n]
+       {-# UNPACK #-} !Int
+       {-# UNPACK #-} !Int
+
+-- Having SpMem is important because it lets us float loads from Sp
+-- past stores to Sp as long as they don't overlap, and this helps to
+-- unravel some long sequences of
+--    x1 = [Sp + 8]
+--    x2 = [Sp + 16]
+--    ...
+--    [Sp + 8]  = xi
+--    [Sp + 16] = xj
+--
+-- Note that SpMem is invalidated if Sp is changed, but the definition
+-- of 'conflicts' above handles that.
+
+-- ToDo: this won't currently fix the following commonly occurring code:
+--    x1 = [R1 + 8]
+--    x2 = [R1 + 16]
+--    ..
+--    [Hp - 8] = x1
+--    [Hp - 16] = x2
+--    ..
+
+-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that
+-- assignments to [Hp + n] do not conflict with any other heap memory,
+-- but this is tricky to nail down.  What if we had
+--
+--   x = Hp + n
+--   [x] = ...
+--
+--  the store to [x] should be "new heap", not "old heap".
+--  Furthermore, you could imagine that if we started inlining
+--  functions in Cmm then there might well be reads of heap memory
+--  that was written in the same basic block.  To take advantage of
+--  non-aliasing of heap memory we will have to be more clever.
+
+-- Note [Foreign calls clobber heap]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- It is tempting to say that foreign calls clobber only
+-- non-heap/stack memory, but unfortunately we break this invariant in
+-- the RTS.  For example, in stg_catch_retry_frame we call
+-- stmCommitNestedTransaction() which modifies the contents of the
+-- TRec it is passed (this actually caused incorrect code to be
+-- generated).
+--
+-- Since the invariant is true for the majority of foreign calls,
+-- perhaps we ought to have a special annotation for calls that can
+-- modify heap/stack memory.  For now we just use the conservative
+-- definition here.
+--
+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
+-- therefore we should never float any memory operations across one of
+-- these calls.
+
+
+bothMems :: AbsMem -> AbsMem -> AbsMem
+bothMems NoMem    x         = x
+bothMems x        NoMem     = x
+bothMems HeapMem  HeapMem   = HeapMem
+bothMems StackMem StackMem     = StackMem
+bothMems (SpMem o1 w1) (SpMem o2 w2)
+  | o1 == o2  = SpMem o1 (max w1 w2)
+  | otherwise = StackMem
+bothMems SpMem{}  StackMem  = StackMem
+bothMems StackMem SpMem{}   = StackMem
+bothMems _         _        = AnyMem
+
+memConflicts :: AbsMem -> AbsMem -> Bool
+memConflicts NoMem      _          = False
+memConflicts _          NoMem      = False
+memConflicts HeapMem    StackMem   = False
+memConflicts StackMem   HeapMem    = False
+memConflicts SpMem{}    HeapMem    = False
+memConflicts HeapMem    SpMem{}    = False
+memConflicts (SpMem o1 w1) (SpMem o2 w2)
+  | o1 < o2   = o1 + w1 > o2
+  | otherwise = o2 + w2 > o1
+memConflicts _         _         = True
+
+exprMem :: DynFlags -> CmmExpr -> AbsMem
+exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
+exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)
+exprMem _      _                 = NoMem
+
+loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
+loadAddr dflags e w =
+  case e of
+   CmmReg r       -> regAddr dflags r 0 w
+   CmmRegOff r i  -> regAddr dflags r i w
+   _other | regUsedIn dflags spReg e -> StackMem
+          | otherwise -> AnyMem
+
+regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
+regAddr _      (CmmGlobal Hp) _ _ = HeapMem
+regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr _      _ _ _ = AnyMem
+
+{-
+Note [Inline GlobalRegs?]
+
+Should we freely inline GlobalRegs?
+
+Actually it doesn't make a huge amount of difference either way, so we
+*do* currently treat GlobalRegs as "trivial" and inline them
+everywhere, but for what it's worth, here is what I discovered when I
+(SimonM) looked into this:
+
+Common sense says we should not inline GlobalRegs, because when we
+have
+
+  x = R1
+
+the register allocator will coalesce this assignment, generating no
+code, and simply record the fact that x is bound to $rbx (or
+whatever).  Furthermore, if we were to sink this assignment, then the
+range of code over which R1 is live increases, and the range of code
+over which x is live decreases.  All things being equal, it is better
+for x to be live than R1, because R1 is a fixed register whereas x can
+live in any register.  So we should neither sink nor inline 'x = R1'.
+
+However, not inlining GlobalRegs can have surprising
+consequences. e.g. (cgrun020)
+
+  c3EN:
+      _s3DB::P64 = R1;
+      _c3ES::P64 = _s3DB::P64 & 7;
+      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;
+  c3EU:
+      _s3DD::P64 = P64[_s3DB::P64 + 6];
+      _s3DE::P64 = P64[_s3DB::P64 + 14];
+      I64[Sp - 8] = c3F0;
+      R1 = _s3DE::P64;
+      P64[Sp] = _s3DD::P64;
+
+inlining the GlobalReg gives:
+
+  c3EN:
+      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;
+  c3EU:
+      I64[Sp - 8] = c3F0;
+      _s3DD::P64 = P64[R1 + 6];
+      R1 = P64[R1 + 14];
+      P64[Sp] = _s3DD::P64;
+
+but if we don't inline the GlobalReg, instead we get:
+
+      _s3DB::P64 = R1;
+      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;
+  c3EU:
+      I64[Sp - 8] = c3F0;
+      R1 = P64[_s3DB::P64 + 14];
+      P64[Sp] = P64[_s3DB::P64 + 6];
+
+This looks better - we managed to inline _s3DD - but in fact it
+generates an extra reg-reg move:
+
+.Lc3EU:
+        movq $c3F0_info,-8(%rbp)
+        movq %rbx,%rax
+        movq 14(%rbx),%rbx
+        movq 6(%rax),%rax
+        movq %rax,(%rbp)
+
+because _s3DB is now live across the R1 assignment, we lost the
+benefit of coalescing.
+
+Who is at fault here?  Perhaps if we knew that _s3DB was an alias for
+R1, then we would not sink a reference to _s3DB past the R1
+assignment.  Or perhaps we *should* do that - we might gain by sinking
+it, despite losing the coalescing opportunity.
+
+Sometimes not inlining global registers wins by virtue of the rule
+about not inlining into arguments of a foreign call, e.g. (T7163) this
+is what happens when we inlined F1:
+
+      _s3L2::F32 = F1;
+      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);
+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);
+
+but if we don't inline F1:
+
+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,
+                                                                                            10.0 :: W32));
+-}
diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmSwitch.hs
@@ -0,0 +1,500 @@
+{-# LANGUAGE GADTs #-}
+module CmmSwitch (
+     SwitchTargets,
+     mkSwitchTargets,
+     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,
+     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
+     switchTargetsToList, eqSwitchTargetWith,
+
+     SwitchPlan(..),
+     targetSupportsSwitch,
+     createSwitchPlan,
+  ) where
+
+import GhcPrelude
+
+import Outputable
+import DynFlags
+import Hoopl.Label (Label)
+
+import Data.Maybe
+import Data.List (groupBy)
+import Data.Function (on)
+import qualified Data.Map as M
+
+-- Note [Cmm Switches, the general plan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Compiling a high-level switch statement, as it comes out of a STG case
+-- expression, for example, allows for a surprising amount of design decisions.
+-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as
+-- well as from the actual code generation.
+--
+-- The overall plan is:
+--  * The Stg → Cmm transformation creates a single `SwitchTargets` in
+--    emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs.
+--    At this stage, they are unsuitable for code generation.
+--  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these
+--    switch statements with code that is suitable for code generation, i.e.
+--    a nice balanced tree of decisions with dense jump tables in the leafs.
+--    The actual planning of this tree is performed in pure code in createSwitchPlan
+--    in this module. See Note [createSwitchPlan].
+--  * The actual code generation will not do any further processing and
+--    implement each CmmSwitch with a jump tables.
+--
+-- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch
+-- statements alone, as we can turn a SwitchTargets value into a nice
+-- switch-statement in LLVM resp. C, and leave the rest to the compiler.
+--
+-- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are
+-- separated.
+
+-----------------------------------------------------------------------------
+-- Note [Magic Constants in CmmSwitch]
+--
+-- There are a lot of heuristics here that depend on magic values where it is
+-- hard to determine the "best" value (for whatever that means). These are the
+-- magic values:
+
+-- | Number of consecutive default values allowed in a jump table. If there are
+-- more of them, the jump tables are split.
+--
+-- Currently 7, as it costs 7 words of additional code when a jump table is
+-- split (at least on x64, determined experimentally).
+maxJumpTableHole :: Integer
+maxJumpTableHole = 7
+
+-- | Minimum size of a jump table. If the number is smaller, the switch is
+-- implemented using conditionals.
+-- Currently 5, because an if-then-else tree of 4 values is nice and compact.
+minJumpTableSize :: Int
+minJumpTableSize = 5
+
+-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset].
+minJumpTableOffset :: Integer
+minJumpTableOffset = 2
+
+
+-----------------------------------------------------------------------------
+-- Switch Targets
+
+-- Note [SwitchTargets]:
+-- ~~~~~~~~~~~~~~~~~~~~~
+--
+-- The branches of a switch are stored in a SwitchTargets, which consists of an
+-- (optional) default jump target, and a map from values to jump targets.
+--
+-- If the default jump target is absent, the behaviour of the switch outside the
+-- values of the map is undefined.
+--
+-- We use an Integer for the keys the map so that it can be used in switches on
+-- unsigned as well as signed integers.
+--
+-- The map may be empty (we prune out-of-range branches here, so it could be us
+-- emptying it).
+--
+-- Before code generation, the table needs to be brought into a form where all
+-- entries are non-negative, so that it can be compiled into a jump table.
+-- See switchTargetsToTable.
+
+
+-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch'
+-- value, and knows whether the value is signed, the possible range, an
+-- optional default value and a map from values to jump labels.
+data SwitchTargets =
+    SwitchTargets
+        Bool                       -- Signed values
+        (Integer, Integer)         -- Range
+        (Maybe Label)              -- Default value
+        (M.Map Integer Label)      -- The branches
+    deriving (Show, Eq)
+
+-- | The smart constructor mkSwitchTargets normalises the map a bit:
+--  * No entries outside the range
+--  * No entries equal to the default
+--  * No default if all elements have explicit values
+mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets
+mkSwitchTargets signed range@(lo,hi) mbdef ids
+    = SwitchTargets signed range mbdef' ids'
+  where
+    ids' = dropDefault $ restrict ids
+    mbdef' | defaultNeeded = mbdef
+           | otherwise     = Nothing
+
+    -- Drop entries outside the range, if there is a range
+    restrict = restrictMap (lo,hi)
+
+    -- Drop entries that equal the default, if there is a default
+    dropDefault | Just l <- mbdef = M.filter (/= l)
+                | otherwise       = id
+
+    -- Check if the default is still needed
+    defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1
+
+
+-- | Changes all labels mentioned in the SwitchTargets value
+mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
+mapSwitchTargets f (SwitchTargets signed range mbdef branches)
+    = SwitchTargets signed range (fmap f mbdef) (fmap f branches)
+
+-- | Returns the list of non-default branches of the SwitchTargets value
+switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
+switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches
+
+-- | Return the default label of the SwitchTargets value
+switchTargetsDefault :: SwitchTargets -> Maybe Label
+switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef
+
+-- | Return the range of the SwitchTargets value
+switchTargetsRange :: SwitchTargets -> (Integer, Integer)
+switchTargetsRange (SwitchTargets _ range _ _) = range
+
+-- | Return whether this is used for a signed value
+switchTargetsSigned :: SwitchTargets -> Bool
+switchTargetsSigned (SwitchTargets signed _ _ _) = signed
+
+-- | switchTargetsToTable creates a dense jump table, usable for code generation.
+--
+-- Also returns an offset to add to the value; the list is 0-based on the
+-- result of that addition.
+--
+-- The conversion from Integer to Int is a bit of a wart, as the actual
+-- scrutinee might be an unsigned word, but it just works, due to wrap-around
+-- arithmetic (as verified by the CmmSwitchTest test case).
+switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label])
+switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches)
+    = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ])
+  where
+    labelFor i = case M.lookup i branches of Just l -> Just l
+                                             Nothing -> mbdef
+    start | lo >= 0 && lo < minJumpTableOffset  = 0  -- See Note [Jump Table Offset]
+          | otherwise                           = lo
+
+-- Note [Jump Table Offset]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Usually, the code for a jump table starting at x will first subtract x from
+-- the value, to avoid a large amount of empty entries. But if x is very small,
+-- the extra entries are no worse than the subtraction in terms of code size, and
+-- not having to do the subtraction is quicker.
+--
+-- I.e. instead of
+--     _u20N:
+--             leaq -1(%r14),%rax
+--             jmp *_n20R(,%rax,8)
+--     _n20R:
+--             .quad   _c20p
+--             .quad   _c20q
+-- do
+--     _u20N:
+--             jmp *_n20Q(,%r14,8)
+--
+--     _n20Q:
+--             .quad   0
+--             .quad   _c20p
+--             .quad   _c20q
+--             .quad   _c20r
+
+-- | The list of all labels occuring in the SwitchTargets value.
+switchTargetsToList :: SwitchTargets -> [Label]
+switchTargetsToList (SwitchTargets _ _ mbdef branches)
+    = maybeToList mbdef ++ M.elems branches
+
+-- | Groups cases with equal targets, suitable for pretty-printing to a
+-- c-like switch statement with fall-through semantics.
+switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
+switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
+  where
+    groups = map (\xs -> (map fst xs, snd (head xs))) $
+             groupBy ((==) `on` snd) $
+             M.toList branches
+
+-- | Custom equality helper, needed for "CmmCommonBlockElim"
+eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool
+eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) =
+    signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)
+  where
+    goMB Nothing Nothing = True
+    goMB (Just l1) (Just l2) = l1 `eq` l2
+    goMB _ _ = False
+    goList [] [] = True
+    goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2
+    goList _ _ = False
+
+-----------------------------------------------------------------------------
+-- Code generation for Switches
+
+
+-- | A SwitchPlan abstractly describes how a Switch statement ought to be
+-- implemented. See Note [createSwitchPlan]
+data SwitchPlan
+    = Unconditionally Label
+    | IfEqual Integer Label SwitchPlan
+    | IfLT Bool Integer SwitchPlan SwitchPlan
+    | JumpTable SwitchTargets
+  deriving Show
+--
+-- Note [createSwitchPlan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A SwitchPlan describes how a Switch statement is to be broken down into
+-- smaller pieces suitable for code generation.
+--
+-- createSwitchPlan creates such a switch plan, in these steps:
+--  1. It splits the switch statement at segments of non-default values that
+--     are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch]
+--  2. Too small jump tables should be avoided, so we break up smaller pieces
+--     in breakTooSmall.
+--  3. We fill in the segments between those pieces with a jump to the default
+--     label (if there is one), returning a SeparatedList in mkFlatSwitchPlan
+--  4. We find and replace two less-than branches by a single equal-to-test in
+--     findSingleValues
+--  5. The thus collected pieces are assembled to a balanced binary tree.
+
+{-
+  Note [Two alts + default]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Discussion and a bit more info at #14644
+
+When dealing with a switch of the form:
+switch(e) {
+  case 1: goto l1;
+  case 3000: goto l2;
+  default: goto ldef;
+}
+
+If we treat it as a sparse jump table we would generate:
+
+if (e > 3000) //Check if value is outside of the jump table.
+    goto ldef;
+else {
+    if (e < 3000) { //Compare to upper value
+        if(e != 1) //Compare to remaining value
+            goto ldef;
+          else
+            goto l2;
+    }
+    else
+        goto l1;
+}
+
+Instead we special case this to :
+
+if (e==1) goto l1;
+else if (e==3000) goto l2;
+else goto l3;
+
+This means we have:
+* Less comparisons for: 1,<3000
+* Unchanged for 3000
+* One more for >3000
+
+This improves code in a few ways:
+* One comparison less means smaller code which helps with cache.
+* It exchanges a taken jump for two jumps no taken in the >range case.
+  Jumps not taken are cheaper (See Agner guides) making this about as fast.
+* For all other cases the first range check is removed making it faster.
+
+The end result is that the change is not measurably slower for the case
+>3000 and faster for the other cases.
+
+This makes running this kind of match in an inner loop cheaper by 10-20%
+depending on the data.
+In nofib this improves wheel-sieve1 by 4-9% depending on problem
+size.
+
+We could also add a second conditional jump after the comparison to
+keep the range check like this:
+    cmp 3000, rArgument
+    jg <default>
+    je <branch 2>
+While this is fairly cheap it made no big difference for the >3000 case
+and slowed down all other cases making it not worthwhile.
+-}
+
+
+-- | Does the target support switch out of the box? Then leave this to the
+-- target!
+targetSupportsSwitch :: HscTarget -> Bool
+targetSupportsSwitch HscC = True
+targetSupportsSwitch HscLlvm = True
+targetSupportsSwitch _ = False
+
+-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it
+-- down into smaller pieces suitable for code generation.
+createSwitchPlan :: SwitchTargets -> SwitchPlan
+-- Lets do the common case of a singleton map quicky and efficiently (#10677)
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+    | [(x, l)] <- M.toList m
+    = IfEqual x l (Unconditionally defLabel)
+-- And another common case, matching "booleans"
+createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)
+    | [(x1, l1), (_x2,l2)] <- M.toAscList m
+    --Checking If |range| = 2 is enough if we have two unique literals
+    , hi - lo == 1
+    = IfEqual x1 l1 (Unconditionally l2)
+-- See Note [Two alts + default]
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+    | [(x1, l1), (x2,l2)] <- M.toAscList m
+    = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))
+createSwitchPlan (SwitchTargets signed range mbdef m) =
+    -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $
+    plan
+  where
+    pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m
+    flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces
+    plan = buildTree signed $ flatPlan
+
+
+---
+--- Step 1: Splitting at large holes
+---
+splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]
+splitAtHoles _        m | M.null m = []
+splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles
+  where
+    holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))
+    nonHoles = reassocTuples lo holes hi
+
+    (lo,_) = M.findMin m
+    (hi,_) = M.findMax m
+
+---
+--- Step 2: Avoid small jump tables
+---
+-- We do not want jump tables below a certain size. This breaks them up
+-- (into singleton maps, for now).
+breakTooSmall :: M.Map Integer a -> [M.Map Integer a]
+breakTooSmall m
+  | M.size m > minJumpTableSize = [m]
+  | otherwise                   = [M.singleton k v | (k,v) <- M.toList m]
+
+---
+---  Step 3: Fill in the blanks
+---
+
+-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every
+-- two entries, dividing the range.
+-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if
+-- the expression is < n, and plan2 otherwise.
+
+type FlatSwitchPlan = SeparatedList Integer SwitchPlan
+
+mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan
+
+-- If we have no default (i.e. undefined where there is no entry), we can
+-- branch at the minimum of each map
+mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty
+mkFlatSwitchPlan signed  Nothing _ (m:ms)
+  = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ])
+
+-- If we have a default, we have to interleave segments that jump
+-- to the default between the maps
+mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps)
+  where
+    go (lo,hi) []
+        | lo > hi = []
+        | otherwise = [(lo, Unconditionally l)]
+    go (lo,hi) (m:ms)
+        | lo < min
+        = (lo, Unconditionally l) : go (min,hi) (m:ms)
+        | lo == min
+        = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms
+        | otherwise
+        = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min)
+      where
+        min = fst (M.findMin m)
+        max = fst (M.findMax m)
+
+
+mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan
+mkLeafPlan signed mbdef m
+    | [(_,l)] <- M.toList m -- singleton map
+    = Unconditionally l
+    | otherwise
+    = JumpTable $ mkSwitchTargets signed (min,max) mbdef m
+  where
+    min = fst (M.findMin m)
+    max = fst (M.findMax m)
+
+---
+---  Step 4: Reduce the number of branches using ==
+---
+
+-- A sequence of three unconditional jumps, with the outer two pointing to the
+-- same value and the bounds off by exactly one can be improved
+findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan
+findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs)
+  | l == l3 && i + 1 == i'
+  = findSingleValues (IfEqual i l2 (Unconditionally l), xs)
+findSingleValues (p, (i,p'):xs)
+  = (p,i) `consSL` findSingleValues (p', xs)
+findSingleValues (p, [])
+  = (p, [])
+
+---
+---  Step 5: Actually build the tree
+---
+
+-- Build a balanced tree from a separated list
+buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan
+buildTree _ (p,[]) = p
+buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2)
+  where
+    (sl1, m, sl2) = divideSL sl
+
+
+
+--
+-- Utility data type: Non-empty lists with extra markers in between each
+-- element:
+--
+
+type SeparatedList b a = (a, [(b,a)])
+
+consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a
+consSL (a, b) (a', xs) = (a, (b,a'):xs)
+
+divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a)
+divideSL (_,[]) = error "divideSL: Singleton SeparatedList"
+divideSL (p,xs) = ((p, xs1), m, (p', xs2))
+  where
+    (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs
+
+--
+-- Other Utilities
+--
+
+restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b
+restrictMap (lo,hi) m = mid
+  where (_,   mid_hi) = M.split (lo-1) m
+        (mid, _) =      M.split (hi+1) mid_hi
+
+-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)]
+reassocTuples :: a -> [(a,a)] -> a -> [(a,a)]
+reassocTuples initial [] last
+    = [(initial,last)]
+reassocTuples initial ((a,b):tuples) last
+    = (initial,a) : reassocTuples b tuples last
+
+-- Note [CmmSwitch vs. CmmImplementSwitchPlans]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- I (Joachim) separated the two somewhat closely related modules
+--
+--  - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy
+--    for implementing a Cmm switch (createSwitchPlan), and
+--  - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification,
+--
+-- for these reasons:
+--
+--  * CmmSwitch is very low in the dependency tree, i.e. does not depend on any
+--    GHC specific modules at all (with the exception of Output and Hoople
+--    (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very
+--    high in the dependency tree.
+--  * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but
+--    used in CmmNodes.
+--  * Because CmmSwitch is low in the dependency tree, the separation allows
+--    for more parallelism when building GHC.
+--  * The interaction between the modules is very explicit and easy to
+--    understand, due to the small and simple interface.
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmUtils.hs
@@ -0,0 +1,592 @@
+{-# LANGUAGE GADTs, RankNTypes #-}
+
+-----------------------------------------------------------------------------
+--
+-- Cmm utilities.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module CmmUtils(
+        -- CmmType
+        primRepCmmType, slotCmmType, slotForeignHint,
+        typeCmmType, typeForeignHint, primRepForeignHint,
+
+        -- CmmLit
+        zeroCLit, mkIntCLit,
+        mkWordCLit, packHalfWordsCLit,
+        mkByteStringCLit,
+        mkDataLits, mkRODataLits,
+        mkStgWordCLit,
+
+        -- CmmExpr
+        mkIntExpr, zeroExpr,
+        mkLblExpr,
+        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,
+        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
+        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
+        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
+        cmmNegate,
+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
+        cmmSLtWord,
+        cmmNeWord, cmmEqWord,
+        cmmOrWord, cmmAndWord,
+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
+        cmmToWord,
+
+        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
+
+        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
+        currentTSOExpr, currentNurseryExpr, cccsExpr,
+
+        -- Statics
+        blankWord,
+
+        -- Tagging
+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
+        cmmConstrTag1,
+
+        -- Overlap and usage
+        regsOverlap, regUsedIn,
+
+        -- Liveness and bitmaps
+        mkLiveness,
+
+        -- * Operations that probably don't belong here
+        modifyGraph,
+
+        ofBlockMap, toBlockMap,
+        ofBlockList, toBlockList, bodyToBlockList,
+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
+        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
+
+        -- * Ticks
+        blockTicks
+  ) where
+
+import GhcPrelude
+
+import TyCon    ( PrimRep(..), PrimElemRep(..) )
+import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
+
+import SMRep
+import Cmm
+import BlockId
+import CLabel
+import Outputable
+import DynFlags
+import CodeGen.Platform
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Bits
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+---------------------------------------------------
+--
+--      CmmTypes
+--
+---------------------------------------------------
+
+primRepCmmType :: DynFlags -> PrimRep -> CmmType
+primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
+primRepCmmType dflags LiftedRep        = gcWord dflags
+primRepCmmType dflags UnliftedRep      = gcWord dflags
+primRepCmmType dflags IntRep           = bWord dflags
+primRepCmmType dflags WordRep          = bWord dflags
+primRepCmmType _      Int8Rep          = b8
+primRepCmmType _      Word8Rep         = b8
+primRepCmmType _      Int16Rep         = b16
+primRepCmmType _      Word16Rep        = b16
+primRepCmmType _      Int64Rep         = b64
+primRepCmmType _      Word64Rep        = b64
+primRepCmmType dflags AddrRep          = bWord dflags
+primRepCmmType _      FloatRep         = f32
+primRepCmmType _      DoubleRep        = f64
+primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)
+
+slotCmmType :: DynFlags -> SlotTy -> CmmType
+slotCmmType dflags PtrSlot    = gcWord dflags
+slotCmmType dflags WordSlot   = bWord dflags
+slotCmmType _      Word64Slot = b64
+slotCmmType _      FloatSlot  = f32
+slotCmmType _      DoubleSlot = f64
+
+primElemRepCmmType :: PrimElemRep -> CmmType
+primElemRepCmmType Int8ElemRep   = b8
+primElemRepCmmType Int16ElemRep  = b16
+primElemRepCmmType Int32ElemRep  = b32
+primElemRepCmmType Int64ElemRep  = b64
+primElemRepCmmType Word8ElemRep  = b8
+primElemRepCmmType Word16ElemRep = b16
+primElemRepCmmType Word32ElemRep = b32
+primElemRepCmmType Word64ElemRep = b64
+primElemRepCmmType FloatElemRep  = f32
+primElemRepCmmType DoubleElemRep = f64
+
+typeCmmType :: DynFlags -> UnaryType -> CmmType
+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
+
+primRepForeignHint :: PrimRep -> ForeignHint
+primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
+primRepForeignHint LiftedRep    = AddrHint
+primRepForeignHint UnliftedRep  = AddrHint
+primRepForeignHint IntRep       = SignedHint
+primRepForeignHint Int8Rep      = SignedHint
+primRepForeignHint Int16Rep     = SignedHint
+primRepForeignHint Int64Rep     = SignedHint
+primRepForeignHint WordRep      = NoHint
+primRepForeignHint Word8Rep     = NoHint
+primRepForeignHint Word16Rep    = NoHint
+primRepForeignHint Word64Rep    = NoHint
+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
+primRepForeignHint FloatRep     = NoHint
+primRepForeignHint DoubleRep    = NoHint
+primRepForeignHint (VecRep {})  = NoHint
+
+slotForeignHint :: SlotTy -> ForeignHint
+slotForeignHint PtrSlot       = AddrHint
+slotForeignHint WordSlot      = NoHint
+slotForeignHint Word64Slot    = NoHint
+slotForeignHint FloatSlot     = NoHint
+slotForeignHint DoubleSlot    = NoHint
+
+typeForeignHint :: UnaryType -> ForeignHint
+typeForeignHint = primRepForeignHint . typePrimRep1
+
+---------------------------------------------------
+--
+--      CmmLit
+--
+---------------------------------------------------
+
+-- XXX: should really be Integer, since Int doesn't necessarily cover
+-- the full range of target Ints.
+mkIntCLit :: DynFlags -> Int -> CmmLit
+mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
+
+mkIntExpr :: DynFlags -> Int -> CmmExpr
+mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
+
+zeroCLit :: DynFlags -> CmmLit
+zeroCLit dflags = CmmInt 0 (wordWidth dflags)
+
+zeroExpr :: DynFlags -> CmmExpr
+zeroExpr dflags = CmmLit (zeroCLit dflags)
+
+mkWordCLit :: DynFlags -> Integer -> CmmLit
+mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
+
+mkByteStringCLit
+  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
+-- We have to make a top-level decl for the string,
+-- and return a literal pointing to it
+mkByteStringCLit lbl bytes
+  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
+  where
+    -- This can not happen for String literals (as there \NUL is replaced by
+    -- C0 80). However, it can happen with Addr# literals.
+    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
+
+mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+-- Build a data-segment data block
+mkDataLits section lbl lits
+  = CmmData section (Statics lbl $ map CmmStaticLit lits)
+
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+-- Build a read-only data block
+mkRODataLits lbl lits
+  = mkDataLits section lbl lits
+  where
+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
+            | otherwise                = Section ReadOnlyData lbl
+    needsRelocation (CmmLabel _)      = True
+    needsRelocation (CmmLabelOff _ _) = True
+    needsRelocation _                 = False
+
+mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
+mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
+
+packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
+-- Make a single word literal in which the lower_half_word is
+-- at the lower address, and the upper_half_word is at the
+-- higher address
+-- ToDo: consider using half-word lits instead
+--       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))
+    where l = fromStgHalfWord lower_half_word
+          u = fromStgHalfWord upper_half_word
+
+---------------------------------------------------
+--
+--      CmmExpr
+--
+---------------------------------------------------
+
+mkLblExpr :: CLabel -> CmmExpr
+mkLblExpr lbl = CmmLit (CmmLabel lbl)
+
+cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+-- assumes base and offset have the same CmmType
+cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
+cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
+
+cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
+cmmOffset _ e                 0        = e
+cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off
+cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
+cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)
+cmmOffset _ (CmmStackSlot area off) byte_off
+  = CmmStackSlot area (off - byte_off)
+  -- note stack area offsets increase towards lower addresses
+cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
+  = CmmMachOp (MO_Add rep)
+              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
+cmmOffset dflags expr byte_off
+  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
+  where
+    width = cmmExprWidth dflags expr
+
+-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
+cmmRegOff :: CmmReg -> Int -> CmmExpr
+cmmRegOff reg 0        = CmmReg reg
+cmmRegOff reg byte_off = CmmRegOff reg byte_off
+
+cmmOffsetLit :: CmmLit -> Int -> CmmLit
+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
+cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w
+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
+
+cmmLabelOff :: CLabel -> Int -> CmmLit
+-- Smart constructor for CmmLabelOff
+cmmLabelOff lbl 0        = CmmLabel lbl
+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
+
+-- | Useful for creating an index into an array, with a statically known offset.
+-- The type is the element type; used for making the multiplier
+cmmIndex :: DynFlags
+         -> Width       -- Width w
+         -> CmmExpr     -- Address of vector of items of width w
+         -> Int         -- Which element of the vector (0 based)
+         -> CmmExpr     -- Address of i'th element
+cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
+
+-- | Useful for creating an index into an array, with an unknown offset.
+cmmIndexExpr :: DynFlags
+             -> Width           -- Width w
+             -> CmmExpr         -- Address of vector of items of width w
+             -> CmmExpr         -- Which element of the vector (0 based)
+             -> CmmExpr         -- Address of i'th element
+cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
+cmmIndexExpr dflags width base idx =
+  cmmOffsetExpr dflags base byte_off
+  where
+    idx_w = cmmExprWidth dflags idx
+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
+
+cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
+
+-- The "B" variants take byte offsets
+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
+cmmRegOffB = cmmRegOff
+
+cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB = cmmOffset
+
+cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB = cmmOffsetExpr
+
+cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
+cmmLabelOffB = cmmLabelOff
+
+cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
+cmmOffsetLitB = cmmOffsetLit
+
+-----------------------
+-- The "W" variants take word offsets
+
+cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+-- The second arg is a *word* offset; need to change it to bytes
+cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
+cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
+
+cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
+
+cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
+cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
+
+cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
+
+cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
+cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
+
+cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
+
+-----------------------
+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
+  cmmSLtWord,
+  cmmNeWord, cmmEqWord,
+  cmmOrWord, cmmAndWord,
+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
+  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]
+cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
+cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]
+cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]
+cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
+cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
+cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
+cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
+cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
+cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
+cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
+cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
+cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
+
+cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
+cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
+cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
+
+blankWord :: DynFlags -> CmmStatic
+blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
+
+cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
+cmmToWord dflags e
+  | w == word  = e
+  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]
+  where
+    w = cmmExprWidth dflags e
+    word = wordWidth dflags
+
+---------------------------------------------------
+--
+--      CmmExpr predicates
+--
+---------------------------------------------------
+
+isTrivialCmmExpr :: CmmExpr -> Bool
+isTrivialCmmExpr (CmmLoad _ _)      = False
+isTrivialCmmExpr (CmmMachOp _ _)    = False
+isTrivialCmmExpr (CmmLit _)         = True
+isTrivialCmmExpr (CmmReg _)         = True
+isTrivialCmmExpr (CmmRegOff _ _)    = True
+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
+
+hasNoGlobalRegs :: CmmExpr -> Bool
+hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
+hasNoGlobalRegs (CmmLit _)                 = True
+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
+hasNoGlobalRegs _ = False
+
+isLit :: CmmExpr -> Bool
+isLit (CmmLit _) = True
+isLit _          = False
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _                  = False
+
+---------------------------------------------------
+--
+--      Tagging
+--
+---------------------------------------------------
+
+-- Tag bits mask
+cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
+cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
+cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
+
+-- Used to untag a possibly tagged pointer
+-- A static label need not be untagged
+cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
+cmmUntag _ e@(CmmLit (CmmLabel _)) = e
+-- Default case
+cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
+
+-- Test if a closure pointer is untagged
+cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
+
+-- Get constructor tag, but one based.
+cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
+
+
+-----------------------------------------------------------------------------
+-- Overlap and usage
+
+-- | Returns True if the two STG registers overlap on the specified
+-- platform, in the sense that writing to one will clobber the
+-- other. This includes the case that the two registers are the same
+-- STG register. See Note [Overlapping global registers] for details.
+regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
+regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
+  | Just real  <- globalRegMaybe (targetPlatform dflags) g,
+    Just real' <- globalRegMaybe (targetPlatform dflags) g',
+    real == real'
+    = True
+regsOverlap _ reg reg' = reg == reg'
+
+-- | Returns True if the STG register is used by the expression, in
+-- the sense that a store to the register might affect the value of
+-- the expression.
+--
+-- We must check for overlapping registers and not just equal
+-- registers here, otherwise CmmSink may incorrectly reorder
+-- assignments that conflict due to overlap. See #10521 and Note
+-- [Overlapping global registers].
+regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
+regUsedIn dflags = regUsedIn_ where
+  _   `regUsedIn_` CmmLit _         = False
+  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e
+  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'
+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es
+  _   `regUsedIn_` CmmStackSlot _ _ = False
+
+--------------------------------------------
+--
+--        mkLiveness
+--
+---------------------------------------------
+
+mkLiveness :: DynFlags -> [LocalReg] -> Liveness
+mkLiveness _      [] = []
+mkLiveness dflags (reg:regs)
+  = bits ++ mkLiveness dflags regs
+  where
+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
+            `quot` wORD_SIZE dflags
+            -- number of words, rounded up
+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
+
+    is_non_ptr = not $ isGcPtrType (localRegType reg)
+
+
+-- ============================================== -
+-- ============================================== -
+-- ============================================== -
+
+---------------------------------------------------
+--
+--      Manipulating CmmGraphs
+--
+---------------------------------------------------
+
+modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+
+ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
+
+toBlockList :: CmmGraph -> [CmmBlock]
+toBlockList g = mapElems $ toBlockMap g
+
+-- | like 'toBlockList', but the entry block always comes first
+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirst g
+  | mapNull m  = []
+  | otherwise  = entry_block : others
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+    others = filter ((/= entry_id) . entryLabel) (mapElems m)
+
+-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
+-- so that the false case of a conditional jumps to the next block in the output
+-- list of blocks. This matches the way OldCmm blocks were output since in
+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
+-- have both true and false successors. Block ordering can make a big difference
+-- in performance in the LLVM backend. Note that we rely crucially on the order
+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
+-- defined in cmm/CmmNode.hs. -GBM
+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirstFalseFallthrough g
+  | mapNull m  = []
+  | otherwise  = dfs setEmpty [entry_block]
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+
+    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
+    dfs _ [] = []
+    dfs visited (block:bs)
+      | id `setMember` visited = dfs visited bs
+      | otherwise              = block : dfs (setInsert id visited) bs'
+      where id = entryLabel block
+            bs' = foldr add_id bs (successors block)
+            add_id id bs = case mapLookup id m of
+                              Just b  -> b : bs
+                              Nothing -> bs
+
+ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
+ofBlockList entry blocks = CmmGraph { g_entry = entry
+                                    , g_graph = GMany NothingO body NothingO }
+  where body = foldr addBlock emptyBody blocks
+
+bodyToBlockList :: Body CmmNode -> [CmmBlock]
+bodyToBlockList body = mapElems body
+
+mapGraphNodes :: ( CmmNode C O -> CmmNode C O
+                 , CmmNode O O -> CmmNode O O
+                 , CmmNode O C -> CmmNode O C)
+              -> CmmGraph -> CmmGraph
+mapGraphNodes funs@(mf,_,_) g =
+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
+  mapMap (mapBlock3' funs) $ toBlockMap g
+
+mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
+mapGraphNodes1 f = modifyGraph (mapGraph f)
+
+
+foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
+
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+    revPostorderFrom (toBlockMap g) (g_entry g)
+
+-------------------------------------------------
+-- Tick utilities
+
+-- | Extract all tick annotations from the given block
+blockTicks :: Block CmmNode C C -> [CmmTickish]
+blockTicks b = reverse $ foldBlockNodesF goStmt b []
+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
+        goStmt  (CmmTick t) ts = t:ts
+        goStmt  _other      ts = ts
+
+
+-- -----------------------------------------------------------------------------
+-- Access to common global registers
+
+baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
+  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
+baseExpr = CmmReg baseReg
+spExpr = CmmReg spReg
+spLimExpr = CmmReg spLimReg
+hpExpr = CmmReg hpReg
+hpLimExpr = CmmReg hpLimReg
+currentTSOExpr = CmmReg currentTSOReg
+currentNurseryExpr = CmmReg currentNurseryReg
+cccsExpr = CmmReg cccsReg
diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Debug.hs
@@ -0,0 +1,550 @@
+{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Debugging data
+--
+-- Association of debug data on the Cmm level, with methods to encode it in
+-- event log format for later inclusion in profiling event logs.
+--
+-----------------------------------------------------------------------------
+
+module Debug (
+
+  DebugBlock(..), dblIsEntry,
+  cmmDebugGen,
+  cmmDebugLabels,
+  cmmDebugLink,
+  debugToMap,
+
+  -- * Unwinding information
+  UnwindTable, UnwindPoint(..),
+  UnwindExpr(..), toUnwindExpr
+  ) where
+
+import GhcPrelude
+
+import BlockId
+import CLabel
+import Cmm
+import CmmUtils
+import CoreSyn
+import FastString      ( nilFS, mkFastString )
+import Module
+import Outputable
+import PprCore         ()
+import PprCmmExpr      ( pprExpr )
+import SrcLoc
+import Util            ( seqList )
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+
+import Data.Maybe
+import Data.List     ( minimumBy, nubBy )
+import Data.Ord      ( comparing )
+import qualified Data.Map as Map
+import Data.Either   ( partitionEithers )
+
+-- | Debug information about a block of code. Ticks scope over nested
+-- blocks.
+data DebugBlock =
+  DebugBlock
+  { dblProcedure  :: !Label        -- ^ Entry label of containing proc
+  , dblLabel      :: !Label        -- ^ Hoopl label
+  , dblCLabel     :: !CLabel       -- ^ Output label
+  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?
+  , 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
+  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
+                                   -- other blocks. @Nothing@ means
+                                   -- the block was optimized out
+  , dblUnwind     :: [UnwindPoint]
+  , 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 (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))
+
+-- | Intermediate data structure holding debug-relevant context information
+-- about a block.
+type BlockContext = (CmmBlock, RawCmmDecl)
+
+-- | Extract debug data from a group of procedures. We will prefer
+-- source notes that come from the given module (presumably the module
+-- that we are currently compiling).
+cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
+cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
+  where
+      blockCtxs :: Map.Map CmmTickScope [BlockContext]
+      blockCtxs = blockContexts decls
+
+      -- Analyse tick scope structure: Each one is either a top-level
+      -- tick scope, or the child of another.
+      (topScopes, childScopes)
+        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
+      findP tsc GlobalScope = Left tsc -- top scope
+      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
+                    | otherwise                   = findP tsc scp'
+        where -- Note that we only following the left parent of
+              -- combined scopes. This loses us ticks, which we will
+              -- recover by copying ticks below.
+              scp' | SubScope _ scp' <- scp      = scp'
+                   | CombinedScope scp' _ <- scp = scp'
+                   | otherwise                   = panic "findP impossible"
+
+      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes
+
+      -- This allows us to recover ticks that we lost by flattening
+      -- the graph. Basically, if the parent is A but the child is
+      -- CBA, we know that there is no BA, because it would have taken
+      -- priority - but there might be a B scope, with ticks that
+      -- would not be associated with our child anymore. Note however
+      -- that there might be other childs (DB), which we have to
+      -- filter out.
+      --
+      -- We expect this to be called rarely, which is why we are not
+      -- trying too hard to be efficient here. In many cases we won't
+      -- have to construct blockCtxsU in the first place.
+      ticksToCopy :: CmmTickScope -> [CmmTickish]
+      ticksToCopy (CombinedScope scp s) = go s
+        where go s | scp `isTickSubScope` s   = [] -- done
+                   | SubScope _ s' <- s       = ticks ++ go s'
+                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
+                   | otherwise                = panic "ticksToCopy impossible"
+                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
+      ticksToCopy _ = []
+      bCtxsTicks = concatMap (blockTicks . fst)
+
+      -- Finding the "best" source tick is somewhat arbitrary -- we
+      -- select the first source span, while preferring source ticks
+      -- from the same source file.  Furthermore, dumps take priority
+      -- (if we generated one, we probably want debug information to
+      -- refer to it).
+      bestSrcTick = minimumBy (comparing rangeRating)
+      rangeRating (SourceNote span _)
+        | srcSpanFile span == thisFile = 1
+        | otherwise                    = 2 :: Int
+      rangeRating note                 = pprPanic "rangeRating" (ppr note)
+      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+
+      -- Returns block tree for this scope as well as all nested
+      -- scopes. Note that if there are multiple blocks in the (exact)
+      -- same scope we elect one as the "branch" node and add the rest
+      -- as children.
+      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
+      blocksForScope cstick scope = mkBlock True (head bctxs)
+        where bctxs = fromJust $ Map.lookup scope blockCtxs
+              nested = fromMaybe [] $ Map.lookup scope scopeMap
+              childs = map (mkBlock False) (tail bctxs) ++
+                       map (blocksForScope stick) nested
+
+              mkBlock :: Bool -> BlockContext -> DebugBlock
+              mkBlock top (block, prc)
+                = DebugBlock { dblProcedure    = g_entry graph
+                             , dblLabel        = label
+                             , dblCLabel       = case info of
+                                 Just (Statics infoLbl _)   -> infoLbl
+                                 Nothing
+                                   | g_entry graph == label -> entryLbl
+                                   | otherwise              -> blockLbl label
+                             , dblHasInfoTbl   = isJust info
+                             , dblParent       = Nothing
+                             , dblTicks        = ticks
+                             , dblPosition     = Nothing -- see cmmDebugLink
+                             , dblSourceTick   = stick
+                             , dblBlocks       = blocks
+                             , dblUnwind       = []
+                             }
+                where (CmmProc infos entryLbl _ graph) = prc
+                      label = entryLabel block
+                      info = mapLookup label infos
+                      blocks | top       = seqList childs childs
+                             | otherwise = []
+
+              -- A source tick scopes over all nested blocks. However
+              -- their source ticks might take priority.
+              isSourceTick SourceNote {} = True
+              isSourceTick _             = False
+              -- Collect ticks from all blocks inside the tick scope.
+              -- We attempt to filter out duplicates while we're at it.
+              ticks = nubBy (flip tickishContains) $
+                      bCtxsTicks bctxs ++ ticksToCopy scope
+              stick = case filter isSourceTick ticks of
+                []     -> cstick
+                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
+
+-- | Build a map of blocks sorted by their tick scopes
+--
+-- This involves a pre-order traversal, as we want blocks in rough
+-- control flow order (so ticks have a chance to be sorted in the
+-- right order).
+blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
+blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
+  where walkProc :: RawCmmDecl
+                 -> Map.Map CmmTickScope [BlockContext]
+                 -> Map.Map CmmTickScope [BlockContext]
+        walkProc CmmData{}                 m = m
+        walkProc prc@(CmmProc _ _ _ graph) m
+          | mapNull blocks = m
+          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)
+          where blocks = toBlockMap graph
+                entry  = [mapFind (g_entry graph) blocks]
+                emptyLbls = setEmpty :: LabelSet
+
+        walkBlock :: RawCmmDecl -> [Block CmmNode C C]
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+        walkBlock _   []             c            = c
+        walkBlock prc (block:blocks) (visited, m)
+          | lbl `setMember` visited
+          = walkBlock prc blocks (visited, m)
+          | otherwise
+          = walkBlock prc blocks $
+            walkBlock prc succs
+              (lbl `setInsert` visited,
+               insertMulti scope (block, prc) m)
+          where CmmEntry lbl scope = firstNode block
+                (CmmProc _ _ _ graph) = prc
+                succs = map (flip mapFind (toBlockMap graph))
+                            (successors (lastNode block))
+        mapFind = mapFindWithDefault (error "contextTree: block not found!")
+
+insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
+insertMulti k v = Map.insertWith (const (v:)) k [v]
+
+cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
+cmmDebugLabels isMeta nats = seqList lbls lbls
+  where -- Find order in which procedures will be generated by the
+        -- back-end (that actually matters for DWARF generation).
+        --
+        -- Note that we might encounter blocks that are missing or only
+        -- consist of meta instructions -- we will declare them missing,
+        -- which will skip debug data generation without messing up the
+        -- block hierarchy.
+        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
+        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
+        getBlocks _other                         = []
+        allMeta (BasicBlock _ instrs) = all isMeta instrs
+
+-- | Sets position and unwind table fields in the debug block tree according to
+-- native generated code.
+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
+             -> [DebugBlock] -> [DebugBlock]
+cmmDebugLink labels unwindPts blocks = map link blocks
+  where blockPos :: LabelMap Int
+        blockPos = mapFromList $ flip zip [0..] labels
+        link block = block { dblPosition = mapLookup (dblLabel block) blockPos
+                           , dblBlocks   = map link (dblBlocks block)
+                           , dblUnwind   = fromMaybe mempty
+                                         $ mapLookup (dblLabel block) unwindPts
+                           }
+
+-- | Converts debug blocks into a label map for easier lookups
+debugToMap :: [DebugBlock] -> LabelMap DebugBlock
+debugToMap = mapUnions . map go
+   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
+
+{-
+Note [What is this unwinding business?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwinding tables are a variety of debugging information used by debugging tools
+to reconstruct the execution history of a program at runtime. These tables
+consist of sets of "instructions", one set for every instruction in the program,
+which describe how to reconstruct the state of the machine at the point where
+the current procedure was called. For instance, consider the following annotated
+pseudo-code,
+
+  a_fun:
+    add rsp, 8            -- unwind: rsp = rsp - 8
+    mov rax, 1            -- unwind: rax = unknown
+    call another_block
+    sub rsp, 8            -- unwind: rsp = rsp
+
+We see that attached to each instruction there is an "unwind" annotation, which
+provides a relationship between each updated register and its value at the
+time of entry to a_fun. This is the sort of information that allows gdb to give
+you a stack backtrace given the execution state of your program. This
+unwinding information is captured in various ways by various debug information
+formats; in the case of DWARF (the only format supported by GHC) it is known as
+Call Frame Information (CFI) and can be found in the .debug.frames section of
+your object files.
+
+Currently we only bother to produce unwinding information for registers which
+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp
+(which is the STG stack pointer) and $rsp (the C stack pointer).
+
+Let's consider how GHC would annotate a C-- program with unwinding information
+with a typical C-- procedure as would come from the STG-to-Cmm code generator,
+
+  entry()
+     { c2fe:
+           v :: P64 = R2;
+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+       c2ff:
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+       c2fg:
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           Sp = Sp - 8;          // Sp updated here
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+       c2dE:
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+Let's consider how this procedure will be decorated with unwind information
+(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the
+value of Sp is no different from what it was at its call site. Therefore we will
+add an `unwind` statement saying this at the beginning of its unwind-annotated
+code,
+
+  entry()
+     { c2fe:
+           unwind Sp = Just Sp + 0;
+           v :: P64 = R2;
+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+
+After c2fe we may pass to either c2ff or c2fg; let's first consider the
+former. In this case there is nothing in particular that we need to do other
+than reiterate what we already know about Sp,
+
+       c2ff:
+           unwind Sp = Just Sp + 0;
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+
+In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
+can happen correctly after this point we must include an unwind statement there,
+in addition to the usual beginning-of-block statement,
+
+       c2fg:
+           unwind Sp = Just Sp + 0;
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           Sp = Sp - 8;
+           unwind Sp = Just Sp + 8;
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+
+The remaining blocks are simple,
+
+       c2dE:
+           unwind Sp = Just Sp + 8;
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           unwind Sp = Just Sp + 8;
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+
+The flow of unwinding information through the compiler is a bit convoluted:
+
+ * C-- begins life in StgCmm without any unwind information. This is because we
+   haven't actually done any register assignment or stack layout yet, so there
+   is no need for unwind information.
+
+ * CmmLayoutStack figures out how to layout each procedure's stack, and produces
+   appropriate unwinding nodes for each adjustment of the STG Sp register.
+
+ * The unwind nodes are carried through the sinking pass. Currently this is
+   guaranteed not to invalidate unwind information since it won't touch stores
+   to Sp, but this will need revisiting if CmmSink gets smarter in the future.
+
+ * Eventually we make it to the native code generator backend which can then
+   preserve the unwind nodes in its machine-specific instructions. In so doing
+   the backend can also modify or add unwinding information; this is necessary,
+   for instance, in the case of x86-64, where adjustment of $rsp may be
+   necessary during calls to native foreign code due to the native calling
+   convention.
+
+ * The NCG then retrieves the final unwinding table for each block from the
+   backend with extractUnwindPoints.
+
+ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
+
+ * These DebugBlocks are then converted to, e.g., DWARF unwinding tables
+   (by the Dwarf module) and emitted in the final object.
+
+See also:
+  Note [Unwinding information in the NCG] in AsmCodeGen,
+  Note [Unwind pseudo-instruction in Cmm],
+  Note [Debugging DWARF unwinding info].
+
+
+Note [Debugging DWARF unwinding info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For debugging generated unwinding info I've found it most useful to dump the
+disassembled binary with objdump -D and dump the debug info with
+readelf --debug-dump=frames-interp.
+
+You should get something like this:
+
+  0000000000000010 <stg_catch_frame_info>:
+    10:   48 83 c5 18             add    $0x18,%rbp
+    14:   ff 65 00                jmpq   *0x0(%rbp)
+
+and:
+
+  Contents of the .debug_frame section:
+
+  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16
+     LOC           CFA      rbp   rsp   ra
+  0000000000000000 rbp+0    v+0   s     c+0
+
+  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017
+     LOC           CFA      rbp   rsp   ra
+  000000000000000f rbp+0    v+0   s     c+0
+  000000000000000f rbp+24   v+0   s     c+0
+
+To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in
+Appendix 5 (page 101 of the pdf) and more details in the relevant section.
+
+The key thing to keep in mind is that the value at LOC is the value from
+*before* the instruction at LOC executes. In other words it answers the
+question: if my $rip is at LOC, how do I get the relevant values given the
+values obtained through unwinding so far.
+
+If the readelf --debug-dump=frames-interp output looks wrong, it may also be
+useful to look at readelf --debug-dump=frames, which is closer to the
+information that GHC generated.
+
+It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm
+-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]
+explains how to interpret it.
+
+Inside gdb there are a couple useful commands for inspecting frames.
+For example:
+
+  gdb> info frame <num>
+
+It shows the values of registers obtained through unwinding.
+
+Another useful thing to try when debugging the DWARF unwinding is to enable
+extra debugging output in GDB:
+
+  gdb> set debug frame 1
+
+This makes GDB produce a trace of its internal workings. Having gone this far,
+it's just a tiny step to run GDB in GDB. Make sure you install debugging
+symbols for gdb if you obtain it through a package manager.
+
+Keep in mind that the current release of GDB has an instruction pointer handling
+heuristic that works well for C-like languages, but doesn't always work for
+Haskell. See Note [Info Offset] in Dwarf.Types for more details.
+
+Note [Unwind pseudo-instruction in Cmm]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't
+generate any assembly, but controls what DWARF unwinding information gets
+generated.
+
+It's important to understand what ranges of code the unwind pseudo-instruction
+refers to.
+For a sequence of CmmNodes like:
+
+  A // starts at addr X and ends at addr Y-1
+  unwind Sp = Just Sp + 16;
+  B // starts at addr Y and ends at addr Z
+
+the unwind statement reflects the state after A has executed, but before B
+has executed. If you consult the Note [Debugging DWARF unwinding info], the
+LOC this information will end up in is Y.
+-}
+
+-- | A label associated with an 'UnwindTable'
+data UnwindPoint = UnwindPoint !CLabel !UnwindTable
+
+instance Outputable UnwindPoint where
+  ppr (UnwindPoint lbl uws) =
+      braces $ ppr lbl<>colon
+      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
+    where
+      pprUw (g, expr) = ppr g <> char '=' <> ppr expr
+
+-- | Maps registers to expressions that yield their "old" values
+-- further up the stack. Most interesting for the stack pointer @Sp@,
+-- but might be useful to document saved registers, too. Note that a
+-- register's value will be 'Nothing' when the register's previous
+-- value cannot be reconstructed.
+type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)
+
+-- | Expressions, used for unwind information
+data UnwindExpr = UwConst !Int                  -- ^ literal value
+                | UwReg !GlobalReg !Int         -- ^ register plus offset
+                | UwDeref UnwindExpr            -- ^ pointer dereferencing
+                | UwLabel CLabel
+                | UwPlus UnwindExpr UnwindExpr
+                | UwMinus UnwindExpr UnwindExpr
+                | UwTimes UnwindExpr UnwindExpr
+                deriving (Eq)
+
+instance Outputable UnwindExpr where
+  pprPrec _ (UwConst i)     = ppr i
+  pprPrec _ (UwReg g 0)     = ppr g
+  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
+  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e
+  pprPrec _ (UwLabel l)     = pprPrec 3 l
+  pprPrec p (UwPlus e0 e1)  | p <= 0
+                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
+  pprPrec p (UwMinus e0 e1) | p <= 0
+                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
+  pprPrec p (UwTimes e0 e1) | p <= 1
+                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
+  pprPrec _ other           = parens (pprPrec 0 other)
+
+-- | Conversion of Cmm expressions to unwind expressions. We check for
+-- unsupported operator usages and simplify the expression as far as
+-- possible.
+toUnwindExpr :: CmmExpr -> UnwindExpr
+toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)
+toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l
+toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
+toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0
+toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)
+toUnwindExpr e@(CmmMachOp op [e1, e2])   =
+  case (op, toUnwindExpr e1, toUnwindExpr e2) of
+    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
+    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
+    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
+    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)
+    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)
+    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)
+    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2
+    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2
+    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2
+    _otherwise -> pprPanic "Unsupported operator in unwind expression!"
+                           (pprExpr e)
+toUnwindExpr e
+  = pprPanic "Unsupported unwind expression!" (ppr e)
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -0,0 +1,328 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Block
+    ( C
+    , O
+    , MaybeO(..)
+    , IndexedCO
+    , Block(..)
+    , blockAppend
+    , blockCons
+    , blockFromList
+    , blockJoin
+    , blockJoinHead
+    , blockJoinTail
+    , blockSnoc
+    , blockSplit
+    , blockSplitHead
+    , blockSplitTail
+    , blockToList
+    , emptyBlock
+    , firstNode
+    , foldBlockNodesB
+    , foldBlockNodesB3
+    , foldBlockNodesF
+    , isEmptyBlock
+    , lastNode
+    , mapBlock
+    , mapBlock'
+    , mapBlock3'
+    , replaceFirstNode
+    , replaceLastNode
+    ) where
+
+import GhcPrelude
+
+-- -----------------------------------------------------------------------------
+-- Shapes: Open and Closed
+
+-- | Used at the type level to indicate an "open" structure with
+-- a unique, unnamed control-flow edge flowing in or out.
+-- "Fallthrough" and concatenation are permitted at an open point.
+data O
+
+-- | Used at the type level to indicate a "closed" structure which
+-- supports control transfer only through the use of named
+-- labels---no "fallthrough" is permitted.  The number of control-flow
+-- edges is unconstrained.
+data C
+
+-- | Either type indexed by closed/open using type families
+type family IndexedCO ex a b :: *
+type instance IndexedCO C a _b = a
+type instance IndexedCO O _a b = b
+
+-- | Maybe type indexed by open/closed
+data MaybeO ex t where
+  JustO    :: t -> MaybeO O t
+  NothingO ::      MaybeO C t
+
+-- | Maybe type indexed by closed/open
+data MaybeC ex t where
+  JustC    :: t -> MaybeC C t
+  NothingC ::      MaybeC O t
+
+
+instance Functor (MaybeO ex) where
+  fmap _ NothingO = NothingO
+  fmap f (JustO a) = JustO (f a)
+
+instance Functor (MaybeC ex) where
+  fmap _ NothingC = NothingC
+  fmap f (JustC a) = JustC (f a)
+
+-- -----------------------------------------------------------------------------
+-- The Block type
+
+-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).
+-- Open at the entry means single entry, mutatis mutandis for exit.
+-- A closed/closed block is a /basic/ block and can't be extended further.
+-- Clients should avoid manipulating blocks and should stick to either nodes
+-- or graphs.
+data Block n e x where
+  BlockCO  :: n C O -> Block n O O          -> Block n C O
+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C
+  BlockOC  ::          Block n O O -> n O C -> Block n O C
+
+  BNil    :: Block n O O
+  BMiddle :: n O O                      -> Block n O O
+  BCat    :: Block n O O -> Block n O O -> Block n O O
+  BSnoc   :: Block n O O -> n O O       -> Block n O O
+  BCons   :: n O O       -> Block n O O -> Block n O O
+
+
+-- -----------------------------------------------------------------------------
+-- Simple operations on Blocks
+
+-- Predicates
+
+isEmptyBlock :: Block n e x -> Bool
+isEmptyBlock BNil       = True
+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
+isEmptyBlock _          = False
+
+
+-- Building
+
+emptyBlock :: Block n O O
+emptyBlock = BNil
+
+blockCons :: n O O -> Block n O x -> Block n O x
+blockCons n b = case b of
+  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l
+  BNil{}    -> BMiddle n
+  BMiddle{} -> n `BCons` b
+  BCat{}    -> n `BCons` b
+  BSnoc{}   -> n `BCons` b
+  BCons{}   -> n `BCons` b
+
+blockSnoc :: Block n e O -> n O O -> Block n e O
+blockSnoc b n = case b of
+  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
+  BNil{}      -> BMiddle n
+  BMiddle{}   -> b `BSnoc` n
+  BCat{}      -> b `BSnoc` n
+  BSnoc{}     -> b `BSnoc` n
+  BCons{}     -> b `BSnoc` n
+
+blockJoinHead :: n C O -> Block n O x -> Block n C x
+blockJoinHead f (BlockOC b l) = BlockCC f b l
+blockJoinHead f b = BlockCO f BNil `cat` b
+
+blockJoinTail :: Block n e O -> n O C -> Block n e C
+blockJoinTail (BlockCO f b) t = BlockCC f b t
+blockJoinTail b t = b `cat` BlockOC BNil t
+
+blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
+blockJoin f b t = BlockCC f b t
+
+blockAppend :: Block n e O -> Block n O x -> Block n e x
+blockAppend = cat
+
+
+-- Taking apart
+
+firstNode :: Block n C x -> n C O
+firstNode (BlockCO n _)   = n
+firstNode (BlockCC n _ _) = n
+
+lastNode :: Block n x C -> n O C
+lastNode (BlockOC   _ n) = n
+lastNode (BlockCC _ _ n) = n
+
+blockSplitHead :: Block n C x -> (n C O, Block n O x)
+blockSplitHead (BlockCO n b)   = (n, b)
+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
+
+blockSplitTail :: Block n e C -> (Block n e O, n O C)
+blockSplitTail (BlockOC b n)   = (b, n)
+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
+
+-- | Split a closed block into its entry node, open middle block, and
+-- exit node.
+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
+blockSplit (BlockCC f b t) = (f, b, t)
+
+blockToList :: Block n O O -> [n O O]
+blockToList b = go b []
+   where go :: Block n O O -> [n O O] -> [n O O]
+         go BNil         r = r
+         go (BMiddle n)  r = n : r
+         go (BCat b1 b2) r = go b1 $! go b2 r
+         go (BSnoc b1 n) r = go b1 (n:r)
+         go (BCons n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BCons BNil
+
+-- Modifying
+
+replaceFirstNode :: Block n C x -> n C O -> Block n C x
+replaceFirstNode (BlockCO _ b)   f = BlockCO f b
+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
+
+replaceLastNode :: Block n x C -> n O C -> Block n x C
+replaceLastNode (BlockOC   b _) n = BlockOC b n
+replaceLastNode (BlockCC l b _) n = BlockCC l b n
+
+-- -----------------------------------------------------------------------------
+-- General concatenation
+
+cat :: Block n e O -> Block n O x -> Block n e x
+cat x y = case x of
+  BNil -> y
+
+  BlockCO l b1 -> case y of
+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
+                   BNil         -> x
+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)
+                   BCat{}       -> BlockCO l $! (b1 `cat` y)
+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)
+                   BCons{}      -> BlockCO l $! (b1 `cat` y)
+
+  BMiddle n -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle{}     -> BCons n y
+                   BCat{}        -> BCons n y
+                   BSnoc{}       -> BCons n y
+                   BCons{}       -> BCons n y
+
+  BCat{} -> case y of
+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+  BSnoc{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+  BCons{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping
+
+-- | map a function over the nodes of a 'Block'
+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)
+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)
+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
+mapBlock _  BNil           = BNil
+mapBlock f (BMiddle n)     = BMiddle (f n)
+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)
+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)
+
+-- | A strict 'mapBlock'
+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
+mapBlock' f = mapBlock3' (f, f, f)
+
+-- | map over a block, with different functions to apply to first nodes,
+-- middle nodes and last nodes respectively.  The map is strict.
+--
+mapBlock3' :: forall n n' e x .
+             ( n C O -> n' C O
+             , n O O -> n' O O,
+               n O C -> n' O C)
+          -> Block n e x -> Block n' e x
+mapBlock3' (f, m, l) b = go b
+  where go :: forall e x . Block n e x -> Block n' e x
+        go (BlockOC b y)   = (BlockOC $! go b) $! l y
+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)
+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
+        go BNil            = BNil
+        go (BMiddle n)     = BMiddle $! m n
+        go (BCat x y)      = (BCat $! go x) $! (go y)
+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)
+        go (BCons n x)     = (BCons $! m n) $! (go x)
+
+-- -----------------------------------------------------------------------------
+-- Folding
+
+
+-- | Fold a function over every node in a block, forward or backward.
+-- The fold function must be polymorphic in the shape of the nodes.
+foldBlockNodesF3 :: forall n a b c .
+                   ( n C O       -> a -> b
+                   , n O O       -> b -> b
+                   , n O C       -> b -> c)
+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
+foldBlockNodesF  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
+foldBlockNodesB3 :: forall n a b c .
+                   ( n C O       -> b -> c
+                   , n O O       -> b -> b
+                   , n O C       -> a -> b)
+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
+foldBlockNodesB  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
+
+foldBlockNodesF3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
+        cat f f' = f' . f
+
+foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
+
+foldBlockNodesB3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+        cat f f' = f . f'
+
+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
+
diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Hoopl.Collections
+    ( IsSet(..)
+    , setInsertList, setDeleteList, setUnions
+    , IsMap(..)
+    , mapInsertList, mapDeleteList, mapUnions
+    , UniqueMap, UniqueSet
+    ) where
+
+import GhcPrelude
+
+import qualified Data.IntMap.Strict as M
+import qualified Data.IntSet as S
+
+import Data.List (foldl1')
+
+class IsSet set where
+  type ElemOf set
+
+  setNull :: set -> Bool
+  setSize :: set -> Int
+  setMember :: ElemOf set -> set -> Bool
+
+  setEmpty :: set
+  setSingleton :: ElemOf set -> set
+  setInsert :: ElemOf set -> set -> set
+  setDelete :: ElemOf set -> set -> set
+
+  setUnion :: set -> set -> set
+  setDifference :: set -> set -> set
+  setIntersection :: set -> set -> set
+  setIsSubsetOf :: set -> set -> Bool
+  setFilter :: (ElemOf set -> Bool) -> set -> set
+
+  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
+
+  setElems :: set -> [ElemOf set]
+  setFromList :: [ElemOf set] -> set
+
+-- Helper functions for IsSet class
+setInsertList :: IsSet set => [ElemOf set] -> set -> set
+setInsertList keys set = foldl' (flip setInsert) set keys
+
+setDeleteList :: IsSet set => [ElemOf set] -> set -> set
+setDeleteList keys set = foldl' (flip setDelete) set keys
+
+setUnions :: IsSet set => [set] -> set
+setUnions [] = setEmpty
+setUnions sets = foldl1' setUnion sets
+
+
+class IsMap map where
+  type KeyOf map
+
+  mapNull :: map a -> Bool
+  mapSize :: map a -> Int
+  mapMember :: KeyOf map -> map a -> Bool
+  mapLookup :: KeyOf map -> map a -> Maybe a
+  mapFindWithDefault :: a -> KeyOf map -> map a -> a
+
+  mapEmpty :: map a
+  mapSingleton :: KeyOf map -> a -> map a
+  mapInsert :: KeyOf map -> a -> map a -> map a
+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
+  mapDelete :: KeyOf map -> map a -> map a
+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
+  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
+
+  mapUnion :: map a -> map a -> map a
+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
+  mapDifference :: map a -> map a -> map a
+  mapIntersection :: map a -> map a -> map a
+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool
+
+  mapMap :: (a -> b) -> map a -> map b
+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
+  mapFoldl :: (b -> a -> b) -> b -> map a -> b
+  mapFoldr :: (a -> b -> b) -> b -> map a -> b
+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
+  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
+  mapFilter :: (a -> Bool) -> map a -> map a
+  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
+
+
+  mapElems :: map a -> [a]
+  mapKeys :: map a -> [KeyOf map]
+  mapToList :: map a -> [(KeyOf map, a)]
+  mapFromList :: [(KeyOf map, a)] -> map a
+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
+
+-- Helper functions for IsMap class
+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs
+
+mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
+mapDeleteList keys map = foldl' (flip mapDelete) map keys
+
+mapUnions :: IsMap map => [map a] -> map a
+mapUnions [] = mapEmpty
+mapUnions maps = foldl1' mapUnion maps
+
+-----------------------------------------------------------------------------
+-- Basic instances
+-----------------------------------------------------------------------------
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
+
+instance IsSet UniqueSet where
+  type ElemOf UniqueSet = Int
+
+  setNull (US s) = S.null s
+  setSize (US s) = S.size s
+  setMember k (US s) = S.member k s
+
+  setEmpty = US S.empty
+  setSingleton k = US (S.singleton k)
+  setInsert k (US s) = US (S.insert k s)
+  setDelete k (US s) = US (S.delete k s)
+
+  setUnion (US x) (US y) = US (S.union x y)
+  setDifference (US x) (US y) = US (S.difference x y)
+  setIntersection (US x) (US y) = US (S.intersection x y)
+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+  setFilter f (US s) = US (S.filter f s)
+
+  setFoldl k z (US s) = S.foldl' k z s
+  setFoldr k z (US s) = S.foldr k z s
+
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
+
+newtype UniqueMap v = UM (M.IntMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+  type KeyOf UniqueMap = Int
+
+  mapNull (UM m) = M.null m
+  mapSize (UM m) = M.size m
+  mapMember k (UM m) = M.member k m
+  mapLookup k (UM m) = M.lookup k m
+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+  mapEmpty = UM M.empty
+  mapSingleton k v = UM (M.singleton k v)
+  mapInsert k v (UM m) = UM (M.insert k v m)
+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+  mapDelete k (UM m) = UM (M.delete k m)
+  mapAlter f k (UM m) = UM (M.alter f k m)
+  mapAdjust f k (UM m) = UM (M.adjust f k m)
+
+  mapUnion (UM x) (UM y) = UM (M.union x y)
+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
+  mapDifference (UM x) (UM y) = UM (M.difference x y)
+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
+  mapFoldl k z (UM m) = M.foldl' k z m
+  mapFoldr k z (UM m) = M.foldr k z m
+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
+  mapFilter f (UM m) = UM (M.filter f m)
+  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
+
+  mapElems (UM m) = M.elems m
+  mapKeys (UM m) = M.keys m
+  mapToList (UM m) = M.toList m
+  mapFromList assocs = UM (M.fromList assocs)
+  mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -0,0 +1,440 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fprof-auto-top #-}
+
+--
+-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
+-- and Norman Ramsey
+--
+-- Modifications copyright (c) The University of Glasgow 2012
+--
+-- This module is a specialised and optimised version of
+-- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is
+-- specialised to the UniqSM monad.
+--
+
+module Hoopl.Dataflow
+  ( C, O, Block
+  , lastNode, entryLabel
+  , foldNodesBwdOO
+  , foldRewriteNodesBwdOO
+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
+  , TransferFun, RewriteFun
+  , Fact, FactBase
+  , getFact, mkFactBase
+  , analyzeCmmFwd, analyzeCmmBwd
+  , rewriteCmmBwd
+  , changedIf
+  , joinOutFacts
+  , joinFacts
+  )
+where
+
+import GhcPrelude
+
+import Cmm
+import UniqSupply
+
+import Data.Array
+import Data.Maybe
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+
+type family   Fact x f :: *
+type instance Fact C f = FactBase f
+type instance Fact O f = f
+
+newtype OldFact a = OldFact a
+
+newtype NewFact a = NewFact a
+
+-- | The result of joining OldFact and NewFact.
+data JoinedFact a
+    = Changed !a     -- ^ Result is different than OldFact.
+    | NotChanged !a  -- ^ Result is the same as OldFact.
+
+getJoined :: JoinedFact a -> a
+getJoined (Changed a) = a
+getJoined (NotChanged a) = a
+
+changedIf :: Bool -> a -> JoinedFact a
+changedIf True = Changed
+changedIf False = NotChanged
+
+type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
+
+data DataflowLattice a = DataflowLattice
+    { fact_bot :: a
+    , fact_join :: JoinFun a
+    }
+
+data Direction = Fwd | Bwd
+
+type TransferFun f = CmmBlock -> FactBase f -> FactBase f
+
+-- | Function for rewrtiting and analysis combined. To be used with
+-- @rewriteCmm@.
+--
+-- Currently set to work with @UniqSM@ monad, but we could probably abstract
+-- that away (if we do that, we might want to specialize the fixpoint algorithms
+-- to the particular monads through SPECIALIZE).
+type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
+
+analyzeCmmBwd, analyzeCmmFwd
+    :: DataflowLattice f
+    -> TransferFun f
+    -> CmmGraph
+    -> FactBase f
+    -> FactBase f
+analyzeCmmBwd = analyzeCmm Bwd
+analyzeCmmFwd = analyzeCmm Fwd
+
+analyzeCmm
+    :: Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> CmmGraph
+    -> FactBase f
+    -> FactBase f
+analyzeCmm dir lattice transfer cmmGraph initFact =
+    let entry = g_entry cmmGraph
+        hooplGraph = g_graph cmmGraph
+        blockMap =
+            case hooplGraph of
+                GMany NothingO bm NothingO -> bm
+    in fixpointAnalysis dir lattice transfer entry blockMap initFact
+
+-- Fixpoint algorithm.
+fixpointAnalysis
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> Label
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> FactBase f
+fixpointAnalysis direction lattice do_block entry blockmap = loop start
+  where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
+    blocks     = sortBlocks direction entry blockmap
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList
+      [0 .. num_blocks - 1]
+    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
+    join       = fact_join lattice
+
+    loop
+        :: IntHeap     -- ^ Worklist, i.e., blocks to process
+        -> FactBase f  -- ^ Current result (increases monotonically)
+        -> FactBase f
+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
+        let block = block_arr ! index
+            out_facts = {-# SCC "do_block" #-} do_block block fbase1
+            -- For each of the outgoing edges, we join it with the current
+            -- information in fbase1 and (if something changed) we update it
+            -- and add the affected blocks to the worklist.
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
+                mapFoldlWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        in loop todo2 fbase2
+    loop _ !fbase1 = fbase1
+
+rewriteCmmBwd
+    :: DataflowLattice f
+    -> RewriteFun f
+    -> CmmGraph
+    -> FactBase f
+    -> UniqSM (CmmGraph, FactBase f)
+rewriteCmmBwd = rewriteCmm Bwd
+
+rewriteCmm
+    :: Direction
+    -> DataflowLattice f
+    -> RewriteFun f
+    -> CmmGraph
+    -> FactBase f
+    -> UniqSM (CmmGraph, FactBase f)
+rewriteCmm dir lattice rwFun cmmGraph initFact = do
+    let entry = g_entry cmmGraph
+        hooplGraph = g_graph cmmGraph
+        blockMap1 =
+            case hooplGraph of
+                GMany NothingO bm NothingO -> bm
+    (blockMap2, facts) <-
+        fixpointRewrite dir lattice rwFun entry blockMap1 initFact
+    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
+
+fixpointRewrite
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> RewriteFun f
+    -> Label
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> UniqSM (LabelMap CmmBlock, FactBase f)
+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
+  where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
+    blocks     = sortBlocks dir entry blockmap
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr_rewrite" #-}
+                 listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start_rewrite" #-}
+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
+    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
+    join       = fact_join lattice
+
+    loop
+        :: IntHeap            -- ^ Worklist, i.e., blocks to process
+        -> LabelMap CmmBlock  -- ^ Rewritten blocks.
+        -> FactBase f         -- ^ Current facts.
+        -> UniqSM (LabelMap CmmBlock, FactBase f)
+    loop todo !blocks1 !fbase1
+      | Just (index, todo1) <- IntSet.minView todo = do
+        -- Note that we use the *original* block here. This is important.
+        -- We're optimistically rewriting blocks even before reaching the fixed
+        -- point, which means that the rewrite might be incorrect. So if the
+        -- facts change, we need to rewrite the original block again (taking
+        -- into account the new facts).
+        let block = block_arr ! index
+        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}
+            do_block block fbase1
+        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
+                mapFoldlWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        loop todo2 blocks2 fbase2
+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
+
+
+{-
+Note [Unreachable blocks]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A block that is not in the domain of tfb_fbase is "currently unreachable".
+A currently-unreachable block is not even analyzed.  Reason: consider
+constant prop and this graph, with entry point L1:
+  L1: x:=3; goto L4
+  L2: x:=4; goto L4
+  L4: if x>3 goto L2 else goto L5
+Here L2 is actually unreachable, but if we process it with bottom input fact,
+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
+
+* If a currently-unreachable block is not analyzed, then its rewritten
+  graph will not be accumulated in tfb_rg.  And that is good:
+  unreachable blocks simply do not appear in the output.
+
+* Note that clients must be careful to provide a fact (even if bottom)
+  for each entry point. Otherwise useful blocks may be garbage collected.
+
+* Note that updateFact must set the change-flag if a label goes from
+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
+  real fact lattice is
+       UNR
+       bottom
+       the points above bottom
+
+* Even if the fact is going from UNR to bottom, we still call the
+  client's fact_join function because it might give the client
+  some useful debugging information.
+
+* All of this only applies for *forward* ixpoints.  For the backward
+  case we must treat every block as reachable; it might finish with a
+  'return', and therefore have no successors, for example.
+-}
+
+
+-----------------------------------------------------------------------------
+--  Pieces that are shared by fixpoint and fixpoint_anal
+-----------------------------------------------------------------------------
+
+-- | Sort the blocks into the right order for analysis. This means reverse
+-- postorder for a forward analysis. For the backward one, we simply reverse
+-- that (see Note [Backward vs forward analysis]).
+sortBlocks
+    :: NonLocal n
+    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
+sortBlocks direction entry blockmap =
+    case direction of
+        Fwd -> fwd
+        Bwd -> reverse fwd
+  where
+    fwd = revPostorderFrom blockmap entry
+
+-- Note [Backward vs forward analysis]
+--
+-- The forward and backward cases are not dual.  In the forward case, the entry
+-- points are known, and one simply traverses the body blocks from those points.
+-- In the backward case, something is known about the exit points, but a
+-- backward analysis must also include reachable blocks that don't reach the
+-- exit, as in a procedure that loops forever and has side effects.)
+-- For instance, let E be the entry and X the exit blocks (arrows indicate
+-- control flow)
+--   E -> X
+--   E -> B
+--   B -> C
+--   C -> B
+-- We do need to include B and C even though they're unreachable in the
+-- *reverse* graph (that we could use for backward analysis):
+--   E <- X
+--   E <- B
+--   B <- C
+--   C <- B
+-- So when sorting the blocks for the backward analysis, we simply take the
+-- reverse of what is used for the forward one.
+
+
+-- | Construct a mapping from a @Label@ to the block indexes that should be
+-- re-analyzed if the facts at that @Label@ change.
+--
+-- Note that we're considering here the entry point of the block, so if the
+-- facts change at the entry:
+-- * for a backward analysis we need to re-analyze all the predecessors, but
+-- * for a forward analysis, we only need to re-analyze the current block
+--   (and that will in turn propagate facts into its successors).
+mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
+mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
+  where
+    go []     !_ !dep_map = dep_map
+    go (b:bs) !n !dep_map =
+        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map
+mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
+  where
+    go []     !_ !dep_map = dep_map
+    go (b:bs) !n !dep_map =
+        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m
+        in go bs (n + 1) $ foldl' insert dep_map (successors b)
+
+-- | After some new facts have been generated by analysing a block, we
+-- fold this function over them to generate (a) a list of block
+-- indices to (re-)analyse, and (b) the new FactBase.
+updateFact
+    :: JoinFun f
+    -> LabelMap IntSet
+    -> (IntHeap, FactBase f)
+    -> Label
+    -> f -- out fact
+    -> (IntHeap, FactBase f)
+updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
+  = case lookupFact lbl fbase of
+      Nothing ->
+          -- Note [No old fact]
+          let !z = mapInsert lbl new_fact fbase in (changed, z)
+      Just old_fact ->
+          case fact_join (OldFact old_fact) (NewFact new_fact) of
+              (NotChanged _) -> (todo, fbase)
+              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
+  where
+    changed = todo `IntSet.union`
+              mapFindWithDefault IntSet.empty lbl dep_blocks
+
+{-
+Note [No old fact]
+
+We know that the new_fact is >= _|_, so we don't need to join.  However,
+if the new fact is also _|_, and we have already analysed its block,
+we don't need to record a change.  So there's a tradeoff here.  It turns
+out that always recording a change is faster.
+-}
+
+----------------------------------------------------------------
+--       Utilities
+----------------------------------------------------------------
+
+-- Fact lookup: the fact `orelse` bottom
+getFact  :: DataflowLattice f -> Label -> FactBase f -> f
+getFact lat l fb = case lookupFact l fb of Just  f -> f
+                                           Nothing -> fact_bot lat
+
+-- | Returns the result of joining the facts from all the successors of the
+-- provided node or block.
+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
+joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+    facts =
+        [ fromJust fact
+        | s <- successors nonLocal
+        , let fact = lookupFact s fact_base
+        , isJust fact
+        ]
+
+joinFacts :: DataflowLattice f -> [f] -> f
+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+
+-- | Returns the joined facts for each label.
+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
+mkFactBase lattice = foldl' add mapEmpty
+  where
+    join = fact_join lattice
+
+    add result (l, f1) =
+        let !newFact =
+                case mapLookup l result of
+                    Nothing -> f1
+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
+        in mapInsert l newFact result
+
+-- | Folds backward over all nodes of an open-open block.
+-- Strict in the accumulator.
+foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
+foldNodesBwdOO funOO = go
+  where
+    go (BCat b1 b2) f = go b1 $! go b2 f
+    go (BSnoc h n) f = go h $! funOO n f
+    go (BCons n t) f = funOO n $! go t f
+    go (BMiddle n) f = funOO n f
+    go BNil f = f
+{-# INLINABLE foldNodesBwdOO #-}
+
+-- | Folds backward over all the nodes of an open-open block and allows
+-- rewriting them. The accumulator is both the block of nodes and @f@ (usually
+-- dataflow facts).
+-- Strict in both accumulated parts.
+foldRewriteNodesBwdOO
+    :: forall f.
+       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
+    -> Block CmmNode O O
+    -> f
+    -> UniqSM (Block CmmNode O O, f)
+foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
+  where
+    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
+    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1
+    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1
+    go (BMiddle node) !fact1 = rewriteOO node fact1
+    go BNil !fact = return (BNil, fact)
+
+    comp rew1 rew2 = \f1 -> do
+        (b, f2) <- rew2 f1
+        (a, !f3) <- rew1 f2
+        let !c = joinBlocksOO a b
+        return (c, f3)
+    {-# INLINE comp #-}
+{-# INLINABLE foldRewriteNodesBwdOO #-}
+
+joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
+joinBlocksOO BNil b = b
+joinBlocksOO b BNil = b
+joinBlocksOO (BMiddle n) b = blockCons n b
+joinBlocksOO b (BMiddle n) = blockSnoc b n
+joinBlocksOO b1 b2 = BCat b1 b2
+
+type IntHeap = IntSet
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Graph
+    ( Body
+    , Graph
+    , Graph'(..)
+    , NonLocal(..)
+    , addBlock
+    , bodyList
+    , emptyBody
+    , labelsDefined
+    , mapGraph
+    , mapGraphBlocks
+    , revPostorderFrom
+    ) where
+
+
+import GhcPrelude
+import Util
+
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+-- | A (possibly empty) collection of closed/closed blocks
+type Body n = LabelMap (Block n C C)
+
+-- | @Body@ abstracted over @block@
+type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
+
+-------------------------------
+-- | Gives access to the anchor points for
+-- nonlocal edges as well as the edges themselves
+class NonLocal thing where
+  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block
+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors
+
+instance NonLocal n => NonLocal (Block n) where
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
+
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
+
+
+emptyBody :: Body' block n
+emptyBody = mapEmpty
+
+bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList body = mapToList body
+
+addBlock
+    :: (NonLocal block, HasDebugCallStack)
+    => block C C -> LabelMap (block C C) -> LabelMap (block C C)
+addBlock block body = mapAlter add lbl body
+  where
+    lbl = entryLabel block
+    add Nothing = Just block
+    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
+
+
+-- ---------------------------------------------------------------------------
+-- Graph
+
+-- | A control-flow graph, which may take any of four shapes (O/O,
+-- O/C, C/O, C/C).  A graph open at the entry has a single,
+-- distinguished, anonymous entry point; if a graph is closed at the
+-- entry, its entry point(s) are supplied by a context.
+type Graph = Graph' Block
+
+-- | @Graph'@ is abstracted over the block type, so that we can build
+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
+-- needs this).
+data Graph' block (n :: * -> * -> *) e x where
+  GNil  :: Graph' block n O O
+  GUnit :: block n O O -> Graph' block n O O
+  GMany :: MaybeO e (block n O C)
+        -> Body' block n
+        -> MaybeO x (block n C O)
+        -> Graph' block n e x
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping over graphs
+
+-- | Maps over all nodes in a graph.
+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
+mapGraph f = mapGraphBlocks (mapBlock f)
+
+-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
+-- graph transform.  When the block representation stabilizes, a similar
+-- function should be provided for blocks.
+mapGraphBlocks :: forall block n block' n' e x .
+                  (forall e x . block n e x -> block' n' e x)
+               -> (Graph' block n e x -> Graph' block' n' e x)
+
+mapGraphBlocks f = map
+  where map :: Graph' block n e x -> Graph' block' n' e x
+        map GNil = GNil
+        map (GUnit b) = GUnit (f b)
+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+
+-- -----------------------------------------------------------------------------
+-- Extracting Labels from graphs
+
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+              -> LabelSet
+labelsDefined GNil      = setEmpty
+labelsDefined (GUnit{}) = setEmpty
+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+        addEntry labels label _ = setInsert label labels
+        exitLabel :: MaybeO x (block n C O) -> LabelSet
+        exitLabel NothingO  = setEmpty
+        exitLabel (JustO b) = setSingleton (entryLabel b)
+
+
+----------------------------------------------------------------
+
+-- | Returns a list of blocks reachable from the provided Labels in the reverse
+-- postorder.
+--
+-- This is the most important traversal over this data structure.  It drops
+-- unreachable code and puts blocks in an order that is good for solving forward
+-- dataflow problems quickly.  The reverse order is good for solving backward
+-- dataflow problems quickly.  The forward order is also reasonably good for
+-- emitting instructions, except that it will not usually exploit Forrest
+-- Baskett's trick of eliminating the unconditional branch from a loop.  For
+-- that you would need a more serious analysis, probably based on dominators, to
+-- identify loop headers.
+--
+-- For forward analyses we want reverse postorder visitation, consider:
+-- @
+--      A -> [B,C]
+--      B -> D
+--      C -> D
+-- @
+-- Postorder: [D, C, B, A] (or [D, B, C, A])
+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
+-- This matters for, e.g., forward analysis, because we want to analyze *both*
+-- B and C before we analyze D.
+revPostorderFrom
+  :: forall block.  (NonLocal block)
+  => LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist setEmpty []
+  where
+    start_worklist = lookup_for_descend start Nil
+
+    -- To compute the postorder we need to "visit" a block (mark as done)
+    -- *after* visiting all its successors. So we need to know whether we
+    -- already processed all successors of each block (and @NonLocal@ allows
+    -- arbitrary many successors). So we use an explicit stack with an extra bit
+    -- of information:
+    -- * @ConsTodo@ means to explore the block if it wasn't visited before
+    -- * @ConsMark@ means that all successors were already done and we can add
+    --   the block to the result.
+    --
+    -- NOTE: We add blocks to the result list in postorder, but we *prepend*
+    -- them (i.e., we use @(:)@), which means that the final list is in reverse
+    -- postorder.
+    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+    go Nil                      !_           !result = result
+    go (ConsMark block rest)    !wip_or_done !result =
+        go rest wip_or_done (block : result)
+    go (ConsTodo block rest)    !wip_or_done !result
+        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+        | otherwise =
+            let new_worklist =
+                    foldr lookup_for_descend
+                          (ConsMark block rest)
+                          (successors block)
+            in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+
+    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
+    lookup_for_descend label wl
+      | Just b <- mapLookup label graph = ConsTodo b wl
+      | otherwise =
+           error $ "Label that doesn't have a block?! " ++ show label
+
+data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Hoopl.Label
+    ( Label
+    , LabelMap
+    , LabelSet
+    , FactBase
+    , lookupFact
+    , mkHooplLabel
+    ) where
+
+import GhcPrelude
+
+import Outputable
+
+-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
+import Hoopl.Collections
+
+import Unique (Uniquable(..))
+import TrieMap
+
+
+-----------------------------------------------------------------------------
+--              Label
+-----------------------------------------------------------------------------
+
+newtype Label = Label { lblToUnique :: Int }
+  deriving (Eq, Ord)
+
+mkHooplLabel :: Int -> Label
+mkHooplLabel = Label
+
+instance Show Label where
+  show (Label n) = "L" ++ show n
+
+instance Uniquable Label where
+  getUnique label = getUnique (lblToUnique label)
+
+instance Outputable Label where
+  ppr label = ppr (getUnique label)
+
+-----------------------------------------------------------------------------
+-- LabelSet
+
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
+
+instance IsSet LabelSet where
+  type ElemOf LabelSet = Label
+
+  setNull (LS s) = setNull s
+  setSize (LS s) = setSize s
+  setMember (Label k) (LS s) = setMember k s
+
+  setEmpty = LS setEmpty
+  setSingleton (Label k) = LS (setSingleton k)
+  setInsert (Label k) (LS s) = LS (setInsert k s)
+  setDelete (Label k) (LS s) = LS (setDelete k s)
+
+  setUnion (LS x) (LS y) = LS (setUnion x y)
+  setDifference (LS x) (LS y) = LS (setDifference x y)
+  setIntersection (LS x) (LS y) = LS (setIntersection x y)
+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
+  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
+  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
+  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
+
+  setElems (LS s) = map mkHooplLabel (setElems s)
+  setFromList ks = LS (setFromList (map lblToUnique ks))
+
+-----------------------------------------------------------------------------
+-- LabelMap
+
+newtype LabelMap v = LM (UniqueMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap LabelMap where
+  type KeyOf LabelMap = Label
+
+  mapNull (LM m) = mapNull m
+  mapSize (LM m) = mapSize m
+  mapMember (Label k) (LM m) = mapMember k m
+  mapLookup (Label k) (LM m) = mapLookup k m
+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
+
+  mapEmpty = LM mapEmpty
+  mapSingleton (Label k) v = LM (mapSingleton k v)
+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
+  mapDelete (Label k) (LM m) = LM (mapDelete k m)
+  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
+  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
+
+  mapUnion (LM x) (LM y) = LM (mapUnion x y)
+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
+  mapDifference (LM x) (LM y) = LM (mapDifference x y)
+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
+
+  mapMap f (LM m) = LM (mapMap f m)
+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
+  mapFoldl k z (LM m) = mapFoldl k z m
+  mapFoldr k z (LM m) = mapFoldr k z m
+  mapFoldlWithKey k z (LM m) =
+      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
+  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
+  mapFilter f (LM m) = LM (mapFilter f m)
+  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
+
+  mapElems (LM m) = mapElems m
+  mapKeys (LM m) = map mkHooplLabel (mapKeys m)
+  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+
+-----------------------------------------------------------------------------
+-- Instances
+
+instance Outputable LabelSet where
+  ppr = ppr . setElems
+
+instance Outputable a => Outputable (LabelMap a) where
+  ppr = ppr . mapToList
+
+instance TrieMap LabelMap where
+  type Key LabelMap = Label
+  emptyTM = mapEmpty
+  lookupTM k m = mapLookup k m
+  alterTM k f m = mapAlter f k m
+  foldTM k m z = mapFoldr k z m
+  mapTM f m = mapMap f m
+
+-----------------------------------------------------------------------------
+-- FactBase
+
+type FactBase f = LabelMap f
+
+lookupFact :: Label -> FactBase f -> Maybe f
+lookupFact = mapLookup
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/MkGraph.hs
@@ -0,0 +1,484 @@
+{-# LANGUAGE BangPatterns, GADTs #-}
+
+module MkGraph
+  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
+  , (<*>), catAGraphs
+  , mkLabel, mkMiddle, mkLast, outOfLine
+  , lgraphOfAGraph, labelAGraph
+
+  , stackStubExpr
+  , mkNop, mkAssign, mkStore
+  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
+  , mkJumpReturnsTo
+  , mkJump, mkJumpExtra
+  , mkRawJump
+  , mkCbranch, mkSwitch
+  , mkReturn, mkComment, mkCallEntry, mkBranch
+  , mkUnwind
+  , copyInOflow, copyOutOflow
+  , noExtraStack
+  , toCall, Transfer(..)
+  )
+where
+
+import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)
+
+import BlockId
+import Cmm
+import CmmCallConv
+import CmmSwitch (SwitchTargets)
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import DynFlags
+import FastString
+import ForeignCall
+import OrdList
+import SMRep (ByteOff)
+import UniqSupply
+import Util
+import Panic
+
+
+-----------------------------------------------------------------------------
+-- Building Graphs
+
+
+-- | CmmAGraph is a chunk of code consisting of:
+--
+--   * ordinary statements (assignments, stores etc.)
+--   * jumps
+--   * labels
+--   * out-of-line labelled blocks
+--
+-- The semantics is that control falls through labels and out-of-line
+-- blocks.  Everything after a jump up to the next label is by
+-- definition unreachable code, and will be discarded.
+--
+-- Two CmmAGraphs can be stuck together with <*>, with the meaning that
+-- control flows from the first to the second.
+--
+-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
+-- by providing a label for the entry point and a tick scope; see
+-- 'labelAGraph'.
+type CmmAGraph = OrdList CgStmt
+-- | Unlabeled graph with tick scope
+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
+
+data CgStmt
+  = CgLabel BlockId CmmTickScope
+  | CgStmt  (CmmNode O O)
+  | CgLast  (CmmNode O C)
+  | CgFork  BlockId CmmAGraph CmmTickScope
+
+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
+flattenCmmAGraph id (stmts_t, tscope) =
+    CmmGraph { g_entry = id,
+               g_graph = GMany NothingO body NothingO }
+  where
+  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
+
+  --
+  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
+  --
+  -- NB. avoid the quadratic-append trap by passing in the tail of the
+  -- list.  This is important for Very Long Functions (e.g. in T783).
+  --
+  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
+          -> [Block CmmNode C C]
+  flatten id g tscope blocks
+      = flatten1 (fromOL g) block' blocks
+      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
+  --
+  -- flatten0: we are outside a block at this point: any code before
+  -- the first label is unreachable, so just drop it.
+  --
+  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
+  flatten0 [] blocks = blocks
+
+  flatten0 (CgLabel id tscope : stmts) blocks
+    = flatten1 stmts block blocks
+    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
+
+  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
+    = flatten fork_id stmts_t tscope $ flatten0 rest blocks
+
+  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
+  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
+
+  --
+  -- flatten1: we have a partial block, collect statements until the
+  -- next last node to make a block, then call flatten0 to get the rest
+  -- of the blocks
+  --
+  flatten1 :: [CgStmt] -> Block CmmNode C O
+           -> [Block CmmNode C C] -> [Block CmmNode C C]
+
+  -- The current block falls through to the end of a function or fork:
+  -- this code should not be reachable, but it may be referenced by
+  -- other code that is not reachable.  We'll remove it later with
+  -- dead-code analysis, but for now we have to keep the graph
+  -- well-formed, so we terminate the block with a branch to the
+  -- beginning of the current block.
+  flatten1 [] block blocks
+    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks
+
+  flatten1 (CgLast stmt : stmts) block blocks
+    = block' : flatten0 stmts blocks
+    where !block' = blockJoinTail block stmt
+
+  flatten1 (CgStmt stmt : stmts) block blocks
+    = flatten1 stmts block' blocks
+    where !block' = blockSnoc block stmt
+
+  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
+    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
+
+  -- a label here means that we should start a new block, and the
+  -- current block should fall through to the new block.
+  flatten1 (CgLabel id tscp : stmts) block blocks
+    = blockJoinTail block (CmmBranch id) :
+      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
+
+
+
+---------- AGraph manipulation
+
+(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
+(<*>)           = appOL
+
+catAGraphs     :: [CmmAGraph] -> CmmAGraph
+catAGraphs      = concatOL
+
+-- | created a sequence "goto id; id:" as an AGraph
+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
+mkLabel bid scp = unitOL (CgLabel bid scp)
+
+-- | creates an open AGraph from a given node
+mkMiddle        :: CmmNode O O -> CmmAGraph
+mkMiddle middle = unitOL (CgStmt middle)
+
+-- | created a closed AGraph from a given node
+mkLast         :: CmmNode O C -> CmmAGraph
+mkLast last     = unitOL (CgLast last)
+
+-- | A labelled code block; should end in a last node
+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
+outOfLine l (c,s) = unitOL (CgFork l c s)
+
+-- | allocate a fresh label for the entry point
+lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
+lgraphOfAGraph g = do
+  u <- getUniqueM
+  return (labelAGraph (mkBlockId u) g)
+
+-- | use the given BlockId as the label of the entry point
+labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
+labelAGraph lbl ag = flattenCmmAGraph lbl ag
+
+---------- No-ops
+mkNop        :: CmmAGraph
+mkNop         = nilOL
+
+mkComment    :: FastString -> CmmAGraph
+mkComment fs
+  -- SDM: generating all those comments takes time, this saved about 4% for me
+  | debugIsOn = mkMiddle $ CmmComment fs
+  | otherwise = nilOL
+
+---------- Assignment and store
+mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
+mkAssign l (CmmReg r) | l == r  = mkNop
+mkAssign l r  = mkMiddle $ CmmAssign l r
+
+mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
+mkStore  l r  = mkMiddle $ CmmStore  l r
+
+---------- Control transfer
+mkJump          :: DynFlags -> Convention -> CmmExpr
+                -> [CmmExpr]
+                -> UpdFrameOffset
+                -> CmmAGraph
+mkJump dflags conv e actuals updfr_off =
+  lastWithArgs dflags Jump Old conv actuals updfr_off $
+    toCall e Nothing updfr_off 0
+
+-- | A jump where the caller says what the live GlobalRegs are.  Used
+-- for low-level hand-written Cmm.
+mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
+                -> CmmAGraph
+mkRawJump dflags e updfr_off vols =
+  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
+    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
+
+
+mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
+                -> UpdFrameOffset -> [CmmExpr]
+                -> CmmAGraph
+mkJumpExtra dflags conv e actuals updfr_off extra_stack =
+  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
+    toCall e Nothing updfr_off 0
+
+mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
+mkCbranch pred ifso ifnot likely =
+  mkLast (CmmCondBranch pred ifso ifnot likely)
+
+mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
+mkSwitch e tbl   = mkLast $ CmmSwitch e tbl
+
+mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
+                -> CmmAGraph
+mkReturn dflags e actuals updfr_off =
+  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
+    toCall e Nothing updfr_off 0
+
+mkBranch        :: BlockId -> CmmAGraph
+mkBranch bid     = mkLast (CmmBranch bid)
+
+mkFinalCall   :: DynFlags
+              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
+              -> CmmAGraph
+mkFinalCall dflags f _ actuals updfr_off =
+  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
+    toCall f Nothing updfr_off 0
+
+mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+                -> BlockId
+                -> ByteOff
+                -> UpdFrameOffset
+                -> [CmmExpr]
+                -> CmmAGraph
+mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
+  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
+     updfr_off extra_stack $
+       toCall f (Just ret_lbl) updfr_off ret_off
+
+-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
+-- already on the stack).
+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+                -> BlockId
+                -> ByteOff
+                -> UpdFrameOffset
+                -> CmmAGraph
+mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
+  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
+       toCall f (Just ret_lbl) updfr_off ret_off
+
+mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
+mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
+
+-- | Construct a 'CmmUnwind' node for the given register and unwinding
+-- expression.
+mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]
+
+--------------------------------------------------------------------------
+
+
+
+
+-- Why are we inserting extra blocks that simply branch to the successors?
+-- Because in addition to the branch instruction, @mkBranch@ will insert
+-- a necessary adjustment to the stack pointer.
+
+
+-- For debugging purposes, we can stub out dead stack slots:
+stackStubExpr :: Width -> CmmExpr
+stackStubExpr w = CmmLit (CmmInt 0 w)
+
+-- When we copy in parameters, we usually want to put overflow
+-- parameters on the stack, but sometimes we want to pass the
+-- variables in their spill slots.  Therefore, for copying arguments
+-- and results, we provide different functions to pass the arguments
+-- in an overflow area and to pass them in spill slots.
+copyInOflow  :: DynFlags -> Convention -> Area
+             -> [CmmFormal]
+             -> [CmmFormal]
+             -> (Int, [GlobalReg], CmmAGraph)
+
+copyInOflow dflags conv area formals extra_stk
+  = (offset, gregs, catAGraphs $ map mkMiddle nodes)
+  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
+
+-- Return the number of bytes used for copying arguments, as well as the
+-- instructions to copy the arguments.
+copyIn :: DynFlags -> Convention -> Area
+       -> [CmmFormal]
+       -> [CmmFormal]
+       -> (ByteOff, [GlobalReg], [CmmNode O O])
+copyIn dflags conv area formals extra_stk
+  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
+  where
+    -- See Note [Width of parameters]
+    ci (reg, RegisterParam r@(VanillaReg {})) =
+        let local = CmmLocal reg
+            global = CmmReg (CmmGlobal r)
+            width = cmmRegWidth dflags local
+            expr
+                | width == wordWidth dflags = global
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in CmmAssign local expr
+
+    -- Non VanillaRegs
+    ci (reg, RegisterParam r) =
+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
+
+    ci (reg, StackParam off)
+      | isBitsType $ localRegType reg
+      , typeWidth (localRegType reg) < wordWidth dflags =
+        let
+          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))
+          local = CmmLocal reg
+          width = cmmRegWidth dflags local
+          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
+        in CmmAssign local expr 
+         
+      | otherwise =
+         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
+         where ty = localRegType reg
+
+    init_offset = widthInBytes (wordWidth dflags) -- infotable
+
+    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+
+    (stk_size, args) = assignArgumentsPos dflags stk_off conv
+                                          localRegType formals
+
+-- Factoring out the common parts of the copyout functions yielded something
+-- more complicated:
+
+data Transfer = Call | JumpRet | Jump | Ret deriving Eq
+
+copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
+             -> UpdFrameOffset
+             -> [CmmExpr] -- extra stack args
+             -> (Int, [GlobalReg], CmmAGraph)
+
+-- Generate code to move the actual parameters into the locations
+-- required by the calling convention.  This includes a store for the
+-- return address.
+--
+-- The argument layout function ignores the pointer to the info table,
+-- so we slot that in here. When copying-out to a young area, we set
+-- the info table for return and adjust the offsets of the other
+-- parameters.  If this is a call instruction, we adjust the offsets
+-- of the other parameters.
+copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
+  = (stk_size, regs, graph)
+  where
+    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
+
+    -- See Note [Width of parameters]
+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
+        let width = cmmExprWidth dflags v
+            value
+                | width == wordWidth dflags = v
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
+
+    -- Non VanillaRegs
+    co (v, RegisterParam r) (rs, ms) =
+        (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+
+    -- See Note [Width of parameters]
+    co (v, StackParam off)  (rs, ms)
+      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
+
+    width v = cmmExprWidth dflags v
+    value v
+      | isBitsType $ cmmExprType dflags v
+      , width v < wordWidth dflags =
+        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]
+      | otherwise = v
+
+    (setRA, init_offset) =
+      case area of
+            Young id ->  -- Generate a store instruction for
+                         -- the return address if making a call
+                  case transfer of
+                     Call ->
+                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
+                       widthInBytes (wordWidth dflags))
+                     JumpRet ->
+                       ([],
+                       widthInBytes (wordWidth dflags))
+                     _other ->
+                       ([], 0)
+            Old -> ([], updfr_off)
+
+    (extra_stack_off, stack_params) =
+       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+
+    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
+    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
+                                          (cmmExprType dflags) actuals
+
+
+-- Note [Width of parameters]
+--
+-- Consider passing a small (< word width) primitive like Int8# to a function.
+-- It's actually non-trivial to do this without extending/narrowing:
+-- * Global registers are considered to have native word width (i.e., 64-bits on
+--   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a
+--   global register.
+-- * Same problem exists with LLVM IR.
+-- * Lowering gets harder since on x86-32 not every register exposes its lower
+--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
+--   8-bit register for %edi). So we would either need to extend/narrow anyway,
+--   or complicate the calling convention.
+-- * Passing a small integer in a stack slot, which has native word width,
+--   requires extending to word width when writing to the stack and narrowing
+--   when reading off the stack (see #16258).
+-- So instead, we always extend every parameter smaller than native word width
+-- in copyOutOflow and then truncate it back to the expected width in copyIn.
+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring
+-- zero-/sign-extending - it's up to a backend to handle this in a most
+-- efficient way (e.g., a simple register move or a smaller size store).
+-- This convention (of ignoring the upper bits) is different from some C ABIs,
+-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.
+--
+-- There was some discussion about this on this PR:
+-- https://github.com/ghc-proposals/ghc-proposals/pull/74
+
+
+mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
+            -> (Int, [GlobalReg], CmmAGraph)
+mkCallEntry dflags conv formals extra_stk
+  = copyInOflow dflags conv Old formals extra_stk
+
+lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
+             -> UpdFrameOffset
+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
+             -> CmmAGraph
+lastWithArgs dflags transfer area conv actuals updfr_off last =
+  lastWithArgsAndExtraStack dflags transfer area conv actuals
+                            updfr_off noExtraStack last
+
+lastWithArgsAndExtraStack :: DynFlags
+             -> Transfer -> Area -> Convention -> [CmmExpr]
+             -> UpdFrameOffset -> [CmmExpr]
+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
+             -> CmmAGraph
+lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
+                          extra_stack last =
+  copies <*> last outArgs regs
+ where
+  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
+                               updfr_off extra_stack
+
+
+noExtraStack :: [CmmExpr]
+noExtraStack = []
+
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
+       -> ByteOff -> [GlobalReg]
+       -> CmmAGraph
+toCall e cont updfr_off res_space arg_space regs =
+  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprC.hs
@@ -0,0 +1,1383 @@
+{-# LANGUAGE CPP, GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as C, suitable for feeding gcc
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-- Print Cmm as real C, for -fvia-C
+--
+-- See wiki:commentary/compiler/backends/ppr-c
+--
+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
+-- relative to the old AbstractC, and many oddities/decorations have
+-- disappeared from the data type.
+--
+-- This code generator is only supported in unregisterised mode.
+--
+-----------------------------------------------------------------------------
+
+module PprC (
+        writeCs,
+        pprStringInCStyle
+  ) where
+
+#include "HsVersions.h"
+
+-- Cmm stuff
+import GhcPrelude
+
+import BlockId
+import CLabel
+import ForeignCall
+import Cmm hiding (pprBBlock)
+import PprCmm ()
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import CmmUtils
+import CmmSwitch
+
+-- Utils
+import CPrim
+import DynFlags
+import FastString
+import Outputable
+import Platform
+import UniqSet
+import UniqFM
+import Unique
+import Util
+
+-- The rest
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Control.Monad.ST
+import Data.Bits
+import Data.Char
+import Data.List
+import Data.Map (Map)
+import Data.Word
+import System.IO
+import qualified Data.Map as Map
+import Control.Monad (liftM, ap)
+import qualified Data.Array.Unsafe as U ( castSTUArray )
+import Data.Array.ST
+
+-- --------------------------------------------------------------------------
+-- 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)
+
+-- --------------------------------------------------------------------------
+-- Now do some real work
+--
+-- for fun, we could call cmmToCmm over the tops...
+--
+
+pprC :: RawCmmGroup -> SDoc
+pprC tops = vcat $ intersperse blankLine $ map pprTop tops
+
+--
+-- top level procs
+--
+pprTop :: RawCmmDecl -> SDoc
+pprTop (CmmProc infos clbl _in_live_regs graph) =
+
+    (case mapLookup (g_entry graph) infos of
+       Nothing -> empty
+       Just (Statics info_clbl info_dat) ->
+           pprDataExterns info_dat $$
+           pprWordArray info_is_in_rodata info_clbl info_dat) $$
+    (vcat [
+           blankLine,
+           extern_decls,
+           (if (externallyVisibleCLabel clbl)
+                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
+           nest 8 temp_decls,
+           vcat (map pprBBlock blocks),
+           rbrace ]
+    )
+  where
+        -- info tables are always in .rodata
+        info_is_in_rodata = True
+        blocks = toBlockListEntryFirst graph
+        (temp_decls, extern_decls) = pprTempAndExternDecls blocks
+
+
+-- Chunks of static data.
+
+-- We only handle (a) arrays of word-sized things and (b) strings.
+
+pprTop (CmmData section (Statics lbl [CmmString str])) =
+  pprExternDecl lbl $$
+  hcat [
+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+    text "[] = ", pprStringInCStyle str, semi
+  ]
+
+pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =
+  pprExternDecl lbl $$
+  hcat [
+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+    brackets (int size), semi
+  ]
+
+pprTop (CmmData section (Statics lbl lits)) =
+  pprDataExterns lits $$
+  pprWordArray (isSecConstant section) lbl lits
+
+-- --------------------------------------------------------------------------
+-- BasicBlocks are self-contained entities: they always end in a jump.
+--
+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
+-- as many jumps as possible into fall throughs.
+--
+
+pprBBlock :: CmmBlock -> SDoc
+pprBBlock block =
+  nest 4 (pprBlockId (entryLabel block) <> colon) $$
+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
+ where
+  (_, nodes, last)  = blockSplit block
+
+-- --------------------------------------------------------------------------
+-- Info tables. Just arrays of words.
+-- See codeGen/ClosureInfo, and nativeGen/PprMach
+
+pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
+pprWordArray is_ro lbl ds
+  = sdocWithDynFlags $ \dflags ->
+    -- TODO: align closures only
+    pprExternDecl lbl $$
+    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
+         , space, ppr lbl, text "[]"
+         -- See Note [StgWord alignment]
+         , pprAlignment (wordWidth dflags)
+         , text "= {" ]
+    $$ nest 8 (commafy (pprStatics dflags ds))
+    $$ text "};"
+
+pprAlignment :: Width -> SDoc
+pprAlignment words =
+     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"
+
+-- Note [StgWord alignment]
+-- C codegen builds static closures as StgWord C arrays (pprWordArray).
+-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume
+-- pointers to 'StgClosure' are aligned at pointer size boundary:
+--  4 byte boundary on 32 systems
+--  and 8 bytes on 64-bit systems
+-- see TAG_MASK and TAG_BITS definition and usage.
+--
+-- It's a reasonable assumption also known as natural alignment.
+-- Although some architectures have different alignment rules.
+-- One of known exceptions is m68k (#11395, comment:16) where:
+--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4
+--
+-- Thus we explicitly increase alignment by using
+--    __attribute__((aligned(4)))
+-- declaration.
+
+--
+-- has to be static, if it isn't globally visible
+--
+pprLocalness :: CLabel -> SDoc
+pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "
+                 | otherwise = empty
+
+pprConstness :: Bool -> SDoc
+pprConstness is_ro | is_ro = text "const "
+                   | otherwise = empty
+
+-- --------------------------------------------------------------------------
+-- Statements.
+--
+
+pprStmt :: CmmNode e x -> SDoc
+
+pprStmt stmt =
+    sdocWithDynFlags $ \dflags ->
+    case stmt of
+    CmmEntry{}   -> empty
+    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")
+                          -- XXX if the string contains "*/", we need to fix it
+                          -- XXX we probably want to emit these comments when
+                          -- some debugging option is on.  They can get quite
+                          -- large.
+
+    CmmTick _ -> empty
+    CmmUnwind{} -> empty
+
+    CmmAssign dest src -> pprAssign dflags dest src
+
+    CmmStore  dest src
+        | typeWidth rep == W64 && wordWidth dflags /= W64
+        -> (if isFloatType rep then text "ASSIGN_DBL"
+                               else ptext (sLit ("ASSIGN_Word64"))) <>
+           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
+        | otherwise
+        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
+        where
+          rep = cmmExprType dflags src
+
+    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
+        fnCall
+        where
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
+        ForeignConvention cconv _ _ ret = conv
+
+        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
+
+        -- See wiki:commentary/compiler/backends/ppr-c#prototypes
+        fnCall =
+            case fn of
+              CmmLit (CmmLabel lbl)
+                | StdCallConv <- cconv ->
+                    pprCall (ppr lbl) cconv hresults hargs
+                        -- stdcall functions must be declared with
+                        -- a function type, otherwise the C compiler
+                        -- doesn't add the @n suffix to the label.  We
+                        -- can't add the @n suffix ourselves, because
+                        -- it isn't valid C.
+                | CmmNeverReturns <- ret ->
+                    pprCall cast_fn cconv hresults hargs <> semi
+                | not (isMathFun lbl) ->
+                    pprForeignCall (ppr lbl) cconv hresults hargs
+              _ ->
+                    pprCall cast_fn cconv hresults hargs <> semi
+                        -- for a dynamic call, no declaration is necessary.
+
+    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
+    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty
+
+    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
+        fn_call
+      where
+        cconv = CCallConv
+        fn = pprCallishMachOp_for_C op
+
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
+        fn_call
+          -- The mem primops carry an extra alignment arg.
+          -- We could maybe emit an alignment directive using this info.
+          -- We also need to cast mem primops to prevent conflicts with GCC
+          -- builtins (see bug #5967).
+          | Just _align <- machOpMemcpyishAlign op
+          = (text ";EFF_(" <> fn <> char ')' <> semi) $$
+            pprForeignCall fn cconv hresults hargs
+          | otherwise
+          = pprCall fn cconv hresults hargs
+
+    CmmBranch ident          -> pprBranch ident
+    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no
+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
+    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->
+                                pprSwitch dflags arg ids
+
+    _other -> pprPanic "PprC.pprStmt" (ppr stmt)
+
+type Hinted a = (a, ForeignHint)
+
+pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
+               -> SDoc
+pprForeignCall fn cconv results args = fn_call
+  where
+    fn_call = braces (
+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+              $$ pprCall (text "ghcFunPtr") cconv results args <> semi
+             )
+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
+
+pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCFunType ppr_fn cconv ress args
+  = sdocWithDynFlags $ \dflags ->
+    let res_type [] = text "void"
+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint
+        res_type _ = panic "pprCFunType: only void or 1 return value supported"
+
+        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
+    in res_type ress <+>
+       parens (ccallConvAttribute cconv <> ppr_fn) <>
+       parens (commafy (map arg_type args))
+
+-- ---------------------------------------------------------------------
+-- unconditional branches
+pprBranch :: BlockId -> SDoc
+pprBranch ident = text "goto" <+> pprBlockId ident <> semi
+
+
+-- ---------------------------------------------------------------------
+-- conditional branches to local labels
+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
+pprCondBranch expr yes no
+        = hsep [ text "if" , parens(pprExpr expr) ,
+                        text "goto", pprBlockId yes <> semi,
+                        text "else goto", pprBlockId no <> semi ]
+
+-- ---------------------------------------------------------------------
+-- a local table branch
+--
+-- we find the fall-through cases
+--
+pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
+pprSwitch dflags e ids
+  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)
+                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace
+  where
+    (pairs, mbdef) = switchTargetsFallThrough ids
+
+    -- fall through case
+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+        where
+        do_fallthrough ix =
+                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
+                        text "/* fall through */" ]
+
+        final_branch ix =
+                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
+                       text "goto" , (pprBlockId ident) <> semi ]
+
+    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"
+
+    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi
+        | otherwise       = empty
+
+-- ---------------------------------------------------------------------
+-- Expressions.
+--
+
+-- C Types: the invariant is that the C expression generated by
+--
+--      pprExpr e
+--
+-- has a type in C which is also given by
+--
+--      machRepCType (cmmExprType e)
+--
+-- (similar invariants apply to the rest of the pretty printer).
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e = case e of
+    CmmLit lit -> pprLit lit
+
+
+    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty
+    CmmReg reg      -> pprCastReg reg
+    CmmRegOff reg 0 -> pprCastReg reg
+
+    -- CmmRegOff is an alias of MO_Add
+    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->
+                       pprCastReg reg <> char '+' <>
+                       pprHexVal (fromIntegral i) (wordWidth dflags)
+
+    CmmMachOp mop args -> pprMachOpApp mop args
+
+    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"
+
+
+pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
+pprLoad dflags e ty
+  | width == W64, wordWidth dflags /= W64
+  = (if isFloatType ty then text "PK_DBL"
+                       else text "PK_Word64")
+    <> parens (mkP_ <> pprExpr1 e)
+
+  | otherwise
+  = case e of
+        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
+                 -> char '*' <> pprAsPtrReg r
+
+        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
+                      -> char '*' <> pprAsPtrReg r
+
+        CmmRegOff r off | isPtrReg r && width == wordWidth dflags
+                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)
+        -- ToDo: check that the offset is a word multiple?
+        --       (For tagging to work, I had to avoid unaligned loads. --ARY)
+                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))
+
+        _other -> cLoad e ty
+  where
+    width = typeWidth ty
+
+pprExpr1 :: CmmExpr -> SDoc
+pprExpr1 (CmmLit lit)     = pprLit1 lit
+pprExpr1 e@(CmmReg _reg)  = pprExpr e
+pprExpr1 other            = parens (pprExpr other)
+
+-- --------------------------------------------------------------------------
+-- MachOp applications
+
+pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
+
+pprMachOpApp op args
+  | isMulMayOfloOp op
+  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))
+  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
+        isMulMayOfloOp (MO_S_MulMayOflo _) = True
+        isMulMayOfloOp _ = False
+
+pprMachOpApp mop args
+  | Just ty <- machOpNeedsCast mop
+  = ty <> parens (pprMachOpApp' mop args)
+  | otherwise
+  = pprMachOpApp' mop args
+
+-- Comparisons in C have type 'int', but we want type W_ (this is what
+-- resultRepOfMachOp says).  The other C operations inherit their type
+-- from their operands, so no casting is required.
+machOpNeedsCast :: MachOp -> Maybe SDoc
+machOpNeedsCast mop
+  | isComparisonMachOp mop = Just mkW_
+  | otherwise              = Nothing
+
+pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp' mop args
+ = case args of
+    -- dyadic
+    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
+
+    -- unary
+    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)
+
+    _     -> panic "PprC.pprMachOp : machop with wrong number of args"
+
+  where
+        -- Cast needed for signed integer ops
+    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->
+                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e
+             | needsFCasts mop = sdocWithDynFlags $ \dflags ->
+                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e
+             | otherwise    = pprExpr1 e
+    needsFCasts (MO_F_Eq _)   = False
+    needsFCasts (MO_F_Ne _)   = False
+    needsFCasts (MO_F_Neg _)  = True
+    needsFCasts (MO_F_Quot _) = True
+    needsFCasts mop  = floatComparison mop
+
+-- --------------------------------------------------------------------------
+-- Literals
+
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+    CmmInt i rep      -> pprHexVal i rep
+
+    CmmFloat f w       -> parens (machRep_F_CType w) <> str
+        where d = fromRational f :: Double
+              str | isInfinite d && d < 0 = text "-INFINITY"
+                  | isInfinite d          = text "INFINITY"
+                  | isNaN d               = text "NAN"
+                  | otherwise             = text (show d)
+                -- these constants come from <math.h>
+                -- see #1861
+
+    CmmVec {} -> panic "PprC printing vector literal"
+
+    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
+    CmmHighStackMark   -> panic "PprC printing high stack mark"
+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
+    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C
+        -- WARNING:
+        --  * the lit must occur in the info table clbl2
+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+    where
+        pprCLabelAddr lbl = char '&' <> ppr lbl
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
+pprLit1 other = pprLit other
+
+-- ---------------------------------------------------------------------------
+-- Static data
+
+pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
+pprStatics _ [] = []
+pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)
+  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
+  -- adjacent floats aren't padded but combined into a single word
+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest
+  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'
+  | wORD_SIZE dflags == 4
+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
+  | otherwise
+  = pprPanic "pprStatics: float" (vcat (map ppr' rest))
+    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
+                                  ppr (cmmLitType dflags l)
+          ppr' _other           = text "bad static!"
+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
+  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
+
+pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
+  | wordWidth dflags == W32
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :
+                            CmmStaticLit (CmmInt r W32) : rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :
+                            CmmStaticLit (CmmInt q W32) : rest)
+  where r = i .&. 0xffffffff
+        q = i `shiftR` 32
+pprStatics dflags (CmmStaticLit (CmmInt a W32) :
+                   CmmStaticLit (CmmInt b W32) : rest)
+  | wordWidth dflags == W64
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :
+                            rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :
+                            rest)
+pprStatics dflags (CmmStaticLit (CmmInt a W16) :
+                   CmmStaticLit (CmmInt b W16) : rest)
+  | wordWidth dflags == W32
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :
+                            rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :
+                            rest)
+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
+  | w /= wordWidth dflags
+  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
+pprStatics dflags (CmmStaticLit lit : rest)
+  = pprLit1 lit : pprStatics dflags rest
+pprStatics _ (other : _)
+  = pprPanic "pprStatics: other" (pprStatic other)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+
+    CmmStaticLit lit   -> nest 4 (pprLit lit)
+    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
+
+    -- these should be inlined, like the old .hc
+    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+
+
+-- ---------------------------------------------------------------------------
+-- Block Ids
+
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = char '_' <> ppr (getUnique b)
+
+-- --------------------------------------------------------------------------
+-- Print a MachOp in a way suitable for emitting via C.
+--
+
+pprMachOp_for_C :: MachOp -> SDoc
+
+pprMachOp_for_C mop = case mop of
+
+        -- Integer operations
+        MO_Add          _ -> char '+'
+        MO_Sub          _ -> char '-'
+        MO_Eq           _ -> text "=="
+        MO_Ne           _ -> text "!="
+        MO_Mul          _ -> char '*'
+
+        MO_S_Quot       _ -> char '/'
+        MO_S_Rem        _ -> char '%'
+        MO_S_Neg        _ -> char '-'
+
+        MO_U_Quot       _ -> char '/'
+        MO_U_Rem        _ -> char '%'
+
+        -- & Floating-point operations
+        MO_F_Add        _ -> char '+'
+        MO_F_Sub        _ -> char '-'
+        MO_F_Neg        _ -> char '-'
+        MO_F_Mul        _ -> char '*'
+        MO_F_Quot       _ -> char '/'
+
+        -- Signed comparisons
+        MO_S_Ge         _ -> text ">="
+        MO_S_Le         _ -> text "<="
+        MO_S_Gt         _ -> char '>'
+        MO_S_Lt         _ -> char '<'
+
+        -- & Unsigned comparisons
+        MO_U_Ge         _ -> text ">="
+        MO_U_Le         _ -> text "<="
+        MO_U_Gt         _ -> char '>'
+        MO_U_Lt         _ -> char '<'
+
+        -- & Floating-point comparisons
+        MO_F_Eq         _ -> text "=="
+        MO_F_Ne         _ -> text "!="
+        MO_F_Ge         _ -> text ">="
+        MO_F_Le         _ -> text "<="
+        MO_F_Gt         _ -> char '>'
+        MO_F_Lt         _ -> char '<'
+
+        -- Bitwise operations.  Not all of these may be supported at all
+        -- sizes, and only integral MachReps are valid.
+        MO_And          _ -> char '&'
+        MO_Or           _ -> char '|'
+        MO_Xor          _ -> char '^'
+        MO_Not          _ -> char '~'
+        MO_Shl          _ -> text "<<"
+        MO_U_Shr        _ -> text ">>" -- unsigned shift right
+        MO_S_Shr        _ -> text ">>" -- signed shift right
+
+-- Conversions.  Some of these will be NOPs, but never those that convert
+-- between ints and floats.
+-- Floating-point conversions use the signed variant.
+-- We won't know to generate (void*) casts here, but maybe from
+-- context elsewhere
+
+-- noop casts
+        MO_UU_Conv from to | from == to -> empty
+        MO_UU_Conv _from to -> parens (machRep_U_CType to)
+
+        MO_SS_Conv from to | from == to -> empty
+        MO_SS_Conv _from to -> parens (machRep_S_CType to)
+
+        MO_XX_Conv from to | from == to -> empty
+        MO_XX_Conv _from to -> parens (machRep_U_CType to)
+
+        MO_FF_Conv from to | from == to -> empty
+        MO_FF_Conv _from to -> parens (machRep_F_CType to)
+
+        MO_SF_Conv _from to -> parens (machRep_F_CType to)
+        MO_FS_Conv _from to -> parens (machRep_S_CType to)
+
+        MO_S_MulMayOflo _ -> pprTrace "offending mop:"
+                                (text "MO_S_MulMayOflo")
+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
+                                      ++ " should have been handled earlier!")
+        MO_U_MulMayOflo _ -> pprTrace "offending mop:"
+                                (text "MO_U_MulMayOflo")
+                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
+                                      ++ " should have been handled earlier!")
+
+        MO_V_Insert {}    -> pprTrace "offending mop:"
+                                (text "MO_V_Insert")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
+                                      ++ " should have been handled earlier!")
+        MO_V_Extract {}   -> pprTrace "offending mop:"
+                                (text "MO_V_Extract")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
+                                      ++ " should have been handled earlier!")
+
+        MO_V_Add {}       -> pprTrace "offending mop:"
+                                (text "MO_V_Add")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
+                                      ++ " should have been handled earlier!")
+        MO_V_Sub {}       -> pprTrace "offending mop:"
+                                (text "MO_V_Sub")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
+                                      ++ " should have been handled earlier!")
+        MO_V_Mul {}       -> pprTrace "offending mop:"
+                                (text "MO_V_Mul")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
+                                      ++ " should have been handled earlier!")
+
+        MO_VS_Quot {}     -> pprTrace "offending mop:"
+                                (text "MO_VS_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
+                                      ++ " should have been handled earlier!")
+        MO_VS_Rem {}      -> pprTrace "offending mop:"
+                                (text "MO_VS_Rem")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
+                                      ++ " should have been handled earlier!")
+        MO_VS_Neg {}      -> pprTrace "offending mop:"
+                                (text "MO_VS_Neg")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
+                                      ++ " should have been handled earlier!")
+
+        MO_VU_Quot {}     -> pprTrace "offending mop:"
+                                (text "MO_VU_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"
+                                      ++ " should have been handled earlier!")
+        MO_VU_Rem {}      -> pprTrace "offending mop:"
+                                (text "MO_VU_Rem")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
+                                      ++ " should have been handled earlier!")
+
+        MO_VF_Insert {}   -> pprTrace "offending mop:"
+                                (text "MO_VF_Insert")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Extract {}  -> pprTrace "offending mop:"
+                                (text "MO_VF_Extract")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
+                                      ++ " should have been handled earlier!")
+
+        MO_VF_Add {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Add")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Sub {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Sub")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Neg {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Neg")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Mul {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Mul")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Quot {}     -> pprTrace "offending mop:"
+                                (text "MO_VF_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
+                                      ++ " should have been handled earlier!")
+
+        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"
+
+signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
+signedOp (MO_S_Quot _)    = True
+signedOp (MO_S_Rem  _)    = True
+signedOp (MO_S_Neg  _)    = True
+signedOp (MO_S_Ge   _)    = True
+signedOp (MO_S_Le   _)    = True
+signedOp (MO_S_Gt   _)    = True
+signedOp (MO_S_Lt   _)    = True
+signedOp (MO_S_Shr  _)    = True
+signedOp (MO_SS_Conv _ _) = True
+signedOp (MO_SF_Conv _ _) = True
+signedOp _                = False
+
+floatComparison :: MachOp -> Bool  -- comparison between float args
+floatComparison (MO_F_Eq   _) = True
+floatComparison (MO_F_Ne   _) = True
+floatComparison (MO_F_Ge   _) = True
+floatComparison (MO_F_Le   _) = True
+floatComparison (MO_F_Gt   _) = True
+floatComparison (MO_F_Lt   _) = True
+floatComparison _             = False
+
+-- ---------------------------------------------------------------------
+-- tend to be implemented by foreign calls
+
+pprCallishMachOp_for_C :: CallishMachOp -> SDoc
+
+pprCallishMachOp_for_C mop
+    = case mop of
+        MO_F64_Pwr      -> text "pow"
+        MO_F64_Sin      -> text "sin"
+        MO_F64_Cos      -> text "cos"
+        MO_F64_Tan      -> text "tan"
+        MO_F64_Sinh     -> text "sinh"
+        MO_F64_Cosh     -> text "cosh"
+        MO_F64_Tanh     -> text "tanh"
+        MO_F64_Asin     -> text "asin"
+        MO_F64_Acos     -> text "acos"
+        MO_F64_Atanh    -> text "atanh"
+        MO_F64_Asinh    -> text "asinh"
+        MO_F64_Acosh    -> text "acosh"
+        MO_F64_Atan     -> text "atan"
+        MO_F64_Log      -> text "log"
+        MO_F64_Exp      -> text "exp"
+        MO_F64_Sqrt     -> text "sqrt"
+        MO_F64_Fabs     -> text "fabs"
+        MO_F32_Pwr      -> text "powf"
+        MO_F32_Sin      -> text "sinf"
+        MO_F32_Cos      -> text "cosf"
+        MO_F32_Tan      -> text "tanf"
+        MO_F32_Sinh     -> text "sinhf"
+        MO_F32_Cosh     -> text "coshf"
+        MO_F32_Tanh     -> text "tanhf"
+        MO_F32_Asin     -> text "asinf"
+        MO_F32_Acos     -> text "acosf"
+        MO_F32_Atan     -> text "atanf"
+        MO_F32_Asinh    -> text "asinhf"
+        MO_F32_Acosh    -> text "acoshf"
+        MO_F32_Atanh    -> text "atanhf"
+        MO_F32_Log      -> text "logf"
+        MO_F32_Exp      -> text "expf"
+        MO_F32_Sqrt     -> text "sqrtf"
+        MO_F32_Fabs     -> text "fabsf"
+        MO_WriteBarrier -> text "write_barrier"
+        MO_Memcpy _     -> text "memcpy"
+        MO_Memset _     -> text "memset"
+        MO_Memmove _    -> text "memmove"
+        MO_Memcmp _     -> text "memcmp"
+        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
+        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)
+        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)
+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)
+        (MO_Clz w)      -> ptext (sLit $ clzLabel w)
+        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)
+        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
+        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)
+        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)
+        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
+        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)
+
+        MO_S_QuotRem  {} -> unsupported
+        MO_U_QuotRem  {} -> unsupported
+        MO_U_QuotRem2 {} -> unsupported
+        MO_Add2       {} -> unsupported
+        MO_AddWordC   {} -> unsupported
+        MO_SubWordC   {} -> unsupported
+        MO_AddIntC    {} -> unsupported
+        MO_SubIntC    {} -> unsupported
+        MO_U_Mul2     {} -> unsupported
+        MO_Touch         -> unsupported
+        (MO_Prefetch_Data _ ) -> unsupported
+        --- we could support prefetch via "__builtin_prefetch"
+        --- Not adding it for now
+    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
+                            ++ " not supported!")
+
+-- ---------------------------------------------------------------------
+-- Useful #defines
+--
+
+mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
+
+mkJMP_ i = text "JMP_" <> parens i
+mkFN_  i = text "FN_"  <> parens i -- externally visible function
+mkIF_  i = text "IF_"  <> parens i -- locally visible
+
+-- from includes/Stg.h
+--
+mkC_,mkW_,mkP_ :: SDoc
+
+mkC_  = text "(C_)"        -- StgChar
+mkW_  = text "(W_)"        -- StgWord
+mkP_  = text "(P_)"        -- StgWord*
+
+-- ---------------------------------------------------------------------
+--
+-- Assignments
+--
+-- Generating assignments is what we're all about, here
+--
+pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc
+
+-- dest is a reg, rhs is a reg
+pprAssign _ r1 (CmmReg r2)
+   | isPtrReg r1 && isPtrReg r2
+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
+
+-- dest is a reg, rhs is a CmmRegOff
+pprAssign dflags r1 (CmmRegOff r2 off)
+   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
+  where
+        off1 = off `shiftR` wordShift dflags
+
+        (op,off') | off >= 0  = (char '+', off1)
+                  | otherwise = (char '-', -off1)
+
+-- dest is a reg, rhs is anything.
+-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
+-- the lvalue elicits a warning from new GCC versions (3.4+).
+pprAssign _ r1 r2
+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)
+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
+  | otherwise                    = mkAssign (pprExpr r2)
+    where mkAssign x = if r1 == CmmGlobal BaseReg
+                       then text "ASSIGN_BaseReg" <> parens x <> semi
+                       else pprReg r1 <> text " = " <> x <> semi
+
+-- ---------------------------------------------------------------------
+-- Registers
+
+pprCastReg :: CmmReg -> SDoc
+pprCastReg reg
+   | isStrangeTypeReg reg = mkW_ <> pprReg reg
+   | otherwise            = pprReg reg
+
+-- True if (pprReg reg) will give an expression with type StgPtr.  We
+-- need to take care with pointer arithmetic on registers with type
+-- StgPtr.
+isFixedPtrReg :: CmmReg -> Bool
+isFixedPtrReg (CmmLocal _) = False
+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
+
+-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
+isPtrReg :: CmmReg -> Bool
+isPtrReg (CmmLocal _)                         = False
+isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg
+
+-- True if this global reg has type StgPtr
+isFixedPtrGlobalReg :: GlobalReg -> Bool
+isFixedPtrGlobalReg Sp    = True
+isFixedPtrGlobalReg Hp    = True
+isFixedPtrGlobalReg HpLim = True
+isFixedPtrGlobalReg SpLim = True
+isFixedPtrGlobalReg _     = False
+
+-- True if in C this register doesn't have the type given by
+-- (machRepCType (cmmRegType reg)), so it has to be cast.
+isStrangeTypeReg :: CmmReg -> Bool
+isStrangeTypeReg (CmmLocal _)   = False
+isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
+
+isStrangeTypeGlobal :: GlobalReg -> Bool
+isStrangeTypeGlobal CCCS                = True
+isStrangeTypeGlobal CurrentTSO          = True
+isStrangeTypeGlobal CurrentNursery      = True
+isStrangeTypeGlobal BaseReg             = True
+isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
+
+strangeRegType :: CmmReg -> Maybe SDoc
+strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")
+strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")
+strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")
+strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")
+strangeRegType _ = Nothing
+
+-- pprReg just prints the register name.
+--
+pprReg :: CmmReg -> SDoc
+pprReg r = case r of
+        CmmLocal  local  -> pprLocalReg local
+        CmmGlobal global -> pprGlobalReg global
+
+pprAsPtrReg :: CmmReg -> SDoc
+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
+  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"
+pprAsPtrReg other_reg = pprReg other_reg
+
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr = case gr of
+    VanillaReg n _ -> char 'R' <> int n  <> text ".w"
+        -- pprGlobalReg prints a VanillaReg as a .w regardless
+        -- Example:     R1.w = R1.w & (-0x8UL);
+        --              JMP_(*R1.p);
+    FloatReg   n   -> char 'F' <> int n
+    DoubleReg  n   -> char 'D' <> int n
+    LongReg    n   -> char 'L' <> int n
+    Sp             -> text "Sp"
+    SpLim          -> text "SpLim"
+    Hp             -> text "Hp"
+    HpLim          -> text "HpLim"
+    CCCS           -> text "CCCS"
+    CurrentTSO     -> text "CurrentTSO"
+    CurrentNursery -> text "CurrentNursery"
+    HpAlloc        -> text "HpAlloc"
+    BaseReg        -> text "BaseReg"
+    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+    GCEnter1       -> text "stg_gc_enter_1"
+    GCFun          -> text "stg_gc_fun"
+    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
+
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
+
+-- -----------------------------------------------------------------------------
+-- Foreign Calls
+
+pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCall ppr_fn cconv results args
+  | not (is_cishCC cconv)
+  = panic $ "pprCall: unknown calling convention"
+
+  | otherwise
+  =
+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
+  where
+     ppr_assign []           rhs = rhs
+     ppr_assign [(one,hint)] rhs
+         = pprLocalReg one <> text " = "
+                 <> pprUnHint hint (localRegType one) <> rhs
+     ppr_assign _other _rhs = panic "pprCall: multiple results"
+
+     pprArg (expr, AddrHint)
+        = cCast (text "void *") expr
+        -- see comment by machRepHintCType below
+     pprArg (expr, SignedHint)
+        = sdocWithDynFlags $ \dflags ->
+          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
+     pprArg (expr, _other)
+        = pprExpr expr
+
+     pprUnHint AddrHint   rep = parens (machRepCType rep)
+     pprUnHint SignedHint rep = parens (machRepCType rep)
+     pprUnHint _          _   = empty
+
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
+is_cishCC :: CCallConv -> Bool
+is_cishCC CCallConv    = True
+is_cishCC CApiConv     = True
+is_cishCC StdCallConv  = True
+is_cishCC PrimCallConv = False
+is_cishCC JavaScriptCallConv = False
+
+-- ---------------------------------------------------------------------
+-- Find and print local and external declarations for a list of
+-- Cmm statements.
+--
+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls stmts
+  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),
+     vcat (map pprExternDecl (Map.keys lbls)))
+  where (temps, lbls) = runTE (mapM_ te_BB stmts)
+
+pprDataExterns :: [CmmStatic] -> SDoc
+pprDataExterns statics
+  = vcat (map pprExternDecl (Map.keys lbls))
+  where (_, lbls) = runTE (mapM_ te_Static statics)
+
+pprTempDecl :: LocalReg -> SDoc
+pprTempDecl l@(LocalReg _ rep)
+  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
+
+pprExternDecl :: CLabel -> SDoc
+pprExternDecl lbl
+  -- do not print anything for "known external" things
+  | not (needsCDecl lbl) = empty
+  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
+  | otherwise =
+        hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"
+             -- occasionally useful to see label type
+             -- , text "/* ", pprDebugCLabel lbl, text " */"
+             ]
+ where
+  label_type lbl | isBytesLabel lbl         = text "B_"
+                 | isForeignLabel lbl && isCFunctionLabel lbl
+                                            = text "FF_"
+                 | isCFunctionLabel lbl     = text "F_"
+                 | isStaticClosureLabel lbl = text "C_"
+                 -- generic .rodata labels
+                 | isSomeRODataLabel lbl    = text "RO_"
+                 -- generic .data labels (common case)
+                 | otherwise                = text "RW_"
+
+  visibility
+     | externallyVisibleCLabel lbl = char 'E'
+     | otherwise                   = char 'I'
+
+  -- If the label we want to refer to is a stdcall function (on Windows) then
+  -- we must generate an appropriate prototype for it, so that the C compiler will
+  -- add the @n suffix to the label (#2276)
+  stdcall_decl sz = sdocWithDynFlags $ \dflags ->
+        text "extern __attribute__((stdcall)) void " <> ppr lbl
+        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))
+        <> semi
+
+type TEState = (UniqSet LocalReg, Map CLabel ())
+newtype TE a = TE { unTE :: TEState -> (a, TEState) }
+
+instance Functor TE where
+      fmap = liftM
+
+instance Applicative TE where
+      pure a = TE $ \s -> (a, s)
+      (<*>) = ap
+
+instance Monad TE where
+   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
+
+te_lbl :: CLabel -> TE ()
+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
+
+te_temp :: LocalReg -> TE ()
+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
+
+runTE :: TE () -> TEState
+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
+
+te_Static :: CmmStatic -> TE ()
+te_Static (CmmStaticLit lit) = te_Lit lit
+te_Static _ = return ()
+
+te_BB :: CmmBlock -> TE ()
+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
+  where (_, mid, last) = blockSplit block
+
+te_Lit :: CmmLit -> TE ()
+te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1
+te_Lit _ = return ()
+
+te_Stmt :: CmmNode e x -> TE ()
+te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
+te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r
+te_Stmt (CmmUnsafeForeignCall target rs es)
+  = do  te_Target target
+        mapM_ te_temp rs
+        mapM_ te_Expr es
+te_Stmt (CmmCondBranch e _ _ _) = te_Expr e
+te_Stmt (CmmSwitch e _)         = te_Expr e
+te_Stmt (CmmCall { cml_target = e }) = te_Expr e
+te_Stmt _                       = return ()
+
+te_Target :: ForeignTarget -> TE ()
+te_Target (ForeignTarget e _)      = te_Expr e
+te_Target (PrimTarget{})           = return ()
+
+te_Expr :: CmmExpr -> TE ()
+te_Expr (CmmLit lit)            = te_Lit lit
+te_Expr (CmmLoad e _)           = te_Expr e
+te_Expr (CmmReg r)              = te_Reg r
+te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es
+te_Expr (CmmRegOff r _)         = te_Reg r
+te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"
+
+te_Reg :: CmmReg -> TE ()
+te_Reg (CmmLocal l) = te_temp l
+te_Reg _            = return ()
+
+
+-- ---------------------------------------------------------------------
+-- C types for MachReps
+
+cCast :: SDoc -> CmmExpr -> SDoc
+cCast ty expr = parens ty <> pprExpr1 expr
+
+cLoad :: CmmExpr -> CmmType -> SDoc
+cLoad expr rep
+    = sdocWithPlatform $ \platform ->
+      if bewareLoadStoreAlignment (platformArch platform)
+      then let decl = machRepCType rep <+> text "x" <> semi
+               struct = text "struct" <+> braces (decl)
+               packed_attr = text "__attribute__((packed))"
+               cast = parens (struct <+> packed_attr <> char '*')
+           in parens (cast <+> pprExpr1 expr) <> text "->x"
+      else char '*' <> parens (cCast (machRepPtrCType rep) expr)
+    where -- On these platforms, unaligned loads are known to cause problems
+          bewareLoadStoreAlignment ArchAlpha    = True
+          bewareLoadStoreAlignment ArchMipseb   = True
+          bewareLoadStoreAlignment ArchMipsel   = True
+          bewareLoadStoreAlignment (ArchARM {}) = True
+          bewareLoadStoreAlignment ArchARM64    = True
+          bewareLoadStoreAlignment ArchSPARC    = True
+          bewareLoadStoreAlignment ArchSPARC64  = True
+          -- Pessimistically assume that they will also cause problems
+          -- on unknown arches
+          bewareLoadStoreAlignment ArchUnknown  = True
+          bewareLoadStoreAlignment _            = False
+
+isCmmWordType :: DynFlags -> CmmType -> Bool
+-- True of GcPtrReg/NonGcReg of native word size
+isCmmWordType dflags ty = not (isFloatType ty)
+                       && typeWidth ty == wordWidth dflags
+
+-- This is for finding the types of foreign call arguments.  For a pointer
+-- argument, we always cast the argument to (void *), to avoid warnings from
+-- the C compiler.
+machRepHintCType :: CmmType -> ForeignHint -> SDoc
+machRepHintCType _   AddrHint   = text "void *"
+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
+machRepHintCType rep _other     = machRepCType rep
+
+machRepPtrCType :: CmmType -> SDoc
+machRepPtrCType r
+ = sdocWithDynFlags $ \dflags ->
+   if isCmmWordType dflags r then text "P_"
+                             else machRepCType r <> char '*'
+
+machRepCType :: CmmType -> SDoc
+machRepCType ty | isFloatType ty = machRep_F_CType w
+                | otherwise      = machRep_U_CType w
+                where
+                  w = typeWidth ty
+
+machRep_F_CType :: Width -> SDoc
+machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?
+machRep_F_CType W64 = text "StgDouble"
+machRep_F_CType _   = panic "machRep_F_CType"
+
+machRep_U_CType :: Width -> SDoc
+machRep_U_CType w
+ = sdocWithDynFlags $ \dflags ->
+   case w of
+   _ | w == wordWidth dflags -> text "W_"
+   W8  -> text "StgWord8"
+   W16 -> text "StgWord16"
+   W32 -> text "StgWord32"
+   W64 -> text "StgWord64"
+   _   -> panic "machRep_U_CType"
+
+machRep_S_CType :: Width -> SDoc
+machRep_S_CType w
+ = sdocWithDynFlags $ \dflags ->
+   case w of
+   _ | w == wordWidth dflags -> text "I_"
+   W8  -> text "StgInt8"
+   W16 -> text "StgInt16"
+   W32 -> text "StgInt32"
+   W64 -> text "StgInt64"
+   _   -> panic "machRep_S_CType"
+
+
+-- ---------------------------------------------------------------------
+-- print strings as valid C strings
+
+pprStringInCStyle :: ByteString -> SDoc
+pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))
+
+-- ---------------------------------------------------------------------------
+-- Initialising static objects with floating-point numbers.  We can't
+-- just emit the floating point number, because C will cast it to an int
+-- by rounding it.  We want the actual bit-representation of the float.
+--
+-- Consider a concrete C example:
+--    double d = 2.5e-10;
+--    float f  = 2.5e-10f;
+--
+--    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);
+--    long long * l = &d; printf (" l: %016llX\n",   l[0]);
+--    int * i = &f;       printf (" i: %08X\n",      i[0]);
+-- Result on 64-bit LE (x86_64):
+--     i2: E826D695 3DF12E0B
+--      l: 3DF12E0BE826D695
+--      i: 2F89705F
+-- Result on 32-bit BE (m68k):
+--     i2: 3DF12E0B E826D695
+--      l: 3DF12E0BE826D695
+--      i: 2F89705F
+--
+-- The trick here is to notice that binary representation does not
+-- change much: only Word32 values get swapped on LE hosts / targets.
+
+-- This is a hack to turn the floating point numbers into ints that we
+-- can safely initialise to static locations.
+
+castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
+castFloatToWord32Array = U.castSTUArray
+
+castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
+castDoubleToWord64Array = U.castSTUArray
+
+floatToWord :: DynFlags -> Rational -> CmmLit
+floatToWord dflags r
+  = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 (fromRational r)
+        arr' <- castFloatToWord32Array arr
+        w32 <- readArray arr' 0
+        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))
+    )
+    where wo | wordWidth dflags == W64
+             , wORDS_BIGENDIAN dflags    = 32
+             | otherwise                 = 0
+
+floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit
+floatPairToWord dflags r1 r2
+  = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 (fromRational r1)
+        writeArray arr 1 (fromRational r2)
+        arr' <- castFloatToWord32Array arr
+        w32_1 <- readArray arr' 0
+        w32_2 <- readArray arr' 1
+        return (pprWord32Pair w32_1 w32_2)
+    )
+    where pprWord32Pair w32_1 w32_2
+              | wORDS_BIGENDIAN dflags =
+                  CmmInt ((shiftL i1 32) .|. i2) W64
+              | otherwise =
+                  CmmInt ((shiftL i2 32) .|. i1) W64
+              where i1 = toInteger w32_1
+                    i2 = toInteger w32_2
+
+doubleToWords :: DynFlags -> Rational -> [CmmLit]
+doubleToWords dflags r
+  = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 (fromRational r)
+        arr' <- castDoubleToWord64Array arr
+        w64 <- readArray arr' 0
+        return (pprWord64 w64)
+    )
+    where targetWidth = wordWidth dflags
+          targetBE    = wORDS_BIGENDIAN dflags
+          pprWord64 w64
+              | targetWidth == W64 =
+                  [ CmmInt (toInteger w64) targetWidth ]
+              | targetWidth == W32 =
+                  [ CmmInt (toInteger targetW1) targetWidth
+                  , CmmInt (toInteger targetW2) targetWidth
+                  ]
+              | otherwise = panic "doubleToWords.pprWord64"
+              where (targetW1, targetW2)
+                        | targetBE  = (wHi, wLo)
+                        | otherwise = (wLo, wHi)
+                    wHi = w64 `shiftR` 32
+                    wLo = w64 .&. 0xFFFFffff
+
+-- ---------------------------------------------------------------------------
+-- Utils
+
+wordShift :: DynFlags -> Int
+wordShift dflags = widthInLog (wordWidth dflags)
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+
+-- Print in C hex format: 0x13fa
+pprHexVal :: Integer -> Width -> SDoc
+pprHexVal w rep
+  | w < 0     = parens (char '-' <>
+                    text "0x" <> intToDoc (-w) <> repsuffix rep)
+  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep
+  where
+        -- type suffix for literals:
+        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
+        -- signed values for doing signed operations, but at all other
+        -- times values are unsigned.  This also helps eliminate occasional
+        -- warnings about integer overflow from gcc.
+
+      repsuffix W64 = sdocWithDynFlags $ \dflags ->
+               if cINT_SIZE       dflags == 8 then char 'U'
+          else if cLONG_SIZE      dflags == 8 then text "UL"
+          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"
+          else panic "pprHexVal: Can't find a 64-bit type"
+      repsuffix _ = char 'U'
+
+      intToDoc :: Integer -> SDoc
+      intToDoc i = case truncInt i of
+                       0 -> char '0'
+                       v -> go v
+
+      -- We need to truncate value as Cmm backend does not drop
+      -- redundant bits to ease handling of negative values.
+      -- Thus the following Cmm code on 64-bit arch, like amd64:
+      --     CInt v;
+      --     v = {something};
+      --     if (v == %lobits32(-1)) { ...
+      -- leads to the following C code:
+      --     StgWord64 v = (StgWord32)({something});
+      --     if (v == 0xFFFFffffFFFFffffU) { ...
+      -- Such code is incorrect as it promotes both operands to StgWord64
+      -- and the whole condition is always false.
+      truncInt :: Integer -> Integer
+      truncInt i =
+          case rep of
+              W8  -> i `rem` (2^(8 :: Int))
+              W16 -> i `rem` (2^(16 :: Int))
+              W32 -> i `rem` (2^(32 :: Int))
+              W64 -> i `rem` (2^(64 :: Int))
+              _   -> panic ("pprHexVal/truncInt: C backend can't encode "
+                            ++ show rep ++ " literals")
+
+      go 0 = empty
+      go w' = go q <> dig
+           where
+             (q,r) = w' `quotRem` 16
+             dig | r < 10    = char (chr (fromInteger r + ord '0'))
+                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprCmm.hs
@@ -0,0 +1,311 @@
+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as (a superset of) C--
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+--
+-- This is where we walk over CmmNode emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+
+module PprCmm
+  ( module PprCmmDecl
+  , module PprCmmExpr
+  )
+where
+
+import GhcPrelude hiding (succ)
+
+import BlockId ()
+import CLabel
+import Cmm
+import CmmUtils
+import CmmSwitch
+import DynFlags
+import FastString
+import Outputable
+import PprCmmDecl
+import PprCmmExpr
+import Util
+import PprCore ()
+
+import BasicTypes
+import Hoopl.Block
+import Hoopl.Graph
+
+-------------------------------------------------
+-- Outputable instances
+
+instance Outputable CmmStackInfo where
+    ppr = pprStackInfo
+
+instance Outputable CmmTopInfo where
+    ppr = pprTopInfo
+
+
+instance Outputable (CmmNode e x) where
+    ppr = pprNode
+
+instance Outputable Convention where
+    ppr = pprConvention
+
+instance Outputable ForeignConvention where
+    ppr = pprForeignConvention
+
+instance Outputable ForeignTarget where
+    ppr = pprForeignTarget
+
+instance Outputable CmmReturnInfo where
+    ppr = pprReturnInfo
+
+instance Outputable (Block CmmNode C C) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode C O) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode O C) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode O O) where
+    ppr = pprBlock
+
+instance Outputable (Graph CmmNode e x) where
+    ppr = pprGraph
+
+instance Outputable CmmGraph where
+    ppr = pprCmmGraph
+
+----------------------------------------------------------
+-- Outputting types Cmm contains
+
+pprStackInfo :: CmmStackInfo -> SDoc
+pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
+  text "arg_space: " <> ppr arg_space <+>
+  text "updfr_space: " <> ppr updfr_space
+
+pprTopInfo :: CmmTopInfo -> SDoc
+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
+  vcat [text "info_tbls: " <> ppr info_tbl,
+        text "stack_info: " <> ppr stack_info]
+
+----------------------------------------------------------
+-- Outputting blocks and graphs
+
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
+         => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock block
+    = foldBlockNodesB3 ( ($$) . ppr
+                       , ($$) . (nest 4) . ppr
+                       , ($$) . (nest 4) . ppr
+                       )
+                       block
+                       empty
+
+pprGraph :: Graph CmmNode e x -> SDoc
+pprGraph GNil = empty
+pprGraph (GUnit block) = ppr block
+pprGraph (GMany entry body exit)
+   = text "{"
+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
+  $$ text "}"
+  where pprMaybeO :: Outputable (Block CmmNode e x)
+                  => MaybeO ex (Block CmmNode e x) -> SDoc
+        pprMaybeO NothingO = empty
+        pprMaybeO (JustO block) = ppr block
+
+pprCmmGraph :: CmmGraph -> SDoc
+pprCmmGraph g
+   = text "{" <> text "offset"
+  $$ nest 2 (vcat $ map ppr blocks)
+  $$ text "}"
+  where blocks = revPostorder g
+    -- revPostorder has the side-effect of discarding unreachable code,
+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
+    -- sometimes be confusing.
+
+---------------------------------------------
+-- Outputting CmmNode and types which it contains
+
+pprConvention :: Convention -> SDoc
+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
+pprConvention (NativeReturn {})     = text "<native-ret-convention>"
+pprConvention  Slow                 = text "<slow-convention>"
+pprConvention  GC                   = text "<gc-convention>"
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c args res ret) =
+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
+pprForeignTarget :: ForeignTarget -> SDoc
+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
+  where
+        ppr_target :: CmmExpr -> SDoc
+        ppr_target t@(CmmLit _) = ppr t
+        ppr_target fn'          = parens (ppr fn')
+
+pprForeignTarget (PrimTarget op)
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ --       might not really be foreign.
+ = ppr
+               (CmmLabel (mkForeignLabel
+                         (mkFastString (show op))
+                         Nothing ForeignLabelInThisPackage IsFunction))
+
+pprNode :: CmmNode e x -> SDoc
+pprNode node = pp_node <+> pp_debug
+  where
+    pp_node :: SDoc
+    pp_node = sdocWithDynFlags $ \dflags -> case node of
+      -- label:
+      CmmEntry id tscope -> lbl <> colon <+>
+         (sdocWithDynFlags $ \dflags ->
+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
+          where
+            lbl = if gopt Opt_SuppressUniques dflags
+                then text "_lbl_"
+                else ppr id
+
+      -- // text
+      CmmComment s -> text "//" <+> ftext s
+
+      -- //tick bla<...>
+      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
+                   text "//tick" <+> ppr t
+
+      -- unwind reg = expr;
+      CmmUnwind regs ->
+          text "unwind "
+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
+
+      -- reg = expr;
+      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+      -- rep[lv] = expr;
+      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+          where
+            rep = sdocWithDynFlags $ \dflags ->
+                  ppr ( cmmExprType dflags expr )
+
+      -- call "ccall" foo(x, y)[r1, r2];
+      -- ToDo ppr volatile
+      CmmUnsafeForeignCall target results args ->
+          hsep [ ppUnless (null results) $
+                    parens (commafy $ map ppr results) <+> equals,
+                 text "call",
+                 ppr target <> parens (commafy $ map ppr args) <> semi]
+
+      -- goto label;
+      CmmBranch ident -> text "goto" <+> ppr ident <> semi
+
+      -- if (expr) goto t; else goto f;
+      CmmCondBranch expr t f l ->
+          hsep [ text "if"
+               , parens(ppr expr)
+               , case l of
+                   Nothing -> empty
+                   Just b -> parens (text "likely:" <+> ppr b)
+               , text "goto"
+               , ppr t <> semi
+               , text "else goto"
+               , ppr f <> semi
+               ]
+
+      CmmSwitch expr ids ->
+          hang (hsep [ text "switch"
+                     , range
+                     , if isTrivialCmmExpr expr
+                       then ppr expr
+                       else parens (ppr expr)
+                     , text "{"
+                     ])
+             4 (vcat (map ppCase cases) $$ def) $$ rbrace
+          where
+            (cases, mbdef) = switchTargetsFallThrough ids
+            ppCase (is,l) = hsep
+                            [ text "case"
+                            , commafy $ map integer is
+                            , text ": goto"
+                            , ppr l <> semi
+                            ]
+            def | Just l <- mbdef = hsep
+                            [ text "default:"
+                            , braces (text "goto" <+> ppr l <> semi)
+                            ]
+                | otherwise = empty
+
+            range = brackets $ hsep [integer lo, text "..", integer hi]
+              where (lo,hi) = switchTargetsRange ids
+
+      CmmCall tgt k regs out res updfr_off ->
+          hcat [ text "call", space
+               , pprFun tgt, parens (interpp'SP regs), space
+               , returns <+>
+                 text "args: " <> ppr out <> comma <+>
+                 text "res: " <> ppr res <> comma <+>
+                 text "upd: " <> ppr updfr_off
+               , semi ]
+          where pprFun f@(CmmLit _) = ppr f
+                pprFun f = parens (ppr f)
+
+                returns
+                  | Just r <- k = text "returns to" <+> ppr r <> comma
+                  | otherwise   = empty
+
+      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
+          hcat $ if i then [text "interruptible", space] else [] ++
+               [ text "foreign call", space
+               , ppr t, text "(...)", space
+               , text "returns to" <+> ppr s
+                    <+> text "args:" <+> parens (ppr as)
+                    <+> text "ress:" <+> parens (ppr rs)
+               , text "ret_args:" <+> ppr a
+               , text "ret_off:" <+> ppr u
+               , semi ]
+
+    pp_debug :: SDoc
+    pp_debug =
+      if not debugIsOn then empty
+      else case node of
+             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
+             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
+             CmmTick {}              -> empty
+             CmmUnwind {}            -> text "  // CmmUnwind"
+             CmmAssign {}            -> text "  // CmmAssign"
+             CmmStore {}             -> text "  // CmmStore"
+             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
+             CmmBranch {}            -> text "  // CmmBranch"
+             CmmCondBranch {}        -> text "  // CmmCondBranch"
+             CmmSwitch {}            -> text "  // CmmSwitch"
+             CmmCall {}              -> text "  // CmmCall"
+             CmmForeignCall {}       -> text "  // CmmForeignCall"
+
+    commafy :: [SDoc] -> SDoc
+    commafy xs = hsep $ punctuate comma xs
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -0,0 +1,169 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of common Cmm types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PprCmmDecl
+    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
+    )
+where
+
+import GhcPrelude
+
+import PprCmmExpr
+import Cmm
+
+import DynFlags
+import Outputable
+import FastString
+
+import Data.List
+import System.IO
+
+import qualified Data.ByteString as BS
+
+
+pprCmms :: (Outputable info, Outputable g)
+        => [GenCmmGroup CmmStatics info g] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+        where
+          separator = space $$ text "-------------------" $$ space
+
+writeCmms :: (Outputable info, Outputable g)
+          => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
+writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance (Outputable d, Outputable info, Outputable i)
+      => Outputable (GenCmmDecl d info i) where
+    ppr t = pprTop t
+
+instance Outputable CmmStatics where
+    ppr = pprStatics
+
+instance Outputable CmmStatic where
+    ppr = pprStatic
+
+instance Outputable CmmInfoTable where
+    ppr = pprInfoTable
+
+
+-----------------------------------------------------------------------------
+
+pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
+            => GenCmmGroup d info g -> SDoc
+pprCmmGroup tops
+    = vcat $ intersperse blankLine $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks.
+--
+pprTop :: (Outputable d, Outputable info, Outputable i)
+       => GenCmmDecl d info i -> SDoc
+
+pprTop (CmmProc info lbl live graph)
+
+  = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live
+         , nest 8 $ lbrace <+> ppr info $$ rbrace
+         , nest 4 $ ppr graph
+         , rbrace ]
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+--      section "data" { ... }
+--
+pprTop (CmmData section ds) =
+    (hang (pprSection section <+> lbrace) 4 (ppr ds))
+    $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Info tables.
+
+pprInfoTable :: CmmInfoTable -> SDoc
+pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+                           , cit_prof = prof_info
+                           , cit_srt = srt })
+  = vcat [ text "label: " <> ppr lbl
+         , text "rep: " <> ppr rep
+         , case prof_info of
+             NoProfilingInfo -> empty
+             ProfilingInfo ct cd ->
+               vcat [ text "type: " <> text (show (BS.unpack ct))
+                    , text "desc: " <> text (show (BS.unpack cd)) ]
+         , text "srt: " <> ppr srt ]
+
+instance Outputable ForeignHint where
+  ppr NoHint     = empty
+  ppr SignedHint = quotes(text "signed")
+--  ppr AddrHint   = quotes(text "address")
+-- Temp Jan08
+  ppr AddrHint   = (text "PtrHint")
+
+-- --------------------------------------------------------------------------
+-- Static data.
+--      Strings are printed as C strings, and we print them as I8[],
+--      following C--
+--
+pprStatics :: CmmStatics -> SDoc
+pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi
+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection (Section t suffix) =
+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)
+  where
+    section = text "section"
+
+pprSectionType :: SectionType -> SDoc
+pprSectionType s = doubleQuotes (ptext t)
+ where
+  t = case s of
+    Text              -> sLit "text"
+    Data              -> sLit "data"
+    ReadOnlyData      -> sLit "readonly"
+    ReadOnlyData16    -> sLit "readonly16"
+    RelocatableReadOnlyData
+                      -> sLit "relreadonly"
+    UninitialisedData -> sLit "uninitialised"
+    CString           -> sLit "cstring"
+    OtherSection s'   -> sLit s' -- Not actually a literal though.
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -0,0 +1,286 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of common Cmm types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PprCmmExpr
+    ( pprExpr, pprLit
+    )
+where
+
+import GhcPrelude
+
+import CmmExpr
+
+import Outputable
+import DynFlags
+
+import Data.Maybe
+import Numeric ( fromRat )
+
+-----------------------------------------------------------------------------
+
+instance Outputable CmmExpr where
+    ppr e = pprExpr e
+
+instance Outputable CmmReg where
+    ppr e = pprReg e
+
+instance Outputable CmmLit where
+    ppr l = pprLit l
+
+instance Outputable LocalReg where
+    ppr e = pprLocalReg e
+
+instance Outputable Area where
+    ppr e = pprArea e
+
+instance Outputable GlobalReg where
+    ppr e = pprGlobalReg e
+
+-- --------------------------------------------------------------------------
+-- Expressions
+--
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e
+    = sdocWithDynFlags $ \dflags ->
+      case e of
+        CmmRegOff reg i ->
+                pprExpr (CmmMachOp (MO_Add rep)
+                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+                where rep = typeWidth (cmmRegType dflags reg)
+        CmmLit lit -> pprLit lit
+        _other     -> pprExpr1 e
+
+-- Here's the precedence table from CmmParse.y:
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+-- %left '|'
+-- %left '^'
+-- %left '&'
+-- %left '>>' '<<'
+-- %left '-' '+'
+-- %left '/' '*' '%'
+-- %right '~'
+
+-- We just cope with the common operators for now, the rest will get
+-- a default conservative behaviour.
+
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+   = pprExpr7 x <+> doc <+> pprExpr7 y
+pprExpr1 e = pprExpr7 e
+
+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
+
+infixMachOp1 (MO_Eq     _) = Just (text "==")
+infixMachOp1 (MO_Ne     _) = Just (text "!=")
+infixMachOp1 (MO_Shl    _) = Just (text "<<")
+infixMachOp1 (MO_U_Shr  _) = Just (text ">>")
+infixMachOp1 (MO_U_Ge   _) = Just (text ">=")
+infixMachOp1 (MO_U_Le   _) = Just (text "<=")
+infixMachOp1 (MO_U_Gt   _) = Just (char '>')
+infixMachOp1 (MO_U_Lt   _) = Just (char '<')
+infixMachOp1 _             = Nothing
+
+-- %left '-' '+'
+pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+   = pprExpr7 x <+> doc <+> pprExpr8 y
+pprExpr7 e = pprExpr8 e
+
+infixMachOp7 (MO_Add _)  = Just (char '+')
+infixMachOp7 (MO_Sub _)  = Just (char '-')
+infixMachOp7 _           = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+   = pprExpr8 x <+> doc <+> pprExpr9 y
+pprExpr8 e = pprExpr9 e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _)    = Just (char '*')
+infixMachOp8 (MO_U_Rem _)  = Just (char '%')
+infixMachOp8 _             = Nothing
+
+pprExpr9 :: CmmExpr -> SDoc
+pprExpr9 e =
+   case e of
+        CmmLit    lit       -> pprLit1 lit
+        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)
+        CmmReg    reg       -> ppr reg
+        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
+        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
+        CmmMachOp mop args  -> genMachOp mop args
+
+genMachOp :: MachOp -> [CmmExpr] -> SDoc
+genMachOp mop args
+   | Just doc <- infixMachOp mop = case args of
+        -- dyadic
+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+
+        -- unary
+        [x]   -> doc <> pprExpr9 x
+
+        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+                          (pprMachOp mop <+>
+                            parens (hcat $ punctuate comma (map pprExpr args)))
+                          empty
+
+   | isJust (infixMachOp1 mop)
+   || isJust (infixMachOp7 mop)
+   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
+
+   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
+        where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
+                                 (show mop))
+                -- replace spaces in (show mop) with underscores,
+
+--
+-- Unsigned ops on the word size of the machine get nice symbols.
+-- All else get dumped in their ugly format.
+--
+infixMachOp :: MachOp -> Maybe SDoc
+infixMachOp mop
+        = case mop of
+            MO_And    _ -> Just $ char '&'
+            MO_Or     _ -> Just $ char '|'
+            MO_Xor    _ -> Just $ char '^'
+            MO_Not    _ -> Just $ char '~'
+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
+            _ -> Nothing
+
+-- --------------------------------------------------------------------------
+-- Literals.
+--  To minimise line noise we adopt the convention that if the literal
+--  has the natural machine word size, we do not append the type
+--
+pprLit :: CmmLit -> SDoc
+pprLit lit = sdocWithDynFlags $ \dflags ->
+             case lit of
+    CmmInt i rep ->
+        hcat [ (if i < 0 then parens else id)(integer i)
+             , ppUnless (rep == wordWidth dflags) $
+               space <> dcolon <+> ppr rep ]
+
+    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]
+    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'
+    CmmLabel clbl      -> ppr clbl
+    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
+    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
+                                  <> ppr clbl2 <> ppr_offset i
+    CmmBlock id        -> ppr id
+    CmmHighStackMark -> text "<highSp>"
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
+pprLit1 lit                  = pprLit lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+    | i==0      = empty
+    | i>=0      = char '+' <> int i
+    | otherwise = char '-' <> int (-i)
+
+-- --------------------------------------------------------------------------
+-- Registers, whether local (temps) or global
+--
+pprReg :: CmmReg -> SDoc
+pprReg r
+    = case r of
+        CmmLocal  local  -> pprLocalReg  local
+        CmmGlobal global -> pprGlobalReg global
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->
+--   = ppr rep <> char '_' <> ppr uniq
+-- Temp Jan08
+    char '_' <> pprUnique dflags uniq <>
+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
+                    then dcolon <> ptr <> ppr rep
+                    else dcolon <> ptr <> ppr rep)
+   where
+     pprUnique dflags unique =
+        if gopt Opt_SuppressUniques dflags
+            then text "_locVar_"
+            else ppr unique
+     ptr = empty
+         --if isGcPtrType rep
+         --      then doubleQuotes (text "ptr")
+         --      else empty
+
+-- Stack areas
+pprArea :: Area -> SDoc
+pprArea Old        = text "old"
+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
+
+-- needs to be kept in syn with CmmExpr.hs.GlobalReg
+--
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr
+    = case gr of
+        VanillaReg n _ -> char 'R' <> int n
+-- Temp Jan08
+--        VanillaReg n VNonGcPtr -> char 'R' <> int n
+--        VanillaReg n VGcPtr    -> char 'P' <> int n
+        FloatReg   n   -> char 'F' <> int n
+        DoubleReg  n   -> char 'D' <> int n
+        LongReg    n   -> char 'L' <> int n
+        XmmReg     n   -> text "XMM" <> int n
+        YmmReg     n   -> text "YMM" <> int n
+        ZmmReg     n   -> text "ZMM" <> int n
+        Sp             -> text "Sp"
+        SpLim          -> text "SpLim"
+        Hp             -> text "Hp"
+        HpLim          -> text "HpLim"
+        MachSp         -> text "MachSp"
+        UnwindReturnReg-> text "UnwindReturnReg"
+        CCCS           -> text "CCCS"
+        CurrentTSO     -> text "CurrentTSO"
+        CurrentNursery -> text "CurrentNursery"
+        HpAlloc        -> text "HpAlloc"
+        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+        GCEnter1       -> text "stg_gc_enter_1"
+        GCFun          -> text "stg_gc_fun"
+        BaseReg        -> text "BaseReg"
+        PicBaseReg     -> text "PicBaseReg"
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs
diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/SMRep.hs
@@ -0,0 +1,563 @@
+-- (c) The University of Glasgow 2006
+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+--
+-- Storage manager representation of closures
+
+{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}
+
+module SMRep (
+        -- * Words and bytes
+        WordOff, ByteOff,
+        wordsToBytes, bytesToWordsRoundUp,
+        roundUpToWords, roundUpTo,
+
+        StgWord, fromStgWord, toStgWord,
+        StgHalfWord, fromStgHalfWord, toStgHalfWord,
+        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
+
+        -- * Closure repesentation
+        SMRep(..), -- CmmInfo sees the rep; no one else does
+        IsStatic,
+        ClosureTypeInfo(..), ArgDescr(..), Liveness,
+        ConstrDescription,
+
+        -- ** Construction
+        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
+        smallArrPtrsRep, arrWordsRep,
+
+        -- ** Predicates
+        isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
+        isStackRep,
+
+        -- ** Size-related things
+        heapClosureSizeW,
+        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,
+        arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,
+        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,
+        fixedHdrSize,
+
+        -- ** RTS closure types
+        rtsClosureType, rET_SMALL, rET_BIG,
+        aRG_GEN, aRG_GEN_BIG,
+
+        -- ** Arrays
+        card, cardRoundUp, cardTableSizeB, cardTableSizeW
+    ) where
+
+import GhcPrelude
+
+import BasicTypes( ConTagZ )
+import DynFlags
+import Outputable
+import Platform
+import FastString
+
+import Data.Word
+import Data.Bits
+import Data.ByteString (ByteString)
+
+{-
+************************************************************************
+*                                                                      *
+                Words and bytes
+*                                                                      *
+************************************************************************
+-}
+
+-- | Word offset, or word count
+type WordOff = Int
+
+-- | Byte offset, or byte count
+type ByteOff = Int
+
+-- | Round up the given byte count to the next byte count that's a
+-- multiple of the machine's word size.
+roundUpToWords :: DynFlags -> ByteOff -> ByteOff
+roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)
+
+-- | Round up @base@ to a multiple of @size@.
+roundUpTo :: ByteOff -> ByteOff -> ByteOff
+roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))
+
+-- | Convert the given number of words to a number of bytes.
+--
+-- This function morally has type @WordOff -> ByteOff@, but uses @Num
+-- a@ to allow for overloading.
+wordsToBytes :: Num a => DynFlags -> a -> a
+wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}
+
+-- | First round the given byte count up to a multiple of the
+-- machine's word size and then convert the result to words.
+bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff
+bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size
+ where word_size = wORD_SIZE dflags
+-- StgWord is a type representing an StgWord on the target platform.
+-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform
+newtype StgWord = StgWord Word64
+    deriving (Eq, Bits)
+
+fromStgWord :: StgWord -> Integer
+fromStgWord (StgWord i) = toInteger i
+
+toStgWord :: DynFlags -> Integer -> StgWord
+toStgWord dflags i
+    = 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)
+
+instance Outputable StgWord where
+    ppr (StgWord i) = integer (toInteger i)
+
+--
+
+-- A Word32 is large enough to hold half a Word for either a 32bit or
+-- 64bit platform
+newtype StgHalfWord = StgHalfWord Word32
+    deriving Eq
+
+fromStgHalfWord :: StgHalfWord -> Integer
+fromStgHalfWord (StgHalfWord w) = toInteger w
+
+toStgHalfWord :: DynFlags -> Integer -> StgHalfWord
+toStgHalfWord dflags i
+    = 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)
+
+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
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}
+*                                                                      *
+************************************************************************
+-}
+
+-- | A description of the layout of a closure.  Corresponds directly
+-- to the closure types in includes/rts/storage/ClosureTypes.h.
+data SMRep
+  = HeapRep              -- GC routines consult sizes in info tbl
+        IsStatic
+        !WordOff         --  # ptr words
+        !WordOff         --  # non-ptr words INCLUDING SLOP (see mkHeapRep below)
+        ClosureTypeInfo  -- type-specific info
+
+  | ArrayPtrsRep
+        !WordOff        -- # ptr words
+        !WordOff        -- # card table words
+
+  | SmallArrayPtrsRep
+        !WordOff        -- # ptr words
+
+  | ArrayWordsRep
+        !WordOff        -- # bytes expressed in words, rounded up
+
+  | StackRep            -- Stack frame (RET_SMALL or RET_BIG)
+        Liveness
+
+  | RTSRep              -- The RTS needs to declare info tables with specific
+        Int             -- type tags, so this form lets us override the default
+        SMRep           -- tag for an SMRep.
+
+-- | True <=> This is a static closure.  Affects how we garbage-collect it.
+-- Static closure have an extra static link field at the end.
+-- Constructors do not have a static variant; see Note [static constructors]
+type IsStatic = Bool
+
+-- From an SMRep you can get to the closure type defined in
+-- includes/rts/storage/ClosureTypes.h. Described by the function
+-- rtsClosureType below.
+
+data ClosureTypeInfo
+  = Constr        ConTagZ ConstrDescription
+  | Fun           FunArity ArgDescr
+  | Thunk
+  | ThunkSelector SelectorOffset
+  | BlackHole
+  | IndStatic
+
+type ConstrDescription = ByteString -- result of dataConIdentity
+type FunArity          = Int
+type SelectorOffset    = Int
+
+-------------------------
+-- We represent liveness bitmaps as a Bitmap (whose internal
+-- representation really is a bitmap).  These are pinned onto case return
+-- vectors to indicate the state of the stack for the garbage collector.
+--
+-- In the compiled program, liveness bitmaps that fit inside a single
+-- word (StgWord) are stored as a single word, while larger bitmaps are
+-- stored as a pointer to an array of words.
+
+type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
+                         --                    False <=> ptr
+
+-------------------------
+-- An ArgDescr describes the argument pattern of a function
+
+data ArgDescr
+  = ArgSpec             -- Fits one of the standard patterns
+        !Int            -- RTS type identifier ARG_P, ARG_N, ...
+
+  | ArgGen              -- General case
+        Liveness        -- Details about the arguments
+
+
+-----------------------------------------------------------------------------
+-- Construction
+
+mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo
+          -> SMRep
+mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info
+  = HeapRep is_static
+            ptr_wds
+            (nonptr_wds + slop_wds)
+            cl_type_info
+  where
+     slop_wds
+      | is_static = 0
+      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))
+
+     hdr_size     = closureTypeHdrSize dflags cl_type_info
+     payload_size = ptr_wds + nonptr_wds
+
+mkRTSRep :: Int -> SMRep -> SMRep
+mkRTSRep = RTSRep
+
+mkStackRep :: [Bool] -> SMRep
+mkStackRep liveness = StackRep liveness
+
+blackHoleRep :: SMRep
+blackHoleRep = HeapRep False 0 0 BlackHole
+
+indStaticRep :: SMRep
+indStaticRep = HeapRep True 1 0 IndStatic
+
+arrPtrsRep :: DynFlags -> WordOff -> SMRep
+arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
+
+smallArrPtrsRep :: WordOff -> SMRep
+smallArrPtrsRep elems = SmallArrayPtrsRep elems
+
+arrWordsRep :: DynFlags -> ByteOff -> SMRep
+arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)
+
+-----------------------------------------------------------------------------
+-- Predicates
+
+isStaticRep :: SMRep -> IsStatic
+isStaticRep (HeapRep is_static _ _ _) = is_static
+isStaticRep (RTSRep _ rep)            = isStaticRep rep
+isStaticRep _                         = False
+
+isStackRep :: SMRep -> Bool
+isStackRep StackRep{}     = True
+isStackRep (RTSRep _ rep) = isStackRep rep
+isStackRep _              = False
+
+isConRep :: SMRep -> Bool
+isConRep (HeapRep _ _ _ Constr{}) = True
+isConRep _                        = False
+
+isThunkRep :: SMRep -> Bool
+isThunkRep (HeapRep _ _ _ Thunk)           = True
+isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
+isThunkRep (HeapRep _ _ _ BlackHole)       = True
+isThunkRep (HeapRep _ _ _ IndStatic)       = True
+isThunkRep _                               = False
+
+isFunRep :: SMRep -> Bool
+isFunRep (HeapRep _ _ _ Fun{}) = True
+isFunRep _                     = False
+
+isStaticNoCafCon :: SMRep -> Bool
+-- This should line up exactly with CONSTR_NOCAF below
+-- See Note [Static NoCaf constructors]
+isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True
+isStaticNoCafCon _                        = False
+
+
+-----------------------------------------------------------------------------
+-- Size-related things
+
+fixedHdrSize :: DynFlags -> ByteOff
+fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)
+
+-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
+fixedHdrSizeW :: DynFlags -> WordOff
+fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags
+
+-- | Size of the profiling part of a closure header
+-- (StgProfHeader in includes/rts/storage/Closures.h)
+profHdrSize  :: DynFlags -> WordOff
+profHdrSize dflags
+ | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags
+ | otherwise                      = 0
+
+-- | The garbage collector requires that every closure is at least as
+--   big as this.
+minClosureSize :: DynFlags -> WordOff
+minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags
+
+arrWordsHdrSize :: DynFlags -> ByteOff
+arrWordsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags
+
+arrWordsHdrSizeW :: DynFlags -> WordOff
+arrWordsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)
+
+arrPtrsHdrSize :: DynFlags -> ByteOff
+arrPtrsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags
+
+arrPtrsHdrSizeW :: DynFlags -> WordOff
+arrPtrsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+
+smallArrPtrsHdrSize :: DynFlags -> ByteOff
+smallArrPtrsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags
+
+smallArrPtrsHdrSizeW :: DynFlags -> WordOff
+smallArrPtrsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+
+-- Thunks have an extra header word on SMP, so the update doesn't
+-- splat the payload.
+thunkHdrSize :: DynFlags -> WordOff
+thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr
+        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags
+
+hdrSize :: DynFlags -> SMRep -> ByteOff
+hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)
+
+hdrSizeW :: DynFlags -> SMRep -> WordOff
+hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty
+hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags
+hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags
+hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags
+hdrSizeW _ _                          = panic "SMRep.hdrSizeW"
+
+nonHdrSize :: DynFlags -> SMRep -> ByteOff
+nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)
+
+nonHdrSizeW :: SMRep -> WordOff
+nonHdrSizeW (HeapRep _ p np _) = p + np
+nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct
+nonHdrSizeW (SmallArrayPtrsRep elems) = elems
+nonHdrSizeW (ArrayWordsRep words) = words
+nonHdrSizeW (StackRep bs)      = length bs
+nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep
+
+-- | The total size of the closure, in words.
+heapClosureSizeW :: DynFlags -> SMRep -> WordOff
+heapClosureSizeW dflags (HeapRep _ p np ty)
+ = closureTypeHdrSize dflags ty + p + np
+heapClosureSizeW dflags (ArrayPtrsRep elems ct)
+ = arrPtrsHdrSizeW dflags + elems + ct
+heapClosureSizeW dflags (SmallArrayPtrsRep elems)
+ = smallArrPtrsHdrSizeW dflags + elems
+heapClosureSizeW dflags (ArrayWordsRep words)
+ = arrWordsHdrSizeW dflags + words
+heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"
+
+closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff
+closureTypeHdrSize dflags ty = case ty of
+                  Thunk           -> thunkHdrSize dflags
+                  ThunkSelector{} -> thunkHdrSize dflags
+                  BlackHole       -> thunkHdrSize dflags
+                  IndStatic       -> thunkHdrSize dflags
+                  _               -> fixedHdrSizeW dflags
+        -- All thunks use thunkHdrSize, even if they are non-updatable.
+        -- this is because we don't have separate closure types for
+        -- updatable vs. non-updatable thunks, so the GC can't tell the
+        -- difference.  If we ever have significant numbers of non-
+        -- updatable thunks, it might be worth fixing this.
+
+-- ---------------------------------------------------------------------------
+-- Arrays
+
+-- | The byte offset into the card table of the card for a given element
+card :: DynFlags -> Int -> Int
+card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags
+
+-- | Convert a number of elements to a number of cards, rounding up
+cardRoundUp :: DynFlags -> Int -> Int
+cardRoundUp dflags i =
+  card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))
+
+-- | The size of a card table, in bytes
+cardTableSizeB :: DynFlags -> Int -> ByteOff
+cardTableSizeB dflags elems = cardRoundUp dflags elems
+
+-- | The size of a card table, in words
+cardTableSizeW :: DynFlags -> Int -> WordOff
+cardTableSizeW dflags elems =
+  bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)
+
+-----------------------------------------------------------------------------
+-- deriving the RTS closure type from an SMRep
+
+#include "../includes/rts/storage/ClosureTypes.h"
+#include "../includes/rts/storage/FunTypes.h"
+-- Defines CONSTR, CONSTR_1_0 etc
+
+-- | Derives the RTS closure type from an 'SMRep'
+rtsClosureType :: SMRep -> Int
+rtsClosureType rep
+    = case rep of
+      RTSRep ty _ -> ty
+
+      -- See Note [static constructors]
+      HeapRep _     1 0 Constr{} -> CONSTR_1_0
+      HeapRep _     0 1 Constr{} -> CONSTR_0_1
+      HeapRep _     2 0 Constr{} -> CONSTR_2_0
+      HeapRep _     1 1 Constr{} -> CONSTR_1_1
+      HeapRep _     0 2 Constr{} -> CONSTR_0_2
+      HeapRep _     0 _ Constr{} -> CONSTR_NOCAF
+           -- See Note [Static NoCaf constructors]
+      HeapRep _     _ _ Constr{} -> CONSTR
+
+      HeapRep False 1 0 Fun{} -> FUN_1_0
+      HeapRep False 0 1 Fun{} -> FUN_0_1
+      HeapRep False 2 0 Fun{} -> FUN_2_0
+      HeapRep False 1 1 Fun{} -> FUN_1_1
+      HeapRep False 0 2 Fun{} -> FUN_0_2
+      HeapRep False _ _ Fun{} -> FUN
+
+      HeapRep False 1 0 Thunk -> THUNK_1_0
+      HeapRep False 0 1 Thunk -> THUNK_0_1
+      HeapRep False 2 0 Thunk -> THUNK_2_0
+      HeapRep False 1 1 Thunk -> THUNK_1_1
+      HeapRep False 0 2 Thunk -> THUNK_0_2
+      HeapRep False _ _ Thunk -> THUNK
+
+      HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR
+
+      HeapRep True _ _ Fun{}      -> FUN_STATIC
+      HeapRep True _ _ Thunk      -> THUNK_STATIC
+      HeapRep False _ _ BlackHole -> BLACKHOLE
+      HeapRep False _ _ IndStatic -> IND_STATIC
+
+      _ -> panic "rtsClosureType"
+
+-- We export these ones
+rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int
+rET_SMALL   = RET_SMALL
+rET_BIG     = RET_BIG
+aRG_GEN     = ARG_GEN
+aRG_GEN_BIG = ARG_GEN_BIG
+
+{-
+Note [static constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We used to have a CONSTR_STATIC closure type, and each constructor had
+two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with
+CONSTR_STATIC.
+
+This distinction was removed, because when copying a data structure
+into a compact region, we must copy static constructors into the
+compact region too.  If we didn't do this, we would need to track the
+references from the compact region out to the static constructors,
+because they might (indirectly) refer to CAFs.
+
+Since static constructors will be copied to the heap, if we wanted to
+use different info tables for static and dynamic constructors, we
+would have to switch the info pointer when copying the constructor
+into the compact region, which means we would need an extra field of
+the static info table to point to the dynamic one.
+
+However, since the distinction between static and dynamic closure
+types is never actually needed (other than for assertions), we can
+just drop the distinction and use the same info table for both.
+
+The GC *does* need to distinguish between static and dynamic closures,
+but it does this using the HEAP_ALLOCED() macro which checks whether
+the address of the closure resides within the dynamic heap.
+HEAP_ALLOCED() doesn't read the closure's info table.
+
+Note [Static NoCaf constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we know that a top-level binding 'x' is not Caffy (ie no CAFs are
+reachable from 'x'), then a statically allocated constructor (Just x)
+is also not Caffy, and the garbage collector need not follow its
+argument fields.  Exploiting this would require two static info tables
+for Just, for the two cases where the argument was Caffy or non-Caffy.
+
+Currently we don't do this; instead we treat nullary constructors
+as non-Caffy, and the others as potentially Caffy.
+
+
+************************************************************************
+*                                                                      *
+             Pretty printing of SMRep and friends
+*                                                                      *
+************************************************************************
+-}
+
+instance Outputable ClosureTypeInfo where
+   ppr = pprTypeInfo
+
+instance Outputable SMRep where
+   ppr (HeapRep static ps nps tyinfo)
+     = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace)
+     where
+       header = text "HeapRep"
+                <+> if static then text "static" else empty
+                <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps
+       pp_n :: String -> Int -> SDoc
+       pp_n _ 0 = empty
+       pp_n s n = int n <+> text s
+
+   ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size
+
+   ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size
+
+   ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words
+
+   ppr (StackRep bs) = text "StackRep" <+> ppr bs
+
+   ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep
+
+instance Outputable ArgDescr where
+  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
+  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
+
+pprTypeInfo :: ClosureTypeInfo -> SDoc
+pprTypeInfo (Constr tag descr)
+  = text "Con" <+>
+    braces (sep [ text "tag:" <+> ppr tag
+                , text "descr:" <> text (show descr) ])
+
+pprTypeInfo (Fun arity args)
+  = text "Fun" <+>
+    braces (sep [ text "arity:" <+> ppr arity
+                , ptext (sLit ("fun_type:")) <+> ppr args ])
+
+pprTypeInfo (ThunkSelector offset)
+  = text "ThunkSel" <+> ppr offset
+
+pprTypeInfo Thunk     = text "Thunk"
+pprTypeInfo BlackHole = text "BlackHole"
+pprTypeInfo IndStatic = text "IndStatic"
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CgUtils.hs
@@ -0,0 +1,186 @@
+{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generator utilities; mostly monadic
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module CgUtils (
+        fixStgRegisters,
+        baseRegOffset,
+        get_Regtable_addr_from_offset,
+        regTableOffset,
+        get_GlobalReg_addr,
+  ) where
+
+import GhcPrelude
+
+import CodeGen.Platform
+import Cmm
+import Hoopl.Block
+import Hoopl.Graph
+import CmmUtils
+import CLabel
+import DynFlags
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- Information about global registers
+
+baseRegOffset :: DynFlags -> GlobalReg -> Int
+
+baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags
+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags
+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags
+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags
+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags
+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags
+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags
+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags
+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags
+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags
+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags
+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags
+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags
+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags
+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags
+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags
+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")
+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags
+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags
+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags
+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags
+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags
+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags
+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags
+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags
+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags
+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags
+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags
+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags
+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags
+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags
+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags
+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags
+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags
+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags
+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags
+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags
+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags
+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags
+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags
+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags
+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags
+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags
+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags
+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags
+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags
+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags
+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags
+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags
+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags
+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags
+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags
+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags
+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"
+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"
+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"
+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"
+
+
+-- -----------------------------------------------------------------------------
+--
+-- STG/Cmm GlobalReg
+--
+-- -----------------------------------------------------------------------------
+
+-- | We map STG registers onto appropriate CmmExprs.  Either they map
+-- to real machine registers or stored as offsets from BaseReg.  Given
+-- a GlobalReg, get_GlobalReg_addr always produces the
+-- register table address for it.
+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
+get_GlobalReg_addr dflags mid
+    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)
+
+-- Calculate a literal representing an offset into the register table.
+-- Used when we don't have an actual BaseReg to offset from.
+regTableOffset :: DynFlags -> Int -> CmmExpr
+regTableOffset dflags n =
+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
+
+get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr
+get_Regtable_addr_from_offset dflags offset =
+    if haveRegBase (targetPlatform dflags)
+    then CmmRegOff baseReg offset
+    else regTableOffset dflags offset
+
+-- | Fixup global registers so that they assign to locations within the
+-- RegTable if they aren't pinned for the current target.
+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
+fixStgRegisters _ top@(CmmData _ _) = top
+
+fixStgRegisters dflags (CmmProc info lbl live graph) =
+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph
+  in CmmProc info lbl live graph'
+
+fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x
+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block
+
+fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
+  where
+    platform = targetPlatform dflags
+
+    fixAssign stmt =
+      case stmt of
+        CmmAssign (CmmGlobal reg) src
+          -- MachSp isn't an STG register; it's merely here for tracking unwind
+          -- information
+          | reg == MachSp -> stmt
+          | otherwise ->
+            let baseAddr = get_GlobalReg_addr dflags reg
+            in case reg `elem` activeStgRegs (targetPlatform dflags) of
+                True  -> CmmAssign (CmmGlobal reg) src
+                False -> CmmStore baseAddr src
+        other_stmt -> other_stmt
+
+    fixExpr expr = case expr of
+        -- MachSp isn't an STG; it's merely here for tracking unwind information
+        CmmReg (CmmGlobal MachSp) -> expr
+        CmmReg (CmmGlobal reg) ->
+            -- Replace register leaves with appropriate StixTrees for
+            -- the given target.  MagicIds which map to a reg on this
+            -- arch are left unchanged.  For the rest, BaseReg is taken
+            -- to mean the address of the reg table in MainCapability,
+            -- and for all others we generate an indirection to its
+            -- location in the register table.
+            case reg `elem` activeStgRegs platform of
+                True  -> expr
+                False ->
+                    let baseAddr = get_GlobalReg_addr dflags reg
+                    in case reg of
+                        BaseReg -> baseAddr
+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)
+
+        CmmRegOff (CmmGlobal reg) offset ->
+            -- RegOf leaves are just a shorthand form. If the reg maps
+            -- to a real reg, we keep the shorthand, otherwise, we just
+            -- expand it and defer to the above code.
+            case reg `elem` activeStgRegs platform of
+                True  -> expr
+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [
+                                    fixExpr (CmmReg (CmmGlobal reg)),
+                                    CmmLit (CmmInt (fromIntegral offset)
+                                                   (wordWidth dflags))]
+
+        other_expr -> other_expr
diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform.hs
@@ -0,0 +1,107 @@
+
+module CodeGen.Platform
+       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)
+       where
+
+import GhcPrelude
+
+import CmmExpr
+import Platform
+import Reg
+
+import qualified CodeGen.Platform.ARM        as ARM
+import qualified CodeGen.Platform.ARM64      as ARM64
+import qualified CodeGen.Platform.PPC        as PPC
+import qualified CodeGen.Platform.SPARC      as SPARC
+import qualified CodeGen.Platform.X86        as X86
+import qualified CodeGen.Platform.X86_64     as X86_64
+import qualified CodeGen.Platform.NoRegs     as NoRegs
+
+-- | Returns 'True' if this global register is stored in a caller-saves
+-- machine register.
+
+callerSaves :: Platform -> GlobalReg -> Bool
+callerSaves platform
+ | platformUnregisterised platform = NoRegs.callerSaves
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.callerSaves
+   ArchX86_64 -> X86_64.callerSaves
+   ArchSPARC  -> SPARC.callerSaves
+   ArchARM {} -> ARM.callerSaves
+   ArchARM64  -> ARM64.callerSaves
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.callerSaves
+
+    | otherwise -> NoRegs.callerSaves
+
+-- | Here is where the STG register map is defined for each target arch.
+-- The order matters (for the llvm backend anyway)! We must make sure to
+-- maintain the order here with the order used in the LLVM calling conventions.
+-- Note that also, this isn't all registers, just the ones that are currently
+-- possbily mapped to real registers.
+activeStgRegs :: Platform -> [GlobalReg]
+activeStgRegs platform
+ | platformUnregisterised platform = NoRegs.activeStgRegs
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.activeStgRegs
+   ArchX86_64 -> X86_64.activeStgRegs
+   ArchSPARC  -> SPARC.activeStgRegs
+   ArchARM {} -> ARM.activeStgRegs
+   ArchARM64  -> ARM64.activeStgRegs
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.activeStgRegs
+
+    | otherwise -> NoRegs.activeStgRegs
+
+haveRegBase :: Platform -> Bool
+haveRegBase platform
+ | platformUnregisterised platform = NoRegs.haveRegBase
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.haveRegBase
+   ArchX86_64 -> X86_64.haveRegBase
+   ArchSPARC  -> SPARC.haveRegBase
+   ArchARM {} -> ARM.haveRegBase
+   ArchARM64  -> ARM64.haveRegBase
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.haveRegBase
+
+    | otherwise -> NoRegs.haveRegBase
+
+globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg
+globalRegMaybe platform
+ | platformUnregisterised platform = NoRegs.globalRegMaybe
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.globalRegMaybe
+   ArchX86_64 -> X86_64.globalRegMaybe
+   ArchSPARC  -> SPARC.globalRegMaybe
+   ArchARM {} -> ARM.globalRegMaybe
+   ArchARM64  -> ARM64.globalRegMaybe
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.globalRegMaybe
+
+    | otherwise -> NoRegs.globalRegMaybe
+
+freeReg :: Platform -> RegNo -> Bool
+freeReg platform
+ | platformUnregisterised platform = NoRegs.freeReg
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.freeReg
+   ArchX86_64 -> X86_64.freeReg
+   ArchSPARC  -> SPARC.freeReg
+   ArchARM {} -> ARM.freeReg
+   ArchARM64  -> ARM64.freeReg
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.freeReg
+
+    | otherwise -> NoRegs.freeReg
+
diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/ARM.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.ARM where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_arm 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/ARM64.hs b/compiler/codeGen/CodeGen/Platform/ARM64.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/ARM64.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.ARM64 where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_aarch64 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.NoRegs where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/PPC.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.PPC where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_powerpc 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.SPARC where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_sparc 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/X86.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.X86 where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_i386 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.X86_64 where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_x86_64 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmm.hs
@@ -0,0 +1,222 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmm ( codeGen ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude as Prelude
+
+import StgCmmProf (initCostCentres, ldvEnter)
+import StgCmmMonad
+import StgCmmEnv
+import StgCmmBind
+import StgCmmCon
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+import StgCmmHpc
+import StgCmmTicky
+
+import Cmm
+import CmmUtils
+import CLabel
+
+import StgSyn
+import DynFlags
+
+import HscTypes
+import CostCentre
+import Id
+import IdInfo
+import RepType
+import DataCon
+import TyCon
+import Module
+import Outputable
+import Stream
+import BasicTypes
+import VarSet ( isEmptyDVarSet )
+
+import OrdList
+import MkGraph
+
+import Data.IORef
+import Control.Monad (when,void)
+import Util
+
+codeGen :: DynFlags
+        -> Module
+        -> [TyCon]
+        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
+        -> [CgStgTopBinding]           -- Bindings to convert
+        -> HpcInfo
+        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
+                                       -- be interleaved with output
+
+codeGen dflags this_mod data_tycons
+        cost_centre_info stg_binds hpc_info
+  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
+              -- Using an IORef to store the state is a bit crude, but otherwise
+              -- we would need to add a state monad layer.
+        ; cgref <- liftIO $ newIORef =<< initC
+        ; let cg :: FCode () -> Stream IO CmmGroup ()
+              cg fcode = do
+                cmm <- liftIO $ do
+                         st <- readIORef cgref
+                         let (a,st') = runC dflags this_mod st (getCmm fcode)
+
+                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
+                         -- a big space leak.  DO NOT REMOVE!
+                         writeIORef cgref $! st'{ cgs_tops = nilOL,
+                                                  cgs_stmts = mkNop }
+                         return a
+                yield cmm
+
+               -- Note [codegen-split-init] the cmm_init block must come
+               -- FIRST.  This is because when -split-objs is on we need to
+               -- combine this block with its initialisation routines; see
+               -- Note [pipeline-split-init].
+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
+
+        ; mapM_ (cg . cgTopBinding dflags) stg_binds
+
+                -- Put datatype_stuff after code_stuff, because the
+                -- datatype closure table (for enumeration types) to
+                -- (say) PrelBase_True_closure, which is defined in
+                -- code_stuff
+        ; let do_tycon tycon = do
+                -- Generate a table of static closures for an
+                -- enumeration type Note that the closure pointers are
+                -- tagged.
+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)
+
+        ; mapM_ do_tycon data_tycons
+        }
+
+---------------------------------------------------------------
+--      Top-level bindings
+---------------------------------------------------------------
+
+{- 'cgTopBinding' is only used for top-level bindings, since they need
+to be allocated statically (not in the heap) and need to be labelled.
+No unboxed bindings can happen at top level.
+
+In the code below, the static bindings are accumulated in the
+@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
+This is so that we can write the top level processing in a compositional
+style, with the increasing static environment being plumbed as a state
+variable. -}
+
+cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
+  = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs
+        ; fcode
+        ; addBindC info
+        }
+
+cgTopBinding dflags (StgTopLifted (StgRec pairs))
+  = do  { let (bndrs, rhss) = unzip pairs
+        ; let pairs' = zip bndrs rhss
+              r = unzipWith (cgTopRhs dflags Recursive) pairs'
+              (infos, fcodes) = unzip r
+        ; addBindsC infos
+        ; sequence_ fcodes
+        }
+
+cgTopBinding dflags (StgTopStringLit id str)
+  = do  { let label = mkBytesLabel (idName id)
+        ; let (lit, decl) = mkByteStringCLit label str
+        ; emitDecl decl
+        ; addBindC (litIdInfo dflags id mkLFStringLit lit)
+        }
+
+cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
+        -- The Id is passed along for setting up a binding...
+
+cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
+  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
+      -- con args are always non-void,
+      -- see Note [Post-unarisation invariants] in UnariseStg
+
+cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
+  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables
+    cgTopRhsClosure dflags rec bndr cc upd_flag args body
+
+
+---------------------------------------------------------------
+--      Module initialisation code
+---------------------------------------------------------------
+
+mkModuleInit
+        :: CollectedCCs         -- cost centre info
+        -> Module
+        -> HpcInfo
+        -> FCode ()
+
+mkModuleInit cost_centre_info this_mod hpc_info
+  = do  { initHpc this_mod hpc_info
+        ; initCostCentres cost_centre_info
+        }
+
+
+---------------------------------------------------------------
+--      Generating static stuff for algebraic data types
+---------------------------------------------------------------
+
+
+cgEnumerationTyCon :: TyCon -> FCode ()
+cgEnumerationTyCon tycon
+  = do dflags <- getDynFlags
+       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
+                           (tagForCon dflags con)
+             | con <- tyConDataCons tycon]
+
+
+cgDataCon :: DataCon -> FCode ()
+-- Generate the entry code, info tables, and (for niladic constructor)
+-- the static closure, for a constructor.
+cgDataCon data_con
+  = do  { dflags <- getDynFlags
+        ; let
+            (tot_wds, --  #ptr_wds + #nonptr_wds
+             ptr_wds) --  #ptr_wds
+              = mkVirtConstrSizes dflags arg_reps
+
+            nonptr_wds   = tot_wds - ptr_wds
+
+            dyn_info_tbl =
+              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
+
+            -- We're generating info tables, so we don't know and care about
+            -- what the actual arguments are. Using () here as the place holder.
+            arg_reps :: [NonVoid PrimRep]
+            arg_reps = [ NonVoid rep_ty
+                       | ty <- dataConRepArgTys data_con
+                       , rep_ty <- typePrimRep ty
+                       , not (isVoidRep rep_ty) ]
+
+        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
+            -- NB: the closure pointer is assumed *untagged* on
+            -- entry to a constructor.  If the pointer is tagged,
+            -- then we should not be entering it.  This assumption
+            -- is used in ldvEnter and when tagging the pointer to
+            -- return it.
+            -- NB 2: We don't set CC when entering data (WDP 94/06)
+            do { tickyEnterDynCon
+               ; ldvEnter (CmmReg nodeReg)
+               ; tickyReturnOldCon (length arg_reps)
+               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
+               }
+                    -- The case continuation code expects a tagged pointer
+        }
diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmArgRep.hs
@@ -0,0 +1,158 @@
+-----------------------------------------------------------------------------
+--
+-- Argument representations used in StgCmmLayout.
+--
+-- (c) The University of Glasgow 2013
+--
+-----------------------------------------------------------------------------
+
+module StgCmmArgRep (
+        ArgRep(..), toArgRep, argRepSizeW,
+
+        argRepString, isNonV, idArgRep,
+
+        slowCallPattern,
+
+        ) where
+
+import GhcPrelude
+
+import StgCmmClosure    ( idPrimRep )
+
+import SMRep            ( WordOff )
+import Id               ( Id )
+import TyCon            ( PrimRep(..), primElemRepSizeB )
+import BasicTypes       ( RepArity )
+import Constants        ( wORD64_SIZE )
+import DynFlags
+
+import Outputable
+import FastString
+
+-- I extricated this code as this new module in order to avoid a
+-- cyclic dependency between StgCmmLayout and StgCmmTicky.
+--
+-- NSF 18 Feb 2013
+
+-------------------------------------------------------------------------
+--      Classifying arguments: ArgRep
+-------------------------------------------------------------------------
+
+-- ArgRep is re-exported by StgCmmLayout, but only for use in the
+-- byte-code generator which also needs to know about the
+-- classification of arguments.
+
+data ArgRep = P   -- GC Ptr
+            | N   -- Word-sized non-ptr
+            | L   -- 64-bit non-ptr (long)
+            | V   -- Void
+            | F   -- Float
+            | D   -- Double
+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.
+            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.
+            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.
+instance Outputable ArgRep where ppr = text . argRepString
+
+argRepString :: ArgRep -> String
+argRepString P = "P"
+argRepString N = "N"
+argRepString L = "L"
+argRepString V = "V"
+argRepString F = "F"
+argRepString D = "D"
+argRepString V16 = "V16"
+argRepString V32 = "V32"
+argRepString V64 = "V64"
+
+toArgRep :: PrimRep -> ArgRep
+toArgRep VoidRep           = V
+toArgRep LiftedRep         = P
+toArgRep UnliftedRep       = P
+toArgRep IntRep            = N
+toArgRep WordRep           = N
+toArgRep Int8Rep           = N  -- Gets widened to native word width for calls
+toArgRep Word8Rep          = N  -- Gets widened to native word width for calls
+toArgRep Int16Rep          = N  -- Gets widened to native word width for calls
+toArgRep Word16Rep         = N  -- Gets widened to native word width for calls
+toArgRep AddrRep           = N
+toArgRep Int64Rep          = L
+toArgRep Word64Rep         = L
+toArgRep FloatRep          = F
+toArgRep DoubleRep         = D
+toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of
+                               16 -> V16
+                               32 -> V32
+                               64 -> V64
+                               _  -> error "toArgRep: bad vector primrep"
+
+isNonV :: ArgRep -> Bool
+isNonV V = False
+isNonV _ = True
+
+argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words
+argRepSizeW _      N   = 1
+argRepSizeW _      P   = 1
+argRepSizeW _      F   = 1
+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags
+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
+argRepSizeW _      V   = 0
+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags
+argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags
+argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags
+
+idArgRep :: Id -> ArgRep
+idArgRep = toArgRep . idPrimRep
+
+-- This list of argument patterns should be kept in sync with at least
+-- the following:
+--
+--  * StgCmmLayout.stdPattern maybe to some degree?
+--
+--  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)
+--  declarations in includes/stg/MiscClosures.h
+--
+--  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,
+--
+--  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,
+--
+--  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,
+--
+--  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and
+--  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c
+--
+-- There may be more places that I haven't found; I merely igrep'd for
+-- pppppp and excluded things that seemed ghci-specific.
+--
+-- Also, it seems at the moment that ticky counters with void
+-- arguments will never be bumped, but I'm still declaring those
+-- counters, defensively.
+--
+-- NSF 6 Mar 2013
+
+slowCallPattern :: [ArgRep] -> (FastString, RepArity)
+-- Returns the generic apply function and arity
+--
+-- The first batch of cases match (some) specialised entries
+-- The last group deals exhaustively with the cases for the first argument
+--   (and the zero-argument case)
+--
+-- In 99% of cases this function will match *all* the arguments in one batch
+
+slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)
+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)
+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)
+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)
+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)
+slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)
+slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)
+slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)
+slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)
+slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)
+slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)
+slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)
+slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)
+slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)
+slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)
+slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)
+slowCallPattern []                    = (fsLit "stg_ap_0", 0)
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -0,0 +1,753 @@
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: bindings
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmBind (
+        cgTopRhsClosure,
+        cgBind,
+        emitBlackHoleCode,
+        pushUpdateFrame, emitUpdateFrame
+  ) where
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmExpr
+import StgCmmMonad
+import StgCmmEnv
+import StgCmmCon
+import StgCmmHeap
+import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
+                   initUpdFrameProf)
+import StgCmmTicky
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+import StgCmmForeign    (emitPrimCall)
+
+import MkGraph
+import CoreSyn          ( AltCon(..), tickishIsCode )
+import BlockId
+import SMRep
+import Cmm
+import CmmInfo
+import CmmUtils
+import CLabel
+import StgSyn
+import CostCentre
+import Id
+import IdInfo
+import Name
+import Module
+import ListSetOps
+import Util
+import VarSet
+import BasicTypes
+import Outputable
+import FastString
+import DynFlags
+
+import Control.Monad
+
+------------------------------------------------------------------------
+--              Top-level bindings
+------------------------------------------------------------------------
+
+-- For closures bound at top level, allocate in static space.
+-- They should have no free variables.
+
+cgTopRhsClosure :: DynFlags
+                -> RecFlag              -- member of a recursive group?
+                -> Id
+                -> CostCentreStack      -- Optional cost centre annotation
+                -> UpdateFlag
+                -> [Id]                 -- Args
+                -> CgStgExpr
+                -> (CgIdInfo, FCode ())
+
+cgTopRhsClosure dflags rec id ccs upd_flag args body =
+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)
+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args
+  in (cg_id_info, gen_code dflags lf_info closure_label)
+  where
+  -- special case for a indirection (f = g).  We create an IND_STATIC
+  -- closure pointing directly to the indirectee.  This is exactly
+  -- what the CAF will eventually evaluate to anyway, we're just
+  -- shortcutting the whole process, and generating a lot less code
+  -- (#7308). Eventually the IND_STATIC closure will be eliminated
+  -- by assembly '.equiv' directives, where possible (#15155).
+  -- See note [emit-time elimination of static indirections] in CLabel.
+  --
+  -- Note: we omit the optimisation when this binding is part of a
+  -- recursive group, because the optimisation would inhibit the black
+  -- hole detection from working in that case.  Test
+  -- concurrent/should_run/4030 fails, for instance.
+  --
+  gen_code dflags _ closure_label
+    | StgApp f [] <- body, null args, isNonRec rec
+    = do
+         cg_info <- getCgIdInfo f
+         let closure_rep   = mkStaticClosureFields dflags
+                                    indStaticInfoTable ccs MayHaveCafRefs
+                                    [unLit (idInfoToAmode cg_info)]
+         emitDataLits closure_label closure_rep
+         return ()
+
+  gen_code dflags lf_info _closure_label
+   = do { let name = idName id
+        ; mod_name <- getModuleName
+        ; let descr         = closureDescription dflags mod_name name
+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
+
+        -- We don't generate the static closure here, because we might
+        -- want to add references to static closures to it later.  The
+        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,
+        -- See Note [SRTs], specifically the [FUN] optimisation.
+
+        ; let fv_details :: [(NonVoid Id, ByteOff)]
+              header = if isLFThunk lf_info then ThunkHeader else StdHeader
+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []
+        -- Don't drop the non-void args until the closure info has been made
+        ; forkClosureBody (closureCodeBody True id closure_info ccs
+                                (nonVoidIds args) (length args) body fv_details)
+
+        ; return () }
+
+  unLit (CmmLit l) = l
+  unLit _ = panic "unLit"
+
+------------------------------------------------------------------------
+--              Non-top-level bindings
+------------------------------------------------------------------------
+
+cgBind :: CgStgBinding -> FCode ()
+cgBind (StgNonRec name rhs)
+  = do  { (info, fcode) <- cgRhs name rhs
+        ; addBindC info
+        ; init <- fcode
+        ; emit init }
+        -- init cannot be used in body, so slightly better to sink it eagerly
+
+cgBind (StgRec pairs)
+  = do  {  r <- sequence $ unzipWith cgRhs pairs
+        ;  let (id_infos, fcodes) = unzip r
+        ;  addBindsC id_infos
+        ;  (inits, body) <- getCodeR $ sequence fcodes
+        ;  emit (catAGraphs inits <*> body) }
+
+{- Note [cgBind rec]
+
+   Recursive let-bindings are tricky.
+   Consider the following pseudocode:
+
+     let x = \_ ->  ... y ...
+         y = \_ ->  ... z ...
+         z = \_ ->  ... x ...
+     in ...
+
+   For each binding, we need to allocate a closure, and each closure must
+   capture the address of the other closures.
+   We want to generate the following C-- code:
+     // Initialization Code
+     x = hp - 24; // heap address of x's closure
+     y = hp - 40; // heap address of x's closure
+     z = hp - 64; // heap address of x's closure
+     // allocate and initialize x
+     m[hp-8]   = ...
+     m[hp-16]  = y       // the closure for x captures y
+     m[hp-24] = x_info;
+     // allocate and initialize y
+     m[hp-32] = z;       // the closure for y captures z
+     m[hp-40] = y_info;
+     // allocate and initialize z
+     ...
+
+   For each closure, we must generate not only the code to allocate and
+   initialize the closure itself, but also some initialization Code that
+   sets a variable holding the closure pointer.
+
+   We could generate a pair of the (init code, body code), but since
+   the bindings are recursive we also have to initialise the
+   environment with the CgIdInfo for all the bindings before compiling
+   anything.  So we do this in 3 stages:
+
+     1. collect all the CgIdInfos and initialise the environment
+     2. compile each binding into (init, body) code
+     3. emit all the inits, and then all the bodies
+
+   We'd rather not have separate functions to do steps 1 and 2 for
+   each binding, since in pratice they share a lot of code.  So we
+   have just one function, cgRhs, that returns a pair of the CgIdInfo
+   for step 1, and a monadic computation to generate the code in step
+   2.
+
+   The alternative to separating things in this way is to use a
+   fixpoint.  That's what we used to do, but it introduces a
+   maintenance nightmare because there is a subtle dependency on not
+   being too strict everywhere.  Doing things this way means that the
+   FCode monad can be strict, for example.
+ -}
+
+cgRhs :: Id
+      -> CgStgRhs
+      -> FCode (
+                 CgIdInfo         -- The info for this binding
+               , FCode CmmAGraph  -- A computation which will generate the
+                                  -- code for the binding, and return an
+                                  -- assignent of the form "x = Hp - n"
+                                  -- (see above)
+               )
+
+cgRhs id (StgRhsCon cc con args)
+  = withNewTickyCounterCon (idName id) $
+    buildDynCon id True cc con (assertNonVoidStgArgs args)
+      -- con args are always non-void,
+      -- see Note [Post-unarisation invariants] in UnariseStg
+
+{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
+cgRhs id (StgRhsClosure fvs cc upd_flag args body)
+  = do dflags <- getDynFlags
+       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
+
+------------------------------------------------------------------------
+--              Non-constructor right hand sides
+------------------------------------------------------------------------
+
+mkRhsClosure :: DynFlags -> Id -> CostCentreStack
+             -> [NonVoid Id]                    -- Free vars
+             -> UpdateFlag
+             -> [Id]                            -- Args
+             -> CgStgExpr
+             -> FCode (CgIdInfo, FCode CmmAGraph)
+
+{- mkRhsClosure looks for two special forms of the right-hand side:
+        a) selector thunks
+        b) AP thunks
+
+If neither happens, it just calls mkClosureLFInfo.  You might think
+that mkClosureLFInfo should do all this, but it seems wrong for the
+latter to look at the structure of an expression
+
+Note [Selectors]
+~~~~~~~~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep.  We are looking for a closure of {\em exactly} the
+form:
+
+...  = [the_fv] \ u [] ->
+         case the_fv of
+           con a_1 ... a_n -> a_i
+
+Note [Ap thunks]
+~~~~~~~~~~~~~~~~
+A more generic AP thunk of the form
+
+        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
+
+A set of these is compiled statically into the RTS, so we just use
+those.  We could extend the idea to thunks where some of the x_i are
+global ids (and hence not free variables), but this would entail
+generating a larger thunk.  It might be an option for non-optimising
+compilation, though.
+
+We only generate an Ap thunk if all the free variables are pointers,
+for semi-obvious reasons.
+
+-}
+
+---------- Note [Selectors] ------------------
+mkRhsClosure    dflags bndr _cc
+                [NonVoid the_fv]                -- Just one free var
+                upd_flag                -- Updatable thunk
+                []                      -- A thunk
+                expr
+  | let strip = snd . stripStgTicksTop (not . tickishIsCode)
+  , StgCase (StgApp scrutinee [{-no args-}])
+         _   -- ignore bndr
+         (AlgAlt _)
+         [(DataAlt _, params, sel_expr)] <- strip expr
+  , StgApp selectee [{-no args-}] <- strip sel_expr
+  , the_fv == scrutinee                -- Scrutinee is the only free variable
+
+  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))
+                                   -- pattern binders are always non-void,
+                                   -- see Note [Post-unarisation invariants] in UnariseStg
+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
+
+  , let offset_into_int = bytesToWordsRoundUp dflags the_offset
+                          - fixedHdrSizeW dflags
+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
+  = -- NOT TRUE: ASSERT(is_single_constructor)
+    -- The simplifier may have statically determined that the single alternative
+    -- is the only possible case and eliminated the others, even if there are
+    -- other constructors in the datatype.  It's still ok to make a selector
+    -- thunk in this case, because we *know* which constructor the scrutinee
+    -- will evaluate to.
+    --
+    -- srt is discarded; it must be empty
+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
+
+---------- Note [Ap thunks] ------------------
+mkRhsClosure    dflags bndr _cc
+                fvs
+                upd_flag
+                []                      -- No args; a thunk
+                (StgApp fun_id args)
+
+  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure
+  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
+  -- So the xi will all be free variables
+  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and
+                               -- args are all distinct local variables
+                               -- The "-1" is for fun_id
+    -- Missed opportunity:   (f x x) is not detected
+  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs
+  , isUpdatable upd_flag
+  , n_fvs <= mAX_SPEC_AP_SIZE dflags
+  , not (gopt Opt_SccProfilingOn dflags)
+                         -- not when profiling: we don't want to
+                         -- lose information about this particular
+                         -- thunk (e.g. its type) (#949)
+  , idArity fun_id == unknownArity -- don't spoil a known call
+
+          -- Ha! an Ap thunk
+  = cgRhsStdThunk bndr lf_info payload
+
+  where
+    n_fvs   = length fvs
+    lf_info = mkApLFInfo bndr upd_flag n_fvs
+    -- the payload has to be in the correct order, hence we can't
+    -- just use the fvs.
+    payload = StgVarArg fun_id : args
+
+---------- Default case ------------------
+mkRhsClosure dflags bndr cc fvs upd_flag args body
+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args
+        ; (id_info, reg) <- rhsIdInfo bndr lf_info
+        ; return (id_info, gen_code lf_info reg) }
+ where
+ gen_code lf_info reg
+  = do  {       -- LAY OUT THE OBJECT
+        -- If the binder is itself a free variable, then don't store
+        -- it in the closure.  Instead, just bind it to Node on entry.
+        -- NB we can be sure that Node will point to it, because we
+        -- haven't told mkClosureLFInfo about this; so if the binder
+        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
+        -- stored in the closure itself, so it will make sure that
+        -- Node points to it...
+        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs
+
+        -- MAKE CLOSURE INFO FOR THIS CLOSURE
+        ; mod_name <- getModuleName
+        ; dflags <- getDynFlags
+        ; let   name  = idName bndr
+                descr = closureDescription dflags mod_name name
+                fv_details :: [(NonVoid Id, ByteOff)]
+                header = if isLFThunk lf_info then ThunkHeader else StdHeader
+                (tot_wds, ptr_wds, fv_details)
+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)
+                closure_info = mkClosureInfo dflags False       -- Not static
+                                             bndr lf_info tot_wds ptr_wds
+                                             descr
+
+        -- BUILD ITS INFO TABLE AND CODE
+        ; forkClosureBody $
+                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
+                --                  (b) ignore Sequel from context; use empty Sequel
+                -- And compile the body
+                closureCodeBody False bndr closure_info cc (nonVoidIds args)
+                                (length args) body fv_details
+
+        -- BUILD THE OBJECT
+--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
+        ; let use_cc = cccsExpr; blame_cc = cccsExpr
+        ; emit (mkComment $ mkFastString "calling allocDynClosure")
+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
+                                         (map toVarArg fv_details)
+
+        -- RETURN
+        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+
+-------------------------
+cgRhsStdThunk
+        :: Id
+        -> LambdaFormInfo
+        -> [StgArg]             -- payload
+        -> FCode (CgIdInfo, FCode CmmAGraph)
+
+cgRhsStdThunk bndr lf_info payload
+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info
+       ; return (id_info, gen_code reg)
+       }
+ where
+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK
+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
+    do
+  {     -- LAY OUT THE OBJECT
+    mod_name <- getModuleName
+  ; dflags <- getDynFlags
+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader
+        (tot_wds, ptr_wds, payload_w_offsets)
+            = mkVirtHeapOffsets dflags header
+                (addArgReps (nonVoidStgArgs payload))
+
+        descr = closureDescription dflags mod_name (idName bndr)
+        closure_info = mkClosureInfo dflags False       -- Not static
+                                     bndr lf_info tot_wds ptr_wds
+                                     descr
+
+--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
+  ; let use_cc = cccsExpr; blame_cc = cccsExpr
+
+
+        -- BUILD THE OBJECT
+  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
+                                   use_cc blame_cc payload_w_offsets
+
+        -- RETURN
+  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+
+
+mkClosureLFInfo :: DynFlags
+                -> Id           -- The binder
+                -> TopLevelFlag -- True of top level
+                -> [NonVoid Id] -- Free vars
+                -> UpdateFlag   -- Update flag
+                -> [Id]         -- Args
+                -> LambdaFormInfo
+mkClosureLFInfo dflags bndr top fvs upd_flag args
+  | null args =
+        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag
+  | otherwise =
+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)
+
+
+------------------------------------------------------------------------
+--              The code for closures
+------------------------------------------------------------------------
+
+closureCodeBody :: Bool            -- whether this is a top-level binding
+                -> Id              -- the closure's name
+                -> ClosureInfo     -- Lots of information about this closure
+                -> CostCentreStack -- Optional cost centre attached to closure
+                -> [NonVoid Id]    -- incoming args to the closure
+                -> Int             -- arity, including void args
+                -> CgStgExpr
+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars
+                -> FCode ()
+
+{- There are two main cases for the code for closures.
+
+* If there are *no arguments*, then the closure is a thunk, and not in
+  normal form. So it should set up an update frame (if it is
+  shared). NB: Thunks cannot have a primitive type!
+
+* If there is *at least one* argument, then this closure is in
+  normal form, so there is no need to set up an update frame.
+-}
+
+closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
+  | arity == 0 -- No args i.e. thunk
+  = withNewTickyCounterThunk
+        (isStaticClosure cl_info)
+        (closureUpdReqd cl_info)
+        (closureName cl_info) $
+    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
+   where
+     lf_info  = closureLFInfo cl_info
+     info_tbl = mkCmmInfo cl_info bndr cc
+
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
+  = -- Note: args may be [], if all args are Void
+    withNewTickyCounterFun
+        (closureSingleEntry cl_info)
+        (closureName cl_info)
+        args $ do {
+
+        ; let
+             lf_info  = closureLFInfo cl_info
+             info_tbl = mkCmmInfo cl_info bndr cc
+
+        -- Emit the main entry code
+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
+            \(_offset, node, arg_regs) -> do
+                -- Emit slow-entry code (for entering a closure through a PAP)
+                { mkSlowEntryCode bndr cl_info arg_regs
+                ; dflags <- getDynFlags
+                ; let node_points = nodeMustPointToIt dflags lf_info
+                      node' = if node_points then Just node else Nothing
+                ; loop_header_id <- newBlockId
+                -- Extend reader monad with information that
+                -- self-recursive tail calls can be optimized into local
+                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
+                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
+                {
+                -- Main payload
+                ; entryHeapCheck cl_info node' arity arg_regs $ do
+                { -- emit LDV code when profiling
+                  when node_points (ldvEnterClosure cl_info (CmmLocal node))
+                -- ticky after heap check to avoid double counting
+                ; tickyEnterFun cl_info
+                ; enterCostCentreFun cc
+                    (CmmMachOp (mo_wordSub dflags)
+                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
+                         , mkIntExpr dflags (funTag dflags cl_info) ])
+                ; fv_bindings <- mapM bind_fv fv_details
+                -- Load free vars out of closure *after*
+                -- heap check, to reduce live vars over check
+                ; when node_points $ load_fvs node lf_info fv_bindings
+                ; void $ cgExpr body
+                }}}
+
+  }
+
+-- Note [NodeReg clobbered with loopification]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
+-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
+-- may get clobbered inside the body of a closure, and since a self-recursive
+-- tail call does not restore R1, a subsequent call to enterFunCCS received a
+-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
+-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
+-- the original value of R1. This way R1 may get modified but loopification will
+-- not care.
+
+-- A function closure pointer may be tagged, so we
+-- must take it into account when accessing the free variables.
+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
+
+load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
+load_fvs node lf_info = mapM_ (\ (reg, off) ->
+   do dflags <- getDynFlags
+      let tag = lfDynTag dflags lf_info
+      emit $ mkTaggedObjectLoad dflags reg node off tag)
+
+-----------------------------------------
+-- The "slow entry" code for a function.  This entry point takes its
+-- arguments on the stack.  It loads the arguments into registers
+-- according to the calling convention, and jumps to the function's
+-- normal entry point.  The function's closure is assumed to be in
+-- R1/node.
+--
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
+
+mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
+-- If this function doesn't have a specialised ArgDescr, we need
+-- to generate the function's arg bitmap and slow-entry code.
+-- Here, we emit the slow-entry code.
+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
+  | Just (_, ArgGen _) <- closureFunInfo cl_info
+  = do dflags <- getDynFlags
+       let node = idToReg dflags (NonVoid bndr)
+           slow_lbl = closureSlowEntryLabel  cl_info
+           fast_lbl = closureLocalEntryLabel dflags cl_info
+           -- mkDirectJump does not clobber `Node' containing function closure
+           jump = mkJump dflags NativeNodeCall
+                                (mkLblExpr fast_lbl)
+                                (map (CmmReg . CmmLocal) (node : arg_regs))
+                                (initUpdFrameOff dflags)
+       tscope <- getTickScope
+       emitProcWithConvention Slow Nothing slow_lbl
+         (node : arg_regs) (jump, tscope)
+  | otherwise = return ()
+
+-----------------------------------------
+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
+          -> LocalReg -> Int -> CgStgExpr -> FCode ()
+thunkCode cl_info fv_details _cc node arity body
+  = do { dflags <- getDynFlags
+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
+             node'       = if node_points then Just node else Nothing
+        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
+
+        -- Heap overflow check
+        ; entryHeapCheck cl_info node' arity [] $ do
+        { -- Overwrite with black hole if necessary
+          -- but *after* the heap-overflow check
+        ; tickyEnterThunk cl_info
+        ; when (blackHoleOnEntry cl_info && node_points)
+                (blackHoleIt node)
+
+          -- Push update frame
+        ; setupUpdate cl_info node $
+            -- We only enter cc after setting up update so
+            -- that cc of enclosing scope will be recorded
+            -- in update frame CAF/DICT functions will be
+            -- subsumed by this enclosing cc
+            do { enterCostCentreThunk (CmmReg nodeReg)
+               ; let lf_info = closureLFInfo cl_info
+               ; fv_bindings <- mapM bind_fv fv_details
+               ; load_fvs node lf_info fv_bindings
+               ; void $ cgExpr body }}}
+
+
+------------------------------------------------------------------------
+--              Update and black-hole wrappers
+------------------------------------------------------------------------
+
+blackHoleIt :: LocalReg -> FCode ()
+-- Only called for closures with no args
+-- Node points to the closure
+blackHoleIt node_reg
+  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
+
+emitBlackHoleCode :: CmmExpr -> FCode ()
+emitBlackHoleCode node = do
+  dflags <- getDynFlags
+
+  -- Eager blackholing is normally disabled, but can be turned on with
+  -- -feager-blackholing.  When it is on, we replace the info pointer
+  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
+
+  -- If we wanted to do eager blackholing with slop filling, we'd need
+  -- to do it at the *end* of a basic block, otherwise we overwrite
+  -- the free variables in the thunk that we still need.  We have a
+  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
+  -- [6/2004]
+  --
+  -- Previously, eager blackholing was enabled when ticky-ticky was
+  -- on. But it didn't work, and it wasn't strictly necessary to bring
+  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
+  -- unconditionally disabled. -- krc 1/2007
+
+  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
+  -- because emitBlackHoleCode is called from CmmParse.
+
+  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)
+                         && gopt Opt_EagerBlackHoling dflags
+             -- Profiling needs slop filling (to support LDV
+             -- profiling), so currently eager blackholing doesn't
+             -- work with profiling.
+
+  when eager_blackholing $ do
+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
+    emitPrimCall [] MO_WriteBarrier []
+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
+
+setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
+        -- Nota Bene: this function does not change Node (even if it's a CAF),
+        -- so that the cost centre in the original closure can still be
+        -- extracted by a subsequent enterCostCentre
+setupUpdate closure_info node body
+  | not (lfUpdatable (closureLFInfo closure_info))
+  = body
+
+  | not (isStaticClosure closure_info)
+  = if not (closureUpdReqd closure_info)
+      then do tickyUpdateFrameOmitted; body
+      else do
+          tickyPushUpdateFrame
+          dflags <- getDynFlags
+          let
+              bh = blackHoleOnEntry closure_info &&
+                   not (gopt Opt_SccProfilingOn dflags) &&
+                   gopt Opt_EagerBlackHoling dflags
+
+              lbl | bh        = mkBHUpdInfoLabel
+                  | otherwise = mkUpdInfoLabel
+
+          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
+
+  | otherwise   -- A static closure
+  = do  { tickyUpdateBhCaf closure_info
+
+        ; if closureUpdReqd closure_info
+          then do       -- Blackhole the (updatable) CAF:
+                { upd_closure <- link_caf node True
+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
+          else do {tickyUpdateFrameOmitted; body}
+    }
+
+-----------------------------------------------------------------------------
+-- Setting up update frames
+
+-- Push the update frame on the stack in the Entry area,
+-- leaving room for the return address that is already
+-- at the old end of the area.
+--
+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
+pushUpdateFrame lbl updatee body
+  = do
+       updfr  <- getUpdFrameOff
+       dflags <- getDynFlags
+       let
+           hdr         = fixedHdrSize dflags
+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
+       --
+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
+       withUpdFrameOff frame body
+
+emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
+emitUpdateFrame dflags frame lbl updatee = do
+  let
+           hdr         = fixedHdrSize dflags
+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
+  --
+  emitStore frame (mkLblExpr lbl)
+  emitStore (cmmOffset dflags frame off_updatee) updatee
+  initUpdFrameProf frame
+
+-----------------------------------------------------------------------------
+-- Entering a CAF
+--
+-- See Note [CAF management] in rts/sm/Storage.c
+
+link_caf :: LocalReg           -- pointer to the closure
+         -> Bool               -- True <=> updatable, False <=> single-entry
+         -> FCode CmmExpr      -- Returns amode for closure to be updated
+-- This function returns the address of the black hole, so it can be
+-- updated with the new value when available.
+link_caf node _is_upd = do
+  { dflags <- getDynFlags
+        -- Call the RTS function newCAF, returning the newly-allocated
+        -- blackhole indirection closure
+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
+                                    ForeignLabelInExternalPackage IsFunction
+  ; bh <- newTemp (bWord dflags)
+  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
+      [ (baseExpr,  AddrHint),
+        (CmmReg (CmmLocal node), AddrHint) ]
+      False
+
+  -- see Note [atomic CAF entry] in rts/sm/Storage.c
+  ; updfr  <- getUpdFrameOff
+  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))
+  ; emit =<< mkCmmIfThen
+      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))
+        -- re-enter the CAF
+       (mkJump dflags NativeNodeCall target [] updfr)
+
+  ; return (CmmReg (CmmLocal bh)) }
+
+------------------------------------------------------------------------
+--              Profiling
+------------------------------------------------------------------------
+
+-- For "global" data constructors the description is simply occurrence
+-- name of the data constructor itself.  Otherwise it is determined by
+-- @closureDescription@ from the let binding information.
+
+closureDescription :: DynFlags
+           -> Module            -- Module
+                   -> Name              -- Id of closure binding
+                   -> String
+        -- Not called for StgRhsCon which have global info tables built in
+        -- CgConTbls.hs with a description generated from the data constructor
+closureDescription dflags mod_name name
+  = showSDocDump dflags (char '<' <>
+                    (if isExternalName name
+                      then ppr name -- ppr will include the module name prefix
+                      else pprModule mod_name <> char '.' <> ppr name) <>
+                    char '>')
+   -- showSDocDump, because we want to see the unique on the Name.
diff --git a/compiler/codeGen/StgCmmBind.hs-boot b/compiler/codeGen/StgCmmBind.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmBind.hs-boot
@@ -0,0 +1,6 @@
+module StgCmmBind where
+
+import StgCmmMonad( FCode )
+import StgSyn( CgStgBinding )
+
+cgBind :: CgStgBinding -> FCode ()
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -0,0 +1,1000 @@
+{-# LANGUAGE CPP, RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation:
+--
+-- The types   LambdaFormInfo
+--             ClosureInfo
+--
+-- Nothing monadic in here!
+--
+-----------------------------------------------------------------------------
+
+module StgCmmClosure (
+        DynTag,  tagForCon, isSmallFamily,
+
+        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
+        argPrimRep,
+
+        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
+        assertNonVoidIds, assertNonVoidStgArgs,
+
+        -- * LambdaFormInfo
+        LambdaFormInfo,         -- Abstract
+        StandardFormInfo,        -- ...ditto...
+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+        mkLFStringLit,
+        lfDynTag,
+        isLFThunk, isLFReEntrant, lfUpdatable,
+
+        -- * Used by other modules
+        CgLoc(..), SelfLoopInfo, CallMethod(..),
+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,
+
+        -- * ClosureInfo
+        ClosureInfo,
+        mkClosureInfo,
+        mkCmmInfo,
+
+        -- ** Inspection
+        closureLFInfo, closureName,
+
+        -- ** Labels
+        -- These just need the info table label
+        closureInfoLabel, staticClosureLabel,
+        closureSlowEntryLabel, closureLocalEntryLabel,
+
+        -- ** Predicates
+        -- These are really just functions on LambdaFormInfo
+        closureUpdReqd, closureSingleEntry,
+        closureReEntrant, closureFunInfo,
+        isToplevClosure,
+
+        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep
+        isStaticClosure,   -- Needs SMPre
+
+        -- * InfoTables
+        mkDataConInfoTable,
+        cafBlackHoleInfoTable,
+        indStaticInfoTable,
+        staticClosureNeedsLink,
+    ) where
+
+#include "../includes/MachDeps.h"
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+import SMRep
+import Cmm
+import PprCmmExpr()
+
+import CostCentre
+import BlockId
+import CLabel
+import Id
+import IdInfo
+import DataCon
+import Name
+import Type
+import TyCoRep
+import TcType
+import TyCon
+import RepType
+import BasicTypes
+import Outputable
+import DynFlags
+import Util
+
+import Data.Coerce (coerce)
+import qualified Data.ByteString.Char8 as BS8
+
+-----------------------------------------------------------------------------
+--                Data types and synonyms
+-----------------------------------------------------------------------------
+
+-- These data types are mostly used by other modules, especially StgCmmMonad,
+-- but we define them here because some functions in this module need to
+-- have access to them as well
+
+data CgLoc
+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
+                        -- Hp, so that it remains valid across calls
+
+  | LneLoc BlockId [LocalReg]             -- A join point
+        -- A join point (= let-no-escape) should only
+        -- be tail-called, and in a saturated way.
+        -- To tail-call it, assign to these locals,
+        -- and branch to the block id
+
+instance Outputable CgLoc where
+  ppr (CmmLoc e)    = text "cmm" <+> ppr e
+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs
+
+type SelfLoopInfo = (Id, BlockId, [LocalReg])
+
+-- used by ticky profiling
+isKnownFun :: LambdaFormInfo -> Bool
+isKnownFun LFReEntrant{} = True
+isKnownFun LFLetNoEscape = True
+isKnownFun _             = False
+
+
+-------------------------------------
+--        Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+  deriving (Eq, Show)
+
+fromNonVoid :: NonVoid a -> a
+fromNonVoid (NonVoid a) = a
+
+instance (Outputable a) => Outputable (NonVoid a) where
+  ppr (NonVoid a) = ppr a
+
+nonVoidIds :: [Id] -> [NonVoid Id]
+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]
+
+-- | Used in places where some invariant ensures that all these Ids are
+-- non-void; e.g. constructor field binders in case expressions.
+-- See Note [Post-unarisation invariants] in UnariseStg.
+assertNonVoidIds :: [Id] -> [NonVoid Id]
+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))
+                       coerce ids
+
+nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]
+
+-- | Used in places where some invariant ensures that all these arguments are
+-- non-void; e.g. constructor arguments.
+-- See Note [Post-unarisation invariants] in UnariseStg.
+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
+                            coerce args
+
+
+-----------------------------------------------------------------------------
+--                Representations
+-----------------------------------------------------------------------------
+
+-- Why are these here?
+
+idPrimRep :: Id -> PrimRep
+idPrimRep id = typePrimRep1 (idType id)
+    -- NB: typePrimRep1 fails on unboxed tuples,
+    --     but by StgCmm no Ids have unboxed tuple type
+
+addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
+addIdReps = map (\id -> let id' = fromNonVoid id
+                         in NonVoid (idPrimRep id', id'))
+
+addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
+addArgReps = map (\arg -> let arg' = fromNonVoid arg
+                           in NonVoid (argPrimRep arg', arg'))
+
+argPrimRep :: StgArg -> PrimRep
+argPrimRep arg = typePrimRep1 (stgArgType arg)
+
+
+-----------------------------------------------------------------------------
+--                LambdaFormInfo
+-----------------------------------------------------------------------------
+
+-- Information about an identifier, from the code generator's point of
+-- view.  Every identifier is bound to a LambdaFormInfo in the
+-- environment, which gives the code generator enough info to be able to
+-- tail call or return that identifier.
+
+data LambdaFormInfo
+  = LFReEntrant         -- Reentrant closure (a function)
+        TopLevelFlag    -- True if top level
+        OneShotInfo
+        !RepArity       -- Arity. Invariant: always > 0
+        !Bool           -- True <=> no fvs
+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
+
+  | LFThunk             -- Thunk (zero arity)
+        TopLevelFlag
+        !Bool           -- True <=> no free vars
+        !Bool           -- True <=> updatable (i.e., *not* single-entry)
+        StandardFormInfo
+        !Bool           -- True <=> *might* be a function type
+
+  | LFCon               -- A saturated constructor application
+        DataCon         -- The constructor
+
+  | LFUnknown           -- Used for function arguments and imported things.
+                        -- We know nothing about this closure.
+                        -- Treat like updatable "LFThunk"...
+                        -- Imported things which we *do* know something about use
+                        -- one of the other LF constructors (eg LFReEntrant for
+                        -- known functions)
+        !Bool           -- True <=> *might* be a function type
+                        --      The False case is good when we want to enter it,
+                        --        because then we know the entry code will do
+                        --        For a function, the entry code is the fast entry point
+
+  | LFUnlifted          -- A value of unboxed type;
+                        -- always a value, needs evaluation
+
+  | LFLetNoEscape       -- See LetNoEscape module for precise description
+
+
+-------------------------
+-- StandardFormInfo tells whether this thunk has one of
+-- a small number of standard forms
+
+data StandardFormInfo
+  = NonStandardThunk
+        -- The usual case: not of the standard forms
+
+  | SelectorThunk
+        -- A SelectorThunk is of form
+        --      case x of
+        --           con a1,..,an -> ak
+        -- and the constructor is from a single-constr type.
+       WordOff          -- 0-origin offset of ak within the "goods" of
+                        -- constructor (Recall that the a1,...,an may be laid
+                        -- out in the heap in a non-obvious order.)
+
+  | ApThunk
+        -- An ApThunk is of form
+        --        x1 ... xn
+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+        -- in the RTS to save space.
+        RepArity                -- Arity, n
+
+
+------------------------------------------------------
+--                Building LambdaFormInfo
+------------------------------------------------------
+
+mkLFArgument :: Id -> LambdaFormInfo
+mkLFArgument id
+  | isUnliftedType ty      = LFUnlifted
+  | might_be_a_function ty = LFUnknown True
+  | otherwise              = LFUnknown False
+  where
+    ty = idType id
+
+-------------
+mkLFLetNoEscape :: LambdaFormInfo
+mkLFLetNoEscape = LFLetNoEscape
+
+-------------
+mkLFReEntrant :: TopLevelFlag    -- True of top level
+              -> [Id]            -- Free vars
+              -> [Id]            -- Args
+              -> ArgDescr        -- Argument descriptor
+              -> LambdaFormInfo
+
+mkLFReEntrant _ _ [] _
+  = pprPanic "mkLFReEntrant" empty
+mkLFReEntrant top fvs args arg_descr
+  = LFReEntrant top os_info (length args) (null fvs) arg_descr
+  where os_info = idOneShotInfo (head args)
+
+-------------
+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
+mkLFThunk thunk_ty top fvs upd_flag
+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
+    LFThunk top (null fvs)
+            (isUpdatable upd_flag)
+            NonStandardThunk
+            (might_be_a_function thunk_ty)
+
+--------------
+might_be_a_function :: Type -> Bool
+-- Return False only if we are *sure* it's a data type
+-- Look through newtypes etc as much as poss
+might_be_a_function ty
+  | [LiftedRep] <- typePrimRep ty
+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
+  , isDataTyCon tc
+  = False
+  | otherwise
+  = True
+
+-------------
+mkConLFInfo :: DataCon -> LambdaFormInfo
+mkConLFInfo con = LFCon con
+
+-------------
+mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
+mkSelectorLFInfo id offset updatable
+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+        (might_be_a_function (idType id))
+
+-------------
+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
+mkApLFInfo id upd_flag arity
+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+        (might_be_a_function (idType id))
+
+-------------
+mkLFImported :: Id -> LambdaFormInfo
+mkLFImported id
+  | Just con <- isDataConWorkId_maybe id
+  , isNullaryRepDataCon con
+  = LFCon con   -- An imported nullary constructor
+                -- We assume that the constructor is evaluated so that
+                -- the id really does point directly to the constructor
+
+  | arity > 0
+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
+
+  | otherwise
+  = mkLFArgument id -- Not sure of exact arity
+  where
+    arity = idFunRepArity id
+
+-------------
+mkLFStringLit :: LambdaFormInfo
+mkLFStringLit = LFUnlifted
+
+-----------------------------------------------------
+--                Dynamic pointer tagging
+-----------------------------------------------------
+
+type DynTag = Int       -- The tag on a *pointer*
+                        -- (from the dynamic-tagging paper)
+
+-- Note [Data constructor dynamic tags]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The family size of a data type (the number of constructors
+-- or the arity of a function) can be either:
+--    * small, if the family size < 2**tag_bits
+--    * big, otherwise.
+--
+-- Small families can have the constructor tag in the tag bits.
+-- Big families only use the tag value 1 to represent evaluatedness.
+-- We don't have very many tag bits: for example, we have 2 bits on
+-- x86-32 and 3 bits on x86-64.
+
+isSmallFamily :: DynFlags -> Int -> Bool
+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
+
+tagForCon :: DynFlags -> DataCon -> DynTag
+tagForCon dflags con
+  | isSmallFamily dflags fam_size = con_tag
+  | otherwise                     = 1
+  where
+    con_tag  = dataConTag con -- NB: 1-indexed
+    fam_size = tyConFamilySize (dataConTyCon con)
+
+tagForArity :: DynFlags -> RepArity -> DynTag
+tagForArity dflags arity
+ | isSmallFamily dflags arity = arity
+ | otherwise                  = 0
+
+lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
+-- Return the tag in the low order bits of a variable bound
+-- to this LambdaForm
+lfDynTag dflags (LFCon con)                 = tagForCon dflags con
+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
+lfDynTag _      _other                      = 0
+
+
+-----------------------------------------------------------------------------
+--                Observing LambdaFormInfo
+-----------------------------------------------------------------------------
+
+------------
+isLFThunk :: LambdaFormInfo -> Bool
+isLFThunk (LFThunk {})  = True
+isLFThunk _ = False
+
+isLFReEntrant :: LambdaFormInfo -> Bool
+isLFReEntrant (LFReEntrant {}) = True
+isLFReEntrant _                = False
+
+-----------------------------------------------------------------------------
+--                Choosing SM reps
+-----------------------------------------------------------------------------
+
+lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
+                                                      (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
+lfClosureType _                              = panic "lfClosureType"
+
+thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
+thunkClosureType (SelectorThunk off) = ThunkSelector off
+thunkClosureType _                   = Thunk
+
+-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
+-- gets compiled to a jump to g (if g has non-zero arity), instead of
+-- messing around with update frames and PAPs.  We set the closure type
+-- to FUN_STATIC in this case.
+
+-----------------------------------------------------------------------------
+--                nodeMustPointToIt
+-----------------------------------------------------------------------------
+
+nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
+-- If nodeMustPointToIt is true, then the entry convention for
+-- this closure has R1 (the "Node" register) pointing to the
+-- closure itself --- the "self" argument
+
+nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
+  =  not no_fvs          -- Certainly if it has fvs we need to point to it
+  || isNotTopLevel top   -- See Note [GC recovery]
+        -- For lex_profiling we also access the cost centre for a
+        -- non-inherited (i.e. non-top-level) function.
+        -- The isNotTopLevel test above ensures this is ok.
+
+nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
+  =  not no_fvs            -- Self parameter
+  || isNotTopLevel top     -- Note [GC recovery]
+  || updatable             -- Need to push update frame
+  || gopt Opt_SccProfilingOn dflags
+          -- For the non-updatable (single-entry case):
+          --
+          -- True if has fvs (in which case we need access to them, and we
+          --                    should black-hole it)
+          -- or profiling (in which case we need to recover the cost centre
+          --                 from inside it)  ToDo: do we need this even for
+          --                                    top-level thunks? If not,
+          --                                    isNotTopLevel subsumes this
+
+nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk
+  = True
+
+nodeMustPointToIt _ (LFCon _) = True
+
+        -- Strictly speaking, the above two don't need Node to point
+        -- to it if the arity = 0.  But this is a *really* unlikely
+        -- situation.  If we know it's nil (say) and we are entering
+        -- it. Eg: let x = [] in x then we will certainly have inlined
+        -- x, since nil is a simple atom.  So we gain little by not
+        -- having Node point to known zero-arity things.  On the other
+        -- hand, we do lose something; Patrick's code for figuring out
+        -- when something has been updated but not entered relies on
+        -- having Node point to the result of an update.  SLPJ
+        -- 27/11/92.
+
+nodeMustPointToIt _ (LFUnknown _)   = True
+nodeMustPointToIt _ LFUnlifted      = False
+nodeMustPointToIt _ LFLetNoEscape   = False
+
+{- Note [GC recovery]
+~~~~~~~~~~~~~~~~~~~~~
+If we a have a local let-binding (function or thunk)
+   let f = <body> in ...
+AND <body> allocates, then the heap-overflow check needs to know how
+to re-start the evaluation.  It uses the "self" pointer to do this.
+So even if there are no free variables in <body>, we still make
+nodeMustPointToIt be True for non-top-level bindings.
+
+Why do any such bindings exist?  After all, let-floating should have
+floated them out.  Well, a clever optimiser might leave one there to
+avoid a space leak, deliberately recomputing a thunk.  Also (and this
+really does happen occasionally) let-floating may make a function f smaller
+so it can be inlined, so now (f True) may generate a local no-fv closure.
+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
+in TcGenDeriv.) -}
+
+-----------------------------------------------------------------------------
+--                getCallMethod
+-----------------------------------------------------------------------------
+
+{- The entry conventions depend on the type of closure being entered,
+whether or not it has free variables, and whether we're running
+sequentially or in parallel.
+
+Closure                           Node   Argument   Enter
+Characteristics              Par   Req'd  Passing    Via
+---------------------------------------------------------------------------
+Unknown                     & no  & yes & stack     & node
+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)
+                                                    & slow entry (otherwise)
+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)
+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry
+0 arg, no fvs \u            & no  & yes & n/a       & node
+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node
+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry
+0 arg, fvs \u               & no  & yes & n/a       & node
+Unknown                     & yes & yes & stack     & node
+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)
+                                                    & slow entry (otherwise)
+Known fun (>1 arg), fvs     & yes & yes & registers & node
+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node
+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry
+0 arg, no fvs \u            & yes & yes & n/a       & node
+0 arg, fvs \r,\s            & yes & yes & n/a       & node
+0 arg, fvs \u               & yes & yes & n/a       & node
+
+When black-holing, single-entry closures could also be entered via node
+(rather than directly) to catch double-entry. -}
+
+data CallMethod
+  = EnterIt             -- No args, not a function
+
+  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
+
+  | ReturnIt            -- It's a value (function, unboxed value,
+                        -- or constructor), so just return it.
+
+  | SlowCall                -- Unknown fun, or known fun with
+                        -- too few args.
+
+  | DirectEntry         -- Jump directly, with args in regs
+        CLabel          --   The code label
+        RepArity        --   Its arity
+
+getCallMethod :: DynFlags
+              -> Name           -- Function being applied
+              -> Id             -- Function Id used to chech if it can refer to
+                                -- CAF's and whether the function is tail-calling
+                                -- itself
+              -> LambdaFormInfo -- Its info
+              -> RepArity       -- Number of available arguments
+              -> RepArity       -- Number of them being void arguments
+              -> CgLoc          -- Passed in from cgIdApp so that we can
+                                -- handle let-no-escape bindings and self-recursive
+                                -- tail calls using the same data constructor,
+                                -- JumpToIt. This saves us one case branch in
+                                -- cgIdApp
+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
+              -> CallMethod
+
+getCallMethod dflags _ id _ n_args v_args _cg_loc
+              (Just (self_loop_id, block_id, args))
+  | gopt Opt_Loopification dflags
+  , id == self_loop_id
+  , args `lengthIs` (n_args - v_args)
+  -- If these patterns match then we know that:
+  --   * loopification optimisation is turned on
+  --   * function is performing a self-recursive call in a tail position
+  --   * number of non-void parameters of the function matches functions arity.
+  -- See Note [Self-recursive tail calls] and Note [Void arguments in
+  -- self-recursive tail calls] in StgCmmExpr for more details
+  = JumpToIt block_id args
+
+getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+              _self_loop_info
+  | n_args == 0 -- No args at all
+  && not (gopt Opt_SccProfilingOn dflags)
+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
+  = ASSERT( arity /= 0 ) ReturnIt
+  | n_args < arity = SlowCall        -- Not enough args
+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
+
+getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
+  = ASSERT( n_args == 0 ) ReturnIt
+
+getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
+  = ASSERT( n_args == 0 ) ReturnIt
+    -- n_args=0 because it'd be ill-typed to apply a saturated
+    --          constructor application to anything
+
+getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+              n_args _v_args _cg_loc _self_loop_info
+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
+                -- is the fast-entry code]
+
+  -- Since is_fun is False, we are *definitely* looking at a data value
+  | updatable || gopt Opt_Ticky dflags -- to catch double entry
+      {- OLD: || opt_SMP
+         I decided to remove this, because in SMP mode it doesn't matter
+         if we enter the same thunk multiple times, so the optimisation
+         of jumping directly to the entry code is still valid.  --SDM
+        -}
+  = EnterIt
+
+  -- even a non-updatable selector thunk can be updated by the garbage
+  -- collector, so we must enter it. (#8817)
+  | SelectorThunk{} <- std_form_info
+  = EnterIt
+
+    -- We used to have ASSERT( n_args == 0 ), but actually it is
+    -- possible for the optimiser to generate
+    --   let bot :: Int = error Int "urk"
+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
+    -- This happens as a result of the case-of-error transformation
+    -- So the right thing to do is just to enter the thing
+
+  | otherwise        -- Jump direct to code for single-entry thunks
+  = ASSERT( n_args == 0 )
+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
+                updatable) 0
+
+getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
+  = SlowCall -- might be a function
+
+getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
+    EnterIt -- Not a function
+
+getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
+              _self_loop_info
+  = JumpToIt blk_id lne_regs
+
+getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
+
+-----------------------------------------------------------------------------
+--              Data types for closure information
+-----------------------------------------------------------------------------
+
+
+{- ClosureInfo: information about a binding
+
+   We make a ClosureInfo for each let binding (both top level and not),
+   but not bindings for data constructors: for those we build a CmmInfoTable
+   directly (see mkDataConInfoTable).
+
+   To a first approximation:
+       ClosureInfo = (LambdaFormInfo, CmmInfoTable)
+
+   A ClosureInfo has enough information
+     a) to construct the info table itself, and build other things
+        related to the binding (e.g. slow entry points for a function)
+     b) to allocate a closure containing that info pointer (i.e.
+           it knows the info table label)
+-}
+
+data ClosureInfo
+  = ClosureInfo {
+        closureName :: !Name,           -- The thing bound to this closure
+           -- we don't really need this field: it's only used in generating
+           -- code for ticky and profiling, and we could pass the information
+           -- around separately, but it doesn't do much harm to keep it here.
+
+        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
+          -- this tells us about what the closure contains: it's right-hand-side.
+
+          -- the rest is just an unpacked CmmInfoTable.
+        closureInfoLabel :: !CLabel,
+        closureSMRep     :: !SMRep,          -- representation used by storage mgr
+        closureProf      :: !ProfilingInfo
+    }
+
+-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
+mkCmmInfo ClosureInfo {..} id ccs
+  = CmmInfoTable { cit_lbl  = closureInfoLabel
+                 , cit_rep  = closureSMRep
+                 , cit_prof = closureProf
+                 , cit_srt  = Nothing
+                 , cit_clo  = if isStaticRep closureSMRep
+                                then Just (id,ccs)
+                                else Nothing }
+
+--------------------------------------
+--        Building ClosureInfos
+--------------------------------------
+
+mkClosureInfo :: DynFlags
+              -> Bool                -- Is static
+              -> Id
+              -> LambdaFormInfo
+              -> Int -> Int        -- Total and pointer words
+              -> String         -- String descriptor
+              -> ClosureInfo
+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
+  = ClosureInfo { closureName      = name
+                , closureLFInfo    = lf_info
+                , closureInfoLabel = info_lbl   -- These three fields are
+                , closureSMRep     = sm_rep     -- (almost) an info table
+                , closureProf      = prof }     -- (we don't have an SRT yet)
+  where
+    name       = idName id
+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
+    prof       = mkProfilingInfo dflags id val_descr
+    nonptr_wds = tot_wds - ptr_wds
+
+    info_lbl = mkClosureInfoTableLabel id lf_info
+
+--------------------------------------
+--   Other functions over ClosureInfo
+--------------------------------------
+
+-- Eager blackholing is normally disabled, but can be turned on with
+-- -feager-blackholing.  When it is on, we replace the info pointer of
+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.
+
+-- If we wanted to do eager blackholing with slop filling,
+-- we'd need to do it at the *end* of a basic block, otherwise
+-- we overwrite the free variables in the thunk that we still
+-- need.  We have a patch for this from Andy Cheadle, but not
+-- incorporated yet. --SDM [6/2004]
+--
+-- Previously, eager blackholing was enabled when ticky-ticky
+-- was on. But it didn't work, and it wasn't strictly necessary
+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
+-- is unconditionally disabled. -- krc 1/2007
+--
+-- Static closures are never themselves black-holed.
+
+blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry cl_info
+  | isStaticRep (closureSMRep cl_info)
+  = False        -- Never black-hole a static closure
+
+  | otherwise
+  = case closureLFInfo cl_info of
+      LFReEntrant {}            -> False
+      LFLetNoEscape             -> False
+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
+      _other -> panic "blackHoleOnEntry"
+
+{- Note [Black-holing non-updatable thunks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not black-hole non-updatable (single-entry) thunks otherwise
+we run into issues like #10414. Specifically:
+
+  * There is no reason to black-hole a non-updatable thunk: it should
+    not be competed for by multiple threads
+
+  * It could, conceivably, cause a space leak if we don't black-hole
+    it, if there was a live but never-followed pointer pointing to it.
+    Let's hope that doesn't happen.
+
+  * It is dangerous to black-hole a non-updatable thunk because
+     - is not updated (of course)
+     - hence, if it is black-holed and another thread tries to evaluate
+       it, that thread will block forever
+    This actually happened in #10414.  So we do not black-hole
+    non-updatable thunks.
+
+  * How could two threads evaluate the same non-updatable (single-entry)
+    thunk?  See Reid Barton's example below.
+
+  * Only eager blackholing could possibly black-hole a non-updatable
+    thunk, because lazy black-holing only affects thunks with an
+    update frame on the stack.
+
+Here is and example due to Reid Barton (#10414):
+    x = \u []  concat [[1], []]
+with the following definitions,
+
+    concat x = case x of
+        []       -> []
+        (:) x xs -> (++) x (concat xs)
+
+    (++) xs ys = case xs of
+        []         -> ys
+        (:) x rest -> (:) x ((++) rest ys)
+
+Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
+to WHNF and calls @(++)@ the heap will contain the following thunks,
+
+    x = 1 : y
+    y = \u []  (++) [] z
+    z = \s []  concat []
+
+Now that the stage is set, consider the follow evaluations by two racing threads
+A and B,
+
+  1. Both threads enter @y@ before either is able to replace it with an
+     indirection
+
+  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
+     replacing it with a black-hole
+
+  3. At some later point thread B does the same case analysis and also attempts
+     to enter @z@. However, it finds that it has been replaced with a black-hole
+     so it blocks.
+
+  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
+     accordingly. It does *not* update @z@, however, as it is single-entry. This
+     leaves Thread B blocked forever on a black-hole which will never be
+     updated.
+
+To avoid this sort of condition we never black-hole non-updatable thunks.
+-}
+
+isStaticClosure :: ClosureInfo -> Bool
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
+
+closureUpdReqd :: ClosureInfo -> Bool
+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
+
+lfUpdatable :: LambdaFormInfo -> Bool
+lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable _ = False
+
+closureSingleEntry :: ClosureInfo -> Bool
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
+closureSingleEntry _ = False
+
+closureReEntrant :: ClosureInfo -> Bool
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
+closureReEntrant _ = False
+
+closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
+
+lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)
+lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)
+lfFunInfo _                                   = Nothing
+
+funTag :: DynFlags -> ClosureInfo -> DynTag
+funTag dflags (ClosureInfo { closureLFInfo = lf_info })
+    = lfDynTag dflags lf_info
+
+isToplevClosure :: ClosureInfo -> Bool
+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
+  = case lf_info of
+      LFReEntrant TopLevel _ _ _ _ -> True
+      LFThunk TopLevel _ _ _ _     -> True
+      _other                       -> False
+
+--------------------------------------
+--   Label generation
+--------------------------------------
+
+staticClosureLabel :: ClosureInfo -> CLabel
+staticClosureLabel = toClosureLbl .  closureInfoLabel
+
+closureSlowEntryLabel :: ClosureInfo -> CLabel
+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
+
+closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
+closureLocalEntryLabel dflags
+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel
+  | otherwise               = toEntryLbl . closureInfoLabel
+
+mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
+mkClosureInfoTableLabel id lf_info
+  = case lf_info of
+        LFThunk _ _ upd_flag (SelectorThunk offset) _
+                      -> mkSelectorInfoLabel upd_flag offset
+
+        LFThunk _ _ upd_flag (ApThunk arity) _
+                      -> mkApInfoTableLabel upd_flag arity
+
+        LFThunk{}     -> std_mk_lbl name cafs
+        LFReEntrant{} -> std_mk_lbl name cafs
+        _other        -> panic "closureInfoTableLabel"
+
+  where
+    name = idName id
+
+    std_mk_lbl | is_local  = mkLocalInfoTableLabel
+               | otherwise = mkInfoTableLabel
+
+    cafs     = idCafInfo id
+    is_local = isDataConWorkId id
+       -- Make the _info pointer for the implicit datacon worker
+       -- binding local. The reason we can do this is that importing
+       -- code always either uses the _closure or _con_info. By the
+       -- invariants in CorePrep anything else gets eta expanded.
+
+
+thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
+-- thunkEntryLabel is a local help function, not exported.  It's used from
+-- getCallMethod.
+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
+  = enterApLabel dflags upd_flag arity
+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
+  = enterSelectorLabel dflags upd_flag offset
+thunkEntryLabel dflags thunk_id c _ _
+  = enterIdLabel dflags thunk_id c
+
+enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
+enterApLabel dflags is_updatable arity
+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
+  | otherwise               = mkApEntryLabel is_updatable arity
+
+enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
+enterSelectorLabel dflags upd_flag offset
+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
+  | otherwise               = mkSelectorEntryLabel upd_flag offset
+
+enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
+enterIdLabel dflags id c
+  | tablesNextToCode dflags = mkInfoTableLabel id c
+  | otherwise               = mkEntryLabel id c
+
+
+--------------------------------------
+--   Profiling
+--------------------------------------
+
+-- Profiling requires two pieces of information to be determined for
+-- each closure's info table --- description and type.
+
+-- The description is stored directly in the @CClosureInfoTable@ when the
+-- info table is built.
+
+-- The type is determined from the type information stored with the @Id@
+-- in the closure info using @closureTypeDescr@.
+
+mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
+mkProfilingInfo dflags id val_descr
+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
+  where
+    ty_descr_w8  = BS8.pack (getTyDescription (idType id))
+
+getTyDescription :: Type -> String
+getTyDescription ty
+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+    case tau_ty of
+      TyVarTy _              -> "*"
+      AppTy fun _            -> getTyDescription fun
+      TyConApp tycon _       -> getOccString tycon
+      FunTy {}              -> '-' : fun_result tau_ty
+      ForAllTy _  ty         -> getTyDescription ty
+      LitTy n                -> getTyLitDescription n
+      CastTy ty _            -> getTyDescription ty
+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)
+    }
+  where
+    fun_result (FunTy { ft_res = res }) = '>' : fun_result res
+    fun_result other                    = getTyDescription other
+
+getTyLitDescription :: TyLit -> String
+getTyLitDescription l =
+  case l of
+    NumTyLit n -> show n
+    StrTyLit n -> show n
+
+--------------------------------------
+--   CmmInfoTable-related things
+--------------------------------------
+
+mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
+ = CmmInfoTable { cit_lbl  = info_lbl
+                , cit_rep  = sm_rep
+                , cit_prof = prof
+                , cit_srt  = Nothing
+                , cit_clo  = Nothing }
+ where
+   name = dataConName data_con
+   info_lbl = mkConInfoTableLabel name NoCafRefs
+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
+                  -- We keep the *zero-indexed* tag in the srt_len field
+                  -- of the info table of a data constructor.
+
+   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+        | otherwise                            = ProfilingInfo ty_descr val_descr
+
+   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
+   val_descr = BS8.pack $ occNameString $ getOccName data_con
+
+-- We need a black-hole closure info to pass to @allocDynClosure@ when we
+-- want to allocate the black hole on entry to a CAF.
+
+cafBlackHoleInfoTable :: CmmInfoTable
+cafBlackHoleInfoTable
+  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
+                 , cit_rep  = blackHoleRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+indStaticInfoTable :: CmmInfoTable
+indStaticInfoTable
+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
+                 , cit_rep  = indStaticRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
+-- A static closure needs a link field to aid the GC when traversing
+-- the static closure graph.  But it only needs such a field if either
+--        a) it has an SRT
+--        b) it's a constructor with one or more pointer fields
+-- In case (b), the constructor's fields themselves play the role
+-- of the SRT.
+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
+  | isConRep smrep         = not (isStaticNoCafCon smrep)
+  | otherwise              = has_srt
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -0,0 +1,285 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C--: code generation for constructors
+--
+-- This module provides the support code for StgCmm to deal with with
+-- constructors on the RHSs of let(rec)s.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmCon (
+        cgTopRhsCon, buildDynCon, bindConArgs
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+import CoreSyn  ( AltCon(..) )
+
+import StgCmmMonad
+import StgCmmEnv
+import StgCmmHeap
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+
+import CmmExpr
+import CmmUtils
+import CLabel
+import MkGraph
+import SMRep
+import CostCentre
+import Module
+import DataCon
+import DynFlags
+import FastString
+import Id
+import RepType (countConRepArgs)
+import Literal
+import PrelInfo
+import Outputable
+import Platform
+import Util
+import MonadUtils (mapMaybeM)
+
+import Control.Monad
+import Data.Char
+
+
+
+---------------------------------------------------------------
+--      Top-level constructors
+---------------------------------------------------------------
+
+cgTopRhsCon :: DynFlags
+            -> Id               -- Name of thing bound to this RHS
+            -> DataCon          -- Id
+            -> [NonVoid StgArg] -- Args
+            -> (CgIdInfo, FCode ())
+cgTopRhsCon dflags id con args =
+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
+    in (id_info, gen_code)
+  where
+   name          = idName id
+   caffy         = idCafInfo id -- any stgArgHasCafRefs args
+   closure_label = mkClosureLabel name caffy
+
+   gen_code =
+     do { this_mod <- getModuleName
+        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
+              -- Windows DLLs have a problem with static cross-DLL refs.
+              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
+        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()
+
+        -- LAY IT OUT
+        ; let
+            (tot_wds, --  #ptr_wds + #nonptr_wds
+             ptr_wds, --  #ptr_wds
+             nv_args_w_offsets) =
+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
+
+            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
+            mk_payload (FieldOff arg _) = do
+                amode <- getArgAmode arg
+                case amode of
+                  CmmLit lit -> return lit
+                  _          -> panic "StgCmmCon.cgTopRhsCon"
+
+            nonptr_wds = tot_wds - ptr_wds
+
+             -- we're not really going to emit an info table, so having
+             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
+             -- needs to poke around inside it.
+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
+
+
+        ; payload <- mapM mk_payload nv_args_w_offsets
+                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
+                -- NB2: all the amodes should be Lits!
+                --      TODO (osa): Why?
+
+        ; let closure_rep = mkStaticClosureFields
+                             dflags
+                             info_tbl
+                             dontCareCCS                -- Because it's static data
+                             caffy                      -- Has CAF refs
+                             payload
+
+                -- BUILD THE OBJECT
+        ; emitDataLits closure_label closure_rep
+
+        ; return () }
+
+
+---------------------------------------------------------------
+--      Lay out and allocate non-top-level constructors
+---------------------------------------------------------------
+
+buildDynCon :: Id                 -- Name of the thing to which this constr will
+                                  -- be bound
+            -> Bool               -- is it genuinely bound to that name, or just
+                                  -- for profiling?
+            -> CostCentreStack    -- Where to grab cost centre from;
+                                  -- current CCS if currentOrSubsumedCCS
+            -> DataCon            -- The data constructor
+            -> [NonVoid StgArg]   -- Its args
+            -> FCode (CgIdInfo, FCode CmmAGraph)
+               -- Return details about how to find it and initialization code
+buildDynCon binder actually_bound cc con args
+    = do dflags <- getDynFlags
+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
+
+
+buildDynCon' :: DynFlags
+             -> Platform
+             -> Id -> Bool
+             -> CostCentreStack
+             -> DataCon
+             -> [NonVoid StgArg]
+             -> FCode (CgIdInfo, FCode CmmAGraph)
+
+{- We used to pass a boolean indicating whether all the
+args were of size zero, so we could use a static
+constructor; but I concluded that it just isn't worth it.
+Now I/O uses unboxed tuples there just aren't any constructors
+with all size-zero args.
+
+The reason for having a separate argument, rather than looking at
+the addr modes of the args is that we may be in a "knot", and
+premature looking at the args will cause the compiler to black-hole!
+-}
+
+
+-------- buildDynCon': Nullary constructors --------------
+-- First we deal with the case of zero-arity constructors.  They
+-- will probably be unfolded, so we don't expect to see this case much,
+-- if at all, but it does no harm, and sets the scene for characters.
+--
+-- In the case of zero-arity constructors, or, more accurately, those
+-- which have exclusively size-zero (VoidRep) args, we generate no code
+-- at all.
+
+buildDynCon' dflags _ binder _ _cc con []
+  | isNullaryRepDataCon con
+  = return (litIdInfo dflags binder (mkConLFInfo con)
+                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
+            return mkNop)
+
+-------- buildDynCon': Charlike and Intlike constructors -----------
+{- The following three paragraphs about @Char@-like and @Int@-like
+closures are obsolete, but I don't understand the details well enough
+to properly word them, sorry. I've changed the treatment of @Char@s to
+be analogous to @Int@s: only a subset is preallocated, because @Char@
+has now 31 bits. Only literals are handled here. -- Qrczak
+
+Now for @Char@-like closures.  We generate an assignment of the
+address of the closure to a temporary.  It would be possible simply to
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always assign to a temporary.
+
+Last special case: @Int@-like closures.  We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal.  Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
+
+Because of this, we use can safely return an addressing mode.
+
+We don't support this optimisation when compiling into Windows DLLs yet
+because they don't support cross package data references well.
+-}
+
+buildDynCon' dflags platform binder _ _cc con [arg]
+  | maybeIntLikeCon con
+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
+              val_int = fromIntegral val :: Int
+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
+                -- INTLIKE closures consist of a header and one word payload
+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
+                 , return mkNop) }
+
+buildDynCon' dflags platform binder _ _cc con [arg]
+  | maybeCharLikeCon con
+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
+  , NonVoid (StgLitArg (LitChar val)) <- arg
+  , let val_int = ord val :: Int
+  , val_int <= mAX_CHARLIKE dflags
+  , val_int >= mIN_CHARLIKE dflags
+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")
+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
+                -- CHARLIKE closures consist of a header and one word payload
+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
+                 , return mkNop) }
+
+-------- buildDynCon': the general case -----------
+buildDynCon' dflags _ binder actually_bound ccs con args
+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info
+        ; return (id_info, gen_code reg)
+        }
+ where
+  lf_info = mkConLFInfo con
+
+  gen_code reg
+    = do  { let (tot_wds, ptr_wds, args_w_offsets)
+                  = mkVirtConstrOffsets dflags (addArgReps args)
+                nonptr_wds = tot_wds - ptr_wds
+                info_tbl = mkDataConInfoTable dflags con False
+                                ptr_wds nonptr_wds
+          ; let ticky_name | actually_bound = Just binder
+                           | otherwise = Nothing
+
+          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
+                                          use_cc blame_cc args_w_offsets
+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+    where
+      use_cc      -- cost-centre to stick in the object
+        | isCurrentCCS ccs = cccsExpr
+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"
+
+      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
+
+
+---------------------------------------------------------------
+--      Binding constructor arguments
+---------------------------------------------------------------
+
+bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
+-- bindConArgs is called from cgAlt of a case
+-- (bindConArgs con args) augments the environment with bindings for the
+-- binders args, assuming that we have just returned from a 'case' which
+-- found a con
+bindConArgs (DataAlt con) base args
+  = ASSERT(not (isUnboxedTupleCon con))
+    do dflags <- getDynFlags
+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
+           tag = tagForCon dflags con
+
+           -- The binding below forces the masking out of the tag bits
+           -- when accessing the constructor field.
+           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
+           bind_arg (arg@(NonVoid b), offset)
+             | isDeadBinder b  -- See Note [Dead-binder optimisation] in StgCmmExpr
+             = return Nothing
+             | otherwise
+             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)
+                                              base offset tag
+                  ; Just <$> bindArgToReg arg }
+
+       mapMaybeM bind_arg args_w_offsets
+
+bindConArgs _other_con _base args
+  = ASSERT( null args ) return []
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -0,0 +1,208 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: the binding environment
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+module StgCmmEnv (
+        CgIdInfo,
+
+        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
+        idInfoToAmode,
+
+        addBindC, addBindsC,
+
+        bindArgsToRegs, bindToReg, rebindToReg,
+        bindArgToReg, idToReg,
+        getArgAmode, getNonVoidArgAmodes,
+        getCgIdInfo,
+        maybeLetNoEscape,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TyCon
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmClosure
+
+import CLabel
+
+import BlockId
+import CmmExpr
+import CmmUtils
+import DynFlags
+import Id
+import MkGraph
+import Name
+import Outputable
+import StgSyn
+import Type
+import TysPrim
+import UniqFM
+import Util
+import VarEnv
+
+-------------------------------------
+--        Manipulating CgIdInfo
+-------------------------------------
+
+mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
+mkCgIdInfo id lf expr
+  = CgIdInfo { cg_id = id, cg_lf = lf
+             , cg_loc = CmmLoc expr }
+
+litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
+litIdInfo dflags id lf lit
+  = CgIdInfo { cg_id = id, cg_lf = lf
+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
+  where
+    tag = lfDynTag dflags lf
+
+lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
+lneIdInfo dflags id regs
+  = CgIdInfo { cg_id = id, cg_lf = lf
+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
+  where
+    lf     = mkLFLetNoEscape
+    blk_id = mkBlockId (idUnique id)
+
+
+rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
+rhsIdInfo id lf_info
+  = do dflags <- getDynFlags
+       reg <- newTemp (gcWord dflags)
+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
+
+mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
+mkRhsInit dflags reg lf_info expr
+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
+
+idInfoToAmode :: CgIdInfo -> CmmExpr
+-- Returns a CmmExpr for the *tagged* pointer
+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
+idInfoToAmode cg_info
+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc
+
+addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
+-- A tag adds a byte offset to the pointer
+addDynTag dflags expr tag = cmmOffsetB dflags expr tag
+
+maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
+maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
+maybeLetNoEscape _other                                      = Nothing
+
+
+
+---------------------------------------------------------
+--        The binding environment
+--
+-- There are three basic routines, for adding (addBindC),
+-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
+---------------------------------------------------------
+
+addBindC :: CgIdInfo -> FCode ()
+addBindC stuff_to_bind = do
+        binds <- getBinds
+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
+
+addBindsC :: [CgIdInfo] -> FCode ()
+addBindsC new_bindings = do
+        binds <- getBinds
+        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)
+                               binds
+                               new_bindings
+        setBinds new_binds
+
+getCgIdInfo :: Id -> FCode CgIdInfo
+getCgIdInfo id
+  = do  { dflags <- getDynFlags
+        ; local_binds <- getBinds -- Try local bindings first
+        ; case lookupVarEnv local_binds id of {
+            Just info -> return info ;
+            Nothing   -> do {
+
+                -- Should be imported; make up a CgIdInfo for it
+          let name = idName id
+        ; if isExternalName name then
+              let ext_lbl
+                      | isUnliftedType (idType id) =
+                          -- An unlifted external Id must refer to a top-level
+                          -- string literal. See Note [Bytes label] in CLabel.
+                          ASSERT( idType id `eqType` addrPrimTy )
+                          mkBytesLabel name
+                      | otherwise = mkClosureLabel name $ idCafInfo id
+              in return $
+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
+          else
+              cgLookupPanic id -- Bug
+        }}}
+
+cgLookupPanic :: Id -> FCode a
+cgLookupPanic id
+  = do  local_binds <- getBinds
+        pprPanic "StgCmmEnv: variable not found"
+                (vcat [ppr id,
+                text "local binds for:",
+                pprUFM local_binds $ \infos ->
+                  vcat [ ppr (cg_id info) | info <- infos ]
+              ])
+
+
+--------------------
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
+
+getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
+-- NB: Filters out void args,
+--     so the result list may be shorter than the argument list
+getNonVoidArgAmodes [] = return []
+getNonVoidArgAmodes (arg:args)
+  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
+                   ; amodes <- getNonVoidArgAmodes args
+                   ; return ( amode : amodes ) }
+
+
+------------------------------------------------------------------------
+--        Interface functions for binding and re-binding names
+------------------------------------------------------------------------
+
+bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
+-- Bind an Id to a fresh LocalReg
+bindToReg nvid@(NonVoid id) lf_info
+  = do dflags <- getDynFlags
+       let reg = idToReg dflags nvid
+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
+       return reg
+
+rebindToReg :: NonVoid Id -> FCode LocalReg
+-- Like bindToReg, but the Id is already in scope, so
+-- get its LF info from the envt
+rebindToReg nvid@(NonVoid id)
+  = do  { info <- getCgIdInfo id
+        ; bindToReg nvid (cg_lf info) }
+
+bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
+
+bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
+bindArgsToRegs args = mapM bindArgToReg args
+
+idToReg :: DynFlags -> NonVoid Id -> LocalReg
+-- Make a register from an Id, typically a function argument,
+-- free variable, or case binder
+--
+-- We re-use the Unique from the Id to make it easier to see what is going on
+--
+-- By now the Ids should be uniquely named; else one would worry
+-- about accidental collision
+idToReg dflags (NonVoid id)
+             = LocalReg (idUnique id)
+                        (primRepCmmType dflags (idPrimRep id))
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -0,0 +1,992 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: expressions
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmExpr ( cgExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding ((<*>))
+
+import {-# SOURCE #-} StgCmmBind ( cgBind )
+
+import StgCmmMonad
+import StgCmmHeap
+import StgCmmEnv
+import StgCmmCon
+import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)
+import StgCmmLayout
+import StgCmmPrim
+import StgCmmHpc
+import StgCmmTicky
+import StgCmmUtils
+import StgCmmClosure
+
+import StgSyn
+
+import MkGraph
+import BlockId
+import Cmm
+import CmmInfo
+import CoreSyn
+import DataCon
+import ForeignCall
+import Id
+import PrimOp
+import TyCon
+import Type             ( isUnliftedType )
+import RepType          ( isVoidTy, countConRepArgs, primRepSlot )
+import CostCentre       ( CostCentreStack, currentCCS )
+import Maybes
+import Util
+import FastString
+import Outputable
+
+import Control.Monad (unless,void)
+import Control.Arrow (first)
+import Data.Function ( on )
+
+------------------------------------------------------------------------
+--              cgExpr: the main function
+------------------------------------------------------------------------
+
+cgExpr  :: CgStgExpr -> FCode ReturnKind
+
+cgExpr (StgApp fun args)     = cgIdApp fun args
+
+-- seq# a s ==> a
+-- See Note [seq# magic] in PrelRules
+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
+  cgIdApp a []
+
+-- dataToTag# :: a -> Int#
+-- See Note [dataToTag#] in primops.txt.pp
+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
+  dflags <- getDynFlags
+  emitComment (mkFastString "dataToTag#")
+  tmp <- newTemp (bWord dflags)
+  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
+  -- TODO: For small types look at the tag bits instead of reading info table
+  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]
+
+cgExpr (StgOpApp op args ty) = cgOpApp op args ty
+cgExpr (StgConApp con args _)= cgConApp con args
+cgExpr (StgTick t e)         = cgTick t >> cgExpr e
+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
+                               emitReturn [CmmLit cmm_lit]
+
+cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }
+cgExpr (StgLetNoEscape _ binds expr) =
+  do { u <- newUnique
+     ; let join_id = mkBlockId u
+     ; cgLneBinds join_id binds
+     ; r <- cgExpr expr
+     ; emitLabel join_id
+     ; return r }
+
+cgExpr (StgCase expr bndr alt_type alts) =
+  cgCase expr bndr alt_type alts
+
+cgExpr (StgLam {}) = panic "cgExpr: StgLam"
+
+------------------------------------------------------------------------
+--              Let no escape
+------------------------------------------------------------------------
+
+{- Generating code for a let-no-escape binding, aka join point is very
+very similar to what we do for a case expression.  The duality is
+between
+        let-no-escape x = b
+        in e
+and
+        case e of ... -> b
+
+That is, the RHS of 'x' (ie 'b') will execute *later*, just like
+the alternative of the case; it needs to be compiled in an environment
+in which all volatile bindings are forgotten, and the free vars are
+bound only to stable things like stack locations..  The 'e' part will
+execute *next*, just like the scrutinee of a case. -}
+
+-------------------------
+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
+cgLneBinds join_id (StgNonRec bndr rhs)
+  = do  { local_cc <- saveCurrentCostCentre
+                -- See Note [Saving the current cost centre]
+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
+        ; fcode
+        ; addBindC info }
+
+cgLneBinds join_id (StgRec pairs)
+  = do  { local_cc <- saveCurrentCostCentre
+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs
+        ; let (infos, fcodes) = unzip r
+        ; addBindsC infos
+        ; sequence_ fcodes
+        }
+
+-------------------------
+cgLetNoEscapeRhs
+    :: BlockId          -- join point for successor of let-no-escape
+    -> Maybe LocalReg   -- Saved cost centre
+    -> Id
+    -> CgStgRhs
+    -> FCode (CgIdInfo, FCode ())
+
+cgLetNoEscapeRhs join_id local_cc bndr rhs =
+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs
+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
+     ; let code = do { (_, body) <- getCodeScoped rhs_code
+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }
+     ; return (info, code)
+     }
+
+cgLetNoEscapeRhsBody
+    :: Maybe LocalReg   -- Saved cost centre
+    -> Id
+    -> CgStgRhs
+    -> FCode (CgIdInfo, FCode ())
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
+  = cgLetNoEscapeClosure bndr local_cc cc []
+      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $
+                           text "StgRhsCon doesn't have type args"))
+        -- For a constructor RHS we want to generate a single chunk of
+        -- code which can be jumped to from many places, which will
+        -- return the constructor. It's easy; just behave as if it
+        -- was an StgRhsClosure with a ConApp inside!
+
+-------------------------
+cgLetNoEscapeClosure
+        :: Id                   -- binder
+        -> Maybe LocalReg       -- Slot for saved current cost centre
+        -> CostCentreStack      -- XXX: *** NOT USED *** why not?
+        -> [NonVoid Id]         -- Args (as in \ args -> body)
+        -> CgStgExpr            -- Body (as in above)
+        -> FCode (CgIdInfo, FCode ())
+
+cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
+  = do dflags <- getDynFlags
+       return ( lneIdInfo dflags bndr args
+              , code )
+  where
+   code = forkLneBody $ do {
+            ; withNewTickyCounterLNE (idName bndr) args $ do
+            ; restoreCurrentCostCentre cc_slot
+            ; arg_regs <- bindArgsToRegs args
+            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }
+
+
+------------------------------------------------------------------------
+--              Case expressions
+------------------------------------------------------------------------
+
+{- Note [Compiling case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is quite interesting to decide whether to put a heap-check at the
+start of each alternative.  Of course we certainly have to do so if
+the case forces an evaluation, or if there is a primitive op which can
+trigger GC.
+
+A more interesting situation is this (a Plan-B situation)
+
+        !P!;
+        ...P...
+        case x# of
+          0#      -> !Q!; ...Q...
+          default -> !R!; ...R...
+
+where !x! indicates a possible heap-check point. The heap checks
+in the alternatives *can* be omitted, in which case the topmost
+heapcheck will take their worst case into account.
+
+In favour of omitting !Q!, !R!:
+
+ - *May* save a heap overflow test,
+   if ...P... allocates anything.
+
+ - We can use relative addressing from a single Hp to
+   get at all the closures so allocated.
+
+ - No need to save volatile vars etc across heap checks
+   in !Q!, !R!
+
+Against omitting !Q!, !R!
+
+  - May put a heap-check into the inner loop.  Suppose
+        the main loop is P -> R -> P -> R...
+        Q is the loop exit, and only it does allocation.
+    This only hurts us if P does no allocation.  If P allocates,
+    then there is a heap check in the inner loop anyway.
+
+  - May do more allocation than reqd.  This sometimes bites us
+    badly.  For example, nfib (ha!) allocates about 30\% more space if the
+    worst-casing is done, because many many calls to nfib are leaf calls
+    which don't need to allocate anything.
+
+    We can un-allocate, but that costs an instruction
+
+Neither problem hurts us if there is only one alternative.
+
+Suppose the inner loop is P->R->P->R etc.  Then here is
+how many heap checks we get in the *inner loop* under various
+conditions
+
+  Alloc   Heap check in branches (!Q!, !R!)?
+  P Q R      yes     no (absorb to !P!)
+--------------------------------------
+  n n n      0          0
+  n y n      0          1
+  n . y      1          1
+  y . y      2          1
+  y . n      1          1
+
+Best choices: absorb heap checks from Q and R into !P! iff
+  a) P itself does some allocation
+or
+  b) P does allocation, or there is exactly one alternative
+
+We adopt (b) because that is more likely to put the heap check at the
+entry to a function, when not many things are live.  After a bunch of
+single-branch cases, we may have lots of things live
+
+Hence: two basic plans for
+
+        case e of r { alts }
+
+------ Plan A: the general case ---------
+
+        ...save current cost centre...
+
+        ...code for e,
+           with sequel (SetLocals r)
+
+        ...restore current cost centre...
+        ...code for alts...
+        ...alts do their own heap checks
+
+------ Plan B: special case when ---------
+  (i)  e does not allocate or call GC
+  (ii) either upstream code performs allocation
+       or there is just one alternative
+
+  Then heap allocation in the (single) case branch
+  is absorbed by the upstream check.
+  Very common example: primops on unboxed values
+
+        ...code for e,
+           with sequel (SetLocals r)...
+
+        ...code for alts...
+        ...no heap check...
+-}
+
+
+
+-------------------------------------
+data GcPlan
+  = GcInAlts            -- Put a GC check at the start the case alternatives,
+        [LocalReg]      -- which binds these registers
+  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a
+                        -- primitive op which does no GC.  Absorb the allocation
+                        -- of the case alternative(s) into the upstream check
+
+-------------------------------------
+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
+
+cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
+  | isEnumerationTyCon tycon -- Note [case on bool]
+  = do { tag_expr <- do_enum_primop op args
+
+       -- If the binder is not dead, convert the tag to a constructor
+       -- and assign it. See Note [Dead-binder optimisation]
+       ; unless (isDeadBinder bndr) $ do
+            { dflags <- getDynFlags
+            ; tmp_reg <- bindArgToReg (NonVoid bndr)
+            ; emitAssign (CmmLocal tmp_reg)
+                         (tagToClosure dflags tycon tag_expr) }
+
+       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)
+                                              (NonVoid bndr) alts
+                                 -- See Note [GC for conditionals]
+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)
+       ; return AssignedDirectly
+       }
+  where
+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr
+    do_enum_primop TagToEnumOp [arg]  -- No code!
+      = getArgAmode (NonVoid arg)
+    do_enum_primop primop args
+      = do dflags <- getDynFlags
+           tmp <- newTemp (bWord dflags)
+           cgPrimOp [tmp] primop args
+           return (CmmReg (CmmLocal tmp))
+
+{-
+Note [case on bool]
+~~~~~~~~~~~~~~~~~~~
+This special case handles code like
+
+  case a <# b of
+    True ->
+    False ->
+
+-->  case tagToEnum# (a <$# b) of
+        True -> .. ; False -> ...
+
+--> case (a <$# b) of r ->
+    case tagToEnum# r of
+        True -> .. ; False -> ...
+
+If we let the ordinary case code handle it, we'll get something like
+
+ tmp1 = a < b
+ tmp2 = Bool_closure_tbl[tmp1]
+ if (tmp2 & 7 != 0) then ... // normal tagged case
+
+but this junk won't optimise away.  What we really want is just an
+inline comparison:
+
+ if (a < b) then ...
+
+So we add a special case to generate
+
+ tmp1 = a < b
+ if (tmp1 == 0) then ...
+
+and later optimisations will further improve this.
+
+Now that #6135 has been resolved it should be possible to remove that
+special case. The idea behind this special case and pre-6135 implementation
+of Bool-returning primops was that tagToEnum# was added implicitly in the
+codegen and then optimized away. Now the call to tagToEnum# is explicit
+in the source code, which allows to optimize it away at the earlier stages
+of compilation (i.e. at the Core level).
+
+Note [Scrutinising VoidRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this STG code:
+   f = \[s : State# RealWorld] ->
+       case s of _ -> blah
+This is very odd.  Why are we scrutinising a state token?  But it
+can arise with bizarre NOINLINE pragmas (#9964)
+    crash :: IO ()
+    crash = IO (\s -> let {-# NOINLINE s' #-}
+                          s' = s
+                      in (# s', () #))
+
+Now the trouble is that 's' has VoidRep, and we do not bind void
+arguments in the environment; they don't live anywhere.  See the
+calls to nonVoidIds in various places.  So we must not look up
+'s' in the environment.  Instead, just evaluate the RHS!  Simple.
+
+Note [Dead-binder optimisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A case-binder, or data-constructor argument, may be marked as dead,
+because we preserve occurrence-info on binders in CoreTidy (see
+CoreTidy.tidyIdBndr).
+
+If the binder is dead, we can sometimes eliminate a load.  While
+CmmSink will eliminate that load, it's very easy to kill it at source
+(giving CmmSink less work to do), and in any case CmmSink only runs
+with -O. Since the majority of case binders are dead, this
+optimisation probably still has a great benefit-cost ratio and we want
+to keep it for -O0. See also Phab:D5358.
+
+This probably also was the reason for occurrence hack in Phab:D5339 to
+exist, perhaps because the occurrence information preserved by
+'CoreTidy.tidyIdBndr' was insufficient.  But now that CmmSink does the
+job we deleted the hacks.
+-}
+
+cgCase (StgApp v []) _ (PrimAlt _) alts
+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]
+  , [(DEFAULT, _, rhs)] <- alts
+  = cgExpr rhs
+
+{- Note [Dodgy unsafeCoerce 1]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    case (x :: HValue) |> co of (y :: MutVar# Int)
+        DEFAULT -> ...
+We want to gnerate an assignment
+     y := x
+We want to allow this assignment to be generated in the case when the
+types are compatible, because this allows some slightly-dodgy but
+occasionally-useful casts to be used, such as in RtClosureInspect
+where we cast an HValue to a MutVar# so we can print out the contents
+of the MutVar#.  If instead we generate code that enters the HValue,
+then we'll get a runtime panic, because the HValue really is a
+MutVar#.  The types are compatible though, so we can just generate an
+assignment.
+-}
+cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
+  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]
+  || reps_compatible
+  = -- assignment suffices for unlifted types
+    do { dflags <- getDynFlags
+       ; unless reps_compatible $
+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+                    (pp_bndr v $$ pp_bndr bndr)
+       ; v_info <- getCgIdInfo v
+       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
+                    (idInfoToAmode v_info)
+       -- Add bndr to the environment
+       ; _ <- bindArgToReg (NonVoid bndr)
+       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
+  where
+    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
+      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,
+      -- the types of the binders are generated from slotPrimRep and might not
+      -- match. Test case:
+      --   swap :: (# Int | Int #) -> (# Int | Int #)
+      --   swap (# x | #) = (# | x #)
+      --   swap (# | y #) = (# y | #)
+
+    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))
+
+{- Note [Dodgy unsafeCoerce 2, #3132]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In all other cases of a lifted Id being cast to an unlifted type, the
+Id should be bound to bottom, otherwise this is an unsafe use of
+unsafeCoerce.  We can generate code to enter the Id and assume that
+it will never return.  Hence, we emit the usual enter/return code, and
+because bottom must be untagged, it will be entered.  The Sequel is a
+type-correct assignment, albeit bogus.  The (dead) continuation loops;
+it would be better to invoke some kind of panic function here.
+-}
+cgCase scrut@(StgApp v []) _ (PrimAlt _) _
+  = do { dflags <- getDynFlags
+       ; mb_cc <- maybeSaveCostCentre True
+       ; _ <- withSequel
+                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
+       ; restoreCurrentCostCentre mb_cc
+       ; emitComment $ mkFastString "should be unreachable code"
+       ; l <- newBlockId
+       ; emitLabel l
+       ; emit (mkBranch l)  -- an infinite loop
+       ; return AssignedDirectly
+       }
+
+{- Note [Handle seq#]
+~~~~~~~~~~~~~~~~~~~~~
+See Note [seq# magic] in PrelRules.
+The special case for seq# in cgCase does this:
+
+  case seq# a s of v
+    (# s', a' #) -> e
+==>
+  case a of v
+    (# s', a' #) -> e
+
+(taking advantage of the fact that the return convention for (# State#, a #)
+is the same as the return convention for just 'a')
+-}
+
+cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
+  = -- Note [Handle seq#]
+    -- And see Note [seq# magic] in PrelRules
+    -- Use the same return convention as vanilla 'a'.
+    cgCase (StgApp a []) bndr alt_type alts
+
+cgCase scrut bndr alt_type alts
+  = -- the general case
+    do { dflags <- getDynFlags
+       ; up_hp_usg <- getVirtHp        -- Upstream heap usage
+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
+             alt_regs  = map (idToReg dflags) ret_bndrs
+       ; simple_scrut <- isSimpleScrut scrut alt_type
+       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]
+                    | not simple_scrut = True
+                    | isSingleton alts = False
+                    | up_hp_usg > 0    = False
+                    | otherwise        = True
+               -- cf Note [Compiling case expressions]
+             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts
+
+       ; mb_cc <- maybeSaveCostCentre simple_scrut
+
+       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}
+       ; ret_kind <- withSequel sequel (cgExpr scrut)
+       ; restoreCurrentCostCentre mb_cc
+       ; _ <- bindArgsToRegs ret_bndrs
+       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts
+       }
+  where
+    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op
+    is_cmp_op _                             = False
+
+{- Note [GC for conditionals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For boolean conditionals it seems that we have always done NoGcInAlts.
+That is, we have always done the GC check before the conditional.
+This is enshrined in the special case for
+   case tagToEnum# (a>b) of ...
+See Note [case on bool]
+
+It's odd, and it's flagrantly inconsistent with the rules described
+Note [Compiling case expressions].  However, after eliminating the
+tagToEnum# (#13397) we will have:
+   case (a>b) of ...
+Rather than make it behave quite differently, I am testing for a
+comparison operator here in in the general case as well.
+
+ToDo: figure out what the Right Rule should be.
+
+Note [scrut sequel]
+~~~~~~~~~~~~~~~~~~~
+The job of the scrutinee is to assign its value(s) to alt_regs.
+Additionally, if we plan to do a heap-check in the alternatives (see
+Note [Compiling case expressions]), then we *must* retreat Hp to
+recover any unused heap before passing control to the sequel.  If we
+don't do this, then any unused heap will become slop because the heap
+check will reset the heap usage. Slop in the heap breaks LDV profiling
+(+RTS -hb) which needs to do a linear sweep through the nursery.
+
+
+Note [Inlining out-of-line primops and heap checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If shouldInlinePrimOp returns True when called from StgCmmExpr for the
+purpose of heap check placement, we *must* inline the primop later in
+StgCmmPrim. If we don't things will go wrong.
+-}
+
+-----------------
+maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
+maybeSaveCostCentre simple_scrut
+  | simple_scrut = return Nothing
+  | otherwise    = saveCurrentCostCentre
+
+
+-----------------
+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate
+-- heap usage from alternatives into the stuff before the case
+-- NB: if you get this wrong, and claim that the expression doesn't allocate
+--     when it does, you'll deeply mess up allocation
+isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args
+isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }
+isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }
+isSimpleScrut _                _           = return False
+
+isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
+-- True iff the op cannot block or allocate
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
+isSimpleOp (StgPrimOp DataToTagOp) _ = return False
+isSimpleOp (StgPrimOp op) stg_args                  = do
+    arg_exprs <- getNonVoidArgAmodes stg_args
+    dflags <- getDynFlags
+    -- See Note [Inlining out-of-line primops and heap checks]
+    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs
+isSimpleOp (StgPrimCallOp _) _                           = return False
+
+-----------------
+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
+-- These are the binders of a case that are assigned by the evaluation of the
+-- scrutinee.
+-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.
+chooseReturnBndrs bndr (PrimAlt _) _alts
+  = assertNonVoidIds [bndr]
+
+chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]
+  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)
+    assertNonVoidIds ids     -- 'bndr' is not assigned!
+
+chooseReturnBndrs bndr (AlgAlt _) _alts
+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned
+
+chooseReturnBndrs bndr PolyAlt _alts
+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned
+
+chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
+                             -- MultiValAlt has only one alternative
+
+-------------------------------------
+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
+       -> FCode ReturnKind
+-- At this point the result of the case are in the binders
+cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]
+  = maybeAltHeapCheck gc_plan (cgExpr rhs)
+
+cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]
+  = maybeAltHeapCheck gc_plan (cgExpr rhs)
+        -- Here bndrs are *already* in scope, so don't rebind them
+
+cgAlts gc_plan bndr (PrimAlt _) alts
+  = do  { dflags <- getDynFlags
+
+        ; tagged_cmms <- cgAltRhss gc_plan bndr alts
+
+        ; let bndr_reg = CmmLocal (idToReg dflags bndr)
+              (DEFAULT,deflt) = head tagged_cmms
+                -- PrimAlts always have a DEFAULT case
+                -- and it always comes first
+
+              tagged_cmms' = [(lit,code)
+                             | (LitAlt lit, code) <- tagged_cmms]
+        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
+        ; return AssignedDirectly }
+
+cgAlts gc_plan bndr (AlgAlt tycon) alts
+  = do  { dflags <- getDynFlags
+
+        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts
+
+        ; let fam_sz   = tyConFamilySize tycon
+              bndr_reg = CmmLocal (idToReg dflags bndr)
+
+                    -- Is the constructor tag in the node reg?
+        ; if isSmallFamily dflags fam_sz
+          then do
+                let   -- Yes, bndr_reg has constr. tag in ls bits
+                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
+                   branches' = [(tag+1,branch) | (tag,branch) <- branches]
+                emitSwitch tag_expr branches' mb_deflt 1 fam_sz
+
+           else -- No, get tag from info table
+                let -- Note that ptr _always_ has tag 1
+                    -- when the family size is big enough
+                    untagged_ptr = cmmRegOffB bndr_reg (-1)
+                    tag_expr = getConstrTag dflags (untagged_ptr)
+                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
+
+        ; return AssignedDirectly }
+
+cgAlts _ _ _ _ = panic "cgAlts"
+        -- UbxTupAlt and PolyAlt have only one alternative
+
+
+-- Note [alg-alt heap check]
+--
+-- In an algebraic case with more than one alternative, we will have
+-- code like
+--
+-- L0:
+--   x = R1
+--   goto L1
+-- L1:
+--   if (x & 7 >= 2) then goto L2 else goto L3
+-- L2:
+--   Hp = Hp + 16
+--   if (Hp > HpLim) then goto L4
+--   ...
+-- L4:
+--   call gc() returns to L5
+-- L5:
+--   x = R1
+--   goto L1
+
+-------------------
+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+             -> FCode ( Maybe CmmAGraphScoped
+                      , [(ConTagZ, CmmAGraphScoped)] )
+cgAlgAltRhss gc_plan bndr alts
+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
+
+       ; let { mb_deflt = case tagged_cmms of
+                           ((DEFAULT,rhs) : _) -> Just rhs
+                           _other              -> Nothing
+                            -- DEFAULT is always first, if present
+
+              ; branches = [ (dataConTagZ con, cmm)
+                           | (DataAlt con, cmm) <- tagged_cmms ]
+              }
+
+       ; return (mb_deflt, branches)
+       }
+
+
+-------------------
+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+          -> FCode [(AltCon, CmmAGraphScoped)]
+cgAltRhss gc_plan bndr alts = do
+  dflags <- getDynFlags
+  let
+    base_reg = idToReg dflags bndr
+    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
+    cg_alt (con, bndrs, rhs)
+      = getCodeScoped             $
+        maybeAltHeapCheck gc_plan $
+        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)
+                    -- alt binders are always non-void,
+                    -- see Note [Post-unarisation invariants] in UnariseStg
+           ; _ <- cgExpr rhs
+           ; return con }
+  forkAlts (map cg_alt alts)
+
+maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
+maybeAltHeapCheck (NoGcInAlts,_)  code = code
+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =
+  altHeapCheck regs code
+maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
+  altHeapCheckReturnsTo regs lret off code
+
+-----------------------------------------------------------------------------
+--      Tail calls
+-----------------------------------------------------------------------------
+
+cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind
+cgConApp con stg_args
+  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return
+  = do { arg_exprs <- getNonVoidArgAmodes stg_args
+       ; tickyUnboxedTupleReturn (length arg_exprs)
+       ; emitReturn arg_exprs }
+
+  | otherwise   --  Boxed constructors; allocate and return
+  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False
+                                     currentCCS con (assertNonVoidStgArgs stg_args)
+                                     -- con args are always non-void,
+                                     -- see Note [Post-unarisation invariants] in UnariseStg
+                -- The first "con" says that the name bound to this
+                -- closure is "con", which is a bit of a fudge, but
+                -- it only affects profiling (hence the False)
+
+        ; emit =<< fcode_init
+        ; tickyReturnNewCon (length stg_args)
+        ; emitReturn [idInfoToAmode idinfo] }
+
+cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
+cgIdApp fun_id args = do
+    dflags         <- getDynFlags
+    fun_info       <- getCgIdInfo fun_id
+    self_loop_info <- getSelfLoop
+    let fun_arg     = StgVarArg fun_id
+        fun_name    = idName    fun_id
+        fun         = idInfoToAmode fun_info
+        lf_info     = cg_lf         fun_info
+        n_args      = length args
+        v_args      = length $ filter (isVoidTy . stgArgType) args
+        node_points dflags = nodeMustPointToIt dflags lf_info
+    case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of
+            -- A value in WHNF, so we can just return it.
+        ReturnIt
+          | isVoidTy (idType fun_id) -> emitReturn []
+          | otherwise                -> emitReturn [fun]
+          -- ToDo: does ReturnIt guarantee tagged?
+
+        EnterIt -> ASSERT( null args )  -- Discarding arguments
+                   emitEnter fun
+
+        SlowCall -> do      -- A slow function call via the RTS apply routines
+                { tickySlowCall lf_info args
+                ; emitComment $ mkFastString "slowCall"
+                ; slowCall fun args }
+
+        -- A direct function call (possibly with some left-over arguments)
+        DirectEntry lbl arity -> do
+                { tickyDirectCall arity args
+                ; if node_points dflags
+                     then directCall NativeNodeCall   lbl arity (fun_arg:args)
+                     else directCall NativeDirectCall lbl arity args }
+
+        -- Let-no-escape call or self-recursive tail-call
+        JumpToIt blk_id lne_regs -> do
+          { adjustHpBackwards -- always do this before a tail-call
+          ; cmm_args <- getNonVoidArgAmodes args
+          ; emitMultiAssign lne_regs cmm_args
+          ; emit (mkBranch blk_id)
+          ; return AssignedDirectly }
+
+-- Note [Self-recursive tail calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Self-recursive tail calls can be optimized into a local jump in the same
+-- way as let-no-escape bindings (see Note [What is a non-escaping let] in
+-- stgSyn/CoreToStg.hs). Consider this:
+--
+-- foo.info:
+--     a = R1  // calling convention
+--     b = R2
+--     goto L1
+-- L1: ...
+--     ...
+-- ...
+-- L2: R1 = x
+--     R2 = y
+--     call foo(R1,R2)
+--
+-- Instead of putting x and y into registers (or other locations required by the
+-- calling convention) and performing a call we can put them into local
+-- variables a and b and perform jump to L1:
+--
+-- foo.info:
+--     a = R1
+--     b = R2
+--     goto L1
+-- L1: ...
+--     ...
+-- ...
+-- L2: a = x
+--     b = y
+--     goto L1
+--
+-- This can be done only when function is calling itself in a tail position
+-- and only if the call passes number of parameters equal to function's arity.
+-- Note that this cannot be performed if a function calls itself with a
+-- continuation.
+--
+-- This in fact implements optimization known as "loopification". It was
+-- described in "Low-level code optimizations in the Glasgow Haskell Compiler"
+-- by Krzysztof Woś, though we use different approach. Krzysztof performed his
+-- optimization at the Cmm level, whereas we perform ours during code generation
+-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is
+-- generated in the first place.
+--
+-- Implementation is spread across a couple of places in the code:
+--
+--   * FCode monad stores additional information in its reader environment
+--     (cgd_self_loop field). This information tells us which function can
+--     tail call itself in an optimized way (it is the function currently
+--     being compiled), what is the label of a loop header (L1 in example above)
+--     and information about local registers in which we should arguments
+--     before making a call (this would be a and b in example above).
+--
+--   * Whenever we are compiling a function, we set that information to reflect
+--     the fact that function currently being compiled can be jumped to, instead
+--     of called. This is done in closureCodyBody in StgCmmBind.
+--
+--   * We also have to emit a label to which we will be jumping. We make sure
+--     that the label is placed after a stack check but before the heap
+--     check. The reason is that making a recursive tail-call does not increase
+--     the stack so we only need to check once. But it may grow the heap, so we
+--     have to repeat the heap check in every self-call. This is done in
+--     do_checks in StgCmmHeap.
+--
+--   * When we begin compilation of another closure we remove the additional
+--     information from the environment. This is done by forkClosureBody
+--     in StgCmmMonad. Other functions that duplicate the environment -
+--     forkLneBody, forkAlts, codeOnly - duplicate that information. In other
+--     words, we only need to clean the environment of the self-loop information
+--     when compiling right hand side of a closure (binding).
+--
+--   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind
+--     of call will be generated. getCallMethod decides to generate a self
+--     recursive tail call when (a) environment stores information about
+--     possible self tail-call; (b) that tail call is to a function currently
+--     being compiled; (c) number of passed non-void arguments is equal to
+--     function's arity. (d) loopification is turned on via -floopification
+--     command-line option.
+--
+--   * Command line option to turn loopification on and off is implemented in
+--     DynFlags.
+--
+--
+-- Note [Void arguments in self-recursive tail calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- State# tokens can get in the way of the loopification optimization as seen in
+-- #11372. Consider this:
+--
+-- foo :: [a]
+--     -> (a -> State# s -> (# State s, Bool #))
+--     -> State# s
+--     -> (# State# s, Maybe a #)
+-- foo [] f s = (# s, Nothing #)
+-- foo (x:xs) f s = case f x s of
+--      (# s', b #) -> case b of
+--          True -> (# s', Just x #)
+--          False -> foo xs f s'
+--
+-- We would like to compile the call to foo as a local jump instead of a call
+-- (see Note [Self-recursive tail calls]). However, the generated function has
+-- an arity of 2 while we apply it to 3 arguments, one of them being of void
+-- type. Thus, we mustn't count arguments of void type when checking whether
+-- we can turn a call into a self-recursive jump.
+--
+
+emitEnter :: CmmExpr -> FCode ReturnKind
+emitEnter fun = do
+  { dflags <- getDynFlags
+  ; adjustHpBackwards
+  ; sequel <- getSequel
+  ; updfr_off <- getUpdFrameOff
+  ; case sequel of
+      -- For a return, we have the option of generating a tag-test or
+      -- not.  If the value is tagged, we can return directly, which
+      -- is quicker than entering the value.  This is a code
+      -- size/speed trade-off: when optimising for speed rather than
+      -- size we could generate the tag test.
+      --
+      -- Right now, we do what the old codegen did, and omit the tag
+      -- test, just generating an enter.
+      Return -> do
+        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg
+        ; emit $ mkJump dflags NativeNodeCall entry
+                        [cmmUntag dflags fun] updfr_off
+        ; return AssignedDirectly
+        }
+
+      -- The result will be scrutinised in the sequel.  This is where
+      -- we generate a tag-test to avoid entering the closure if
+      -- possible.
+      --
+      -- The generated code will be something like this:
+      --
+      --    R1 = fun  -- copyout
+      --    if (fun & 7 != 0) goto Lret else goto Lcall
+      --  Lcall:
+      --    call [fun] returns to Lret
+      --  Lret:
+      --    fun' = R1  -- copyin
+      --    ...
+      --
+      -- Note in particular that the label Lret is used as a
+      -- destination by both the tag-test and the call.  This is
+      -- because Lret will necessarily be a proc-point, and we want to
+      -- ensure that we generate only one proc-point for this
+      -- sequence.
+      --
+      -- Furthermore, we tell the caller that we generated a native
+      -- return continuation by returning (ReturnedTo Lret off), so
+      -- that the continuation can be reused by the heap-check failure
+      -- code in the enclosing case expression.
+      --
+      AssignTo res_regs _ -> do
+       { lret <- newBlockId
+       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
+       ; lcall <- newBlockId
+       ; updfr_off <- getUpdFrameOff
+       ; let area = Young lret
+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
+                                          [fun] updfr_off []
+         -- refer to fun via nodeReg after the copyout, to avoid having
+         -- both live simultaneously; this sometimes enables fun to be
+         -- inlined in the RHS of the R1 assignment.
+       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))
+             the_call = toCall entry (Just lret) updfr_off off outArgs regs
+       ; tscope <- getTickScope
+       ; emit $
+           copyout <*>
+           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))
+                     lret lcall Nothing <*>
+           outOfLine lcall (the_call,tscope) <*>
+           mkLabel lret tscope <*>
+           copyin
+       ; return (ReturnedTo lret off)
+       }
+  }
+
+------------------------------------------------------------------------
+--              Ticks
+------------------------------------------------------------------------
+
+-- | Generate Cmm code for a tick. Depending on the type of Tickish,
+-- this will either generate actual Cmm instrumentation code, or
+-- simply pass on the annotation as a @CmmTickish@.
+cgTick :: Tickish Id -> FCode ()
+cgTick tick
+  = do { dflags <- getDynFlags
+       ; case tick of
+           ProfNote   cc t p -> emitSetCCC cc t p
+           HpcTick    m n    -> emit (mkTickBox dflags m n)
+           SourceNote s n    -> emitTick $ SourceNote s n
+           _other            -> return () -- ignore
+       }
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -0,0 +1,253 @@
+-- | Our extended FCode monad.
+
+-- We add a mapping from names to CmmExpr, to support local variable names in
+-- the concrete C-- code.  The unique supply of the underlying FCode monad
+-- is used to grab a new unique for each local variable.
+
+-- In C--, a local variable can be declared anywhere within a proc,
+-- and it scopes from the beginning of the proc to the end.  Hence, we have
+-- to collect declarations as we parse the proc, and feed the environment
+-- back in circularly (to avoid a two-pass algorithm).
+
+module StgCmmExtCode (
+        CmmParse, unEC,
+        Named(..), Env,
+
+        loopDecls,
+        getEnv,
+
+        withName,
+        getName,
+
+        newLocal,
+        newLabel,
+        newBlockId,
+        newFunctionName,
+        newImport,
+        lookupLabel,
+        lookupName,
+
+        code,
+        emit, emitLabel, emitAssign, emitStore,
+        getCode, getCodeR, getCodeScoped,
+        emitOutOfLine,
+        withUpdFrameOff, getUpdFrameOff
+)
+
+where
+
+import GhcPrelude
+
+import qualified StgCmmMonad as F
+import StgCmmMonad (FCode, newUnique)
+
+import Cmm
+import CLabel
+import MkGraph
+
+import BlockId
+import DynFlags
+import FastString
+import Module
+import UniqFM
+import Unique
+import UniqSupply
+
+import Control.Monad (liftM, ap)
+
+-- | The environment contains variable definitions or blockids.
+data Named
+        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
+                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.
+
+        | FunN   UnitId      -- ^ A function name from this package
+        | LabelN BlockId                -- ^ A blockid of some code or data.
+
+-- | An environment of named things.
+type Env        = UniqFM Named
+
+-- | Local declarations that are in scope during code generation.
+type Decls      = [(FastString,Named)]
+
+-- | Does a computation in the FCode monad, with a current environment
+--      and a list of local declarations. Returns the resulting list of declarations.
+newtype CmmParse a
+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
+
+type ExtCode = CmmParse ()
+
+returnExtFC :: a -> CmmParse a
+returnExtFC a   = EC $ \_ _ s -> return (s, a)
+
+thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
+
+instance Functor CmmParse where
+      fmap = liftM
+
+instance Applicative CmmParse where
+      pure = returnExtFC
+      (<*>) = ap
+
+instance Monad CmmParse where
+  (>>=) = thenExtFC
+
+instance MonadUnique CmmParse where
+  getUniqueSupplyM = code getUniqueSupplyM
+  getUniqueM = EC $ \_ _ decls -> do
+    u <- getUniqueM
+    return (decls, u)
+
+instance HasDynFlags CmmParse where
+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
+                                   return (d, dflags))
+
+
+-- | Takes the variable decarations and imports from the monad
+--      and makes an environment, which is looped back into the computation.
+--      In this way, we can have embedded declarations that scope over the whole
+--      procedure, and imports that scope over the entire module.
+--      Discards the local declaration contained within decl'
+--
+loopDecls :: CmmParse a -> CmmParse a
+loopDecls (EC fcode) =
+      EC $ \c e globalDecls -> do
+        (_, a) <- F.fixC $ \ ~(decls, _) ->
+          fcode c (addListToUFM e decls) globalDecls
+        return (globalDecls, a)
+
+
+-- | Get the current environment from the monad.
+getEnv :: CmmParse Env
+getEnv  = EC $ \_ e s -> return (s, e)
+
+-- | Get the current context name from the monad
+getName :: CmmParse String
+getName  = EC $ \c _ s -> return (s, c)
+
+-- | Set context name for a sub-parse
+withName :: String -> CmmParse a -> CmmParse a
+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
+
+addDecl :: FastString -> Named -> ExtCode
+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
+
+
+-- | Add a new variable to the list of local declarations.
+--      The CmmExpr says where the value is stored.
+addVarDecl :: FastString -> CmmExpr -> ExtCode
+addVarDecl var expr = addDecl var (VarN expr)
+
+-- | Add a new label to the list of local declarations.
+addLabel :: FastString -> BlockId -> ExtCode
+addLabel name block_id = addDecl name (LabelN block_id)
+
+
+-- | Create a fresh local variable of a given type.
+newLocal
+        :: CmmType              -- ^ data type
+        -> FastString           -- ^ name of variable
+        -> CmmParse LocalReg    -- ^ register holding the value
+
+newLocal ty name = do
+   u <- code newUnique
+   let reg = LocalReg u ty
+   addVarDecl name (CmmReg (CmmLocal reg))
+   return reg
+
+
+-- | Allocate a fresh label.
+newLabel :: FastString -> CmmParse BlockId
+newLabel name = do
+   u <- code newUnique
+   addLabel name (mkBlockId u)
+   return (mkBlockId u)
+
+-- | Add add a local function to the environment.
+newFunctionName
+        :: FastString   -- ^ name of the function
+        -> UnitId    -- ^ package of the current module
+        -> ExtCode
+
+newFunctionName name pkg = addDecl name (FunN pkg)
+
+
+-- | Add an imported foreign label to the list of local declarations.
+--      If this is done at the start of the module the declaration will scope
+--      over the whole module.
+newImport
+        :: (FastString, CLabel)
+        -> CmmParse ()
+
+newImport (name, cmmLabel)
+   = addVarDecl name (CmmLit (CmmLabel cmmLabel))
+
+
+-- | Lookup the BlockId bound to the label with this name.
+--      If one hasn't been bound yet, create a fresh one based on the
+--      Unique of the name.
+lookupLabel :: FastString -> CmmParse BlockId
+lookupLabel name = do
+  env <- getEnv
+  return $
+     case lookupUFM env name of
+        Just (LabelN l) -> l
+        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')
+
+
+-- | Lookup the location of a named variable.
+--      Unknown names are treated as if they had been 'import'ed from the runtime system.
+--      This saves us a lot of bother in the RTS sources, at the expense of
+--      deferring some errors to link time.
+lookupName :: FastString -> CmmParse CmmExpr
+lookupName name = do
+  env    <- getEnv
+  return $
+     case lookupUFM env name of
+        Just (VarN e)   -> e
+        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))
+        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
+
+
+-- | Lift an FCode computation into the CmmParse monad
+code :: FCode a -> CmmParse a
+code fc = EC $ \_ _ s -> do
+                r <- fc
+                return (s, r)
+
+emit :: CmmAGraph -> CmmParse ()
+emit = code . F.emit
+
+emitLabel :: BlockId -> CmmParse ()
+emitLabel = code . F.emitLabel
+
+emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
+emitAssign l r = code (F.emitAssign l r)
+
+emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
+emitStore l r = code (F.emitStore l r)
+
+getCode :: CmmParse a -> CmmParse CmmAGraph
+getCode (EC ec) = EC $ \c e s -> do
+  ((s',_), gr) <- F.getCodeR (ec c e s)
+  return (s', gr)
+
+getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
+getCodeR (EC ec) = EC $ \c e s -> do
+  ((s', r), gr) <- F.getCodeR (ec c e s)
+  return (s', (r,gr))
+
+getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
+getCodeScoped (EC ec) = EC $ \c e s -> do
+  ((s', r), gr) <- F.getCodeScoped (ec c e s)
+  return (s', (r,gr))
+
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
+emitOutOfLine l g = code (F.emitOutOfLine l g)
+
+withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
+withUpdFrameOff size inner
+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
+
+getUpdFrameOff :: CmmParse UpdFrameOffset
+getUpdFrameOff = code $ F.getUpdFrameOff
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -0,0 +1,534 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for foreign calls.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmForeign (
+  cgForeignCall,
+  emitPrimCall, emitCCall,
+  emitForeignCall,     -- For CmmParse
+  emitSaveThreadState,
+  saveThreadState,
+  emitLoadThreadState,
+  loadThreadState,
+  emitOpenNursery,
+  emitCloseNursery,
+ ) where
+
+import GhcPrelude hiding( succ, (<*>) )
+
+import StgSyn
+import StgCmmProf (storeCurCCS, ccsType)
+import StgCmmEnv
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmClosure
+import StgCmmLayout
+
+import BlockId (newBlockId)
+import Cmm
+import CmmUtils
+import MkGraph
+import Type
+import RepType
+import TysPrim
+import CLabel
+import SMRep
+import ForeignCall
+import DynFlags
+import Maybes
+import Outputable
+import UniqSupply
+import BasicTypes
+
+import Control.Monad
+
+-----------------------------------------------------------------------------
+-- Code generation for Foreign Calls
+-----------------------------------------------------------------------------
+
+-- | emit code for a foreign call, and return the results to the sequel.
+--
+cgForeignCall :: ForeignCall            -- the op
+              -> [StgArg]               -- x,y    arguments
+              -> Type                   -- result type
+              -> FCode ReturnKind
+
+cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
+  = do  { dflags <- getDynFlags
+        ; let -- in the stdcall calling convention, the symbol needs @size appended
+              -- to it, where size is the total number of bytes of arguments.  We
+              -- attach this info to the CLabel here, and the CLabel pretty printer
+              -- will generate the suffix when the label is printed.
+            call_size args
+              | StdCallConv <- cconv = Just (sum (map arg_size args))
+              | otherwise            = Nothing
+
+              -- ToDo: this might not be correct for 64-bit API
+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
+                                     (wORD_SIZE dflags)
+        ; cmm_args <- getFCallArgs stg_args
+        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
+        ; let ((call_args, arg_hints), cmm_target)
+                = case target of
+                   StaticTarget _ _   _      False ->
+                       panic "cgForeignCall: unexpected FFI value import"
+                   StaticTarget _ lbl mPkgId True
+                     -> let labelSource
+                                = case mPkgId of
+                                        Nothing         -> ForeignLabelInThisPackage
+                                        Just pkgId      -> ForeignLabelInPackage pkgId
+                            size = call_size cmm_args
+                        in  ( unzip cmm_args
+                            , CmmLit (CmmLabel
+                                        (mkForeignLabel lbl size labelSource IsFunction)))
+
+                   DynamicTarget    ->  case cmm_args of
+                                           (fn,_):rest -> (unzip rest, fn)
+                                           [] -> panic "cgForeignCall []"
+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
+              call_target = ForeignTarget cmm_target fc
+
+        -- we want to emit code for the call, and then emitReturn.
+        -- However, if the sequel is AssignTo, we shortcut a little
+        -- and generate a foreign call that assigns the results
+        -- directly.  Otherwise we end up generating a bunch of
+        -- useless "r = r" assignments, which are not merely annoying:
+        -- they prevent the common block elimination from working correctly
+        -- in the case of a safe foreign call.
+        -- See Note [safe foreign call convention]
+        --
+        ; sequel <- getSequel
+        ; case sequel of
+            AssignTo assign_to_these _ ->
+                emitForeignCall safety assign_to_these call_target call_args
+
+            _something_else ->
+                do { _ <- emitForeignCall safety res_regs call_target call_args
+                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)
+                   }
+         }
+
+{- Note [safe foreign call convention]
+
+The simple thing to do for a safe foreign call would be the same as an
+unsafe one: just
+
+    emitForeignCall ...
+    emitReturn ...
+
+but consider what happens in this case
+
+   case foo x y z of
+     (# s, r #) -> ...
+
+The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]
+as the result reg, and we generate
+
+  r = foo(x,y,z) returns to L1  -- emitForeignCall
+ L1:
+  r = r  -- emitReturn
+  goto L2
+L2:
+  ...
+
+Now L1 is a proc point (by definition, it is the continuation of the
+safe foreign call).  If L2 does a heap check, then L2 will also be a
+proc point.
+
+Furthermore, the stack layout algorithm has to arrange to save r
+somewhere between the call and the jump to L1, which is annoying: we
+would have to treat r differently from the other live variables, which
+have to be saved *before* the call.
+
+So we adopt a special convention for safe foreign calls: the results
+are copied out according to the NativeReturn convention by the call,
+and the continuation of the call should copyIn the results.  (The
+copyOut code is actually inserted when the safe foreign call is
+lowered later).  The result regs attached to the safe foreign call are
+only used temporarily to hold the results before they are copied out.
+
+We will now generate this:
+
+  r = foo(x,y,z) returns to L1
+ L1:
+  r = R1  -- copyIn, inserted by mkSafeCall
+  goto L2
+ L2:
+  ... r ...
+
+And when the safe foreign call is lowered later (see Note [lower safe
+foreign calls]) we get this:
+
+  suspendThread()
+  r = foo(x,y,z)
+  resumeThread()
+  R1 = r  -- copyOut, inserted by lowerSafeForeignCall
+  jump L1
+ L1:
+  r = R1  -- copyIn, inserted by mkSafeCall
+  goto L2
+ L2:
+  ... r ...
+
+Now consider what happens if L2 does a heap check: the Adams
+optimisation kicks in and commons up L1 with the heap-check
+continuation, resulting in just one proc point instead of two. Yay!
+-}
+
+
+emitCCall :: [(CmmFormal,ForeignHint)]
+          -> CmmExpr
+          -> [(CmmActual,ForeignHint)]
+          -> FCode ()
+emitCCall hinted_results fn hinted_args
+  = void $ emitForeignCall PlayRisky results target args
+  where
+    (args, arg_hints) = unzip hinted_args
+    (results, result_hints) = unzip hinted_results
+    target = ForeignTarget fn fc
+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
+
+
+emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
+emitPrimCall res op args
+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args
+
+-- alternative entry point, used by CmmParse
+emitForeignCall
+        :: Safety
+        -> [CmmFormal]          -- where to put the results
+        -> ForeignTarget        -- the op
+        -> [CmmActual]          -- arguments
+        -> FCode ReturnKind
+emitForeignCall safety results target args
+  | not (playSafe safety) = do
+    dflags <- getDynFlags
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+    emit caller_save
+    target' <- load_target_into_temp target
+    args' <- mapM maybe_assign_temp args
+    emit $ mkUnsafeCall target' results args'
+    emit caller_load
+    return AssignedDirectly
+
+  | otherwise = do
+    dflags <- getDynFlags
+    updfr_off <- getUpdFrameOff
+    target' <- load_target_into_temp target
+    args' <- mapM maybe_assign_temp args
+    k <- newBlockId
+    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []
+       -- see Note [safe foreign call convention]
+    tscope <- getTickScope
+    emit $
+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
+                        (CmmLit (CmmBlock k))
+            <*> mkLast (CmmForeignCall { tgt  = target'
+                                       , res  = results
+                                       , args = args'
+                                       , succ = k
+                                       , ret_args = off
+                                       , ret_off = updfr_off
+                                       , intrbl = playInterruptible safety })
+            <*> mkLabel k tscope
+            <*> copyout
+           )
+    return (ReturnedTo k off)
+
+load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
+load_target_into_temp (ForeignTarget expr conv) = do
+  tmp <- maybe_assign_temp expr
+  return (ForeignTarget tmp conv)
+load_target_into_temp other_target@(PrimTarget _) =
+  return other_target
+
+-- What we want to do here is create a new temporary for the foreign
+-- call argument if it is not safe to use the expression directly,
+-- because the expression mentions caller-saves GlobalRegs (see
+-- Note [Register Parameter Passing]).
+--
+-- However, we can't pattern-match on the expression here, because
+-- this is used in a loop by CmmParse, and testing the expression
+-- results in a black hole.  So we always create a temporary, and rely
+-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code
+-- ends up being the same, at least for the RTS .cmm code.
+--
+maybe_assign_temp :: CmmExpr -> FCode CmmExpr
+maybe_assign_temp e = do
+  dflags <- getDynFlags
+  reg <- newTemp (cmmExprType dflags e)
+  emitAssign (CmmLocal reg) e
+  return (CmmReg (CmmLocal reg))
+
+-- -----------------------------------------------------------------------------
+-- Save/restore the thread state in the TSO
+
+-- This stuff can't be done in suspendThread/resumeThread, because it
+-- refers to global registers which aren't available in the C world.
+
+emitSaveThreadState :: FCode ()
+emitSaveThreadState = do
+  dflags <- getDynFlags
+  code <- saveThreadState dflags
+  emit code
+
+-- | Produce code to save the current thread state to @CurrentTSO@
+saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
+saveThreadState dflags = do
+  tso <- newTemp (gcWord dflags)
+  close_nursery <- closeNursery dflags tso
+  pure $ catAGraphs [
+    -- tso = CurrentTSO;
+    mkAssign (CmmLocal tso) currentTSOExpr,
+    -- tso->stackobj->sp = Sp;
+    mkStore (cmmOffset dflags
+                       (CmmLoad (cmmOffset dflags
+                                           (CmmReg (CmmLocal tso))
+                                           (tso_stackobj dflags))
+                                (bWord dflags))
+                       (stack_SP dflags))
+            spExpr,
+    close_nursery,
+    -- and save the current cost centre stack in the TSO when profiling:
+    if gopt Opt_SccProfilingOn dflags then
+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
+      else mkNop
+    ]
+
+emitCloseNursery :: FCode ()
+emitCloseNursery = do
+  dflags <- getDynFlags
+  tso <- newTemp (bWord dflags)
+  code <- closeNursery dflags tso
+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
+
+{- |
+@closeNursery dflags tso@ produces code to close the nursery.
+A local register holding the value of @CurrentTSO@ is expected for
+efficiency.
+
+Closing the nursery corresponds to the following code:
+
+@
+  tso = CurrentTSO;
+  cn = CurrentNuresry;
+
+  // Update the allocation limit for the current thread.  We don't
+  // check to see whether it has overflowed at this point, that check is
+  // made when we run out of space in the current heap block (stg_gc_noregs)
+  // and in the scheduler when context switching (schedulePostRunThread).
+  tso->alloc_limit -= Hp + WDS(1) - cn->start;
+
+  // Set cn->free to the next unoccupied word in the block
+  cn->free = Hp + WDS(1);
+@
+-}
+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
+closeNursery df tso = do
+  let tsoreg  = CmmLocal tso
+  cnreg      <- CmmLocal <$> newTemp (bWord df)
+  pure $ catAGraphs [
+    mkAssign cnreg currentNurseryExpr,
+
+    -- CurrentNursery->free = Hp+1;
+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),
+
+    let alloc =
+           CmmMachOp (mo_wordSub df)
+              [ cmmOffsetW df hpExpr 1
+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
+              ]
+
+        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+    in
+
+    -- tso->alloc_limit += alloc
+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)
+                               [ CmmLoad alloc_limit b64
+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])
+   ]
+
+emitLoadThreadState :: FCode ()
+emitLoadThreadState = do
+  dflags <- getDynFlags
+  code <- loadThreadState dflags
+  emit code
+
+-- | Produce code to load the current thread state from @CurrentTSO@
+loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
+loadThreadState dflags = do
+  tso <- newTemp (gcWord dflags)
+  stack <- newTemp (gcWord dflags)
+  open_nursery <- openNursery dflags tso
+  pure $ catAGraphs [
+    -- tso = CurrentTSO;
+    mkAssign (CmmLocal tso) currentTSOExpr,
+    -- stack = tso->stackobj;
+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
+    -- Sp = stack->sp;
+    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;
+    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
+                                (rESERVED_STACK_WORDS dflags)),
+    -- HpAlloc = 0;
+    --   HpAlloc is assumed to be set to non-zero only by a failed
+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
+    mkAssign hpAllocReg (zeroExpr dflags),
+    open_nursery,
+    -- and load the current cost centre stack from the TSO when profiling:
+    if gopt Opt_SccProfilingOn dflags
+       then storeCurCCS
+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))
+                 (tso_CCCS dflags)) (ccsType dflags))
+       else mkNop
+   ]
+
+
+emitOpenNursery :: FCode ()
+emitOpenNursery = do
+  dflags <- getDynFlags
+  tso <- newTemp (bWord dflags)
+  code <- openNursery dflags tso
+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
+
+{- |
+@openNursery dflags tso@ produces code to open the nursery. A local register
+holding the value of @CurrentTSO@ is expected for efficiency.
+
+Opening the nursery corresponds to the following code:
+
+@
+   tso = CurrentTSO;
+   cn = CurrentNursery;
+   bdfree = CurrentNursery->free;
+   bdstart = CurrentNursery->start;
+
+   // We *add* the currently occupied portion of the nursery block to
+   // the allocation limit, because we will subtract it again in
+   // closeNursery.
+   tso->alloc_limit += bdfree - bdstart;
+
+   // Set Hp to the last occupied word of the heap block.  Why not the
+   // next unocupied word?  Doing it this way means that we get to use
+   // an offset of zero more often, which might lead to slightly smaller
+   // code on some architectures.
+   Hp = bdfree - WDS(1);
+
+   // Set HpLim to the end of the current nursery block (note that this block
+   // might be a block group, consisting of several adjacent blocks.
+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+@
+-}
+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
+openNursery df tso = do
+  let tsoreg =  CmmLocal tso
+  cnreg      <- CmmLocal <$> newTemp (bWord df)
+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)
+  bdstartreg <- CmmLocal <$> newTemp (bWord df)
+
+  -- These assignments are carefully ordered to reduce register
+  -- pressure and generate not completely awful code on x86.  To see
+  -- what code we generate, look at the assembly for
+  -- stg_returnToStackTop in rts/StgStartup.cmm.
+  pure $ catAGraphs [
+     mkAssign cnreg currentNurseryExpr,
+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),
+
+     -- Hp = CurrentNursery->free - 1;
+     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),
+
+     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
+
+     -- HpLim = CurrentNursery->start +
+     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+     mkAssign hpLimReg
+         (cmmOffsetExpr df
+             (CmmReg bdstartreg)
+             (cmmOffset df
+               (CmmMachOp (mo_wordMul df) [
+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))
+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],
+                 mkIntExpr df (bLOCK_SIZE df)
+                ])
+               (-1)
+             )
+         ),
+
+     -- alloc = bd->free - bd->start
+     let alloc =
+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]
+
+         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+     in
+
+     -- tso->alloc_limit += alloc
+     mkStore alloc_limit (CmmMachOp (MO_Add W64)
+                               [ CmmLoad alloc_limit b64
+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])
+
+   ]
+
+nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
+  :: DynFlags -> CmmReg -> CmmExpr
+nursery_bdescr_free   dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)
+nursery_bdescr_start  dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)
+nursery_bdescr_blocks dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)
+
+tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
+tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)
+tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
+stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)
+stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
+
+
+closureField :: DynFlags -> ByteOff -> ByteOff
+closureField dflags off = off + fixedHdrSize dflags
+
+-- -----------------------------------------------------------------------------
+-- For certain types passed to foreign calls, we adjust the actual
+-- value passed to the call.  For ByteArray#/Array# we pass the
+-- address of the actual array, not the address of the heap object.
+
+getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
+-- (a) Drop void args
+-- (b) Add foreign-call shim code
+-- It's (b) that makes this differ from getNonVoidArgAmodes
+
+getFCallArgs args
+  = do  { mb_cmms <- mapM get args
+        ; return (catMaybes mb_cmms) }
+  where
+    get arg | null arg_reps
+            = return Nothing
+            | otherwise
+            = do { cmm <- getArgAmode (NonVoid arg)
+                 ; dflags <- getDynFlags
+                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
+            where
+              arg_ty   = stgArgType arg
+              arg_reps = typePrimRep arg_ty
+              hint     = typeForeignHint arg_ty
+
+add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
+add_shim dflags arg_ty expr
+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
+
+  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
+  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
+
+  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
+
+  | otherwise = expr
+  where
+    tycon           = tyConAppTyCon (unwrapType arg_ty)
+        -- should be a tycon app, since this is a foreign call
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -0,0 +1,680 @@
+-----------------------------------------------------------------------------
+--
+-- Stg to C--: heap management functions
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmHeap (
+        getVirtHp, setVirtHp, setRealHp,
+        getHpRelOffset,
+
+        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
+        heapStackCheckGen,
+        entryHeapCheck',
+
+        mkStaticClosureFields, mkStaticClosure,
+
+        allocDynClosure, allocDynClosureCmm, allocHeapClosure,
+        emitSetDynHdr
+    ) where
+
+import GhcPrelude hiding ((<*>))
+
+import StgSyn
+import CLabel
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmMonad
+import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)
+import StgCmmTicky
+import StgCmmClosure
+import StgCmmEnv
+
+import MkGraph
+
+import Hoopl.Label
+import SMRep
+import BlockId
+import Cmm
+import CmmUtils
+import CostCentre
+import IdInfo( CafInfo(..), mayHaveCafRefs )
+import Id ( Id )
+import Module
+import DynFlags
+import FastString( mkFastString, fsLit )
+import Panic( sorry )
+
+import Control.Monad (when)
+import Data.Maybe (isJust)
+
+-----------------------------------------------------------
+--              Initialise dynamic heap objects
+-----------------------------------------------------------
+
+allocDynClosure
+        :: Maybe Id
+        -> CmmInfoTable
+        -> LambdaFormInfo
+        -> CmmExpr              -- Cost Centre to stick in the object
+        -> CmmExpr              -- Cost Centre to blame for this alloc
+                                -- (usually the same; sometimes "OVERHEAD")
+
+        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
+                                                -- ie Info ptr has offset zero.
+                                                -- No void args in here
+        -> FCode CmmExpr -- returns Hp+n
+
+allocDynClosureCmm
+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
+        -> [(CmmExpr, ByteOff)]
+        -> FCode CmmExpr -- returns Hp+n
+
+-- allocDynClosure allocates the thing in the heap,
+-- and modifies the virtual Hp to account for this.
+-- The second return value is the graph that sets the value of the
+-- returned LocalReg, which should point to the closure after executing
+-- the graph.
+
+-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is
+-- only valid until Hp is changed.  The caller should assign the
+-- result to a LocalReg if it is required to remain live.
+--
+-- The reason we don't assign it to a LocalReg here is that the caller
+-- is often about to call regIdInfo, which immediately assigns the
+-- result of allocDynClosure to a new temp in order to add the tag.
+-- So by not generating a LocalReg here we avoid a common source of
+-- new temporaries and save some compile time.  This can be quite
+-- significant - see test T4801.
+
+
+allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do
+  let (args, offsets) = unzip args_w_offsets
+  cmm_args <- mapM getArgAmode args     -- No void args
+  allocDynClosureCmm mb_id info_tbl lf_info
+                     use_cc _blame_cc (zip cmm_args offsets)
+
+
+allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
+  -- SAY WHAT WE ARE ABOUT TO DO
+  let rep = cit_rep info_tbl
+  tickyDynAlloc mb_id rep lf_info
+  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))
+  allocHeapClosure rep info_ptr use_cc amodes_w_offsets
+
+
+-- | Low-level heap object allocation.
+allocHeapClosure
+  :: SMRep                            -- ^ representation of the object
+  -> CmmExpr                          -- ^ info pointer
+  -> CmmExpr                          -- ^ cost centre
+  -> [(CmmExpr,ByteOff)]              -- ^ payload
+  -> FCode CmmExpr                    -- ^ returns the address of the object
+allocHeapClosure rep info_ptr use_cc payload = do
+  profDynAlloc rep use_cc
+
+  virt_hp <- getVirtHp
+
+  -- Find the offset of the info-ptr word
+  let info_offset = virt_hp + 1
+            -- info_offset is the VirtualHpOffset of the first
+            -- word of the new object
+            -- Remember, virtHp points to last allocated word,
+            -- ie 1 *before* the info-ptr word of new object.
+
+  base <- getHpRelOffset info_offset
+  emitComment $ mkFastString "allocHeapClosure"
+  emitSetDynHdr base info_ptr use_cc
+
+  -- Fill in the fields
+  hpStore base payload
+
+  -- Bump the virtual heap pointer
+  dflags <- getDynFlags
+  setVirtHp (virt_hp + heapClosureSizeW dflags rep)
+
+  return base
+
+
+emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+emitSetDynHdr base info_ptr ccs
+  = do dflags <- getDynFlags
+       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])
+  where
+    header :: DynFlags -> [CmmExpr]
+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs
+        -- ToDo: Parallel stuff
+        -- No ticky header
+
+-- Store the item (expr,off) in base[off]
+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
+hpStore base vals = do
+  dflags <- getDynFlags
+  sequence_ $
+    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]
+
+-----------------------------------------------------------
+--              Layout of static closures
+-----------------------------------------------------------
+
+-- Make a static closure, adding on any extra padding needed for CAFs,
+-- and adding a static link field if necessary.
+
+mkStaticClosureFields
+        :: DynFlags
+        -> CmmInfoTable
+        -> CostCentreStack
+        -> CafInfo
+        -> [CmmLit]             -- Payload
+        -> [CmmLit]             -- The full closure
+mkStaticClosureFields dflags info_tbl ccs caf_refs payload
+  = mkStaticClosure dflags info_lbl ccs payload padding
+        static_link_field saved_info_field
+  where
+    info_lbl = cit_lbl info_tbl
+
+    -- CAFs must have consistent layout, regardless of whether they
+    -- are actually updatable or not.  The layout of a CAF is:
+    --
+    --        3 saved_info
+    --        2 static_link
+    --        1 indirectee
+    --        0 info ptr
+    --
+    -- the static_link and saved_info fields must always be in the
+    -- same place.  So we use isThunkRep rather than closureUpdReqd
+    -- here:
+
+    is_caf = isThunkRep (cit_rep info_tbl)
+
+    padding
+        | is_caf && null payload = [mkIntCLit dflags 0]
+        | otherwise = []
+
+    static_link_field
+        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
+        = [static_link_value]
+        | otherwise
+        = []
+
+    saved_info_field
+        | is_caf     = [mkIntCLit dflags 0]
+        | otherwise  = []
+
+        -- For a static constructor which has NoCafRefs, we set the
+        -- static link field to a non-zero value so the garbage
+        -- collector will ignore it.
+    static_link_value
+        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0
+        | otherwise                = mkIntCLit dflags 3  -- No CAF refs
+                                      -- See Note [STATIC_LINK fields]
+                                      -- in rts/sm/Storage.h
+
+mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
+  =  [CmmLabel info_lbl]
+  ++ staticProfHdr dflags ccs
+  ++ payload
+  ++ padding
+  ++ static_link_field
+  ++ saved_info_field
+
+-----------------------------------------------------------
+--              Heap overflow checking
+-----------------------------------------------------------
+
+{- Note [Heap checks]
+   ~~~~~~~~~~~~~~~~~~
+Heap checks come in various forms.  We provide the following entry
+points to the runtime system, all of which use the native C-- entry
+convention.
+
+  * gc() performs garbage collection and returns
+    nothing to its caller
+
+  * A series of canned entry points like
+        r = gc_1p( r )
+    where r is a pointer.  This performs gc, and
+    then returns its argument r to its caller.
+
+  * A series of canned entry points like
+        gcfun_2p( f, x, y )
+    where f is a function closure of arity 2
+    This performs garbage collection, keeping alive the
+    three argument ptrs, and then tail-calls f(x,y)
+
+These are used in the following circumstances
+
+* entryHeapCheck: Function entry
+    (a) With a canned GC entry sequence
+        f( f_clo, x:ptr, y:ptr ) {
+             Hp = Hp+8
+             if Hp > HpLim goto L
+             ...
+          L: HpAlloc = 8
+             jump gcfun_2p( f_clo, x, y ) }
+     Note the tail call to the garbage collector;
+     it should do no register shuffling
+
+    (b) No canned sequence
+        f( f_clo, x:ptr, y:ptr, ...etc... ) {
+          T: Hp = Hp+8
+             if Hp > HpLim goto L
+             ...
+          L: HpAlloc = 8
+             call gc()  -- Needs an info table
+             goto T }
+
+* altHeapCheck: Immediately following an eval
+  Started as
+        case f x y of r { (p,q) -> rhs }
+  (a) With a canned sequence for the results of f
+       (which is the very common case since
+       all boxed cases return just one pointer
+           ...
+           r = f( x, y )
+        K:      -- K needs an info table
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...code for rhs...
+
+        L: r = gc_1p( r )
+           goto K }
+
+        Here, the info table needed by the call
+        to gc_1p should be the *same* as the
+        one for the call to f; the C-- optimiser
+        spots this sharing opportunity)
+
+   (b) No canned sequence for results of f
+       Note second info table
+           ...
+           (r1,r2,r3) = call f( x, y )
+        K:
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...code for rhs...
+
+        L: call gc()    -- Extra info table here
+           goto K
+
+* generalHeapCheck: Anywhere else
+  e.g. entry to thunk
+       case branch *not* following eval,
+       or let-no-escape
+  Exactly the same as the previous case:
+
+        K:      -- K needs an info table
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...
+
+        L: call gc()
+           goto K
+-}
+
+--------------------------------------------------------------
+-- A heap/stack check at a function or thunk entry point.
+
+entryHeapCheck :: ClosureInfo
+               -> Maybe LocalReg -- Function (closure environment)
+               -> Int            -- Arity -- not same as len args b/c of voids
+               -> [LocalReg]     -- Non-void args (empty for thunk)
+               -> FCode ()
+               -> FCode ()
+
+entryHeapCheck cl_info nodeSet arity args code
+  = entryHeapCheck' is_fastf node arity args code
+  where
+    node = case nodeSet of
+              Just r  -> CmmReg (CmmLocal r)
+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+
+    is_fastf = case closureFunInfo cl_info of
+                 Just (_, ArgGen _) -> False
+                 _otherwise         -> True
+
+-- | lower-level version for CmmParse
+entryHeapCheck' :: Bool           -- is a known function pattern
+                -> CmmExpr        -- expression for the closure pointer
+                -> Int            -- Arity -- not same as len args b/c of voids
+                -> [LocalReg]     -- Non-void args (empty for thunk)
+                -> FCode ()
+                -> FCode ()
+entryHeapCheck' is_fastf node arity args code
+  = do dflags <- getDynFlags
+       let is_thunk = arity == 0
+
+           args' = map (CmmReg . CmmLocal) args
+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)
+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
+
+           {- Thunks:          jump stg_gc_enter_1
+
+              Function (fast): call (NativeNode) stg_gc_fun(fun, args)
+
+              Function (slow): call (slow) stg_gc_fun(fun, args)
+           -}
+           gc_call upd
+               | is_thunk
+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd
+
+               | is_fastf
+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd
+
+               | otherwise
+                 = mkJump dflags Slow stg_gc_fun (node : args') upd
+
+       updfr_sz <- getUpdFrameOff
+
+       loop_id <- newBlockId
+       emitLabel loop_id
+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
+
+-- ------------------------------------------------------------
+-- A heap/stack check in a case alternative
+
+
+-- If there are multiple alts and we need to GC, but don't have a
+-- continuation already (the scrut was simple), then we should
+-- pre-generate the continuation.  (if there are multiple alts it is
+-- always a canned GC point).
+
+-- altHeapCheck:
+-- If we have a return continuation,
+--   then if it is a canned GC pattern,
+--           then we do mkJumpReturnsTo
+--           else we do a normal call to stg_gc_noregs
+--   else if it is a canned GC pattern,
+--           then generate the continuation and do mkCallReturnsTo
+--           else we do a normal call to stg_gc_noregs
+
+altHeapCheck :: [LocalReg] -> FCode a -> FCode a
+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
+
+altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
+altOrNoEscapeHeapCheck checkYield regs code = do
+    dflags <- getDynFlags
+    case cannedGCEntryPoint dflags regs of
+      Nothing -> genericGC checkYield code
+      Just gc -> do
+        lret <- newBlockId
+        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
+        lcont <- newBlockId
+        tscope <- getTickScope
+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
+        emitLabel lcont
+        cannedGCReturnsTo checkYield False gc regs lret off code
+
+altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
+altHeapCheckReturnsTo regs lret off code
+  = do dflags <- getDynFlags
+       case cannedGCEntryPoint dflags regs of
+           Nothing -> genericGC False code
+           Just gc -> cannedGCReturnsTo False True gc regs lret off code
+
+-- noEscapeHeapCheck is implemented identically to altHeapCheck (which
+-- is more efficient), but cannot be optimized away in the non-allocating
+-- case because it may occur in a loop
+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code
+
+cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
+                  -> FCode a
+                  -> FCode a
+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
+  = do dflags <- getDynFlags
+       updfr_sz <- getUpdFrameOff
+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code
+  where
+    reg_exprs = map (CmmReg . CmmLocal) regs
+      -- Note [stg_gc arguments]
+
+      -- NB. we use the NativeReturn convention for passing arguments
+      -- to the canned heap-check routines, because we are in a case
+      -- alternative and hence the [LocalReg] was passed to us in the
+      -- NativeReturn convention.
+    gc_call dflags label sp
+      | cont_on_stack
+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp
+      | otherwise
+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []
+
+genericGC :: Bool -> FCode a -> FCode a
+genericGC checkYield code
+  = do updfr_sz <- getUpdFrameOff
+       lretry <- newBlockId
+       emitLabel lretry
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
+       heapCheck False checkYield (call <*> mkBranch lretry) code
+
+cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
+cannedGCEntryPoint dflags regs
+  = case map localRegType regs of
+      []  -> Just (mkGcLabel "stg_gc_noregs")
+      [ty]
+          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
+          | isFloatType ty -> case width of
+                                  W32       -> Just (mkGcLabel "stg_gc_f1")
+                                  W64       -> Just (mkGcLabel "stg_gc_d1")
+                                  _         -> Nothing
+
+          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")
+          | width == W64              -> Just (mkGcLabel "stg_gc_l1")
+          | otherwise                 -> Nothing
+          where
+              width = typeWidth ty
+      [ty1,ty2]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
+      [ty1,ty2,ty3]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
+      [ty1,ty2,ty3,ty4]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3
+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
+      _otherwise -> Nothing
+
+-- Note [stg_gc arguments]
+-- It might seem that we could avoid passing the arguments to the
+-- stg_gc function, because they are already in the right registers.
+-- While this is usually the case, it isn't always.  Sometimes the
+-- code generator has cleverly avoided the eval in a case, e.g. in
+-- ffi/should_run/4221.hs we found
+--
+--   case a_r1mb of z
+--     FunPtr x y -> ...
+--
+-- where a_r1mb is bound a top-level constructor, and is known to be
+-- evaluated.  The codegen just assigns x, y and z, and continues;
+-- R1 is never assigned.
+--
+-- So we'll have to rely on optimisations to eliminatethese
+-- assignments where possible.
+
+
+-- | The generic GC procedure; no params, no results
+generic_gc :: CmmExpr
+generic_gc = mkGcLabel "stg_gc_noregs"
+
+-- | Create a CLabel for calling a garbage collector entry point
+mkGcLabel :: String -> CmmExpr
+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))
+
+-------------------------------
+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
+heapCheck checkStack checkYield do_gc code
+  = getHeapUsage $ \ hpHw ->
+    -- Emit heap checks, but be sure to do it lazily so
+    -- that the conditionals on hpHw don't cause a black hole
+    do  { dflags <- getDynFlags
+        ; let mb_alloc_bytes
+                 | hpHw > mBLOCK_SIZE = sorry $ unlines
+                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",
+                     "",
+                     "This is currently not possible due to a limitation of GHC's code generator.",
+                     "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",
+                     "Suggestion: read data from a file instead of having large static data",
+                     "structures in code."]
+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
+                 | otherwise = Nothing
+                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags
+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
+                      | otherwise  = Nothing
+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
+        ; tickyAllocHeap True hpHw
+        ; setRealHp hpHw
+        ; code }
+
+heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
+heapStackCheckGen stk_hwm mb_bytes
+  = do updfr_sz <- getUpdFrameOff
+       lretry <- newBlockId
+       emitLabel lretry
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
+       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)
+
+-- Note [Single stack check]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- When compiling a function we can determine how much stack space it
+-- will use. We therefore need to perform only a single stack check at
+-- the beginning of a function to see if we have enough stack space.
+--
+-- The check boils down to comparing Sp-N with SpLim, where N is the
+-- amount of stack space needed (see Note [Stack usage] below).  *BUT*
+-- at this stage of the pipeline we are not supposed to refer to Sp
+-- itself, because the stack is not yet manifest, so we don't quite
+-- know where Sp pointing.
+
+-- So instead of referring directly to Sp - as we used to do in the
+-- past - the code generator uses (old + 0) in the stack check. That
+-- is the address of the first word of the old area, so if we add N
+-- we'll get the address of highest used word.
+--
+-- This makes the check robust.  For example, while we need to perform
+-- only one stack check for each function, we could in theory place
+-- more stack checks later in the function. They would be redundant,
+-- but not incorrect (in a sense that they should not change program
+-- behaviour). We need to make sure however that a stack check
+-- inserted after incrementing the stack pointer checks for a
+-- respectively smaller stack space. This would not be the case if the
+-- code generator produced direct references to Sp. By referencing
+-- (old + 0) we make sure that we always check for a correct amount of
+-- stack: when converting (old + 0) to Sp the stack layout phase takes
+-- into account changes already made to stack pointer. The idea for
+-- this change came from observations made while debugging #8275.
+
+-- Note [Stack usage]
+-- ~~~~~~~~~~~~~~~~~~
+-- At the moment we convert from STG to Cmm we don't know N, the
+-- number of bytes of stack that the function will use, so we use a
+-- special late-bound CmmLit, namely
+--       CmmHighStackMark
+-- to stand for the number of bytes needed. When the stack is made
+-- manifest, the number of bytes needed is calculated, and used to
+-- replace occurrences of CmmHighStackMark
+--
+-- The (Maybe CmmExpr) passed to do_checks is usually
+--     Just (CmmLit CmmHighStackMark)
+-- but can also (in certain hand-written RTS functions)
+--     Just (CmmLit 8)  or some other fixed valuet
+-- If it is Nothing, we don't generate a stack check at all.
+
+do_checks :: Maybe CmmExpr    -- Should we check the stack?
+                              -- See Note [Stack usage]
+          -> Bool             -- Should we check for preemption?
+          -> Maybe CmmExpr    -- Heap headroom (bytes)
+          -> CmmAGraph        -- What to do on failure
+          -> FCode ()
+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
+  dflags <- getDynFlags
+  gc_id <- newBlockId
+
+  let
+    Just alloc_lit = mb_alloc_lit
+
+    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit
+
+    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
+    -- At the beginning of a function old + 0 = Sp
+    -- See Note [Single stack check]
+    sp_oflo sp_hwm =
+         CmmMachOp (mo_wordULt dflags)
+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
+                             [CmmStackSlot Old 0, sp_hwm],
+                   CmmReg spLimReg]
+
+    -- Hp overflow if (Hp > HpLim)
+    -- (Hp has been incremented by now)
+    -- HpLim points to the LAST WORD of valid allocation space.
+    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]
+
+    alloc_n = mkAssign hpAllocReg alloc_lit
+
+  case mb_stk_hwm of
+    Nothing -> return ()
+    Just stk_hwm -> tickyStackCheck
+      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )
+
+  -- Emit new label that might potentially be a header
+  -- of a self-recursive tail call.
+  -- See Note [Self-recursive loop header].
+  self_loop_info <- getSelfLoop
+  case self_loop_info of
+    Just (_, loop_header_id, _)
+        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id
+    _otherwise -> return ()
+
+  if (isJust mb_alloc_lit)
+    then do
+     tickyHeapCheck
+     emitAssign hpReg bump_hp
+     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)
+    else do
+      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do
+         -- Yielding if HpLim == 0
+         let yielding = CmmMachOp (mo_wordEq dflags)
+                                  [CmmReg hpLimReg,
+                                   CmmLit (zeroCLit dflags)]
+         emit =<< mkCmmIfGoto' yielding gc_id (Just False)
+
+  tscope <- getTickScope
+  emitOutOfLine gc_id
+   (do_gc, tscope) -- this is expected to jump back somewhere
+
+                -- Test for stack pointer exhaustion, then
+                -- bump heap pointer, and test for heap exhaustion
+                -- Note that we don't move the heap pointer unless the
+                -- stack check succeeds.  Otherwise we might end up
+                -- with slop at the end of the current block, which can
+                -- confuse the LDV profiler.
+
+-- Note [Self-recursive loop header]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Self-recursive loop header is required by loopification optimization (See
+-- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if:
+--
+--  1. There is information about self-loop in the FCode environment. We don't
+--     check the binder (first component of the self_loop_info) because we are
+--     certain that if the self-loop info is present then we are compiling the
+--     binder body. Reason: the only possible way to get here with the
+--     self_loop_info present is from closureCodeBody.
+--
+--  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible
+--     to preempt the heap check (see #367 for motivation behind this check). It
+--     is True for heap checks placed at the entry to a function and
+--     let-no-escape heap checks but false for other heap checks (eg. in case
+--     alternatives or created from hand-written high-level Cmm). The second
+--     check (isJust mb_stk_hwm) is true for heap checks at the entry to a
+--     function and some heap checks created in hand-written Cmm. Otherwise it
+--     is Nothing. In other words the only situation when both conditions are
+--     true is when compiling stack and heap checks at the entry to a
+--     function. This is the only situation when we want to emit a self-loop
+--     label.
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -0,0 +1,48 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for coverage
+--
+-- (c) Galois Connections, Inc. 2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmHpc ( initHpc, mkTickBox ) where
+
+import GhcPrelude
+
+import StgCmmMonad
+
+import MkGraph
+import CmmExpr
+import CLabel
+import Module
+import CmmUtils
+import StgCmmUtils
+import HscTypes
+import DynFlags
+
+import Control.Monad
+
+mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph
+mkTickBox dflags mod n
+  = mkStore tick_box (CmmMachOp (MO_Add W64)
+                                [ CmmLoad tick_box b64
+                                , CmmLit (CmmInt 1 W64)
+                                ])
+  where
+    tick_box = cmmIndex dflags W64
+                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
+                        n
+
+initHpc :: Module -> HpcInfo -> FCode ()
+-- Emit top-level tables for HPC and return code to initialise
+initHpc _ (NoHpcInfo {})
+  = return ()
+initHpc this_mod (HpcInfo tickCount _hashNo)
+  = do dflags <- getDynFlags
+       when (gopt Opt_Hpc dflags) $
+           do emitDataLits (mkHpcTicksLabel this_mod)
+                           [ (CmmInt 0 W64)
+                           | _ <- take tickCount [0 :: Int ..]
+                           ]
+
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -0,0 +1,623 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Building info tables.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmLayout (
+        mkArgDescr,
+        emitCall, emitReturn, adjustHpBackwards,
+
+        emitClosureProcAndInfoTable,
+        emitClosureAndInfoTable,
+
+        slowCall, directCall,
+
+        FieldOffOrPadding(..),
+        ClosureHeader(..),
+        mkVirtHeapOffsets,
+        mkVirtHeapOffsetsWithPadding,
+        mkVirtConstrOffsets,
+        mkVirtConstrSizes,
+        getHpRelOffset,
+
+        ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep
+  ) where
+
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmClosure
+import StgCmmEnv
+import StgCmmArgRep -- notably: ( slowCallPattern )
+import StgCmmTicky
+import StgCmmMonad
+import StgCmmUtils
+
+import MkGraph
+import SMRep
+import BlockId
+import Cmm
+import CmmUtils
+import CmmInfo
+import CLabel
+import StgSyn
+import Id
+import TyCon             ( PrimRep(..), primRepSizeB )
+import BasicTypes        ( RepArity )
+import DynFlags
+import Module
+
+import Util
+import Data.List
+import Outputable
+import FastString
+import Control.Monad
+
+------------------------------------------------------------------------
+--                Call and return sequences
+------------------------------------------------------------------------
+
+-- | Return multiple values to the sequel
+--
+-- If the sequel is @Return@
+--
+-- >     return (x,y)
+--
+-- If the sequel is @AssignTo [p,q]@
+--
+-- >    p=x; q=y;
+--
+emitReturn :: [CmmExpr] -> FCode ReturnKind
+emitReturn results
+  = do { dflags    <- getDynFlags
+       ; sequel    <- getSequel
+       ; updfr_off <- getUpdFrameOff
+       ; case sequel of
+           Return ->
+             do { adjustHpBackwards
+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)
+                }
+           AssignTo regs adjust ->
+             do { when adjust adjustHpBackwards
+                ; emitMultiAssign  regs results }
+       ; return AssignedDirectly
+       }
+
+
+-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
+-- using the call/return convention @conv@, passing @args@, and
+-- returning the results to the current sequel.
+--
+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
+emitCall convs fun args
+  = emitCallWithExtraStack convs fun args noExtraStack
+
+
+-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
+-- entry-code of @fun@, using the call/return convention @conv@,
+-- passing @args@, pushing some extra stack frames described by
+-- @stack@, and returning the results to the current sequel.
+--
+emitCallWithExtraStack
+   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
+   -> [CmmExpr] -> FCode ReturnKind
+emitCallWithExtraStack (callConv, retConv) fun args extra_stack
+  = do  { dflags <- getDynFlags
+        ; adjustHpBackwards
+        ; sequel <- getSequel
+        ; updfr_off <- getUpdFrameOff
+        ; case sequel of
+            Return -> do
+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack
+              return AssignedDirectly
+            AssignTo res_regs _ -> do
+              k <- newBlockId
+              let area = Young k
+                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []
+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
+                                   extra_stack
+              tscope <- getTickScope
+              emit (copyout <*> mkLabel k tscope <*> copyin)
+              return (ReturnedTo k off)
+      }
+
+
+adjustHpBackwards :: FCode ()
+-- This function adjusts the heap pointer just before a tail call or
+-- return.  At a call or return, the virtual heap pointer may be less
+-- than the real Hp, because the latter was advanced to deal with
+-- the worst-case branch of the code, and we may be in a better-case
+-- branch.  In that case, move the real Hp *back* and retract some
+-- ticky allocation count.
+--
+-- It *does not* deal with high-water-mark adjustment.  That's done by
+-- functions which allocate heap.
+adjustHpBackwards
+  = do  { hp_usg <- getHpUsage
+        ; let rHp = realHp hp_usg
+              vHp = virtHp hp_usg
+              adjust_words = vHp -rHp
+        ; new_hp <- getHpRelOffset vHp
+
+        ; emit (if adjust_words == 0
+                then mkNop
+                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
+
+        ; tickyAllocHeap False adjust_words -- ...ditto
+
+        ; setRealHp vHp
+        }
+
+
+-------------------------------------------------------------------------
+--        Making calls: directCall and slowCall
+-------------------------------------------------------------------------
+
+-- General plan is:
+--   - we'll make *one* fast call, either to the function itself
+--     (directCall) or to stg_ap_<pat>_fast (slowCall)
+--     Any left-over arguments will be pushed on the stack,
+--
+--     e.g. Sp[old+8]  = arg1
+--          Sp[old+16] = arg2
+--          Sp[old+32] = stg_ap_pp_info
+--          R2 = arg3
+--          R3 = arg4
+--          call f() return to Nothing updfr_off: 32
+
+
+directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
+-- (directCall f n args)
+-- calls f(arg1, ..., argn), and applies the result to the remaining args
+-- The function f has arity n, and there are guaranteed at least n args
+-- Both arity and args include void args
+directCall conv lbl arity stg_args
+  = do  { argreps <- getArgRepsAmodes stg_args
+        ; direct_call "directCall" conv lbl arity argreps }
+
+
+slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
+-- (slowCall fun args) applies fun to args, returning the results to Sequel
+slowCall fun stg_args
+  = do  dflags <- getDynFlags
+        argsreps <- getArgRepsAmodes stg_args
+        let (rts_fun, arity) = slowCallPattern (map fst argsreps)
+
+        (r, slow_code) <- getCodeR $ do
+           r <- direct_call "slow_call" NativeNodeCall
+                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
+           emitComment $ mkFastString ("slow_call for " ++
+                                      showSDoc dflags (ppr fun) ++
+                                      " with pat " ++ unpackFS rts_fun)
+           return r
+
+        -- Note [avoid intermediate PAPs]
+        let n_args = length stg_args
+        if n_args > arity && optLevel dflags >= 2
+           then do
+             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
+             fun_iptr <- (CmmReg . CmmLocal) `fmap`
+                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))
+
+             -- ToDo: we could do slightly better here by reusing the
+             -- continuation from the slow call, which we have in r.
+             -- Also we'd like to push the continuation on the stack
+             -- before the branch, so that we only get one copy of the
+             -- code that saves all the live variables across the
+             -- call, but that might need some improvements to the
+             -- special case in the stack layout code to handle this
+             -- (see Note [diamond proc point]).
+
+             fast_code <- getCode $
+                emitCall (NativeNodeCall, NativeReturn)
+                  (entryCode dflags fun_iptr)
+                  (nonVArgs ((P,Just funv):argsreps))
+
+             slow_lbl <- newBlockId
+             fast_lbl <- newBlockId
+             is_tagged_lbl <- newBlockId
+             end_lbl <- newBlockId
+
+             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
+                                                  (mkIntExpr dflags n_args)
+
+             tscope <- getTickScope
+             emit (mkCbranch (cmmIsTagged dflags funv)
+                             is_tagged_lbl slow_lbl (Just True)
+                   <*> mkLabel is_tagged_lbl tscope
+                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
+                   <*> mkLabel fast_lbl tscope
+                   <*> fast_code
+                   <*> mkBranch end_lbl
+                   <*> mkLabel slow_lbl tscope
+                   <*> slow_code
+                   <*> mkLabel end_lbl tscope)
+             return r
+
+           else do
+             emit slow_code
+             return r
+
+
+-- Note [avoid intermediate PAPs]
+--
+-- A slow call which needs multiple generic apply patterns will be
+-- almost guaranteed to create one or more intermediate PAPs when
+-- applied to a function that takes the correct number of arguments.
+-- We try to avoid this situation by generating code to test whether
+-- we are calling a function with the correct number of arguments
+-- first, i.e.:
+--
+--   if (TAG(f) != 0} {  // f is not a thunk
+--      if (f->info.arity == n) {
+--         ... make a fast call to f ...
+--      }
+--   }
+--   ... otherwise make the slow call ...
+--
+-- We *only* do this when the call requires multiple generic apply
+-- functions, which requires pushing extra stack frames and probably
+-- results in intermediate PAPs.  (I say probably, because it might be
+-- that we're over-applying a function, but that seems even less
+-- likely).
+--
+-- This very rarely applies, but if it does happen in an inner loop it
+-- can have a severe impact on performance (#6084).
+
+
+--------------
+direct_call :: String
+            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall
+            -> CLabel -> RepArity
+            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
+direct_call caller call_conv lbl arity args
+  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args
+  = do -- Caller should ensure that there enough args!
+       pprPanic "direct_call" $
+            text caller <+> ppr arity <+>
+            ppr lbl <+> ppr (length args) <+>
+            ppr (map snd args) <+> ppr (map fst args)
+
+  | null rest_args  -- Precisely the right number of arguments
+  = emitCall (call_conv, NativeReturn) target (nonVArgs args)
+
+  | otherwise       -- Note [over-saturated calls]
+  = do dflags <- getDynFlags
+       emitCallWithExtraStack (call_conv, NativeReturn)
+                              target
+                              (nonVArgs fast_args)
+                              (nonVArgs (stack_args dflags))
+  where
+    target = CmmLit (CmmLabel lbl)
+    (fast_args, rest_args) = splitAt real_arity args
+    stack_args dflags = slowArgs dflags rest_args
+    real_arity = case call_conv of
+                   NativeNodeCall -> arity+1
+                   _              -> arity
+
+
+-- When constructing calls, it is easier to keep the ArgReps and the
+-- CmmExprs zipped together.  However, a void argument has no
+-- representation, so we need to use Maybe CmmExpr (the alternative of
+-- using zeroCLit or even undefined would work, but would be ugly).
+--
+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
+getArgRepsAmodes = mapM getArgRepAmode
+  where getArgRepAmode arg
+           | V <- rep  = return (V, Nothing)
+           | otherwise = do expr <- getArgAmode (NonVoid arg)
+                            return (rep, Just expr)
+           where rep = toArgRep (argPrimRep arg)
+
+nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
+nonVArgs [] = []
+nonVArgs ((_,Nothing)  : args) = nonVArgs args
+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
+
+{-
+Note [over-saturated calls]
+
+The natural thing to do for an over-saturated call would be to call
+the function with the correct number of arguments, and then apply the
+remaining arguments to the value returned, e.g.
+
+  f a b c d   (where f has arity 2)
+  -->
+  r = call f(a,b)
+  call r(c,d)
+
+but this entails
+  - saving c and d on the stack
+  - making a continuation info table
+  - at the continuation, loading c and d off the stack into regs
+  - finally, call r
+
+Note that since there are a fixed number of different r's
+(e.g.  stg_ap_pp_fast), we can also pre-compile continuations
+that correspond to each of them, rather than generating a fresh
+one for each over-saturated call.
+
+Not only does this generate much less code, it is faster too.  We will
+generate something like:
+
+Sp[old+16] = c
+Sp[old+24] = d
+Sp[old+32] = stg_ap_pp_info
+call f(a,b) -- usual calling convention
+
+For the purposes of the CmmCall node, we count this extra stack as
+just more arguments that we are passing on the stack (cml_args).
+-}
+
+-- | 'slowArgs' takes a list of function arguments and prepares them for
+-- pushing on the stack for "extra" arguments to a function which requires
+-- fewer arguments than we currently have.
+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
+slowArgs _ [] = []
+slowArgs dflags args -- careful: reps contains voids (V), but args does not
+  | gopt Opt_SccProfilingOn dflags
+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args
+  | otherwise =              this_pat ++ slowArgs dflags rest_args
+  where
+    (arg_pat, n)            = slowCallPattern (map fst args)
+    (call_args, rest_args)  = splitAt n args
+
+    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
+    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
+    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
+
+-------------------------------------------------------------------------
+----        Laying out objects on the heap and stack
+-------------------------------------------------------------------------
+
+-- The heap always grows upwards, so hpRel is easy to compute
+hpRel :: VirtualHpOffset         -- virtual offset of Hp
+      -> VirtualHpOffset         -- virtual offset of The Thing
+      -> WordOff                -- integer word offset
+hpRel hp off = off - hp
+
+getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
+-- See Note [Virtual and real heap pointers] in StgCmmMonad
+getHpRelOffset virtual_offset
+  = do dflags <- getDynFlags
+       hp_usg <- getHpUsage
+       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
+
+data FieldOffOrPadding a
+    = FieldOff (NonVoid a) -- Something that needs an offset.
+               ByteOff     -- Offset in bytes.
+    | Padding ByteOff  -- Length of padding in bytes.
+              ByteOff  -- Offset in bytes.
+
+-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
+-- of header the object has.  This will be accounted for in the
+-- offsets of the fields returned.
+data ClosureHeader
+  = NoHeader
+  | StdHeader
+  | ThunkHeader
+
+mkVirtHeapOffsetsWithPadding
+  :: DynFlags
+  -> ClosureHeader            -- What kind of header to account for
+  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
+  -> ( WordOff                -- Total number of words allocated
+     , WordOff                -- Number of words allocated for *pointers*
+     , [FieldOffOrPadding a]  -- Either an offset or padding.
+     )
+
+-- Things with their offsets from start of object in order of
+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
+-- First in list gets lowest offset, which is initial offset + 1.
+--
+-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
+-- than the unboxed things
+
+mkVirtHeapOffsetsWithPadding dflags header things =
+    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
+    ( tot_wds
+    , bytesToWordsRoundUp dflags bytes_of_ptrs
+    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
+    )
+  where
+    hdr_words = case header of
+      NoHeader -> 0
+      StdHeader -> fixedHdrSizeW dflags
+      ThunkHeader -> thunkHdrSize dflags
+    hdr_bytes = wordsToBytes dflags hdr_words
+
+    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
+
+    (bytes_of_ptrs, ptrs_w_offsets) =
+       mapAccumL computeOffset 0 ptrs
+    (tot_bytes, non_ptrs_w_offsets) =
+       mapAccumL computeOffset bytes_of_ptrs non_ptrs
+
+    tot_wds = bytesToWordsRoundUp dflags tot_bytes
+
+    final_pad_size = tot_wds * word_size - tot_bytes
+    final_pad
+        | final_pad_size > 0 = [(Padding final_pad_size
+                                         (hdr_bytes + tot_bytes))]
+        | otherwise          = []
+
+    word_size = wORD_SIZE dflags
+
+    computeOffset bytes_so_far nv_thing =
+        (new_bytes_so_far, with_padding field_off)
+      where
+        (rep, thing) = fromNonVoid nv_thing
+
+        -- Size of the field in bytes.
+        !sizeB = primRepSizeB dflags rep
+
+        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
+        -- But not more than to a word.
+        !align = min word_size sizeB
+        !start = roundUpTo bytes_so_far align
+        !padding = start - bytes_so_far
+
+        -- Final offset is:
+        --   size of header + bytes_so_far + padding
+        !final_offset = hdr_bytes + bytes_so_far + padding
+        !new_bytes_so_far = start + sizeB
+        field_off = FieldOff (NonVoid thing) final_offset
+
+        with_padding field_off
+            | padding == 0 = [field_off]
+            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)
+                             , field_off
+                             ]
+
+
+mkVirtHeapOffsets
+  :: DynFlags
+  -> ClosureHeader            -- What kind of header to account for
+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
+  -> (WordOff,                -- _Total_ number of words allocated
+      WordOff,                -- Number of words allocated for *pointers*
+      [(NonVoid a, ByteOff)])
+mkVirtHeapOffsets dflags header things =
+    ( tot_wds
+    , ptr_wds
+    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
+    )
+  where
+   (tot_wds, ptr_wds, things_offsets) =
+       mkVirtHeapOffsetsWithPadding dflags header things
+
+-- | Just like mkVirtHeapOffsets, but for constructors
+mkVirtConstrOffsets
+  :: DynFlags -> [NonVoid (PrimRep, a)]
+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader
+
+-- | Just like mkVirtConstrOffsets, but used when we don't have the actual
+-- arguments. Useful when e.g. generating info tables; we just need to know
+-- sizes of pointer and non-pointer fields.
+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)
+mkVirtConstrSizes dflags field_reps
+  = (tot_wds, ptr_wds)
+  where
+    (tot_wds, ptr_wds, _) =
+       mkVirtConstrOffsets dflags
+         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)
+
+-------------------------------------------------------------------------
+--
+--        Making argument descriptors
+--
+--  An argument descriptor describes the layout of args on the stack,
+--  both for         * GC (stack-layout) purposes, and
+--                * saving/restoring registers when a heap-check fails
+--
+-- Void arguments aren't important, therefore (contrast constructSlowCall)
+--
+-------------------------------------------------------------------------
+
+-- bring in ARG_P, ARG_N, etc.
+#include "../includes/rts/storage/FunTypes.h"
+
+mkArgDescr :: DynFlags -> [Id] -> ArgDescr
+mkArgDescr dflags args
+  = let arg_bits = argBits dflags arg_reps
+        arg_reps = filter isNonV (map idArgRep args)
+           -- Getting rid of voids eases matching of standard patterns
+    in case stdPattern arg_reps of
+         Just spec_id -> ArgSpec spec_id
+         Nothing      -> ArgGen  arg_bits
+
+argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
+argBits _      []           = []
+argBits dflags (P   : args) = False : argBits dflags args
+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
+                    ++ argBits dflags args
+
+----------------------
+stdPattern :: [ArgRep] -> Maybe Int
+stdPattern reps
+  = case reps of
+        []    -> Just ARG_NONE        -- just void args, probably
+        [N]   -> Just ARG_N
+        [P]   -> Just ARG_P
+        [F]   -> Just ARG_F
+        [D]   -> Just ARG_D
+        [L]   -> Just ARG_L
+        [V16] -> Just ARG_V16
+        [V32] -> Just ARG_V32
+        [V64] -> Just ARG_V64
+
+        [N,N] -> Just ARG_NN
+        [N,P] -> Just ARG_NP
+        [P,N] -> Just ARG_PN
+        [P,P] -> Just ARG_PP
+
+        [N,N,N] -> Just ARG_NNN
+        [N,N,P] -> Just ARG_NNP
+        [N,P,N] -> Just ARG_NPN
+        [N,P,P] -> Just ARG_NPP
+        [P,N,N] -> Just ARG_PNN
+        [P,N,P] -> Just ARG_PNP
+        [P,P,N] -> Just ARG_PPN
+        [P,P,P] -> Just ARG_PPP
+
+        [P,P,P,P]     -> Just ARG_PPPP
+        [P,P,P,P,P]   -> Just ARG_PPPPP
+        [P,P,P,P,P,P] -> Just ARG_PPPPPP
+
+        _ -> Nothing
+
+-------------------------------------------------------------------------
+--
+--        Generating the info table and code for a closure
+--
+-------------------------------------------------------------------------
+
+-- Here we make an info table of type 'CmmInfo'.  The concrete
+-- representation as a list of 'CmmAddr' is handled later
+-- in the pipeline by 'cmmToRawCmm'.
+-- When loading the free variables, a function closure pointer may be tagged,
+-- so we must take it into account.
+
+emitClosureProcAndInfoTable :: Bool                    -- top-level?
+                            -> Id                      -- name of the closure
+                            -> LambdaFormInfo
+                            -> CmmInfoTable
+                            -> [NonVoid Id]            -- incoming arguments
+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
+                            -> FCode ()
+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
+ = do   { dflags <- getDynFlags
+        -- Bind the binder itself, but only if it's not a top-level
+        -- binding. We need non-top let-bindings to refer to the
+        -- top-level binding, which this binding would incorrectly shadow.
+        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)
+                  else bindToReg (NonVoid bndr) lf_info
+        ; let node_points = nodeMustPointToIt dflags lf_info
+        ; arg_regs <- bindArgsToRegs args
+        ; let args' = if node_points then (node : arg_regs) else arg_regs
+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall
+                                                          else NativeDirectCall
+              (offset, _, _) = mkCallEntry dflags conv args' []
+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
+        }
+
+-- Data constructors need closures, but not with all the argument handling
+-- needed for functions. The shared part goes here.
+emitClosureAndInfoTable ::
+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable info_tbl conv args body
+  = do { (_, blks) <- getCodeScoped body
+       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
+       }
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -0,0 +1,862 @@
+{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Monad for Stg to C-- code generation
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmMonad (
+        FCode,        -- type
+
+        initC, runC, fixC,
+        newUnique,
+
+        emitLabel,
+
+        emit, emitDecl,
+        emitProcWithConvention, emitProcWithStackFrame,
+        emitOutOfLine, emitAssign, emitStore,
+        emitComment, emitTick, emitUnwind,
+
+        getCmm, aGraphToGraph,
+        getCodeR, getCode, getCodeScoped, getHeapUsage,
+
+        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
+        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',
+
+        mkCall, mkCmmCall,
+
+        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
+
+        ConTagZ,
+
+        Sequel(..), ReturnKind(..),
+        withSequel, getSequel,
+
+        setTickyCtrLabel, getTickyCtrLabel,
+        tickScope, getTickScope,
+
+        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
+
+        HeapUsage(..), VirtualHpOffset,        initHpUsage,
+        getHpUsage,  setHpUsage, heapHWM,
+        setVirtHp, getVirtHp, setRealHp,
+
+        getModuleName,
+
+        -- ideally we wouldn't export these, but some other modules access internal state
+        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,
+
+        -- more localised access to monad state
+        CgIdInfo(..),
+        getBinds, setBinds,
+
+        -- out of general friendliness, we also export ...
+        CgInfoDownwards(..), CgState(..)        -- non-abstract
+    ) where
+
+import GhcPrelude hiding( sequence, succ )
+
+import Cmm
+import StgCmmClosure
+import DynFlags
+import Hoopl.Collections
+import MkGraph
+import BlockId
+import CLabel
+import SMRep
+import Module
+import Id
+import VarEnv
+import OrdList
+import BasicTypes( ConTagZ )
+import Unique
+import UniqSupply
+import FastString
+import Outputable
+import Util
+
+import Control.Monad
+import Data.List
+
+
+
+--------------------------------------------------------
+-- The FCode monad and its types
+--
+-- FCode is the monad plumbed through the Stg->Cmm code generator, and
+-- the Cmm parser.  It contains the following things:
+--
+--  - A writer monad, collecting:
+--    - code for the current function, in the form of a CmmAGraph.
+--      The function "emit" appends more code to this.
+--    - the top-level CmmDecls accumulated so far
+--
+--  - A state monad with:
+--    - the local bindings in scope
+--    - the current heap usage
+--    - a UniqSupply
+--
+--  - A reader monad, for CgInfoDownwards, containing
+--    - DynFlags,
+--    - the current Module
+--    - the update-frame offset
+--    - the ticky counter label
+--    - the Sequel (the continuation to return to)
+--    - the self-recursive tail call information
+
+--------------------------------------------------------
+
+newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
+
+instance Functor FCode where
+    fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')
+
+instance Applicative FCode where
+    pure val = FCode (\_info_down state -> (val, state))
+    {-# INLINE pure #-}
+    (<*>) = ap
+
+instance Monad FCode where
+    FCode m >>= k = FCode $
+        \info_down state ->
+            case m info_down state of
+              (m_result, new_state) ->
+                 case k m_result of
+                   FCode kcode -> kcode info_down new_state
+    {-# INLINE (>>=) #-}
+
+instance MonadUnique FCode where
+  getUniqueSupplyM = cgs_uniqs <$> getState
+  getUniqueM = FCode $ \_ st ->
+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)
+    in (u, st { cgs_uniqs = us' })
+
+initC :: IO CgState
+initC  = do { uniqs <- mkSplitUniqSupply 'c'
+            ; return (initCgState uniqs) }
+
+runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
+
+fixC :: (a -> FCode a) -> FCode a
+fixC fcode = FCode $
+    \info_down state -> let (v, s) = doFCode (fcode v) info_down state
+                        in (v, s)
+
+--------------------------------------------------------
+--        The code generator environment
+--------------------------------------------------------
+
+-- This monadery has some information that it only passes
+-- *downwards*, as well as some ``state'' which is modified
+-- as we go along.
+
+data CgInfoDownwards        -- information only passed *downwards* by the monad
+  = MkCgInfoDown {
+        cgd_dflags    :: DynFlags,
+        cgd_mod       :: Module,            -- Module being compiled
+        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame
+        cgd_ticky     :: CLabel,            -- Current destination for ticky counts
+        cgd_sequel    :: Sequel,            -- What to do at end of basic block
+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled
+                                            -- as local jumps? See Note
+                                            -- [Self-recursive tail calls] in
+                                            -- StgCmmExpr
+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks
+  }
+
+type CgBindings = IdEnv CgIdInfo
+
+data CgIdInfo
+  = CgIdInfo
+        { cg_id :: Id   -- Id that this is the info for
+        , cg_lf  :: LambdaFormInfo
+        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value
+        }
+
+instance Outputable CgIdInfo where
+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
+    = ppr id <+> text "-->" <+> ppr loc
+
+-- Sequel tells what to do with the result of this expression
+data Sequel
+  = Return              -- Return result(s) to continuation found on the stack.
+
+  | AssignTo
+        [LocalReg]      -- Put result(s) in these regs and fall through
+                        -- NB: no void arguments here
+                        --
+        Bool            -- Should we adjust the heap pointer back to
+                        -- recover space that's unused on this path?
+                        -- We need to do this only if the expression
+                        -- may allocate (e.g. it's a foreign call or
+                        -- allocating primOp)
+
+instance Outputable Sequel where
+    ppr Return = text "Return"
+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b
+
+-- See Note [sharing continuations] below
+data ReturnKind
+  = AssignedDirectly
+  | ReturnedTo BlockId ByteOff
+
+-- Note [sharing continuations]
+--
+-- ReturnKind says how the expression being compiled returned its
+-- results: either by assigning directly to the registers specified
+-- by the Sequel, or by returning to a continuation that does the
+-- assignments.  The point of this is we might be able to re-use the
+-- continuation in a subsequent heap-check.  Consider:
+--
+--    case f x of z
+--      True  -> <True code>
+--      False -> <False code>
+--
+-- Naively we would generate
+--
+--    R2 = x   -- argument to f
+--    Sp[young(L1)] = L1
+--    call f returns to L1
+--  L1:
+--    z = R1
+--    if (z & 1) then Ltrue else Lfalse
+--  Ltrue:
+--    Hp = Hp + 24
+--    if (Hp > HpLim) then L4 else L7
+--  L4:
+--    HpAlloc = 24
+--    goto L5
+--  L5:
+--    R1 = z
+--    Sp[young(L6)] = L6
+--    call stg_gc_unpt_r1 returns to L6
+--  L6:
+--    z = R1
+--    goto L1
+--  L7:
+--    <True code>
+--  Lfalse:
+--    <False code>
+--
+-- We want the gc call in L4 to return to L1, and discard L6.  Note
+-- that not only can we share L1 and L6, but the assignment of the
+-- return address in L4 is unnecessary because the return address for
+-- L1 is already on the stack.  We used to catch the sharing of L1 and
+-- L6 in the common-block-eliminator, but not the unnecessary return
+-- address assignment.
+--
+-- Since this case is so common I decided to make it more explicit and
+-- robust by programming the sharing directly, rather than relying on
+-- the common-block eliminator to catch it.  This makes
+-- common-block-elimination an optional optimisation, and furthermore
+-- generates less code in the first place that we have to subsequently
+-- clean up.
+--
+-- There are some rarer cases of common blocks that we don't catch
+-- this way, but that's ok.  Common-block-elimination is still available
+-- to catch them when optimisation is enabled.  Some examples are:
+--
+--   - when both the True and False branches do a heap check, we
+--     can share the heap-check failure code L4a and maybe L4
+--
+--   - in a case-of-case, there might be multiple continuations that
+--     we can common up.
+--
+-- It is always safe to use AssignedDirectly.  Expressions that jump
+-- to the continuation from multiple places (e.g. case expressions)
+-- fall back to AssignedDirectly.
+--
+
+
+initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
+initCgInfoDown dflags mod
+  = MkCgInfoDown { cgd_dflags    = dflags
+                 , cgd_mod       = mod
+                 , cgd_updfr_off = initUpdFrameOff dflags
+                 , cgd_ticky     = mkTopTickyCtrLabel
+                 , cgd_sequel    = initSequel
+                 , cgd_self_loop = Nothing
+                 , cgd_tick_scope= GlobalScope }
+
+initSequel :: Sequel
+initSequel = Return
+
+initUpdFrameOff :: DynFlags -> UpdFrameOffset
+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
+
+
+--------------------------------------------------------
+--        The code generator state
+--------------------------------------------------------
+
+data CgState
+  = MkCgState {
+     cgs_stmts :: CmmAGraph,          -- Current procedure
+
+     cgs_tops  :: OrdList CmmDecl,
+        -- Other procedures and data blocks in this compilation unit
+        -- Both are ordered only so that we can
+        -- reduce forward references, when it's easy to do so
+
+     cgs_binds :: CgBindings,
+
+     cgs_hp_usg  :: HeapUsage,
+
+     cgs_uniqs :: UniqSupply }
+
+data HeapUsage   -- See Note [Virtual and real heap pointers]
+  = HeapUsage {
+        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word
+                                         --   Incremented whenever we allocate
+        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr
+                                         --   Used in instruction addressing modes
+    }
+
+type VirtualHpOffset = WordOff
+
+
+{- Note [Virtual and real heap pointers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The code generator can allocate one or more objects contiguously, performing
+one heap check to cover allocation of all the objects at once.  Let's call
+this little chunk of heap space an "allocation chunk".  The code generator
+will emit code to
+  * Perform a heap-exhaustion check
+  * Move the heap pointer to the end of the allocation chunk
+  * Allocate multiple objects within the chunk
+
+The code generator uses VirtualHpOffsets to address words within a
+single allocation chunk; these start at one and increase positively.
+The first word of the chunk has VirtualHpOffset=1, the second has
+VirtualHpOffset=2, and so on.
+
+ * The field realHp tracks (the VirtualHpOffset) where the real Hp
+   register is pointing.  Typically it'll be pointing to the end of the
+   allocation chunk.
+
+ * The field virtHp gives the VirtualHpOffset of the highest-allocated
+   word so far.  It starts at zero (meaning no word has been allocated),
+   and increases whenever an object is allocated.
+
+The difference between realHp and virtHp gives the offset from the
+real Hp register of a particular word in the allocation chunk. This
+is what getHpRelOffset does.  Since the returned offset is relative
+to the real Hp register, it is valid only until you change the real
+Hp register.  (Changing virtHp doesn't matter.)
+-}
+
+
+initCgState :: UniqSupply -> CgState
+initCgState uniqs
+  = MkCgState { cgs_stmts  = mkNop
+              , cgs_tops   = nilOL
+              , cgs_binds  = emptyVarEnv
+              , cgs_hp_usg = initHpUsage
+              , cgs_uniqs  = uniqs }
+
+stateIncUsage :: CgState -> CgState -> CgState
+-- stateIncUsage@ e1 e2 incorporates in e1
+-- the heap high water mark found in e2.
+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
+     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
+       `addCodeBlocksFrom` s2
+
+addCodeBlocksFrom :: CgState -> CgState -> CgState
+-- Add code blocks from the latter to the former
+-- (The cgs_stmts will often be empty, but not always; see codeOnly)
+s1 `addCodeBlocksFrom` s2
+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,
+         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
+
+
+-- The heap high water mark is the larger of virtHp and hwHp.  The latter is
+-- only records the high water marks of forked-off branches, so to find the
+-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
+-- virtHp never retreats!
+--
+-- Note Jan 04: ok, so why do we only look at the virtual Hp??
+
+heapHWM :: HeapUsage -> VirtualHpOffset
+heapHWM = virtHp
+
+initHpUsage :: HeapUsage
+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
+
+maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
+
+--------------------------------------------------------
+-- Operators for getting and setting the state and "info_down".
+--------------------------------------------------------
+
+getState :: FCode CgState
+getState = FCode $ \_info_down state -> (state, state)
+
+setState :: CgState -> FCode ()
+setState state = FCode $ \_info_down _ -> ((), state)
+
+getHpUsage :: FCode HeapUsage
+getHpUsage = do
+        state <- getState
+        return $ cgs_hp_usg state
+
+setHpUsage :: HeapUsage -> FCode ()
+setHpUsage new_hp_usg = do
+        state <- getState
+        setState $ state {cgs_hp_usg = new_hp_usg}
+
+setVirtHp :: VirtualHpOffset -> FCode ()
+setVirtHp new_virtHp
+  = do  { hp_usage <- getHpUsage
+        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
+
+getVirtHp :: FCode VirtualHpOffset
+getVirtHp
+  = do  { hp_usage <- getHpUsage
+        ; return (virtHp hp_usage) }
+
+setRealHp ::  VirtualHpOffset -> FCode ()
+setRealHp new_realHp
+  = do  { hp_usage <- getHpUsage
+        ; setHpUsage (hp_usage {realHp = new_realHp}) }
+
+getBinds :: FCode CgBindings
+getBinds = do
+        state <- getState
+        return $ cgs_binds state
+
+setBinds :: CgBindings -> FCode ()
+setBinds new_binds = do
+        state <- getState
+        setState $ state {cgs_binds = new_binds}
+
+withState :: FCode a -> CgState -> FCode (a,CgState)
+withState (FCode fcode) newstate = FCode $ \info_down state ->
+  case fcode info_down newstate of
+    (retval, state2) -> ((retval,state2), state)
+
+newUniqSupply :: FCode UniqSupply
+newUniqSupply = do
+        state <- getState
+        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
+        setState $ state { cgs_uniqs = us1 }
+        return us2
+
+newUnique :: FCode Unique
+newUnique = do
+        state <- getState
+        let (u,us') = takeUniqFromSupply (cgs_uniqs state)
+        setState $ state { cgs_uniqs = us' }
+        return u
+
+------------------
+getInfoDown :: FCode CgInfoDownwards
+getInfoDown = FCode $ \info_down state -> (info_down,state)
+
+getSelfLoop :: FCode (Maybe SelfLoopInfo)
+getSelfLoop = do
+        info_down <- getInfoDown
+        return $ cgd_self_loop info_down
+
+withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
+withSelfLoop self_loop code = do
+        info_down <- getInfoDown
+        withInfoDown code (info_down {cgd_self_loop = Just self_loop})
+
+instance HasDynFlags FCode where
+    getDynFlags = liftM cgd_dflags getInfoDown
+
+getThisPackage :: FCode UnitId
+getThisPackage = liftM thisPackage getDynFlags
+
+withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
+
+-- ----------------------------------------------------------------------------
+-- Get the current module name
+
+getModuleName :: FCode Module
+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the end-of-block info
+
+withSequel :: Sequel -> FCode a -> FCode a
+withSequel sequel code
+  = do  { info  <- getInfoDown
+        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }
+
+getSequel :: FCode Sequel
+getSequel = do  { info <- getInfoDown
+                ; return (cgd_sequel info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the size of the update frame
+
+-- We keep track of the size of the update frame so that we
+-- can set the stack pointer to the proper address on return
+-- (or tail call) from the closure.
+-- There should be at most one update frame for each closure.
+-- Note: I'm including the size of the original return address
+-- in the size of the update frame -- hence the default case on `get'.
+
+withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
+withUpdFrameOff size code
+  = do  { info  <- getInfoDown
+        ; withInfoDown code (info {cgd_updfr_off = size }) }
+
+getUpdFrameOff :: FCode UpdFrameOffset
+getUpdFrameOff
+  = do  { info  <- getInfoDown
+        ; return $ cgd_updfr_off info }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the current ticky counter label
+
+getTickyCtrLabel :: FCode CLabel
+getTickyCtrLabel = do
+        info <- getInfoDown
+        return (cgd_ticky info)
+
+setTickyCtrLabel :: CLabel -> FCode a -> FCode a
+setTickyCtrLabel ticky code = do
+        info <- getInfoDown
+        withInfoDown code (info {cgd_ticky = ticky})
+
+-- ----------------------------------------------------------------------------
+-- Manage tick scopes
+
+-- | The current tick scope. We will assign this to generated blocks.
+getTickScope :: FCode CmmTickScope
+getTickScope = do
+        info <- getInfoDown
+        return (cgd_tick_scope info)
+
+-- | Places blocks generated by the given code into a fresh
+-- (sub-)scope. This will make sure that Cmm annotations in our scope
+-- will apply to the Cmm blocks generated therein - but not the other
+-- way around.
+tickScope :: FCode a -> FCode a
+tickScope code = do
+        info <- getInfoDown
+        if debugLevel (cgd_dflags info) == 0 then code else do
+          u <- newUnique
+          let scope' = SubScope u (cgd_tick_scope info)
+          withInfoDown code info{ cgd_tick_scope = scope' }
+
+
+--------------------------------------------------------
+--                 Forking
+--------------------------------------------------------
+
+forkClosureBody :: FCode () -> FCode ()
+-- forkClosureBody compiles body_code in environment where:
+--   - sequel, update stack frame and self loop info are
+--     set to fresh values
+--   - state is set to a fresh value, except for local bindings
+--     that are passed in unchanged. It's up to the enclosed code to
+--     re-bind the free variables to a field of the closure.
+
+forkClosureBody body_code
+  = do  { dflags <- getDynFlags
+        ; info   <- getInfoDown
+        ; us     <- newUniqSupply
+        ; state  <- getState
+        ; let body_info_down = info { cgd_sequel    = initSequel
+                                    , cgd_updfr_off = initUpdFrameOff dflags
+                                    , cgd_self_loop = Nothing }
+              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in
+        ; setState $ state `addCodeBlocksFrom` fork_state_out }
+
+forkLneBody :: FCode a -> FCode a
+-- 'forkLneBody' takes a body of let-no-escape binding and compiles
+-- it in the *current* environment, returning the graph thus constructed.
+--
+-- The current environment is passed on completely unchanged to
+-- the successor.  In particular, any heap usage from the enclosed
+-- code is discarded; it should deal with its own heap consumption.
+forkLneBody body_code
+  = do  { info_down <- getInfoDown
+        ; us        <- newUniqSupply
+        ; state     <- getState
+        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+              (result, fork_state_out) = doFCode body_code info_down fork_state_in
+        ; setState $ state `addCodeBlocksFrom` fork_state_out
+        ; return result }
+
+codeOnly :: FCode () -> FCode ()
+-- Emit any code from the inner thing into the outer thing
+-- Do not affect anything else in the outer state
+-- Used in almost-circular code to prevent false loop dependencies
+codeOnly body_code
+  = do  { info_down <- getInfoDown
+        ; us        <- newUniqSupply
+        ; state     <- getState
+        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state
+                                                 , cgs_hp_usg  = cgs_hp_usg state }
+                ((), fork_state_out) = doFCode body_code info_down fork_state_in
+        ; setState $ state `addCodeBlocksFrom` fork_state_out }
+
+forkAlts :: [FCode a] -> FCode [a]
+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
+-- an fcode for the default case 'd', and compiles each in the current
+-- environment.  The current environment is passed on unmodified, except
+-- that the virtual Hp is moved on to the worst virtual Hp for the branches
+
+forkAlts branch_fcodes
+  = do  { info_down <- getInfoDown
+        ; us <- newUniqSupply
+        ; state <- getState
+        ; let compile us branch
+                = (us2, doFCode branch info_down branch_state)
+                where
+                  (us1,us2) = splitUniqSupply us
+                  branch_state = (initCgState us1) {
+                                        cgs_binds  = cgs_binds state
+                                      , cgs_hp_usg = cgs_hp_usg state }
+              (_us, results) = mapAccumL compile us branch_fcodes
+              (branch_results, branch_out_states) = unzip results
+        ; setState $ foldl' stateIncUsage state branch_out_states
+                -- NB foldl.  state is the *left* argument to stateIncUsage
+        ; return branch_results }
+
+forkAltPair :: FCode a -> FCode a -> FCode (a,a)
+-- Most common use of 'forkAlts'; having this helper function avoids
+-- accidental use of failible pattern-matches in @do@-notation
+forkAltPair x y = do
+  xy' <- forkAlts [x,y]
+  case xy' of
+    [x',y'] -> return (x',y')
+    _ -> panic "forkAltPair"
+
+-- collect the code emitted by an FCode computation
+getCodeR :: FCode a -> FCode (a, CmmAGraph)
+getCodeR fcode
+  = do  { state1 <- getState
+        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
+        ; return (a, cgs_stmts state2) }
+
+getCode :: FCode a -> FCode CmmAGraph
+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
+
+-- | Generate code into a fresh tick (sub-)scope and gather generated code
+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
+getCodeScoped fcode
+  = do  { state1 <- getState
+        ; ((a, tscope), state2) <-
+            tickScope $
+            flip withState state1 { cgs_stmts = mkNop } $
+            do { a   <- fcode
+               ; scp <- getTickScope
+               ; return (a, scp) }
+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
+        ; return (a, (cgs_stmts state2, tscope)) }
+
+
+-- 'getHeapUsage' applies a function to the amount of heap that it uses.
+-- It initialises the heap usage to zeros, and passes on an unchanged
+-- heap usage.
+--
+-- It is usually a prelude to performing a GC check, so everything must
+-- be in a tidy and consistent state.
+--
+-- Note the slightly subtle fixed point behaviour needed here
+
+getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
+getHeapUsage fcode
+  = do  { info_down <- getInfoDown
+        ; state <- getState
+        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
+                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
+                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!
+
+        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
+        ; return r }
+
+-- ----------------------------------------------------------------------------
+-- Combinators for emitting code
+
+emitCgStmt :: CgStmt -> FCode ()
+emitCgStmt stmt
+  = do  { state <- getState
+        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+        }
+
+emitLabel :: BlockId -> FCode ()
+emitLabel id = do tscope <- getTickScope
+                  emitCgStmt (CgLabel id tscope)
+
+emitComment :: FastString -> FCode ()
+emitComment s
+  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))
+  | otherwise = return ()
+
+emitTick :: CmmTickish -> FCode ()
+emitTick = emitCgStmt . CgStmt . CmmTick
+
+emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
+emitUnwind regs = do
+  dflags <- getDynFlags
+  when (debugLevel dflags > 0) $ do
+     emitCgStmt $ CgStmt $ CmmUnwind regs
+
+emitAssign :: CmmReg  -> CmmExpr -> FCode ()
+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
+
+emitStore :: CmmExpr  -> CmmExpr -> FCode ()
+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
+
+emit :: CmmAGraph -> FCode ()
+emit ag
+  = do  { state <- getState
+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }
+
+emitDecl :: CmmDecl -> FCode ()
+emitDecl decl
+  = do  { state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
+
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
+
+emitProcWithStackFrame
+   :: Convention                        -- entry convention
+   -> Maybe CmmInfoTable                -- info table?
+   -> CLabel                            -- label for the proc
+   -> [CmmFormal]                       -- stack frame
+   -> [CmmFormal]                       -- arguments
+   -> CmmAGraphScoped                   -- code
+   -> Bool                              -- do stack layout?
+   -> FCode ()
+
+emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
+  = do  { dflags <- getDynFlags
+        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
+        }
+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
+        -- do layout
+  = do  { dflags <- getDynFlags
+        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
+              graph' = entry MkGraph.<*> graph
+        ; emitProc mb_info lbl live (graph', tscope) offset True
+        }
+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
+
+emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
+                       -> [CmmFormal]
+                       -> CmmAGraphScoped
+                       -> FCode ()
+emitProcWithConvention conv mb_info lbl args blocks
+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True
+
+emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+         -> Int -> Bool -> FCode ()
+emitProc mb_info lbl live blocks offset do_layout
+  = do  { dflags <- getDynFlags
+        ; l <- newBlockId
+        ; let
+              blks :: CmmGraph
+              blks = labelAGraph l blocks
+
+              infos | Just info <- mb_info = mapSingleton (g_entry blks) info
+                    | otherwise            = mapEmpty
+
+              sinfo = StackInfo { arg_space = offset
+                                , updfr_space = Just (initUpdFrameOff dflags)
+                                , do_layout = do_layout }
+
+              tinfo = TopInfo { info_tbls = infos
+                              , stack_info=sinfo}
+
+              proc_block = CmmProc tinfo lbl live blks
+
+        ; state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+
+getCmm :: FCode () -> FCode CmmGroup
+-- Get all the CmmTops (there should be no stmts)
+-- Return a single Cmm which may be split from other Cmms by
+-- object splitting (at a later stage)
+getCmm code
+  = do  { state1 <- getState
+        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
+        ; setState $ state2 { cgs_tops = cgs_tops state1 }
+        ; return (fromOL (cgs_tops state2)) }
+
+
+mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing
+
+mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
+                 -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfThenElse' e tbranch fbranch likely = do
+  tscp  <- getTickScope
+  endif <- newBlockId
+  tid   <- newBlockId
+  fid   <- newBlockId
+
+  let
+    (test, then_, else_, likely') = case likely of
+      Just False | Just e' <- maybeInvertCmmExpr e
+        -- currently NCG doesn't know about likely
+        -- annotations. We manually switch then and
+        -- else branch so the likely false branch
+        -- becomes a fallthrough.
+        -> (e', fbranch, tbranch, Just True)
+      _ -> (e, tbranch, fbranch, likely)
+
+  return $ catAGraphs [ mkCbranch test tid fid likely'
+                      , mkLabel tid tscp, then_, mkBranch endif
+                      , mkLabel fid tscp, else_, mkLabel endif tscp ]
+
+mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing
+
+mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfGoto' e tid l = do
+  endif <- newBlockId
+  tscp  <- getTickScope
+  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]
+
+mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing
+
+mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfThen' e tbranch l = do
+  endif <- newBlockId
+  tid   <- newBlockId
+  tscp  <- getTickScope
+  return $ catAGraphs [ mkCbranch e tid endif l
+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
+
+mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
+       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
+  dflags <- getDynFlags
+  k      <- newBlockId
+  tscp   <- getTickScope
+  let area = Young k
+      (off, _, copyin) = copyInOflow dflags retConv area results []
+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]
+
+mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
+          -> FCode CmmAGraph
+mkCmmCall f results actuals updfr_off
+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
+
+
+-- ----------------------------------------------------------------------------
+-- turn CmmAGraph into CmmGraph, for making a new proc.
+
+aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
+aGraphToGraph stmts
+  = do  { l <- newBlockId
+        ; return (labelAGraph l stmts) }
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -0,0 +1,2590 @@
+{-# LANGUAGE CPP #-}
+-- emitPrimOp is quite large
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}
+
+----------------------------------------------------------------------------
+--
+-- Stg to C--: primitive operations
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmPrim (
+   cgOpApp,
+   cgPrimOp, -- internal(ish), used by cgCase to get code for a
+             -- comparison without also turning it into a Bool.
+   shouldInlinePrimOp
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmLayout
+import StgCmmForeign
+import StgCmmEnv
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmTicky
+import StgCmmHeap
+import StgCmmProf ( costCentreFrom )
+
+import DynFlags
+import Platform
+import BasicTypes
+import BlockId
+import MkGraph
+import StgSyn
+import Cmm
+import Type     ( Type, tyConAppTyCon )
+import TyCon
+import CLabel
+import CmmUtils
+import PrimOp
+import SMRep
+import FastString
+import Outputable
+import Util
+
+import Data.Bits ((.&.), bit)
+import Control.Monad (liftM, when, unless)
+
+------------------------------------------------------------------------
+--      Primitive operations and foreign calls
+------------------------------------------------------------------------
+
+{- Note [Foreign call results]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A foreign call always returns an unboxed tuple of results, one
+of which is the state token.  This seems to happen even for pure
+calls.
+
+Even if we returned a single result for pure calls, it'd still be
+right to wrap it in a singleton unboxed tuple, because the result
+might be a Haskell closure pointer, we don't want to evaluate it. -}
+
+----------------------------------
+cgOpApp :: StgOp        -- The op
+        -> [StgArg]     -- Arguments
+        -> Type         -- Result type (always an unboxed tuple)
+        -> FCode ReturnKind
+
+-- Foreign calls
+cgOpApp (StgFCallOp fcall _) stg_args res_ty
+  = cgForeignCall fcall stg_args res_ty
+      -- Note [Foreign call results]
+
+-- tagToEnum# is special: we need to pull the constructor
+-- out of the table, and perform an appropriate return.
+
+cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
+  = ASSERT(isEnumerationTyCon tycon)
+    do  { dflags <- getDynFlags
+        ; args' <- getNonVoidArgAmodes [arg]
+        ; let amode = case args' of [amode] -> amode
+                                    _ -> panic "TagToEnumOp had void arg"
+        ; emitReturn [tagToClosure dflags tycon amode] }
+   where
+          -- If you're reading this code in the attempt to figure
+          -- out why the compiler panic'ed here, it is probably because
+          -- you used tagToEnum# in a non-monomorphic setting, e.g.,
+          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
+          -- That won't work.
+        tycon = tyConAppTyCon res_ty
+
+cgOpApp (StgPrimOp primop) args res_ty = do
+    dflags <- getDynFlags
+    cmm_args <- getNonVoidArgAmodes args
+    case shouldInlinePrimOp dflags primop cmm_args of
+        Nothing -> do  -- out-of-line
+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args
+
+        Just f  -- inline
+          | ReturnsPrim VoidRep <- result_info
+          -> do f []
+                emitReturn []
+
+          | ReturnsPrim rep <- result_info
+          -> do dflags <- getDynFlags
+                res <- newTemp (primRepCmmType dflags rep)
+                f [res]
+                emitReturn [CmmReg (CmmLocal res)]
+
+          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
+                f regs
+                emitReturn (map (CmmReg . CmmLocal) regs)
+
+          | otherwise -> panic "cgPrimop"
+          where
+             result_info = getPrimOpResultInfo primop
+
+cgOpApp (StgPrimCallOp primcall) args _res_ty
+  = do  { cmm_args <- getNonVoidArgAmodes args
+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
+
+-- | Interpret the argument as an unsigned value, assuming the value
+-- is given in two-complement form in the given width.
+--
+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.
+--
+-- This function is used to work around the fact that many array
+-- primops take Int# arguments, but we interpret them as unsigned
+-- quantities in the code gen. This means that we have to be careful
+-- every time we work on e.g. a CmmInt literal that corresponds to the
+-- array size, as it might contain a negative Integer value if the
+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#
+-- literal.
+asUnsigned :: Width -> Integer -> Integer
+asUnsigned w n = n .&. (bit (widthInBits w) - 1)
+
+-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use
+--     ByteOff (or some other fixed width signed type) to represent
+--     array sizes or indices. This means that these will overflow for
+--     large enough sizes.
+
+-- | Decide whether an out-of-line primop should be replaced by an
+-- inline implementation. This might happen e.g. if there's enough
+-- static information, such as statically know arguments, to emit a
+-- more efficient implementation inline.
+--
+-- Returns 'Nothing' if this primop should use its out-of-line
+-- implementation (defined elsewhere) and 'Just' together with a code
+-- generating function that takes the output regs as arguments
+-- otherwise.
+shouldInlinePrimOp :: DynFlags
+                   -> PrimOp     -- ^ The primop
+                   -> [CmmExpr]  -- ^ The primop arguments
+                   -> Maybe ([LocalReg] -> FCode ())
+
+shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]
+  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)
+
+shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] ->
+      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
+      [ (mkIntExpr dflags (fromInteger n),
+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)
+      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),
+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)
+      ]
+      (fromInteger n) init
+
+shouldInlinePrimOp _ CopyArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopyMutableArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopyArrayArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopyMutableArrayArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] ->
+      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
+      [ (mkIntExpr dflags (fromInteger n),
+         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
+      ]
+      (fromInteger n) init
+
+shouldInlinePrimOp _ CopySmallArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopySmallMutableArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags primop args
+  | primOpOutOfLine primop = Nothing
+  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args
+
+-- TODO: Several primops, such as 'copyArray#', only have an inline
+-- implementation (below) but could possibly have both an inline
+-- implementation and an out-of-line implementation, just like
+-- 'newArray#'. This would lower the amount of code generated,
+-- hopefully without a performance impact (needs to be measured).
+
+---------------------------------------------------
+cgPrimOp   :: [LocalReg]        -- where to put the results
+           -> PrimOp            -- the op
+           -> [StgArg]          -- arguments
+           -> FCode ()
+
+cgPrimOp results op args
+  = do dflags <- getDynFlags
+       arg_exprs <- getNonVoidArgAmodes args
+       emitPrimOp dflags results op arg_exprs
+
+
+------------------------------------------------------------------------
+--      Emitting code for a primop
+------------------------------------------------------------------------
+
+emitPrimOp :: DynFlags
+           -> [LocalReg]        -- where to put the results
+           -> PrimOp            -- the op
+           -> [CmmExpr]         -- arguments
+           -> FCode ()
+
+-- First we handle various awkward cases specially.  The remaining
+-- easy cases are then handled by translateOp, defined below.
+
+emitPrimOp _ [res] ParOp [arg]
+  =
+        -- for now, just implement this in a C function
+        -- later, we might want to inline it.
+    emitCCall
+        [(res,NoHint)]
+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
+        [(baseExpr, AddrHint), (arg,AddrHint)]
+
+emitPrimOp dflags [res] SparkOp [arg]
+  = do
+        -- returns the value of arg in res.  We're going to therefore
+        -- refer to arg twice (once to pass to newSpark(), and once to
+        -- assign to res), so put it in a temporary.
+        tmp <- assignTemp arg
+        tmp2 <- newTemp (bWord dflags)
+        emitCCall
+            [(tmp2,NoHint)]
+            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
+            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
+        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
+
+emitPrimOp dflags [res] GetCCSOfOp [arg]
+  = emitAssign (CmmLocal res) val
+  where
+    val
+     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
+     | otherwise                      = CmmLit (zeroCLit dflags)
+
+emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
+   = emitAssign (CmmLocal res) cccsExpr
+
+emitPrimOp _ [res] MyThreadIdOp []
+   = emitAssign (CmmLocal res) currentTSOExpr
+
+emitPrimOp dflags [res] ReadMutVarOp [mutv]
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
+
+emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]
+   = do -- Without this write barrier, other CPUs may see this pointer before
+        -- the writes for the closure it points to have occurred.
+        emitPrimCall res MO_WriteBarrier []
+        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
+        emitCCall
+                [{-no results-}]
+                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+                [(baseExpr, AddrHint), (mutv,AddrHint)]
+
+--  #define sizzeofByteArrayzh(r,a) \
+--     r = ((StgArrBytes *)(a))->bytes
+emitPrimOp dflags [res] SizeofByteArrayOp [arg]
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+
+--  #define sizzeofMutableByteArrayzh(r,a) \
+--      r = ((StgArrBytes *)(a))->bytes
+emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]
+
+--  #define getSizzeofMutableByteArrayzh(r,a) \
+--      r = ((StgArrBytes *)(a))->bytes
+emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+
+
+--  #define touchzh(o)                  /* nothing */
+emitPrimOp _ res@[] TouchOp args@[_arg]
+   = do emitPrimCall res MO_Touch args
+
+--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
+emitPrimOp dflags [res] ByteArrayContents_Char [arg]
+   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))
+
+--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
+emitPrimOp dflags [res] StableNameToIntOp [arg]
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+
+emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
+   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
+
+--  #define addrToHValuezh(r,a) r=(P_)a
+emitPrimOp _      [res] AddrToAnyOp [arg]
+   = emitAssign (CmmLocal res) arg
+
+--  #define hvalueToAddrzh(r, a) r=(W_)a
+emitPrimOp _      [res] AnyToAddrOp [arg]
+   = emitAssign (CmmLocal res) arg
+
+{- Freezing arrays-of-ptrs requires changing an info table, for the
+   benefit of the generational collector.  It needs to scavenge mutable
+   objects, even if they are in old space.  When they become immutable,
+   they can be removed from this scavenge list.  -}
+
+--  #define unsafeFreezzeArrayzh(r,a)
+--      {
+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);
+--        r = a;
+--      }
+emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
+emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
+emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
+
+--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
+emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]
+   = emitAssign (CmmLocal res) arg
+
+-- Reading/writing pointer arrays
+
+emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix
+emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v
+
+emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v
+emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v
+emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v
+emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v
+
+emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix
+emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v
+
+-- Getting the size of pointer arrays
+
+emitPrimOp dflags [res] SizeofArrayOp [arg]
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg
+    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))
+        (bWord dflags))
+emitPrimOp dflags [res] SizeofMutableArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofArrayOp [arg]
+emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofArrayOp [arg]
+emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofArrayOp [arg]
+
+emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =
+    emit $ mkAssign (CmmLocal res)
+    (cmmLoadIndexW dflags arg
+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))
+        (bWord dflags))
+emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =
+    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]
+
+-- IndexXXXoffAddr
+
+emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args
+emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args
+emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
+emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args
+
+-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
+
+emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args
+emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args
+emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
+emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args
+
+-- IndexXXXArray
+
+emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args
+emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args
+emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
+emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
+emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
+emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
+emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
+
+-- ReadXXXArray, identical to IndexXXXArray.
+
+emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args
+emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args
+emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
+emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
+emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
+emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
+emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
+
+-- IndexWord8ArrayAsXXX
+
+emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+
+-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX
+
+emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+
+-- WriteXXXoffAddr
+
+emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args
+emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args
+emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args
+emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args
+
+-- WriteXXXArray
+
+emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args
+emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args
+emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args
+emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args
+
+-- WriteInt8ArrayAsXXX
+
+emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args
+
+-- Copying and setting byte arrays
+emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =
+    doCopyByteArrayOp src src_off dst dst_off n
+emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =
+    doCopyMutableByteArrayOp src src_off dst dst_off n
+emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =
+    doCopyByteArrayToAddrOp src src_off dst n
+emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =
+    doCopyMutableByteArrayToAddrOp src src_off dst n
+emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =
+    doCopyAddrToByteArrayOp src dst dst_off n
+emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =
+    doSetByteArrayOp ba off len c
+
+-- Comparing byte arrays
+emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =
+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n
+
+emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16
+emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32
+emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64
+emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)
+
+emitPrimOp _      [res] BRev8Op  [w] = emitBRevCall res w W8
+emitPrimOp _      [res] BRev16Op [w] = emitBRevCall res w W16
+emitPrimOp _      [res] BRev32Op [w] = emitBRevCall res w W32
+emitPrimOp _      [res] BRev64Op [w] = emitBRevCall res w W64
+emitPrimOp dflags [res] BRevOp   [w] = emitBRevCall res w (wordWidth dflags)
+
+-- Population count
+emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8
+emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16
+emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32
+emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64
+emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)
+
+-- Parallel bit deposit
+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8
+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16
+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32
+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64
+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)
+
+-- Parallel bit extract
+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8
+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16
+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32
+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64
+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)
+
+-- count leading zeros
+emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8
+emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16
+emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32
+emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64
+emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)
+
+-- count trailing zeros
+emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8
+emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16
+emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32
+emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64
+emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)
+
+-- Unsigned int to floating point conversions
+emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]
+                                            (MO_UF_Conv W32) [w]
+emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]
+                                            (MO_UF_Conv W64) [w]
+
+-- SIMD primops
+emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do
+    checkVecCompatibility dflags vcat n w
+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res
+  where
+    zeros :: CmmExpr
+    zeros = CmmLit $ CmmVec (replicate n zero)
+
+    zero :: CmmLit
+    zero = case vcat of
+             IntVec   -> CmmInt 0 w
+             WordVec  -> CmmInt 0 w
+             FloatVec -> CmmFloat 0 w
+
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags [res] (VecPackOp vcat n w) es = do
+    checkVecCompatibility dflags vcat n w
+    when (es `lengthIsNot` n) $
+        panic "emitPrimOp: VecPackOp has wrong number of arguments"
+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res
+  where
+    zeros :: CmmExpr
+    zeros = CmmLit $ CmmVec (replicate n zero)
+
+    zero :: CmmLit
+    zero = case vcat of
+             IntVec   -> CmmInt 0 w
+             WordVec  -> CmmInt 0 w
+             FloatVec -> CmmFloat 0 w
+
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do
+    checkVecCompatibility dflags vcat n w
+    when (res `lengthIsNot` n) $
+        panic "emitPrimOp: VecUnpackOp has wrong number of results"
+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do
+    checkVecCompatibility dflags vcat n w
+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+-- Prefetch
+emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args
+emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args
+emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args
+
+emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args
+emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args
+emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args
+
+emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args
+emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args
+emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args
+
+emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args
+emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args
+emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args
+
+-- Atomic read-modify-write
+emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_And mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n
+emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =
+    doAtomicReadByteArray res mba ix (bWord dflags)
+emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =
+    doAtomicWriteByteArray mba ix (bWord dflags) val
+emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =
+    doCasByteArray res mba ix (bWord dflags) old new
+
+-- The rest just translate straightforwardly
+emitPrimOp dflags [res] op [arg]
+   | nopOp op
+   = emitAssign (CmmLocal res) arg
+
+   | Just (mop,rep) <- narrowOp op
+   = emitAssign (CmmLocal res) $
+           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
+
+emitPrimOp dflags r@[res] op args
+   | Just prim <- callishOp op
+   = do emitPrimCall r prim args
+
+   | Just mop <- translateOp dflags op
+   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
+     emit stmt
+
+emitPrimOp dflags results op args
+   = case callishPrimOpSupported dflags op of
+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args
+          Right gen -> gen results args
+
+type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
+
+callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
+callishPrimOpSupported dflags op
+  = case op of
+      IntQuotRemOp   | ncg && (x86ish || ppc) ->
+                         Left (MO_S_QuotRem  (wordWidth dflags))
+                     | otherwise              ->
+                         Right (genericIntQuotRemOp (wordWidth dflags))
+
+      Int8QuotRemOp  | ncg && (x86ish || ppc)
+                                     -> Left (MO_S_QuotRem W8)
+                     | otherwise     -> Right (genericIntQuotRemOp W8)
+
+      Int16QuotRemOp | ncg && (x86ish || ppc)
+                                     -> Left (MO_S_QuotRem W16)
+                     | otherwise     -> Right (genericIntQuotRemOp W16)
+
+
+      WordQuotRemOp  | ncg && (x86ish || ppc) ->
+                         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)
+                                      -> Left (MO_U_QuotRem W8)
+                     | otherwise      -> Right (genericWordQuotRemOp W8)
+
+      Word16QuotRemOp| ncg && (x86ish || ppc)
+                                     -> Left (MO_U_QuotRem W16)
+                     | otherwise     -> Right (genericWordQuotRemOp W16)
+
+      WordAdd2Op     | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_Add2       (wordWidth dflags))
+                     | otherwise      -> Right genericWordAdd2Op
+
+      WordAddCOp     | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))
+                     | otherwise      -> Right genericWordAddCOp
+
+      WordSubCOp     | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))
+                     | otherwise      -> Right genericWordSubCOp
+
+      IntAddCOp      | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))
+                     | otherwise      -> Right genericIntAddCOp
+
+      IntSubCOp      | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))
+                     | otherwise      -> Right genericIntSubCOp
+
+      WordMul2Op     | ncg && (x86ish || ppc)
+                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))
+                     | otherwise      -> Right genericWordMul2Op
+      FloatFabsOp    | (ncg && x86ish || ppc)
+                         || llvm      -> Left MO_F32_Fabs
+                     | otherwise      -> Right $ genericFabsOp W32
+      DoubleFabsOp   | (ncg && x86ish || ppc)
+                         || llvm      -> Left MO_F64_Fabs
+                     | otherwise      -> Right $ genericFabsOp W64
+
+      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)
+ where
+  ncg = case hscTarget dflags of
+           HscAsm -> True
+           _      -> False
+  llvm = case hscTarget dflags of
+           HscLlvm -> True
+           _       -> False
+  x86ish = case platformArch (targetPlatform dflags) of
+             ArchX86    -> True
+             ArchX86_64 -> True
+             _          -> False
+  ppc = case platformArch (targetPlatform dflags) of
+          ArchPPC      -> True
+          ArchPPC_64 _ -> True
+          _            -> False
+
+genericIntQuotRemOp :: Width -> GenericOp
+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]
+   = emit $ mkAssign (CmmLocal res_q)
+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>
+            mkAssign (CmmLocal res_r)
+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])
+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
+
+genericWordQuotRemOp :: Width -> GenericOp
+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
+    = emit $ mkAssign (CmmLocal res_q)
+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>
+             mkAssign (CmmLocal res_r)
+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])
+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
+
+genericWordQuotRem2Op :: DynFlags -> GenericOp
+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
+    where    ty = cmmExprType dflags arg_x_high
+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]
+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]
+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]
+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]
+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]
+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]
+             zero   = lit 0
+             one    = lit 1
+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
+             lit i = CmmLit (CmmInt i (wordWidth dflags))
+
+             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
+                                      mkAssign (CmmLocal res_r) high)
+             f i acc high low =
+                 do roverflowedBit <- newTemp ty
+                    rhigh'         <- newTemp ty
+                    rhigh''        <- newTemp ty
+                    rlow'          <- newTemp ty
+                    risge          <- newTemp ty
+                    racc'          <- newTemp ty
+                    let high'         = CmmReg (CmmLocal rhigh')
+                        isge          = CmmReg (CmmLocal risge)
+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
+                    let this = catAGraphs
+                               [mkAssign (CmmLocal roverflowedBit)
+                                          (shr high negone),
+                                mkAssign (CmmLocal rhigh')
+                                          (or (shl high one) (shr low negone)),
+                                mkAssign (CmmLocal rlow')
+                                          (shl low one),
+                                mkAssign (CmmLocal risge)
+                                          (or (overflowedBit `ne` zero)
+                                              (high' `ge` arg_y)),
+                                mkAssign (CmmLocal rhigh'')
+                                          (high' `minus` (arg_y `times` isge)),
+                                mkAssign (CmmLocal racc')
+                                          (or (shl acc one) isge)]
+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
+                                      (CmmReg (CmmLocal rhigh''))
+                                      (CmmReg (CmmLocal rlow'))
+                    return (this <*> rest)
+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"
+
+genericWordAdd2Op :: GenericOp
+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
+  = do dflags <- getDynFlags
+       r1 <- newTemp (cmmExprType dflags arg_x)
+       r2 <- newTemp (cmmExprType dflags arg_x)
+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
+                                (wordWidth dflags))
+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+       emit $ catAGraphs
+          [mkAssign (CmmLocal r1)
+               (add (bottomHalf arg_x) (bottomHalf arg_y)),
+           mkAssign (CmmLocal r2)
+               (add (topHalf (CmmReg (CmmLocal r1)))
+                    (add (topHalf arg_x) (topHalf arg_y))),
+           mkAssign (CmmLocal res_h)
+               (topHalf (CmmReg (CmmLocal r2))),
+           mkAssign (CmmLocal res_l)
+               (or (toTopHalf (CmmReg (CmmLocal r2)))
+                   (bottomHalf (CmmReg (CmmLocal r1))))]
+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
+
+-- | Implements branchless recovery of the carry flag @c@ by checking the
+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:
+--
+-- @
+--    c = a&b | (a|b)&~r
+-- @
+--
+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
+genericWordAddCOp :: GenericOp
+genericWordAddCOp [res_r, res_c] [aa, bb]
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+            CmmMachOp (mo_wordOr dflags) [
+              CmmMachOp (mo_wordAnd dflags) [aa,bb],
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordOr dflags) [aa,bb],
+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]
+              ]
+            ],
+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericWordAddCOp _ _ = panic "genericWordAddCOp"
+
+-- | Implements branchless recovery of the carry flag @c@ by checking the
+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:
+--
+-- @
+--    c = ~a&b | (~a|b)&r
+-- @
+--
+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
+genericWordSubCOp :: GenericOp
+genericWordSubCOp [res_r, res_c] [aa, bb]
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+            CmmMachOp (mo_wordOr dflags) [
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordNot dflags) [aa],
+                bb
+              ],
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordOr dflags) [
+                  CmmMachOp (mo_wordNot dflags) [aa],
+                  bb
+                ],
+                CmmReg (CmmLocal res_r)
+              ]
+            ],
+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericWordSubCOp _ _ = panic "genericWordSubCOp"
+
+genericIntAddCOp :: GenericOp
+genericIntAddCOp [res_r, res_c] [aa, bb]
+{-
+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in
+   C, and without needing any comparisons.  This may not be the
+   fastest way to do it - if you have better code, please send it! --SDM
+
+   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
+
+   We currently don't make use of the r value if c is != 0 (i.e.
+   overflow), we just convert to big integers and try again.  This
+   could be improved by making r and c the correct values for
+   plugging into a new J#.
+
+   { r = ((I_)(a)) + ((I_)(b));                                 \
+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
+         >> (BITS_IN (I_) - 1);                                 \
+   }
+   Wading through the mass of bracketry, it seems to reduce to:
+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
+
+-}
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+                CmmMachOp (mo_wordAnd dflags) [
+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
+                ],
+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericIntAddCOp _ _ = panic "genericIntAddCOp"
+
+genericIntSubCOp :: GenericOp
+genericIntSubCOp [res_r, res_c] [aa, bb]
+{- Similarly:
+   #define subIntCzh(r,c,a,b)                                   \
+   { r = ((I_)(a)) - ((I_)(b));                                 \
+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
+         >> (BITS_IN (I_) - 1);                                 \
+   }
+
+   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
+-}
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+                CmmMachOp (mo_wordAnd dflags) [
+                    CmmMachOp (mo_wordXor dflags) [aa,bb],
+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
+                ],
+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericIntSubCOp _ _ = panic "genericIntSubCOp"
+
+genericWordMul2Op :: GenericOp
+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
+ = do dflags <- getDynFlags
+      let t = cmmExprType dflags arg_x
+      xlyl <- liftM CmmLocal $ newTemp t
+      xlyh <- liftM CmmLocal $ newTemp t
+      xhyl <- liftM CmmLocal $ newTemp t
+      r    <- liftM CmmLocal $ newTemp t
+      -- This generic implementation is very simple and slow. We might
+      -- well be able to do better, but for now this at least works.
+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+          sum = foldl1 add
+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
+                               (wordWidth dflags))
+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+      emit $ catAGraphs
+             [mkAssign xlyl
+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),
+              mkAssign xlyh
+                  (mul (bottomHalf arg_x) (topHalf arg_y)),
+              mkAssign xhyl
+                  (mul (topHalf arg_x) (bottomHalf arg_y)),
+              mkAssign r
+                  (sum [topHalf    (CmmReg xlyl),
+                        bottomHalf (CmmReg xhyl),
+                        bottomHalf (CmmReg xlyh)]),
+              mkAssign (CmmLocal res_l)
+                  (or (bottomHalf (CmmReg xlyl))
+                      (toTopHalf (CmmReg r))),
+              mkAssign (CmmLocal res_h)
+                  (sum [mul (topHalf arg_x) (topHalf arg_y),
+                        topHalf (CmmReg xhyl),
+                        topHalf (CmmReg xlyh),
+                        topHalf (CmmReg r)])]
+genericWordMul2Op _ _ = panic "genericWordMul2Op"
+
+-- This replicates what we had in libraries/base/GHC/Float.hs:
+--
+--    abs x    | x == 0    = 0 -- handles (-0.0)
+--             | x >  0    = x
+--             | otherwise = negateFloat x
+genericFabsOp :: Width -> GenericOp
+genericFabsOp w [res_r] [aa]
+ = do dflags <- getDynFlags
+      let zero   = CmmLit (CmmFloat 0 w)
+
+          eq x y = CmmMachOp (MO_F_Eq w) [x, y]
+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]
+
+          neg x  = CmmMachOp (MO_F_Neg w) [x]
+
+          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]
+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]
+
+      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)
+      let g3 = catAGraphs [mkAssign res_t aa,
+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]
+
+      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3
+
+      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4
+
+genericFabsOp _ _ _ = panic "genericFabsOp"
+
+-- These PrimOps are NOPs in Cmm
+
+nopOp :: PrimOp -> Bool
+nopOp Int2WordOp     = True
+nopOp Word2IntOp     = True
+nopOp Int2AddrOp     = True
+nopOp Addr2IntOp     = True
+nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
+nopOp OrdOp          = True
+nopOp _              = False
+
+-- These PrimOps turn into double casts
+
+narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
+narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
+narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
+narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
+narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
+narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
+narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
+narrowOp _              = Nothing
+
+-- Native word signless ops
+
+translateOp :: DynFlags -> PrimOp -> Maybe MachOp
+translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)
+translateOp dflags IntSubOp       = Just (mo_wordSub dflags)
+translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)
+translateOp dflags WordSubOp      = Just (mo_wordSub dflags)
+translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)
+translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)
+
+translateOp dflags IntEqOp        = Just (mo_wordEq dflags)
+translateOp dflags IntNeOp        = Just (mo_wordNe dflags)
+translateOp dflags WordEqOp       = Just (mo_wordEq dflags)
+translateOp dflags WordNeOp       = Just (mo_wordNe dflags)
+translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)
+translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)
+
+translateOp dflags AndOp          = Just (mo_wordAnd dflags)
+translateOp dflags OrOp           = Just (mo_wordOr dflags)
+translateOp dflags XorOp          = Just (mo_wordXor dflags)
+translateOp dflags NotOp          = Just (mo_wordNot dflags)
+translateOp dflags SllOp          = Just (mo_wordShl dflags)
+translateOp dflags SrlOp          = Just (mo_wordUShr dflags)
+
+translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)
+
+-- Native word signed ops
+
+translateOp dflags IntMulOp        = Just (mo_wordMul dflags)
+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
+translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)
+translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)
+translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)
+
+
+translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)
+translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)
+translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)
+translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)
+
+translateOp dflags AndIOp         = Just (mo_wordAnd dflags)
+translateOp dflags OrIOp          = Just (mo_wordOr dflags)
+translateOp dflags XorIOp         = Just (mo_wordXor dflags)
+translateOp dflags NotIOp         = Just (mo_wordNot dflags)
+translateOp dflags ISllOp         = Just (mo_wordShl dflags)
+translateOp dflags ISraOp         = Just (mo_wordSShr dflags)
+translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)
+
+-- Native word unsigned ops
+
+translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)
+translateOp dflags WordLeOp       = Just (mo_wordULe dflags)
+translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)
+translateOp dflags WordLtOp       = Just (mo_wordULt dflags)
+
+translateOp dflags WordMulOp      = Just (mo_wordMul dflags)
+translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)
+translateOp dflags WordRemOp      = Just (mo_wordURem dflags)
+
+translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)
+translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)
+translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)
+translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)
+
+-- Int8# signed ops
+
+translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))
+translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)
+translateOp _      Int8NegOp      = Just (MO_S_Neg W8)
+translateOp _      Int8AddOp      = Just (MO_Add W8)
+translateOp _      Int8SubOp      = Just (MO_Sub W8)
+translateOp _      Int8MulOp      = Just (MO_Mul W8)
+translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)
+translateOp _      Int8RemOp      = Just (MO_S_Rem W8)
+
+translateOp _      Int8EqOp       = Just (MO_Eq W8)
+translateOp _      Int8GeOp       = Just (MO_S_Ge W8)
+translateOp _      Int8GtOp       = Just (MO_S_Gt W8)
+translateOp _      Int8LeOp       = Just (MO_S_Le W8)
+translateOp _      Int8LtOp       = Just (MO_S_Lt W8)
+translateOp _      Int8NeOp       = Just (MO_Ne W8)
+
+-- Word8# unsigned ops
+
+translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))
+translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)
+translateOp _      Word8NotOp      = Just (MO_Not W8)
+translateOp _      Word8AddOp      = Just (MO_Add W8)
+translateOp _      Word8SubOp      = Just (MO_Sub W8)
+translateOp _      Word8MulOp      = Just (MO_Mul W8)
+translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)
+translateOp _      Word8RemOp      = Just (MO_U_Rem W8)
+
+translateOp _      Word8EqOp       = Just (MO_Eq W8)
+translateOp _      Word8GeOp       = Just (MO_U_Ge W8)
+translateOp _      Word8GtOp       = Just (MO_U_Gt W8)
+translateOp _      Word8LeOp       = Just (MO_U_Le W8)
+translateOp _      Word8LtOp       = Just (MO_U_Lt W8)
+translateOp _      Word8NeOp       = Just (MO_Ne W8)
+
+-- Int16# signed ops
+
+translateOp dflags Int16Extend     = Just (MO_SS_Conv W16 (wordWidth dflags))
+translateOp dflags Int16Narrow     = Just (MO_SS_Conv (wordWidth dflags) W16)
+translateOp _      Int16NegOp      = Just (MO_S_Neg W16)
+translateOp _      Int16AddOp      = Just (MO_Add W16)
+translateOp _      Int16SubOp      = Just (MO_Sub W16)
+translateOp _      Int16MulOp      = Just (MO_Mul W16)
+translateOp _      Int16QuotOp     = Just (MO_S_Quot W16)
+translateOp _      Int16RemOp      = Just (MO_S_Rem W16)
+
+translateOp _      Int16EqOp       = Just (MO_Eq W16)
+translateOp _      Int16GeOp       = Just (MO_S_Ge W16)
+translateOp _      Int16GtOp       = Just (MO_S_Gt W16)
+translateOp _      Int16LeOp       = Just (MO_S_Le W16)
+translateOp _      Int16LtOp       = Just (MO_S_Lt W16)
+translateOp _      Int16NeOp       = Just (MO_Ne W16)
+
+-- Word16# unsigned ops
+
+translateOp dflags Word16Extend     = Just (MO_UU_Conv W16 (wordWidth dflags))
+translateOp dflags Word16Narrow     = Just (MO_UU_Conv (wordWidth dflags) W16)
+translateOp _      Word16NotOp      = Just (MO_Not W16)
+translateOp _      Word16AddOp      = Just (MO_Add W16)
+translateOp _      Word16SubOp      = Just (MO_Sub W16)
+translateOp _      Word16MulOp      = Just (MO_Mul W16)
+translateOp _      Word16QuotOp     = Just (MO_U_Quot W16)
+translateOp _      Word16RemOp      = Just (MO_U_Rem W16)
+
+translateOp _      Word16EqOp       = Just (MO_Eq W16)
+translateOp _      Word16GeOp       = Just (MO_U_Ge W16)
+translateOp _      Word16GtOp       = Just (MO_U_Gt W16)
+translateOp _      Word16LeOp       = Just (MO_U_Le W16)
+translateOp _      Word16LtOp       = Just (MO_U_Lt W16)
+translateOp _      Word16NeOp       = Just (MO_Ne W16)
+
+-- Char# ops
+
+translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))
+translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))
+translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))
+translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))
+translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))
+translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))
+
+-- Double ops
+
+translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)
+translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)
+translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)
+translateOp _      DoubleLeOp     = Just (MO_F_Le W64)
+translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)
+translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)
+
+translateOp _      DoubleAddOp    = Just (MO_F_Add W64)
+translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)
+translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)
+translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)
+translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)
+
+-- Float ops
+
+translateOp _      FloatEqOp     = Just (MO_F_Eq W32)
+translateOp _      FloatNeOp     = Just (MO_F_Ne W32)
+translateOp _      FloatGeOp     = Just (MO_F_Ge W32)
+translateOp _      FloatLeOp     = Just (MO_F_Le W32)
+translateOp _      FloatGtOp     = Just (MO_F_Gt W32)
+translateOp _      FloatLtOp     = Just (MO_F_Lt W32)
+
+translateOp _      FloatAddOp    = Just (MO_F_Add  W32)
+translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)
+translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)
+translateOp _      FloatDivOp    = Just (MO_F_Quot W32)
+translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)
+
+-- Vector ops
+
+translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)
+translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)
+translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)
+translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)
+translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)
+
+translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)
+translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)
+translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)
+translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)
+translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)
+translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)
+
+translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)
+translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)
+translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)
+translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)
+translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)
+
+-- Conversions
+
+translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)
+translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))
+
+translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)
+translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))
+
+translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)
+translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)
+
+-- Word comparisons masquerading as more exotic things.
+
+translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)
+translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)
+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)
+translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)
+-- See Note [Comparing stable names]
+translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)
+
+translateOp _      _ = Nothing
+
+-- Note [Comparing stable names]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A StableName# is actually a pointer to a stable name object (SNO)
+-- containing an index into the stable name table (SNT). We
+-- used to compare StableName#s by following the pointers to the
+-- SNOs and checking whether they held the same SNT indices. However,
+-- this is not necessary: there is a one-to-one correspondence
+-- between SNOs and entries in the SNT, so simple pointer equality
+-- does the trick.
+
+-- These primops are implemented by CallishMachOps, because they sometimes
+-- turn into foreign calls depending on the backend.
+
+callishOp :: PrimOp -> Maybe CallishMachOp
+callishOp DoublePowerOp  = Just MO_F64_Pwr
+callishOp DoubleSinOp    = Just MO_F64_Sin
+callishOp DoubleCosOp    = Just MO_F64_Cos
+callishOp DoubleTanOp    = Just MO_F64_Tan
+callishOp DoubleSinhOp   = Just MO_F64_Sinh
+callishOp DoubleCoshOp   = Just MO_F64_Cosh
+callishOp DoubleTanhOp   = Just MO_F64_Tanh
+callishOp DoubleAsinOp   = Just MO_F64_Asin
+callishOp DoubleAcosOp   = Just MO_F64_Acos
+callishOp DoubleAtanOp   = Just MO_F64_Atan
+callishOp DoubleAsinhOp  = Just MO_F64_Asinh
+callishOp DoubleAcoshOp  = Just MO_F64_Acosh
+callishOp DoubleAtanhOp  = Just MO_F64_Atanh
+callishOp DoubleLogOp    = Just MO_F64_Log
+callishOp DoubleExpOp    = Just MO_F64_Exp
+callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
+
+callishOp FloatPowerOp  = Just MO_F32_Pwr
+callishOp FloatSinOp    = Just MO_F32_Sin
+callishOp FloatCosOp    = Just MO_F32_Cos
+callishOp FloatTanOp    = Just MO_F32_Tan
+callishOp FloatSinhOp   = Just MO_F32_Sinh
+callishOp FloatCoshOp   = Just MO_F32_Cosh
+callishOp FloatTanhOp   = Just MO_F32_Tanh
+callishOp FloatAsinOp   = Just MO_F32_Asin
+callishOp FloatAcosOp   = Just MO_F32_Acos
+callishOp FloatAtanOp   = Just MO_F32_Atan
+callishOp FloatAsinhOp  = Just MO_F32_Asinh
+callishOp FloatAcoshOp  = Just MO_F32_Acosh
+callishOp FloatAtanhOp  = Just MO_F32_Atanh
+callishOp FloatLogOp    = Just MO_F32_Log
+callishOp FloatExpOp    = Just MO_F32_Exp
+callishOp FloatSqrtOp   = Just MO_F32_Sqrt
+
+callishOp _ = Nothing
+
+------------------------------------------------------------------------------
+-- Helpers for translating various minor variants of array indexing.
+
+doIndexOffAddrOp :: Maybe MachOp
+                 -> CmmType
+                 -> [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx
+doIndexOffAddrOp _ _ _ _
+   = panic "StgCmmPrim: doIndexOffAddrOp"
+
+doIndexOffAddrOpAs :: Maybe MachOp
+                   -> CmmType
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx
+doIndexOffAddrOpAs _ _ _ _ _
+   = panic "StgCmmPrim: doIndexOffAddrOpAs"
+
+doIndexByteArrayOp :: Maybe MachOp
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx
+doIndexByteArrayOp _ _ _ _
+   = panic "StgCmmPrim: doIndexByteArrayOp"
+
+doIndexByteArrayOpAs :: Maybe MachOp
+                    -> CmmType
+                    -> CmmType
+                    -> [LocalReg]
+                    -> [CmmExpr]
+                    -> FCode ()
+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx
+doIndexByteArrayOpAs _ _ _ _ _
+   = panic "StgCmmPrim: doIndexByteArrayOpAs"
+
+doReadPtrArrayOp :: LocalReg
+                 -> CmmExpr
+                 -> CmmExpr
+                 -> FCode ()
+doReadPtrArrayOp res addr idx
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx
+
+doWriteOffAddrOp :: Maybe MachOp
+                 -> CmmType
+                 -> [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val
+doWriteOffAddrOp _ _ _ _
+   = panic "StgCmmPrim: doWriteOffAddrOp"
+
+doWriteByteArrayOp :: Maybe MachOp
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
+   = do dflags <- getDynFlags
+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val
+doWriteByteArrayOp _ _ _ _
+   = panic "StgCmmPrim: doWriteByteArrayOp"
+
+doWritePtrArrayOp :: CmmExpr
+                  -> CmmExpr
+                  -> CmmExpr
+                  -> FCode ()
+doWritePtrArrayOp addr idx val
+  = do dflags <- getDynFlags
+       let ty = cmmExprType dflags val
+       -- This write barrier is to ensure that the heap writes to the object
+       -- referred to by val have happened before we write val into the array.
+       -- See #12469 for details.
+       emitPrimCall [] MO_WriteBarrier []
+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val
+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+  -- the write barrier.  We must write a byte into the mark table:
+  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
+       emit $ mkStore (
+         cmmOffsetExpr dflags
+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
+                         (loadArrPtrsSize dflags addr))
+          (CmmMachOp (mo_wordUShr dflags) [idx,
+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])
+         ) (CmmLit (CmmInt 1 W8))
+
+loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags
+
+mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes
+                   -> Maybe MachOp -- Optional result cast
+                   -> CmmType      -- Type of element we are accessing
+                   -> LocalReg     -- Destination
+                   -> CmmExpr      -- Base address
+                   -> CmmType      -- Type of element by which we are indexing
+                   -> CmmExpr      -- Index
+                   -> FCode ()
+mkBasicIndexedRead off Nothing ty res base idx_ty idx
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)
+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (CmmMachOp cast [
+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])
+
+mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
+                    -> Maybe MachOp -- Optional value cast
+                    -> CmmExpr      -- Base address
+                    -> CmmType      -- Type of element by which we are indexing
+                    -> CmmExpr      -- Index
+                    -> CmmExpr      -- Value to write
+                    -> FCode ()
+mkBasicIndexedWrite off Nothing base idx_ty idx val
+   = do dflags <- getDynFlags
+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val
+mkBasicIndexedWrite off (Just cast) base idx_ty idx val
+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])
+
+-- ----------------------------------------------------------------------------
+-- Misc utils
+
+cmmIndexOffExpr :: DynFlags
+                -> ByteOff  -- Initial offset in bytes
+                -> Width    -- Width of element by which we are indexing
+                -> CmmExpr  -- Base address
+                -> CmmExpr  -- Index
+                -> CmmExpr
+cmmIndexOffExpr dflags off width base idx
+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx
+
+cmmLoadIndexOffExpr :: DynFlags
+                    -> ByteOff  -- Initial offset in bytes
+                    -> CmmType  -- Type of element we are accessing
+                    -> CmmExpr  -- Base address
+                    -> CmmType  -- Type of element by which we are indexing
+                    -> CmmExpr  -- Index
+                    -> CmmExpr
+cmmLoadIndexOffExpr dflags off ty base idx_ty idx
+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty
+
+setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
+
+------------------------------------------------------------------------------
+-- Helpers for translating vector primops.
+
+vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType
+vecVmmType pocat n w = vec n (vecCmmCat pocat w)
+
+vecCmmCat :: PrimOpVecCat -> Width -> CmmType
+vecCmmCat IntVec   = cmmBits
+vecCmmCat WordVec  = cmmBits
+vecCmmCat FloatVec = cmmFloat
+
+vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp
+vecElemInjectCast _      FloatVec _   =  Nothing
+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)
+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)
+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)
+vecElemInjectCast _      IntVec   W64 =  Nothing
+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)
+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)
+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)
+vecElemInjectCast _      WordVec  W64 =  Nothing
+vecElemInjectCast _      _        _   =  Nothing
+
+vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp
+vecElemProjectCast _      FloatVec _   =  Nothing
+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)
+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)
+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)
+vecElemProjectCast _      IntVec   W64 =  Nothing
+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)
+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)
+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)
+vecElemProjectCast _      WordVec  W64 =  Nothing
+vecElemProjectCast _      _        _   =  Nothing
+
+
+-- NOTE [SIMD Design for the future]
+-- Check to make sure that we can generate code for the specified vector type
+-- given the current set of dynamic flags.
+-- Currently these checks are specific to x86 and x86_64 architecture.
+-- This should be fixed!
+-- In particular,
+-- 1) Add better support for other architectures! (this may require a redesign)
+-- 2) Decouple design choices from LLVM's pseudo SIMD model!
+--   The high level LLVM naive rep makes per CPU family SIMD generation is own
+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd
+-- 3) Depending on the architecture, the SIMD registers may also support general
+--    computations on Float/Double/Word/Int scalars, but currently on
+--    for example x86_64, we always put Word/Int (or sized) in GPR
+--    (general purpose) registers. Would relaxing that allow for
+--    useful optimization opportunities?
+--      Phrased differently, it is worth experimenting with supporting
+--    different register mapping strategies than we currently have, especially if
+--    someday we want SIMD to be a first class denizen in GHC along with scalar
+--    values!
+--      The current design with respect to register mapping of scalars could
+--    very well be the best,but exploring the  design space and doing careful
+--    measurments is the only only way to validate that.
+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension
+--    includes  support for a sort of run time CPU dependent vectorization parameter,
+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...
+--    element chunk! Time will tell if that direction sees wide adoption,
+--    but it is from that context that unifying our handling of simd and scalars
+--    may benefit. It is not likely to benefit current architectures, though
+--    it may very well be a design perspective that helps guide improving the NCG.
+
+
+checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()
+checkVecCompatibility dflags vcat l w = do
+    when (hscTarget dflags /= HscLlvm) $ do
+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."
+                         ,"Please use -fllvm."]
+    check vecWidth vcat l w
+  where
+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()
+    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =
+        sorry $ "128-bit wide single-precision floating point " ++
+                "SIMD vector instructions require at least -msse."
+    check W128 _ _ _ | not (isSse2Enabled dflags) =
+        sorry $ "128-bit wide integer and double precision " ++
+                "SIMD vector instructions require at least -msse2."
+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =
+        sorry $ "256-bit wide floating point " ++
+                "SIMD vector instructions require at least -mavx."
+    check W256 _ _ _ | not (isAvx2Enabled dflags) =
+        sorry $ "256-bit wide integer " ++
+                "SIMD vector instructions require at least -mavx2."
+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =
+        sorry $ "512-bit wide " ++
+                "SIMD vector instructions require -mavx512f."
+    check _ _ _ _ = return ()
+
+    vecWidth = typeWidth (vecVmmType vcat l w)
+
+------------------------------------------------------------------------------
+-- Helpers for translating vector packing and unpacking.
+
+doVecPackOp :: Maybe MachOp  -- Cast from element to vector component
+            -> CmmType       -- Type of vector
+            -> CmmExpr       -- Initial vector
+            -> [CmmExpr]     -- Elements
+            -> CmmFormal     -- Destination for result
+            -> FCode ()
+doVecPackOp maybe_pre_write_cast ty z es res = do
+    dst <- newTemp ty
+    emitAssign (CmmLocal dst) z
+    vecPack dst es 0
+  where
+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()
+    vecPack src [] _ =
+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))
+
+    vecPack src (e : es) i = do
+        dst <- newTemp ty
+        if isFloatType (vecElemType ty)
+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
+                                                    [CmmReg (CmmLocal src), cast e, iLit])
+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
+                                                    [CmmReg (CmmLocal src), cast e, iLit])
+        vecPack dst es (i + 1)
+      where
+        -- vector indices are always 32-bits
+        iLit = CmmLit (CmmInt (toInteger i) W32)
+
+    cast :: CmmExpr -> CmmExpr
+    cast val = case maybe_pre_write_cast of
+                 Nothing   -> val
+                 Just cast -> CmmMachOp cast [val]
+
+    len :: Length
+    len = vecLength ty
+
+    wid :: Width
+    wid = typeWidth (vecElemType ty)
+
+doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result
+              -> CmmType       -- Type of vector
+              -> CmmExpr       -- Vector
+              -> [CmmFormal]   -- Element results
+              -> FCode ()
+doVecUnpackOp maybe_post_read_cast ty e res =
+    vecUnpack res 0
+  where
+    vecUnpack :: [CmmFormal] -> Int -> FCode ()
+    vecUnpack [] _ =
+        return ()
+
+    vecUnpack (r : rs) i = do
+        if isFloatType (vecElemType ty)
+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)
+                                             [e, iLit]))
+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)
+                                             [e, iLit]))
+        vecUnpack rs (i + 1)
+      where
+        -- vector indices are always 32-bits
+        iLit = CmmLit (CmmInt (toInteger i) W32)
+
+    cast :: CmmExpr -> CmmExpr
+    cast val = case maybe_post_read_cast of
+                 Nothing   -> val
+                 Just cast -> CmmMachOp cast [val]
+
+    len :: Length
+    len = vecLength ty
+
+    wid :: Width
+    wid = typeWidth (vecElemType ty)
+
+doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component
+              -> CmmType       -- Vector type
+              -> CmmExpr       -- Source vector
+              -> CmmExpr       -- Element
+              -> CmmExpr       -- Index at which to insert element
+              -> CmmFormal     -- Destination for result
+              -> FCode ()
+doVecInsertOp maybe_pre_write_cast ty src e idx res = do
+    dflags <- getDynFlags
+    -- vector indices are always 32-bits
+    let idx' :: CmmExpr
+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]
+    if isFloatType (vecElemType ty)
+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])
+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])
+  where
+    cast :: CmmExpr -> CmmExpr
+    cast val = case maybe_pre_write_cast of
+                 Nothing   -> val
+                 Just cast -> CmmMachOp cast [val]
+
+    len :: Length
+    len = vecLength ty
+
+    wid :: Width
+    wid = typeWidth (vecElemType ty)
+
+------------------------------------------------------------------------------
+-- Helpers for translating prefetching.
+
+
+-- | Translate byte array prefetch operations into proper primcalls.
+doPrefetchByteArrayOp :: Int
+                      -> [CmmExpr]
+                      -> FCode ()
+doPrefetchByteArrayOp locality  [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx
+doPrefetchByteArrayOp _ _
+   = panic "StgCmmPrim: doPrefetchByteArrayOp"
+
+-- | Translate mutable byte array prefetch operations into proper primcalls.
+doPrefetchMutableByteArrayOp :: Int
+                      -> [CmmExpr]
+                      -> FCode ()
+doPrefetchMutableByteArrayOp locality  [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx
+doPrefetchMutableByteArrayOp _ _
+   = panic "StgCmmPrim: doPrefetchByteArrayOp"
+
+-- | Translate address prefetch operations into proper primcalls.
+doPrefetchAddrOp ::Int
+                 -> [CmmExpr]
+                 -> FCode ()
+doPrefetchAddrOp locality   [addr,idx]
+   = mkBasicPrefetch locality 0  addr idx
+doPrefetchAddrOp _ _
+   = panic "StgCmmPrim: doPrefetchAddrOp"
+
+-- | Translate value prefetch operations into proper primcalls.
+doPrefetchValueOp :: Int
+                 -> [CmmExpr]
+                 -> FCode ()
+doPrefetchValueOp  locality   [addr]
+  =  do dflags <- getDynFlags
+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))
+doPrefetchValueOp _ _
+  = panic "StgCmmPrim: doPrefetchValueOp"
+
+-- | helper to generate prefetch primcalls
+mkBasicPrefetch :: Int          -- Locality level 0-3
+                -> ByteOff      -- Initial offset in bytes
+                -> CmmExpr      -- Base address
+                -> CmmExpr      -- Index
+                -> FCode ()
+mkBasicPrefetch locality off base idx
+   = do dflags <- getDynFlags
+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]
+        return ()
+
+-- ----------------------------------------------------------------------------
+-- Allocating byte arrays
+
+-- | Takes a register to return the newly allocated array in and the
+-- size of the new array in bytes. Allocates a new
+-- 'MutableByteArray#'.
+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()
+doNewByteArrayOp res_r n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr mkArrWords_infoLabel
+        rep = arrWordsRep dflags n
+
+    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr cccsExpr
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgArrBytes_bytes dflags)
+                     ]
+
+    emit $ mkAssign (CmmLocal res_r) base
+
+-- ----------------------------------------------------------------------------
+-- Comparing byte arrays
+
+doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                     -> FCode ()
+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
+    dflags <- getDynFlags
+    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off
+    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off
+
+    -- short-cut in case of equal pointers avoiding a costly
+    -- subroutine call to the memcmp(3) routine; the Cmm logic below
+    -- results in assembly code being generated for
+    --
+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#
+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#
+    --
+    -- that looks like
+    --
+    --          leaq 16(%r14),%rax
+    --          leaq 16(%rsi),%rbx
+    --          xorl %ecx,%ecx
+    --          cmpq %rbx,%rax
+    --          je l_ptr_eq
+    --
+    --          ; NB: the common case (unequal pointers) falls-through
+    --          ; the conditional jump, and therefore matches the
+    --          ; usual static branch prediction convention of modern cpus
+    --
+    --          subq $8,%rsp
+    --          movq %rbx,%rsi
+    --          movq %rax,%rdi
+    --          movl $10,%edx
+    --          xorl %eax,%eax
+    --          call memcmp
+    --          addq $8,%rsp
+    --          movslq %eax,%rax
+    --          movq %rax,%rcx
+    --  l_ptr_eq:
+    --          movq %rcx,%rbx
+    --          jmp *(%rbp)
+
+    l_ptr_eq <- newBlockId
+    l_ptr_ne <- newBlockId
+
+    emit (mkAssign (CmmLocal res) (zeroExpr dflags))
+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)
+                    l_ptr_eq l_ptr_ne (Just False))
+
+    emitLabel l_ptr_ne
+    emitMemcmpCall res ba1_p ba2_p n 1
+
+    emitLabel l_ptr_eq
+
+-- ----------------------------------------------------------------------------
+-- Copying byte arrays
+
+-- | Takes a source 'ByteArray#', an offset in the source array, a
+-- destination 'MutableByteArray#', an offset into the destination
+-- array, and the number of bytes to copy.  Copies the given number of
+-- bytes from the source array to the destination array.
+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                  -> FCode ()
+doCopyByteArrayOp = emitCopyByteArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst dst_p src_p bytes align =
+        emitMemcpyCall dst_p src_p bytes align
+
+-- | Takes a source 'MutableByteArray#', an offset in the source
+-- array, a destination 'MutableByteArray#', an offset into the
+-- destination array, and the number of bytes to copy.  Copies the
+-- given number of bytes from the source array to the destination
+-- array.
+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                         -> FCode ()
+doCopyMutableByteArrayOp = emitCopyByteArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes align = do
+        dflags <- getDynFlags
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p bytes align)
+            (getCode $ emitMemcpyCall  dst_p src_p bytes align)
+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+
+emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                      -> Alignment -> FCode ())
+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                  -> FCode ()
+emitCopyByteArray copy src src_off dst dst_off n = do
+    dflags <- getDynFlags
+    let byteArrayAlignment = wordAlignment dflags
+        srcOffAlignment = cmmExprAlignment src_off
+        dstOffAlignment = cmmExprAlignment dst_off
+        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]
+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
+    copy src dst dst_p src_p n align
+
+-- | Takes a source 'ByteArray#', an offset in the source array, a
+-- destination 'Addr#', and the number of bytes to copy.  Copies the given
+-- number of bytes from the source array to the destination memory region.
+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+doCopyByteArrayToAddrOp src src_off dst_p bytes = do
+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
+    dflags <- getDynFlags
+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
+
+-- | Takes a source 'MutableByteArray#', an offset in the source array, a
+-- destination 'Addr#', and the number of bytes to copy.  Copies the given
+-- number of bytes from the source array to the destination memory region.
+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                               -> FCode ()
+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp
+
+-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into
+-- the destination array, and the number of bytes to copy.  Copies the given
+-- number of bytes from the source memory region to the destination array.
+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
+    dflags <- getDynFlags
+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
+
+
+-- ----------------------------------------------------------------------------
+-- Setting byte arrays
+
+-- | Takes a 'MutableByteArray#', an offset into the array, a length,
+-- and a byte, and sets each of the selected bytes in the array to the
+-- character.
+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                 -> FCode ()
+doSetByteArrayOp ba off len c = do
+    dflags <- getDynFlags
+
+    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap
+        offsetAlignment = cmmExprAlignment off
+        align = min byteArrayAlignment offsetAlignment
+
+    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
+    emitMemsetCall p c len align
+
+-- ----------------------------------------------------------------------------
+-- Allocating arrays
+
+-- | Allocate a new array.
+doNewArrayOp :: CmmFormal             -- ^ return register
+             -> SMRep                 -- ^ representation of the array
+             -> CLabel                -- ^ info pointer
+             -> [(CmmExpr, ByteOff)]  -- ^ header payload
+             -> WordOff               -- ^ array size
+             -> CmmExpr               -- ^ initial element
+             -> FCode ()
+doNewArrayOp res_r rep info payload n init = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info
+
+    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    base <- allocHeapClosure rep info_ptr cccsExpr payload
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    -- Initialise all elements of the array
+    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)
+        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]
+    emit (catAGraphs initialization)
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
+-- ----------------------------------------------------------------------------
+-- Copying pointer arrays
+
+-- EZY: This code has an unusually high amount of assignTemp calls, seen
+-- nowhere else in the code generator.  This is mostly because these
+-- "primitive" ops result in a surprisingly large amount of code.  It
+-- will likely be worthwhile to optimize what is emitted here, so that
+-- our optimization passes don't waste time repeatedly optimizing the
+-- same bits of code.
+
+-- More closely imitates 'assignTemp' from the old code generator, which
+-- returns a CmmExpr rather than a LocalReg.
+assignTempE :: CmmExpr -> FCode CmmExpr
+assignTempE e = do
+    t <- assignTemp e
+    return (CmmReg (CmmLocal t))
+
+-- | Takes a source 'Array#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy.  Copies the given number of
+-- elements from the source array to the destination array.
+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+              -> FCode ()
+doCopyArrayOp = emitCopyArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst dst_p src_p bytes =
+        do dflags <- getDynFlags
+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+               (wordAlignment dflags)
+
+
+-- | Takes a source 'MutableArray#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy.  Copies the given number of
+-- elements from the source array to the destination array.
+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+                     -> FCode ()
+doCopyMutableArrayOp = emitCopyArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes = do
+        dflags <- getDynFlags
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wordAlignment dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wordAlignment dflags))
+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+
+emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
+                  -> FCode ())  -- ^ copy function
+              -> CmmExpr        -- ^ source array
+              -> CmmExpr        -- ^ offset in source array
+              -> CmmExpr        -- ^ destination array
+              -> CmmExpr        -- ^ offset in destination array
+              -> WordOff        -- ^ number of elements to copy
+              -> FCode ()
+emitCopyArray copy src0 src_off dst0 dst_off0 n =
+    when (n /= 0) $ do
+        dflags <- getDynFlags
+
+        -- Passed as arguments (be careful)
+        src     <- assignTempE src0
+        dst     <- assignTempE dst0
+        dst_off <- assignTempE dst_off0
+
+        -- Set the dirty bit in the header.
+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+
+        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst
+                       (arrPtrsHdrSize dflags)
+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
+        src_p <- assignTempE $ cmmOffsetExprW dflags
+                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
+        let bytes = wordsToBytes dflags n
+
+        copy src dst dst_p src_p bytes
+
+        -- The base address of the destination card table
+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p
+                       (loadArrPtrsSize dflags dst)
+
+        emitSetCards dst_off dst_cards_p n
+
+doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+                   -> FCode ()
+doCopySmallArrayOp = emitCopySmallArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst dst_p src_p bytes =
+        do dflags <- getDynFlags
+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+               (wordAlignment dflags)
+
+
+doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+                          -> FCode ()
+doCopySmallMutableArrayOp = emitCopySmallArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes = do
+        dflags <- getDynFlags
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wordAlignment dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wordAlignment dflags))
+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+
+emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
+                       -> FCode ())  -- ^ copy function
+                   -> CmmExpr        -- ^ source array
+                   -> CmmExpr        -- ^ offset in source array
+                   -> CmmExpr        -- ^ destination array
+                   -> CmmExpr        -- ^ offset in destination array
+                   -> WordOff        -- ^ number of elements to copy
+                   -> FCode ()
+emitCopySmallArray copy src0 src_off dst0 dst_off n =
+    when (n /= 0) $ do
+        dflags <- getDynFlags
+
+        -- Passed as arguments (be careful)
+        src     <- assignTempE src0
+        dst     <- assignTempE dst0
+
+        -- Set the dirty bit in the header.
+        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
+
+        dst_p <- assignTempE $ cmmOffsetExprW dflags
+                 (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off
+        src_p <- assignTempE $ cmmOffsetExprW dflags
+                 (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off
+        let bytes = wordsToBytes dflags n
+
+        copy src dst dst_p src_p bytes
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it from the source array.
+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
+               -> FCode ()
+emitCloneArray info_p res_r src src_off n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info_p
+        rep = arrPtrsRep dflags n
+
+    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr cccsExpr
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
+                     , (mkIntExpr dflags (nonHdrSizeW rep),
+                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)
+                     ]
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+             (arrPtrsHdrSize dflags)
+    src_p <- assignTempE $ cmmOffsetExprW dflags src
+             (cmmAddWord dflags
+              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)
+
+    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+        (wordAlignment dflags)
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it from the source array.
+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
+                    -> FCode ()
+emitCloneSmallArray info_p res_r src src_off n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info_p
+        rep = smallArrPtrsRep n
+
+    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr cccsExpr
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
+                     ]
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+             (smallArrPtrsHdrSize dflags)
+    src_p <- assignTempE $ cmmOffsetExprW dflags src
+             (cmmAddWord dflags
+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)
+
+    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+        (wordAlignment dflags)
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
+-- | Takes and offset in the destination array, the base address of
+-- the card table, and the number of elements affected (*not* the
+-- number of cards). The number of elements may not be zero.
+-- Marks the relevant cards as dirty.
+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()
+emitSetCards dst_start dst_cards_start n = do
+    dflags <- getDynFlags
+    start_card <- assignTempE $ cardCmm dflags dst_start
+    let end_card = cardCmm dflags
+                   (cmmSubWord dflags
+                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))
+                    (mkIntExpr dflags 1))
+    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
+        (mkIntExpr dflags 1)
+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))
+        (mkAlignment 1) -- no alignment (1 byte)
+
+-- Convert an element index to a card index
+cardCmm :: DynFlags -> CmmExpr -> CmmExpr
+cardCmm dflags i =
+    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))
+
+------------------------------------------------------------------------------
+-- SmallArray PrimOp implementations
+
+doReadSmallPtrArrayOp :: LocalReg
+                      -> CmmExpr
+                      -> CmmExpr
+                      -> FCode ()
+doReadSmallPtrArrayOp res addr idx = do
+    dflags <- getDynFlags
+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr
+        (gcWord dflags) idx
+
+doWriteSmallPtrArrayOp :: CmmExpr
+                       -> CmmExpr
+                       -> CmmExpr
+                       -> FCode ()
+doWriteSmallPtrArrayOp addr idx val = do
+    dflags <- getDynFlags
+    let ty = cmmExprType dflags val
+    emitPrimCall [] MO_WriteBarrier [] -- #12469
+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val
+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
+
+------------------------------------------------------------------------------
+-- Atomic read-modify-write
+
+-- | Emit an atomic modification to a byte array element. The result
+-- reg contains that previous value of the element. Implies a full
+-- memory barrier.
+doAtomicRMW :: LocalReg      -- ^ Result reg
+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)
+            -> CmmExpr       -- ^ MutableByteArray#
+            -> CmmExpr       -- ^ Index
+            -> CmmType       -- ^ Type of element by which we are indexing
+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)
+            -> FCode ()
+doAtomicRMW res amop mba idx idx_ty n = do
+    dflags <- getDynFlags
+    let width = typeWidth idx_ty
+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+                width mba idx
+    emitPrimCall
+        [ res ]
+        (MO_AtomicRMW width amop)
+        [ addr, n ]
+
+-- | Emit an atomic read to a byte array that acts as a memory barrier.
+doAtomicReadByteArray
+    :: LocalReg  -- ^ Result reg
+    -> CmmExpr   -- ^ MutableByteArray#
+    -> CmmExpr   -- ^ Index
+    -> CmmType   -- ^ Type of element by which we are indexing
+    -> FCode ()
+doAtomicReadByteArray res mba idx idx_ty = do
+    dflags <- getDynFlags
+    let width = typeWidth idx_ty
+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+                width mba idx
+    emitPrimCall
+        [ res ]
+        (MO_AtomicRead width)
+        [ addr ]
+
+-- | Emit an atomic write to a byte array that acts as a memory barrier.
+doAtomicWriteByteArray
+    :: CmmExpr   -- ^ MutableByteArray#
+    -> CmmExpr   -- ^ Index
+    -> CmmType   -- ^ Type of element by which we are indexing
+    -> CmmExpr   -- ^ Value to write
+    -> FCode ()
+doAtomicWriteByteArray mba idx idx_ty val = do
+    dflags <- getDynFlags
+    let width = typeWidth idx_ty
+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+                width mba idx
+    emitPrimCall
+        [ {- no results -} ]
+        (MO_AtomicWrite width)
+        [ addr, val ]
+
+doCasByteArray
+    :: LocalReg  -- ^ Result reg
+    -> CmmExpr   -- ^ MutableByteArray#
+    -> CmmExpr   -- ^ Index
+    -> CmmType   -- ^ Type of element by which we are indexing
+    -> CmmExpr   -- ^ Old value
+    -> CmmExpr   -- ^ New value
+    -> FCode ()
+doCasByteArray res mba idx idx_ty old new = do
+    dflags <- getDynFlags
+    let width = (typeWidth idx_ty)
+        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+               width mba idx
+    emitPrimCall
+        [ res ]
+        (MO_Cmpxchg width)
+        [ addr, old, new ]
+
+------------------------------------------------------------------------------
+-- Helpers for emitting function calls
+
+-- | Emit a call to @memcpy@.
+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
+emitMemcpyCall dst src n align = do
+    emitPrimCall
+        [ {-no results-} ]
+        (MO_Memcpy (alignmentBytes align))
+        [ dst, src, n ]
+
+-- | Emit a call to @memmove@.
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
+emitMemmoveCall dst src n align = do
+    emitPrimCall
+        [ {- no results -} ]
+        (MO_Memmove (alignmentBytes align))
+        [ dst, src, n ]
+
+-- | Emit a call to @memset@.  The second argument must fit inside an
+-- unsigned char.
+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
+emitMemsetCall dst c n align = do
+    emitPrimCall
+        [ {- no results -} ]
+        (MO_Memset (alignmentBytes align))
+        [ dst, c, n ]
+
+emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemcmpCall res ptr1 ptr2 n align = do
+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all
+    -- code-gens currently call out to the @memcmp(3)@ C function.
+    -- This was easier than moving the sign-extensions into
+    -- all the code-gens.
+    dflags <- getDynFlags
+    let is32Bit = typeWidth (localRegType res) == W32
+
+    cres <- if is32Bit
+              then return res
+              else newTemp b32
+
+    emitPrimCall
+        [ cres ]
+        (MO_Memcmp align)
+        [ ptr1, ptr2, n ]
+
+    unless is32Bit $ do
+      emit $ mkAssign (CmmLocal res)
+                      (CmmMachOp
+                         (mo_s_32ToWord dflags)
+                         [(CmmReg (CmmLocal cres))])
+
+emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitBSwapCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_BSwap width)
+        [ x ]
+
+emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitBRevCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_BRev width)
+        [ x ]
+
+emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitPopCntCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_PopCnt width)
+        [ x ]
+
+emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPdepCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pdep width)
+        [ x, y ]
+
+emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPextCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pext width)
+        [ x, y ]
+
+emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitClzCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_Clz width)
+        [ x ]
+
+emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitCtzCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_Ctz width)
+        [ x ]
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -0,0 +1,360 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for profiling
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmProf (
+        initCostCentres, ccType, ccsType,
+        mkCCostCentre, mkCCostCentreStack,
+
+        -- Cost-centre Profiling
+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
+        enterCostCentreThunk, enterCostCentreFun,
+        costCentreFrom,
+        storeCurCCS,
+        emitSetCCC,
+
+        saveCurrentCostCentre, restoreCurrentCostCentre,
+
+        -- Lag/drag/void stuff
+        ldvEnter, ldvEnterClosure, ldvRecordCreate
+  ) where
+
+import GhcPrelude
+
+import StgCmmClosure
+import StgCmmUtils
+import StgCmmMonad
+import SMRep
+
+import MkGraph
+import Cmm
+import CmmUtils
+import CLabel
+
+import CostCentre
+import DynFlags
+import FastString
+import Module
+import Outputable
+
+import Control.Monad
+import Data.Char (ord)
+
+-----------------------------------------------------------------------------
+--
+-- Cost-centre-stack Profiling
+--
+-----------------------------------------------------------------------------
+
+-- Expression representing the current cost centre stack
+ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack
+ccsType = bWord
+
+ccType :: DynFlags -> CmmType -- Type of a cost centre
+ccType = bWord
+
+storeCurCCS :: CmmExpr -> CmmAGraph
+storeCurCCS e = mkAssign cccsReg e
+
+mkCCostCentre :: CostCentre -> CmmLit
+mkCCostCentre cc = CmmLabel (mkCCLabel cc)
+
+mkCCostCentreStack :: CostCentreStack -> CmmLit
+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
+
+costCentreFrom :: DynFlags
+               -> CmmExpr         -- A closure pointer
+               -> CmmExpr        -- The cost centre from that closure
+costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
+
+-- | The profiling header words in a static closure
+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
+staticProfHdr dflags ccs
+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
+
+-- | Profiling header words in a dynamic closure
+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
+
+-- | Initialise the profiling field of an update frame
+initUpdFrameProf :: CmmExpr -> FCode ()
+initUpdFrameProf frame
+  = ifProfiling $        -- frame->header.prof.ccs = CCCS
+    do dflags <- getDynFlags
+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr
+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
+        -- is unnecessary because it is not used anyhow.
+
+---------------------------------------------------------------------------
+--         Saving and restoring the current cost centre
+---------------------------------------------------------------------------
+
+{-        Note [Saving the current cost centre]
+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The current cost centre is like a global register.  Like other
+global registers, it's a caller-saves one.  But consider
+        case (f x) of (p,q) -> rhs
+Since 'f' may set the cost centre, we must restore it
+before resuming rhs.  So we want code like this:
+        local_cc = CCC  -- save
+        r = f( x )
+        CCC = local_cc  -- restore
+That is, we explicitly "save" the current cost centre in
+a LocalReg, local_cc; and restore it after the call. The
+C-- infrastructure will arrange to save local_cc across the
+call.
+
+The same goes for join points;
+        let j x = join-stuff
+        in blah-blah
+We want this kind of code:
+        local_cc = CCC  -- save
+        blah-blah
+     J:
+        CCC = local_cc  -- restore
+-}
+
+saveCurrentCostCentre :: FCode (Maybe LocalReg)
+        -- Returns Nothing if profiling is off
+saveCurrentCostCentre
+  = do dflags <- getDynFlags
+       if not (gopt Opt_SccProfilingOn dflags)
+           then return Nothing
+           else do local_cc <- newTemp (ccType dflags)
+                   emitAssign (CmmLocal local_cc) cccsExpr
+                   return (Just local_cc)
+
+restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
+restoreCurrentCostCentre Nothing
+  = return ()
+restoreCurrentCostCentre (Just local_cc)
+  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
+
+
+-------------------------------------------------------------------------------
+-- Recording allocation in a cost centre
+-------------------------------------------------------------------------------
+
+-- | Record the allocation of a closure.  The CmmExpr is the cost
+-- centre stack to which to attribute the allocation.
+profDynAlloc :: SMRep -> CmmExpr -> FCode ()
+profDynAlloc rep ccs
+  = ifProfiling $
+    do dflags <- getDynFlags
+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs
+
+-- | Record the allocation of a closure (size is given by a CmmExpr)
+-- The size must be in words, because the allocation counter in a CCS counts
+-- in words.
+profAlloc :: CmmExpr -> CmmExpr -> FCode ()
+profAlloc words ccs
+  = ifProfiling $
+        do dflags <- getDynFlags
+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
+           emit (addToMemE alloc_rep
+                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
+                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
+                         [CmmMachOp (mo_wordSub dflags) [words,
+                                                         mkIntExpr dflags (profHdrSize dflags)]]))
+                       -- subtract the "profiling overhead", which is the
+                       -- profiling header in a closure.
+
+-- -----------------------------------------------------------------------
+-- Setting the current cost centre on entry to a closure
+
+enterCostCentreThunk :: CmmExpr -> FCode ()
+enterCostCentreThunk closure =
+  ifProfiling $ do
+      dflags <- getDynFlags
+      emit $ storeCurCCS (costCentreFrom dflags closure)
+
+enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
+enterCostCentreFun ccs closure =
+  ifProfiling $ do
+    if isCurrentCCS ccs
+       then do dflags <- getDynFlags
+               emitRtsCall rtsUnitId (fsLit "enterFunCCS")
+                   [(baseExpr, AddrHint),
+                    (costCentreFrom dflags closure, AddrHint)] False
+       else return () -- top-level function, nothing to do
+
+ifProfiling :: FCode () -> FCode ()
+ifProfiling code
+  = do dflags <- getDynFlags
+       if gopt Opt_SccProfilingOn dflags
+           then code
+           else return ()
+
+ifProfilingL :: DynFlags -> [a] -> [a]
+ifProfilingL dflags xs
+  | gopt Opt_SccProfilingOn dflags = xs
+  | otherwise                      = []
+
+
+---------------------------------------------------------------
+--        Initialising Cost Centres & CCSs
+---------------------------------------------------------------
+
+initCostCentres :: CollectedCCs -> FCode ()
+-- Emit the declarations
+initCostCentres (local_CCs, singleton_CCSs)
+  = do dflags <- getDynFlags
+       when (gopt Opt_SccProfilingOn dflags) $
+           do mapM_ emitCostCentreDecl local_CCs
+              mapM_ emitCostCentreStackDecl singleton_CCSs
+
+
+emitCostCentreDecl :: CostCentre -> FCode ()
+emitCostCentreDecl cc = do
+  { dflags <- getDynFlags
+  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
+               | otherwise  = zero dflags
+                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
+  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
+  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS
+                                        $ Module.moduleName
+                                        $ cc_mod cc)
+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
+                   showPpr dflags (costCentreSrcSpan cc)
+           -- XXX going via FastString to get UTF-8 encoding is silly
+  ; let
+     lits = [ zero dflags,           -- StgInt ccID,
+              label,        -- char *label,
+              modl,        -- char *module,
+              loc,      -- char *srcloc,
+              zero64,   -- StgWord64 mem_alloc
+              zero dflags,     -- StgWord time_ticks
+              is_caf,   -- StgInt is_caf
+              zero dflags      -- struct _CostCentre *link
+            ]
+  ; emitDataLits (mkCCLabel cc) lits
+  }
+
+emitCostCentreStackDecl :: CostCentreStack -> FCode ()
+emitCostCentreStackDecl ccs
+  = case maybeSingletonCCS ccs of
+    Just cc ->
+        do dflags <- getDynFlags
+           let mk_lits cc = zero dflags :
+                            mkCCostCentre cc :
+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)
+                -- Note: to avoid making any assumptions about how the
+                -- C compiler (that compiles the RTS, in particular) does
+                -- layouts of structs containing long-longs, simply
+                -- pad out the struct with zero words until we hit the
+                -- size of the overall struct (which we get via DerivedConstants.h)
+           emitDataLits (mkCCSLabel ccs) (mk_lits cc)
+    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
+
+zero :: DynFlags -> CmmLit
+zero dflags = mkIntCLit dflags 0
+zero64 :: CmmLit
+zero64 = CmmInt 0 W64
+
+sizeof_ccs_words :: DynFlags -> Int
+sizeof_ccs_words dflags
+    -- round up to the next word.
+  | ms == 0   = ws
+  | otherwise = ws + 1
+  where
+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
+
+-- ---------------------------------------------------------------------------
+-- Set the current cost centre stack
+
+emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
+emitSetCCC cc tick push
+ = do dflags <- getDynFlags
+      if not (gopt Opt_SccProfilingOn dflags)
+          then return ()
+          else do tmp <- newTemp (ccsType dflags)
+                  pushCostCentre tmp cccsExpr cc
+                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
+
+pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
+pushCostCentre result ccs cc
+  = emitRtsCallWithResult result AddrHint
+        rtsUnitId
+        (fsLit "pushCostCentre") [(ccs,AddrHint),
+                                (CmmLit (mkCCostCentre cc), AddrHint)]
+        False
+
+bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
+bumpSccCount dflags ccs
+  = addToMem (rEP_CostCentreStack_scc_count dflags)
+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
+
+-----------------------------------------------------------------------------
+--
+--                Lag/drag/void stuff
+--
+-----------------------------------------------------------------------------
+
+--
+-- Initial value for the LDV field in a static closure
+--
+staticLdvInit :: DynFlags -> CmmLit
+staticLdvInit = zeroCLit
+
+--
+-- Initial value of the LDV field in a dynamic closure
+--
+dynLdvInit :: DynFlags -> CmmExpr
+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
+  CmmMachOp (mo_wordOr dflags) [
+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
+  ]
+
+--
+-- Initialise the LDV word of a new closure
+--
+ldvRecordCreate :: CmmExpr -> FCode ()
+ldvRecordCreate closure = do
+  dflags <- getDynFlags
+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
+
+--
+-- | Called when a closure is entered, marks the closure as having
+-- been "used".  The closure is not an "inherently used" one.  The
+-- closure is not @IND@ because that is not considered for LDV profiling.
+--
+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
+ldvEnterClosure closure_info node_reg = do
+    dflags <- getDynFlags
+    let tag = funTag dflags closure_info
+    -- don't forget to substract node's tag
+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))
+
+ldvEnter :: CmmExpr -> FCode ()
+-- Argument is a closure pointer
+ldvEnter cl_ptr = do
+    dflags <- getDynFlags
+    let -- don't forget to substract node's tag
+        ldv_wd = ldvWord dflags cl_ptr
+        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
+    ifProfiling $
+         -- if (era > 0) {
+         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
+         --                era | LDV_STATE_USE }
+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
+                     (mkStore ldv_wd new_ldv_wd)
+                     mkNop
+
+loadEra :: DynFlags -> CmmExpr
+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
+             (cInt dflags)]
+
+ldvWord :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes the address of a closure, and returns
+-- the address of the LDV word in the closure
+ldvWord dflags closure_ptr
+    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -0,0 +1,682 @@
+{-# LANGUAGE BangPatterns #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generation for ticky-ticky profiling
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+{- OVERVIEW: ticky ticky profiling
+
+Please see
+https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also
+edit it and the rest of this comment to keep them up-to-date if you
+change ticky-ticky. Thanks!
+
+ *** All allocation ticky numbers are in bytes. ***
+
+Some of the relevant source files:
+
+       ***not necessarily an exhaustive list***
+
+  * some codeGen/ modules import this one
+
+  * this module imports cmm/CLabel.hs to manage labels
+
+  * cmm/CmmParse.y expands some macros using generators defined in
+    this module
+
+  * includes/stg/Ticky.h declares all of the global counters
+
+  * includes/rts/Ticky.h declares the C data type for an
+    STG-declaration's counters
+
+  * some macros defined in includes/Cmm.h (and used within the RTS's
+    CMM code) update the global ticky counters
+
+  * at the end of execution rts/Ticky.c generates the final report
+    +RTS -r<report-file> -RTS
+
+The rts/Ticky.c function that generates the report includes an
+STG-declaration's ticky counters if
+
+  * that declaration was entered, or
+
+  * it was allocated (if -ticky-allocd)
+
+On either of those events, the counter is "registered" by adding it to
+a linked list; cf the CMM generated by registerTickyCtr.
+
+Ticky-ticky profiling has evolved over many years. Many of the
+counters from its most sophisticated days are no longer
+active/accurate. As the RTS has changed, sometimes the ticky code for
+relevant counters was not accordingly updated. Unfortunately, neither
+were the comments.
+
+As of March 2013, there still exist deprecated code and comments in
+the code generator as well as the RTS because:
+
+  * I don't know what is out-of-date versus merely commented out for
+    momentary convenience, and
+
+  * someone else might know how to repair it!
+
+-}
+
+module StgCmmTicky (
+  withNewTickyCounterFun,
+  withNewTickyCounterLNE,
+  withNewTickyCounterThunk,
+  withNewTickyCounterStdThunk,
+  withNewTickyCounterCon,
+
+  tickyDynAlloc,
+  tickyAllocHeap,
+
+  tickyAllocPrim,
+  tickyAllocThunk,
+  tickyAllocPAP,
+  tickyHeapCheck,
+  tickyStackCheck,
+
+  tickyUnknownCall, tickyDirectCall,
+
+  tickyPushUpdateFrame,
+  tickyUpdateFrameOmitted,
+
+  tickyEnterDynCon,
+  tickyEnterStaticCon,
+  tickyEnterViaNode,
+
+  tickyEnterFun,
+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
+                                              -- thunks only
+  tickyEnterLNE,
+
+  tickyUpdateBhCaf,
+  tickyBlackHole,
+  tickyUnboxedTupleReturn,
+  tickyReturnOldCon, tickyReturnNewCon,
+
+  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
+  tickySlowCall, tickySlowCallPat,
+  ) where
+
+import GhcPrelude
+
+import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )
+import StgCmmClosure
+import StgCmmUtils
+import StgCmmMonad
+
+import StgSyn
+import CmmExpr
+import MkGraph
+import CmmUtils
+import CLabel
+import SMRep
+
+import Module
+import Name
+import Id
+import BasicTypes
+import FastString
+import Outputable
+import Util
+
+import DynFlags
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType
+import Type
+import TyCon
+
+import Data.Maybe
+import qualified Data.Char
+import Control.Monad ( when )
+
+-----------------------------------------------------------------------------
+--
+-- Ticky-ticky profiling
+--
+-----------------------------------------------------------------------------
+
+data TickyClosureType
+    = TickyFun
+        Bool -- True <-> single entry
+    | TickyCon
+    | TickyThunk
+        Bool -- True <-> updateable
+        Bool -- True <-> standard thunk (AP or selector), has no entry counter
+    | TickyLNE
+
+withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
+
+withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterLNE nm args code = do
+  b <- tickyLNEIsOn
+  if not b then code else withNewTickyCounter TickyLNE nm args code
+
+thunkHasCounter :: Bool -> FCode Bool
+thunkHasCounter isStatic = do
+  b <- tickyDynThunkIsOn
+  pure (not isStatic && b)
+
+withNewTickyCounterThunk
+  :: Bool -- ^ static
+  -> Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterThunk isStatic isUpdatable name code = do
+    has_ctr <- thunkHasCounter isStatic
+    if not has_ctr
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+
+withNewTickyCounterStdThunk
+  :: Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterStdThunk isUpdatable name code = do
+    has_ctr <- thunkHasCounter False
+    if not has_ctr
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+
+withNewTickyCounterCon
+  :: Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterCon name code = do
+    has_ctr <- thunkHasCounter False
+    if not has_ctr
+      then code
+      else withNewTickyCounter TickyCon name [] code
+
+-- args does not include the void arguments
+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounter cloType name args m = do
+  lbl <- emitTickyCounter cloType name args
+  setTickyCtrLabel lbl m
+
+emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
+emitTickyCounter cloType name args
+  = let ctr_lbl = mkRednCountsLabel name in
+    (>> return ctr_lbl) $
+    ifTicky $ do
+        { dflags <- getDynFlags
+        ; parent <- getTickyCtrLabel
+        ; mod_name <- getModuleName
+
+          -- When printing the name of a thing in a ticky file, we
+          -- want to give the module name even for *local* things.  We
+          -- print just "x (M)" rather that "M.x" to distinguish them
+          -- from the global kind.
+        ; let ppr_for_ticky_name :: SDoc
+              ppr_for_ticky_name =
+                let n = ppr name
+                    ext = case cloType of
+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $
+                                  [text "fun"] ++ [text "se"|single_entry]
+                              TickyCon -> parens (text "con")
+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $
+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
+                              TickyLNE | isInternalName name -> parens (text "LNE")
+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
+                    p = case hasHaskellName parent of
+                            -- NB the default "top" ticky ctr does not
+                            -- have a Haskell name
+                          Just pname -> text "in" <+> ppr (nameUnique pname)
+                          _ -> empty
+                in if isInternalName name
+                   then n <+> parens (ppr mod_name) <+> ext <+> p
+                   else n <+> ext <+> p
+
+        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+        ; emitDataLits ctr_lbl
+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter
+        --
+        -- krc: note that all the fields are I32 now; some were I16
+        -- before, but the code generator wasn't handling that
+        -- properly and it led to chaos, panic and disorder.
+            [ mkIntCLit dflags 0,               -- registered?
+              mkIntCLit dflags (length args),   -- Arity
+              mkIntCLit dflags 0,               -- Heap allocated for this thing
+              fun_descr_lit,
+              arg_descr_lit,
+              zeroCLit dflags,          -- Entries into this thing
+              zeroCLit dflags,          -- Heap allocated by this thing
+              zeroCLit dflags                   -- Link to next StgEntCounter
+            ]
+        }
+
+-- -----------------------------------------------------------------------------
+-- Ticky stack frames
+
+tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky entries
+
+-- NB the name-specific entries are only available for names that have
+-- dedicated Cmm code. As far as I know, this just rules out
+-- constructor thunks. For them, there is no CMM code block to put the
+-- bump of name-specific ticky counter into. On the other hand, we can
+-- still track allocation their allocation.
+
+tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
+
+tickyEnterThunk :: ClosureInfo -> FCode ()
+tickyEnterThunk cl_info
+  = ifTicky $ do
+    { bumpTickyCounter ctr
+    ; has_ctr <- thunkHasCounter static
+    ; when has_ctr $ do
+      ticky_ctr_lbl <- getTickyCtrLabel
+      registerTickyCtrAtEntryDyn ticky_ctr_lbl
+      bumpTickyEntryCount ticky_ctr_lbl }
+  where
+    updatable = closureSingleEntry cl_info
+    static    = isStaticClosure cl_info
+
+    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"
+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
+                                   else fsLit "ENT_DYN_THK_MANY_ctr"
+
+tickyEnterStdThunk :: ClosureInfo -> FCode ()
+tickyEnterStdThunk = tickyEnterThunk
+
+tickyBlackHole :: Bool{-updatable-} -> FCode ()
+tickyBlackHole updatable
+  = ifTicky (bumpTickyCounter ctr)
+  where
+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
+
+tickyUpdateBhCaf :: ClosureInfo -> FCode ()
+tickyUpdateBhCaf cl_info
+  = ifTicky (bumpTickyCounter ctr)
+  where
+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
+
+tickyEnterFun :: ClosureInfo -> FCode ()
+tickyEnterFun cl_info = ifTicky $ do
+  ctr_lbl <- getTickyCtrLabel
+
+  if isStaticClosure cl_info
+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
+            registerTickyCtr ctr_lbl
+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
+            registerTickyCtrAtEntryDyn ctr_lbl
+
+  bumpTickyEntryCount ctr_lbl
+
+tickyEnterLNE :: FCode ()
+tickyEnterLNE = ifTicky $ do
+  bumpTickyCounter (fsLit "ENT_LNE_ctr")
+  ifTickyLNE $ do
+    ctr_lbl <- getTickyCtrLabel
+    registerTickyCtr ctr_lbl
+    bumpTickyEntryCount ctr_lbl
+
+-- needn't register a counter upon entry if
+--
+-- 1) it's for a dynamic closure, and
+--
+-- 2) -ticky-allocd is on
+--
+-- since the counter was registered already upon being alloc'd
+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
+registerTickyCtrAtEntryDyn ctr_lbl = do
+  already_registered <- tickyAllocdIsOn
+  when (not already_registered) $ registerTickyCtr ctr_lbl
+
+registerTickyCtr :: CLabel -> FCode ()
+-- Register a ticky counter
+--   if ( ! f_ct.registeredp ) {
+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
+--          f_ct.registeredp = 1 }
+registerTickyCtr ctr_lbl = do
+  dflags <- getDynFlags
+  let
+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
+    test = CmmMachOp (MO_Eq (wordWidth dflags))
+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
+               zeroExpr dflags]
+    register_stmts
+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
+                   (CmmLoad ticky_entry_ctrs (bWord dflags))
+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl
+                                (oFFSET_StgEntCounter_registeredp dflags)))
+                   (mkIntExpr dflags 1) ]
+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)
+
+tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
+tickyReturnOldCon arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }
+tickyReturnNewCon arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }
+
+tickyUnboxedTupleReturn :: RepArity -> FCode ()
+tickyUnboxedTupleReturn arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
+
+-- -----------------------------------------------------------------------------
+-- Ticky calls
+
+-- Ticks at a *call site*:
+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
+tickyDirectCall arity args
+  | args `lengthIs` arity = tickyKnownCallExact
+  | otherwise = do tickyKnownCallExtraArgs
+                   tickySlowCallPat (map argPrimRep (drop arity args))
+
+tickyKnownCallTooFewArgs :: FCode ()
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+
+tickyKnownCallExact :: FCode ()
+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
+
+tickyKnownCallExtraArgs :: FCode ()
+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+
+tickyUnknownCall :: FCode ()
+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
+
+-- Tick for the call pattern at slow call site (i.e. in addition to
+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
+tickySlowCall _ [] = return ()
+tickySlowCall lf_info args = do
+ -- see Note [Ticky for slow calls]
+ if isKnownFun lf_info
+   then tickyKnownCallTooFewArgs
+   else tickyUnknownCall
+ tickySlowCallPat (map argPrimRep args)
+
+tickySlowCallPat :: [PrimRep] -> FCode ()
+tickySlowCallPat args = ifTicky $
+  let argReps = map toArgRep args
+      (_, n_matched) = slowCallPattern argReps
+  in if n_matched > 0 && args `lengthIs` n_matched
+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
+
+{-
+
+Note [Ticky for slow calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Terminology is unfortunately a bit mixed up for these calls. codeGen
+uses "slow call" to refer to unknown calls and under-saturated known
+calls.
+
+Nowadays, though (ie as of the eval/apply paper), the significantly
+slower calls are actually just a subset of these: the ones with no
+built-in argument pattern (cf StgCmmArgRep.slowCallPattern)
+
+So for ticky profiling, we split slow calls into
+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
+bad for both space and time).
+
+-}
+
+-- -----------------------------------------------------------------------------
+-- Ticky allocation
+
+tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
+-- Called when doing a dynamic heap allocation; the LambdaFormInfo
+-- used to distinguish between closure types
+--
+-- TODO what else to count while we're here?
+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep
+
+      countGlobal tot ctr = do
+        bumpTickyCounterBy tot bytes
+        bumpTickyCounter   ctr
+      countSpecific = ifTickyAllocd $ case mb_id of
+        Nothing -> return ()
+        Just id -> do
+          let ctr_lbl = mkRednCountsLabel (idName id)
+          registerTickyCtr ctr_lbl
+          bumpTickyAllocd ctr_lbl bytes
+
+  -- TODO are we still tracking "good stuff" (_gds) versus
+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
+  -- for now, since I don't currently know neither if we do nor how to
+  -- distinguish. NSF Mar 2013
+
+  in case () of
+    _ | isConRep rep   ->
+          ifTickyDynThunk countSpecific >>
+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
+      | isThunkRep rep ->
+          ifTickyDynThunk countSpecific >>
+          if lfUpdatable lf
+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
+      | isFunRep   rep ->
+          countSpecific >>
+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"
+
+
+
+tickyAllocHeap ::
+  Bool -> -- is this a genuine allocation? As opposed to
+          -- StgCmmLayout.adjustHpBackwards
+  VirtualHpOffset -> FCode ()
+-- Called when doing a heap check [TICK_ALLOC_HEAP]
+-- Must be lazy in the amount of allocation!
+tickyAllocHeap genuine hp
+  = ifTicky $
+    do  { dflags <- getDynFlags
+        ; ticky_ctr <- getTickyCtrLabel
+        ; emit $ catAGraphs $
+            -- only test hp from within the emit so that the monadic
+            -- computation itself is not strict in hp (cf knot in
+            -- StgCmmMonad.getHeapUsage)
+          if hp == 0 then []
+          else let !bytes = wORD_SIZE dflags * hp in [
+            -- Bump the allocation total in the closure's StgEntCounter
+            addToMem (rEP_StgEntCounter_allocs dflags)
+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
+                     bytes,
+            -- Bump the global allocation total ALLOC_HEAP_tot
+            addToMemLbl (bWord dflags)
+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+                        bytes,
+            -- Bump the global allocation counter ALLOC_HEAP_ctr
+            if not genuine then mkNop
+            else addToMemLbl (bWord dflags)
+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+                             1
+            ]}
+
+
+--------------------------------------------------------------------------------
+-- these three are only called from CmmParse.y (ie ultimately from the RTS)
+
+-- the units are bytes
+
+tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
+               -> CmmExpr  -- ^ size of the payload, in bytes
+               -> CmmExpr -> FCode ()
+tickyAllocPrim _hdr _goods _slop = ifTicky $ do
+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
+
+tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocThunk _goods _slop = ifTicky $ do
+    -- TODO is it ever called with a Single-Entry thunk?
+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
+
+tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocPAP _goods _slop = ifTicky $ do
+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
+
+tickyHeapCheck :: FCode ()
+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
+
+tickyStackCheck :: FCode ()
+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky utils
+
+ifTicky :: FCode () -> FCode ()
+ifTicky code =
+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code
+
+tickyAllocdIsOn :: FCode Bool
+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags
+
+tickyLNEIsOn :: FCode Bool
+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags
+
+tickyDynThunkIsOn :: FCode Bool
+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags
+
+ifTickyAllocd :: FCode () -> FCode ()
+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code
+
+ifTickyLNE :: FCode () -> FCode ()
+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code
+
+ifTickyDynThunk :: FCode () -> FCode ()
+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
+
+bumpTickyCounter :: FastString -> FCode ()
+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterBy :: FastString -> Int -> FCode ()
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyEntryCount :: CLabel -> FCode ()
+bumpTickyEntryCount lbl = do
+  dflags <- getDynFlags
+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))
+
+bumpTickyAllocd :: CLabel -> Int -> FCode ()
+bumpTickyAllocd lbl bytes = do
+  dflags <- getDynFlags
+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
+
+bumpTickyLbl :: CLabel -> FCode ()
+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
+
+bumpTickyLblBy :: CLabel -> Int -> FCode ()
+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
+
+bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
+
+bumpTickyLit :: CmmLit -> FCode ()
+bumpTickyLit lhs = bumpTickyLitBy lhs 1
+
+bumpTickyLitBy :: CmmLit -> Int -> FCode ()
+bumpTickyLitBy lhs n = do
+  dflags <- getDynFlags
+  emit (addToMem (bWord dflags) (CmmLit lhs) n)
+
+bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
+bumpTickyLitByE lhs e = do
+  dflags <- getDynFlags
+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)
+
+bumpHistogram :: FastString -> Int -> FCode ()
+bumpHistogram lbl n = do
+    dflags <- getDynFlags
+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)
+    emit (addToMem (bWord dflags)
+           (cmmIndexExpr dflags
+                (wordWidth dflags)
+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))
+           1)
+
+------------------------------------------------------------------
+-- Showing the "type category" for ticky-ticky profiling
+
+showTypeCategory :: Type -> Char
+  {-
+        +           dictionary
+
+        >           function
+
+        {C,I,F,D,W} char, int, float, double, word
+        {c,i,f,d,w} unboxed ditto
+
+        T           tuple
+
+        P           other primitive type
+        p           unboxed ditto
+
+        L           list
+        E           enumeration type
+        S           other single-constructor type
+        M           other multi-constructor data-con type
+
+        .           other type
+
+        -           reserved for others to mark as "uninteresting"
+
+  Accurate as of Mar 2013, but I eliminated the Array category instead
+  of updating it, for simplicity. It's in P/p, I think --NSF
+
+    -}
+showTypeCategory ty
+  | isDictTy ty = '+'
+  | otherwise = case tcSplitTyConApp_maybe ty of
+  Nothing -> '.'
+  Just (tycon, _) ->
+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $
+    let anyOf us = getUnique tycon `elem` us in
+    case () of
+      _ | anyOf [funTyConKey] -> '>'
+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'
+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'
+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'
+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+                ] -> 'I'
+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,
+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+                ] -> 'W'
+        | anyOf [listTyConKey] -> 'L'
+        | isTupleTyCon tycon       -> 'T'
+        | isPrimTyCon tycon        -> 'P'
+        | isEnumerationTyCon tycon -> 'E'
+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
+        | otherwise -> 'M' -- oh, well...
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -0,0 +1,578 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generator utilities; mostly monadic
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmUtils (
+        cgLit, mkSimpleLit,
+        emitDataLits, mkDataLits,
+        emitRODataLits, mkRODataLits,
+        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
+        assignTemp, newTemp,
+
+        newUnboxedTupleRegs,
+
+        emitMultiAssign, emitCmmLitSwitch, emitSwitch,
+
+        tagToClosure, mkTaggedObjectLoad,
+
+        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
+
+        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
+        cmmOffsetExprW, cmmOffsetExprB,
+        cmmRegOffW, cmmRegOffB,
+        cmmLabelOffW, cmmLabelOffB,
+        cmmOffsetW, cmmOffsetB,
+        cmmOffsetLitW, cmmOffsetLitB,
+        cmmLoadIndexW,
+        cmmConstrTag1,
+
+        cmmUntag, cmmIsTagged,
+
+        addToMem, addToMemE, addToMemLblE, addToMemLbl,
+        mkWordCLit,
+        newStringCLit, newByteStringCLit,
+        blankWord,
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgCmmMonad
+import StgCmmClosure
+import Cmm
+import BlockId
+import MkGraph
+import CodeGen.Platform
+import CLabel
+import CmmUtils
+import CmmSwitch
+import CgUtils
+
+import ForeignCall
+import IdInfo
+import Type
+import TyCon
+import SMRep
+import Module
+import Literal
+import Digraph
+import Util
+import Unique
+import UniqSupply (MonadUnique(..))
+import DynFlags
+import FastString
+import Outputable
+import RepType
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Map as M
+import Data.Char
+import Data.List
+import Data.Ord
+
+
+-------------------------------------------------------------------------
+--
+--      Literals
+--
+-------------------------------------------------------------------------
+
+cgLit :: Literal -> FCode CmmLit
+cgLit (LitString s) = newByteStringCLit s
+ -- not unpackFS; we want the UTF-8 byte stream.
+cgLit other_lit     = do dflags <- getDynFlags
+                         return (mkSimpleLit dflags other_lit)
+
+mkSimpleLit :: DynFlags -> Literal -> CmmLit
+mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))
+                                                         (wordWidth dflags)
+mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags
+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64
+mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32
+mkSimpleLit _      (LitDouble r)                = CmmFloat r W64
+mkSimpleLit _      (LitLabel fs ms fod)
+  = let -- TODO: Literal labels might not actually be in the current package...
+        labelSrc = ForeignLabelInThisPackage
+    in CmmLabel (mkForeignLabel fs ms labelSrc fod)
+-- NB: LitRubbish should have been lowered in "CoreToStg"
+mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)
+
+--------------------------------------------------------------------------
+--
+-- Incrementing a memory location
+--
+--------------------------------------------------------------------------
+
+addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
+
+addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
+addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
+
+addToMem :: CmmType     -- rep of the counter
+         -> CmmExpr     -- Address
+         -> Int         -- What to add (a word)
+         -> CmmAGraph
+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
+
+addToMemE :: CmmType    -- rep of the counter
+          -> CmmExpr    -- Address
+          -> CmmExpr    -- What to add (a word-typed expression)
+          -> CmmAGraph
+addToMemE rep ptr n
+  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
+
+
+-------------------------------------------------------------------------
+--
+--      Loading a field from an object,
+--      where the object pointer is itself tagged
+--
+-------------------------------------------------------------------------
+
+mkTaggedObjectLoad
+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
+-- (loadTaggedObjectField reg base off tag) generates assignment
+--      reg = bitsK[ base + off - tag ]
+-- where K is fixed by 'reg'
+mkTaggedObjectLoad dflags reg base offset tag
+  = mkAssign (CmmLocal reg)
+             (CmmLoad (cmmOffsetB dflags
+                                  (CmmReg (CmmLocal base))
+                                  (offset - tag))
+                      (localRegType reg))
+
+-------------------------------------------------------------------------
+--
+--      Converting a closure tag to a closure for enumeration types
+--      (this is the implementation of tagToEnum#).
+--
+-------------------------------------------------------------------------
+
+tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure dflags tycon tag
+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
+  where closure_tbl = CmmLit (CmmLabel lbl)
+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
+
+-------------------------------------------------------------------------
+--
+--      Conditionals and rts calls
+--
+-------------------------------------------------------------------------
+
+emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
+
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
+        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCallWithResult res hint pkg fun args safe
+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
+
+-- Make a call to an RTS C procedure
+emitRtsCallGen
+   :: [(LocalReg,ForeignHint)]
+   -> CLabel
+   -> [(CmmExpr,ForeignHint)]
+   -> Bool -- True <=> CmmSafe call
+   -> FCode ()
+emitRtsCallGen res lbl args safe
+  = do { dflags <- getDynFlags
+       ; updfr_off <- getUpdFrameOff
+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+       ; emit caller_save
+       ; call updfr_off
+       ; emit caller_load }
+  where
+    call updfr_off =
+      if safe then
+        emit =<< mkCmmCall fun_expr res' args' updfr_off
+      else do
+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
+    (args', arg_hints) = unzip args
+    (res',  res_hints) = unzip res
+    fun_expr = mkLblExpr lbl
+
+
+-----------------------------------------------------------------------------
+--
+--      Caller-Save Registers
+--
+-----------------------------------------------------------------------------
+
+-- Here we generate the sequence of saves/restores required around a
+-- foreign call instruction.
+
+-- TODO: reconcile with includes/Regs.h
+--  * Regs.h claims that BaseReg should be saved last and loaded first
+--    * This might not have been tickled before since BaseReg is callee save
+--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers.  We can't (nor want) to do that
+-- here, as we don't have liveness information.  And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
+callerSaveVolatileRegs dflags = (caller_save, caller_load)
+  where
+    platform = targetPlatform dflags
+
+    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
+    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
+
+    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
+                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
+                  , BaseReg ]
+
+    regs_to_save = filter (callerSaves platform) system_regs
+
+    callerSaveGlobalReg reg
+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
+
+    callerRestoreGlobalReg reg
+        = mkAssign (CmmGlobal reg)
+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
+
+
+-------------------------------------------------------------------------
+--
+--      Strings generate a top-level data block
+--
+-------------------------------------------------------------------------
+
+emitDataLits :: CLabel -> [CmmLit] -> FCode ()
+-- Emit a data-segment data block
+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
+
+emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
+-- Emit a read-only data block
+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
+
+newStringCLit :: String -> FCode CmmLit
+-- Make a global definition for the string,
+-- and return its label
+newStringCLit str = newByteStringCLit (BS8.pack str)
+
+newByteStringCLit :: ByteString -> FCode CmmLit
+newByteStringCLit bytes
+  = do  { uniq <- newUnique
+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
+        ; emitDecl decl
+        ; return lit }
+
+-------------------------------------------------------------------------
+--
+--      Assigning expressions to temporaries
+--
+-------------------------------------------------------------------------
+
+assignTemp :: CmmExpr -> FCode LocalReg
+-- Make sure the argument is in a local register.
+-- We don't bother being particularly aggressive with avoiding
+-- unnecessary local registers, since we can rely on a later
+-- optimization pass to inline as necessary (and skipping out
+-- on things like global registers can be a little dangerous
+-- due to them being trashed on foreign calls--though it means
+-- the optimization pass doesn't have to do as much work)
+assignTemp (CmmReg (CmmLocal reg)) = return reg
+assignTemp e = do { dflags <- getDynFlags
+                  ; uniq <- newUnique
+                  ; let reg = LocalReg uniq (cmmExprType dflags e)
+                  ; emitAssign (CmmLocal reg) e
+                  ; return reg }
+
+newTemp :: MonadUnique m => CmmType -> m LocalReg
+newTemp rep = do { uniq <- getUniqueM
+                 ; return (LocalReg uniq rep) }
+
+newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
+-- Choose suitable local regs to use for the components
+-- of an unboxed tuple that we are about to return to
+-- the Sequel.  If the Sequel is a join point, using the
+-- regs it wants will save later assignments.
+newUnboxedTupleRegs res_ty
+  = ASSERT( isUnboxedTupleType res_ty )
+    do  { dflags <- getDynFlags
+        ; sequel <- getSequel
+        ; regs <- choose_regs dflags sequel
+        ; ASSERT( regs `equalLength` reps )
+          return (regs, map primRepForeignHint reps) }
+  where
+    reps = typePrimRep res_ty
+    choose_regs _ (AssignTo regs _) = return regs
+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps
+
+
+
+-------------------------------------------------------------------------
+--      emitMultiAssign
+-------------------------------------------------------------------------
+
+emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
+-- Emit code to perform the assignments in the
+-- input simultaneously, using temporary variables when necessary.
+
+type Key  = Int
+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
+                        -- for fast comparison
+type Stmt = (LocalReg, CmmExpr) -- r := e
+
+-- We use the strongly-connected component algorithm, in which
+--      * the vertices are the statements
+--      * an edge goes from s1 to s2 iff
+--              s1 assigns to something s2 uses
+--        that is, if s1 should *follow* s2 in the final order
+
+emitMultiAssign []    []    = return ()
+emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
+emitMultiAssign regs rhss   = do
+  dflags <- getDynFlags
+  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
+    unscramble dflags ([1..] `zip` (regs `zip` rhss))
+
+unscramble :: DynFlags -> [Vrtx] -> FCode ()
+unscramble dflags vertices = mapM_ do_component components
+  where
+        edges :: [ Node Key Vrtx ]
+        edges = [ DigraphNode vertex key1 (edges_from stmt1)
+                | vertex@(key1, stmt1) <- vertices ]
+
+        edges_from :: Stmt -> [Key]
+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
+                                    stmt1 `mustFollow` stmt2 ]
+
+        components :: [SCC Vrtx]
+        components = stronglyConnCompFromEdgedVerticesUniq edges
+
+        -- do_components deal with one strongly-connected component
+        -- Not cyclic, or singleton?  Just do it
+        do_component :: SCC Vrtx -> FCode ()
+        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt
+        do_component (CyclicSCC [])         = panic "do_component"
+        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
+
+                -- Cyclic?  Then go via temporaries.  Pick one to
+                -- break the loop and try again with the rest.
+        do_component (CyclicSCC ((_,first_stmt) : rest)) = do
+            dflags <- getDynFlags
+            u <- newUnique
+            let (to_tmp, from_tmp) = split dflags u first_stmt
+            mk_graph to_tmp
+            unscramble dflags rest
+            mk_graph from_tmp
+
+        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
+        split dflags uniq (reg, rhs)
+          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
+          where
+            rep = cmmExprType dflags rhs
+            tmp = LocalReg uniq rep
+
+        mk_graph :: Stmt -> FCode ()
+        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
+
+        mustFollow :: Stmt -> Stmt -> Bool
+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
+
+-------------------------------------------------------------------------
+--      mkSwitch
+-------------------------------------------------------------------------
+
+
+emitSwitch :: CmmExpr                      -- Tag to switch on
+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
+           -> Maybe CmmAGraphScoped        -- Default branch (if any)
+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;
+                                           -- behaviour outside this range is
+                                           -- undefined
+           -> FCode ()
+
+-- First, two rather common cases in which there is no work to do
+emitSwitch _ []         (Just code) _ _ = emit (fst code)
+emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)
+
+-- Right, off we go
+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
+    join_lbl      <- newBlockId
+    mb_deflt_lbl  <- label_default join_lbl mb_deflt
+    branches_lbls <- label_branches join_lbl branches
+    tag_expr'     <- assignTemp' tag_expr
+
+    -- Sort the branches before calling mk_discrete_switch
+    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
+    let range = (fromIntegral lo_tag, fromIntegral hi_tag)
+
+    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
+
+    emitLabel join_lbl
+
+mk_discrete_switch :: Bool -- ^ Use signed comparisons
+          -> CmmExpr
+          -> [(Integer, BlockId)]
+          -> Maybe BlockId
+          -> (Integer, Integer)
+          -> CmmAGraph
+
+-- SINGLETON TAG RANGE: no case analysis to do
+mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
+  | lo_tag == hi_tag
+  = ASSERT( tag == lo_tag )
+    mkBranch lbl
+
+-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
+mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
+  = mkBranch lbl
+        -- The simplifier might have eliminated a case
+        --       so we may have e.g. case xs of
+        --                               [] -> e
+        -- In that situation we can be sure the (:) case
+        -- can't happen, so no need to test
+
+-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
+-- See Note [Cmm Switches, the general plan] in CmmSwitch
+mk_discrete_switch signed tag_expr branches mb_deflt range
+  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
+
+divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
+divideBranches branches = (lo_branches, mid, hi_branches)
+  where
+    -- 2 branches => n_branches `div` 2 = 1
+    --            => branches !! 1 give the *second* tag
+    -- There are always at least 2 branches here
+    (mid,_) = branches !! (length branches `div` 2)
+    (lo_branches, hi_branches) = span is_lo branches
+    is_lo (t,_) = t < mid
+
+--------------
+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches
+               -> CmmAGraphScoped              -- Default branch (always)
+               -> FCode ()                     -- Emit the code
+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt
+emitCmmLitSwitch scrut  branches deflt = do
+    scrut' <- assignTemp' scrut
+    join_lbl <- newBlockId
+    deflt_lbl <- label_code join_lbl deflt
+    branches_lbls <- label_branches join_lbl branches
+
+    dflags <- getDynFlags
+    let cmm_ty = cmmExprType dflags scrut
+        rep = typeWidth cmm_ty
+
+    -- We find the necessary type information in the literals in the branches
+    let signed = case head branches of
+                    (LitNumber nt _ _, _) -> litNumIsSigned nt
+                    _ -> False
+
+    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
+              | otherwise = (0, tARGET_MAX_WORD dflags)
+
+    if isFloatType cmm_ty
+    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
+    else emit $ mk_discrete_switch
+        signed
+        scrut'
+        [(litValue lit,l) | (lit,l) <- branches_lbls]
+        (Just deflt_lbl)
+        range
+    emitLabel join_lbl
+
+-- | lower bound (inclusive), upper bound (exclusive)
+type LitBound = (Maybe Literal, Maybe Literal)
+
+noBound :: LitBound
+noBound = (Nothing, Nothing)
+
+mk_float_switch :: Width -> CmmExpr -> BlockId
+              -> LitBound
+              -> [(Literal,BlockId)]
+              -> FCode CmmAGraph
+mk_float_switch rep scrut deflt _bounds [(lit,blk)]
+  = do dflags <- getDynFlags
+       return $ mkCbranch (cond dflags) deflt blk Nothing
+  where
+    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
+      where
+        cmm_lit = mkSimpleLit dflags lit
+        ne      = MO_F_Ne rep
+
+mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
+  = do dflags <- getDynFlags
+       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
+       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk
+  where
+    (lo_branches, mid_lit, hi_branches) = divideBranches branches
+
+    bounds_lo = (lo_bound, Just mid_lit)
+    bounds_hi = (Just mid_lit, hi_bound)
+
+    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
+      where
+        cmm_lit = mkSimpleLit dflags mid_lit
+        lt      = MO_F_Lt rep
+
+
+--------------
+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
+label_default _ Nothing
+  = return Nothing
+label_default join_lbl (Just code)
+  = do lbl <- label_code join_lbl code
+       return (Just lbl)
+
+--------------
+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
+label_branches _join_lbl []
+  = return []
+label_branches join_lbl ((tag,code):branches)
+  = do lbl <- label_code join_lbl code
+       branches' <- label_branches join_lbl branches
+       return ((tag,lbl):branches')
+
+--------------
+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
+--  label_code J code
+--      generates
+--  [L: code; goto J]
+-- and returns L
+label_code join_lbl (code,tsc) = do
+    lbl <- newBlockId
+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
+    return lbl
+
+--------------
+assignTemp' :: CmmExpr -> FCode CmmExpr
+assignTemp' e
+  | isTrivialCmmExpr e = return e
+  | otherwise = do
+       dflags <- getDynFlags
+       lreg <- newTemp (cmmExprType dflags e)
+       let reg = CmmLocal lreg
+       emitAssign reg e
+       return (CmmReg reg)
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/coreSyn/CoreLint.hs
@@ -0,0 +1,2741 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+
+A ``lint'' pass to check for Core correctness
+-}
+
+{-# LANGUAGE CPP #-}
+
+module CoreLint (
+    lintCoreBindings, lintUnfolding,
+    lintPassResult, lintInteractiveExpr, lintExpr,
+    lintAnnots, lintTypes,
+
+    -- ** Debug output
+    endPass, endPassIO,
+    dumpPassResult,
+    CoreLint.dumpIfSet,
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreFVs
+import CoreUtils
+import CoreStats   ( coreBindsStats )
+import CoreMonad
+import Bag
+import Literal
+import DataCon
+import TysWiredIn
+import TysPrim
+import TcType ( isFloatingTy )
+import Var
+import VarEnv
+import VarSet
+import Name
+import Id
+import IdInfo
+import PprCore
+import ErrUtils
+import Coercion
+import SrcLoc
+import Kind
+import Type
+import RepType
+import TyCoRep       -- checks validity of types/coercions
+import TyCon
+import CoAxiom
+import BasicTypes
+import ErrUtils as Err
+import ListSetOps
+import PrelNames
+import Outputable
+import FastString
+import Util
+import InstEnv     ( instanceDFunId )
+import OptCoercion ( checkAxInstCo )
+import UniqSupply
+import CoreArity ( typeArity )
+import Demand ( splitStrictSig, isBotRes )
+
+import HscTypes
+import DynFlags
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+import MonadUtils
+import Data.Foldable      ( toList )
+import Data.List.NonEmpty ( NonEmpty )
+import Data.Maybe
+import Pair
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+Note [GHC Formalism]
+~~~~~~~~~~~~~~~~~~~~
+This file implements the type-checking algorithm for System FC, the "official"
+name of the Core language. Type safety of FC is heart of the claim that
+executables produced by GHC do not have segmentation faults. Thus, it is
+useful to be able to reason about System FC independently of reading the code.
+To this purpose, there is a document core-spec.pdf built in docs/core-spec that
+contains a formalism of the types and functions dealt with here. If you change
+just about anything in this file or you change other types/functions throughout
+the Core language (all signposted to this note), you should update that
+formalism. See docs/core-spec/README for more info about how to do so.
+
+Note [check vs lint]
+~~~~~~~~~~~~~~~~~~~~
+This file implements both a type checking algorithm and also general sanity
+checking. For example, the "sanity checking" checks for TyConApp on the left
+of an AppTy, which should never happen. These sanity checks don't really
+affect any notion of type soundness. Yet, it is convenient to do the sanity
+checks at the same time as the type checks. So, we use the following naming
+convention:
+
+- Functions that begin with 'lint'... are involved in type checking. These
+  functions might also do some sanity checking.
+
+- Functions that begin with 'check'... are *not* involved in type checking.
+  They exist only for sanity checking.
+
+Issues surrounding variable naming, shadowing, and such are considered *not*
+to be part of type checking, as the formalism omits these details.
+
+Summary of checks
+~~~~~~~~~~~~~~~~~
+Checks that a set of core bindings is well-formed.  The PprStyle and String
+just control what we print in the event of an error.  The Bool value
+indicates whether we have done any specialisation yet (in which case we do
+some extra checks).
+
+We check for
+        (a) type errors
+        (b) Out-of-scope type variables
+        (c) Out-of-scope local variables
+        (d) Ill-kinded types
+        (e) Incorrect unsafe coercions
+
+If we have done specialisation the we check that there are
+        (a) No top-level bindings of primitive (unboxed type)
+
+Outstanding issues:
+
+    -- Things are *not* OK if:
+    --
+    --  * Unsaturated type app before specialisation has been done;
+    --
+    --  * Oversaturated type app after specialisation (eta reduction
+    --   may well be happening...);
+
+
+Note [Linting function types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in Note [Representation of function types], all saturated
+applications of funTyCon are represented with the FunTy constructor. We check
+this invariant in lintType.
+
+Note [Linting type lets]
+~~~~~~~~~~~~~~~~~~~~~~~~
+In the desugarer, it's very very convenient to be able to say (in effect)
+        let a = Type Int in <body>
+That is, use a type let.   See Note [Type let] in CoreSyn.
+
+However, when linting <body> we need to remember that a=Int, else we might
+reject a correct program.  So we carry a type substitution (in this example
+[a -> Int]) and apply this substitution before comparing types.  The functin
+        lintInTy :: Type -> LintM (Type, Kind)
+returns a substituted type.
+
+When we encounter a binder (like x::a) we must apply the substitution
+to the type of the binding variable.  lintBinders does this.
+
+For Ids, the type-substituted Id is added to the in_scope set (which
+itself is part of the TCvSubst we are carrying down), and when we
+find an occurrence of an Id, we fetch it from the in-scope set.
+
+Note [Bad unsafe coercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions
+Linter introduces additional rules that checks improper coercion between
+different types, called bad coercions. Following coercions are forbidden:
+
+  (a) coercions between boxed and unboxed values;
+  (b) coercions between unlifted values of the different sizes, here
+      active size is checked, i.e. size of the actual value but not
+      the space allocated for value;
+  (c) coercions between floating and integral boxed values, this check
+      is not yet supported for unboxed tuples, as no semantics were
+      specified for that;
+  (d) coercions from / to vector type
+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be
+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules
+      (a-e) holds.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+We check the rules listed in Note [Invariants on join points] in CoreSyn. The
+only one that causes any difficulty is the first: All occurrences must be tail
+calls. To this end, along with the in-scope set, we remember in le_joins the
+subset of in-scope Ids that are valid join ids. For example:
+
+  join j x = ... in
+  case e of
+    A -> jump j y -- good
+    B -> case (jump j z) of -- BAD
+           C -> join h = jump j w in ... -- good
+           D -> let x = jump j v in ... -- BAD
+
+A join point remains valid in case branches, so when checking the A
+branch, j is still valid. When we check the scrutinee of the inner
+case, however, we set le_joins to empty, and catch the
+error. Similarly, join points can occur free in RHSes of other join
+points but not the RHSes of value bindings (thunks and functions).
+
+************************************************************************
+*                                                                      *
+                 Beginning and ending passes
+*                                                                      *
+************************************************************************
+
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a convenient place for them.  They print out stuff
+before and after core passes, and do Core Lint when necessary.
+-}
+
+endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
+endPass pass binds rules
+  = do { hsc_env <- getHscEnv
+       ; print_unqual <- getPrintUnqualified
+       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
+
+endPassIO :: HscEnv -> PrintUnqualified
+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+-- Used by the IO-is CorePrep too
+endPassIO hsc_env print_unqual pass binds rules
+  = do { dumpPassResult dflags print_unqual mb_flag
+                        (ppr pass) (pprPassDetails pass) binds rules
+       ; lintPassResult hsc_env pass binds }
+  where
+    dflags  = hsc_dflags hsc_env
+    mb_flag = case coreDumpFlag pass of
+                Just flag | dopt flag dflags                    -> Just flag
+                          | dopt Opt_D_verbose_core2core dflags -> Just flag
+                _ -> Nothing
+
+dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dflags dump_me pass extra_info doc
+  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
+
+dumpPassResult :: DynFlags
+               -> PrintUnqualified
+               -> Maybe DumpFlag        -- Just df => show details in a file whose
+                                        --            name is specified by df
+               -> SDoc                  -- Header
+               -> SDoc                  -- Extra info to appear after header
+               -> CoreProgram -> [CoreRule]
+               -> IO ()
+dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
+  = do { forM_ mb_flag $ \flag ->
+           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
+
+         -- Report result size
+         -- This has the side effect of forcing the intermediate to be evaluated
+         -- if it's not already forced by a -ddump flag.
+       ; Err.debugTraceMsg dflags 2 size_doc
+       }
+
+  where
+    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
+
+    dump_doc  = vcat [ nest 2 extra_info
+                     , size_doc
+                     , blankLine
+                     , pprCoreBindingsWithSize binds
+                     , ppUnless (null rules) pp_rules ]
+    pp_rules = vcat [ blankLine
+                    , text "------ Local rules for imported ids --------"
+                    , pprRules rules ]
+
+coreDumpFlag :: CoreToDo -> Maybe DumpFlag
+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
+coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify
+coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt
+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
+coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal
+
+coreDumpFlag CoreDoPrintCore          = Nothing
+coreDumpFlag (CoreDoRuleCheck {})     = Nothing
+coreDumpFlag CoreDoNothing            = Nothing
+coreDumpFlag (CoreDoPasses {})        = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+                 Top-level interfaces
+*                                                                      *
+************************************************************************
+-}
+
+lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
+lintPassResult hsc_env pass binds
+  | not (gopt Opt_DoCoreLinting dflags)
+  = return ()
+  | otherwise
+  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
+       ; displayLintResults dflags pass warns errs binds  }
+  where
+    dflags = hsc_dflags hsc_env
+
+displayLintResults :: DynFlags -> CoreToDo
+                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
+                   -> IO ()
+displayLintResults dflags pass warns errs binds
+  | not (isEmptyBag errs)
+  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
+           (defaultDumpStyle dflags)
+           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
+                 , text "*** Offending Program ***"
+                 , pprCoreBindings binds
+                 , text "*** End of Offense ***" ])
+       ; Err.ghcExit dflags 1 }
+
+  | not (isEmptyBag warns)
+  , not (hasNoDebugOutput dflags)
+  , showLintWarnings pass
+  -- If the Core linter encounters an error, output to stderr instead of
+  -- stdout (#13342)
+  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
+        (defaultDumpStyle dflags)
+        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
+
+  | otherwise = return ()
+  where
+
+lint_banner :: String -> SDoc -> SDoc
+lint_banner string pass = text "*** Core Lint"      <+> text string
+                          <+> text ": in result of" <+> pass
+                          <+> text "***"
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
+
+lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr what hsc_env expr
+  | not (gopt Opt_DoCoreLinting dflags)
+  = return ()
+  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
+  = do { display_lint_err err
+       ; Err.ghcExit dflags 1 }
+  | otherwise
+  = return ()
+  where
+    dflags = hsc_dflags hsc_env
+
+    display_lint_err err
+      = do { putLogMsg dflags NoReason Err.SevDump
+               noSrcSpan (defaultDumpStyle dflags)
+               (vcat [ lint_banner "errors" (text what)
+                     , err
+                     , text "*** Offending Program ***"
+                     , pprCoreExpr expr
+                     , text "*** End of Offense ***" ])
+           ; Err.ghcExit dflags 1 }
+
+interactiveInScope :: HscEnv -> [Var]
+-- In GHCi we may lint expressions, or bindings arising from 'deriving'
+-- clauses, that mention variables bound in the interactive context.
+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
+-- So we have to tell Lint about them, lest it reports them as out of scope.
+--
+-- We do this by find local-named things that may appear free in interactive
+-- context.  This function is pretty revolting and quite possibly not quite right.
+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
+-- so this is a (cheap) no-op.
+--
+-- See #8215 for an example
+interactiveInScope hsc_env
+  = tyvars ++ ids
+  where
+    -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
+    ictxt                   = hsc_IC hsc_env
+    (cls_insts, _fam_insts) = ic_instances ictxt
+    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
+    te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
+    ids    = typeEnvIds te
+    tyvars = tyCoVarsOfTypesList $ map idType ids
+              -- Why the type variables?  How can the top level envt have free tyvars?
+              -- I think it's because of the GHCi debugger, which can bind variables
+              --   f :: [t] -> [t]
+              -- where t is a RuntimeUnk (see TcType)
+
+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+--   Returns (warnings, errors)
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreBindings dflags pass local_in_scope binds
+  = initL dflags flags in_scope_set $
+    addLoc TopLevelBindings         $
+    lintLetBndrs TopLevel binders   $
+        -- Put all the top-level binders in scope at the start
+        -- This is because transformation rules can bring something
+        -- into use 'unexpectedly'
+    do { checkL (null dups) (dupVars dups)
+       ; checkL (null ext_dups) (dupExtVars ext_dups)
+       ; mapM lint_bind binds }
+  where
+    in_scope_set = mkInScopeSet (mkVarSet local_in_scope)
+
+    flags = defaultLintFlags
+               { lf_check_global_ids = check_globals
+               , lf_check_inline_loop_breakers = check_lbs
+               , lf_check_static_ptrs = check_static_ptrs }
+
+    -- See Note [Checking for global Ids]
+    check_globals = case pass of
+                      CoreTidy -> False
+                      CorePrep -> False
+                      _        -> True
+
+    -- See Note [Checking for INLINE loop breakers]
+    check_lbs = case pass of
+                      CoreDesugar    -> False
+                      CoreDesugarOpt -> False
+                      _              -> True
+
+    -- See Note [Checking StaticPtrs]
+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
+                      | otherwise = case pass of
+                          CoreDoFloatOutwards _ -> AllowAtTopLevel
+                          CoreTidy              -> RejectEverywhere
+                          CorePrep              -> AllowAtTopLevel
+                          _                     -> AllowAnywhere
+
+    binders = bindersOfBinds binds
+    (_, dups) = removeDups compare binders
+
+    -- dups_ext checks for names with different uniques
+    -- but but the same External name M.n.  We don't
+    -- allow this at top level:
+    --    M.n{r3}  = ...
+    --    M.n{r29} = ...
+    -- because they both get the same linker symbol
+    ext_dups = snd (removeDups ord_ext (map Var.varName binders))
+    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
+                  , Just m2 <- nameModule_maybe n2
+                  = compare (m1, nameOccName n1) (m2, nameOccName n2)
+                  | otherwise = LT
+
+    -- If you edit this function, you may need to update the GHC formalism
+    -- See Note [GHC Formalism]
+    lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
+    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lintUnfolding]{lintUnfolding}
+*                                                                      *
+************************************************************************
+
+Note [Linting Unfoldings from Interfaces]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We use this to check all top-level unfoldings that come in from interfaces
+(it is very painful to catch errors otherwise).
+
+We do not need to call lintUnfolding on unfoldings that are nested within
+top-level unfoldings; they are linted when we lint the top-level unfolding;
+hence the `TopLevelFlag` on `tcPragExpr` in TcIface.
+
+-}
+
+lintUnfolding :: DynFlags
+              -> SrcLoc
+              -> VarSet         -- Treat these as in scope
+              -> CoreExpr
+              -> Maybe MsgDoc   -- Nothing => OK
+
+lintUnfolding dflags locn vars expr
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = mkInScopeSet vars
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = addLoc (ImportedUnfolding locn) $
+             lintCoreExpr expr
+
+lintExpr :: DynFlags
+         -> [Var]               -- Treat these as in scope
+         -> CoreExpr
+         -> Maybe MsgDoc        -- Nothing => OK
+
+lintExpr dflags vars expr
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = mkInScopeSet (mkVarSet vars)
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = addLoc TopLevelBindings $
+             lintCoreExpr expr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lintCoreBinding]{lintCoreBinding}
+*                                                                      *
+************************************************************************
+
+Check a core binding, returning the list of variables bound.
+-}
+
+lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
+  = addLoc (RhsOf binder) $
+         -- Check the rhs
+    do { ty <- lintRhs binder rhs
+       ; binder_ty <- applySubstTy (idType binder)
+       ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
+
+       -- If the binding is for a CoVar, the RHS should be (Coercion co)
+       -- See Note [CoreSyn type and coercion invariant] in CoreSyn
+       ; checkL (not (isCoVar binder) || isCoArg rhs)
+                (mkLetErr binder rhs)
+
+       -- Check that it's not levity-polymorphic
+       -- Do this first, because otherwise isUnliftedType panics
+       -- Annoyingly, this duplicates the test in lintIdBdr,
+       -- because for non-rec lets we call lintSingleBinding first
+       ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))
+                (badBndrTyMsg binder (text "levity-polymorphic"))
+
+        -- Check the let/app invariant
+        -- See Note [CoreSyn let/app invariant] in CoreSyn
+       ; checkL ( isJoinId binder
+               || not (isUnliftedType binder_ty)
+               || (isNonRec rec_flag && exprOkForSpeculation rhs)
+               || exprIsTickedString rhs)
+           (badBndrTyMsg binder (text "unlifted"))
+
+        -- Check that if the binder is top-level or recursive, it's not
+        -- demanded. Primitive string literals are exempt as there is no
+        -- computation to perform, see Note [CoreSyn top-level string literals].
+       ; checkL (not (isStrictId binder)
+            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
+            || exprIsTickedString rhs)
+           (mkStrictMsg binder)
+
+        -- Check that if the binder is at the top level and has type Addr#,
+        -- that it is a string literal, see
+        -- Note [CoreSyn top-level string literals].
+       ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
+                 || exprIsTickedString rhs)
+           (mkTopNonLitStrMsg binder)
+
+       ; flags <- getLintFlags
+
+         -- Check that a join-point binder has a valid type
+         -- NB: lintIdBinder has checked that it is not top-level bound
+       ; case isJoinId_maybe binder of
+            Nothing    -> return ()
+            Just arity ->  checkL (isValidJoinPointType arity binder_ty)
+                                  (mkInvalidJoinPointMsg binder binder_ty)
+
+       ; when (lf_check_inline_loop_breakers flags
+               && isStableUnfolding (realIdUnfolding binder)
+               && isStrongLoopBreaker (idOccInfo binder)
+               && isInlinePragma (idInlinePragma binder))
+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
+              -- Only non-rule loop breakers inhibit inlining
+
+       -- We used to check that the dmdTypeDepth of a demand signature never
+       -- exceeds idArity, but that is an unnecessary complication, see
+       -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal
+
+       -- Check that the binder's arity is within the bounds imposed by
+       -- the type and the strictness signature. See Note [exprArity invariant]
+       -- and Note [Trimming arity]
+       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)
+           (text "idArity" <+> ppr (idArity binder) <+>
+           text "exceeds typeArity" <+>
+           ppr (length (typeArity (idType binder))) <> colon <+>
+           ppr binder)
+
+       ; case splitStrictSig (idStrictness binder) of
+           (demands, result_info) | isBotRes result_info ->
+             checkL (demands `lengthAtLeast` idArity binder)
+               (text "idArity" <+> ppr (idArity binder) <+>
+               text "exceeds arity imposed by the strictness signature" <+>
+               ppr (idStrictness binder) <> colon <+>
+               ppr binder)
+           _ -> return ()
+
+       ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
+
+       ; addLoc (UnfoldingOf binder) $
+         lintIdUnfolding binder binder_ty (idUnfolding binder) }
+
+        -- We should check the unfolding, if any, but this is tricky because
+        -- the unfolding is a SimplifiableCoreExpr. Give up for now.
+
+-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
+-- in that it doesn't reject occurrences of the function 'makeStatic' when they
+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
+-- for join points, it skips the outer lambdas that take arguments to the
+-- join point.
+--
+-- See Note [Checking StaticPtrs].
+lintRhs :: Id -> CoreExpr -> LintM OutType
+lintRhs bndr rhs
+    | Just arity <- isJoinId_maybe bndr
+    = lint_join_lams arity arity True rhs
+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
+    = lint_join_lams arity arity False rhs
+  where
+    lint_join_lams 0 _ _ rhs
+      = lintCoreExpr rhs
+
+    lint_join_lams n tot enforce (Lam var expr)
+      = addLoc (LambdaBodyOf var) $
+        lintBinder LambdaBind var $ \ var' ->
+        do { body_ty <- lint_join_lams (n-1) tot enforce expr
+           ; return $ mkLamType var' body_ty }
+
+    lint_join_lams n tot True _other
+      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
+    lint_join_lams _ _ False rhs
+      = markAllJoinsBad $ lintCoreExpr rhs
+          -- Future join point, not yet eta-expanded
+          -- Body is not a tail position
+
+-- Allow applications of the data constructor @StaticPtr@ at the top
+-- but produce errors otherwise.
+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
+  where
+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
+    -- otherwise.
+    go AllowAtTopLevel
+      | (binders0, rhs') <- collectTyBinders rhs
+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
+      = markAllJoinsBad $
+        foldr
+        -- imitate @lintCoreExpr (Lam ...)@
+        (\var loopBinders ->
+          addLoc (LambdaBodyOf var) $
+            lintBinder LambdaBind var $ \var' ->
+              do { body_ty <- loopBinders
+                 ; return $ mkLamType var' body_ty }
+        )
+        -- imitate @lintCoreExpr (App ...)@
+        (do fun_ty <- lintCoreExpr fun
+            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
+        )
+        binders0
+    go _ = markAllJoinsBad $ lintCoreExpr rhs
+
+lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
+lintIdUnfolding bndr bndr_ty uf
+  | isStableUnfolding uf
+  , Just rhs <- maybeUnfoldingTemplate uf
+  = do { ty <- lintRhs bndr rhs
+       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
+lintIdUnfolding  _ _ _
+  = return ()       -- Do not Lint unstable unfoldings, because that leads
+                    -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
+
+{-
+Note [Checking for INLINE loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very suspicious if a strong loop breaker is marked INLINE.
+
+However, the desugarer generates instance methods with INLINE pragmas
+that form a mutually recursive group.  Only after a round of
+simplification are they unravelled.  So we suppress the test for
+the desugarer.
+
+************************************************************************
+*                                                                      *
+\subsection[lintCoreExpr]{lintCoreExpr}
+*                                                                      *
+************************************************************************
+-}
+
+-- For OutType, OutKind, the substitution has been applied,
+--                       but has not been linted yet
+
+type LintedType  = Type -- Substitution applied, and type is linted
+type LintedKind  = Kind
+
+lintCoreExpr :: CoreExpr -> LintM OutType
+-- The returned type has the substitution from the monad
+-- already applied to it:
+--      lintCoreExpr e subst = exprType (subst e)
+--
+-- The returned "type" can be a kind, if the expression is (Type ty)
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreExpr (Var var)
+  = lintVarOcc var 0
+
+lintCoreExpr (Lit lit)
+  = return (literalType lit)
+
+lintCoreExpr (Cast expr co)
+  = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
+       ; co' <- applySubstCo co
+       ; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
+       ; checkValueKind k2 (text "target of cast" <+> quotes (ppr co))
+       ; lintRole co' Representational r
+       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
+       ; return to_ty }
+
+lintCoreExpr (Tick tickish expr)
+  = do case tickish of
+         Breakpoint _ ids -> forM_ ids $ \id -> do
+                               checkDeadIdOcc id
+                               lookupIdInScope id
+         _                -> return ()
+       markAllJoinsBadIf block_joins $ lintCoreExpr expr
+  where
+    block_joins = not (tickish `tickishScopesLike` SoftScope)
+      -- TODO Consider whether this is the correct rule. It is consistent with
+      -- the simplifier's behaviour - cost-centre-scoped ticks become part of
+      -- the continuation, and thus they behave like part of an evaluation
+      -- context, but soft-scoped and non-scoped ticks simply wrap the result
+      -- (see Simplify.simplTick).
+
+lintCoreExpr (Let (NonRec tv (Type ty)) body)
+  | isTyVar tv
+  =     -- See Note [Linting type lets]
+    do  { ty' <- applySubstTy ty
+        ; lintTyBndr tv              $ \ tv' ->
+    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'
+                -- Now extend the substitution so we
+                -- take advantage of it in the body
+        ; extendSubstL tv ty'        $
+          addLoc (BodyOfLetRec [tv]) $
+          lintCoreExpr body } }
+
+lintCoreExpr (Let (NonRec bndr rhs) body)
+  | isId bndr
+  = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
+        ; addLoc (BodyOfLetRec [bndr])
+                 (lintBinder LetBind bndr $ \_ ->
+                  addGoodJoins [bndr] $
+                  lintCoreExpr body) }
+
+  | otherwise
+  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
+
+lintCoreExpr e@(Let (Rec pairs) body)
+  = lintLetBndrs NotTopLevel bndrs $
+    addGoodJoins bndrs             $
+    do  { -- Check that the list of pairs is non-empty
+          checkL (not (null pairs)) (emptyRec e)
+
+          -- Check that there are no duplicated binders
+        ; checkL (null dups) (dupVars dups)
+
+          -- Check that either all the binders are joins, or none
+        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
+            mkInconsistentRecMsg bndrs
+
+        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
+        ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
+  where
+    bndrs = map fst pairs
+    (_, dups) = removeDups compare bndrs
+
+lintCoreExpr e@(App _ _)
+  = addLoc (AnExpr e) $
+    do { fun_ty <- lintCoreFun fun (length args)
+       ; lintCoreArgs fun_ty args }
+  where
+    (fun, args) = collectArgs e
+
+lintCoreExpr (Lam var expr)
+  = addLoc (LambdaBodyOf var) $
+    markAllJoinsBad $
+    lintBinder LambdaBind var $ \ var' ->
+    do { body_ty <- lintCoreExpr expr
+       ; return $ mkLamType var' body_ty }
+
+lintCoreExpr e@(Case scrut var alt_ty alts) =
+       -- Check the scrutinee
+  do { let scrut_diverges = exprIsBottom scrut
+     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut
+     ; (alt_ty, _) <- lintInTy alt_ty
+     ; (var_ty, _) <- lintInTy (idType var)
+
+     -- We used to try to check whether a case expression with no
+     -- alternatives was legitimate, but this didn't work.
+     -- See Note [No alternatives lint check] for details.
+
+     -- See Note [Rules for floating-point comparisons] in PrelRules
+     ; let isLitPat (LitAlt _, _ , _) = True
+           isLitPat _                 = False
+     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
+                        "expression with literal pattern in case " ++
+                        "analysis (see #9238).")
+          $$ text "scrut" <+> ppr scrut)
+
+     ; case tyConAppTyCon_maybe (idType var) of
+         Just tycon
+              | debugIsOn
+              , isAlgTyCon tycon
+              , not (isAbstractTyCon tycon)
+              , null (tyConDataCons tycon)
+              , not scrut_diverges
+              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
+                        -- This can legitimately happen for type families
+                      $ return ()
+         _otherwise -> return ()
+
+        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
+
+     ; subst <- getTCvSubst
+     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
+
+     ; lintBinder CaseBind var $ \_ ->
+       do { -- Check the alternatives
+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts
+          ; checkCaseAlts e scrut_ty alts
+          ; return alt_ty } }
+
+-- This case can't happen; linting types in expressions gets routed through
+-- lintCoreArgs
+lintCoreExpr (Type ty)
+  = failWithL (text "Type found as expression" <+> ppr ty)
+
+lintCoreExpr (Coercion co)
+  = do { (k1, k2, ty1, ty2, role) <- lintInCo co
+       ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }
+
+----------------------
+lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
+            -> LintM Type -- returns type of the *variable*
+lintVarOcc var nargs
+  = do  { checkL (isNonCoVarId var)
+                 (text "Non term variable" <+> ppr var)
+                 -- See CoreSyn Note [Variable occurrences in Core]
+
+        -- Cneck that the type of the occurrence is the same
+        -- as the type of the binding site
+        ; ty   <- applySubstTy (idType var)
+        ; var' <- lookupIdInScope var
+        ; let ty' = idType var'
+        ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty
+
+          -- Check for a nested occurrence of the StaticPtr constructor.
+          -- See Note [Checking StaticPtrs].
+        ; lf <- getLintFlags
+        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
+            checkL (idName var /= makeStaticName) $
+              text "Found makeStatic nested in an expression"
+
+        ; checkDeadIdOcc var
+        ; checkJoinOcc var nargs
+
+        ; return (idType var') }
+
+lintCoreFun :: CoreExpr
+            -> Int        -- Number of arguments (type or val) being passed
+            -> LintM Type -- Returns type of the *function*
+lintCoreFun (Var var) nargs
+  = lintVarOcc var nargs
+
+lintCoreFun (Lam var body) nargs
+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see
+  -- Note [Beta redexes]
+  | nargs /= 0
+  = addLoc (LambdaBodyOf var) $
+    lintBinder LambdaBind var $ \ var' ->
+    do { body_ty <- lintCoreFun body (nargs - 1)
+       ; return $ mkLamType var' body_ty }
+
+lintCoreFun expr nargs
+  = markAllJoinsBadIf (nargs /= 0) $
+    lintCoreExpr expr
+
+------------------
+checkDeadIdOcc :: Id -> LintM ()
+-- Occurrences of an Id should never be dead....
+-- except when we are checking a case pattern
+checkDeadIdOcc id
+  | isDeadOcc (idOccInfo id)
+  = do { in_case <- inCasePat
+       ; checkL in_case
+                (text "Occurrence of a dead Id" <+> ppr id) }
+  | otherwise
+  = return ()
+
+------------------
+checkJoinOcc :: Id -> JoinArity -> LintM ()
+-- Check that if the occurrence is a JoinId, then so is the
+-- binding site, and it's a valid join Id
+checkJoinOcc var n_args
+  | Just join_arity_occ <- isJoinId_maybe var
+  = do { mb_join_arity_bndr <- lookupJoinId var
+       ; case mb_join_arity_bndr of {
+           Nothing -> -- Binder is not a join point
+                      addErrL (invalidJoinOcc var) ;
+
+           Just join_arity_bndr ->
+
+    do { checkL (join_arity_bndr == join_arity_occ) $
+           -- Arity differs at binding site and occurrence
+         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ
+
+       ; checkL (n_args == join_arity_occ) $
+           -- Arity doesn't match #args
+         mkBadJumpMsg var join_arity_occ n_args } } }
+
+  | otherwise
+  = return ()
+
+{-
+Note [No alternatives lint check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case expressions with no alternatives are odd beasts, and it would seem
+like they would worth be looking at in the linter (cf #10180). We
+used to check two things:
+
+* exprIsHNF is false: it would *seem* to be terribly wrong if
+  the scrutinee was already in head normal form.
+
+* exprIsBottom is true: we should be able to see why GHC believes the
+  scrutinee is diverging for sure.
+
+It was already known that the second test was not entirely reliable.
+Unfortunately (#13990), the first test turned out not to be reliable
+either. Getting the checks right turns out to be somewhat complicated.
+
+For example, suppose we have (comment 8)
+
+  data T a where
+    TInt :: T Int
+
+  absurdTBool :: T Bool -> a
+  absurdTBool v = case v of
+
+  data Foo = Foo !(T Bool)
+
+  absurdFoo :: Foo -> a
+  absurdFoo (Foo x) = absurdTBool x
+
+GHC initially accepts the empty case because of the GADT conditions. But then
+we inline absurdTBool, getting
+
+  absurdFoo (Foo x) = case x of
+
+x is in normal form (because the Foo constructor is strict) but the
+case is empty. To avoid this problem, GHC would have to recognize
+that matching on Foo x is already absurd, which is not so easy.
+
+More generally, we don't really know all the ways that GHC can
+lose track of why an expression is bottom, so we shouldn't make too
+much fuss when that happens.
+
+
+Note [Beta redexes]
+~~~~~~~~~~~~~~~~~~~
+Consider:
+
+  join j @x y z = ... in
+  (\@x y z -> jump j @x y z) @t e1 e2
+
+This is clearly ill-typed, since the jump is inside both an application and a
+lambda, either of which is enough to disqualify it as a tail call (see Note
+[Invariants on join points] in CoreSyn). However, strictly from a
+lambda-calculus perspective, the term doesn't go wrong---after the two beta
+reductions, the jump *is* a tail call and everything is fine.
+
+Why would we want to allow this when we have let? One reason is that a compound
+beta redex (that is, one with more than one argument) has different scoping
+rules: naively reducing the above example using lets will capture any free
+occurrence of y in e2. More fundamentally, type lets are tricky; many passes,
+such as Float Out, tacitly assume that the incoming program's type lets have
+all been dealt with by the simplifier. Thus we don't want to let-bind any types
+in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately
+before Float Out.
+
+All that said, currently CoreSubst.simpleOptPgm is the only thing using this
+loophole, doing so to avoid re-traversing large functions (beta-reducing a type
+lambda without introducing a type let requires a substitution). TODO: Improve
+simpleOptPgm so that we can forget all this ever happened.
+
+************************************************************************
+*                                                                      *
+\subsection[lintCoreArgs]{lintCoreArgs}
+*                                                                      *
+************************************************************************
+
+The basic version of these functions checks that the argument is a
+subtype of the required type, as one would expect.
+-}
+
+
+lintCoreArgs  :: OutType -> [CoreArg] -> LintM OutType
+lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args
+
+lintCoreArg  :: OutType -> CoreArg -> LintM OutType
+lintCoreArg fun_ty (Type arg_ty)
+  = do { checkL (not (isCoercionTy arg_ty))
+                (text "Unnecessary coercion-to-type injection:"
+                  <+> ppr arg_ty)
+       ; arg_ty' <- applySubstTy arg_ty
+       ; lintTyApp fun_ty arg_ty' }
+
+lintCoreArg fun_ty arg
+  = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg
+           -- See Note [Levity polymorphism invariants] in CoreSyn
+       ; lintL (not (isTypeLevPoly arg_ty))
+           (text "Levity-polymorphic argument:" <+>
+             (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))
+          -- check for levity polymorphism first, because otherwise isUnliftedType panics
+
+       ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
+                (mkLetAppMsg arg)
+       ; lintValApp arg fun_ty arg_ty }
+
+-----------------
+lintAltBinders :: OutType     -- Scrutinee type
+               -> OutType     -- Constructor type
+               -> [OutVar]    -- Binders
+               -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintAltBinders scrut_ty con_ty []
+  = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
+lintAltBinders scrut_ty con_ty (bndr:bndrs)
+  | isTyVar bndr
+  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
+       ; lintAltBinders scrut_ty con_ty' bndrs }
+  | otherwise
+  = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
+       ; lintAltBinders scrut_ty con_ty' bndrs }
+
+-----------------
+lintTyApp :: OutType -> OutType -> LintM OutType
+lintTyApp fun_ty arg_ty
+  | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
+  = do  { lintTyKind tv arg_ty
+        ; in_scope <- getInScope
+        -- substTy needs the set of tyvars in scope to avoid generating
+        -- uniques that are already in scope.
+        -- See Note [The substitution invariant] in TyCoRep
+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }
+
+  | otherwise
+  = failWithL (mkTyAppMsg fun_ty arg_ty)
+
+-----------------
+lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
+lintValApp arg fun_ty arg_ty
+  | Just (arg,res) <- splitFunTy_maybe fun_ty
+  = do { ensureEqTys arg arg_ty err1
+       ; return res }
+  | otherwise
+  = failWithL err2
+  where
+    err1 = mkAppMsg       fun_ty arg_ty arg
+    err2 = mkNonFunAppMsg fun_ty arg_ty arg
+
+lintTyKind :: OutTyVar -> OutType -> LintM ()
+-- Both args have had substitution applied
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintTyKind tyvar arg_ty
+        -- Arg type might be boxed for a function with an uncommitted
+        -- tyvar; notably this is used so that we can give
+        --      error :: forall a:*. String -> a
+        -- and then apply it to both boxed and unboxed types.
+  = do { arg_kind <- lintType arg_ty
+       ; unless (arg_kind `eqType` tyvar_kind)
+                (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) }
+  where
+    tyvar_kind = tyVarKind tyvar
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lintCoreAlts]{lintCoreAlts}
+*                                                                      *
+************************************************************************
+-}
+
+checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b1) Check that the DEFAULT comes first, if it exists
+-- b2) Check that the others are in increasing order
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+--     the simplifier correctly eliminates case that can't
+--     possibly match.
+
+checkCaseAlts e ty alts =
+  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
+
+          -- For types Int#, Word# with an infinite (well, large!) number of
+          -- possible values, there should usually be a DEFAULT case
+          -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to
+          -- have *no* case alternatives.
+          -- In effect, this is a kind of partial test. I suppose it's possible
+          -- that we might *know* that 'x' was 1 or 2, in which case
+          --   case x of { 1 -> e1; 2 -> e2 }
+          -- would be fine.
+     ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)
+              (nonExhaustiveAltsMsg e) }
+  where
+    (con_alts, maybe_deflt) = findDefault alts
+
+        -- Check that successive alternatives have strictly increasing tags
+    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
+    increasing_tag _                         = True
+
+    non_deflt (DEFAULT, _, _) = False
+    non_deflt _               = True
+
+    is_infinite_ty = case tyConAppTyCon_maybe ty of
+                        Nothing    -> False
+                        Just tycon -> isPrimTyCon tycon
+
+lintAltExpr :: CoreExpr -> OutType -> LintM ()
+lintAltExpr expr ann_ty
+  = do { actual_ty <- lintCoreExpr expr
+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
+
+lintCoreAlt :: OutType          -- Type of scrutinee
+            -> OutType          -- Type of the alternative
+            -> CoreAlt
+            -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
+  do { lintL (null args) (mkDefaultArgsMsg args)
+     ; lintAltExpr rhs alt_ty }
+
+lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
+  | litIsLifted lit
+  = failWithL integerScrutinisedMsg
+  | otherwise
+  = do { lintL (null args) (mkDefaultArgsMsg args)
+       ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
+       ; lintAltExpr rhs alt_ty }
+  where
+    lit_ty = literalType lit
+
+lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+  | isNewTyCon (dataConTyCon con)
+  = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
+  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
+  = addLoc (CaseAlt alt) $  do
+    {   -- First instantiate the universally quantified
+        -- type variables of the data constructor
+        -- We've already check
+      lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
+    ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys
+
+        -- And now bring the new binders into scope
+    ; lintBinders CasePatBind args $ \ args' -> do
+    { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
+    ; lintAltExpr rhs alt_ty } }
+
+  | otherwise   -- Scrut-ty is wrong shape
+  = addErrL (mkBadAltMsg scrut_ty alt)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lint-types]{Types}
+*                                                                      *
+************************************************************************
+-}
+
+-- When we lint binders, we (one at a time and in order):
+--  1. Lint var types or kinds (possibly substituting)
+--  2. Add the binder to the in scope set, and if its a coercion var,
+--     we may extend the substitution to reflect its (possibly) new kind
+lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
+lintBinders _    []         linterF = linterF []
+lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->
+                                      lintBinders site vars $ \ vars' ->
+                                      linterF (var':vars')
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
+lintBinder site var linterF
+  | isTyVar var = lintTyBndr                  var linterF
+  | isCoVar var = lintCoBndr                  var linterF
+  | otherwise   = lintIdBndr NotTopLevel site var linterF
+
+lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
+lintTyBndr tv thing_inside
+  = do { subst <- getTCvSubst
+       ; let (subst', tv') = substTyVarBndr subst tv
+       ; lintKind (varType tv')
+       ; updateTCvSubst subst' (thing_inside tv') }
+
+lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a
+lintCoBndr cv thing_inside
+  = do { subst <- getTCvSubst
+       ; let (subst', cv') = substCoVarBndr subst cv
+       ; lintKind (varType cv')
+       ; lintL (isCoVarType (varType cv'))
+               (text "CoVar with non-coercion type:" <+> pprTyVar cv)
+       ; updateTCvSubst subst' (thing_inside cv') }
+
+lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a
+lintLetBndrs top_lvl ids linterF
+  = go ids
+  where
+    go []       = linterF
+    go (id:ids) = lintIdBndr top_lvl LetBind id  $ \_ ->
+                  go ids
+
+lintIdBndr :: TopLevelFlag -> BindingSite
+           -> InVar -> (OutVar -> LintM a) -> LintM a
+-- Do substitution on the type of a binder and add the var with this
+-- new type to the in-scope set of the second argument
+-- ToDo: lint its rules
+lintIdBndr top_lvl bind_site id linterF
+  = ASSERT2( isId id, ppr id )
+    do { flags <- getLintFlags
+       ; checkL (not (lf_check_global_ids flags) || isLocalId id)
+                (text "Non-local Id binder" <+> ppr id)
+                -- See Note [Checking for global Ids]
+
+       -- Check that if the binder is nested, it is not marked as exported
+       ; checkL (not (isExportedId id) || is_top_lvl)
+           (mkNonTopExportedMsg id)
+
+       -- Check that if the binder is nested, it does not have an external name
+       ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)
+           (mkNonTopExternalNameMsg id)
+
+       ; (ty, k) <- lintInTy (idType id)
+
+          -- See Note [Levity polymorphism invariants] in CoreSyn
+       ; lintL (isJoinId id || not (isKindLevPoly k))
+           (text "Levity-polymorphic binder:" <+>
+                 (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
+
+       -- Check that a join-id is a not-top-level let-binding
+       ; when (isJoinId id) $
+         checkL (not is_top_lvl && is_let_bind) $
+         mkBadJoinBindMsg id
+
+       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);
+       -- if so, it should be a CoVar, and checked by lintCoVarBndr
+       ; lintL (not (isCoVarType ty))
+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr ty)
+
+       ; let id' = setIdType id ty
+       ; addInScopeVar id' $ (linterF id') }
+  where
+    is_top_lvl = isTopLevel top_lvl
+    is_let_bind = case bind_site of
+                    LetBind -> True
+                    _       -> False
+
+{-
+%************************************************************************
+%*                                                                      *
+             Types
+%*                                                                      *
+%************************************************************************
+-}
+
+lintTypes :: DynFlags
+          -> [TyCoVar]   -- Treat these as in scope
+          -> [Type]
+          -> Maybe MsgDoc -- Nothing => OK
+lintTypes dflags vars tys
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = emptyInScopeSet
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = lintBinders LambdaBind vars $ \_ ->
+             mapM_ lintInTy tys
+
+lintInTy :: InType -> LintM (LintedType, LintedKind)
+-- Types only, not kinds
+-- Check the type, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInTy ty
+  = addLoc (InType ty) $
+    do  { ty' <- applySubstTy ty
+        ; k  <- lintType ty'
+        ; lintKind k  -- The kind returned by lintType is already
+                      -- a LintedKind but we also want to check that
+                      -- k :: *, which lintKind does
+        ; return (ty', k) }
+
+checkTyCon :: TyCon -> LintM ()
+checkTyCon tc
+  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
+
+-------------------
+lintType :: OutType -> LintM LintedKind
+-- The returned Kind has itself been linted
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintType (TyVarTy tv)
+  = do { checkL (isTyVar tv) (mkBadTyVarMsg tv)
+       ; lintTyCoVarInScope tv
+       ; return (tyVarKind tv) }
+         -- We checked its kind when we added it to the envt
+
+lintType ty@(AppTy t1 t2)
+  | TyConApp {} <- t1
+  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty
+  | otherwise
+  = do { k1 <- lintType t1
+       ; k2 <- lintType t2
+       ; lint_ty_app ty k1 [(t2,k2)] }
+
+lintType ty@(TyConApp tc tys)
+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags
+       ; lintTySynFamApp report_unsat ty tc tys }
+
+  | isFunTyCon tc
+  , tys `lengthIs` 4
+    -- We should never see a saturated application of funTyCon; such
+    -- applications should be represented with the FunTy constructor.
+    -- See Note [Linting function types] and
+    -- Note [Representation of function types].
+  = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
+
+  | otherwise  -- Data types, data families, primitive types
+  = do { checkTyCon tc
+       ; ks <- mapM lintType tys
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+-- arrows can related *unlifted* kinds, so this has to be separate from
+-- a dependent forall.
+lintType ty@(FunTy _ t1 t2)
+  = do { k1 <- lintType t1
+       ; k2 <- lintType t2
+       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
+
+lintType t@(ForAllTy (Bndr tv _vis) ty)
+  -- forall over types
+  | isTyVar tv
+  = lintTyBndr tv $ \tv' ->
+    do { k <- lintType ty
+       ; checkValueKind k (text "the body of forall:" <+> ppr t)
+       ; case occCheckExpand [tv'] k of  -- See Note [Stupid type synonyms]
+           Just k' -> return k'
+           Nothing -> failWithL (hang (text "Variable escape in forall:")
+                                    2 (vcat [ text "type:" <+> ppr t
+                                            , text "kind:" <+> ppr k ]))
+    }
+
+lintType t@(ForAllTy (Bndr cv _vis) ty)
+  -- forall over coercions
+  = do { lintL (isCoVar cv)
+               (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t)
+       ; lintL (cv `elemVarSet` tyCoVarsOfType ty)
+               (text "Covar does not occur in the body:" <+> ppr t)
+       ; lintCoBndr cv $ \_ ->
+    do { k <- lintType ty
+       ; checkValueKind k (text "the body of forall:" <+> ppr t)
+       ; return liftedTypeKind
+           -- We don't check variable escape here. Namely, k could refer to cv'
+           -- See Note [NthCo and newtypes] in TyCoRep
+    }}
+
+lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
+
+lintType (CastTy ty co)
+  = do { k1 <- lintType ty
+       ; (k1', k2) <- lintStarCoercion co
+       ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1)
+       ; return k2 }
+
+lintType (CoercionTy co)
+  = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
+       ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }
+
+{- Note [Stupid type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#14939)
+   type Alg cls ob = ob
+   f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b
+
+Here 'cls' appears free in b's kind, which would usually be illegal
+(because in (forall a. ty), ty's kind should not mention 'a'). But
+#in this case (Alg cls *) = *, so all is well.  Currently we allow
+this, and make Lint expand synonyms where necessary to make it so.
+
+c.f. TcUnify.occCheckExpand and CoreUtils.coreAltsType which deal
+with the same problem. A single systematic solution eludes me.
+-}
+
+-----------------
+lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind
+-- The TyCon is a type synonym or a type family (not a data family)
+-- See Note [Linting type synonym applications]
+-- c.f. TcValidity.check_syn_tc_app
+lintTySynFamApp report_unsat ty tc tys
+  | report_unsat   -- Report unsaturated only if report_unsat is on
+  , tys `lengthLessThan` tyConArity tc
+  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
+
+  -- Deal with type synonyms
+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
+  = do { -- Kind-check the argument types, but without reporting
+         -- un-saturated type families/synonyms
+         ks <- setReportUnsat False (mapM lintType tys)
+
+       ; when report_unsat $
+         do { _ <- lintType expanded_ty
+            ; return () }
+
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+  -- Otherwise this must be a type family
+  | otherwise
+  = do { ks <- mapM lintType tys
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+-----------------
+lintKind :: OutKind -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintKind k = do { sk <- lintType k
+                ; unless (classifiesTypeWithValues sk)
+                         (addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
+                                      2 (text "has kind:" <+> ppr sk))) }
+
+-----------------
+-- Confirms that a type is really *, #, Constraint etc
+checkValueKind :: OutKind -> SDoc -> LintM ()
+checkValueKind k doc
+  = lintL (classifiesTypeWithValues k)
+          (text "Non-*-like kind when *-like expected:" <+> ppr k $$
+           text "when checking" <+> doc)
+
+-----------------
+lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2
+                       -- or lintarrow "coercion `blah'" k1 k2
+  = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1))
+       ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result")   k2))
+       ; return liftedTypeKind }
+  where
+    msg ar k
+      = vcat [ hang (text "Ill-kinded" <+> ar)
+                  2 (text "in" <+> what)
+             , what <+> text "kind:" <+> ppr k ]
+
+-----------------
+lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
+lint_ty_app ty k tys
+  = lint_app (text "type" <+> quotes (ppr ty)) k tys
+
+----------------
+lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
+lint_co_app ty k tys
+  = lint_app (text "coercion" <+> quotes (ppr ty)) k tys
+
+----------------
+lintTyLit :: TyLit -> LintM ()
+lintTyLit (NumTyLit n)
+  | n >= 0    = return ()
+  | otherwise = failWithL msg
+    where msg = text "Negative type literal:" <+> integer n
+lintTyLit (StrTyLit _) = return ()
+
+lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
+-- (lint_app d fun_kind arg_tys)
+--    We have an application (f arg_ty1 .. arg_tyn),
+--    where f :: fun_kind
+-- Takes care of linting the OutTypes
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lint_app doc kfn kas
+    = do { in_scope <- getInScope
+         -- We need the in_scope set to satisfy the invariant in
+         -- Note [The substitution invariant] in TyCoRep
+         ; foldlM (go_app in_scope) kfn kas }
+  where
+    fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc
+                          , nest 2 (text "Function kind =" <+> ppr kfn)
+                          , nest 2 (text "Arg kinds =" <+> ppr kas)
+                          , extra ]
+
+    go_app in_scope kfn tka
+      | Just kfn' <- coreView kfn
+      = go_app in_scope kfn' tka
+
+    go_app _ (FunTy _ kfa kfb) tka@(_,ka)
+      = do { unless (ka `eqType` kfa) $
+             addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))
+           ; return kfb }
+
+    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka)
+      = do { let kv_kind = varType kv
+           ; unless (ka `eqType` kv_kind) $
+             addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka)))
+           ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn }
+
+    go_app _ kfn ka
+       = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka)))
+
+{- *********************************************************************
+*                                                                      *
+        Linting rules
+*                                                                      *
+********************************************************************* -}
+
+lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()
+lintCoreRule _ _ (BuiltinRule {})
+  = return ()  -- Don't bother
+
+lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
+                                   , ru_args = args, ru_rhs = rhs })
+  = lintBinders LambdaBind bndrs $ \ _ ->
+    do { lhs_ty <- lintCoreArgs fun_ty args
+       ; rhs_ty <- case isJoinId_maybe fun of
+                     Just join_arity
+                       -> do { checkL (args `lengthIs` join_arity) $
+                                mkBadJoinPointRuleMsg fun join_arity rule
+                               -- See Note [Rules for join points]
+                             ; lintCoreExpr rhs }
+                     _ -> markAllJoinsBad $ lintCoreExpr rhs
+       ; ensureEqTys lhs_ty rhs_ty $
+         (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty
+                            , text "rhs type:" <+> ppr rhs_ty
+                            , text "fun_ty:" <+> ppr fun_ty ])
+       ; let bad_bndrs = filter is_bad_bndr bndrs
+
+       ; checkL (null bad_bndrs)
+                (rule_doc <+> text "unbound" <+> ppr bad_bndrs)
+            -- See Note [Linting rules]
+    }
+  where
+    rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon
+
+    lhs_fvs = exprsFreeVars args
+    rhs_fvs = exprFreeVars rhs
+
+    is_bad_bndr :: Var -> Bool
+    -- See Note [Unbound RULE binders] in Rules
+    is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs)
+                    && bndr `elemVarSet` rhs_fvs
+                    && isNothing (isReflCoVar_maybe bndr)
+
+
+{- Note [Linting rules]
+~~~~~~~~~~~~~~~~~~~~~~~
+It's very bad if simplifying a rule means that one of the template
+variables (ru_bndrs) that /is/ mentioned on the RHS becomes
+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in
+#10602, SpecConstr stupidly constructed a rule like
+
+  forall x,c1,c2.
+     f (x |> c1 |> c2) = ....
+
+But simplExpr collapses those coercions into one.  (Indeed in
+#10602, it collapsed to the identity and was removed altogether.)
+
+We don't have a great story for what to do here, but at least
+this check will nail it.
+
+NB (#11643): it's possible that a variable listed in the
+binders becomes not-mentioned on both LHS and RHS.  Here's a silly
+example:
+   RULE forall x y. f (g x y) = g (x+1) (y-1)
+And suppose worker/wrapper decides that 'x' is Absent.  Then
+we'll end up with
+   RULE forall x y. f ($gw y) = $gw (x+1)
+This seems sufficiently obscure that there isn't enough payoff to
+try to trim the forall'd binder list.
+
+Note [Rules for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A join point cannot be partially applied. However, the left-hand side of a rule
+for a join point is effectively a *pattern*, not a piece of code, so there's an
+argument to be made for allowing a situation like this:
+
+  join $sj :: Int -> Int -> String
+       $sj n m = ...
+       j :: forall a. Eq a => a -> a -> String
+       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}
+       j @a $dEq x y = ...
+
+Applying this rule can't turn a well-typed program into an ill-typed one, so
+conceivably we could allow it. But we can always eta-expand such an
+"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact
+the simplifier would have to in order to deal with the RHS. So we take a
+conservative view and don't allow undersaturated rules for join points. See
+Note [Rules and join points] in OccurAnal for further discussion.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+         Linting coercions
+*                                                                      *
+************************************************************************
+-}
+
+lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+  = addLoc (InCo co) $
+    do  { co' <- applySubstCo co
+        ; lintCoercion co' }
+
+-- lints a coercion, confirming that its lh kind and its rh kind are both *
+-- also ensures that the role is Nominal
+lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)
+lintStarCoercion g
+  = do { (k1, k2, t1, t2, r) <- lintCoercion g
+       ; checkValueKind k1 (text "the kind of the left type in" <+> ppr g)
+       ; checkValueKind k2 (text "the kind of the right type in" <+> ppr g)
+       ; lintRole g Nominal r
+       ; return (t1, t2) }
+
+lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
+-- Check the kind of a coercion term, returning the kind
+-- Post-condition: the returned OutTypes are lint-free
+--
+-- If   lintCoercion co = (k1, k2, s1, s2, r)
+-- then co :: s1 ~r s2
+--      s1 :: k1
+--      s2 :: k2
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoercion (Refl ty)
+  = do { k <- lintType ty
+       ; return (k, k, ty, ty, Nominal) }
+
+lintCoercion (GRefl r ty MRefl)
+  = do { k <- lintType ty
+       ; return (k, k, ty, ty, r) }
+
+lintCoercion (GRefl r ty (MCo co))
+  = do { k <- lintType ty
+       ; (_, _, k1, k2, r') <- lintCoercion co
+       ; ensureEqTys k k1
+               (hang (text "GRefl coercion kind mis-match:" <+> ppr co)
+                   2 (vcat [ppr ty, ppr k, ppr k1]))
+       ; lintRole co Nominal r'
+       ; return (k1, k2, ty, mkCastTy ty co, r) }
+
+lintCoercion co@(TyConAppCo r tc cos)
+  | tc `hasKey` funTyConKey
+  , [_rep1,_rep2,_co1,_co2] <- cos
+  = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co)
+       } -- All saturated TyConAppCos should be FunCos
+
+  | Just {} <- synTyConDefn_maybe tc
+  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)
+
+  | otherwise
+  = do { checkTyCon tc
+       ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos
+       ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's)
+       ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks)
+       ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs
+       ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) }
+
+lintCoercion co@(AppCo co1 co2)
+  | TyConAppCo {} <- co1
+  = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)
+  | Just (TyConApp {}, _) <- isReflCo_maybe co1
+  = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
+  | otherwise
+  = do { (k1,  k2,  s1, s2, r1) <- lintCoercion co1
+       ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2
+       ; k3 <- lint_co_app co k1 [(t1,k'1)]
+       ; k4 <- lint_co_app co k2 [(t2,k'2)]
+       ; if r1 == Phantom
+         then lintL (r2 == Phantom || r2 == Nominal)
+                     (text "Second argument in AppCo cannot be R:" $$
+                      ppr co)
+         else lintRole co Nominal r2
+       ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) }
+
+----------
+lintCoercion (ForAllCo tv1 kind_co co)
+  -- forall over types
+  | isTyVar tv1
+  = do { (_, k2) <- lintStarCoercion kind_co
+       ; let tv2 = setTyVarKind tv1 k2
+       ; addInScopeVar tv1 $
+    do {
+       ; (k3, k4, t1, t2, r) <- lintCoercion co
+       ; in_scope <- getInScope
+       ; let tyl = mkInvForAllTy tv1 t1
+             subst = mkTvSubst in_scope $
+                     -- We need both the free vars of the `t2` and the
+                     -- free vars of the range of the substitution in
+                     -- scope. All the free vars of `t2` and `kind_co` should
+                     -- already be in `in_scope`, because they've been
+                     -- linted and `tv2` has the same unique as `tv1`.
+                     -- See Note [The substitution invariant]
+                     unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)
+             tyr = mkInvForAllTy tv2 $
+                   substTy subst t2
+       ; return (k3, k4, tyl, tyr, r) } }
+
+lintCoercion (ForAllCo cv1 kind_co co)
+  -- forall over coercions
+  = ASSERT( isCoVar cv1 )
+    do { lintL (almostDevoidCoVarOfCo cv1 co)
+               (text "Covar can only appear in Refl and GRefl: " <+> ppr co)
+       ; (_, k2) <- lintStarCoercion kind_co
+       ; let cv2 = setVarType cv1 k2
+       ; addInScopeVar cv1 $
+    do {
+       ; (k3, k4, t1, t2, r) <- lintCoercion co
+       ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co)
+       ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co)
+           -- See Note [Weird typing rule for ForAllTy] in Type
+       ; in_scope <- getInScope
+       ; let tyl   = mkTyCoInvForAllTy cv1 t1
+             r2    = coVarRole cv1
+             kind_co' = downgradeRole r2 Nominal kind_co
+             eta1  = mkNthCo r2 2 kind_co'
+             eta2  = mkNthCo r2 3 kind_co'
+             subst = mkCvSubst in_scope $
+                     -- We need both the free vars of the `t2` and the
+                     -- free vars of the range of the substitution in
+                     -- scope. All the free vars of `t2` and `kind_co` should
+                     -- already be in `in_scope`, because they've been
+                     -- linted and `cv2` has the same unique as `cv1`.
+                     -- See Note [The substitution invariant]
+                     unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2)
+                                          `mkTransCo` (mkSymCo eta2))
+             tyr = mkTyCoInvForAllTy cv2 $
+                   substTy subst t2
+       ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } }
+                   -- See Note [Weird typing rule for ForAllTy] in Type
+
+lintCoercion co@(FunCo r co1 co2)
+  = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
+       ; (k2,k'2,s2,t2,r2) <- lintCoercion co2
+       ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2
+       ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2
+       ; lintRole co1 r r1
+       ; lintRole co2 r r2
+       ; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) }
+
+lintCoercion (CoVarCo cv)
+  | not (isCoVar cv)
+  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)
+                  2 (text "With offending type:" <+> ppr (varType cv)))
+  | otherwise
+  = do { lintTyCoVarInScope cv
+       ; cv' <- lookupIdInScope cv
+       ; lintUnliftedCoVar cv
+       ; return $ coVarKindsTypesRole cv' }
+
+-- See Note [Bad unsafe coercion]
+lintCoercion co@(UnivCo prov r ty1 ty2)
+  = do { k1 <- lintType ty1
+       ; k2 <- lintType ty2
+       ; case prov of
+           UnsafeCoerceProv -> return ()  -- no extra checks
+
+           PhantomProv kco    -> do { lintRole co Phantom r
+                                    ; check_kinds kco k1 k2 }
+
+           ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $
+                                          mkBadProofIrrelMsg ty1 co
+                                    ; lintL (isCoercionTy ty2) $
+                                          mkBadProofIrrelMsg ty2 co
+                                    ; check_kinds kco k1 k2 }
+
+           PluginProv _     -> return ()  -- no extra checks
+
+       ; when (r /= Phantom && classifiesTypeWithValues k1
+                            && classifiesTypeWithValues k2)
+              (checkTypes ty1 ty2)
+       ; return (k1, k2, ty1, ty2, r) }
+   where
+     report s = hang (text $ "Unsafe coercion: " ++ s)
+                     2 (vcat [ text "From:" <+> ppr ty1
+                             , text "  To:" <+> ppr ty2])
+     isUnBoxed :: PrimRep -> Bool
+     isUnBoxed = not . isGcPtrRep
+
+       -- see #9122 for discussion of these checks
+     checkTypes t1 t2
+       = do { checkWarnL (not lev_poly1)
+                         (report "left-hand type is levity-polymorphic")
+            ; checkWarnL (not lev_poly2)
+                         (report "right-hand type is levity-polymorphic")
+            ; when (not (lev_poly1 || lev_poly2)) $
+              do { checkWarnL (reps1 `equalLength` reps2)
+                              (report "between values with different # of reps")
+                 ; zipWithM_ validateCoercion reps1 reps2 }}
+       where
+         lev_poly1 = isTypeLevPoly t1
+         lev_poly2 = isTypeLevPoly t2
+
+         -- don't look at these unless lev_poly1/2 are False
+         -- Otherwise, we get #13458
+         reps1 = typePrimRep t1
+         reps2 = typePrimRep t2
+
+     validateCoercion :: PrimRep -> PrimRep -> LintM ()
+     validateCoercion rep1 rep2
+       = do { dflags <- getDynFlags
+            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
+                         (report "between unboxed and boxed value")
+            ; checkWarnL (TyCon.primRepSizeB dflags rep1
+                           == TyCon.primRepSizeB dflags rep2)
+                         (report "between unboxed values of different size")
+            ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
+                                   (TyCon.primRepIsFloat rep2)
+            ; case fl of
+                Nothing    -> addWarnL (report "between vector types")
+                Just False -> addWarnL (report "between float and integral values")
+                _          -> return ()
+            }
+
+     check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco
+                                ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  co)
+                                ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }
+
+
+lintCoercion (SymCo co)
+  = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
+       ; return (k2, k1, ty2, ty1, r) }
+
+lintCoercion co@(TransCo co1 co2)
+  = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1
+       ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2
+       ; ensureEqTys ty1b ty2a
+               (hang (text "Trans coercion mis-match:" <+> ppr co)
+                   2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
+       ; lintRole co r1 r2
+       ; return (k1a, k2b, ty1a, ty2b, r1) }
+
+lintCoercion the_co@(NthCo r0 n co)
+  = do { (_, _, s, t, r) <- lintCoercion co
+       ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
+         { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t))
+             -- works for both tyvar and covar
+             | n == 0
+             ,  (isForAllTy_ty s && isForAllTy_ty t)
+             || (isForAllTy_co s && isForAllTy_co t)
+             -> do { lintRole the_co Nominal r0
+                   ; return (ks, kt, ts, tt, r0) }
+             where
+               ts = varType tcv_s
+               tt = varType tcv_t
+               ks = typeKind ts
+               kt = typeKind tt
+
+         ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
+         { (Just (tc_s, tys_s), Just (tc_t, tys_t))
+             | tc_s == tc_t
+             , isInjectiveTyCon tc_s r
+                 -- see Note [NthCo and newtypes] in TyCoRep
+             , tys_s `equalLength` tys_t
+             , tys_s `lengthExceeds` n
+             -> do { lintRole the_co tr r0
+                   ; return (ks, kt, ts, tt, r0) }
+             where
+               ts = getNth tys_s n
+               tt = getNth tys_t n
+               tr = nthRole r tc_s n
+               ks = typeKind ts
+               kt = typeKind tt
+
+         ; _ -> failWithL (hang (text "Bad getNth:")
+                              2 (ppr the_co $$ ppr s $$ ppr t)) }}}
+
+lintCoercion the_co@(LRCo lr co)
+  = do { (_,_,s,t,r) <- lintCoercion co
+       ; lintRole co Nominal r
+       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
+           (Just s_pr, Just t_pr)
+             -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal)
+             where
+               s_pick  = pickLR lr s_pr
+               t_pick  = pickLR lr t_pr
+               ks_pick = typeKind s_pick
+               kt_pick = typeKind t_pick
+
+           _ -> failWithL (hang (text "Bad LRCo:")
+                              2 (ppr the_co $$ ppr s $$ ppr t)) }
+
+lintCoercion (InstCo co arg)
+  = do { (k3, k4, t1',t2', r) <- lintCoercion co
+       ; (k1',k2',s1,s2, r') <- lintCoercion arg
+       ; lintRole arg Nominal r'
+       ; in_scope <- getInScope
+       ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of
+         -- forall over tvar
+         { (Just (tv1,t1), Just (tv2,t2))
+             | k1' `eqType` tyVarKind tv1
+             , k2' `eqType` tyVarKind tv2
+             -> return (k3, k4,
+                        substTyWithInScope in_scope [tv1] [s1] t1,
+                        substTyWithInScope in_scope [tv2] [s2] t2, r)
+             | otherwise
+             -> failWithL (text "Kind mis-match in inst coercion")
+         ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of
+         -- forall over covar
+         { (Just (cv1, t1), Just (cv2, t2))
+             | k1' `eqType` varType cv1
+             , k2' `eqType` varType cv2
+             , CoercionTy s1' <- s1
+             , CoercionTy s2' <- s2
+             -> do { return $
+                       (liftedTypeKind, liftedTypeKind
+                          -- See Note [Weird typing rule for ForAllTy] in Type
+                       , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1
+                       , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2
+                       , r) }
+             | otherwise
+             -> failWithL (text "Kind mis-match in inst coercion")
+         ; _ -> failWithL (text "Bad argument of inst") }}}
+
+lintCoercion co@(AxiomInstCo con ind cos)
+  = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))
+                (bad_ax (text "index out of range"))
+       ; let CoAxBranch { cab_tvs   = ktvs
+                        , cab_cvs   = cvs
+                        , cab_roles = roles
+                        , cab_lhs   = lhs
+                        , cab_rhs   = rhs } = coAxiomNthBranch con ind
+       ; unless (cos `equalLength` (ktvs ++ cvs)) $
+           bad_ax (text "lengths")
+       ; subst <- getTCvSubst
+       ; let empty_subst = zapTCvSubst subst
+       ; (subst_l, subst_r) <- foldlM check_ki
+                                      (empty_subst, empty_subst)
+                                      (zip3 (ktvs ++ cvs) roles cos)
+       ; let lhs' = substTys subst_l lhs
+             rhs' = substTy  subst_r rhs
+             fam_tc = coAxiomTyCon con
+       ; case checkAxInstCo co of
+           Just bad_branch -> bad_ax $ text "inconsistent with" <+>
+                                       pprCoAxBranch fam_tc bad_branch
+           Nothing -> return ()
+       ; let s2 = mkTyConApp fam_tc lhs'
+       ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }
+  where
+    bad_ax what = addErrL (hang (text  "Bad axiom application" <+> parens what)
+                        2 (ppr co))
+
+    check_ki (subst_l, subst_r) (ktv, role, arg)
+      = do { (k', k'', s', t', r) <- lintCoercion arg
+           ; lintRole arg role r
+           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)
+                 ktv_kind_r = substTy subst_r (tyVarKind ktv)
+           ; unless (k' `eqType` ktv_kind_l)
+                    (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] ))
+           ; unless (k'' `eqType` ktv_kind_r)
+                    (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] ))
+           ; return (extendTCvSubst subst_l ktv s',
+                     extendTCvSubst subst_r ktv t') }
+
+lintCoercion (KindCo co)
+  = do { (k1, k2, _, _, _) <- lintCoercion co
+       ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }
+
+lintCoercion (SubCo co')
+  = do { (k1,k2,s,t,r) <- lintCoercion co'
+       ; lintRole co' Nominal r
+       ; return (k1,k2,s,t,Representational) }
+
+lintCoercion this@(AxiomRuleCo co cs)
+  = do { eqs <- mapM lintCoercion cs
+       ; lintRoles 0 (coaxrAsmpRoles co) eqs
+       ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of
+           Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]
+           Just (Pair l r) ->
+             return (typeKind l, typeKind r, l, r, coaxrRole co) }
+  where
+  err m xs  = failWithL $
+                hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs)
+
+  lintRoles n (e : es) ((_,_,_,_,r) : rs)
+    | e == r    = lintRoles (n+1) es rs
+    | otherwise = err "Argument roles mismatch"
+                      [ text "In argument:" <+> int (n+1)
+                      , text "Expected:" <+> ppr e
+                      , text "Found:" <+> ppr r ]
+  lintRoles _ [] []  = return ()
+  lintRoles n [] rs  = err "Too many coercion arguments"
+                          [ text "Expected:" <+> int n
+                          , text "Provided:" <+> int (n + length rs) ]
+
+  lintRoles n es []  = err "Not enough coercion arguments"
+                          [ text "Expected:" <+> int (n + length es)
+                          , text "Provided:" <+> int n ]
+
+lintCoercion (HoleCo h)
+  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h
+       ; lintCoercion (CoVarCo (coHoleCoVar h)) }
+
+
+----------
+lintUnliftedCoVar :: CoVar -> LintM ()
+lintUnliftedCoVar cv
+  = when (not (isUnliftedType (coVarKind cv))) $
+    failWithL (text "Bad lifted equality:" <+> ppr cv
+                 <+> dcolon <+> ppr (coVarKind cv))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lint-monad]{The Lint monad}
+*                                                                      *
+************************************************************************
+-}
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+data LintEnv
+  = LE { le_flags :: LintFlags       -- Linting the result of this pass
+       , le_loc   :: [LintLocInfo]   -- Locations
+
+       , le_subst :: TCvSubst  -- Current type substitution
+                               -- We also use le_subst to keep track of
+                               -- /all variables/ in scope, both Ids and TyVars
+
+       , le_joins :: IdSet     -- Join points in scope that are valid
+                               -- A subset of the InScopeSet in le_subst
+                               -- See Note [Join points]
+
+       , le_dynflags :: DynFlags     -- DynamicFlags
+       }
+
+data LintFlags
+  = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]
+       , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
+       , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]
+       , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]
+    }
+
+-- See Note [Checking StaticPtrs]
+data StaticPtrCheck
+    = AllowAnywhere
+        -- ^ Allow 'makeStatic' to occur anywhere.
+    | AllowAtTopLevel
+        -- ^ Allow 'makeStatic' calls at the top-level only.
+    | RejectEverywhere
+        -- ^ Reject any 'makeStatic' occurrence.
+  deriving Eq
+
+defaultLintFlags :: LintFlags
+defaultLintFlags = LF { lf_check_global_ids = False
+                      , lf_check_inline_loop_breakers = True
+                      , lf_check_static_ptrs = AllowAnywhere
+                      , lf_report_unsat_syns = True
+                      }
+
+newtype LintM a =
+   LintM { unLintM ::
+            LintEnv ->
+            WarnsAndErrs ->           -- Warning and error messages so far
+            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
+
+type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
+
+{- Note [Checking for global Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before CoreTidy, all locally-bound Ids must be LocalIds, even
+top-level ones. See Note [Exported LocalIds] and #9857.
+
+Note [Checking StaticPtrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
+Every occurrence of the function 'makeStatic' should be moved to the
+top level by the FloatOut pass.  It's vital that we don't have nested
+'makeStatic' occurrences after CorePrep, because we populate the Static
+Pointer Table from the top-level bindings. See SimplCore Note [Grand
+plan for static forms].
+
+The linter checks that no occurrence is left behind, nested within an
+expression. The check is enabled only after the FloatOut, CorePrep,
+and CoreTidy passes and only if the module uses the StaticPointers
+language extension. Checking more often doesn't help since the condition
+doesn't hold until after the first FloatOut pass.
+
+Note [Type substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Why do we need a type substitution?  Consider
+        /\(a:*). \(x:a). /\(a:*). id a x
+This is ill typed, because (renaming variables) it is really
+        /\(a:*). \(x:a). /\(b:*). id b x
+Hence, when checking an application, we can't naively compare x's type
+(at its binding site) with its expected type (at a use site).  So we
+rename type binders as we go, maintaining a substitution.
+
+The same substitution also supports let-type, current expressed as
+        (/\(a:*). body) ty
+Here we substitute 'ty' for 'a' in 'body', on the fly.
+
+Note [Linting type synonym applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When linting a type-synonym, or type-family, application
+  S ty1 .. tyn
+we behave as follows (#15057, #T15664):
+
+* If lf_report_unsat_syns = True, and S has arity < n,
+  complain about an unsaturated type synonym or type family
+
+* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.
+
+  Reason: catch out of scope variables or other ill-kinded gubbins,
+  even if S discards that argument entirely. E.g. (#15012):
+     type FakeOut a = Int
+     type family TF a
+     type instance TF Int = FakeOut a
+  Here 'a' is out of scope; but if we expand FakeOut, we conceal
+  that out-of-scope error.
+
+  Reason for switching off lf_report_unsat_syns: with
+  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they
+  are saturated when the type is expanded. Example
+     type T f = f Int
+     type S a = a -> a
+     type Z = T S
+  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.
+
+* If lf_report_unsat_syns is on, expand the synonym application and
+  lint the result.  Reason: want to check that synonyms are saturated
+  when the type is expanded.
+-}
+
+instance Functor LintM where
+      fmap = liftM
+
+instance Applicative LintM where
+      pure x = LintM $ \ _ errs -> (Just x, errs)
+      (<*>) = ap
+
+instance Monad LintM where
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+  m >>= k  = LintM (\ env errs ->
+                       let (res, errs') = unLintM m env errs in
+                         case res of
+                           Just r -> unLintM (k r) env errs'
+                           Nothing -> (Nothing, errs'))
+
+instance MonadFail.MonadFail LintM where
+    fail err = failWithL (text err)
+
+instance HasDynFlags LintM where
+  getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
+
+data LintLocInfo
+  = RhsOf Id            -- The variable bound
+  | LambdaBodyOf Id     -- The lambda-binder
+  | UnfoldingOf Id      -- Unfolding of a binder
+  | BodyOfLetRec [Id]   -- One of the binders
+  | CaseAlt CoreAlt     -- Case alternative
+  | CasePat CoreAlt     -- The *pattern* of the case alternative
+  | AnExpr CoreExpr     -- Some expression
+  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
+  | TopLevelBindings
+  | InType Type         -- Inside a type
+  | InCo   Coercion     -- Inside a coercion
+
+initL :: DynFlags -> LintFlags -> InScopeSet
+       -> LintM a -> WarnsAndErrs    -- Warnings and errors
+initL dflags flags in_scope m
+  = case unLintM m env (emptyBag, emptyBag) of
+      (Just _, errs) -> errs
+      (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs
+                             | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++
+                                                      "without reporting an error message") empty
+  where
+    env = LE { le_flags = flags
+             , le_subst = mkEmptyTCvSubst in_scope
+             , le_joins = emptyVarSet
+             , le_loc = []
+             , le_dynflags = dflags }
+
+setReportUnsat :: Bool -> LintM a -> LintM a
+-- Switch off lf_report_unsat_syns
+setReportUnsat ru thing_inside
+  = LintM $ \ env errs ->
+    let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }
+    in unLintM thing_inside env' errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
+
+checkL :: Bool -> MsgDoc -> LintM ()
+checkL True  _   = return ()
+checkL False msg = failWithL msg
+
+-- like checkL, but relevant to type checking
+lintL :: Bool -> MsgDoc -> LintM ()
+lintL = checkL
+
+checkWarnL :: Bool -> MsgDoc -> LintM ()
+checkWarnL True   _  = return ()
+checkWarnL False msg = addWarnL msg
+
+failWithL :: MsgDoc -> LintM a
+failWithL msg = LintM $ \ env (warns,errs) ->
+                (Nothing, (warns, addMsg env errs msg))
+
+addErrL :: MsgDoc -> LintM ()
+addErrL msg = LintM $ \ env (warns,errs) ->
+              (Just (), (warns, addMsg env errs msg))
+
+addWarnL :: MsgDoc -> LintM ()
+addWarnL msg = LintM $ \ env (warns,errs) ->
+              (Just (), (addMsg env warns msg, errs))
+
+addMsg :: LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc
+addMsg env msgs msg
+  = ASSERT( notNull locs )
+    msgs `snocBag` mk_msg msg
+  where
+   locs = le_loc env
+   (loc, cxt1) = dumpLoc (head locs)
+   cxts        = [snd (dumpLoc loc) | loc <- locs]
+   context     = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$
+                             text "Substitution:" <+> ppr (le_subst env))
+                            cxt1
+
+   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
+
+addLoc :: LintLocInfo -> LintM a -> LintM a
+addLoc extra_loc m
+  = LintM $ \ env errs ->
+    unLintM m (env { le_loc = extra_loc : le_loc env }) errs
+
+inCasePat :: LintM Bool         -- A slight hack; see the unique call site
+inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
+  where
+    is_case_pat (LE { le_loc = CasePat {} : _ }) = True
+    is_case_pat _other                           = False
+
+addInScopeVar :: Var -> LintM a -> LintM a
+addInScopeVar var m
+  = LintM $ \ env errs ->
+    unLintM m (env { le_subst = extendTCvInScope (le_subst env) var
+                   , le_joins = delVarSet        (le_joins env) var
+               }) errs
+
+extendSubstL :: TyVar -> Type -> LintM a -> LintM a
+extendSubstL tv ty m
+  = LintM $ \ env errs ->
+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
+
+updateTCvSubst :: TCvSubst -> LintM a -> LintM a
+updateTCvSubst subst' m
+  = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs
+
+markAllJoinsBad :: LintM a -> LintM a
+markAllJoinsBad m
+  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs
+
+markAllJoinsBadIf :: Bool -> LintM a -> LintM a
+markAllJoinsBadIf True  m = markAllJoinsBad m
+markAllJoinsBadIf False m = m
+
+addGoodJoins :: [Var] -> LintM a -> LintM a
+addGoodJoins vars thing_inside
+  | null join_ids
+  = thing_inside
+  | otherwise
+  = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs
+  where
+    add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids }
+    join_ids = filter isJoinId vars
+
+getValidJoins :: LintM IdSet
+getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))
+
+getTCvSubst :: LintM TCvSubst
+getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
+
+getInScope :: LintM InScopeSet
+getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))
+
+applySubstTy :: InType -> LintM OutType
+applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }
+
+applySubstCo :: InCoercion -> LintM OutCoercion
+applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) }
+
+lookupIdInScope :: Id -> LintM Id
+lookupIdInScope id_occ
+  = do { subst <- getTCvSubst
+       ; case lookupInScope (getTCvInScope subst) id_occ of
+           Just id_bnd  -> do { checkL (not (bad_global id_bnd)) global_in_scope
+                              ; return id_bnd }
+           Nothing -> do { checkL (not is_local) local_out_of_scope
+                         ; return id_occ } }
+  where
+    is_local = mustHaveLocalBinding id_occ
+    local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ
+    global_in_scope    = hang (text "Occurrence is GlobalId, but binding is LocalId")
+                            2 (pprBndr LetBind id_occ)
+    bad_global id_bnd = isGlobalId id_occ
+                     && isLocalId id_bnd
+                     && not (isWiredInName (idName id_occ))
+       -- 'bad_global' checks for the case where an /occurrence/ is
+       -- a GlobalId, but there is an enclosing binding fora a LocalId.
+       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,
+       --     but GHCi adds GlobalIds from the interactive context.  These
+       --     are fine; hence the test (isLocalId id == isLocalId v)
+       -- NB: when compiling Control.Exception.Base, things like absentError
+       --     are defined locally, but appear in expressions as (global)
+       --     wired-in Ids after worker/wrapper
+       --     So we simply disable the test in this case
+
+lookupJoinId :: Id -> LintM (Maybe JoinArity)
+-- Look up an Id which should be a join point, valid here
+-- If so, return its arity, if not return Nothing
+lookupJoinId id
+  = do { join_set <- getValidJoins
+       ; case lookupVarSet join_set id of
+            Just id' -> return (isJoinId_maybe id')
+            Nothing  -> return Nothing }
+
+lintTyCoVarInScope :: TyCoVar -> LintM ()
+lintTyCoVarInScope var
+  = do { subst <- getTCvSubst
+       ; lintL (var `isInScope` subst)
+               (pprBndr LetBind var <+> text "is out of scope") }
+
+ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM ()
+-- check ty2 is subtype of ty1 (ie, has same structure but usage
+-- annotations need only be consistent, not equal)
+-- Assumes ty1,ty2 are have already had the substitution applied
+ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg
+
+lintRole :: Outputable thing
+          => thing     -- where the role appeared
+          -> Role      -- expected
+          -> Role      -- actual
+          -> LintM ()
+lintRole co r1 r2
+  = lintL (r1 == r2)
+          (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>
+           text "got" <+> ppr r2 $$
+           text "in" <+> ppr co)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
+
+dumpLoc (RhsOf v)
+  = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))
+
+dumpLoc (LambdaBodyOf b)
+  = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))
+
+dumpLoc (UnfoldingOf b)
+  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))
+
+dumpLoc (BodyOfLetRec [])
+  = (noSrcLoc, brackets (text "In body of a letrec with no binders"))
+
+dumpLoc (BodyOfLetRec bs@(_:_))
+  = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs))
+
+dumpLoc (AnExpr e)
+  = (noSrcLoc, text "In the expression:" <+> ppr e)
+
+dumpLoc (CaseAlt (con, args, _))
+  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (CasePat (con, args, _))
+  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (ImportedUnfolding locn)
+  = (locn, brackets (text "in an imported unfolding"))
+dumpLoc TopLevelBindings
+  = (noSrcLoc, Outputable.empty)
+dumpLoc (InType ty)
+  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
+
+pp_binders :: [Var] -> SDoc
+pp_binders bs = sep (punctuate comma (map pp_binder bs))
+
+pp_binder :: Var -> SDoc
+pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
+            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
+
+------------------------------------------------------
+--      Messages for case expressions
+
+mkDefaultArgsMsg :: [Var] -> MsgDoc
+mkDefaultArgsMsg args
+  = hang (text "DEFAULT case with binders")
+         4 (ppr args)
+
+mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
+mkCaseAltMsg e ty1 ty2
+  = hang (text "Type of case alternatives not the same as the annotation on case:")
+         4 (vcat [ text "Actual type:" <+> ppr ty1,
+                   text "Annotation on case:" <+> ppr ty2,
+                   text "Alt Rhs:" <+> ppr e ])
+
+mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc
+mkScrutMsg var var_ty scrut_ty subst
+  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
+          text "Result binder type:" <+> ppr var_ty,--(idType var),
+          text "Scrutinee type:" <+> ppr scrut_ty,
+     hsep [text "Current TCv subst", ppr subst]]
+
+mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
+mkNonDefltMsg e
+  = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e)
+mkNonIncreasingAltsMsg e
+  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
+
+nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
+nonExhaustiveAltsMsg e
+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
+
+mkBadConMsg :: TyCon -> DataCon -> MsgDoc
+mkBadConMsg tycon datacon
+  = vcat [
+        text "In a case alternative, data constructor isn't in scrutinee type:",
+        text "Scrutinee type constructor:" <+> ppr tycon,
+        text "Data con:" <+> ppr datacon
+    ]
+
+mkBadPatMsg :: Type -> Type -> MsgDoc
+mkBadPatMsg con_result_ty scrut_ty
+  = vcat [
+        text "In a case alternative, pattern result type doesn't match scrutinee type:",
+        text "Pattern result type:" <+> ppr con_result_ty,
+        text "Scrutinee type:" <+> ppr scrut_ty
+    ]
+
+integerScrutinisedMsg :: MsgDoc
+integerScrutinisedMsg
+  = text "In a LitAlt, the literal is lifted (probably Integer)"
+
+mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
+mkBadAltMsg scrut_ty alt
+  = vcat [ text "Data alternative when scrutinee is not a tycon application",
+           text "Scrutinee type:" <+> ppr scrut_ty,
+           text "Alternative:" <+> pprCoreAlt alt ]
+
+mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
+mkNewTyDataConAltMsg scrut_ty alt
+  = vcat [ text "Data alternative for newtype datacon",
+           text "Scrutinee type:" <+> ppr scrut_ty,
+           text "Alternative:" <+> pprCoreAlt alt ]
+
+
+------------------------------------------------------
+--      Other error messages
+
+mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
+mkAppMsg fun_ty arg_ty arg
+  = vcat [text "Argument value doesn't match argument type:",
+              hang (text "Fun type:") 4 (ppr fun_ty),
+              hang (text "Arg type:") 4 (ppr arg_ty),
+              hang (text "Arg:") 4 (ppr arg)]
+
+mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
+mkNonFunAppMsg fun_ty arg_ty arg
+  = vcat [text "Non-function type in function position",
+              hang (text "Fun type:") 4 (ppr fun_ty),
+              hang (text "Arg type:") 4 (ppr arg_ty),
+              hang (text "Arg:") 4 (ppr arg)]
+
+mkLetErr :: TyVar -> CoreExpr -> MsgDoc
+mkLetErr bndr rhs
+  = vcat [text "Bad `let' binding:",
+          hang (text "Variable:")
+                 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+          hang (text "Rhs:")
+                 4 (ppr rhs)]
+
+mkTyAppMsg :: Type -> Type -> MsgDoc
+mkTyAppMsg ty arg_ty
+  = vcat [text "Illegal type application:",
+              hang (text "Exp type:")
+                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+              hang (text "Arg type:")
+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
+emptyRec :: CoreExpr -> MsgDoc
+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)
+
+mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
+mkRhsMsg binder what ty
+  = vcat
+    [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,
+            ppr binder],
+     hsep [text "Binder's type:", ppr (idType binder)],
+     hsep [text "Rhs type:", ppr ty]]
+
+mkLetAppMsg :: CoreExpr -> MsgDoc
+mkLetAppMsg e
+  = hang (text "This argument does not satisfy the let/app invariant:")
+       2 (ppr e)
+
+badBndrTyMsg :: Id -> SDoc -> MsgDoc
+badBndrTyMsg binder what
+  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder
+         , text "Binder's type:" <+> ppr (idType binder) ]
+
+mkStrictMsg :: Id -> MsgDoc
+mkStrictMsg binder
+  = vcat [hsep [text "Recursive or top-level binder has strict demand info:",
+                     ppr binder],
+              hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]
+             ]
+
+mkNonTopExportedMsg :: Id -> MsgDoc
+mkNonTopExportedMsg binder
+  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]
+
+mkNonTopExternalNameMsg :: Id -> MsgDoc
+mkNonTopExternalNameMsg binder
+  = hsep [text "Non-top-level binder has an external name:", ppr binder]
+
+mkTopNonLitStrMsg :: Id -> MsgDoc
+mkTopNonLitStrMsg binder
+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]
+
+mkKindErrMsg :: TyVar -> Type -> MsgDoc
+mkKindErrMsg tyvar arg_ty
+  = vcat [text "Kinds don't match in type application:",
+          hang (text "Type variable:")
+                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+          hang (text "Arg type:")
+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
+mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)
+
+mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc
+mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)
+
+mk_cast_err :: String -- ^ What sort of casted thing this is
+                      --   (\"expression\" or \"type\").
+            -> String -- ^ What sort of coercion is being used
+                      --   (\"type\" or \"kind\").
+            -> SDoc   -- ^ The thing being casted.
+            -> Coercion -> Type -> Type -> MsgDoc
+mk_cast_err thing_str co_str pp_thing co from_ty thing_ty
+  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg
+            <+> text "of" <+> enclosed_msg,
+          from_msg <> colon <+> ppr from_ty,
+          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon
+            <+> ppr thing_ty,
+          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,
+          text "Coercion used in cast:" <+> ppr co
+         ]
+  where
+    co_msg, from_msg, enclosed_msg :: SDoc
+    co_msg       = text co_str
+    from_msg     = text "From-" <> co_msg
+    enclosed_msg = text "enclosed" <+> text thing_str
+
+mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
+mkBadUnivCoMsg lr co
+  = text "Kind mismatch on the" <+> pprLeftOrRight lr <+>
+    text "side of a UnivCo:" <+> ppr co
+
+mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
+mkBadProofIrrelMsg ty co
+  = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")
+       2 (vcat [ text "type:" <+> ppr ty
+               , text "co:" <+> ppr co ])
+
+mkBadTyVarMsg :: Var -> SDoc
+mkBadTyVarMsg tv
+  = text "Non-tyvar used in TyVarTy:"
+      <+> ppr tv <+> dcolon <+> ppr (varType tv)
+
+mkBadJoinBindMsg :: Var -> SDoc
+mkBadJoinBindMsg var
+  = vcat [ text "Bad join point binding:" <+> ppr var
+         , text "Join points can be bound only by a non-top-level let" ]
+
+mkInvalidJoinPointMsg :: Var -> Type -> SDoc
+mkInvalidJoinPointMsg var ty
+  = hang (text "Join point has invalid type:")
+        2 (ppr var <+> dcolon <+> ppr ty)
+
+mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
+mkBadJoinArityMsg var ar nlams rhs
+  = vcat [ text "Join point has too few lambdas",
+           text "Join var:" <+> ppr var,
+           text "Join arity:" <+> ppr ar,
+           text "Number of lambdas:" <+> ppr nlams,
+           text "Rhs = " <+> ppr rhs
+           ]
+
+invalidJoinOcc :: Var -> SDoc
+invalidJoinOcc var
+  = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var
+         , text "The binder is either not a join point, or not valid here" ]
+
+mkBadJumpMsg :: Var -> Int -> Int -> SDoc
+mkBadJumpMsg var ar nargs
+  = vcat [ text "Join point invoked with wrong number of arguments",
+           text "Join var:" <+> ppr var,
+           text "Join arity:" <+> ppr ar,
+           text "Number of arguments:" <+> int nargs ]
+
+mkInconsistentRecMsg :: [Var] -> SDoc
+mkInconsistentRecMsg bndrs
+  = vcat [ text "Recursive let binders mix values and join points",
+           text "Binders:" <+> hsep (map ppr_with_details bndrs) ]
+  where
+    ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)
+
+mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc
+mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ
+  = vcat [ text "Mismatch in join point arity between binder and occurrence"
+         , text "Var:" <+> ppr bndr
+         , text "Arity at binding site:" <+> ppr join_arity_bndr
+         , text "Arity at occurrence:  " <+> ppr join_arity_occ ]
+
+mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc
+mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty
+  = vcat [ text "Mismatch in type between binder and occurrence"
+         , text "Var:" <+> ppr bndr
+         , text "Binder type:" <+> ppr bndr_ty
+         , text "Occurrence type:" <+> ppr var_ty
+         , text "  Before subst:" <+> ppr (idType var) ]
+
+mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc
+mkBadJoinPointRuleMsg bndr join_arity rule
+  = vcat [ text "Join point has rule with wrong number of arguments"
+         , text "Var:" <+> ppr bndr
+         , text "Join arity:" <+> ppr join_arity
+         , text "Rule:" <+> ppr rule ]
+
+pprLeftOrRight :: LeftOrRight -> MsgDoc
+pprLeftOrRight CLeft  = text "left"
+pprLeftOrRight CRight = text "right"
+
+dupVars :: [NonEmpty Var] -> MsgDoc
+dupVars vars
+  = hang (text "Duplicate variables brought into scope")
+       2 (ppr (map toList vars))
+
+dupExtVars :: [NonEmpty Name] -> MsgDoc
+dupExtVars vars
+  = hang (text "Duplicate top-level variables with the same qualified name")
+       2 (ppr (map toList vars))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Annotation Linting}
+*                                                                      *
+************************************************************************
+-}
+
+-- | This checks whether a pass correctly looks through debug
+-- annotations (@SourceNote@). This works a bit different from other
+-- consistency checks: We check this by running the given task twice,
+-- noting all differences between the results.
+lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+lintAnnots pname pass guts = do
+  -- Run the pass as we normally would
+  dflags <- getDynFlags
+  when (gopt Opt_DoAnnotationLinting dflags) $
+    liftIO $ Err.showPass dflags "Annotation linting - first run"
+  nguts <- pass guts
+  -- If appropriate re-run it without debug annotations to make sure
+  -- that they made no difference.
+  when (gopt Opt_DoAnnotationLinting dflags) $ do
+    liftIO $ Err.showPass dflags "Annotation linting - second run"
+    nguts' <- withoutAnnots pass guts
+    -- Finally compare the resulting bindings
+    liftIO $ Err.showPass dflags "Annotation linting - comparison"
+    let binds = flattenBinds $ mg_binds nguts
+        binds' = flattenBinds $ mg_binds nguts'
+        (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
+    when (not (null diffs)) $ CoreMonad.putMsg $ vcat
+      [ lint_banner "warning" pname
+      , text "Core changes with annotations:"
+      , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
+      ]
+  -- Return actual new guts
+  return nguts
+
+-- | Run the given pass without annotations. This means that we both
+-- set the debugLevel setting to 0 in the environment as well as all
+-- annotations from incoming modules.
+withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+withoutAnnots pass guts = do
+  -- Remove debug flag from environment.
+  dflags <- getDynFlags
+  let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }
+      withoutFlag corem =
+        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
+                                getUniqueSupplyM <*> getModule <*>
+                                getVisibleOrphanMods <*>
+                                getPrintUnqualified <*> getSrcSpanM <*>
+                                pure corem
+  -- Nuke existing ticks in module.
+  -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
+  -- them in absence of debugLevel > 0.
+  let nukeTicks = stripTicksE (not . tickishIsCode)
+      nukeAnnotsBind :: CoreBind -> CoreBind
+      nukeAnnotsBind bind = case bind of
+        Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
+        NonRec b e -> NonRec b $ nukeTicks e
+      nukeAnnotsMod mg@ModGuts{mg_binds=binds}
+        = mg{mg_binds = map nukeAnnotsBind binds}
+  -- Perform pass with all changes applied
+  fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
new file mode 100644
--- /dev/null
+++ b/compiler/coreSyn/CorePrep.hs
@@ -0,0 +1,1728 @@
+{-
+(c) The University of Glasgow, 1994-2006
+
+
+Core pass to saturate constructors and PrimOps
+-}
+
+{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
+
+module CorePrep (
+      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
+      lookupMkIntegerName, lookupIntegerSDataConName,
+      lookupMkNaturalName, lookupNaturalSDataConName
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import OccurAnal
+
+import HscTypes
+import PrelNames
+import MkId             ( realWorldPrimId )
+import CoreUtils
+import CoreArity
+import CoreFVs
+import CoreMonad        ( CoreToDo(..) )
+import CoreLint         ( endPassIO )
+import CoreSyn
+import CoreSubst
+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here
+import Type
+import Literal
+import Coercion
+import TcEnv
+import TyCon
+import Demand
+import Var
+import VarSet
+import VarEnv
+import Id
+import IdInfo
+import TysWiredIn
+import DataCon
+import BasicTypes
+import Module
+import UniqSupply
+import Maybes
+import OrdList
+import ErrUtils
+import DynFlags
+import Util
+import Pair
+import Outputable
+import Platform
+import FastString
+import Name             ( NamedThing(..), nameSrcSpan )
+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
+import Data.Bits
+import MonadUtils       ( mapAccumLM )
+import Data.List        ( mapAccumL )
+import Control.Monad
+import CostCentre       ( CostCentre, ccFromThisModule )
+import qualified Data.Set as S
+
+{-
+-- ---------------------------------------------------------------------------
+-- Note [CorePrep Overview]
+-- ---------------------------------------------------------------------------
+
+The goal of this pass is to prepare for code generation.
+
+1.  Saturate constructor and primop applications.
+
+2.  Convert to A-normal form; that is, function arguments
+    are always variables.
+
+    * Use case for strict arguments:
+        f E ==> case E of x -> f x
+        (where f is strict)
+
+    * Use let for non-trivial lazy arguments
+        f E ==> let x = E in f x
+        (were f is lazy and x is non-trivial)
+
+3.  Similarly, convert any unboxed lets into cases.
+    [I'm experimenting with leaving 'ok-for-speculation'
+     rhss in let-form right up to this point.]
+
+4.  Ensure that *value* lambdas only occur as the RHS of a binding
+    (The code generator can't deal with anything else.)
+    Type lambdas are ok, however, because the code gen discards them.
+
+5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
+
+6.  Clone all local Ids.
+    This means that all such Ids are unique, rather than the
+    weaker guarantee of no clashes which the simplifier provides.
+    And that is what the code generator needs.
+
+    We don't clone TyVars or CoVars. The code gen doesn't need that,
+    and doing so would be tiresome because then we'd need
+    to substitute in types and coercions.
+
+7.  Give each dynamic CCall occurrence a fresh unique; this is
+    rather like the cloning step above.
+
+8.  Inject bindings for the "implicit" Ids:
+        * Constructor wrappers
+        * Constructor workers
+    We want curried definitions for all of these in case they
+    aren't inlined by some caller.
+
+9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs
+    Also replace (noinline e) by e.
+
+10. Convert (LitInteger i t) into the core representation
+    for the Integer i. Normally this uses mkInteger, but if
+    we are using the integer-gmp implementation then there is a
+    special case where we use the S# constructor for Integers that
+    are in the range of Int.
+
+11. Same for LitNatural.
+
+12. Uphold tick consistency while doing this: We move ticks out of
+    (non-type) applications where we can, and make sure that we
+    annotate according to scoping rules when floating.
+
+13. Collect cost centres (including cost centres in unfoldings) if we're in
+    profiling mode. We have to do this here beucase we won't have unfoldings
+    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
+
+This is all done modulo type applications and abstractions, so that
+when type erasure is done for conversion to STG, we don't end up with
+any trivial or useless bindings.
+
+
+Note [CorePrep invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is the syntax of the Core produced by CorePrep:
+
+    Trivial expressions
+       arg ::= lit |  var
+              | arg ty  |  /\a. arg
+              | truv co  |  /\c. arg  |  arg |> co
+
+    Applications
+       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co
+
+    Expressions
+       body ::= app
+              | let(rec) x = rhs in body     -- Boxed only
+              | case body of pat -> body
+              | /\a. body | /\c. body
+              | body |> co
+
+    Right hand sides (only place where value lambdas can occur)
+       rhs ::= /\a.rhs  |  \x.rhs  |  body
+
+We define a synonym for each of these non-terminals.  Functions
+with the corresponding name produce a result in that syntax.
+-}
+
+type CpeArg  = CoreExpr    -- Non-terminal 'arg'
+type CpeApp  = CoreExpr    -- Non-terminal 'app'
+type CpeBody = CoreExpr    -- Non-terminal 'body'
+type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
+
+{-
+************************************************************************
+*                                                                      *
+                Top level stuff
+*                                                                      *
+************************************************************************
+-}
+
+corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
+            -> IO (CoreProgram, S.Set CostCentre)
+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
+    withTiming (pure dflags)
+               (text "CorePrep"<+>brackets (ppr this_mod))
+               (const ()) $ do
+    us <- mkSplitUniqSupply 's'
+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
+
+    let cost_centres
+          | WayProf `elem` ways dflags
+          = collectCostCentres this_mod binds
+          | otherwise
+          = S.empty
+
+        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
+            -- NB: we must feed mkImplicitBinds through corePrep too
+            -- so that they are suitably cloned and eta-expanded
+
+        binds_out = initUs_ us $ do
+                      floats1 <- corePrepTopBinds initialCorePrepEnv binds
+                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
+                      return (deFloatTop (floats1 `appendFloats` floats2))
+
+    endPassIO hsc_env alwaysQualify CorePrep binds_out []
+    return (binds_out, cost_centres)
+  where
+    dflags = hsc_dflags hsc_env
+
+corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
+corePrepExpr dflags hsc_env expr =
+    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
+    us <- mkSplitUniqSupply 's'
+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
+    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
+    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
+    return new_expr
+
+corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
+-- Note [Floating out of top level bindings]
+corePrepTopBinds initialCorePrepEnv binds
+  = go initialCorePrepEnv binds
+  where
+    go _   []             = return emptyFloats
+    go env (bind : binds) = do (env', floats, maybe_new_bind)
+                                 <- cpeBind TopLevel env bind
+                               MASSERT(isNothing maybe_new_bind)
+                                 -- Only join points get returned this way by
+                                 -- cpeBind, and no join point may float to top
+                               floatss <- go env' binds
+                               return (floats `appendFloats` floatss)
+
+mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
+-- See Note [Data constructor workers]
+-- c.f. Note [Injecting implicit bindings] in TidyPgm
+mkDataConWorkers dflags mod_loc data_tycons
+  = [ NonRec id (tick_it (getName data_con) (Var id))
+                                -- The ice is thin here, but it works
+    | tycon <- data_tycons,     -- CorePrep will eta-expand it
+      data_con <- tyConDataCons tycon,
+      let id = dataConWorkId data_con
+    ]
+ where
+   -- If we want to generate debug info, we put a source note on the
+   -- worker. This is useful, especially for heap profiling.
+   tick_it name
+     | debugLevel dflags == 0                = id
+     | RealSrcSpan span <- nameSrcSpan name  = tick span
+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)
+     | otherwise                             = tick (span1 "???")
+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))
+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
+
+{-
+Note [Floating out of top level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: we do need to float out of top-level bindings
+Consider        x = length [True,False]
+We want to get
+                s1 = False : []
+                s2 = True  : s1
+                x  = length s2
+
+We return a *list* of bindings, because we may start with
+        x* = f (g y)
+where x is demanded, in which case we want to finish with
+        a = g y
+        x* = f a
+And then x will actually end up case-bound
+
+Note [CafInfo and floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What happens when we try to float bindings to the top level?  At this
+point all the CafInfo is supposed to be correct, and we must make certain
+that is true of the new top-level bindings.  There are two cases
+to consider
+
+a) The top-level binding is marked asCafRefs.  In that case we are
+   basically fine.  The floated bindings had better all be lazy lets,
+   so they can float to top level, but they'll all have HasCafRefs
+   (the default) which is safe.
+
+b) The top-level binding is marked NoCafRefs.  This really happens
+   Example.  CoreTidy produces
+      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
+   Now CorePrep has to eta-expand to
+      $fApplicativeSTM = let sat = \xy. retry x y
+                         in D:Alternative sat ...blah...
+   So what we *want* is
+      sat [NoCafRefs] = \xy. retry x y
+      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
+
+   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
+   *and* substitute the modified 'sat' into the old RHS.
+
+   It should be the case that 'sat' is itself [NoCafRefs] (a value, no
+   cafs) else the original top-level binding would not itself have been
+   marked [NoCafRefs].  The DEBUG check in CoreToStg for
+   consistentCafInfo will find this.
+
+This is all very gruesome and horrible. It would be better to figure
+out CafInfo later, after CorePrep.  We'll do that in due course.
+Meanwhile this horrible hack works.
+
+Note [Join points and floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Join points can float out of other join points but not out of value bindings:
+
+  let z =
+    let  w = ... in -- can float
+    join k = ... in -- can't float
+    ... jump k ...
+  join j x1 ... xn =
+    let  y = ... in -- can float (but don't want to)
+    join h = ... in -- can float (but not much point)
+    ... jump h ...
+  in ...
+
+Here, the jump to h remains valid if h is floated outward, but the jump to k
+does not.
+
+We don't float *out* of join points. It would only be safe to float out of
+nullary join points (or ones where the arguments are all either type arguments
+or dead binders). Nullary join points aren't ever recursive, so they're always
+effectively one-shot functions, which we don't float out of. We *could* float
+join points from nullary join points, but there's no clear benefit at this
+stage.
+
+Note [Data constructor workers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Create any necessary "implicit" bindings for data con workers.  We
+create the rather strange (non-recursive!) binding
+
+        $wC = \x y -> $wC x y
+
+i.e. a curried constructor that allocates.  This means that we can
+treat the worker for a constructor like any other function in the rest
+of the compiler.  The point here is that CoreToStg will generate a
+StgConApp for the RHS, rather than a call to the worker (which would
+give a loop).  As Lennart says: the ice is thin here, but it works.
+
+Hmm.  Should we create bindings for dictionary constructors?  They are
+always fully applied, and the bindings are just there to support
+partial applications. But it's easier to let them through.
+
+
+Note [Dead code in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine that we got an input program like this (see #4962):
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g True (Just x) + g () (Just x), g)
+    where
+      g :: Show a => a -> Maybe Int -> Int
+      g _ Nothing = x
+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
+
+After specialisation and SpecConstr, we would get something like this:
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
+    where
+      {-# RULES g $dBool = g$Bool
+                g $dUnit = g$Unit #-}
+      g = ...
+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
+      g$Bool = ...
+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
+      g$Unit = ...
+      g$Bool_True_Just = ...
+      g$Unit_Unit_Just = ...
+
+Note that the g$Bool and g$Unit functions are actually dead code: they
+are only kept alive by the occurrence analyser because they are
+referred to by the rules of g, which is being kept alive by the fact
+that it is used (unspecialised) in the returned pair.
+
+However, at the CorePrep stage there is no way that the rules for g
+will ever fire, and it really seems like a shame to produce an output
+program that goes to the trouble of allocating a closure for the
+unreachable g$Bool and g$Unit functions.
+
+The way we fix this is to:
+ * In cloneBndr, drop all unfoldings/rules
+
+ * In deFloatTop, run a simple dead code analyser on each top-level
+   RHS to drop the dead local bindings. For that call to OccAnal, we
+   disable the binder swap, else the occurrence analyser sometimes
+   introduces new let bindings for cased binders, which lead to the bug
+   in #5433.
+
+The reason we don't just OccAnal the whole output of CorePrep is that
+the tidier ensures that all top-level binders are GlobalIds, so they
+don't show up in the free variables any longer. So if you run the
+occurrence analyser on the output of CoreTidy (or later) you e.g. turn
+this program:
+
+  Rec {
+  f = ... f ...
+  }
+
+Into this one:
+
+  f = ... f ...
+
+(Since f is not considered to be free in its own RHS.)
+
+
+************************************************************************
+*                                                                      *
+                The main code
+*                                                                      *
+************************************************************************
+-}
+
+cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
+        -> UniqSM (CorePrepEnv,
+                   Floats,         -- Floating value bindings
+                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float
+                                   -- Nothing <=> added bind' to floats instead
+cpeBind top_lvl env (NonRec bndr rhs)
+  | not (isJoinId bndr)
+  = do { (_, bndr1) <- cpCloneBndr env bndr
+       ; let dmd         = idDemandInfo bndr
+             is_unlifted = isUnliftedType (idType bndr)
+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
+                                   dmd is_unlifted
+                                   env bndr1 rhs
+       -- See Note [Inlining in CorePrep]
+       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
+            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
+            else do {
+
+       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
+
+       ; return (extendCorePrepEnv env bndr bndr1,
+                 addFloat floats new_float,
+                 Nothing) }}
+
+  | otherwise -- A join point; see Note [Join points and floating]
+  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point
+    do { (_, bndr1) <- cpCloneBndr env bndr
+       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
+       ; return (extendCorePrepEnv env bndr bndr2,
+                 emptyFloats,
+                 Just (NonRec bndr2 rhs1)) }
+
+cpeBind top_lvl env (Rec pairs)
+  | not (isJoinId (head bndrs))
+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
+                           bndrs1 rhss
+
+       ; let (floats_s, rhss1) = unzip stuff
+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
+                                           (concatFloats floats_s)
+
+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
+                 unitFloat (FloatLet (Rec all_pairs)),
+                 Nothing) }
+
+  | otherwise -- See Note [Join points and floating]
+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
+
+       ; let bndrs2 = map fst pairs1
+       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),
+                 emptyFloats,
+                 Just (Rec pairs1)) }
+  where
+    (bndrs, rhss) = unzip pairs
+
+        -- Flatten all the floats, and the current
+        -- group into a single giant Rec
+    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
+    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
+    add_float b                       _    = pprPanic "cpeBind" (ppr b)
+
+---------------
+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
+        -> CorePrepEnv -> OutId -> CoreExpr
+        -> UniqSM (Floats, CpeRhs)
+-- Used for all bindings
+-- The binder is already cloned, hence an OutId
+cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
+  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
+    do { (floats1, rhs1) <- cpeRhsE env rhs
+
+       -- See if we are allowed to float this stuff out of the RHS
+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
+
+       -- Make the arity match up
+       ; (floats3, rhs3)
+            <- if manifestArity rhs1 <= arity
+               then return (floats2, cpeEtaExpand arity rhs2)
+               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+                               -- Note [Silly extra arguments]
+                    (do { v <- newVar (idType bndr)
+                        ; let float = mkFloat topDmd False v rhs2
+                        ; return ( addFloat floats2 float
+                                 , cpeEtaExpand arity (Var v)) })
+
+        -- Wrap floating ticks
+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3
+
+       ; return (floats4, rhs4) }
+  where
+    platform = targetPlatform (cpe_dynFlags env)
+
+    arity = idArity bndr        -- We must match this arity
+
+    ---------------------
+    float_from_rhs floats rhs
+      | isEmptyFloats floats = return (emptyFloats, rhs)
+      | isTopLevel top_lvl   = float_top    floats rhs
+      | otherwise            = float_nested floats rhs
+
+    ---------------------
+    float_nested floats rhs
+      | wantFloatNested is_rec dmd is_unlifted floats rhs
+                  = return (floats, rhs)
+      | otherwise = dontFloat floats rhs
+
+    ---------------------
+    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]
+      | mayHaveCafRefs (idCafInfo bndr)
+      , allLazyTop floats
+      = return (floats, rhs)
+
+      -- So the top-level binding is marked NoCafRefs
+      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
+      = return (floats', rhs')
+
+      | otherwise
+      = dontFloat floats rhs
+
+dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
+-- Non-empty floats, but do not want to float from rhs
+-- So wrap the rhs in the floats
+-- But: rhs1 might have lambdas, and we can't
+--      put them inside a wrapBinds
+dontFloat floats1 rhs
+  = do { (floats2, body) <- rhsToBody rhs
+        ; return (emptyFloats, wrapBinds floats1 $
+                               wrapBinds floats2 body) }
+
+{- Note [Silly extra arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we had this
+        f{arity=1} = \x\y. e
+We *must* match the arity on the Id, so we have to generate
+        f' = \x\y. e
+        f  = \x. f' x
+
+It's a bizarre case: why is the arity on the Id wrong?  Reason
+(in the days of __inline_me__):
+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
+When InlineMe notes go away this won't happen any more.  But
+it seems good for CorePrep to be robust.
+-}
+
+---------------
+cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
+            -> UniqSM (JoinId, CpeRhs)
+-- Used for all join bindings
+cpeJoinPair env bndr rhs
+  = ASSERT(isJoinId bndr)
+    do { let Just join_arity = isJoinId_maybe bndr
+             (bndrs, body)   = collectNBinders join_arity rhs
+
+       ; (env', bndrs') <- cpCloneBndrs env bndrs
+
+       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
+                                      -- with a lambda
+
+       ; let rhs'  = mkCoreLams bndrs' body'
+             bndr' = bndr `setIdUnfolding` evaldUnfolding
+                          `setIdArity` count isId bndrs
+                            -- See Note [Arity and join points]
+
+       ; return (bndr', rhs') }
+
+{-
+Note [Arity and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Up to now, we've allowed a join point to have an arity greater than its join
+arity (minus type arguments), since this is what's useful for eta expansion.
+However, for code gen purposes, its arity must be exactly the number of value
+arguments it will be called with, and it must have exactly that many value
+lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:
+
+  join j x y z = \w -> ... in ...
+    =>
+  join j x y z = (let f = \w -> ... in f) in ...
+
+This is also what happens with Note [Silly extra arguments]. Note that it's okay
+for us to mess with the arity because a join point is never exported.
+-}
+
+-- ---------------------------------------------------------------------------
+--              CpeRhs: produces a result satisfying CpeRhs
+-- ---------------------------------------------------------------------------
+
+cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
+-- If
+--      e  ===>  (bs, e')
+-- then
+--      e = let bs in e'        (semantically, that is!)
+--
+-- For example
+--      f (g x)   ===>   ([v = g x], f v)
+
+cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)
+cpeRhsE env (Lit (LitNumber LitNumInteger i _))
+    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
+                   (cpe_integerSDataCon env) i)
+cpeRhsE env (Lit (LitNumber LitNumNatural i _))
+    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
+                   (cpe_naturalSDataCon env) i)
+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})  = cpeApp env expr
+cpeRhsE env expr@(App {}) = cpeApp env expr
+
+cpeRhsE env (Let bind body)
+  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind
+       ; (body_floats, body') <- cpeRhsE env' body
+       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'
+                                         Nothing    -> body'
+       ; return (bind_floats `appendFloats` body_floats, expr') }
+
+cpeRhsE env (Tick tickish expr)
+  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
+  = do { (floats, body) <- cpeRhsE env expr
+         -- See [Floating Ticks in CorePrep]
+       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
+  | otherwise
+  = do { body <- cpeBodyNF env expr
+       ; return (emptyFloats, mkTick tickish' body) }
+  where
+    tickish' | Breakpoint n fvs <- tickish
+             -- See also 'substTickish'
+             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
+             | otherwise
+             = tickish
+
+cpeRhsE env (Cast expr co)
+   = do { (floats, expr') <- cpeRhsE env expr
+        ; return (floats, Cast expr' co) }
+
+cpeRhsE env expr@(Lam {})
+   = do { let (bndrs,body) = collectBinders expr
+        ; (env', bndrs') <- cpCloneBndrs env bndrs
+        ; body' <- cpeBodyNF env' body
+        ; return (emptyFloats, mkLams bndrs' body') }
+
+cpeRhsE env (Case scrut bndr ty alts)
+  = do { (floats, scrut') <- cpeBody env scrut
+       ; (env', bndr2) <- cpCloneBndr env bndr
+       ; let alts'
+                 -- This flag is intended to aid in debugging strictness
+                 -- analysis bugs. These are particularly nasty to chase down as
+                 -- they may manifest as segmentation faults. When this flag is
+                 -- enabled we instead produce an 'error' expression to catch
+                 -- the case where a function we think should bottom
+                 -- unexpectedly returns.
+               | gopt Opt_CatchBottoms (cpe_dynFlags env)
+               , not (altsAreExhaustive alts)
+               = addDefault alts (Just err)
+               | otherwise = alts
+               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
+                                             "Bottoming expression returned"
+       ; alts'' <- mapM (sat_alt env') alts'
+       ; return (floats, Case scrut' bndr2 ty alts'') }
+  where
+    sat_alt env (con, bs, rhs)
+       = do { (env2, bs') <- cpCloneBndrs env bs
+            ; rhs' <- cpeBodyNF env2 rhs
+            ; return (con, bs', rhs') }
+
+cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Integer to the low-level
+-- representation. Exactly how we do this depends on the
+-- library that implements Integer.  If it's GMP we
+-- use the S# data constructor for small literals.
+-- See Note [Integer literals] in Literal
+cvtLitInteger dflags _ (Just sdatacon) i
+  | inIntRange dflags i -- Special case for small integers
+    = mkConApp sdatacon [Lit (mkLitInt dflags i)]
+
+cvtLitInteger dflags mk_integer _ i
+    = mkApps (Var mk_integer) [isNonNegative, ints]
+  where isNonNegative = if i < 0 then mkConApp falseDataCon []
+                                 else mkConApp trueDataCon  []
+        ints = mkListExpr intTy (f (abs i))
+        f 0 = []
+        f x = let low  = x .&. mask
+                  high = x `shiftR` bits
+              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high
+        bits = 31
+        mask = 2 ^ bits - 1
+
+cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Natural to the low-level
+-- representation.
+-- See Note [Natural literals] in Literal
+cvtLitNatural dflags _ (Just sdatacon) i
+  | inWordRange dflags i -- Special case for small naturals
+    = mkConApp sdatacon [Lit (mkLitWord dflags i)]
+
+cvtLitNatural dflags mk_natural _ i
+    = mkApps (Var mk_natural) [words]
+  where words = mkListExpr wordTy (f i)
+        f 0 = []
+        f x = let low  = x .&. mask
+                  high = x `shiftR` bits
+              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high
+        bits = 32
+        mask = 2 ^ bits - 1
+
+-- ---------------------------------------------------------------------------
+--              CpeBody: produces a result satisfying CpeBody
+-- ---------------------------------------------------------------------------
+
+-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
+-- producing any floats (any generated floats are immediately
+-- let-bound using 'wrapBinds').  Generally you want this, esp.
+-- when you've reached a binding form (e.g., a lambda) and
+-- floating any further would be incorrect.
+cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
+cpeBodyNF env expr
+  = do { (floats, body) <- cpeBody env expr
+       ; return (wrapBinds floats body) }
+
+-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
+-- a list of 'Floats' which are being propagated upwards.  In
+-- fact, this function is used in only two cases: to
+-- implement 'cpeBodyNF' (which is what you usually want),
+-- and in the case when a let-binding is in a case scrutinee--here,
+-- we can always float out:
+--
+--      case (let x = y in z) of ...
+--      ==> let x = y in case z of ...
+--
+cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
+cpeBody env expr
+  = do { (floats1, rhs) <- cpeRhsE env expr
+       ; (floats2, body) <- rhsToBody rhs
+       ; return (floats1 `appendFloats` floats2, body) }
+
+--------
+rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
+-- Remove top level lambdas by let-binding
+
+rhsToBody (Tick t expr)
+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations
+  = do { (floats, expr') <- rhsToBody expr
+       ; return (floats, mkTick t expr') }
+
+rhsToBody (Cast e co)
+        -- You can get things like
+        --      case e of { p -> coerce t (\s -> ...) }
+  = do { (floats, e') <- rhsToBody e
+       ; return (floats, Cast e' co) }
+
+rhsToBody expr@(Lam {})
+  | Just no_lam_result <- tryEtaReducePrep bndrs body
+  = return (emptyFloats, no_lam_result)
+  | all isTyVar bndrs           -- Type lambdas are ok
+  = return (emptyFloats, expr)
+  | otherwise                   -- Some value lambdas
+  = do { fn <- newVar (exprType expr)
+       ; let rhs   = cpeEtaExpand (exprArity expr) expr
+             float = FloatLet (NonRec fn rhs)
+       ; return (unitFloat float, Var fn) }
+  where
+    (bndrs,body) = collectBinders expr
+
+rhsToBody expr = return (emptyFloats, expr)
+
+
+
+-- ---------------------------------------------------------------------------
+--              CpeApp: produces a result satisfying CpeApp
+-- ---------------------------------------------------------------------------
+
+data ArgInfo = CpeApp  CoreArg
+             | CpeCast Coercion
+             | CpeTick (Tickish Id)
+
+{- Note [runRW arg]
+~~~~~~~~~~~~~~~~~~~
+If we got, say
+   runRW# (case bot of {})
+which happened in #11291, we do /not/ want to turn it into
+   (case bot of {}) realWorldPrimId#
+because that gives a panic in CoreToStg.myCollectArgs, which expects
+only variables in function position.  But if we are sure to make
+runRW# strict (which we do in MkId), this can't happen
+-}
+
+cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
+-- May return a CpeRhs because of saturating primops
+cpeApp top_env expr
+  = do { let (terminal, args, depth) = collect_args expr
+       ; cpe_app top_env terminal args depth
+       }
+
+  where
+    -- We have a nested data structure of the form
+    -- e `App` a1 `App` a2 ... `App` an, convert it into
+    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
+    -- We use 'ArgInfo' because we may also need to
+    -- record casts and ticks.  Depth counts the number
+    -- of arguments that would consume strictness information
+    -- (so, no type or coercion arguments.)
+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
+    collect_args e = go e [] 0
+      where
+        go (App fun arg)      as !depth
+            = go fun (CpeApp arg : as)
+                (if isTyCoArg arg then depth else depth + 1)
+        go (Cast fun co)      as depth
+            = go fun (CpeCast co : as) depth
+        go (Tick tickish fun) as depth
+            | tickishPlace tickish == PlaceNonLam
+            && tickish `tickishScopesLike` SoftScope
+            = go fun (CpeTick tickish : as) depth
+        go terminal as depth = (terminal, as, depth)
+
+    cpe_app :: CorePrepEnv
+            -> CoreExpr
+            -> [ArgInfo]
+            -> Int
+            -> UniqSM (Floats, CpeRhs)
+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
+        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
+       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a
+        -- Consider the code:
+        --
+        --      lazy (f x) y
+        --
+        -- We need to make sure that we need to recursively collect arguments on
+        -- "f x", otherwise we'll float "f x" out (it's not a variable) and
+        -- end up with this awful -ddump-prep:
+        --
+        --      case f x of f_x {
+        --        __DEFAULT -> f_x y
+        --      }
+        --
+        -- rather than the far superior "f x y".  Test case is par01.
+        = let (terminal, args', depth') = collect_args arg
+          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
+    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
+        | f `hasKey` runRWKey
+        -- See Note [runRW magic]
+        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
+        -- is why we return a CorePrepEnv as well)
+        = case arg of
+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
+            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
+    cpe_app env (Var v) args depth
+      = do { v1 <- fiddleCCall v
+           ; let e2 = lookupCorePrepEnv env v1
+                 hd = getIdFromTrivialExpr_maybe e2
+           -- NB: depth from collect_args is right, because e2 is a trivial expression
+           -- and thus its embedded Id *must* be at the same depth as any
+           -- Apps it is under are type applications only (c.f.
+           -- exprIsTrivial).  But note that we need the type of the
+           -- expression, not the id.
+           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
+           ; mb_saturate hd app floats depth }
+        where
+          stricts = case idStrictness v of
+                            StrictSig (DmdType _ demands _)
+                              | listLengthCmp demands depth /= GT -> demands
+                                    -- length demands <= depth
+                              | otherwise                         -> []
+                -- If depth < length demands, then we have too few args to
+                -- satisfy strictness  info so we have to  ignore all the
+                -- strictness info, e.g. + (error "urk")
+                -- Here, we can't evaluate the arg strictly, because this
+                -- partial application might be seq'd
+
+        -- We inlined into something that's not a var and has no args.
+        -- Bounce it back up to cpeRhsE.
+    cpe_app env fun [] _ = cpeRhsE env fun
+
+        -- N-variable fun, better let-bind it
+    cpe_app env fun args depth
+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
+                          -- The evalDmd says that it's sure to be evaluated,
+                          -- so we'll end up case-binding it
+           ; (app, floats) <- rebuild_app args fun' ty fun_floats []
+           ; mb_saturate Nothing app floats depth }
+        where
+          ty = exprType fun
+
+    -- Saturate if necessary
+    mb_saturate head app floats depth =
+       case head of
+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
+                          ; return (floats, sat_app) }
+         _other              -> return (floats, app)
+
+    -- Deconstruct and rebuild the application, floating any non-atomic
+    -- arguments to the outside.  We collect the type of the expression,
+    -- the head of the application, and the number of actual value arguments,
+    -- all of which are used to possibly saturate this application if it
+    -- has a constructor or primop at the head.
+    rebuild_app
+        :: [ArgInfo]                  -- The arguments (inner to outer)
+        -> CpeApp
+        -> Type
+        -> Floats
+        -> [Demand]
+        -> UniqSM (CpeApp, Floats)
+    rebuild_app [] app _ floats ss = do
+      MASSERT(null ss) -- make sure we used all the strictness info
+      return (app, floats)
+    rebuild_app (a : as) fun' fun_ty floats ss = case a of
+      CpeApp arg@(Type arg_ty) ->
+        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
+      CpeApp arg@(Coercion {}) ->
+        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
+      CpeApp arg -> do
+        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId
+               = case (ss, isLazyExpr arg) of
+                   (_   : ss_rest, True)  -> (topDmd, ss_rest)
+                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)
+                   ([],            _)     -> (topDmd, [])
+            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
+                               splitFunTy_maybe fun_ty
+        (fs, arg') <- cpeArg top_env ss1 arg arg_ty
+        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
+      CpeCast co ->
+        let Pair _ty1 ty2 = coercionKind co
+        in rebuild_app as (Cast fun' co) ty2 floats ss
+      CpeTick tickish ->
+        -- See [Floating Ticks in CorePrep]
+        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss
+
+isLazyExpr :: CoreExpr -> Bool
+-- See Note [lazyId magic] in MkId
+isLazyExpr (Cast e _)              = isLazyExpr e
+isLazyExpr (Tick _ e)              = isLazyExpr e
+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
+isLazyExpr _                       = False
+
+{- Note [runRW magic]
+~~~~~~~~~~~~~~~~~~~~~
+Some definitions, for instance @runST@, must have careful control over float out
+of the bindings in their body. Consider this use of @runST@,
+
+    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
+                             (_, s'') = fill_in_array_or_something a x s'
+                         in freezeArray# a s'' )
+
+If we inline @runST@, we'll get:
+
+    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
+              (_, s'') = fill_in_array_or_something a x s'
+          in freezeArray# a s''
+
+And now if we allow the @newArray#@ binding to float out to become a CAF,
+we end up with a result that is totally and utterly wrong:
+
+    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
+        in \ x ->
+            let (_, s'') = fill_in_array_or_something a x s'
+            in freezeArray# a s''
+
+All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
+must be prevented.
+
+This is what @runRW#@ gives us: by being inlined extremely late in the
+optimization (right before lowering to STG, in CorePrep), we can ensure that
+no further floating will occur. This allows us to safely inline things like
+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).
+
+'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE
+pragma.  It is levity-polymorphic.
+
+    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
+           => (State# RealWorld -> (# State# RealWorld, o #))
+                              -> (# State# RealWorld, o #)
+
+It needs no special treatment in GHC except this special inlining here
+in CorePrep (and in ByteCodeGen).
+
+-- ---------------------------------------------------------------------------
+--      CpeArg: produces a result satisfying CpeArg
+-- ---------------------------------------------------------------------------
+
+Note [ANF-ising literal string arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider a program like,
+
+    data Foo = Foo Addr#
+
+    foo = Foo "turtle"#
+
+When we go to ANFise this we might think that we want to float the string
+literal like we do any other non-trivial argument. This would look like,
+
+    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }
+
+However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
+wreaks havoc on the CAF annotations that we produce here since we the result
+above is caffy since it is updateable. Ideally at some point in the future we
+would like to just float the literal to the top level as suggested in #11312,
+
+    s = "turtle"#
+    foo = Foo s
+
+However, until then we simply add a special case excluding literals from the
+floating done by cpeArg.
+-}
+
+-- | Is an argument okay to CPE?
+okCpeArg :: CoreExpr -> Bool
+-- Don't float literals. See Note [ANF-ising literal string arguments].
+okCpeArg (Lit _) = False
+-- Do not eta expand a trivial argument
+okCpeArg expr    = not (exprIsTrivial expr)
+
+-- This is where we arrange that a non-trivial argument is let-bound
+cpeArg :: CorePrepEnv -> Demand
+       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)
+cpeArg env dmd arg arg_ty
+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
+       ; (floats2, arg2) <- if want_float floats1 arg1
+                            then return (floats1, arg1)
+                            else dontFloat floats1 arg1
+                -- Else case: arg1 might have lambdas, and we can't
+                --            put them inside a wrapBinds
+
+       ; if okCpeArg arg2
+         then do { v <- newVar arg_ty
+                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
+                       arg_float = mkFloat dmd is_unlifted v arg3
+                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }
+         else return (floats2, arg2)
+       }
+  where
+    is_unlifted = isUnliftedType arg_ty
+    want_float  = wantFloatNested NonRecursive dmd is_unlifted
+
+{-
+Note [Floating unlifted arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider    C (let v* = expensive in v)
+
+where the "*" indicates "will be demanded".  Usually v will have been
+inlined by now, but let's suppose it hasn't (see #2756).  Then we
+do *not* want to get
+
+     let v* = expensive in C v
+
+because that has different strictness.  Hence the use of 'allLazy'.
+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
+
+
+------------------------------------------------------------------------------
+-- Building the saturated syntax
+-- ---------------------------------------------------------------------------
+
+maybeSaturate deals with saturating primops and constructors
+The type is the type of the entire application
+-}
+
+maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
+maybeSaturate fn expr n_args
+  | hasNoBinding fn        -- There's no binding
+  = return sat_expr
+
+  | otherwise
+  = return expr
+  where
+    fn_arity     = idArity fn
+    excess_arity = fn_arity - n_args
+    sat_expr     = cpeEtaExpand excess_arity expr
+
+{-
+************************************************************************
+*                                                                      *
+                Simple CoreSyn operations
+*                                                                      *
+************************************************************************
+-}
+
+{-
+-- -----------------------------------------------------------------------------
+--      Eta reduction
+-- -----------------------------------------------------------------------------
+
+Note [Eta expansion]
+~~~~~~~~~~~~~~~~~~~~~
+Eta expand to match the arity claimed by the binder Remember,
+CorePrep must not change arity
+
+Eta expansion might not have happened already, because it is done by
+the simplifier only when there at least one lambda already.
+
+NB1:we could refrain when the RHS is trivial (which can happen
+    for exported things).  This would reduce the amount of code
+    generated (a little) and make things a little words for
+    code compiled without -O.  The case in point is data constructor
+    wrappers.
+
+NB2: we have to be careful that the result of etaExpand doesn't
+   invalidate any of the assumptions that CorePrep is attempting
+   to establish.  One possible cause is eta expanding inside of
+   an SCC note - we're now careful in etaExpand to make sure the
+   SCC is pushed inside any new lambdas that are generated.
+
+Note [Eta expansion and the CorePrep invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It turns out to be much much easier to do eta expansion
+*after* the main CorePrep stuff.  But that places constraints
+on the eta expander: given a CpeRhs, it must return a CpeRhs.
+
+For example here is what we do not want:
+                f = /\a -> g (h 3)      -- h has arity 2
+After ANFing we get
+                f = /\a -> let s = h 3 in g s
+and now we do NOT want eta expansion to give
+                f = /\a -> \ y -> (let s = h 3 in g s) y
+
+Instead CoreArity.etaExpand gives
+                f = /\a -> \y -> let s = h 3 in g s y
+-}
+
+cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
+cpeEtaExpand arity expr
+  | arity == 0 = expr
+  | otherwise  = etaExpand arity expr
+
+{-
+-- -----------------------------------------------------------------------------
+--      Eta reduction
+-- -----------------------------------------------------------------------------
+
+Why try eta reduction?  Hasn't the simplifier already done eta?
+But the simplifier only eta reduces if that leaves something
+trivial (like f, or f Int).  But for deLam it would be enough to
+get to a partial application:
+        case x of { p -> \xs. map f xs }
+    ==> case x of { p -> map f }
+-}
+
+tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
+tryEtaReducePrep bndrs expr@(App _ _)
+  | ok_to_eta_reduce f
+  , n_remaining >= 0
+  , and (zipWith ok bndrs last_args)
+  , not (any (`elemVarSet` fvs_remaining) bndrs)
+  , exprIsHNF remaining_expr   -- Don't turn value into a non-value
+                               -- else the behaviour with 'seq' changes
+  = Just remaining_expr
+  where
+    (f, args) = collectArgs expr
+    remaining_expr = mkApps f remaining_args
+    fvs_remaining = exprFreeVars remaining_expr
+    (remaining_args, last_args) = splitAt n_remaining args
+    n_remaining = length args - length bndrs
+
+    ok bndr (Var arg) = bndr == arg
+    ok _    _         = False
+
+          -- We can't eta reduce something which must be saturated.
+    ok_to_eta_reduce (Var f) = not (hasNoBinding f)
+    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise
+
+tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
+  | not (any (`elemVarSet` fvs) bndrs)
+  = case tryEtaReducePrep bndrs body of
+        Just e -> Just (Let bind e)
+        Nothing -> Nothing
+  where
+    fvs = exprFreeVars r
+
+-- NB: do not attempt to eta-reduce across ticks
+-- Otherwise we risk reducing
+--       \x. (Tick (Breakpoint {x}) f x)
+--   ==> Tick (breakpoint {x}) f
+-- which is bogus (#17228)
+-- tryEtaReducePrep bndrs (Tick tickish e)
+--   = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
+
+tryEtaReducePrep _ _ = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+                Floats
+*                                                                      *
+************************************************************************
+
+Note [Pin demand info on floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pin demand info on floated lets, so that we can see the one-shot thunks.
+-}
+
+data FloatingBind
+  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
+                         -- They are always of lifted type;
+                         -- unlifted ones are done with FloatCase
+
+ | FloatCase
+      Id CpeBody
+      Bool              -- The bool indicates "ok-for-speculation"
+
+ -- | See Note [Floating Ticks in CorePrep]
+ | FloatTick (Tickish Id)
+
+data Floats = Floats OkToSpec (OrdList FloatingBind)
+
+instance Outputable FloatingBind where
+  ppr (FloatLet b) = ppr b
+  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
+  ppr (FloatTick t) = ppr t
+
+instance Outputable Floats where
+  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
+                         braces (vcat (map ppr (fromOL fs)))
+
+instance Outputable OkToSpec where
+  ppr OkToSpec    = text "OkToSpec"
+  ppr IfUnboxedOk = text "IfUnboxedOk"
+  ppr NotOkToSpec = text "NotOkToSpec"
+
+-- Can we float these binds out of the rhs of a let?  We cache this decision
+-- to avoid having to recompute it in a non-linear way when there are
+-- deeply nested lets.
+data OkToSpec
+   = OkToSpec           -- Lazy bindings of lifted type
+   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n
+                        -- ok-to-speculate unlifted bindings
+   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings
+
+mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+mkFloat dmd is_unlifted bndr rhs
+  | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)
+  | is_hnf    = FloatLet (NonRec bndr                       rhs)
+  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
+                   -- See Note [Pin demand info on floats]
+  where
+    is_hnf    = exprIsHNF rhs
+    is_strict = isStrictDmd dmd
+    use_case  = is_unlifted || is_strict && not is_hnf
+                -- Don't make a case for a value binding,
+                -- even if it's strict.  Otherwise we get
+                --      case (\x -> e) of ...!
+
+emptyFloats :: Floats
+emptyFloats = Floats OkToSpec nilOL
+
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats _ bs) = isNilOL bs
+
+wrapBinds :: Floats -> CpeBody -> CpeBody
+wrapBinds (Floats _ binds) body
+  = foldrOL mk_bind body binds
+  where
+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
+    mk_bind (FloatLet bind)        body = Let bind body
+    mk_bind (FloatTick tickish)    body = mkTick tickish body
+
+addFloat :: Floats -> FloatingBind -> Floats
+addFloat (Floats ok_to_spec floats) new_float
+  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
+  where
+    check (FloatLet _) = OkToSpec
+    check (FloatCase _ _ ok_for_spec)
+        | ok_for_spec  =  IfUnboxedOk
+        | otherwise    =  NotOkToSpec
+    check FloatTick{}  = OkToSpec
+        -- The ok-for-speculation flag says that it's safe to
+        -- float this Case out of a let, and thereby do it more eagerly
+        -- We need the top-level flag because it's never ok to float
+        -- an unboxed binding to the top level
+
+unitFloat :: FloatingBind -> Floats
+unitFloat = addFloat emptyFloats
+
+appendFloats :: Floats -> Floats -> Floats
+appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
+  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
+
+concatFloats :: [Floats] -> OrdList FloatingBind
+concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
+
+combine :: OkToSpec -> OkToSpec -> OkToSpec
+combine NotOkToSpec _ = NotOkToSpec
+combine _ NotOkToSpec = NotOkToSpec
+combine IfUnboxedOk _ = IfUnboxedOk
+combine _ IfUnboxedOk = IfUnboxedOk
+combine _ _           = OkToSpec
+
+deFloatTop :: Floats -> [CoreBind]
+-- For top level only; we don't expect any FloatCases
+deFloatTop (Floats _ floats)
+  = foldrOL get [] floats
+  where
+    get (FloatLet b) bs = occurAnalyseRHSs b : bs
+    get (FloatCase var body _) bs  =
+      occurAnalyseRHSs (NonRec var body) : bs
+    get b _ = pprPanic "corePrepPgm" (ppr b)
+
+    -- See Note [Dead code in CorePrep]
+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
+
+---------------------------------------------------------------------------
+
+canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
+       -- Note [CafInfo and floating]
+canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
+  | OkToSpec <- ok_to_spec           -- Worth trying
+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
+  = Just (Floats OkToSpec fs', subst_expr subst rhs)
+  | otherwise
+  = Nothing
+  where
+    subst_expr = substExpr (text "CorePrep")
+
+    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
+       -> Maybe (Subst, OrdList FloatingBind)
+
+    go (subst, fbs_out) [] = Just (subst, fbs_out)
+
+    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
+      | rhs_ok r
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
+      where
+        (subst', b') = set_nocaf_bndr subst b
+        new_fb = FloatLet (NonRec b' (subst_expr subst r))
+
+    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
+      | all rhs_ok rs
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
+      where
+        (bs,rs) = unzip prs
+        (subst', bs') = mapAccumL set_nocaf_bndr subst bs
+        rs' = map (subst_expr subst') rs
+        new_fb = FloatLet (Rec (bs' `zip` rs'))
+
+    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
+      = go (subst, fbs_out `snocOL` ft) fbs_in
+
+    go _ _ = Nothing      -- Encountered a caffy binding
+
+    ------------
+    set_nocaf_bndr subst bndr
+      = (extendIdSubst subst bndr (Var bndr'), bndr')
+      where
+        bndr' = bndr `setIdCafInfo` NoCafRefs
+
+    ------------
+    rhs_ok :: CoreExpr -> Bool
+    -- We can only float to top level from a NoCaf thing if
+    -- the new binding is static. However it can't mention
+    -- any non-static things or it would *already* be Caffy
+    rhs_ok = rhsIsStatic platform (\_ -> False)
+                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))
+                         -- Integer or Natural literals should not show up
+
+wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
+wantFloatNested is_rec dmd is_unlifted floats rhs
+  =  isEmptyFloats floats
+  || isStrictDmd dmd
+  || is_unlifted
+  || (allLazyNested is_rec floats && exprIsHNF rhs)
+        -- Why the test for allLazyNested?
+        --      v = f (x `divInt#` y)
+        -- we don't want to float the case, even if f has arity 2,
+        -- because floating the case would make it evaluated too early
+
+allLazyTop :: Floats -> Bool
+allLazyTop (Floats OkToSpec _) = True
+allLazyTop _                   = False
+
+allLazyNested :: RecFlag -> Floats -> Bool
+allLazyNested _      (Floats OkToSpec    _) = True
+allLazyNested _      (Floats NotOkToSpec _) = False
+allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
+
+{-
+************************************************************************
+*                                                                      *
+                Cloning
+*                                                                      *
+************************************************************************
+-}
+
+-- ---------------------------------------------------------------------------
+--                      The environment
+-- ---------------------------------------------------------------------------
+
+-- Note [Inlining in CorePrep]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- There is a subtle but important invariant that must be upheld in the output
+-- of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core
+-- is impermissible:
+--
+--      let x :: ()
+--          x = y
+--
+-- (where y is a reference to a GLOBAL variable).  Thunks like this are silly:
+-- they can always be profitably replaced by inlining x with y. Consequently,
+-- the code generator/runtime does not bother implementing this properly
+-- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
+-- stack frame that would be used to update this thunk.  The "0" means it has
+-- zero free variables.)
+--
+-- In general, the inliner is good at eliminating these let-bindings.  However,
+-- there is one case where these trivial updatable thunks can arise: when
+-- we are optimizing away 'lazy' (see Note [lazyId magic], and also
+-- 'cpeRhsE'.)  Then, we could have started with:
+--
+--      let x :: ()
+--          x = lazy @ () y
+--
+-- which is a perfectly fine, non-trivial thunk, but then CorePrep will
+-- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
+-- The solution is CorePrep to have a miniature inlining pass which deals
+-- with cases like this.  We can then drop the let-binding altogether.
+--
+-- Why does the removal of 'lazy' have to occur in CorePrep?
+-- The gory details are in Note [lazyId magic] in MkId, but the
+-- main reason is that lazy must appear in unfoldings (optimizer
+-- output) and it must prevent call-by-value for catch# (which
+-- is implemented by CorePrep.)
+--
+-- An alternate strategy for solving this problem is to have the
+-- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
+-- We decided not to adopt this solution to keep the definition
+-- of 'exprIsTrivial' simple.
+--
+-- There is ONE caveat however: for top-level bindings we have
+-- to preserve the binding so that we float the (hacky) non-recursive
+-- binding for data constructors; see Note [Data constructor workers].
+--
+-- Note [CorePrep inlines trivial CoreExpr not Id]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
+-- IdEnv Id?  Naively, we might conjecture that trivial updatable thunks
+-- as per Note [Inlining in CorePrep] always have the form
+-- 'lazy @ SomeType gbl_id'.  But this is not true: the following is
+-- perfectly reasonable Core:
+--
+--      let x :: ()
+--          x = lazy @ (forall a. a) y @ Bool
+--
+-- When we inline 'x' after eliminating 'lazy', we need to replace
+-- occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like
+-- this can easily arise with higher-rank types; thus, cpe_env must
+-- map to CoreExprs, not Ids.
+
+data CorePrepEnv
+  = CPE { cpe_dynFlags        :: DynFlags
+        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids
+        -- ^ This environment is used for three operations:
+        --
+        --      1. To support cloning of local Ids so that they are
+        --      all unique (see item (6) of CorePrep overview).
+        --
+        --      2. To support beta-reduction of runRW, see
+        --      Note [runRW magic] and Note [runRW arg].
+        --
+        --      3. To let us inline trivial RHSs of non top-level let-bindings,
+        --      see Note [lazyId magic], Note [Inlining in CorePrep]
+        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
+        , cpe_mkIntegerId     :: Id
+        , cpe_mkNaturalId     :: Id
+        , cpe_integerSDataCon :: Maybe DataCon
+        , cpe_naturalSDataCon :: Maybe DataCon
+    }
+
+lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
+lookupMkIntegerName dflags hsc_env
+    = guardIntegerUse dflags $ liftM tyThingId $
+      lookupGlobal hsc_env mkIntegerName
+
+lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
+lookupMkNaturalName dflags hsc_env
+    = guardNaturalUse dflags $ liftM tyThingId $
+      lookupGlobal hsc_env mkNaturalName
+
+-- See Note [The integer library] in PrelNames
+lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of
+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env integerSDataConName
+    IntegerSimple -> return Nothing
+
+lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of
+    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env naturalSDataConName
+    IntegerSimple -> return Nothing
+
+-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
+guardIntegerUse :: DynFlags -> IO a -> IO a
+guardIntegerUse dflags act
+  | thisPackage dflags == primUnitId
+  = return $ panic "Can't use Integer in ghc-prim"
+  | thisPackage dflags == integerUnitId
+  = return $ panic "Can't use Integer in integer-*"
+  | otherwise = act
+
+-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
+--
+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural
+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
+guardNaturalUse :: DynFlags -> IO a -> IO a
+guardNaturalUse dflags act
+  | thisPackage dflags == primUnitId
+  = return $ panic "Can't use Natural in ghc-prim"
+  | thisPackage dflags == integerUnitId
+  = return $ panic "Can't use Natural in integer-*"
+  | thisPackage dflags == baseUnitId
+  = return $ panic "Can't use Natural in base"
+  | otherwise = act
+
+mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
+mkInitialCorePrepEnv dflags hsc_env
+    = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+         mkNaturalId <- lookupMkNaturalName dflags hsc_env
+         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+         return $ CPE {
+                      cpe_dynFlags = dflags,
+                      cpe_env = emptyVarEnv,
+                      cpe_mkIntegerId = mkIntegerId,
+                      cpe_mkNaturalId = mkNaturalId,
+                      cpe_integerSDataCon = integerSDataCon,
+                      cpe_naturalSDataCon = naturalSDataCon
+                  }
+
+extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
+extendCorePrepEnv cpe id id'
+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
+
+extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
+extendCorePrepEnvExpr cpe id expr
+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
+
+extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
+extendCorePrepEnvList cpe prs
+    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
+                        (map (\(id, id') -> (id, Var id')) prs) }
+
+lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
+lookupCorePrepEnv cpe id
+  = case lookupVarEnv (cpe_env cpe) id of
+        Nothing  -> Var id
+        Just exp -> exp
+
+getMkIntegerId :: CorePrepEnv -> Id
+getMkIntegerId = cpe_mkIntegerId
+
+getMkNaturalId :: CorePrepEnv -> Id
+getMkNaturalId = cpe_mkNaturalId
+
+------------------------------------------------------------------------------
+-- Cloning binders
+-- ---------------------------------------------------------------------------
+
+cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
+
+cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
+cpCloneBndr env bndr
+  | not (isId bndr)
+  = return (env, bndr)
+
+  | otherwise
+  = do { bndr' <- clone_it bndr
+
+       -- Drop (now-useless) rules/unfoldings
+       -- See Note [Drop unfoldings and rules]
+       -- and Note [Preserve evaluatedness] in CoreTidy
+       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
+                          -- Simplifier will set the Id's unfolding
+
+             bndr'' = bndr' `setIdUnfolding`      unfolding'
+                            `setIdSpecialisation` emptyRuleInfo
+
+       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
+  where
+    clone_it bndr
+      | isLocalId bndr, not (isCoVar bndr)
+      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }
+      | otherwise   -- Top level things, which we don't want
+                    -- to clone, have become GlobalIds by now
+                    -- And we don't clone tyvars, or coercion variables
+      = return bndr
+
+{- Note [Drop unfoldings and rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to drop the unfolding/rules on every Id:
+
+  - We are now past interface-file generation, and in the
+    codegen pipeline, so we really don't need full unfoldings/rules
+
+  - The unfolding/rule may be keeping stuff alive that we'd like
+    to discard.  See  Note [Dead code in CorePrep]
+
+  - Getting rid of unnecessary unfoldings reduces heap usage
+
+  - We are changing uniques, so if we didn't discard unfoldings/rules
+    we'd have to substitute in them
+
+HOWEVER, we want to preserve evaluated-ness;
+see Note [Preserve evaluatedness] in CoreTidy.
+-}
+
+------------------------------------------------------------------------------
+-- Cloning ccall Ids; each must have a unique name,
+-- to give the code generator a handle to hang it on
+-- ---------------------------------------------------------------------------
+
+fiddleCCall :: Id -> UniqSM Id
+fiddleCCall id
+  | isFCallId id = (id `setVarUnique`) <$> getUniqueM
+  | otherwise    = return id
+
+------------------------------------------------------------------------------
+-- Generating new binders
+-- ---------------------------------------------------------------------------
+
+newVar :: Type -> UniqSM Id
+newVar ty
+ = seqType ty `seq` do
+     uniq <- getUniqueM
+     return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
+
+
+------------------------------------------------------------------------------
+-- Floating ticks
+-- ---------------------------------------------------------------------------
+--
+-- Note [Floating Ticks in CorePrep]
+--
+-- It might seem counter-intuitive to float ticks by default, given
+-- that we don't actually want to move them if we can help it. On the
+-- other hand, nothing gets very far in CorePrep anyway, and we want
+-- to preserve the order of let bindings and tick annotations in
+-- relation to each other. For example, if we just wrapped let floats
+-- when they pass through ticks, we might end up performing the
+-- following transformation:
+--
+--   src<...> let foo = bar in baz
+--   ==>  let foo = src<...> bar in src<...> baz
+--
+-- Because the let-binding would float through the tick, and then
+-- immediately materialize, achieving nothing but decreasing tick
+-- accuracy. The only special case is the following scenario:
+--
+--   let foo = src<...> (let a = b in bar) in baz
+--   ==>  let foo = src<...> bar; a = src<...> b in baz
+--
+-- Here we would not want the source tick to end up covering "baz" and
+-- therefore refrain from pushing ticks outside. Instead, we copy them
+-- into the floating binds (here "a") in cpePair. Note that where "b"
+-- or "bar" are (value) lambdas we have to push the annotations
+-- further inside in order to uphold our rules.
+--
+-- All of this is implemented below in @wrapTicks@.
+
+-- | Like wrapFloats, but only wraps tick floats
+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
+wrapTicks (Floats flag floats0) expr =
+    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
+  where (floats1, ticks1) = foldlOL go ([], []) $ floats0
+        -- Deeply nested constructors will produce long lists of
+        -- redundant source note floats here. We need to eliminate
+        -- those early, as relying on mkTick to spot it after the fact
+        -- can yield O(n^3) complexity [#11095]
+        go (floats, ticks) (FloatTick t)
+          = ASSERT(tickishPlace t == PlaceNonLam)
+            (floats, if any (flip tickishContains t) ticks
+                     then ticks else t:ticks)
+        go (floats, ticks) f
+          = (foldr wrap f (reverse ticks):floats, ticks)
+
+        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)
+        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
+        wrap _ other              = pprPanic "wrapTicks: unexpected float!"
+                                             (ppr other)
+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
+
+------------------------------------------------------------------------------
+-- Collecting cost centres
+-- ---------------------------------------------------------------------------
+
+-- | Collect cost centres defined in the current module, including those in
+-- unfoldings.
+collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
+collectCostCentres mod_name
+  = foldl' go_bind S.empty
+  where
+    go cs e = case e of
+      Var{} -> cs
+      Lit{} -> cs
+      App e1 e2 -> go (go cs e1) e2
+      Lam _ e -> go cs e
+      Let b e -> go (go_bind cs b) e
+      Case scrt _ _ alts -> go_alts (go cs scrt) alts
+      Cast e _ -> go cs e
+      Tick (ProfNote cc _ _) e ->
+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
+      Tick _ e -> go cs e
+      Type{} -> cs
+      Coercion{} -> cs
+
+    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)
+
+    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
+    go_bind cs (NonRec b e) =
+      go (maybe cs (go cs) (get_unf b)) e
+    go_bind cs (Rec bs) =
+      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs
+
+    -- Unfoldings may have cost centres that in the original definion are
+    -- optimized away, see #5889.
+    get_unf = maybeUnfoldingTemplate . realIdUnfolding
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Check.hs
@@ -0,0 +1,2753 @@
+{-
+Author: George Karachalias <george.karachalias@cs.kuleuven.be>
+
+Pattern Matching Coverage Checking.
+-}
+
+{-# LANGUAGE CPP            #-}
+{-# LANGUAGE GADTs          #-}
+{-# LANGUAGE DataKinds      #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TupleSections  #-}
+{-# LANGUAGE ViewPatterns   #-}
+{-# LANGUAGE MultiWayIf     #-}
+
+module Check (
+        -- Checking and printing
+        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,
+
+        -- See Note [Type and Term Equality Propagation]
+        genCaseTmCs1, genCaseTmCs2
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TmOracle
+import Unify( tcMatchTy )
+import DynFlags
+import HsSyn
+import TcHsSyn
+import Id
+import ConLike
+import Name
+import FamInstEnv
+import TysPrim (tYPETyCon)
+import TysWiredIn
+import TyCon
+import SrcLoc
+import Util
+import Outputable
+import FastString
+import DataCon
+import PatSyn
+import HscTypes (CompleteMatch(..))
+
+import DsMonad
+import TcSimplify    (tcCheckSatisfiability)
+import TcType        (isStringTy)
+import Bag
+import ErrUtils
+import Var           (EvVar)
+import TyCoRep
+import Type
+import UniqSupply
+import DsUtils       (isTrueLHsExpr)
+import Maybes        (expectJust)
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List     (find)
+import Data.Maybe    (catMaybes, isJust, fromMaybe)
+import Control.Monad (forM, when, forM_, zipWithM, filterM)
+import Coercion
+import TcEvidence
+import TcSimplify    (tcNormalise)
+import IOEnv
+import qualified Data.Semigroup as Semi
+
+import ListT (ListT(..), fold, select)
+
+{-
+This module checks pattern matches for:
+\begin{enumerate}
+  \item Equations that are redundant
+  \item Equations with inaccessible right-hand-side
+  \item Exhaustiveness
+\end{enumerate}
+
+The algorithm is based on the paper:
+
+  "GADTs Meet Their Match:
+     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"
+
+    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf
+
+%************************************************************************
+%*                                                                      *
+                     Pattern Match Check Types
+%*                                                                      *
+%************************************************************************
+-}
+
+-- We use the non-determinism monad to apply the algorithm to several
+-- possible sets of constructors. Users can specify complete sets of
+-- constructors by using COMPLETE pragmas.
+-- The algorithm only picks out constructor
+-- sets deep in the bowels which makes a simpler `mapM` more difficult to
+-- implement. The non-determinism is only used in one place, see the ConVar
+-- case in `pmCheckHd`.
+
+type PmM a = ListT DsM a
+
+liftD :: DsM a -> PmM a
+liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
+
+-- Pick the first match complete covered match or otherwise the "best" match.
+-- The best match is the one with the least uncovered clauses, ties broken
+-- by the number of inaccessible clauses followed by number of redundant
+-- clauses.
+--
+-- This is specified in the
+-- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the
+-- users' guide. If you update the implementation of this function, make sure
+-- to update that section of the users' guide as well.
+getResult :: PmM PmResult -> DsM PmResult
+getResult ls
+  = do { res <- fold ls goM (pure Nothing)
+       ; case res of
+            Nothing -> panic "getResult is empty"
+            Just a  -> return a }
+  where
+    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)
+    goM mpm dpm = do { pmr <- dpm
+                     ; return $ Just $ go pmr mpm }
+
+    -- Careful not to force unecessary results
+    go :: Maybe PmResult -> PmResult -> PmResult
+    go Nothing rs = rs
+    go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new
+      | null us && null rs && null is = old
+      | otherwise =
+        let PmResult prov' rs' (UncoveredPatterns us') is' = new
+        in case compareLength us us'
+                `mappend` (compareLength is is')
+                `mappend` (compareLength rs rs')
+                `mappend` (compare prov prov') of
+              GT  -> new
+              EQ  -> new
+              LT  -> old
+    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new
+      = panic "getResult: No inhabitation candidates"
+
+data PatTy = PAT | VA -- Used only as a kind, to index PmPat
+
+-- The *arity* of a PatVec [p1,..,pn] is
+-- the number of p1..pn that are not Guards
+
+data PmPat :: PatTy -> * where
+  PmCon  :: { pm_con_con     :: ConLike
+            , pm_con_arg_tys :: [Type]
+            , pm_con_tvs     :: [TyVar]
+            , pm_con_dicts   :: [EvVar]
+            , pm_con_args    :: [PmPat t] } -> PmPat t
+            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs
+  PmVar  :: { pm_var_id   :: Id } -> PmPat t
+  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]
+  PmNLit :: { pm_lit_id   :: Id
+            , pm_lit_not  :: [PmLit] } -> PmPat 'VA
+  PmGrd  :: { pm_grd_pv   :: PatVec
+            , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+  -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.
+  PmFake :: PmPat 'PAT
+
+instance Outputable (PmPat a) where
+  ppr = pprPmPatDebug
+
+-- data T a where
+--     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]
+-- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r
+
+type Pattern = PmPat 'PAT -- ^ Patterns
+type ValAbs  = PmPat 'VA  -- ^ Value Abstractions
+
+type PatVec = [Pattern]             -- ^ Pattern Vectors
+data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions
+
+-- | Term and type constraints to accompany each value vector abstraction.
+-- For efficiency, we store the term oracle state instead of the term
+-- constraints. TODO: Do the same for the type constraints?
+data Delta = MkDelta { delta_ty_cs :: Bag EvVar
+                     , delta_tm_cs :: TmState }
+
+type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions
+type Uncovered = ValSetAbs
+
+-- Instead of keeping the whole sets in memory, we keep a boolean for both the
+-- covered and the divergent set (we store the uncovered set though, since we
+-- want to print it). For both the covered and the divergent we have:
+--
+--   True <=> The set is non-empty
+--
+-- hence:
+--  C = True             ==> Useful clause (no warning)
+--  C = False, D = True  ==> Clause with inaccessible RHS
+--  C = False, D = False ==> Redundant clause
+
+data Covered = Covered | NotCovered
+  deriving Show
+
+instance Outputable Covered where
+  ppr (Covered) = text "Covered"
+  ppr (NotCovered) = text "NotCovered"
+
+-- Like the or monoid for booleans
+-- Covered = True, Uncovered = False
+instance Semi.Semigroup Covered where
+  Covered <> _ = Covered
+  _ <> Covered = Covered
+  NotCovered <> NotCovered = NotCovered
+
+instance Monoid Covered where
+  mempty = NotCovered
+  mappend = (Semi.<>)
+
+data Diverged = Diverged | NotDiverged
+  deriving Show
+
+instance Outputable Diverged where
+  ppr Diverged = text "Diverged"
+  ppr NotDiverged = text "NotDiverged"
+
+instance Semi.Semigroup Diverged where
+  Diverged <> _ = Diverged
+  _ <> Diverged = Diverged
+  NotDiverged <> NotDiverged = NotDiverged
+
+instance Monoid Diverged where
+  mempty = NotDiverged
+  mappend = (Semi.<>)
+
+-- | When we learned that a given match group is complete
+data Provenance =
+                  FromBuiltin -- ^  From the original definition of the type
+                              --    constructor.
+                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma
+  deriving (Show, Eq, Ord)
+
+instance Outputable Provenance where
+  ppr  = text . show
+
+instance Semi.Semigroup Provenance where
+  FromComplete <> _ = FromComplete
+  _ <> FromComplete = FromComplete
+  _ <> _ = FromBuiltin
+
+instance Monoid Provenance where
+  mempty = FromBuiltin
+  mappend = (Semi.<>)
+
+data PartialResult = PartialResult {
+                        presultProvenance :: Provenance
+                         -- keep track of provenance because we don't want
+                         -- to warn about redundant matches if the result
+                         -- is contaminated with a COMPLETE pragma
+                      , presultCovered :: Covered
+                      , presultUncovered :: Uncovered
+                      , presultDivergent :: Diverged }
+
+instance Outputable PartialResult where
+  ppr (PartialResult prov c vsa d)
+           = text "PartialResult" <+> ppr prov <+> ppr c
+                                  <+> ppr d <+> ppr vsa
+
+
+instance Semi.Semigroup PartialResult where
+  (PartialResult prov1 cs1 vsa1 ds1)
+    <> (PartialResult prov2 cs2 vsa2 ds2)
+      = PartialResult (prov1 Semi.<> prov2)
+                      (cs1 Semi.<> cs2)
+                      (vsa1 Semi.<> vsa2)
+                      (ds1 Semi.<> ds2)
+
+
+instance Monoid PartialResult where
+  mempty = PartialResult mempty mempty [] mempty
+  mappend = (Semi.<>)
+
+-- newtype ChoiceOf a = ChoiceOf [a]
+
+-- | Pattern check result
+--
+-- * Redundant clauses
+-- * Not-covered clauses (or their type, if no pattern is available)
+-- * Clauses with inaccessible RHS
+--
+-- More details about the classification of clauses into useful, redundant
+-- and with inaccessible right hand side can be found here:
+--
+--     https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check
+--
+data PmResult =
+  PmResult {
+      pmresultProvenance   :: Provenance
+    , pmresultRedundant    :: [Located [LPat GhcTc]]
+    , pmresultUncovered    :: UncoveredCandidates
+    , pmresultInaccessible :: [Located [LPat GhcTc]] }
+
+instance Outputable PmResult where
+  ppr pmr = hang (text "PmResult") 2 $ vcat
+    [ text "pmresultProvenance" <+> ppr (pmresultProvenance pmr)
+    , text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)
+    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)
+    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)
+    ]
+
+-- | Either a list of patterns that are not covered, or their type, in case we
+-- have no patterns at hand. Not having patterns at hand can arise when
+-- handling EmptyCase expressions, in two cases:
+--
+-- * The type of the scrutinee is a trivially inhabited type (like Int or Char)
+-- * The type of the scrutinee cannot be reduced to WHNF.
+--
+-- In both these cases we have no inhabitation candidates for the type at hand,
+-- but we don't want to issue just a wildcard as missing. Instead, we print a
+-- type annotated wildcard, so that the user knows what kind of patterns is
+-- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).
+data UncoveredCandidates = UncoveredPatterns Uncovered
+                         | TypeOfUncovered Type
+
+instance Outputable UncoveredCandidates where
+  ppr (UncoveredPatterns uc) = text "UnPat" <+> ppr uc
+  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr ty
+
+-- | The empty pattern check result
+emptyPmResult :: PmResult
+emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []
+
+-- | Non-exhaustive empty case with unknown/trivial inhabitants
+uncoveredWithTy :: Type -> PmResult
+uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []
+
+{-
+%************************************************************************
+%*                                                                      *
+       Entry points to the checker: checkSingle and checkMatches
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | Check a single pattern binding (let)
+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()
+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
+  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
+  mb_pm_res <- tryM (getResult (checkSingle' locn var p))
+  case mb_pm_res of
+    Left  _   -> warnPmIters dflags ctxt
+    Right res -> dsPmWarn dflags ctxt res
+
+-- | Check a single pattern binding (let)
+checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult
+checkSingle' locn var p = do
+  liftD resetPmIterDs -- set the iter-no to zero
+  fam_insts <- liftD dsGetFamInstEnvs
+  clause    <- liftD $ translatePat fam_insts p
+  missing   <- mkInitialUncovered [var]
+  tracePm "checkSingle': missing" (vcat (map pprValVecDebug missing))
+                                  -- no guards
+  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing
+  let us' = UncoveredPatterns us
+  return $ case (cs,ds) of
+    (Covered,  _    )         -> PmResult prov [] us' [] -- useful
+    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant
+    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs
+  where m = [cL locn [cL locn p]]
+
+-- | Exhaustive for guard matches, is used for guards in pattern bindings and
+-- in @MultiIf@ expressions.
+checkGuardMatches :: HsMatchContext Name          -- Match context
+                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs
+                  -> DsM ()
+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
+    dflags <- getDynFlags
+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
+        dsMatchContext = DsMatchContext hs_ctx combinedLoc
+        match = cL combinedLoc $
+                  Match { m_ext = noExt
+                        , m_ctxt = hs_ctx
+                        , m_pats = []
+                        , m_grhss = guards }
+    checkMatches dflags dsMatchContext [] [match]
+checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"
+
+-- | Check a matchgroup (case, functions, etc.)
+checkMatches :: DynFlags -> DsMatchContext
+             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
+checkMatches dflags ctxt vars matches = do
+  tracePmD "checkMatches" (hang (vcat [ppr ctxt
+                               , ppr vars
+                               , text "Matches:"])
+                               2
+                               (vcat (map ppr matches)))
+  mb_pm_res <- tryM $ getResult $ case matches of
+    -- Check EmptyCase separately
+    -- See Note [Checking EmptyCase Expressions]
+    [] | [var] <- vars -> checkEmptyCase' var
+    _normal_match      -> checkMatches' vars matches
+  case mb_pm_res of
+    Left  _   -> warnPmIters dflags ctxt
+    Right res -> dsPmWarn dflags ctxt res
+
+-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty
+-- list of matches. For empty case expressions, use checkEmptyCase' instead.
+checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult
+checkMatches' vars matches
+  | null matches = panic "checkMatches': EmptyCase"
+  | otherwise = do
+      liftD resetPmIterDs -- set the iter-no to zero
+      missing    <- mkInitialUncovered vars
+      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))
+      (prov, rs,us,ds) <- go matches missing
+      return $ PmResult {
+                   pmresultProvenance   = prov
+                 , pmresultRedundant    = map hsLMatchToLPats rs
+                 , pmresultUncovered    = UncoveredPatterns us
+                 , pmresultInaccessible = map hsLMatchToLPats ds }
+  where
+    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered
+       -> PmM (Provenance
+              , [LMatch GhcTc (LHsExpr GhcTc)]
+              , Uncovered
+              , [LMatch GhcTc (LHsExpr GhcTc)])
+    go []     missing = return (mempty, [], missing, [])
+    go (m:ms) missing = do
+      tracePm "checkMatches': go" (ppr m $$ ppr missing)
+      fam_insts          <- liftD dsGetFamInstEnvs
+      (clause, guards)   <- liftD $ translateMatch fam_insts m
+      r@(PartialResult prov cs missing' ds)
+        <- runMany (pmcheckI clause guards) missing
+      tracePm "checkMatches': go: res" (ppr r)
+      (ms_prov, rs, final_u, is)  <- go ms missing'
+      let final_prov = prov `mappend` ms_prov
+      return $ case (cs, ds) of
+        -- useful
+        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)
+        -- redundant
+        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)
+        -- inaccessible
+        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)
+
+    hsLMatchToLPats :: LMatch id body -> Located [LPat id]
+    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
+    hsLMatchToLPats _                                   = panic "checkMatches'"
+
+-- | Check an empty case expression. Since there are no clauses to process, we
+--   only compute the uncovered set. See Note [Checking EmptyCase Expressions]
+--   for details.
+checkEmptyCase' :: Id -> PmM PmResult
+checkEmptyCase' var = do
+  tm_ty_css     <- pmInitialTmTyCs
+  mb_candidates <- inhabitationCandidates (delta_ty_cs tm_ty_css) (idType var)
+  case mb_candidates of
+    -- Inhabitation checking failed / the type is trivially inhabited
+    Left ty -> return (uncoveredWithTy ty)
+
+    -- A list of inhabitant candidates is available: Check for each
+    -- one for the satisfiability of the constraints it gives rise to.
+    Right (_, candidates) -> do
+      missing_m <- flip mapMaybeM candidates $
+          \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
+                                , ic_ty_cs = ty_cs
+                                , ic_strict_arg_tys = strict_arg_tys } -> do
+        mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys
+        pure $ fmap (ValVec [va]) mb_sat
+      return $ if null missing_m
+        then emptyPmResult
+        else PmResult FromBuiltin [] (UncoveredPatterns missing_m) []
+
+-- | Returns 'True' if the argument 'Type' is a fully saturated application of
+-- a closed type constructor.
+--
+-- Closed type constructors are those with a fixed right hand side, as
+-- opposed to e.g. associated types. These are of particular interest for
+-- pattern-match coverage checking, because GHC can exhaustively consider all
+-- possible forms that values of a closed type can take on.
+--
+-- Note that this function is intended to be used to check types of value-level
+-- patterns, so as a consequence, the 'Type' supplied as an argument to this
+-- function should be of kind @Type@.
+pmIsClosedType :: Type -> Bool
+pmIsClosedType ty
+  = case splitTyConApp_maybe ty of
+      Just (tc, ty_args)
+             | is_algebraic_like tc && not (isFamilyTyCon tc)
+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+      _other -> False
+  where
+    -- This returns True for TyCons which /act like/ algebraic types.
+    -- (See "Type#type_classification" for what an algebraic type is.)
+    --
+    -- This is qualified with \"like\" because of a particular special
+    -- case: TYPE (the underlyind kind behind Type, among others). TYPE
+    -- is conceptually a datatype (and thus algebraic), but in practice it is
+    -- a primitive builtin type, so we must check for it specially.
+    --
+    -- NB: it makes sense to think of TYPE as a closed type in a value-level,
+    -- pattern-matching context. However, at the kind level, TYPE is certainly
+    -- not closed! Since this function is specifically tailored towards pattern
+    -- matching, however, it's OK to label TYPE as closed.
+    is_algebraic_like :: TyCon -> Bool
+    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon
+
+pmTopNormaliseType_maybe :: FamInstEnvs -> Bag EvVar -> Type
+                         -> PmM (Maybe (Type, [DataCon], Type))
+-- ^ Get rid of *outermost* (or toplevel)
+--      * type function redex
+--      * data family redex
+--      * newtypes
+--
+-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a
+-- coercion, it returns useful information for issuing pattern matching
+-- warnings. See Note [Type normalisation for EmptyCase] for details.
+--
+-- NB: Normalisation can potentially change kinds, if the head of the type
+-- is a type family with a variable result kind. I (Richard E) can't think
+-- of a way to cause trouble here, though.
+pmTopNormaliseType_maybe env ty_cs typ
+  = do (_, mb_typ') <- liftD $ initTcDsForSolver $ tcNormalise ty_cs typ
+         -- Before proceeding, we chuck typ into the constraint solver, in case
+         -- solving for given equalities may reduce typ some. See
+         -- "Wrinkle: local equalities" in
+         -- Note [Type normalisation for EmptyCase].
+       pure $ do typ' <- mb_typ'
+                 ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ'
+                 -- We need to do topNormaliseTypeX in addition to tcNormalise,
+                 -- since topNormaliseX looks through newtypes, which
+                 -- tcNormalise does not do.
+                 Just (eq_src_ty ty (typ' : ty_f [ty]), tm_f [], ty)
+  where
+    -- Find the first type in the sequence of rewrites that is a data type,
+    -- newtype, or a data family application (not the representation tycon!).
+    -- This is the one that is equal (in source Haskell) to the initial type.
+    -- If none is found in the list, then all of them are type family
+    -- applications, so we simply return the last one, which is the *simplest*.
+    eq_src_ty :: Type -> [Type] -> Type
+    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)
+
+    is_closed_or_data_family :: Type -> Bool
+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty
+
+    -- For efficiency, represent both lists as difference lists.
+    -- comb performs the concatenation, for both lists.
+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)
+
+    stepper = newTypeStepper `composeSteppers` tyFamStepper
+
+    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.
+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])
+    newTypeStepper rec_nts tc tys
+      | Just (ty', _co) <- instNewTyCon_maybe tc tys
+      = case checkRecTc rec_nts tc of
+          Just rec_nts' -> let tyf = ((TyConApp tc tys):)
+                               tmf = ((tyConSingleDataCon tc):)
+                           in  NS_Step rec_nts' ty' (tyf, tmf)
+          Nothing       -> NS_Abort
+      | otherwise
+      = NS_Done
+
+    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])
+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family
+      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in
+          -- NB: It's OK to use normaliseTcArgs here instead of
+          -- normalise_tc_args (which takes the LiftingContext described
+          -- in Note [Normalising types]) because the reduceTyFamApp below
+          -- works only at top level. We'll never recur in this function
+          -- after reducing the kind of a bound tyvar.
+
+        case reduceTyFamApp_maybe env Representational tc ntys of
+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)
+          _               -> NS_Done
+
+-- | Determine suitable constraints to use at the beginning of pattern-match
+-- coverage checking by consulting the sets of term and type constraints
+-- currently in scope. If one of these sets of constraints is unsatisfiable,
+-- use an empty set in its place. (See
+-- @Note [Recovering from unsatisfiable pattern-matching constraints]@
+-- for why this is done.)
+pmInitialTmTyCs :: PmM Delta
+pmInitialTmTyCs = do
+  ty_cs  <- liftD getDictsDs
+  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs
+  sat_ty <- tyOracle ty_cs
+  let initTyCs = if sat_ty then ty_cs else emptyBag
+      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)
+  pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs }
+
+{-
+Note [Recovering from unsatisfiable pattern-matching constraints]
+~~~~~~~~~~~~~~~~
+Consider the following code (see #12957 and #15450):
+
+  f :: Int ~ Bool => ()
+  f = case True of { False -> () }
+
+We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC
+used not to do this; in fact, it would warn that the match was /redundant/!
+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the
+coverage checker deems any matches with unsatifiable constraint sets to be
+unreachable.
+
+We decide to better than this. When beginning coverage checking, we first
+check if the constraints in scope are unsatisfiable, and if so, we start
+afresh with an empty set of constraints. This way, we'll get the warnings
+that we expect.
+-}
+
+-- | Given a conlike's term constraints, type constraints, and strict argument
+-- types, check if they are satisfiable.
+-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet
+-- Their Match paper.)
+--
+-- For the purposes of efficiency, this takes as separate arguments the
+-- ambient term and type constraints (which are known beforehand to be
+-- satisfiable), as well as the new term and type constraints (which may not
+-- be satisfiable). This lets us implement two mini-optimizations:
+--
+-- * If there are no new type constraints, then don't bother initializing
+--   the type oracle, since it's redundant to do so.
+-- * Since the new term constraint is a separate argument, we only need to
+--   execute one iteration of the term oracle (instead of traversing the
+--   entire set of term constraints).
+--
+-- Taking strict argument types into account is something which was not
+-- discussed in GADTs Meet Their Match. For an explanation of what role they
+-- serve, see @Note [Extensions to GADTs Meet Their Match]@.
+pmIsSatisfiable
+  :: Delta     -- ^ The ambient term and type constraints
+               --   (known to be satisfiable).
+  -> ComplexEq -- ^ The new term constraint.
+  -> Bag EvVar -- ^ The new type constraints.
+  -> [Type]    -- ^ The strict argument types.
+  -> PmM (Maybe Delta)
+               -- ^ @'Just' delta@ if the constraints (@delta@) are
+               -- satisfiable, and each strict argument type is inhabitable.
+               -- 'Nothing' otherwise.
+pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do
+  mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs
+  case mb_sat of
+    Nothing -> pure Nothing
+    Just delta -> do
+      -- We know that the term and type constraints are inhabitable, so now
+      -- check if each strict argument type is inhabitable.
+      all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys
+      pure $ if all_non_void -- Check if each strict argument type
+                             -- is inhabitable
+                then Just delta
+                else Nothing
+
+-- | Like 'pmIsSatisfiable', but only checks if term and type constraints are
+-- satisfiable, and doesn't bother checking anything related to strict argument
+-- types.
+tmTyCsAreSatisfiable
+  :: Delta     -- ^ The ambient term and type constraints
+               --   (known to be satisfiable).
+  -> ComplexEq -- ^ The new term constraint.
+  -> Bag EvVar -- ^ The new type constraints.
+  -> PmM (Maybe Delta)
+       -- ^ @'Just' delta@ if the constraints (@delta@) are
+       -- satisfiable. 'Nothing' otherwise.
+tmTyCsAreSatisfiable
+    (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs })
+    new_tm_c new_ty_cs = do
+  let ty_cs = new_ty_cs `unionBags` amb_ty_cs
+  sat_ty <- if isEmptyBag new_ty_cs
+               then pure True
+               else tyOracle ty_cs
+  pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of
+           (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs
+                                                 , delta_tm_cs = term_cs }
+           _unsat               -> Nothing
+
+-- | Implements two performance optimizations, as described in the
+-- \"Strict argument type constraints\" section of
+-- @Note [Extensions to GADTs Meet Their Match]@.
+checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool
+checkAllNonVoid rec_ts amb_cs strict_arg_tys = do
+  fam_insts <- liftD dsGetFamInstEnvs
+  let definitely_inhabited =
+        definitelyInhabitedType fam_insts (delta_ty_cs amb_cs)
+  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys
+  let rec_max_bound | tys_to_check `lengthExceeds` 1
+                    = 1
+                    | otherwise
+                    = defaultRecTcMaxBound
+      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts
+  allM (nonVoid rec_ts' amb_cs) tys_to_check
+
+-- | Checks if a strict argument type of a conlike is inhabitable by a
+-- terminating value (i.e, an 'InhabitationCandidate').
+-- See @Note [Extensions to GADTs Meet Their Match]@.
+nonVoid
+  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.
+  -> Delta        -- ^ The ambient term/type constraints (known to be
+                  --   satisfiable).
+  -> Type         -- ^ The strict argument type.
+  -> PmM Bool     -- ^ 'True' if the strict argument type might be inhabited by
+                  --   a terminating value (i.e., an 'InhabitationCandidate').
+                  --   'False' if it is definitely uninhabitable by anything
+                  --   (except bottom).
+nonVoid rec_ts amb_cs strict_arg_ty = do
+  mb_cands <- inhabitationCandidates (delta_ty_cs amb_cs) strict_arg_ty
+  case mb_cands of
+    Right (tc, cands)
+      |  Just rec_ts' <- checkRecTc rec_ts tc
+      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands
+           -- A strict argument type is inhabitable by a terminating value if
+           -- at least one InhabitationCandidate is inhabitable.
+    _ -> pure True
+           -- Either the type is trivially inhabited or we have exceeded the
+           -- recursion depth for some TyCon (so bail out and conservatively
+           -- claim the type is inhabited).
+  where
+    -- Checks if an InhabitationCandidate for a strict argument type:
+    --
+    -- (1) Has satisfiable term and type constraints.
+    -- (2) Has 'nonVoid' strict argument types (we bail out of this
+    --     check if recursion is detected).
+    --
+    -- See Note [Extensions to GADTs Meet Their Match]
+    cand_is_inhabitable :: RecTcChecker -> Delta
+                        -> InhabitationCandidate -> PmM Bool
+    cand_is_inhabitable rec_ts amb_cs
+      (InhabitationCandidate{ ic_tm_ct          = new_term_c
+                            , ic_ty_cs          = new_ty_cs
+                            , ic_strict_arg_tys = new_strict_arg_tys }) = do
+        mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs
+        case mb_sat of
+          Nothing -> pure False
+          Just new_delta -> do
+            checkAllNonVoid rec_ts new_delta new_strict_arg_tys
+
+-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one
+-- constructor @C@ such that:
+--
+-- 1. @C@ has no equality constraints.
+-- 2. @C@ has no strict argument types.
+--
+-- See the \"Strict argument type constraints\" section of
+-- @Note [Extensions to GADTs Meet Their Match]@.
+definitelyInhabitedType :: FamInstEnvs -> Bag EvVar -> Type -> PmM Bool
+definitelyInhabitedType env ty_cs ty = do
+  mb_res <- pmTopNormaliseType_maybe env ty_cs ty
+  pure $ case mb_res of
+           Just (_, cons, _) -> any meets_criteria cons
+           Nothing           -> False
+  where
+    meets_criteria :: DataCon -> Bool
+    meets_criteria con =
+      null (dataConEqSpec con) && -- (1)
+      null (dataConImplBangs con) -- (2)
+
+{- Note [Type normalisation for EmptyCase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+EmptyCase is an exception for pattern matching, since it is strict. This means
+that it boils down to checking whether the type of the scrutinee is inhabited.
+Function pmTopNormaliseType_maybe gets rid of the outermost type function/data
+family redex and newtypes, in search of an algebraic type constructor, which is
+easier to check for inhabitation.
+
+It returns 3 results instead of one, because there are 2 subtle points:
+1. Newtypes are isomorphic to the underlying type in core but not in the source
+   language,
+2. The representational data family tycon is used internally but should not be
+   shown to the user
+
+Hence, if pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty),
+then
+  (a) src_ty is the rewritten type which we can show to the user. That is, the
+      type we get if we rewrite type families but not data families or
+      newtypes.
+  (b) dcs is the list of data constructors "skipped", every time we normalise a
+      newtype to its core representation, we keep track of the source data
+      constructor.
+  (c) core_ty is the rewritten type. That is,
+        pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty)
+      implies
+        topNormaliseType_maybe env ty = Just (co, core_ty)
+      for some coercion co.
+
+To see how all cases come into play, consider the following example:
+
+  data family T a :: *
+  data instance T Int = T1 | T2 Bool
+  -- Which gives rise to FC:
+  --   data T a
+  --   data R:TInt = T1 | T2 Bool
+  --   axiom ax_ti : T Int ~R R:TInt
+
+  newtype G1 = MkG1 (T Int)
+  newtype G2 = MkG2 G1
+
+  type instance F Int  = F Char
+  type instance F Char = G2
+
+In this case pmTopNormaliseType_maybe env ty_cs (F Int) results in
+
+  Just (G2, [MkG2,MkG1], R:TInt)
+
+Which means that in source Haskell:
+  - G2 is equivalent to F Int (in contrast, G1 isn't).
+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).
+
+-----
+-- Wrinkle: Local equalities
+-----
+
+Given the following type family:
+
+  type family F a
+  type instance F Int = Void
+
+Should the following program (from #14813) be considered exhaustive?
+
+  f :: (i ~ Int) => F i -> a
+  f x = case x of {}
+
+You might think "of course, since `x` is obviously of type Void". But the
+idType of `x` is technically F i, not Void, so if we pass F i to
+inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.
+In order to avoid this pitfall, we need to normalise the type passed to
+pmTopNormaliseType_maybe, using the constraint solver to solve for any local
+equalities (such as i ~ Int) that may be in scope.
+-}
+
+-- | Generate all 'InhabitationCandidate's for a given type. The result is
+-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type
+-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,
+-- if it can. In this case, the candidates are the signature of the tycon, each
+-- one accompanied by the term- and type- constraints it gives rise to.
+-- See also Note [Checking EmptyCase Expressions]
+inhabitationCandidates :: Bag EvVar -> Type
+                       -> PmM (Either Type (TyCon, [InhabitationCandidate]))
+inhabitationCandidates ty_cs ty = do
+  fam_insts   <- liftD dsGetFamInstEnvs
+  mb_norm_res <- pmTopNormaliseType_maybe fam_insts ty_cs ty
+  case mb_norm_res of
+    Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs
+    Nothing                     -> alts_to_check ty     ty      []
+  where
+    -- All these types are trivially inhabited
+    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon
+                          , intTyCon, wordTyCon, word8TyCon ]
+
+    -- Note: At the moment we leave all the typing and constraint fields of
+    -- PmCon empty, since we know that they are not gonna be used. Is the
+    -- right-thing-to-do to actually create them, even if they are never used?
+    build_tm :: ValAbs -> [DataCon] -> ValAbs
+    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])
+
+    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe
+    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, _)
+        |  tc `elem` trivially_inhabited
+        -> case dcs of
+             []    -> return (Left src_ty)
+             (_:_) -> do var <- liftD $ mkPmId core_ty
+                         let va = build_tm (PmVar var) dcs
+                         return $ Right (tc, [InhabitationCandidate
+                           { ic_val_abs = va, ic_tm_ct = mkIdEq var
+                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])
+
+        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)
+           -- Don't consider abstract tycons since we don't know what their
+           -- constructors are, which makes the results of coverage checking
+           -- them extremely misleading.
+        -> liftD $ do
+             var  <- mkPmId core_ty -- it would be wrong to unify x
+             alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)
+             return $ Right
+               (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}
+                    | alt <- alts ])
+      -- For other types conservatively assume that they are inhabited.
+      _other -> return (Left src_ty)
+
+{- Note [Checking EmptyCase Expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Empty case expressions are strict on the scrutinee. That is, `case x of {}`
+will force argument `x`. Hence, `checkMatches` is not sufficient for checking
+empty cases, because it assumes that the match is not strict (which is true
+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,
+we do the following:
+
+1. We normalise the outermost type family redex, data family redex or newtype,
+   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3
+   things:
+   (a) A normalised type src_ty, which is equal to the type of the scrutinee in
+       source Haskell (does not normalise newtypes or data families)
+   (b) The actual normalised type core_ty, which coincides with the result
+       topNormaliseType_maybe. This type is not necessarily equal to the input
+       type in source Haskell. And this is precicely the reason we compute (a)
+       and (c): the reasoning happens with the underlying types, but both the
+       patterns and types we print should respect newtypes and also show the
+       family type constructors and not the representation constructors.
+
+   (c) A list of all newtype data constructors dcs, each one corresponding to a
+       newtype rewrite performed in (b).
+
+   For an example see also Note [Type normalisation for EmptyCase]
+   in types/FamInstEnv.hs.
+
+2. Function checkEmptyCase' performs the check:
+   - If core_ty is not an algebraic type, then we cannot check for
+     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming
+     that the type is inhabited.
+   - If core_ty is an algebraic type, then we unfold the scrutinee to all
+     possible constructor patterns, using inhabitationCandidates, and then
+     check each one for constraint satisfiability, same as we for normal
+     pattern match checking.
+
+%************************************************************************
+%*                                                                      *
+              Transform source syntax to *our* syntax
+%*                                                                      *
+%************************************************************************
+-}
+
+-- -----------------------------------------------------------------------
+-- * Utilities
+
+nullaryConPattern :: ConLike -> Pattern
+-- Nullary data constructor and nullary type constructor
+nullaryConPattern con =
+  PmCon { pm_con_con = con, pm_con_arg_tys = []
+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }
+{-# INLINE nullaryConPattern #-}
+
+truePattern :: Pattern
+truePattern = nullaryConPattern (RealDataCon trueDataCon)
+{-# INLINE truePattern #-}
+
+-- | Generate a `canFail` pattern vector of a specific type
+mkCanFailPmPat :: Type -> DsM PatVec
+mkCanFailPmPat ty = do
+  var <- mkPmVar ty
+  return [var, PmFake]
+
+vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
+-- ADT constructor pattern => no existentials, no local constraints
+vanillaConPattern con arg_tys args =
+  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }
+{-# INLINE vanillaConPattern #-}
+
+-- | Create an empty list pattern of a given type
+nilPattern :: Type -> Pattern
+nilPattern ty =
+  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]
+        , pm_con_tvs = [], pm_con_dicts = []
+        , pm_con_args = [] }
+{-# INLINE nilPattern #-}
+
+mkListPatVec :: Type -> PatVec -> PatVec -> PatVec
+mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
+                               , pm_con_arg_tys = [ty]
+                               , pm_con_tvs = [], pm_con_dicts = []
+                               , pm_con_args = xs++ys }]
+{-# INLINE mkListPatVec #-}
+
+-- | Create a (non-overloaded) literal pattern
+mkLitPattern :: HsLit GhcTc -> Pattern
+mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
+{-# INLINE mkLitPattern #-}
+
+-- -----------------------------------------------------------------------
+-- * Transform (Pat Id) into of (PmPat Id)
+
+translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
+translatePat fam_insts pat = case pat of
+  WildPat  ty  -> mkPmVars [ty]
+  VarPat _ id  -> return [PmVar (unLoc id)]
+  ParPat _ p   -> translatePat fam_insts (unLoc p)
+  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable
+
+  -- ignore strictness annotations for now
+  BangPat _ p  -> translatePat fam_insts (unLoc p)
+
+  AsPat _ lid p -> do
+     -- Note [Translating As Patterns]
+    ps <- translatePat fam_insts (unLoc p)
+    let [e] = map vaToPmExpr (coercePatVec ps)
+        g   = PmGrd [PmVar (unLoc lid)] e
+    return (ps ++ [g])
+
+  SigPat _ p _ty -> translatePat fam_insts (unLoc p)
+
+  -- See Note [Translate CoPats]
+  CoPat _ wrapper p ty
+    | isIdHsWrapper wrapper                   -> translatePat fam_insts p
+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p
+    | otherwise -> do
+        ps      <- translatePat fam_insts p
+        (xp,xe) <- mkPmId2Forms ty
+        g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))
+        return [xp,g]
+
+  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)
+  NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
+
+  -- (fun -> pat)   ===>   x (pat <- fun x)
+  ViewPat arg_ty lexpr lpat -> do
+    ps <- translatePat fam_insts (unLoc lpat)
+    -- See Note [Guards and Approximation]
+    res <- allM cantFailPattern ps
+    case res of
+      True  -> do
+        (xp,xe) <- mkPmId2Forms arg_ty
+        g <- mkGuard ps (HsApp noExt lexpr xe)
+        return [xp,g]
+      False -> mkCanFailPmPat arg_ty
+
+  -- list
+  ListPat (ListPatTc ty Nothing) ps -> do
+    foldr (mkListPatVec ty) [nilPattern ty]
+      <$> translatePatVec fam_insts (map unLoc ps)
+
+  -- overloaded list
+  ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do
+    dflags <- getDynFlags
+    if xopt LangExt.RebindableSyntax dflags
+       then mkCanFailPmPat pat_ty
+       else case splitListTyConApp_maybe pat_ty of
+              Just e_ty -> translatePat fam_insts
+                                        (ListPat (ListPatTc e_ty Nothing) lpats)
+              Nothing   -> mkCanFailPmPat pat_ty
+    -- (a) In the presence of RebindableSyntax, we don't know anything about
+    --     `toList`, we should treat `ListPat` as any other view pattern.
+    --
+    -- (b) In the absence of RebindableSyntax,
+    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern
+    --       as ordinary list pattern. Although we can give an instance
+    --       `IsList [Int]` (more specific than the default `IsList [a]`), in
+    --       practice, we almost never do that. We assume the `_to_list` is
+    --       the `toList` from `instance IsList [a]`.
+    --
+    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.
+    --
+    -- See #14547, especially comment#9 and comment#10.
+    --
+    -- Here we construct CanFailPmPat directly, rather can construct a view
+    -- pattern and do further translation as an optimization, for the reason,
+    -- see Note [Guards and Approximation].
+
+  ConPatOut { pat_con     = (dL->L _ con)
+            , pat_arg_tys = arg_tys
+            , pat_tvs     = ex_tvs
+            , pat_dicts   = dicts
+            , pat_args    = ps } -> do
+    groups <- allCompleteMatches con arg_tys
+    case groups of
+      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)
+      _  -> do
+        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
+        return [PmCon { pm_con_con     = con
+                      , pm_con_arg_tys = arg_tys
+                      , pm_con_tvs     = ex_tvs
+                      , pm_con_dicts   = dicts
+                      , pm_con_args    = args }]
+
+  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+  NPat _ (dL->L _ olit) mb_neg _
+    | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
+    , isStringTy ty ->
+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+          translatePatVec fam_insts
+            (map (LitPat noExt . HsChar src) (unpackFS s))
+    | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]
+
+  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+  LitPat _ lit
+    | HsString src s <- lit ->
+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+          translatePatVec fam_insts
+            (map (LitPat noExt . HsChar src) (unpackFS s))
+    | otherwise -> return [mkLitPattern lit]
+
+  TuplePat tys ps boxity -> do
+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)
+    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
+    return [vanillaConPattern tuple_con tys (concat tidy_ps)]
+
+  SumPat ty p alt arity -> do
+    tidy_p <- translatePat fam_insts (unLoc p)
+    let sum_con = RealDataCon (sumDataCon alt arity)
+    return [vanillaConPattern sum_con ty tidy_p]
+
+  -- --------------------------------------------------------------------------
+  -- Not supposed to happen
+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
+  SplicePat {} -> panic "Check.translatePat: SplicePat"
+  XPat      {} -> panic "Check.translatePat: XPat"
+
+{- Note [Translate Overloaded Literal for Exhaustiveness Checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The translation of @NPat@ in exhaustiveness checker is a bit different
+from translation in pattern matcher.
+
+  * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we
+    translate integral literals to HsIntPrim or HsWordPrim and translate
+    overloaded strings to HsString.
+
+  * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use
+    `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,
+    however we generate `PmOLit` for HsOverLit, rather than refine
+    `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do
+    the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness
+    checker will fail to match the literals patterns correctly. See
+    #14546.
+
+  In Note [Undecidable Equality for Overloaded Literals], we say: "treat
+  overloaded literals that look different as different", but previously we
+  didn't do such things.
+
+  Now, we translate the literal value to match and the literal patterns
+  consistently:
+
+  * For integral literals, we parse both the integral literal value and
+    the patterns as OverLit HsIntegral. For example:
+
+      case 0::Int of
+          0 -> putStrLn "A"
+          1 -> putStrLn "B"
+          _ -> putStrLn "C"
+
+    When checking the exhaustiveness of pattern matching, we translate the 0
+    in value position as PmOLit, but translate the 0 and 1 in pattern position
+    as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the
+    equality and report warning of "Pattern match is redundant" on pattern 0,
+    as reported in #14546. In this patch we remove the specialization of
+    OverLit patterns, and keep the overloaded number literal in pattern as it
+    is to maintain the consistency. We know nothing about the `fromInteger`
+    method (see Note [Undecidable Equality for Overloaded Literals]). Now we
+    can capture the exhaustiveness of pattern 0 and the redundancy of pattern
+    1 and _.
+
+  * For string literals, we parse the string literals as HsString. When
+    OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.
+    For example:
+
+      case "foo" of
+          "foo" -> putStrLn "A"
+          "bar" -> putStrLn "B"
+          "baz" -> putStrLn "C"
+
+    Previously, the overloaded string values are translated to PmOLit and the
+    non-overloaded string values are translated to PmSLit. However the string
+    patterns, both overloaded and non-overloaded, are translated to list of
+    characters. The inconsistency leads to wrong warnings about redundant and
+    non-exhaustive pattern matching warnings, as reported in #14546.
+
+    In order to catch the redundant pattern in following case:
+
+      case "foo" of
+          ('f':_) -> putStrLn "A"
+          "bar" -> putStrLn "B"
+
+    in this patch, we translate non-overloaded string literals, both in value
+    position and pattern position, as list of characters. For overloaded string
+    literals, we only translate it to list of characters only when it's type
+    is stringTy, since we know nothing about the toString methods. But we know
+    that if two overloaded strings are syntax equal, then they are equal. Then
+    if it's type is not stringTy, we just translate it to PmOLit. We can still
+    capture the exhaustiveness of pattern "foo" and the redundancy of pattern
+    "bar" and "baz" in the following code:
+
+      {-# LANGUAGE OverloadedStrings #-}
+      main = do
+        case "foo" of
+            "foo" -> putStrLn "A"
+            "bar" -> putStrLn "B"
+            "baz" -> putStrLn "C"
+
+  We must ensure that doing the same translation to literal values and patterns
+  in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to
+  #14546.
+-}
+
+-- | Translate a list of patterns (Note: each pattern is translated
+-- to a pattern vector but we do not concatenate the results).
+translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]
+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
+
+-- | Translate a constructor pattern
+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
+                   -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
+  = concat <$> translatePatVec fam_insts (map unLoc ps)
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
+  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])
+translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
+    -- Nothing matched. Make up some fresh term variables
+  | null fs        = mkPmVars arg_tys
+    -- The data constructor was not defined using record syntax. For the
+    -- pattern to be in record syntax it should be empty (e.g. Just {}).
+    -- So just like the previous case.
+  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys
+    -- Some of the fields appear, in the original order (there may be holes).
+    -- Generate a simple constructor pattern and make up fresh variables for
+    -- the rest of the fields
+  | matched_lbls `subsetOf` orig_lbls
+  = ASSERT(orig_lbls `equalLength` arg_tys)
+      let translateOne (lbl, ty) = case lookup lbl matched_pats of
+            Just p  -> translatePat fam_insts p
+            Nothing -> mkPmVars [ty]
+      in  concatMapM translateOne (zip orig_lbls arg_tys)
+    -- The fields that appear are not in the correct order. Make up fresh
+    -- variables for all fields and add guards after matching, to force the
+    -- evaluation in the correct order.
+  | otherwise = do
+      arg_var_pats    <- mkPmVars arg_tys
+      translated_pats <- forM matched_pats $ \(x,pat) -> do
+        pvec <- translatePat fam_insts pat
+        return (x, pvec)
+
+      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]
+          guards = map (\(name,pvec) -> case lookup name zipped of
+                            Just x  -> PmGrd pvec (PmExprVar (idName x))
+                            Nothing -> panic "translateConPatVec: lookup")
+                       translated_pats
+
+      return (arg_var_pats ++ guards)
+  where
+    -- The actual argument types (instantiated)
+    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
+
+    -- Some label information
+    orig_lbls    = map flSelector $ conLikeFieldLabels c
+    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
+                   | (dL->L _ x) <- fs]
+    matched_lbls = [ name | (name, _pat) <- matched_pats ]
+
+    subsetOf :: Eq a => [a] -> [a] -> Bool
+    subsetOf []     _  = True
+    subsetOf (_:_)  [] = False
+    subsetOf (x:xs) (y:ys)
+      | x == y    = subsetOf    xs  ys
+      | otherwise = subsetOf (x:xs) ys
+
+-- Translate a single match
+translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
+               -> DsM (PatVec,[PatVec])
+translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =
+  do
+  pats'   <- concat <$> translatePatVec fam_insts pats
+  guards' <- mapM (translateGuards fam_insts) guards
+  return (pats', guards')
+  where
+    extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
+    extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
+    extractGuards _                       = panic "translateMatch"
+
+    pats   = map unLoc lpats
+    guards = map extractGuards (grhssGRHSs grhss)
+translateMatch _ _ = panic "translateMatch"
+
+-- -----------------------------------------------------------------------
+-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
+
+-- | Translate a list of guard statements to a pattern vector
+translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec
+translateGuards fam_insts guards = do
+  all_guards <- concat <$> mapM (translateGuard fam_insts) guards
+  let
+    shouldKeep :: Pattern -> DsM Bool
+    shouldKeep p
+      | PmVar {} <- p = pure True
+      | PmCon {} <- p = (&&)
+                          <$> singleMatchConstructor (pm_con_con p) (pm_con_arg_tys p)
+                          <*> allM shouldKeep (pm_con_args p)
+    shouldKeep (PmGrd pv e)
+      | isNotPmExprOther e = pure True  -- expensive but we want it
+      | otherwise          = allM shouldKeep pv
+    shouldKeep _other_pat  = pure False -- let the rest..
+
+  all_handled <- allM shouldKeep all_guards
+  -- It should have been @pure all_guards@ but it is too expressive.
+  -- Since the term oracle does not handle all constraints we generate,
+  -- we (hackily) replace all constraints the oracle cannot handle with a
+  -- single one (we need to know if there is a possibility of failure).
+  -- See Note [Guards and Approximation] for all guard-related approximations
+  -- we implement.
+  if all_handled
+    then pure all_guards
+    else do
+      kept <- filterM shouldKeep all_guards
+      pure (PmFake : kept)
+
+-- | Check whether a pattern can fail to match
+cantFailPattern :: Pattern -> DsM Bool
+cantFailPattern PmVar {}      = pure True
+cantFailPattern PmCon { pm_con_con = c, pm_con_arg_tys = tys, pm_con_args = ps}
+  = (&&) <$> singleMatchConstructor c tys <*> allM cantFailPattern ps
+cantFailPattern (PmGrd pv _e) = allM cantFailPattern pv
+cantFailPattern _             = pure False
+
+-- | Translate a guard statement to Pattern
+translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
+translateGuard fam_insts guard = case guard of
+  BodyStmt _   e _ _ -> translateBoolGuard e
+  LetStmt  _   binds -> translateLet (unLoc binds)
+  BindStmt _ p e _ _ -> translateBind fam_insts p e
+  LastStmt        {} -> panic "translateGuard LastStmt"
+  ParStmt         {} -> panic "translateGuard ParStmt"
+  TransStmt       {} -> panic "translateGuard TransStmt"
+  RecStmt         {} -> panic "translateGuard RecStmt"
+  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
+  XStmtLR         {} -> panic "translateGuard RecStmt"
+
+-- | Translate let-bindings
+translateLet :: HsLocalBinds GhcTc -> DsM PatVec
+translateLet _binds = return []
+
+-- | Translate a pattern guard
+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
+translateBind fam_insts (dL->L _ p) e = do
+  ps <- translatePat fam_insts p
+  g <- mkGuard ps (unLoc e)
+  return [g]
+
+-- | Translate a boolean guard
+translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec
+translateBoolGuard e
+  | isJust (isTrueLHsExpr e) = return []
+    -- The formal thing to do would be to generate (True <- True)
+    -- but it is trivial to solve so instead we give back an empty
+    -- PatVec for efficiency
+  | otherwise = (:[]) <$> mkGuard [truePattern] (unLoc e)
+
+{- Note [Guards and Approximation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if the algorithm is really expressive, the term oracle we use is not.
+Hence, several features are not translated *properly* but we approximate.
+The list includes:
+
+1. View Patterns
+----------------
+A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term
+oracle does not handle function applications so we know that the generated
+constraints will not be handled at the end. Hence, we distinguish between two
+cases:
+  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right
+     thing*.
+  b) Pattern @p@ can fail. This means that when checking the guard, we will
+     generate several cases, with no useful information. E.g.:
+
+       h (f -> [a,b]) = ...
+       h x ([a,b] <- f x) = ...
+
+       uncovered set = { [x |> { False ~ (f x ~ [])            }]
+                       , [x |> { False ~ (f x ~ (t1:[]))       }]
+                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }
+
+     So we have two problems:
+       1) Since we do not print the constraints in the general case (they may
+          be too many), the warning will look like this:
+
+            Pattern match(es) are non-exhaustive
+            In an equation for `h':
+                Patterns not matched:
+                    _
+                    _
+                    _
+          Which is not short and not more useful than a single underscore.
+       2) The size of the uncovered set increases a lot, without gaining more
+          expressivity in our warnings.
+
+     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
+     @PmFake@: @True <- _@. That is, we record that there is a possibility
+     of failure but we minimize it to a True/False. This generates a single
+     warning and much smaller uncovered sets.
+
+2. Overloaded Lists
+-------------------
+An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The
+problem is exactly like above, as its solution. For future reference, the code
+below is the *right thing to do*:
+
+   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
+     otherwise -> do
+       (xp, xe) <- mkPmId2Forms pat_ty
+       ps       <- translatePatVec (map unLoc lpats)
+       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
+           g    = mkGuard pats (HsApp (noLoc to_list) xe)
+       return [xp,g]
+
+3. Overloaded Literals
+----------------------
+The case with literals is a bit different. a literal @l@ should be translated
+to @x (True <- x == from l)@. Since we want to have better warnings for
+overloaded literals as it is a very common feature, we treat them differently.
+They are mainly covered in Note [Undecidable Equality for Overloaded Literals]
+in PmExpr.
+
+4. N+K Patterns & Pattern Synonyms
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.
+Since the only pattern of the three that causes failure is guard @(n <- x-k)@,
+and has two possible outcomes. Hence, there is no benefit in using a dummy and
+we implement the proper thing. Pattern synonyms are simply not implemented yet.
+Hence, to be conservative, we generate a dummy pattern, assuming that the
+pattern can fail.
+
+5. Actual Guards
+----------------
+During translation, boolean guards and pattern guards are translated properly.
+Let bindings though are omitted by function @translateLet@. Since they are lazy
+bindings, we do not actually want to generate a (strict) equality (like we do
+in the pattern bind case). Hence, we safely drop them.
+
+Additionally, top-level guard translation (performed by @translateGuards@)
+replaces guards that cannot be reasoned about (like the ones we described in
+1-4) with a single @PmFake@ to record the possibility of failure to match.
+
+Note [Translate CoPats]
+~~~~~~~~~~~~~~~~~~~~~~~
+The pattern match checker did not know how to handle coerced patterns `CoPat`
+efficiently, which gave rise to #11276. The original approach translated
+`CoPat`s:
+
+    pat |> co    ===>    x (pat <- (e |> co))
+
+Instead, we now check whether the coercion is a hole or if it is just refl, in
+which case we can drop it. Unfortunately, data families generate useful
+coercions so guards are still generated in these cases and checking data
+families is not really efficient.
+
+%************************************************************************
+%*                                                                      *
+                 Utilities for Pattern Match Checking
+%*                                                                      *
+%************************************************************************
+-}
+
+-- ----------------------------------------------------------------------------
+-- * Basic utilities
+
+-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type
+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
+pmPatType :: PmPat p -> Type
+pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })
+  = conLikeResTy con tys
+pmPatType (PmVar  { pm_var_id  = x }) = idType x
+pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l
+pmPatType (PmNLit { pm_lit_id  = x }) = idType x
+pmPatType (PmGrd  { pm_grd_pv  = pv })
+  = ASSERT(patVecArity pv == 1) (pmPatType p)
+  where Just p = find ((==1) . patternArity) pv
+pmPatType PmFake = pmPatType truePattern
+
+-- | Information about a conlike that is relevant to coverage checking.
+-- It is called an \"inhabitation candidate\" since it is a value which may
+-- possibly inhabit some type, but only if its term constraint ('ic_tm_ct')
+-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict
+-- argument types ('ic_strict_arg_tys') are inhabitable.
+-- See @Note [Extensions to GADTs Meet Their Match]@.
+data InhabitationCandidate =
+  InhabitationCandidate
+  { ic_val_abs        :: ValAbs
+  , ic_tm_ct          :: ComplexEq
+  , ic_ty_cs          :: Bag EvVar
+  , ic_strict_arg_tys :: [Type]
+  }
+
+{-
+Note [Extensions to GADTs Meet Their Match]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The GADTs Meet Their Match paper presents the formalism that GHC's coverage
+checker adheres to. Since the paper's publication, there have been some
+additional features added to the coverage checker which are not described in
+the paper. This Note serves as a reference for these new features.
+
+-----
+-- Strict argument type constraints
+-----
+
+In the ConVar case of clause processing, each conlike K traditionally
+generates two different forms of constraints:
+
+* A term constraint (e.g., x ~ K y1 ... yn)
+* Type constraints from the conlike's context (e.g., if K has type
+  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)
+
+As it turns out, these alone are not enough to detect a certain class of
+unreachable code. Consider the following example (adapted from #15305):
+
+  data K = K1 | K2 !Void
+
+  f :: K -> ()
+  f K1 = ()
+
+Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?
+Because it's impossible to construct a terminating value of type `K` using the
+`K2` constructor, and thus it's impossible for `f` to ever successfully match
+on `K2`.
+
+The reason is because `K2`'s field of type `Void` is //strict//. Because there
+are no terminating values of type `Void`, any attempt to construct something
+using `K2` will immediately loop infinitely or throw an exception due to the
+strictness annotation. (If the field were not strict, then `f` could match on,
+say, `K2 undefined` or `K2 (let x = x in x)`.)
+
+Since neither the term nor type constraints mentioned above take strict
+argument types into account, we make use of the `nonVoid` function to
+determine whether a strict type is inhabitable by a terminating value or not.
+
+`nonVoid ty` returns True when either:
+1. `ty` has at least one InhabitationCandidate for which both its term and type
+   constraints are satifiable, and `nonVoid` returns `True` for all of the
+   strict argument types in that InhabitationCandidate.
+2. We're unsure if it's inhabited by a terminating value.
+
+`nonVoid ty` returns False when `ty` is definitely uninhabited by anything
+(except bottom). Some examples:
+
+* `nonVoid Void` returns False, since Void has no InhabitationCandidates.
+  (This is what lets us discard the `K2` constructor in the earlier example.)
+* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate
+  (through the Refl constructor), and its term constraint (x ~ Refl) and
+  type constraint (Int ~ Int) are satisfiable.
+* `nonVoid (Int :~: Bool)` returns False. Although it has an
+  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is
+  not satisfiable.
+* Given the following definition of `MyVoid`:
+
+    data MyVoid = MkMyVoid !Void
+
+  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid
+  constructor contains Void as a strict argument type, and since `nonVoid Void`
+  returns False, that InhabitationCandidate is discarded, leaving no others.
+
+* Performance considerations
+
+We must be careful when recursively calling `nonVoid` on the strict argument
+types of an InhabitationCandidate, because doing so naïvely can cause GHC to
+fall into an infinite loop. Consider the following example:
+
+  data Abyss = MkAbyss !Abyss
+
+  stareIntoTheAbyss :: Abyss -> a
+  stareIntoTheAbyss x = case x of {}
+
+In principle, stareIntoTheAbyss is exhaustive, since there is no way to
+construct a terminating value using MkAbyss. However, both the term and type
+constraints for MkAbyss are satisfiable, so the only way one could determine
+that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.
+There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term
+and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`
+returns False... and now we've entered an infinite loop!
+
+To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the
+presence of recursive types (through `checkRecTc`), and if recursion is
+detected, we bail out and conservatively assume that the type is inhabited by
+some terminating value. This avoids infinite loops at the expense of making
+the coverage checker incomplete with respect to functions like
+stareIntoTheAbyss above. Then again, the same problem occurs with recursive
+newtypes, like in the following code:
+
+  newtype Chasm = MkChasm Chasm
+
+  gazeIntoTheChasm :: Chasm -> a
+  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive
+
+So this limitation is somewhat understandable.
+
+Note that even with this recursion detection, there is still a possibility that
+`nonVoid` can run in exponential time. Consider the following data type:
+
+  data T = MkT !T !T !T
+
+If we call `nonVoid` on each of its fields, that will require us to once again
+check if `MkT` is inhabitable in each of those three fields, which in turn will
+require us to check if `MkT` is inhabitable again... As you can see, the
+branching factor adds up quickly, and if the recursion depth limit is, say,
+100, then `nonVoid T` will effectively take forever.
+
+To mitigate this, we check the branching factor every time we are about to call
+`nonVoid` on a list of strict argument types. If the branching factor exceeds 1
+(i.e., if there is potential for exponential runtime), then we limit the
+maximum recursion depth to 1 to mitigate the problem. If the branching factor
+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay
+to stick with a larger maximum recursion depth.
+
+Another microoptimization applies to data types like this one:
+
+  data S a = ![a] !T
+
+Even though there is a strict field of type [a], it's quite silly to call
+nonVoid on it, since it's "obvious" that it is inhabitable. To make this
+intuition formal, we say that a type is definitely inhabitable (DI) if:
+
+  * It has at least one constructor C such that:
+    1. C has no equality constraints (since they might be unsatisfiable)
+    2. C has no strict argument types (since they might be uninhabitable)
+
+It's relatively cheap to cheap if a type is DI, so before we call `nonVoid`
+on a list of strict argument types, we filter out all of the DI ones.
+-}
+
+instance Outputable InhabitationCandidate where
+  ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct
+                             , ic_ty_cs = ty_cs
+                             , ic_strict_arg_tys = strict_arg_tys }) =
+    text "InhabitationCandidate" <+>
+      vcat [ text "ic_val_abs        =" <+> ppr va
+           , text "ic_tm_ct          =" <+> ppr tm_ct
+           , text "ic_ty_cs          =" <+> ppr ty_cs
+           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]
+
+-- | 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
+--
+--  * 'con' K is a conlike of data type T
+--
+-- After instantiating the universal tyvars of K 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)
+        = 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
+
+  (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM
+
+  let arg_tys' = substTys subst arg_tys
+  -- Fresh term variables (VAs) as arguments to the constructor
+  arguments <-  mapM mkPmVar arg_tys'
+  -- All constraints bound by the constructor (alpha-renamed)
+  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)
+  evvars <- mapM (nameType "pm") theta_cs
+  let con_abs  = PmCon { pm_con_con     = con
+                       , pm_con_arg_tys = tc_args
+                       , pm_con_tvs     = ex_tvs'
+                       , pm_con_dicts   = evvars
+                       , pm_con_args    = arguments }
+      strict_arg_tys = filterByList arg_is_banged arg_tys'
+  return $ InhabitationCandidate
+           { ic_val_abs        = con_abs
+           , ic_tm_ct          = (PmExprVar (idName x), vaToPmExpr con_abs)
+           , ic_ty_cs          = listToBag evvars
+           , ic_strict_arg_tys = strict_arg_tys
+           }
+
+-- ----------------------------------------------------------------------------
+-- * More smart constructors and fresh variable generation
+
+-- | Create a guard pattern
+mkGuard :: PatVec -> HsExpr GhcTc -> DsM Pattern
+mkGuard pv e = do
+  res <- allM cantFailPattern pv
+  let expr = hsExprToPmExpr e
+  tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])
+  if | res                    -> pure (PmGrd pv expr)
+     | PmExprOther {} <- expr -> pure PmFake
+     | otherwise              -> pure (PmGrd pv expr)
+
+-- | Create a term equality of the form: `(False ~ (x ~ lit))`
+mkNegEq :: Id -> PmLit -> ComplexEq
+mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)
+{-# INLINE mkNegEq #-}
+
+-- | Create a term equality of the form: `(x ~ lit)`
+mkPosEq :: Id -> PmLit -> ComplexEq
+mkPosEq x l = (PmExprVar (idName x), PmExprLit l)
+{-# INLINE mkPosEq #-}
+
+-- | Create a term equality of the form: `(x ~ x)`
+-- (always discharged by the term oracle)
+mkIdEq :: Id -> ComplexEq
+mkIdEq x = (PmExprVar name, PmExprVar name)
+  where name = idName x
+{-# INLINE mkIdEq #-}
+
+-- | Generate a variable pattern of a given type
+mkPmVar :: Type -> DsM (PmPat p)
+mkPmVar ty = PmVar <$> mkPmId ty
+{-# INLINE mkPmVar #-}
+
+-- | Generate many variable patterns, given a list of types
+mkPmVars :: [Type] -> DsM PatVec
+mkPmVars tys = mapM mkPmVar tys
+{-# INLINE mkPmVars #-}
+
+-- | Generate a fresh `Id` of a given type
+mkPmId :: Type -> DsM Id
+mkPmId ty = getUniqueM >>= \unique ->
+  let occname = mkVarOccFS $ fsLit "$pm"
+      name    = mkInternalName unique occname noSrcSpan
+  in  return (mkLocalId name ty)
+
+-- | Generate a fresh term variable of a given and return it in two forms:
+-- * A variable pattern
+-- * A variable expression
+mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
+mkPmId2Forms ty = do
+  x <- mkPmId ty
+  return (PmVar x, noLoc (HsVar noExt (noLoc x)))
+
+-- ----------------------------------------------------------------------------
+-- * Converting between Value Abstractions, Patterns and PmExpr
+
+-- | Convert a value abstraction an expression
+vaToPmExpr :: ValAbs -> PmExpr
+vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })
+  = PmExprCon c (map vaToPmExpr ps)
+vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)
+vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l
+vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)
+
+-- | Convert a pattern vector to a list of value abstractions by dropping the
+-- guards (See Note [Translating As Patterns])
+coercePatVec :: PatVec -> [ValAbs]
+coercePatVec pv = concatMap coercePmPat pv
+
+-- | Convert a pattern to a list of value abstractions (will be either an empty
+-- list if the pattern is a guard pattern, or a singleton list in all other
+-- cases) by dropping the guards (See Note [Translating As Patterns])
+coercePmPat :: Pattern -> [ValAbs]
+coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]
+coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]
+coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+                   , pm_con_tvs = tvs, pm_con_dicts = dicts
+                   , pm_con_args = args })
+  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys
+           , pm_con_tvs  = tvs, pm_con_dicts = dicts
+           , pm_con_args = coercePatVec args }]
+coercePmPat (PmGrd {}) = [] -- drop the guards
+coercePmPat PmFake     = [] -- drop the guards
+
+-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether
+-- it is the only possible match in the given context. See also
+-- 'allCompleteMatches' and Note [Single match constructors].
+singleMatchConstructor :: ConLike -> [Type] -> DsM Bool
+singleMatchConstructor cl tys =
+  any (isSingleton . snd) <$> allCompleteMatches cl tys
+
+{-
+Note [Single match constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When translating pattern guards for consumption by the checker, we desugar
+every pattern guard that might fail ('cantFailPattern') to 'PmFake'
+(True <- _). Which patterns can't fail? Exactly those that only match on
+'singleMatchConstructor's.
+
+Here are a few examples:
+  * @f a | (a, b) <- foo a = 42@: Product constructors are generally
+    single match. This extends to single constructors of GADTs like 'Refl'.
+  * If @f | Id <- id () = 42@, where @pattern Id = ()@ and 'Id' is part of a
+    singleton `COMPLETE` set, then 'Id' has the single match property.
+
+In effect, we can just enumerate 'allCompleteMatches' and check if the conlike
+occurs as a singleton set.
+There's the chance that 'Id' is part of multiple `COMPLETE` sets. That's
+irrelevant; If the user specified a singleton set, it is single-match.
+
+Note that this doesn't really take into account incoming type constraints;
+It might be obvious from type context that a particular GADT constructor has
+the single-match property. We currently don't (can't) check this in the
+translation step. See #15753 for why this yields surprising results.
+-}
+
+-- | For a given conlike, finds all the sets of patterns which could
+-- be relevant to that conlike by consulting the result type.
+--
+-- These come from two places.
+--  1. From data constructors defined with the result type constructor.
+--  2. From `COMPLETE` pragmas which have the same type as the result
+--     type constructor. Note that we only use `COMPLETE` pragmas
+--     *all* of whose pattern types match. See #14135
+allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]
+allCompleteMatches cl tys = do
+  let fam = case cl of
+           RealDataCon dc ->
+            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
+           PatSynCon _    -> []
+      ty  = conLikeResTy cl tys
+  pragmas <- case splitTyConApp_maybe ty of
+               Just (tc, _) -> dsGetCompleteMatches tc
+               Nothing      -> return []
+  let fams cm = (FromComplete,) <$>
+                mapM dsLookupConLike (completeMatchConLikes cm)
+  from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$>
+                mapM fams pragmas
+  let final_groups = fam ++ from_pragma
+  return final_groups
+    where
+      -- Check that all the pattern synonym return types in a `COMPLETE`
+      -- pragma subsume the type we're matching.
+      -- See Note [Filtering out non-matching COMPLETE sets]
+      isValidCompleteMatch :: Type -> [ConLike] -> Bool
+      isValidCompleteMatch ty = all go
+        where
+          go (RealDataCon {}) = True
+          go (PatSynCon psc)  = isJust $ flip tcMatchTy ty $ patSynResTy
+                                       $ patSynSig psc
+
+          patSynResTy (_, _, _, _, _, res_ty) = res_ty
+
+{-
+Note [Filtering out non-matching COMPLETE sets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, conlikes in a COMPLETE set are simply grouped by the
+type constructor heading the return type. This is nice and simple, but it does
+mean that there are scenarios when a COMPLETE set might be incompatible with
+the type of a scrutinee. For instance, consider (from #14135):
+
+  data Foo a = Foo1 a | Foo2 a
+
+  pattern MyFoo2 :: Int -> Foo Int
+  pattern MyFoo2 i = Foo2 i
+
+  {-# COMPLETE Foo1, MyFoo2 #-}
+
+  f :: Foo a -> a
+  f (Foo1 x) = x
+
+`f` has an incomplete pattern-match, so when choosing which constructors to
+report as unmatched in a warning, GHC must choose between the original set of
+data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe
+that GHC shouldn't even consider the COMPLETE set as a possibility: the return
+type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since
+there's no substitution `s` such that s(Foo Int) = Foo a.
+
+To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern
+synonym constructor's return type matches the type of the scrutinee, and if one
+doesn't, then we remove the whole COMPLETE set from consideration.
+
+One might wonder why GHC only checks /pattern synonym/ constructors, and not
+/data/ constructors as well. The reason is because that the type of a
+GADT constructor very well may not match the type of a scrutinee, and that's
+OK. Consider this example (from #14059):
+
+  data SBool (z :: Bool) where
+    SFalse :: SBool False
+    STrue  :: SBool True
+
+  pattern STooGoodToBeTrue :: forall (z :: Bool). ()
+                           => z ~ True
+                           => SBool z
+  pattern STooGoodToBeTrue = STrue
+  {-# COMPLETE SFalse, STooGoodToBeTrue #-}
+
+  wobble :: SBool z -> Bool
+  wobble STooGoodToBeTrue = True
+
+In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse
+should be matched against, even though its type, SBool False, does not match
+the scrutinee type, SBool z.
+-}
+
+-- -----------------------------------------------------------------------
+-- * Types and constraints
+
+newEvVar :: Name -> Type -> EvVar
+newEvVar name ty = mkLocalId name ty
+
+nameType :: String -> Type -> DsM EvVar
+nameType name ty = do
+  unique <- getUniqueM
+  let occname = mkVarOccFS (fsLit (name++"_"++show unique))
+      idname  = mkInternalName unique occname noSrcSpan
+  return (newEvVar idname ty)
+
+{-
+%************************************************************************
+%*                                                                      *
+                              The type oracle
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | Check whether a set of type constraints is satisfiable.
+tyOracle :: Bag EvVar -> PmM Bool
+tyOracle evs
+  = liftD $
+    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs
+       ; case res of
+            Just sat -> return sat
+            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }
+
+{-
+%************************************************************************
+%*                                                                      *
+                             Sanity Checks
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | The arity of a pattern/pattern vector is the
+-- number of top-level patterns that are not guards
+type PmArity = Int
+
+-- | Compute the arity of a pattern vector
+patVecArity :: PatVec -> PmArity
+patVecArity = sum . map patternArity
+
+-- | Compute the arity of a pattern
+patternArity :: Pattern -> PmArity
+patternArity (PmGrd {}) = 0
+patternArity _other_pat = 1
+
+{-
+%************************************************************************
+%*                                                                      *
+            Heart of the algorithm: Function pmcheck
+%*                                                                      *
+%************************************************************************
+
+Main functions are:
+
+* mkInitialUncovered :: [Id] -> PmM Uncovered
+
+  Generates the initial uncovered set. Term and type constraints in scope
+  are checked, if they are inconsistent, the set is empty, otherwise, the
+  set contains only a vector of variables with the constraints in scope.
+
+* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+
+  Checks redundancy, coverage and inaccessibility, using auxilary functions
+  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is
+  common in all three checks (see paper) and calls `pmcheckGuards` when the
+  whole clause is checked, or `pmcheckHd` when the pattern vector does not
+  start with a guard.
+
+* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
+
+  Processes the guards.
+
+* pmcheckHd :: Pattern -> PatVec -> [PatVec]
+          -> ValAbs -> ValVec -> PmM PartialResult
+
+  Worker: This function implements functions `covered`, `uncovered` and
+  `divergent` from the paper at once. Slightly different from the paper because
+  it does not even produce the covered and uncovered sets. Since we only care
+  about whether a clause covers SOMETHING or if it may forces ANY argument, we
+  only store a boolean in both cases, for efficiency.
+-}
+
+-- | Lift a pattern matching action from a single value vector abstration to a
+-- value set abstraction, but calling it on every vector and the combining the
+-- results.
+runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)
+runMany _ [] = return mempty
+runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms
+
+-- | Generate the initial uncovered set. It initializes the
+-- delta with all term and type constraints in scope.
+mkInitialUncovered :: [Id] -> PmM Uncovered
+mkInitialUncovered vars = do
+  delta <- pmInitialTmTyCs
+  let patterns = map PmVar vars
+  return [ValVec patterns delta]
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheck`
+pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+pmcheckI ps guards vva = do
+  n <- liftD incrCheckPmIterDs
+  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps
+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+                        $$ pprValVecDebug vva)
+  res <- pmcheck ps guards vva
+  tracePm "pmCheckResult:" (ppr res)
+  return res
+{-# INLINE pmcheckI #-}
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheckGuards`
+pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult
+pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva
+{-# INLINE pmcheckGuardsI #-}
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheckHd`
+pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+           -> PmM PartialResult
+pmcheckHdI p ps guards va vva = do
+  n <- liftD incrCheckPmIterDs
+  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
+                        $$ pprPatVec ps
+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+                        $$ pprPmPatDebug va
+                        $$ pprValVecDebug vva)
+
+  res <- pmcheckHd p ps guards va vva
+  tracePm "pmCheckHdI: res" (ppr res)
+  return res
+{-# INLINE pmcheckHdI #-}
+
+-- | Matching function: Check simultaneously a clause (takes separately the
+-- patterns and the list of guards) for exhaustiveness, redundancy and
+-- inaccessibility.
+pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+pmcheck [] guards vva@(ValVec [] _)
+  | null guards = return $ mempty { presultCovered = Covered }
+  | otherwise   = pmcheckGuardsI guards vva
+
+-- Guard
+pmcheck (PmFake : ps) guards vva =
+  -- short-circuit if the guard pattern is useless.
+  -- we just have two possible outcomes: fail here or match and recurse
+  -- none of the two contains any useful information about the failure
+  -- though. So just have these two cases but do not do all the boilerplate
+  forces . mkCons vva <$> pmcheckI ps guards vva
+pmcheck (p : ps) guards (ValVec vas delta)
+  | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p
+  = do
+      y <- liftD $ mkPmId (pmPatType p)
+      let tm_state = extendSubst y e (delta_tm_cs delta)
+          delta'   = delta { delta_tm_cs = tm_state }
+      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')
+
+pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"
+pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"
+
+pmcheck (p:ps) guards (ValVec (va:vva) delta)
+  = pmcheckHdI p ps guards va (ValVec vva delta)
+
+-- | Check the list of guards
+pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
+pmcheckGuards []       vva = return (usimple [vva])
+pmcheckGuards (gv:gvs) vva = do
+  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva
+  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
+  return $ PartialResult (prov1 `mappend` prov2)
+                         (cs `mappend` css)
+                         vsas
+                         (ds `mappend` dss)
+
+-- | Worker function: Implements all cases described in the paper for all three
+-- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`
+-- cases which are handled by `pmcheck`
+pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+          -> PmM PartialResult
+
+-- Var
+pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
+  | Just tm_state <- solveOneEq (delta_tm_cs delta)
+                                (PmExprVar (idName x), vaToPmExpr va)
+  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))
+  | otherwise = return mempty
+
+-- ConCon
+pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1
+                     , pm_con_args = args1})) ps guards
+          (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2
+                     , pm_con_args = args2})) (ValVec vva delta)
+  | c1 /= c2  =
+    return (usimple [ValVec (va:vva) delta])
+  | otherwise = do
+    let to_evvar tv1 tv2 = nameType "pmConCon" $
+                           mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)
+        mb_to_evvar tv1 tv2
+            -- If we have identical constructors but different existential
+            -- tyvars, then generate extra equality constraints to ensure the
+            -- existential tyvars.
+            -- See Note [Coverage checking and existential tyvars].
+          | tv1 == tv2 = pure Nothing
+          | otherwise  = Just <$> to_evvar tv1 tv2
+    evvars <- (listToBag . catMaybes) <$>
+              ASSERT(ex_tvs1 `equalLength` ex_tvs2)
+              liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2)
+    let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta }
+    kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)
+      <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta')
+
+-- LitLit
+pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
+  case eqPmLit l1 l2 of
+    True  -> ucon va <$> pmcheckI ps guards vva
+    False -> return $ ucon va (usimple [vva])
+
+-- ConVar
+pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))
+          ps guards
+          (PmVar x) (ValVec vva delta) = do
+  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)
+
+  cons_cs <- mapM (liftD . mkOneConFull x) complete_match
+
+  inst_vsa <- flip mapMaybeM cons_cs $
+      \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
+                            , ic_ty_cs = ty_cs
+                            , ic_strict_arg_tys = strict_arg_tys } -> do
+    mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys
+    pure $ fmap (ValVec (va:vva)) mb_sat
+
+  set_provenance prov .
+    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+      runMany (pmcheckI (p:ps) guards) inst_vsa
+
+-- LitVar
+pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)
+  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+      mkUnion non_matched <$>
+        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of
+          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $
+                             ValVec vva (delta {delta_tm_cs = tm_state})
+          Nothing       -> return mempty
+  where
+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
+       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]
+       | otherwise = []
+
+    non_matched = usimple us
+
+-- LitNLit
+pmcheckHd (p@(PmLit l)) ps guards
+          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)
+  | all (not . eqPmLit l) lits
+  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)
+    -- Both guards check the same so it would be sufficient to have only
+    -- the second one. Nevertheless, it is much cheaper to check whether
+    -- the literal is in the list so we check it first, to avoid calling
+    -- the term oracle (`solveOneEq`) if possible
+  = mkUnion non_matched <$>
+      pmcheckHdI p ps guards (PmLit l)
+                (ValVec vva (delta { delta_tm_cs = tm_state }))
+  | otherwise = return non_matched
+  where
+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
+       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]
+       | otherwise = []
+
+    non_matched = usimple us
+
+-- ----------------------------------------------------------------------------
+-- The following three can happen only in cases like #322 where constructors
+-- and overloaded literals appear in the same match. The general strategy is
+-- to replace the literal (positive/negative) by a variable and recurse. The
+-- fact that the variable is equal to the literal is recorded in `delta` so
+-- no information is lost
+
+-- LitCon
+pmcheckHd p@PmLit{} ps guards va@PmCon{} (ValVec vva delta)
+  = do y <- liftD $ mkPmId (pmPatType va)
+       -- Analogous to the ConVar case, we have to case split the value
+       -- abstraction on possible literals. We do so by introducing a fresh
+       -- variable that is equated to the constructor. LitVar will then take
+       -- care of the case split by resorting to NLit.
+       let tm_state = extendSubst y (vaToPmExpr va) (delta_tm_cs delta)
+           delta'   = delta { delta_tm_cs = tm_state }
+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')
+
+-- ConLit
+pmcheckHd p@PmCon{} ps guards (PmLit l) (ValVec vva delta)
+  = do y <- liftD $ mkPmId (pmPatType p)
+       -- This desugars to the ConVar case by introducing a fresh variable that
+       -- is equated to the literal via a constraint. ConVar will then properly
+       -- case split on all possible constructors.
+       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
+           delta'   = delta { delta_tm_cs = tm_state }
+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')
+
+-- ConNLit
+pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
+  = pmcheckHdI p ps guards (PmVar x) vva
+
+-- Impossible: handled by pmcheck
+pmcheckHd PmFake     _ _ _ _ = panic "pmcheckHd: Fake"
+pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
+
+{-
+Note [Coverage checking and existential tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC's implementation of the pattern-match coverage algorithm (as described in
+the GADTs Meet Their Match paper) must take some care to emit enough type
+constraints when handling data constructors with exisentially quantified type
+variables. To better explain what the challenge is, consider a constructor K
+of the form:
+
+  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p
+
+Where:
+
+* e_1, ..., e_m are the existentially bound type variables.
+* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type
+  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).
+* ty_1, ..., ty_n are the types of K's fields.
+* T u_1 ... u_p is the return type, where T is the data type constructor, and
+  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.
+
+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,
+but we don't want them to appear in the final PmCon, because then
+calling (mkOneConFull K) for other pattern variables might reuse the same
+existential tyvars, which is certainly wrong.
+
+Previously, GHC's solution to this wrinkle was to always create fresh names
+for the existential tyvars and put them into the PmCon. This works well for
+many cases, but it can break down if you nest GADT pattern matches in just
+the right way. For instance, consider the following program:
+
+    data App f a where
+      App :: f a -> App f (Maybe a)
+
+    data Ty a where
+      TBool :: Ty Bool
+      TInt  :: Ty Int
+
+    data T f a where
+      C :: T Ty (Maybe Bool)
+
+    foo :: T f a -> App f a -> ()
+    foo C (App TBool) = ()
+
+foo is a total program, but with the previous approach to handling existential
+tyvars, GHC would mark foo's patterns as non-exhaustive.
+
+When foo is desugared to Core, it looks roughly like so:
+
+    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()
+
+(Where `a1` is an existential tyvar.)
+
+That, in turn, is processed by the coverage checker to become:
+
+    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))
+      | TBool <- pmvar123 |> co1
+      = ()
+
+Note that the type of pmvar123 is `f a1`—this will be important later.
+
+Now, we proceed with coverage-checking as usual. When we come to the
+ConVar case for App, we create a fresh variable `a2` to represent its
+existential tyvar. At this point, we have the equality constraints
+`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.
+
+However, when we check the guard, it will use the type of pmvar123, which is
+`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,
+it will generate the constraint `a1 ~ Int`. This means our final set of
+equality constraints would be:
+
+    f  ~ Ty
+    a  ~ Maybe Bool
+    a  ~ Maybe a2
+    a1 ~ Int
+
+Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,
+because GHC is unable to relate `a2` to `a1`, which really should be the same
+tyvar.
+
+Luckily, we can avoid this pitfall. Recall that the ConVar case was where we
+generated a PmCon with too-fresh existentials. But after ConVar, we have the
+ConCon case, which considers whether each constructor of a particular data type
+can be matched on in a particular spot.
+
+In the case of App, when we get to the ConCon case, we will compare our
+original App PmCon (from the source program) to the App PmCon created from the
+ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the
+existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here
+by emitting an additional `a1 ~ a2` constraint. Now our final set of equality
+constraints will be:
+
+    f  ~ Ty
+    a  ~ Maybe Bool
+    a  ~ Maybe a2
+    a1 ~ Int
+    a1 ~ a2
+
+Which is unsatisfiable, as we desired, since we now have that
+Int ~ a1 ~ a2 ~ Bool.
+
+In general, App might have more than one constructor, in which case we
+couldn't reuse the existential tyvar for App for a different constructor. This
+means that we can only use this trick in ConCon when the constructors are the
+same. But this is fine, since this is the only scenario where this situation
+arises in the first place!
+-}
+
+-- ----------------------------------------------------------------------------
+-- * Utilities for main checking
+
+updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)
+updateVsa f p@(PartialResult { presultUncovered = old })
+  = p { presultUncovered = f old }
+
+
+-- | Initialise with default values for covering and divergent information.
+usimple :: ValSetAbs -> PartialResult
+usimple vsa = mempty { presultUncovered = vsa }
+
+-- | Take the tail of all value vector abstractions in the uncovered set
+utail :: PartialResult -> PartialResult
+utail = updateVsa upd
+  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]
+
+-- | Prepend a value abstraction to all value vector abstractions in the
+-- uncovered set
+ucon :: ValAbs -> PartialResult -> PartialResult
+ucon va = updateVsa upd
+  where
+    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]
+
+-- | Given a data constructor of arity `a` and an uncovered set containing
+-- value vector abstractions of length `(a+n)`, pass the first `n` value
+-- abstractions to the constructor (Hence, the resulting value vector
+-- abstractions will have length `n+1`)
+kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]
+     -> PartialResult -> PartialResult
+kcon con arg_tys ex_tvs dicts
+  = let n = conLikeArity con
+        upd vsa =
+          [ ValVec (va:vva) delta
+          | ValVec vva' delta <- vsa
+          , let (args, vva) = splitAt n vva'
+          , let va = PmCon { pm_con_con     = con
+                            , pm_con_arg_tys = arg_tys
+                            , pm_con_tvs     = ex_tvs
+                            , pm_con_dicts   = dicts
+                            , pm_con_args    = args } ]
+    in updateVsa upd
+
+-- | Get the union of two covered, uncovered and divergent value set
+-- abstractions. Since the covered and divergent sets are represented by a
+-- boolean, union means computing the logical or (at least one of the two is
+-- non-empty).
+
+mkUnion :: PartialResult -> PartialResult -> PartialResult
+mkUnion = mappend
+
+-- | Add a value vector abstraction to a value set abstraction (uncovered).
+mkCons :: ValVec -> PartialResult -> PartialResult
+mkCons vva = updateVsa (vva:)
+
+-- | Set the divergent set to not empty
+forces :: PartialResult -> PartialResult
+forces pres = pres { presultDivergent = Diverged }
+
+-- | Set the divergent set to non-empty if the flag is `True`
+force_if :: Bool -> PartialResult -> PartialResult
+force_if True  pres = forces pres
+force_if False pres = pres
+
+set_provenance :: Provenance -> PartialResult -> PartialResult
+set_provenance prov pr = pr { presultProvenance = prov }
+
+-- ----------------------------------------------------------------------------
+-- * Propagation of term constraints inwards when checking nested matches
+
+{- Note [Type and Term Equality Propagation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking a match it would be great to have all type and term information
+available so we can get more precise results. For this reason we have functions
+`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and
+term constraints (respectively) as we go deeper.
+
+The type constraints we propagate inwards are collected by `collectEvVarsPats'
+in HsPat.hs. This handles bug #4139 ( see example
+  https://gitlab.haskell.org/ghc/ghc/snippets/672 )
+where this is needed.
+
+For term equalities we do less, we just generate equalities for HsCase. For
+example we accurately give 2 redundancy warnings for the marked cases:
+
+f :: [a] -> Bool
+f x = case x of
+
+  []    -> case x of        -- brings (x ~ []) in scope
+             []    -> True
+             (_:_) -> False -- can't happen
+
+  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope
+             (_:_) -> True
+             []    -> False -- can't happen
+
+Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating
+these constraints.
+-}
+
+-- | Generate equalities when checking a case expression:
+--     case x of { p1 -> e1; ... pn -> en }
+-- When we go deeper to check e.g. e1 we record two equalities:
+-- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)
+-- and (x ~ p1).
+genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee
+             -> [Pat GhcTc]           -- LHS       (should have length 1)
+             -> [Id]                  -- MatchVars (should have length 1)
+             -> DsM (Bag SimpleEq)
+genCaseTmCs2 Nothing _ _ = return emptyBag
+genCaseTmCs2 (Just scr) [p] [var] = do
+  fam_insts <- dsGetFamInstEnvs
+  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p
+  let scr_e = lhsExprToPmExpr scr
+  return $ listToBag [(var, e), (var, scr_e)]
+genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
+
+-- | Generate a simple equality when checking a case expression:
+--     case x of { matches }
+-- When checking matches we record that (x ~ y) where y is the initial
+-- uncovered. All matches will have to satisfy this equality.
+genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq
+genCaseTmCs1 Nothing     _    = emptyBag
+genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
+genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"
+
+{- Note [Literals in PmPat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of translating a literal to a variable accompanied with a guard, we
+treat them like constructor patterns. The following example from
+"./libraries/base/GHC/IO/Encoding.hs" shows why:
+
+mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding
+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of
+    "UTF8"    -> return $ UTF8.mkUTF8 cfm
+    "UTF16"   -> return $ UTF16.mkUTF16 cfm
+    "UTF16LE" -> return $ UTF16.mkUTF16le cfm
+    ...
+
+Each clause gets translated to a list of variables with an equal number of
+guards. For every guard we generate two cases (equals True/equals False) which
+means that we generate 2^n cases to feed the oracle with, where n is the sum of
+the length of all strings that appear in the patterns. For this particular
+example this means over 2^40 cases. Instead, by representing them like with
+constructor we get the following:
+  1. We exploit the common prefix with our representation of VSAs
+  2. We prune immediately non-reachable cases
+     (e.g. False == (x == "U"), True == (x == "U"))
+
+Note [Translating As Patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of translating x@p as:  x (p <- x)
+we instead translate it as:     p (x <- coercePattern p)
+for performance reasons. For example:
+
+  f x@True  = 1
+  f y@False = 2
+
+Gives the following with the first translation:
+
+  x |> {x == False, x == y, y == True}
+
+If we use the second translation we get an empty set, independently of the
+oracle. Since the pattern `p' may contain guard patterns though, it cannot be
+used as an expression. That's why we call `coercePatVec' to drop the guard and
+`vaToPmExpr' to transform the value abstraction to an expression in the
+guard pattern (value abstractions are a subset of expressions). We keep the
+guards in the first pattern `p' though.
+
+
+%************************************************************************
+%*                                                                      *
+      Pretty printing of exhaustiveness/redundancy check warnings
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | Check whether any part of pattern match checking is enabled (does not
+-- matter whether it is the redundancy check or the exhaustiveness check).
+isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool
+isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)
+  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind
+
+instance Outputable ValVec where
+  ppr (ValVec vva delta)
+    = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)
+          vector                = substInValAbs subst vva
+      in  ppr_uncovered (vector, residual_eqs)
+
+-- | Apply a term substitution to a value vector abstraction. All VAs are
+-- transformed to PmExpr (used only before pretty printing).
+substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]
+substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)
+
+-- | Wrap up the term oracle's state once solving is complete. Drop any
+-- information about unhandled constraints (involving HsExprs) and flatten
+-- (height 1) the substitution.
+wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)
+wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
+
+-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)
+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
+  = when (flag_i || flag_u) $ do
+      let exists_r = flag_i && notNull redundant && onlyBuiltin
+          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd
+          exists_u = flag_u && (case uncovered of
+                                  TypeOfUncovered   _ -> True
+                                  UncoveredPatterns u -> notNull u)
+
+      when exists_r $ forM_ redundant $ \(dL->L l q) -> do
+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+                               (pprEqn q "is redundant"))
+      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do
+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+                               (pprEqn q "has inaccessible right hand side"))
+      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
+        case uncovered of
+          TypeOfUncovered ty           -> warnEmptyCase ty
+          UncoveredPatterns candidates -> pprEqns candidates
+  where
+    PmResult
+      { pmresultProvenance = prov
+      , pmresultRedundant = redundant
+      , pmresultUncovered = uncovered
+      , pmresultInaccessible = inaccessible } = pm_result
+
+    flag_i = wopt Opt_WarnOverlappingPatterns dflags
+    flag_u = exhaustive dflags kind
+    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
+
+    is_rec_upd = case kind of { RecUpd -> True; _ -> False }
+       -- See Note [Inaccessible warnings for record updates]
+
+    onlyBuiltin = prov == FromBuiltin
+
+    maxPatterns = maxUncoveredPatterns dflags
+
+    -- Print a single clause (for redundant/with-inaccessible-rhs)
+    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
+
+    -- Print several clauses (for uncovered clauses)
+    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->
+      case qs of -- See #11245
+           [ValVec [] _]
+                    -> text "Guards do not cover entire pattern space"
+           _missing -> let us = map ppr qs
+                       in  hang (text "Patterns not matched:") 4
+                                (vcat (take maxPatterns us)
+                                 $$ dots maxPatterns us)
+
+    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for
+    -- which we only know the type and have no inhabitants at hand)
+    warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->
+      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)
+
+{- Note [Inaccessible warnings for record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#12957)
+  data T a where
+    T1 :: { x :: Int } -> T Bool
+    T2 :: { x :: Int } -> T a
+    T3 :: T a
+
+  f :: T Char -> T a
+  f r = r { x = 3 }
+
+The desugarer will (conservatively generate a case for T1 even though
+it's impossible:
+  f r = case r of
+          T1 x -> T1 3   -- Inaccessible branch
+          T2 x -> T2 3
+          _    -> error "Missing"
+
+We don't want to warn about the inaccessible branch because the programmer
+didn't put it there!  So we filter out the warning here.
+-}
+
+-- | Issue a warning when the predefined number of iterations is exceeded
+-- for the pattern match checker
+warnPmIters :: DynFlags -> DsMatchContext -> DsM ()
+warnPmIters dflags (DsMatchContext kind loc)
+  = when (flag_i || flag_u) $ do
+      iters <- maxPmCheckIterations <$> getDynFlags
+      putSrcSpanDs loc (warnDs NoReason (msg iters))
+  where
+    ctxt   = pprMatchContext kind
+    msg is = fsep [ text "Pattern match checker exceeded"
+                  , parens (ppr is), text "iterations in", ctxt <> dot
+                  , text "(Use -fmax-pmcheck-iterations=n"
+                  , text "to set the maximun number of iterations to n)" ]
+
+    flag_i = wopt Opt_WarnOverlappingPatterns dflags
+    flag_u = exhaustive dflags kind
+
+dots :: Int -> [a] -> SDoc
+dots maxPatterns qs
+    | qs `lengthExceeds` maxPatterns = text "..."
+    | otherwise                      = empty
+
+-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
+exhaustive :: DynFlags -> HsMatchContext id -> Bool
+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
+
+-- | Denotes whether an exhaustiveness check is supported, and if so,
+-- via which 'WarningFlag' it's controlled.
+-- Returns 'Nothing' if check is not supported.
+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag ThPatSplice   = Nothing
+exhaustiveWarningFlag PatSyn        = Nothing
+exhaustiveWarningFlag ThPatQuote    = Nothing
+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
+                                       -- in list comprehensions, pattern guards
+                                       -- etc. They are often *supposed* to be
+                                       -- incomplete
+
+-- True <==> singular
+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
+  = vcat [text txt <+> msg,
+          sep [ text "In" <+> ppr_match <> char ':'
+              , nest 4 (rest_of_msg_fun pref)]]
+  where
+    txt | singular  = "Pattern match"
+        | otherwise = "Pattern match(es)"
+
+    (ppr_match, pref)
+        = case kind of
+             FunRhs { mc_fun = (dL->L _ fun) }
+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+             _    -> (pprMatchContext kind, \ pp -> pp)
+
+ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
+ppr_pats kind pats
+  = sep [sep (map ppr pats), matchSeparator kind, text "..."]
+
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc
+ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))
+
+ppr_constraint :: (SDoc,[PmLit]) -> SDoc
+ppr_constraint (var, lits) = var <+> text "is not one of"
+                                 <+> braces (pprWithCommas ppr lits)
+
+ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc
+ppr_uncovered (expr_vec, complex)
+  | null cs   = fsep vec -- there are no literal constraints
+  | otherwise = hang (fsep vec) 4 $
+                  text "where" <+> vcat (map ppr_constraint cs)
+  where
+    sdoc_vec = mapM pprPmExprWithParens expr_vec
+    (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)
+
+{- Note [Representation of Term Equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the paper, term constraints always take the form (x ~ e). Of course, a more
+general constraint of the form (e1 ~ e1) can always be transformed to an
+equivalent set of the former constraints, by introducing a fresh, intermediate
+variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise
+to #11160 (incredibly bad performance for literal pattern matching). Two are
+the main sources of this problem (the actual problem is how these two interact
+with each other):
+
+1. Pattern matching on literals generates twice as many constraints as needed.
+   Consider the following (tests/ghci/should_run/ghcirun004):
+
+    foo :: Int -> Int
+    foo 1    = 0
+    ...
+    foo 5000 = 4999
+
+   The covered and uncovered set *should* look like:
+     U0 = { x |> {} }
+
+     C1  = { 1  |> { x ~ 1 } }
+     U1  = { x  |> { False ~ (x ~ 1) } }
+     ...
+     C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }
+     U10 = { x  |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }
+     ...
+
+     If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }
+     we get twice as many constraints. Also note that half of them are just the
+     substitution [x |-> False].
+
+2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form
+   (x ~ e) as substitutions [x |-> e]. More specifically, function
+   `extendSubstAndSolve` applies such substitutions in the residual constraints
+   and partitions them in the affected and non-affected ones, which are the new
+   worklist. Essentially, this gives quadradic behaviour on the number of the
+   residual constraints. (This would not be the case if the term oracle used
+   mutable variables but, since we use it to handle disjunctions on value set
+   abstractions (`Union` case), we chose a pure, incremental interface).
+
+Now the problem becomes apparent (e.g. for clause 300):
+  * Set U300 contains 300 substituting constraints [y_i |-> False] and 300
+    constraints that we know that will not reduce (stay in the worklist).
+  * To check for consistency, we apply the substituting constraints ONE BY ONE
+    (since `tmOracle` is called incrementally, it does not have all of them
+    available at once). Hence, we go through the (non-progressing) constraints
+    over and over, achieving over-quadradic behaviour.
+
+If instead we allow constraints of the form (e ~ e),
+  * All uncovered sets Ui contain no substituting constraints and i
+    non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle
+    behaves linearly.
+  * All covered sets Ci contain exactly (i-1) non-progressing constraints and
+    a single substituting constraint. So the term oracle goes through the
+    constraints only once.
+
+The performance improvement becomes even more important when more arguments are
+involved.
+-}
+
+-- Debugging Infrastructre
+
+tracePm :: String -> SDoc -> PmM ()
+tracePm herald doc = liftD $ tracePmD herald doc
+
+
+tracePmD :: String -> SDoc -> DsM ()
+tracePmD herald doc = do
+  dflags <- getDynFlags
+  printer <- mkPrintUnqualifiedDs
+  liftIO $ dumpIfSet_dyn_printer printer dflags
+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))
+
+
+pprPmPatDebug :: PmPat a -> SDoc
+pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)
+  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]
+pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid
+pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li
+pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
+pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
+                                           <+> ppr ge
+pprPmPatDebug PmFake = text "PmFake"
+
+pprPatVec :: PatVec -> SDoc
+pprPatVec ps = hang (text "Pattern:") 2
+                (brackets $ sep
+                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))
+
+pprValAbs :: [ValAbs] -> SDoc
+pprValAbs ps = hang (text "ValAbs:") 2
+                (brackets $ sep
+                  $ punctuate (comma) (map pprPmPatDebug ps))
+
+pprValVecDebug :: ValVec -> SDoc
+pprValVecDebug (ValVec vas _d) = text "ValVec" <+>
+                                  parens (pprValAbs vas)
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Coverage.hs
@@ -0,0 +1,1364 @@
+{-
+(c) Galois, 2006
+(c) University of Glasgow, 2007
+-}
+
+{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Coverage (addTicksToBinds, hpcInitCode) where
+
+import GhcPrelude as Prelude
+
+import qualified GHCi
+import GHCi.RemoteTypes
+import Data.Array
+import ByteCodeTypes
+import GHC.Stack.CCS
+import Type
+import HsSyn
+import Module
+import Outputable
+import DynFlags
+import ConLike
+import Control.Monad
+import SrcLoc
+import ErrUtils
+import NameSet hiding (FreeVars)
+import Name
+import Bag
+import CostCentre
+import CostCentreState
+import CoreSyn
+import Id
+import VarSet
+import Data.List
+import FastString
+import HscTypes
+import TyCon
+import BasicTypes
+import MonadUtils
+import Maybes
+import CLabel
+import Util
+
+import Data.Time
+import System.Directory
+
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+
+import qualified Data.ByteString as BS
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+*              The main function: addTicksToBinds
+*                                                                      *
+************************************************************************
+-}
+
+addTicksToBinds
+        :: HscEnv
+        -> Module
+        -> ModLocation          -- ... off the current module
+        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
+                                -- isExportedId doesn't work yet (the desugarer
+                                -- hasn't set it), so we have to work from this set.
+        -> [TyCon]              -- Type constructor in this module
+        -> LHsBinds GhcTc
+        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
+
+addTicksToBinds hsc_env mod mod_loc exports tyCons binds
+  | let dflags = hsc_dflags hsc_env
+        passes = coveragePasses dflags, not (null passes),
+    Just orig_file <- ml_hs_file mod_loc,
+    not ("boot" `isSuffixOf` orig_file) = do
+
+     let  orig_file2 = guessSourceFile binds orig_file
+
+          tickPass tickish (binds,st) =
+            let env = TTE
+                      { fileName     = mkFastString orig_file2
+                      , declPath     = []
+                      , tte_dflags   = dflags
+                      , exports      = exports
+                      , inlines      = emptyVarSet
+                      , inScope      = emptyVarSet
+                      , blackList    = Map.fromList
+                                          [ (getSrcSpan (tyConName tyCon),())
+                                          | tyCon <- tyCons ]
+                      , density      = mkDensity tickish dflags
+                      , this_mod     = mod
+                      , tickishType  = tickish
+                      }
+                (binds',_,st') = unTM (addTickLHsBinds binds) env st
+            in (binds', st')
+
+          initState = TT { tickBoxCount = 0
+                         , mixEntries   = []
+                         , ccIndices    = newCostCentreState
+                         }
+
+          (binds1,st) = foldr tickPass (binds, initState) passes
+
+     let tickCount = tickBoxCount st
+         entries = reverse $ mixEntries st
+     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
+     modBreaks <- mkModBreaks hsc_env mod tickCount entries
+
+     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)
+
+     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
+
+  | otherwise = return (binds, emptyHpcInfo False, Nothing)
+
+guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
+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 ->
+                                 srcSpanFileName_maybe pos : rest) [] binds
+     in
+     case top_pos of
+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
+                      -> unpackFS file_name
+        _ -> orig_file
+
+
+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks hsc_env mod count entries
+  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
+    breakArray <- GHCi.newBreakArray hsc_env (length entries)
+    ccs <- mkCCSArray hsc_env mod count entries
+    let
+           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
+           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
+           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
+    return emptyModBreaks
+                       { modBreaks_flags = breakArray
+                       , modBreaks_locs  = locsTicks
+                       , modBreaks_vars  = varsTicks
+                       , modBreaks_decls = declsTicks
+                       , modBreaks_ccs   = ccs
+                       }
+  | otherwise = return emptyModBreaks
+
+mkCCSArray
+  :: HscEnv -> Module -> Int -> [MixEntry_]
+  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
+mkCCSArray hsc_env modul count entries = do
+  if interpreterProfiled dflags
+    then do
+      let module_str = moduleNameString (moduleName modul)
+      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
+      return (listArray (0,count-1) costcentres)
+    else do
+      return (listArray (0,-1) [])
+ where
+    dflags = hsc_dflags hsc_env
+    mk_one (srcspan, decl_path, _, _) = (name, src)
+      where name = concat (intersperse "." decl_path)
+            src = showSDoc dflags (ppr srcspan)
+
+
+writeMixEntries
+  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
+writeMixEntries dflags mod count entries filename
+  | not (gopt Opt_Hpc dflags) = return 0
+  | otherwise   = do
+        let
+            hpc_dir = hpcDir dflags
+            mod_name = moduleNameString (moduleName mod)
+
+            hpc_mod_dir
+              | moduleUnitId mod == mainUnitId  = hpc_dir
+              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
+
+            tabStop = 8 -- <tab> counts as a normal char in GHC's
+                        -- location ranges.
+
+        createDirectoryIfMissing True hpc_mod_dir
+        modTime <- getModificationUTCTime filename
+        let entries' = [ (hpcPos, box)
+                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+        when (entries' `lengthIsNot` count) $ do
+          panic "the number of .mix entries are inconsistent"
+        let hashNo = mixHash filename modTime tabStop entries'
+        mixCreate hpc_mod_dir mod_name
+                       $ Mix filename modTime (toHash hashNo) tabStop entries'
+        return hashNo
+
+
+-- -----------------------------------------------------------------------------
+-- TickDensity: where to insert ticks
+
+data TickDensity
+  = TickForCoverage       -- for Hpc
+  | TickForBreakPoints    -- for GHCi
+  | TickAllFunctions      -- for -prof-auto-all
+  | TickTopFunctions      -- for -prof-auto-top
+  | TickExportedFunctions -- for -prof-auto-exported
+  | TickCallSites         -- for stack tracing
+  deriving Eq
+
+mkDensity :: TickishType -> DynFlags -> TickDensity
+mkDensity tickish dflags = case tickish of
+  HpcTicks             -> TickForCoverage
+  SourceNotes          -> TickForCoverage
+  Breakpoints          -> TickForBreakPoints
+  ProfNotes ->
+    case profAuto dflags of
+      ProfAutoAll      -> TickAllFunctions
+      ProfAutoTop      -> TickTopFunctions
+      ProfAutoExports  -> TickExportedFunctions
+      ProfAutoCalls    -> TickCallSites
+      _other           -> panic "mkDensity"
+
+-- | Decide whether to add a tick to a binding or not.
+shouldTickBind  :: TickDensity
+                -> Bool         -- top level?
+                -> Bool         -- exported?
+                -> Bool         -- simple pat bind?
+                -> Bool         -- INLINE pragma?
+                -> Bool
+
+shouldTickBind density top_lev exported _simple_pat inline
+ = case density of
+      TickForBreakPoints    -> False
+        -- we never add breakpoints to simple pattern bindings
+        -- (there's always a tick on the rhs anyway).
+      TickAllFunctions      -> not inline
+      TickTopFunctions      -> top_lev && not inline
+      TickExportedFunctions -> exported && not inline
+      TickForCoverage       -> True
+      TickCallSites         -> False
+
+shouldTickPatBind :: TickDensity -> Bool -> Bool
+shouldTickPatBind density top_lev
+  = case density of
+      TickForBreakPoints    -> False
+      TickAllFunctions      -> True
+      TickTopFunctions      -> top_lev
+      TickExportedFunctions -> False
+      TickForCoverage       -> False
+      TickCallSites         -> False
+
+-- -----------------------------------------------------------------------------
+-- Adding ticks to bindings
+
+addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
+addTickLHsBinds = mapBagM addTickLHsBind
+
+addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
+addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds   = binds,
+                                       abs_exports = abs_exports })) = do
+  withEnv add_exports $ do
+  withEnv add_inlines $ do
+  binds' <- addTickLHsBinds binds
+  return $ cL pos $ bind { abs_binds = binds' }
+ where
+   -- in AbsBinds, the Id on each binding is not the actual top-level
+   -- Id that we are defining, they are related by the abs_exports
+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
+   -- to add the local Ids to the set of exported Names so that we know to
+   -- tick the right bindings.
+   add_exports env =
+     env{ exports = exports env `extendNameSetList`
+                      [ idName mid
+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+                      , idName pid `elemNameSet` (exports env) ] }
+
+   -- See Note [inline sccs]
+   add_inlines env =
+     env{ inlines = inlines env `extendVarSetList`
+                      [ mid
+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+                      , isInlinePragma (idInlinePragma pid) ] }
+
+addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id)  }))) = do
+  let name = getOccString id
+  decl_path <- getPathEntry
+  density <- getDensity
+
+  inline_ids <- liftM inlines getEnv
+  -- See Note [inline sccs]
+  let inline   = isInlinePragma (idInlinePragma id)
+                 || id `elemVarSet` inline_ids
+
+  -- See Note [inline sccs]
+  tickish <- tickishType `liftM` getEnv
+  if inline && tickish == ProfNotes then return (cL pos funBind) else do
+
+  (fvs, mg) <-
+        getFreeVars $
+        addPathEntry name $
+        addTickMatchGroup False (fun_matches funBind)
+
+  case mg of
+    MG {} -> return ()
+    _     -> panic "addTickLHsBind"
+
+  blackListed <- isBlackListed pos
+  exported_names <- liftM exports getEnv
+
+  -- We don't want to generate code for blacklisted positions
+  -- We don't want redundant ticks on simple pattern bindings
+  -- We don't want to tick non-exported bindings in TickExportedFunctions
+  let simple = isSimplePatBind funBind
+      toplev = null decl_path
+      exported = idName id `elemNameSet` exported_names
+
+  tick <- if not blackListed &&
+               shouldTickBind density toplev exported simple inline
+             then
+                bindTick density name pos fvs
+             else
+                return Nothing
+
+  let mbCons = maybe Prelude.id (:)
+  return $ cL pos $ funBind { fun_matches = mg
+                            , fun_tick = tick `mbCons` fun_tick funBind }
+
+   where
+   -- a binding is a simple pattern binding if it is a funbind with
+   -- zero patterns
+   isSimplePatBind :: HsBind a -> Bool
+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
+
+-- TODO: Revisit this
+addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
+                                        , pat_rhs = rhs }))) = do
+  let name = "(...)"
+  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
+  let pat' = pat { pat_rhs = rhs'}
+
+  -- Should create ticks here?
+  density <- getDensity
+  decl_path <- getPathEntry
+  let top_lev = null decl_path
+  if not (shouldTickPatBind density top_lev)
+    then return (cL pos pat')
+    else do
+
+    -- Allocate the ticks
+    rhs_tick <- bindTick density name pos fvs
+    let patvars = map getOccString (collectPatBinders lhs)
+    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
+
+    -- Add to pattern
+    let mbCons = maybe id (:)
+        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
+        patvar_tickss = zipWith mbCons patvar_ticks
+                        (snd (pat_ticks pat') ++ repeat [])
+    return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+
+-- Only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
+addTickLHsBind _  = panic "addTickLHsBind: Impossible Match" -- due to #15884
+
+
+
+bindTick
+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
+bindTick density name pos fvs = do
+  decl_path <- getPathEntry
+  let
+      toplev        = null decl_path
+      count_entries = toplev || density == TickAllFunctions
+      top_only      = density /= TickAllFunctions
+      box_label     = if toplev then TopLevelBox [name]
+                                else LocalBox (decl_path ++ [name])
+  --
+  allocATickBox box_label count_entries top_only pos fvs
+
+
+-- Note [inline sccs]
+--
+-- The reason not to add ticks to INLINE functions is that this is
+-- sometimes handy for avoiding adding a tick to a particular function
+-- (see #6131)
+--
+-- So for now we do not add any ticks to INLINE functions at all.
+--
+-- We used to use isAnyInlinePragma to figure out whether to avoid adding
+-- ticks for this purpose. However, #12962 indicates that this contradicts
+-- the documentation on profiling (which only mentions INLINE pragmas).
+-- So now we're more careful about what we avoid adding ticks to.
+
+-- -----------------------------------------------------------------------------
+-- Decorate an LHsExpr with ticks
+
+-- selectively add ticks to interesting expressions
+addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExpr e@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
+    TickForCoverage    -> tick_it
+    TickCallSites      | isCallSite e0      -> tick_it
+    _other             -> dont_tick_it
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- Add a tick to an expression which is the RHS of an equation or a binding.
+-- We always consider these to be breakpoints, unless the expression is a 'let'
+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps
+-- we should treat 'case' and 'if' the same way?
+addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprRHS e@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+                        | otherwise     -> tick_it
+     TickForCoverage -> tick_it
+     TickCallSites   | isCallSite e0 -> tick_it
+     _other          -> dont_tick_it
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- The inner expression of an evaluation context:
+--    let binds in [], ( [] )
+-- we never tick these if we're doing HPC, but otherwise
+-- we treat it like an ordinary expression.
+addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprEvalInner e = do
+   d <- getDensity
+   case d of
+     TickForCoverage -> addTickLHsExprNever e
+     _otherwise      -> addTickLHsExpr e
+
+-- | A let body is treated differently from addTickLHsExprEvalInner
+-- above with TickForBreakPoints, because for breakpoints we always
+-- want to tick the body, even if it is not a redex.  See test
+-- break012.  This gives the user the opportunity to inspect the
+-- values of the let-bound variables.
+addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprLetBody e@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+                        | otherwise     -> tick_it
+     _other -> addTickLHsExprEvalInner e
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by
+-- another.
+addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprNever (dL->L pos e0) = do
+    e1 <- addTickHsExpr e0
+    return $ cL pos e1
+
+-- general heuristic: expressions which do not denote values are good
+-- break points
+isGoodBreakExpr :: HsExpr GhcTc -> Bool
+isGoodBreakExpr (HsApp {})     = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {})     = True
+isGoodBreakExpr _other         = False
+
+isCallSite :: HsExpr GhcTc -> Bool
+isCallSite HsApp{}     = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{}     = True
+isCallSite _ = False
+
+addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
+  = ifDensity TickForCoverage
+        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
+        (addTickLHsExpr (cL pos e0))
+
+addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addBinTickLHsExpr boxLabel (dL->L pos e0)
+  = ifDensity TickForCoverage
+        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
+        (addTickLHsExpr (cL pos e0))
+
+
+-- -----------------------------------------------------------------------------
+-- Decorate the body of an HsExpr with ticks.
+-- (Whether to put a tick around the whole expression was already decided,
+-- in the addTickLHsExpr family of functions.)
+
+addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut _ con)
+  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
+addTickHsExpr e@(HsIPVar {})       = return e
+addTickHsExpr e@(HsOverLit {})     = return e
+addTickHsExpr e@(HsOverLabel{})    = return e
+addTickHsExpr e@(HsLit {})         = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+                                           (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
+                                           (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
+                                                      (addTickLHsExpr      e2)
+addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
+                                                      (addTickLHsExprNever e)
+                                                      (return ty)
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
+        liftM4 OpApp
+                (return fix)
+                (addTickLHsExpr e1)
+                (addTickLHsExprNever e2)
+                (addTickLHsExpr e3)
+addTickHsExpr (NegApp x e neg) =
+        liftM2 (NegApp x)
+                (addTickLHsExpr e)
+                (addTickSyntaxExpr hpcSrcSpan neg)
+addTickHsExpr (HsPar x e) =
+        liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+        liftM2 (SectionL x)
+                (addTickLHsExpr e1)
+                (addTickLHsExprNever e2)
+addTickHsExpr (SectionR x e1 e2) =
+        liftM2 (SectionR x)
+                (addTickLHsExprNever e1)
+                (addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple x es boxity) =
+        liftM2 (ExplicitTuple x)
+                (mapM addTickTupArg es)
+                (return boxity)
+addTickHsExpr (ExplicitSum ty tag arity e) = do
+        e' <- addTickLHsExpr e
+        return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase x e mgs) =
+        liftM2 (HsCase x)
+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
+                                   -- be evaluated.
+                (addTickMatchGroup False mgs)
+addTickHsExpr (HsIf x cnd e1 e2 e3) =
+        liftM3 (HsIf x cnd)
+                (addBinTickLHsExpr (BinBox CondBinBox) e1)
+                (addTickLHsExprOptAlt True e2)
+                (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsMultiIf ty alts)
+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
+       ; return $ HsMultiIf ty alts' }
+addTickHsExpr (HsLet x (dL->L l binds) e) =
+        bindLocals (collectLocalBinders binds) $
+          liftM2 (HsLet x . cL l)
+                  (addTickHsLocalBinds binds) -- to think about: !patterns.
+                  (addTickLHsExprLetBody e)
+addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+       ; return (HsDo srcloc cxt (cL l stmts')) }
+  where
+        forQual = case cxt of
+                    ListComp -> Just $ BinBox QualBinBox
+                    _        -> Nothing
+addTickHsExpr (ExplicitList ty wit es) =
+        liftM3 ExplicitList
+                (return ty)
+                (addTickWit wit)
+                (mapM (addTickLHsExpr) es)
+             where addTickWit Nothing = return Nothing
+                   addTickWit (Just fln)
+                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
+                          return (Just fln')
+
+addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
+
+addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
+  = do { rec_binds' <- addTickHsRecordBinds rec_binds
+       ; return (expr { rcon_flds = rec_binds' }) }
+
+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
+  = do { e' <- addTickLHsExpr e
+       ; flds' <- mapM addTickHsRecField flds
+       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
+
+addTickHsExpr (ExprWithTySig x e ty) =
+        liftM3 ExprWithTySig
+                (return x)
+                (addTickLHsExprNever e) -- No need to tick the inner expression
+                                        -- for expressions with signatures
+                (return ty)
+addTickHsExpr (ArithSeq ty wit arith_seq) =
+        liftM3 ArithSeq
+                (return ty)
+                (addTickWit wit)
+                (addTickArithSeqInfo arith_seq)
+             where addTickWit Nothing = return Nothing
+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
+                                             return (Just fl')
+
+-- We might encounter existing ticks (multiple Coverage passes)
+addTickHsExpr (HsTick x t e) =
+        liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
+
+addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do
+    e2 <- allocTickBox (ExpBox False) False False pos $
+                addTickHsExpr e0
+    return $ unLoc e2
+addTickHsExpr (HsSCC x src nm e) =
+        liftM3 (HsSCC x)
+                (return src)
+                (return nm)
+                (addTickLHsExpr e)
+addTickHsExpr (HsCoreAnn x src nm e) =
+        liftM3 (HsCoreAnn x)
+                (return src)
+                (return nm)
+                (addTickLHsExpr e)
+addTickHsExpr e@(HsBracket     {})   = return e
+addTickHsExpr e@(HsTcBracketOut  {}) = return e
+addTickHsExpr e@(HsRnBracketOut  {}) = return e
+addTickHsExpr e@(HsSpliceE  {})      = return e
+addTickHsExpr (HsProc x pat cmdtop) =
+        liftM2 (HsProc x)
+                (addTickLPat pat)
+                (liftL (addTickHsCmdTop) cmdtop)
+addTickHsExpr (HsWrap x w e) =
+        liftM2 (HsWrap x)
+                (return w)
+                (addTickHsExpr e)       -- Explicitly no tick on inside
+
+-- Others should never happen in expression content.
+addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
+
+addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
+addTickTupArg (dL->L l (Present x e))  = do { e' <- addTickLHsExpr e
+                                            ; return (cL l (Present x e')) }
+addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
+addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"
+addTickTupArg _  = panic "addTickTupArg: Impossible Match" -- due to #15884
+
+
+addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
+                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
+addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
+  let isOneOfMany = matchesOneOfMany matches
+  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
+  return $ mg { mg_alts = cL l matches' }
+addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
+
+addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
+             -> TM (Match GhcTc (LHsExpr GhcTc))
+addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
+                                               , m_grhss = gRHSs }) =
+  bindLocals (collectPatsBinders pats) $ do
+    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
+    return $ match { m_grhss = gRHSs' }
+addTickMatch _ _ (XMatch _) = panic "addTickMatch"
+
+addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
+             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do
+  bindLocals binders $ do
+    local_binds' <- addTickHsLocalBinds local_binds
+    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
+    return $ GRHSs x guarded' (cL l local_binds')
+  where
+    binders = collectLocalBinders local_binds
+addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
+
+addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
+            -> TM (GRHS GhcTc (LHsExpr GhcTc))
+addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
+  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
+                        (addTickGRHSBody isOneOfMany isLambda expr)
+  return $ GRHS x stmts' expr'
+addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
+
+addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
+    TickAllFunctions | isLambda ->
+       addPathEntry "\\" $
+         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
+           addTickHsExpr e0
+    _otherwise ->
+       addTickLHsExprRHS expr
+
+addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
+              -> TM [ExprLStmt GhcTc]
+addTickLStmts isGuard stmts = do
+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
+  return stmts
+
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
+               -> TM ([ExprLStmt GhcTc], a)
+addTickLStmts' isGuard lstmts res
+  = bindLocals (collectLStmtsBinders lstmts) $
+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+       ; a <- res
+       ; return (lstmts', a) }
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
+            -> TM (Stmt GhcTc (LHsExpr GhcTc))
+addTickStmt _isGuard (LastStmt x e noret ret) = do
+        liftM3 (LastStmt x)
+                (addTickLHsExpr e)
+                (pure noret)
+                (addTickSyntaxExpr hpcSrcSpan ret)
+addTickStmt _isGuard (BindStmt x pat e bind fail) = do
+        liftM4 (BindStmt x)
+                (addTickLPat pat)
+                (addTickLHsExprRHS e)
+                (addTickSyntaxExpr hpcSrcSpan bind)
+                (addTickSyntaxExpr hpcSrcSpan fail)
+addTickStmt isGuard (BodyStmt x e bind' guard') = do
+        liftM3 (BodyStmt x)
+                (addTick isGuard e)
+                (addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
+addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do
+        liftM (LetStmt x . cL l)
+                (addTickHsLocalBinds binds)
+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
+    liftM3 (ParStmt x)
+        (mapM (addTickStmtAndBinders isGuard) pairs)
+        (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))
+        (addTickSyntaxExpr hpcSrcSpan bindExpr)
+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
+    args' <- mapM (addTickApplicativeArg isGuard) args
+    return (ApplicativeStmt body_ty args' mb_join)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+                                    , trS_by = by, trS_using = using
+                                    , trS_ret = returnExpr, trS_bind = bindExpr
+                                    , trS_fmap = liftMExpr }) = do
+    t_s <- addTickLStmts isGuard stmts
+    t_y <- fmapMaybeM  addTickLHsExprRHS by
+    t_u <- addTickLHsExprRHS using
+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+    t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))
+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
+
+addTickStmt isGuard stmt@(RecStmt {})
+  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+
+addTickStmt _ (XStmtLR _) = panic "addTickStmt"
+
+addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+                  | otherwise          = addTickLHsExprRHS e
+
+addTickApplicativeArg
+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+addTickApplicativeArg isGuard (op, arg) =
+  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
+ where
+  addTickArg (ApplicativeArgOne x pat expr isBody) =
+    (ApplicativeArgOne x)
+      <$> addTickLPat pat
+      <*> addTickLHsExpr expr
+      <*> pure isBody
+  addTickArg (ApplicativeArgMany x stmts ret pat) =
+    (ApplicativeArgMany x)
+      <$> addTickLStmts isGuard stmts
+      <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
+      <*> addTickLPat pat
+  addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
+
+addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
+                      -> TM (ParStmtBlock GhcTc GhcTc)
+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
+    liftM3 (ParStmtBlock x)
+        (addTickLStmts isGuard stmts)
+        (return ids)
+        (addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
+
+addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
+addTickHsLocalBinds (HsValBinds x binds) =
+        liftM (HsValBinds x)
+                (addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds x binds)  =
+        liftM (HsIPBinds x)
+                (addTickHsIPBinds binds)
+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
+addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)
+
+addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
+                  -> TM (HsValBindsLR GhcTc (GhcPass b))
+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
+        b <- liftM2 NValBinds
+                (mapM (\ (rec,binds') ->
+                                liftM2 (,)
+                                        (return rec)
+                                        (addTickLHsBinds binds'))
+                        binds)
+                (return sigs)
+        return $ XValBindsLR b
+addTickHsValBinds _ = panic "addTickHsValBinds"
+
+addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
+addTickHsIPBinds (IPBinds dictbinds ipbinds) =
+        liftM2 IPBinds
+                (return dictbinds)
+                (mapM (liftL (addTickIPBind)) ipbinds)
+addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
+
+addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
+addTickIPBind (IPBind x nm e) =
+        liftM2 (IPBind x)
+                (return nm)
+                (addTickLHsExpr e)
+addTickIPBind (XIPBind x) = return (XIPBind x)
+
+-- There is no location here, so we might need to use a context location??
+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
+addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
+        x' <- fmap unLoc (addTickLHsExpr (cL pos x))
+        return $ syn { syn_expr = x' }
+-- we do not walk into patterns.
+addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
+addTickLPat pat = return pat
+
+addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
+addTickHsCmdTop (HsCmdTop x cmd) =
+        liftM2 HsCmdTop
+                (return x)
+                (addTickLHsCmd cmd)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
+
+addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
+addTickLHsCmd (dL->L pos c0) = do
+        c1 <- addTickHsCmd c0
+        return $ cL pos c1
+
+addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
+addTickHsCmd (HsCmdLam x matchgroup) =
+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp x c e) =
+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
+{-
+addTickHsCmd (OpApp e1 c2 fix c3) =
+        liftM4 OpApp
+                (addTickLHsExpr e1)
+                (addTickLHsCmd c2)
+                (return fix)
+                (addTickLHsCmd c3)
+-}
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase x e mgs) =
+        liftM2 (HsCmdCase x)
+                (addTickLHsExpr e)
+                (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
+        liftM3 (HsCmdIf x cnd)
+                (addBinTickLHsExpr (BinBox CondBinBox) e1)
+                (addTickLHsCmd c2)
+                (addTickLHsCmd c3)
+addTickHsCmd (HsCmdLet x (dL->L l binds) c) =
+        bindLocals (collectLocalBinders binds) $
+          liftM2 (HsCmdLet x . cL l)
+                   (addTickHsLocalBinds binds) -- to think about: !patterns.
+                   (addTickLHsCmd c)
+addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))
+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+       ; return (HsCmdDo srcloc (cL l stmts')) }
+
+addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
+        liftM5 HsCmdArrApp
+               (return arr_ty)
+               (addTickLHsExpr e1)
+               (addTickLHsExpr e2)
+               (return ty1)
+               (return lr)
+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
+        liftM4 (HsCmdArrForm x)
+               (addTickLHsExpr e)
+               (return f)
+               (return fix)
+               (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
+addTickHsCmd (HsCmdWrap x w cmd)
+  = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)
+
+-- Others should never happen in a command context.
+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
+
+addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
+                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
+addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do
+  matches' <- mapM (liftL addTickCmdMatch) matches
+  return $ mg { mg_alts = cL l matches' }
+addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"
+
+addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
+addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
+  bindLocals (collectPatsBinders pats) $ do
+    gRHSs' <- addTickCmdGRHSs gRHSs
+    return $ match { m_grhss = gRHSs' }
+addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"
+
+addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
+addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do
+  bindLocals binders $ do
+    local_binds' <- addTickHsLocalBinds local_binds
+    guarded' <- mapM (liftL addTickCmdGRHS) guarded
+    return $ GRHSs x guarded' (cL l local_binds')
+  where
+    binders = collectLocalBinders local_binds
+addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"
+
+addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS x stmts cmd)
+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+                                   stmts (addTickLHsCmd cmd)
+       ; return $ GRHS x stmts' expr' }
+addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"
+
+addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
+                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
+addTickLCmdStmts stmts = do
+  (stmts, _) <- addTickLCmdStmts' stmts (return ())
+  return stmts
+
+addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
+                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
+addTickLCmdStmts' lstmts res
+  = bindLocals binders $ do
+        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
+        a <- res
+        return (lstmts', a)
+  where
+        binders = collectLStmtsBinders lstmts
+
+addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
+addTickCmdStmt (BindStmt x pat c bind fail) = do
+        liftM4 (BindStmt x)
+                (addTickLPat pat)
+                (addTickLHsCmd c)
+                (return bind)
+                (return fail)
+addTickCmdStmt (LastStmt x c noret ret) = do
+        liftM3 (LastStmt x)
+                (addTickLHsCmd c)
+                (pure noret)
+                (addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (BodyStmt x c bind' guard') = do
+        liftM3 (BodyStmt x)
+                (addTickLHsCmd c)
+                (addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
+addTickCmdStmt (LetStmt x (dL->L l binds)) = do
+        liftM (LetStmt x . cL l)
+                (addTickHsLocalBinds binds)
+addTickCmdStmt stmt@(RecStmt {})
+  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+addTickCmdStmt ApplicativeStmt{} =
+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
+addTickCmdStmt XStmtLR{} =
+  panic "addTickCmdStmt XStmtLR"
+
+-- Others should never happen in a command context.
+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
+
+addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
+addTickHsRecordBinds (HsRecFields fields dd)
+  = do  { fields' <- mapM addTickHsRecField fields
+        ; return (HsRecFields fields' dd) }
+
+addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
+                  -> TM (LHsRecField' id (LHsExpr GhcTc))
+addTickHsRecField (dL->L l (HsRecField id expr pun))
+        = do { expr' <- addTickLHsExpr expr
+             ; return (cL l (HsRecField id expr' pun)) }
+
+
+addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
+addTickArithSeqInfo (From e1) =
+        liftM From
+                (addTickLHsExpr e1)
+addTickArithSeqInfo (FromThen e1 e2) =
+        liftM2 FromThen
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+addTickArithSeqInfo (FromTo e1 e2) =
+        liftM2 FromTo
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+addTickArithSeqInfo (FromThenTo e1 e2 e3) =
+        liftM3 FromThenTo
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+                (addTickLHsExpr e3)
+
+data TickTransState = TT { tickBoxCount:: Int
+                         , mixEntries  :: [MixEntry_]
+                         , ccIndices   :: CostCentreState
+                         }
+
+data TickTransEnv = TTE { fileName     :: FastString
+                        , density      :: TickDensity
+                        , tte_dflags   :: DynFlags
+                        , exports      :: NameSet
+                        , inlines      :: VarSet
+                        , declPath     :: [String]
+                        , inScope      :: VarSet
+                        , blackList    :: Map SrcSpan ()
+                        , this_mod     :: Module
+                        , tickishType  :: TickishType
+                        }
+
+--      deriving Show
+
+data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
+                 deriving (Eq)
+
+coveragePasses :: DynFlags -> [TickishType]
+coveragePasses dflags =
+    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
+    ifa (gopt Opt_Hpc dflags)                HpcTicks $
+    ifa (gopt Opt_SccProfilingOn dflags &&
+         profAuto dflags /= NoProfAuto)      ProfNotes $
+    ifa (debugLevel dflags > 0)              SourceNotes []
+  where ifa f x xs | f         = x:xs
+                   | otherwise = xs
+
+-- | Tickishs that only make sense when their source code location
+-- refers to the current file. This might not always be true due to
+-- LINE pragmas in the code - which would confuse at least HPC.
+tickSameFileOnly :: TickishType -> Bool
+tickSameFileOnly HpcTicks = True
+tickSameFileOnly _other   = False
+
+type FreeVars = OccEnv Id
+noFVs :: FreeVars
+noFVs = emptyOccEnv
+
+-- Note [freevars]
+--   For breakpoints we want to collect the free variables of an
+--   expression for pinning on the HsTick.  We don't want to collect
+--   *all* free variables though: in particular there's no point pinning
+--   on free variables that are will otherwise be in scope at the GHCi
+--   prompt, which means all top-level bindings.  Unfortunately detecting
+--   top-level bindings isn't easy (collectHsBindsBinders on the top-level
+--   bindings doesn't do it), so we keep track of a set of "in-scope"
+--   variables in addition to the free variables, and the former is used
+--   to filter additions to the latter.  This gives us complete control
+--   over what free variables we track.
+
+data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
+        -- a combination of a state monad (TickTransState) and a writer
+        -- monad (FreeVars).
+
+instance Functor TM where
+    fmap = liftM
+
+instance Applicative TM where
+    pure a = TM $ \ _env st -> (a,noFVs,st)
+    (<*>) = ap
+
+instance Monad TM where
+  (TM m) >>= k = TM $ \ env st ->
+                                case m env st of
+                                  (r1,fv1,st1) ->
+                                     case unTM (k r1) env st1 of
+                                       (r2,fv2,st2) ->
+                                          (r2, fv1 `plusOccEnv` fv2, st2)
+
+instance HasDynFlags TM where
+  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
+
+-- | Get the next HPC cost centre index for a given centre name
+getCCIndexM :: FastString -> TM CostCentreIndex
+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
+                                                 ccIndices st
+                              in (idx, noFVs, st { ccIndices = is' })
+
+getState :: TM TickTransState
+getState = TM $ \ _ st -> (st, noFVs, st)
+
+setState :: (TickTransState -> TickTransState) -> TM ()
+setState f = TM $ \ _ st -> ((), noFVs, f st)
+
+getEnv :: TM TickTransEnv
+getEnv = TM $ \ env st -> (env, noFVs, st)
+
+withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
+withEnv f (TM m) = TM $ \ env st ->
+                                 case m (f env) st of
+                                   (a, fvs, st') -> (a, fvs, st')
+
+getDensity :: TM TickDensity
+getDensity = TM $ \env st -> (density env, noFVs, st)
+
+ifDensity :: TickDensity -> TM a -> TM a -> TM a
+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
+
+getFreeVars :: TM a -> TM (FreeVars, a)
+getFreeVars (TM m)
+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
+
+freeVar :: Id -> TM ()
+freeVar id = TM $ \ env st ->
+                if id `elemVarSet` inScope env
+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
+                   else ((), noFVs, st)
+
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
+
+getPathEntry :: TM [String]
+getPathEntry = declPath `liftM` getEnv
+
+getFileName :: TM FastString
+getFileName = fileName `liftM` getEnv
+
+isGoodSrcSpan' :: SrcSpan -> Bool
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
+
+isGoodTickSrcSpan :: SrcSpan -> TM Bool
+isGoodTickSrcSpan pos = do
+  file_name <- getFileName
+  tickish <- tickishType `liftM` getEnv
+  let need_same_file = tickSameFileOnly tickish
+      same_file      = Just file_name == srcSpanFileName_maybe pos
+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
+
+ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
+ifGoodTickSrcSpan pos then_code else_code = do
+  good <- isGoodTickSrcSpan pos
+  if good then then_code else else_code
+
+bindLocals :: [Id] -> TM a -> TM a
+bindLocals new_ids (TM m)
+  = TM $ \ env st ->
+                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
+  where occs = [ nameOccName (idName id) | id <- new_ids ]
+
+isBlackListed :: SrcSpan -> TM Bool
+isBlackListed pos = TM $ \ env st ->
+              case Map.lookup pos (blackList env) of
+                Nothing -> (False,noFVs,st)
+                Just () -> (True,noFVs,st)
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
+             -> TM (LHsExpr GhcTc)
+allocTickBox boxLabel countEntries topOnly pos m =
+  ifGoodTickSrcSpan pos (do
+    (fvs, e) <- getFreeVars m
+    env <- getEnv
+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
+    return (cL pos (HsTick noExt tickish (cL pos e)))
+  ) (do
+    e <- m
+    return (cL pos e)
+  )
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
+              -> TM (Maybe (Tickish Id))
+allocATickBox boxLabel countEntries topOnly  pos fvs =
+  ifGoodTickSrcSpan pos (do
+    let
+      mydecl_path = case boxLabel of
+                      TopLevelBox x -> x
+                      LocalBox xs  -> xs
+                      _ -> panic "allocATickBox"
+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
+    return (Just tickish)
+  ) (return Nothing)
+
+
+mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
+          -> TM (Tickish Id)
+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
+
+  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
+          -- unlifted types cause two problems here:
+          --   * we can't bind them  at the GHCi prompt
+          --     (bindLocalsAtBreakpoint already fliters them out),
+          --   * the simplifier might try to substitute a literal for
+          --     the Id, and we can't handle that.
+
+      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
+
+      cc_name | topOnly   = head decl_path
+              | otherwise = concat (intersperse "." decl_path)
+
+  dflags <- getDynFlags
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me : mixEntries st }
+      return $ HpcTick (this_mod env) c
+
+    ProfNotes -> do
+      let nm = mkFastString cc_name
+      flavour <- HpcCC <$> getCCIndexM nm
+      let cc = mkUserCC nm (this_mod env) pos flavour
+          count = countEntries && gopt Opt_ProfCountEntries dflags
+      return $ ProfNote cc count True{-scopes-}
+
+    Breakpoints -> do
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me:mixEntries st }
+      return $ Breakpoint c ids
+
+    SourceNotes | RealSrcSpan pos' <- pos ->
+      return $ SourceNote pos' cc_name
+
+    _otherwise -> panic "mkTickish: bad source span!"
+
+
+allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
+                -> TM (LHsExpr GhcTc)
+allocBinTickBox boxLabel pos m = do
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do e <- liftM (cL pos) m
+                   ifGoodTickSrcSpan pos
+                     (mkBinTickBoxHpc boxLabel pos e)
+                     (return e)
+    _other   -> allocTickBox (ExpBox False) False False pos m
+
+mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
+                -> TM (LHsExpr GhcTc)
+mkBinTickBoxHpc boxLabel pos e =
+ TM $ \ env st ->
+  let meT = (pos,declPath env, [],boxLabel True)
+      meF = (pos,declPath env, [],boxLabel False)
+      meE = (pos,declPath env, [],ExpBox False)
+      c = tickBoxCount st
+      mes = mixEntries st
+  in
+     ( cL pos $ HsTick noExt (HpcTick (this_mod env) c)
+          $ cL pos $ HsBinTick noExt (c+1) (c+2) e
+   -- notice that F and T are reversed,
+   -- because we are building the list in
+   -- reverse...
+     , noFVs
+     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+     )
+
+mkHpcPos :: SrcSpan -> HpcPos
+mkHpcPos pos@(RealSrcSpan s)
+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+                                    srcSpanStartCol s,
+                                    srcSpanEndLine s,
+                                    srcSpanEndCol s - 1)
+                              -- the end column of a SrcSpan is one
+                              -- greater than the last column of the
+                              -- span (see SrcLoc), whereas HPC
+                              -- expects to the column range to be
+                              -- inclusive, hence we subtract one above.
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
+
+hpcSrcSpan :: SrcSpan
+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
+
+matchesOneOfMany :: [LMatch GhcTc body] -> Bool
+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
+  where
+        matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))
+          = length grhss
+        matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))
+          = panic "matchesOneOfMany"
+        matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"
+        matchCount _ = panic "matchCount: Impossible Match" -- due to #15884
+
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
+
+-- For the hash value, we hash everything: the file name,
+--  the timestamp of the original source file, the tab stop,
+--  and the mix entries. We cheat, and hash the show'd string.
+-- This hash only has to be hashed at Mix creation time,
+-- and is for sanity checking only.
+
+mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
+mixHash file tm tabstop entries = fromIntegral $ hashString
+        (show $ Mix file tm 0 tabstop entries)
+
+{-
+************************************************************************
+*                                                                      *
+*              initialisation
+*                                                                      *
+************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_<module>()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+-}
+
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+    [ text "static void hpc_init_" <> ppr this_mod
+         <> text "(void) __attribute__((constructor));"
+    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+    , braces (vcat [
+        text "extern StgWord64 " <> tickboxes <>
+               text "[]" <> semi,
+        text "hs_hpc_module" <>
+          parens (hcat (punctuate comma [
+              doubleQuotes full_name_str,
+              int tickCount, -- really StgWord32
+              int hashNo,    -- really StgWord32
+              tickboxes
+            ])) <> semi
+       ])
+    ]
+  where
+    tickboxes = ppr (mkHpcTicksLabel $ this_mod)
+
+    module_name  = hcat (map (text.charToC) $ BS.unpack $
+                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
+    package_name = hcat (map (text.charToC) $ BS.unpack $
+                         bytesFS (unitIdFS  (moduleUnitId this_mod)))
+    full_name_str
+       | moduleUnitId this_mod == mainUnitId
+       = module_name
+       | otherwise
+       = package_name <> char '/' <> module_name
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Desugar.hs
@@ -0,0 +1,546 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The Desugarer: turning HsSyn into Core.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Desugar (
+    -- * Desugaring operations
+    deSugar, deSugarExpr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DsUsage
+import DynFlags
+import HscTypes
+import HsSyn
+import TcRnTypes
+import TcRnMonad  ( finalSafeMode, fixSafeInstances )
+import TcRnDriver ( runTcInteractive )
+import Id
+import Name
+import Type
+import Avail
+import CoreSyn
+import CoreFVs     ( exprsSomeFreeVarsList )
+import CoreOpt     ( simpleOptPgm, simpleOptExpr )
+import PprCore
+import DsMonad
+import DsExpr
+import DsBinds
+import DsForeign
+import PrelNames   ( coercibleTyConKey )
+import TysPrim     ( eqReprPrimTyCon )
+import Unique      ( hasKey )
+import Coercion    ( mkCoVarCo )
+import TysWiredIn  ( coercibleDataCon )
+import DataCon     ( dataConWrapId )
+import MkCore      ( mkCoreLet )
+import Module
+import NameSet
+import NameEnv
+import Rules
+import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
+import CoreMonad        ( CoreToDo(..) )
+import CoreLint         ( endPassIO )
+import VarSet
+import FastString
+import ErrUtils
+import Outputable
+import SrcLoc
+import Coverage
+import Util
+import MonadUtils
+import OrdList
+import ExtractDocs
+
+import Data.List
+import Data.IORef
+import Control.Monad( when )
+import Plugins ( LoadedPlugin(..) )
+
+{-
+************************************************************************
+*                                                                      *
+*              The main function: deSugar
+*                                                                      *
+************************************************************************
+-}
+
+-- | Main entry point to the desugarer.
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
+-- Can modify PCS by faulting in more declarations
+
+deSugar hsc_env
+        mod_loc
+        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
+                            tcg_semantic_mod = mod,
+                            tcg_src          = hsc_src,
+                            tcg_type_env     = type_env,
+                            tcg_imports      = imports,
+                            tcg_exports      = exports,
+                            tcg_keep         = keep_var,
+                            tcg_th_splice_used = tc_splice_used,
+                            tcg_rdr_env      = rdr_env,
+                            tcg_fix_env      = fix_env,
+                            tcg_inst_env     = inst_env,
+                            tcg_fam_inst_env = fam_inst_env,
+                            tcg_merged       = merged,
+                            tcg_warns        = warns,
+                            tcg_anns         = anns,
+                            tcg_binds        = binds,
+                            tcg_imp_specs    = imp_specs,
+                            tcg_dependent_files = dependent_files,
+                            tcg_ev_binds     = ev_binds,
+                            tcg_th_foreign_files = th_foreign_files_var,
+                            tcg_fords        = fords,
+                            tcg_rules        = rules,
+                            tcg_patsyns      = patsyns,
+                            tcg_tcs          = tcs,
+                            tcg_insts        = insts,
+                            tcg_fam_insts    = fam_insts,
+                            tcg_hpc          = other_hpc_info,
+                            tcg_complete_matches = complete_matches
+                            })
+
+  = do { let dflags = hsc_dflags hsc_env
+             print_unqual = mkPrintUnqualified dflags rdr_env
+        ; withTiming (pure dflags)
+                     (text "Desugar"<+>brackets (ppr mod))
+                     (const ()) $
+     do { -- Desugar the program
+        ; let export_set = availsToNameSet exports
+              target     = hscTarget dflags
+              hpcInfo    = emptyHpcInfo other_hpc_info
+
+        ; (binds_cvr, ds_hpc_info, modBreaks)
+                         <- if not (isHsBootOrSig hsc_src)
+                              then addTicksToBinds hsc_env mod mod_loc
+                                       export_set (typeEnvTyCons type_env) binds
+                              else return (binds, hpcInfo, Nothing)
+        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
+                       do { ds_ev_binds <- dsEvBinds ev_binds
+                          ; core_prs <- dsTopLHsBinds binds_cvr
+                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
+                          ; (ds_fords, foreign_prs) <- dsForeigns fords
+                          ; ds_rules <- mapMaybeM dsRule rules
+                          ; let hpc_init
+                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
+                                  | otherwise = empty
+                          ; return ( ds_ev_binds
+                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
+                                   , spec_rules ++ ds_rules
+                                   , ds_fords `appendStubC` hpc_init) }
+
+        ; case mb_res of {
+           Nothing -> return (msgs, Nothing) ;
+           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
+
+     do {       -- Add export flags to bindings
+          keep_alive <- readIORef keep_var
+        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+              final_prs = addExportFlagsAndRules target export_set keep_alive
+                                                 rules_for_locals (fromOL all_prs)
+
+              final_pgm = combineEvBinds ds_ev_binds final_prs
+        -- Notice that we put the whole lot in a big Rec, even the foreign binds
+        -- When compiling PrelFloat, which defines data Float = F# Float#
+        -- we want F# to be in scope in the foreign marshalling code!
+        -- You might think it doesn't matter, but the simplifier brings all top-level
+        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
+        ; (ds_binds, ds_rules_for_imps)
+            <- simpleOptPgm dflags mod final_pgm rules_for_imps
+                         -- The simpleOptPgm gets rid of type
+                         -- bindings plus any stupid dead code
+
+        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
+
+        ; let used_names = mkUsedNames tcg_env
+              pluginModules =
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
+        ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
+                                 (map mi_module pluginModules) tcg_env
+
+        ; used_th <- readIORef tc_splice_used
+        ; dep_files <- readIORef dependent_files
+        ; safe_mode <- finalSafeMode dflags tcg_env
+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
+                      dep_files merged pluginModules
+        -- id_mod /= mod when we are processing an hsig, but hsigs
+        -- never desugared and compiled (there's no code!)
+        -- Consequently, this should hold for any ModGuts that make
+        -- past desugaring. See Note [Identity versus semantic module].
+        ; MASSERT( id_mod == mod )
+
+        ; foreign_files <- readIORef th_foreign_files_var
+
+        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
+
+        ; let mod_guts = ModGuts {
+                mg_module       = mod,
+                mg_hsc_src      = hsc_src,
+                mg_loc          = mkFileSrcSpan mod_loc,
+                mg_exports      = exports,
+                mg_usages       = usages,
+                mg_deps         = deps,
+                mg_used_th      = used_th,
+                mg_rdr_env      = rdr_env,
+                mg_fix_env      = fix_env,
+                mg_warns        = warns,
+                mg_anns         = anns,
+                mg_tcs          = tcs,
+                mg_insts        = fixSafeInstances safe_mode insts,
+                mg_fam_insts    = fam_insts,
+                mg_inst_env     = inst_env,
+                mg_fam_inst_env = fam_inst_env,
+                mg_patsyns      = patsyns,
+                mg_rules        = ds_rules_for_imps,
+                mg_binds        = ds_binds,
+                mg_foreign      = ds_fords,
+                mg_foreign_files = foreign_files,
+                mg_hpc_info     = ds_hpc_info,
+                mg_modBreaks    = modBreaks,
+                mg_safe_haskell = safe_mode,
+                mg_trust_pkg    = imp_trust_own_pkg imports,
+                mg_complete_sigs = complete_matches,
+                mg_doc_hdr      = doc_hdr,
+                mg_decl_docs    = decl_docs,
+                mg_arg_docs     = arg_docs
+              }
+        ; return (msgs, Just mod_guts)
+        }}}}
+
+mkFileSrcSpan :: ModLocation -> SrcSpan
+mkFileSrcSpan mod_loc
+  = case ml_hs_file mod_loc of
+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+      Nothing        -> interactiveSrcSpan   -- Presumably
+
+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
+dsImpSpecs imp_specs
+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
+      ; let (spec_binds, spec_rules) = unzip spec_prs
+      ; return (concatOL spec_binds, spec_rules) }
+
+combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
+-- Top-level bindings can include coercion bindings, but not via superclasses
+-- See Note [Top-level evidence]
+combineEvBinds [] val_prs
+  = [Rec val_prs]
+combineEvBinds (NonRec b r : bs) val_prs
+  | isId b    = combineEvBinds bs ((b,r):val_prs)
+  | otherwise = NonRec b r : combineEvBinds bs val_prs
+combineEvBinds (Rec prs : bs) val_prs
+  = combineEvBinds bs (prs ++ val_prs)
+
+{-
+Note [Top-level evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level evidence bindings may be mutually recursive with the top-level value
+bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
+because the occurrence analyser doesn't take account of type/coercion variables
+when computing dependencies.
+
+So we pull out the type/coercion variables (which are in dependency order),
+and Rec the rest.
+-}
+
+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
+
+deSugarExpr hsc_env tc_expr = do {
+         let dflags = hsc_dflags hsc_env
+
+       ; showPass dflags "Desugar"
+
+         -- Do desugaring
+       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
+                                 dsLExpr tc_expr
+
+       ; case mb_core_expr of
+            Nothing   -> return ()
+            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
+                         (pprCoreExpr expr)
+
+       ; return (msgs, mb_core_expr) }
+
+{-
+************************************************************************
+*                                                                      *
+*              Add rules and export flags to binders
+*                                                                      *
+************************************************************************
+-}
+
+addExportFlagsAndRules
+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
+    -> [(Id, t)] -> [(Id, t)]
+addExportFlagsAndRules target exports keep_alive rules prs
+  = mapFst add_one prs
+  where
+    add_one bndr = add_rules name (add_export name bndr)
+       where
+         name = idName bndr
+
+    ---------- Rules --------
+        -- See Note [Attach rules to local ids]
+        -- NB: the binder might have some existing rules,
+        -- arising from specialisation pragmas
+    add_rules name bndr
+        | Just rules <- lookupNameEnv rule_base name
+        = bndr `addIdSpecialisations` rules
+        | otherwise
+        = bndr
+    rule_base = extendRuleBaseList emptyRuleBase rules
+
+    ---------- Export flag --------
+    -- See Note [Adding export flags]
+    add_export name bndr
+        | dont_discard name = setIdExported bndr
+        | otherwise         = bndr
+
+    dont_discard :: Name -> Bool
+    dont_discard name = is_exported name
+                     || name `elemNameSet` keep_alive
+
+        -- In interactive mode, we don't want to discard any top-level
+        -- entities at all (eg. do not inline them away during
+        -- simplification), and retain them all in the TypeEnv so they are
+        -- available from the command line.
+        --
+        -- isExternalName separates the user-defined top-level names from those
+        -- introduced by the type checker.
+    is_exported :: Name -> Bool
+    is_exported | targetRetainsAllBindings target = isExternalName
+                | otherwise                       = (`elemNameSet` exports)
+
+{-
+Note [Adding export flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Set the no-discard flag if either
+        a) the Id is exported
+        b) it's mentioned in the RHS of an orphan rule
+        c) it's in the keep-alive set
+
+It means that the binding won't be discarded EVEN if the binding
+ends up being trivial (v = w) -- the simplifier would usually just
+substitute w for v throughout, but we don't apply the substitution to
+the rules (maybe we should?), so this substitution would make the rule
+bogus.
+
+You might wonder why exported Ids aren't already marked as such;
+it's just because the type checker is rather busy already and
+I didn't want to pass in yet another mapping.
+
+Note [Attach rules to local ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Find the rules for locally-defined Ids; then we can attach them
+to the binders in the top-level bindings
+
+Reason
+  - It makes the rules easier to look up
+  - It means that transformation rules and specialisations for
+    locally defined Ids are handled uniformly
+  - It keeps alive things that are referred to only from a rule
+    (the occurrence analyser knows about rules attached to Ids)
+  - It makes sure that, when we apply a rule, the free vars
+    of the RHS are more likely to be in scope
+  - The imported rules are carried in the in-scope set
+    which is extended on each iteration by the new wave of
+    local binders; any rules which aren't on the binding will
+    thereby get dropped
+
+
+************************************************************************
+*                                                                      *
+*              Desugaring transformation rules
+*                                                                      *
+************************************************************************
+-}
+
+dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
+dsRule (dL->L loc (HsRule { rd_name = name
+                          , rd_act  = rule_act
+                          , rd_tmvs = vars
+                          , rd_lhs  = lhs
+                          , rd_rhs  = rhs }))
+  = putSrcSpanDs loc $
+    do  { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]
+
+        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
+                  unsetWOptM Opt_WarnIdentities $
+                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
+
+        ; rhs' <- dsLExpr rhs
+        ; this_mod <- getModule
+
+        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
+
+        -- Substitute the dict bindings eagerly,
+        -- and take the body apart into a (f args) form
+        ; dflags <- getDynFlags
+        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
+                Left msg -> do { warnDs NoReason msg; return Nothing } ;
+                Right (final_bndrs, fn_id, args) -> do
+
+        { let is_local = isLocalId fn_id
+                -- NB: isLocalId is False of implicit Ids.  This is good because
+                -- we don't want to attach rules to the bindings of implicit Ids,
+                -- because they don't show up in the bindings until just before code gen
+              fn_name   = idName fn_id
+              final_rhs = simpleOptExpr dflags rhs''    -- De-crap it
+              rule_name = snd (unLoc name)
+              final_bndrs_set = mkVarSet final_bndrs
+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
+                        exprsSomeFreeVarsList isId args
+
+        ; rule <- dsMkUserRule this_mod is_local
+                         rule_name rule_act fn_name final_bndrs args
+                         final_rhs
+        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
+          warnRuleShadowing rule_name rule_act fn_id arg_ids
+
+        ; return (Just rule)
+        } } }
+dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"
+dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
+
+warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
+-- See Note [Rules and inlining/other rules]
+warnRuleShadowing rule_name rule_act fn_id arg_ids
+  = do { check False fn_id    -- We often have multiple rules for the same Id in a
+                              -- module. Maybe we should check that they don't overlap
+                              -- but currently we don't
+       ; mapM_ (check True) arg_ids }
+  where
+    check check_rules_too lhs_id
+      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
+                       -- If imported with no unfolding, no worries
+      , idInlineActivation lhs_id `competesWith` rule_act
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because" <+> quotes (ppr lhs_id)
+                               <+> text "might inline first")
+                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
+                       <+> quotes (ppr lhs_id)
+                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
+
+      | check_rules_too
+      , bad_rule : _ <- get_bad_rules lhs_id
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
+                               <+> text "for"<+> quotes (ppr lhs_id)
+                               <+> text "might fire first")
+                      , text "Probable fix: add phase [n] or [~n] to the competing rule"
+                      , whenPprDebug (ppr bad_rule) ])
+
+      | otherwise
+      = return ()
+
+    get_bad_rules lhs_id
+      = [ rule | rule <- idCoreRules lhs_id
+               , ruleActivation rule `competesWith` rule_act ]
+
+-- See Note [Desugaring coerce as cast]
+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
+unfold_coerce bndrs lhs rhs = do
+    (bndrs', wrap) <- go bndrs
+    return (bndrs', wrap lhs, wrap rhs)
+  where
+    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
+    go []     = return ([], id)
+    go (v:vs)
+        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
+        , tc `hasKey` coercibleTyConKey = do
+            u <- newUnique
+
+            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
+                v'  = mkLocalCoVar
+                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
+                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
+                      [k, t1, t2] `App`
+                      Coercion (mkCoVarCo v')
+
+            (bndrs, wrap) <- go vs
+            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
+        | otherwise = do
+            (bndrs,wrap) <- go vs
+            return (v:bndrs, wrap)
+
+{- Note [Desugaring RULE left hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the LHS of a RULE we do *not* want to desugar
+    [x]   to    build (\cn. x `c` n)
+We want to leave explicit lists simply as chains
+of cons's. We can achieve that slightly indirectly by
+switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
+
+That keeps the desugaring of list comprehensions simple too.
+
+Nor do we want to warn of conversion identities on the LHS;
+the rule is precisely to optimise them:
+  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
+
+Note [Desugaring coerce as cast]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want the user to express a rule saying roughly “mapping a coercion over a
+list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
+be written in Haskell. So we use `coerce` for that (#2110). The user writes
+    map coerce = coerce
+as a RULE, and this optimizes any kind of mapped' casts away, including `map
+MkNewtype`.
+
+For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
+corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
+`let c = MkCoercible co in ...`. This is later simplified to the desired form
+by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
+See also Note [Getting the map/coerce RULE to work] in CoreSubst.
+
+Note [Rules and inlining/other rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you have
+  f x = ...
+  g x = ...
+  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
+then there's a good chance that in a potential rule redex
+    ...f (g e)...
+then 'f' or 'g' will inline befor the rule can fire.  Solution: add an
+INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
+
+Note that this applies to all the free variables on the LHS, both the
+main function and things in its arguments.
+
+We also check if there are Ids on the LHS that have competing RULES.
+In the above example, suppose we had
+  {-# RULES "rule-for-g" forally. g [y] = ... #-}
+Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
+control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
+active; or perhpas after "rule-for-g" has become inactive. This is checked
+by 'competesWith'
+
+Class methods have a built-in RULE to select the method from the dictionary,
+so you can't change the phase on this.  That makes id very dubious to
+match on class methods in RULE lhs's.   See #10595.   I'm not happy
+about this. For example in Control.Arrow we have
+
+{-# RULES "compose/arr"   forall f g .
+                          (arr f) . (arr g) = arr (f . g) #-}
+
+and similar, which will elicit exactly these warnings, and risk never
+firing.  But it's not clear what to do instead.  We could make the
+class method rules inactive in phase 2, but that would delay when
+subsequent transformations could fire.
+-}
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsArrows.hs
@@ -0,0 +1,1270 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring arrow commands
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsArrows ( dsProcExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Match
+import DsUtils
+import DsMonad
+
+import HsSyn    hiding (collectPatBinders, collectPatsBinders,
+                        collectLStmtsBinders, collectLStmtBinders,
+                        collectStmtBinders )
+import TcHsSyn
+import qualified HsUtils
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types (newtypes etc), and sometimes not
+--     So WATCH OUT; check each use of split*Ty functions.
+-- Sigh.  This is a pain.
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
+                               dsSyntaxExpr )
+
+import TcType
+import Type ( splitPiTy )
+import TcEvidence
+import CoreSyn
+import CoreFVs
+import CoreUtils
+import MkCore
+import DsBinds (dsHsWrapper)
+
+import Name
+import Id
+import ConLike
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import Outputable
+import Bag
+import VarSet
+import SrcLoc
+import ListSetOps( assocMaybe )
+import Data.List
+import Util
+import UniqDSet
+
+data DsCmdEnv = DsCmdEnv {
+        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+    }
+
+mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
+-- See Note [CmdSyntaxTable] in HsExpr
+mkCmdEnv tc_meths
+  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
+
+       -- NB: Some of these lookups might fail, but that's OK if the
+       -- symbol is never used. That's why we use Maybe first and then
+       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
+       ; let the_arr_id     = assocMaybe prs arrAName
+             the_compose_id = assocMaybe prs composeAName
+             the_first_id   = assocMaybe prs firstAName
+             the_app_id     = assocMaybe prs appAName
+             the_choice_id  = assocMaybe prs choiceAName
+             the_loop_id    = assocMaybe prs loopAName
+
+           -- used as an argument in, e.g., do_premap
+       ; check_lev_poly 3 the_arr_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 5 the_compose_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 4 the_first_id
+
+           -- the result of the_app_id is used as an argument in, e.g.,
+           -- dsCmd/HsCmdArrApp/HsHigherOrderApp
+       ; check_lev_poly 2 the_app_id
+
+           -- used as an argument in, e.g., HsCmdIf
+       ; check_lev_poly 5 the_choice_id
+
+           -- used as an argument in, e.g., RecStmt
+       ; check_lev_poly 4 the_loop_id
+
+       ; return (meth_binds, DsCmdEnv {
+               arr_id     = Var (unmaybe the_arr_id arrAName),
+               compose_id = Var (unmaybe the_compose_id composeAName),
+               first_id   = Var (unmaybe the_first_id firstAName),
+               app_id     = Var (unmaybe the_app_id appAName),
+               choice_id  = Var (unmaybe the_choice_id choiceAName),
+               loop_id    = Var (unmaybe the_loop_id loopAName)
+             }) }
+  where
+    mk_bind (std_name, expr)
+      = do { rhs <- dsExpr expr
+           ; id <- newSysLocalDs (exprType rhs)
+           -- no check needed; these are functions
+           ; return (NonRec id rhs, (std_name, id)) }
+
+    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
+    unmaybe (Just id) _  = id
+
+      -- returns the result type of a pi-type (that is, a forall or a function)
+      -- Note that this result type may be ill-scoped.
+    res_type :: Type -> Type
+    res_type ty = res_ty
+      where
+        (_, res_ty) = splitPiTy ty
+
+    check_lev_poly :: Int -- arity
+                   -> Maybe Id -> DsM ()
+    check_lev_poly _     Nothing = return ()
+    check_lev_poly arity (Just id)
+      = dsNoLevPoly (nTimes arity res_type (idType id))
+          (text "In the result of the function" <+> quotes (ppr id))
+
+
+-- arr :: forall b c. (b -> c) -> a b c
+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
+
+-- (>>>) :: forall b c d. a b c -> a c d -> a b d
+do_compose :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_compose ids b_ty c_ty d_ty f g
+  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
+
+-- first :: forall b c d. a b c -> a (b,d) (c,d)
+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_first ids b_ty c_ty d_ty f
+  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
+
+-- app :: forall b c. a (a b c, b) c
+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
+
+-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
+-- note the swapping of d and c
+do_choice :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_choice ids b_ty c_ty d_ty f g
+  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
+
+-- loop :: forall b d c. a (b,d) (c,d) -> a b c
+-- note the swapping of d and c
+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_loop ids b_ty c_ty d_ty f
+  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
+
+-- premap :: forall b c d. (b -> c) -> a c d -> a b d
+-- premap f g = arr f >>> g
+do_premap :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_premap ids b_ty c_ty d_ty f g
+   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
+
+mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
+mkFailExpr ctxt ty
+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
+mkFstExpr :: Type -> Type -> DsM CoreExpr
+mkFstExpr a_ty b_ty = do
+    a_var <- newSysLocalDs a_ty
+    b_var <- newSysLocalDs b_ty
+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+    return (Lam pair_var
+               (coreCasePair pair_var a_var b_var (Var a_var)))
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
+mkSndExpr :: Type -> Type -> DsM CoreExpr
+mkSndExpr a_ty b_ty = do
+    a_var <- newSysLocalDs a_ty
+    b_var <- newSysLocalDs b_ty
+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+    return (Lam pair_var
+               (coreCasePair pair_var a_var b_var (Var b_var)))
+
+{-
+Build case analysis of a tuple.  This cannot be done in the DsM monad,
+because the list of variables is typically not yet defined.
+-}
+
+-- coreCaseTuple [u1..] v [x1..xn] body
+--      = case v of v { (x1, .., xn) -> body }
+-- But the matching may be nested if the tuple is very big
+
+coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseTuple uniqs scrut_var vars body
+  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
+
+coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
+coreCasePair scrut_var var1 var2 body
+  = Case (Var scrut_var) scrut_var (exprType body)
+         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
+
+mkCorePairTy :: Type -> Type -> Type
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
+
+mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
+
+mkCoreUnitExpr :: CoreExpr
+mkCoreUnitExpr = mkCoreTup []
+
+{-
+The input is divided into a local environment, which is a flat tuple
+(unless it's too big), and a stack, which is a right-nested pair.
+In general, the input has the form
+
+        ((x1,...,xn), (s1,...(sk,())...))
+
+where xi are the environment values, and si the ones on the stack,
+with s1 being the "top", the first one to be matched with a lambda.
+-}
+
+envStackType :: [Id] -> Type -> Type
+envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
+
+-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
+splitTypeAt :: Int -> Type -> ([Type], Type)
+splitTypeAt n ty
+  | n == 0 = ([], ty)
+  | otherwise = case tcTyConAppArgs ty of
+      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
+      _ -> pprPanic "splitTypeAt" (ppr ty)
+
+----------------------------------------------
+--              buildEnvStack
+--
+--      ((x1,...,xn),stk)
+
+buildEnvStack :: [Id] -> Id -> CoreExpr
+buildEnvStack env_ids stack_id
+  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
+
+----------------------------------------------
+--              matchEnvStack
+--
+--      \ ((x1,...,xn),stk) -> body
+--      =>
+--      \ pair ->
+--      case pair of (tup,stk) ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnvStack   :: [Id]         -- x1..xn
+                -> Id           -- stk
+                -> CoreExpr     -- e
+                -> DsM CoreExpr
+matchEnvStack env_ids stack_id body = do
+    uniqs <- newUniqueSupply
+    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+    let match_env = coreCaseTuple uniqs tup_var env_ids body
+    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))
+    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
+
+----------------------------------------------
+--              matchEnv
+--
+--      \ (x1,...,xn) -> body
+--      =>
+--      \ tup ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnv :: [Id]        -- x1..xn
+         -> CoreExpr    -- e
+         -> DsM CoreExpr
+matchEnv env_ids body = do
+    uniqs <- newUniqueSupply
+    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
+
+----------------------------------------------
+--              matchVarStack
+--
+--      case (x1, ...(xn, s)...) -> e
+--      =>
+--      case z0 of (x1,z1) ->
+--      case zn-1 of (xn,s) ->
+--      e
+matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
+matchVarStack [] stack_id body = return (stack_id, body)
+matchVarStack (param_id:param_ids) stack_id body = do
+    (tail_id, tail_code) <- matchVarStack param_ids stack_id body
+    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
+    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
+
+mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
+mkHsEnvStackExpr env_ids stack_id
+  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
+
+-- Translation of arrow abstraction
+
+-- D; xs |-a c : () --> t'      ---> c'
+-- --------------------------
+-- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
+--
+--              where (xs) is the tuple of variables bound by p
+
+dsProcExpr
+        :: LPat GhcTc
+        -> LHsCmdTop GhcTc
+        -> DsM CoreExpr
+dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+    (meth_binds, meth_ids) <- mkCmdEnv ids
+    let locals = mkVarSet (collectPatBinders pat)
+    (core_cmd, _free_vars, env_ids)
+       <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
+    let env_ty = mkBigCoreVarTupTy env_ids
+    let env_stk_ty = mkCorePairTy env_ty unitTy
+    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
+    fail_expr <- mkFailExpr ProcExpr env_stk_ty
+    var <- selectSimpleMatchVarL pat
+    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
+    let pat_ty = hsLPatType pat
+    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
+                    (Lam var match_code)
+                    core_cmd
+    return (mkLets meth_binds proc_code)
+dsProcExpr _ _ = panic "dsProcExpr"
+
+{-
+Translation of a command judgement of the form
+
+        D; xs |-a c : stk --> t
+
+to an expression e such that
+
+        D |- e :: a (xs, stk) t
+-}
+
+dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
+       -> DsM (CoreExpr, DIdSet)
+dsLCmd ids local_vars stk_ty res_ty cmd env_ids
+  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
+
+dsCmd   :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> HsCmd GhcTc           -- command to desugar
+        -> [Id]           -- list of vars in the input to this command
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+-- D |- fun :: a t1 t2
+-- D, xs |- arg :: t1
+-- -----------------------------
+-- D; xs |-a fun -< arg : stk --> t2
+--
+--              ---> premap (\ ((xs), _stk) -> arg) fun
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
+        env_ids = do
+    let
+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+    core_arrow <- dsLExprNoLP arrow
+    core_arg   <- dsLExpr arg
+    stack_id   <- newSysLocalDs stack_ty
+    core_make_arg <- matchEnvStack env_ids stack_id core_arg
+    return (do_premap ids
+              (envStackType env_ids stack_ty)
+              arg_ty
+              res_ty
+              core_make_arg
+              core_arrow,
+            exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)
+
+-- D, xs |- fun :: a t1 t2
+-- D, xs |- arg :: t1
+-- ------------------------------
+-- D; xs |-a fun -<< arg : stk --> t2
+--
+--              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
+        env_ids = do
+    let
+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+
+    core_arrow <- dsLExpr arrow
+    core_arg   <- dsLExpr arg
+    stack_id   <- newSysLocalDs stack_ty
+    core_make_pair <- matchEnvStack env_ids stack_id
+          (mkCorePairExpr core_arrow core_arg)
+
+    return (do_premap ids
+              (envStackType env_ids stack_ty)
+              (mkCorePairTy arrow_ty arg_ty)
+              res_ty
+              core_make_pair
+              (do_app ids arg_ty res_ty),
+            (exprsFreeIdsDSet [core_arrow, core_arg])
+              `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys |-a cmd : (t,stk) --> t'
+-- D, xs |-  exp :: t
+-- ------------------------
+-- D; xs |-a cmd exp : stk --> t'
+--
+--              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
+    core_arg <- dsLExpr arg
+    let
+        arg_ty = exprType core_arg
+        stack_ty' = mkCorePairTy arg_ty stack_ty
+    (core_cmd, free_vars, env_ids')
+             <- dsfixCmd ids local_vars stack_ty' res_ty cmd
+    stack_id <- newSysLocalDs stack_ty
+    arg_id <- newSysLocalDsNoLP arg_ty
+    -- push the argument expression onto the stack
+    let
+        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
+        core_body = bindNonRec arg_id core_arg
+                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
+
+    -- match the environment and stack against the input
+    core_map <- matchEnvStack env_ids stack_id core_body
+    return (do_premap ids
+                      (envStackType env_ids stack_ty)
+                      (envStackType env_ids' stack_ty')
+                      res_ty
+                      core_map
+                      core_cmd,
+            free_vars `unionDVarSet`
+              (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))
+
+-- D; ys |-a cmd : stk t'
+-- -----------------------------------------------
+-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
+--
+--              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdLam _ (MG { mg_alts
+          = (dL->L _ [dL->L _ (Match { m_pats  = pats
+                       , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) }))
+        env_ids = do
+    let pat_vars = mkVarSet (collectPatsBinders pats)
+    let
+        local_vars' = pat_vars `unionVarSet` local_vars
+        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
+    (core_body, free_vars, env_ids')
+       <- dsfixCmd ids local_vars' stack_ty' res_ty body
+    param_ids <- mapM newSysLocalDsNoLP pat_tys
+    stack_id' <- newSysLocalDs stack_ty'
+
+    -- the expression is built from the inside out, so the actions
+    -- are presented in reverse order
+
+    let
+        -- build a new environment, plus what's left of the stack
+        core_expr = buildEnvStack env_ids' stack_id'
+        in_ty = envStackType env_ids stack_ty
+        in_ty' = envStackType env_ids' stack_ty'
+
+    fail_expr <- mkFailExpr LambdaExpr in_ty'
+    -- match the patterns against the parameters
+    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr
+                    fail_expr
+    -- match the parameters against the top of the old stack
+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
+    -- match the old environment and stack against the input
+    select_code <- matchEnvStack env_ids stack_id param_code
+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,
+            free_vars `uniqDSetMinusUniqSet` pat_vars)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
+  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
+
+-- D, xs |- e :: Bool
+-- D; xs1 |-a c1 : stk --> t
+-- D; xs2 |-a c2 : stk --> t
+-- ----------------------------------------
+-- D; xs |-a if e then c1 else c2 : stk --> t
+--
+--              ---> premap (\ ((xs),stk) ->
+--                       if e then Left ((xs1),stk) else Right ((xs2),stk))
+--                     (c1 ||| c2)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
+        env_ids = do
+    core_cond <- dsLExpr cond
+    (core_then, fvs_then, then_ids)
+       <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
+    (core_else, fvs_else, else_ids)
+       <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
+    stack_id   <- newSysLocalDs stack_ty
+    either_con <- dsLookupTyCon eitherTyConName
+    left_con   <- dsLookupDataCon leftDataConName
+    right_con  <- dsLookupDataCon rightDataConName
+
+    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1,Type ty2, e]
+        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]
+
+        in_ty = envStackType env_ids stack_ty
+        then_ty = envStackType then_ids stack_ty
+        else_ty = envStackType else_ids stack_ty
+        sum_ty = mkTyConApp either_con [then_ty, else_ty]
+        fvs_cond = exprFreeIdsDSet core_cond
+                   `uniqDSetIntersectUniqSet` local_vars
+
+        core_left  = mk_left_expr  then_ty else_ty
+                       (buildEnvStack then_ids stack_id)
+        core_right = mk_right_expr then_ty else_ty
+                       (buildEnvStack else_ids stack_id)
+
+    core_if <- case mb_fun of
+       Just fun -> do { fun_apps <- dsSyntaxExpr fun
+                                      [core_cond, core_left, core_right]
+                      ; matchEnvStack env_ids stack_id fun_apps }
+       Nothing  -> matchEnvStack env_ids stack_id $
+                   mkIfThenElse core_cond core_left core_right
+
+    return (do_premap ids in_ty sum_ty res_ty
+                core_if
+                (do_choice ids then_ty else_ty res_ty core_then core_else),
+        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
+
+{-
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives.  For example
+
+        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+        premap (\ ((xs)*ts) -> case e of
+                p1 -> (Left (Left (xs1)*ts))
+                p2 -> Left ((Right (xs2)*ts))
+                p3 -> Right ((xs3)*ts))
+        ((c1 ||| c2) ||| c3)
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use triples describing segments of the list of
+case bodies, containing the following fields:
+ * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+   into the case replacing the commands
+ * a sum type that is the common type of these expressions, and also the
+   input type of the arrow
+ * a CoreExpr for an arrow built by combining the translated command
+   bodies with |||.
+-}
+
+dsCmd ids local_vars stack_ty res_ty
+      (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches)
+                           , mg_ext = MatchGroupTc arg_tys _
+                           , mg_origin = origin }))
+      env_ids = do
+    stack_id <- newSysLocalDs stack_ty
+
+    -- Extract and desugar the leaf commands in the case, building tuple
+    -- expressions that will (after tagging) replace these leaves
+
+    let
+        leaves = concatMap leavesMatch matches
+        make_branch (leaf, bound_vars) = do
+            (core_leaf, _fvs, leaf_ids)
+               <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
+                    res_ty leaf
+            return ([mkHsEnvStackExpr leaf_ids stack_id],
+                    envStackType leaf_ids stack_ty,
+                    core_leaf)
+
+    branches <- mapM make_branch leaves
+    either_con <- dsLookupTyCon eitherTyConName
+    left_con <- dsLookupDataCon leftDataConName
+    right_con <- dsLookupDataCon rightDataConName
+    let
+        left_id  = HsConLikeOut noExt (RealDataCon left_con)
+        right_id = HsConLikeOut noExt (RealDataCon right_con)
+        left_expr  ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+        right_expr ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+
+        -- Prefix each tuple with a distinct series of Left's and Right's,
+        -- in a balanced way, keeping track of the types.
+
+        merge_branches (builds1, in_ty1, core_exp1)
+                       (builds2, in_ty2, core_exp2)
+          = (map (left_expr in_ty1 in_ty2) builds1 ++
+                map (right_expr in_ty1 in_ty2) builds2,
+             mkTyConApp either_con [in_ty1, in_ty2],
+             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+        (leaves', sum_ty, core_choices) = foldb merge_branches branches
+
+        -- Replace the commands in the case with these tagged tuples,
+        -- yielding a HsExpr Id we can feed to dsExpr.
+
+        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+        in_ty = envStackType env_ids stack_ty
+
+    core_body <- dsExpr (HsCase noExt exp
+                         (MG { mg_alts = cL l matches'
+                             , mg_ext = MatchGroupTc arg_tys sum_ty
+                             , mg_origin = origin }))
+        -- Note that we replace the HsCase result type by sum_ty,
+        -- which is the type of matches'
+
+    core_matches <- matchEnvStack env_ids stack_id core_body
+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys |-a cmd : stk --> t
+-- ----------------------------------
+-- D; xs |-a let binds in cmd : stk --> t
+--
+--              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)
+                                                                    env_ids = do
+    let
+        defined_vars = mkVarSet (collectLocalBinders binds)
+        local_vars' = defined_vars `unionVarSet` local_vars
+
+    (core_body, _free_vars, env_ids')
+       <- dsfixCmd ids local_vars' stack_ty res_ty body
+    stack_id <- newSysLocalDs stack_ty
+    -- build a new environment, plus the stack, using the let bindings
+    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
+    -- match the old environment and stack against the input
+    core_map <- matchEnvStack env_ids stack_id core_binds
+    return (do_premap ids
+                        (envStackType env_ids stack_ty)
+                        (envStackType env_ids' stack_ty)
+                        res_ty
+                        core_map
+                        core_body,
+        exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; xs |-a ss : t
+-- ----------------------------------
+-- D; xs |-a do { ss } : () --> t
+--
+--              ---> premap (\ (env,stk) -> env) c
+
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
+                                               (dL->L loc stmts))
+                                                                   env_ids = do
+    putSrcSpanDs loc $
+      dsNoLevPoly stmts_ty
+        (text "In the do-command:" <+> ppr do_block)
+    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
+    let env_ty = mkBigCoreVarTupTy env_ids
+    core_fst <- mkFstExpr env_ty stack_ty
+    return (do_premap ids
+                (mkCorePairTy env_ty stack_ty)
+                env_ty
+                res_ty
+                core_fst
+                core_stmts,
+        env_ids')
+
+-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
+-- D; xs |-a ci :: stki --> ti
+-- -----------------------------------
+-- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
+
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
+    let env_ty = mkBigCoreVarTupTy env_ids
+    core_op <- dsLExpr op
+    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
+    return (mkApps (App core_op (Type env_ty)) core_args,
+            unionDVarSets fv_sets)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
+    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
+    core_wrap <- dsHsWrapper wrap
+    return (core_wrap core_cmd, env_ids')
+
+dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
+
+-- D; ys |-a c : stk --> t      (ys <= xs)
+-- ---------------------
+-- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c
+
+dsTrimCmdArg
+        :: IdSet                -- set of local vars available to this command
+        -> [Id]           -- list of vars in the input to this command
+        -> LHsCmdTop GhcTc       -- command argument to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+dsTrimCmdArg local_vars env_ids
+                       (dL->L _ (HsCmdTop
+                                 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
+    (meth_binds, meth_ids) <- mkCmdEnv ids
+    (core_cmd, free_vars, env_ids')
+       <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
+    stack_id <- newSysLocalDs stack_ty
+    trim_code
+      <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
+    let
+        in_ty = envStackType env_ids stack_ty
+        in_ty' = envStackType env_ids' stack_ty
+        arg_code = if env_ids' == env_ids then core_cmd else
+                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+    return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg"
+
+-- Given D; xs |-a c : stk --> t, builds c with xs fed back.
+-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
+
+dsfixCmd
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> LHsCmd GhcTc         -- command to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- the same local vars as a list, fed back
+dsfixCmd ids local_vars stk_ty cmd_ty cmd
+  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
+           (text "When desugaring the command:" <+> ppr cmd)
+       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
+
+-- Feed back the list of local variables actually used a command,
+-- for use as the input tuple of the generated arrow.
+
+trimInput
+        :: ([Id] -> DsM (CoreExpr, DIdSet))
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list, fed back to
+                                -- the inner function to form the tuple of
+                                -- inputs to the arrow.
+trimInput build_arrow
+  = fixDs (\ ~(_,_,env_ids) -> do
+        (core_cmd, free_vars) <- build_arrow env_ids
+        return (core_cmd, free_vars, dVarSetElems free_vars))
+
+{-
+Translation of command judgements of the form
+
+        D |-a do { ss } : t
+-}
+
+dsCmdDo :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> Type                 -- return type of the statement
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
+
+-- D; xs |-a c : () --> t
+-- --------------------------
+-- D; xs |-a do { c } : t
+--
+--              ---> premap (\ (xs) -> ((xs), ())) c
+
+dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do
+    putSrcSpanDs loc $ dsNoLevPoly res_ty
+                         (text "In the command:" <+> ppr body)
+    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
+    let env_ty = mkBigCoreVarTupTy env_ids
+    env_var <- newSysLocalDs env_ty
+    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
+    return (do_premap ids
+                        env_ty
+                        (mkCorePairTy env_ty unitTy)
+                        res_ty
+                        core_map
+                        core_body,
+        env_ids')
+
+dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)
+    let local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
+    return (do_compose ids
+                (mkBigCoreVarTupTy env_ids)
+                (mkBigCoreVarTupTy env_ids')
+                res_ty
+                core_stmt
+                core_stmts,
+              fv_stmt)
+
+{-
+A statement maps one local environment to another, and is represented
+as an arrow from one tuple type to another.  A statement sequence is
+translated to a composition of such arrows.
+-}
+
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
+           -> DsM (CoreExpr, DIdSet)
+dsCmdLStmt ids local_vars out_ids cmd env_ids
+  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
+
+dsCmdStmt
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- list of vars in the output of this statement
+        -> CmdStmt GhcTc        -- statement to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+-- D; xs1 |-a c : () --> t
+-- D; xs' |-a do { ss } : t'
+-- ------------------------------
+-- D; xs  |-a do { c; ss } : t'
+--
+--              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
+--                      (first c >>> arr snd) >>> ss
+
+dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
+    core_mux <- matchEnv env_ids
+        (mkCorePairExpr
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup out_ids))
+    let
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        out_ty = mkBigCoreVarTupTy out_ids
+        before_c_ty = mkCorePairTy in_ty1 out_ty
+        after_c_ty = mkCorePairTy c_ty out_ty
+    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
+    snd_fn <- mkSndExpr c_ty out_ty
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 c_ty out_ty core_cmd) $
+                do_arr ids after_c_ty out_ty snd_fn,
+              extendDVarSetList fv_cmd out_ids)
+
+-- D; xs1 |-a c : () --> t
+-- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
+-- -----------------------------------
+-- D; xs  |-a do { p <- c; ss } : t'
+--
+--              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
+--                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
+--
+-- It would be simpler and more consistent to do this using second,
+-- but that's likely to be defined in terms of first.
+
+dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
+    let pat_ty = hsLPatType pat
+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
+    let pat_vars = mkVarSet (collectPatBinders pat)
+    let
+        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
+        env_ty2 = mkBigCoreVarTupTy env_ids2
+
+    -- multiplexing function
+    --          \ (xs) -> (((xs1),()),(xs2))
+
+    core_mux <- matchEnv env_ids
+        (mkCorePairExpr
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup env_ids2))
+
+    -- projection function
+    --          \ (p, (xs2)) -> (zs)
+
+    env_id <- newSysLocalDs env_ty2
+    uniqs <- newUniqueSupply
+    let
+       after_c_ty = mkCorePairTy pat_ty env_ty2
+       out_ty = mkBigCoreVarTupTy out_ids
+       body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+
+    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
+    pat_id    <- selectSimpleMatchVarL pat
+    match_code
+      <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+    pair_id   <- newSysLocalDs after_c_ty
+    let
+        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+
+    -- put it all together
+    let
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        in_ty2 = mkBigCoreVarTupTy env_ids2
+        before_c_ty = mkCorePairTy in_ty1 in_ty2
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+                do_arr ids after_c_ty out_ty proj_expr,
+              fv_cmd `unionDVarSet` (mkDVarSet out_ids
+                                     `uniqDSetMinusUniqSet` pat_vars))
+
+-- D; xs' |-a do { ss } : t
+-- --------------------------------------
+-- D; xs  |-a do { let binds; ss } : t
+--
+--              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+
+dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
+    -- build a new environment using the let bindings
+    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
+    -- match the old environment against the input
+    core_map <- matchEnv env_ids core_binds
+    return (do_arr ids
+                        (mkBigCoreVarTupTy env_ids)
+                        (mkBigCoreVarTupTy out_ids)
+                        core_map,
+            exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
+-- D; xs' |-a do { ss' } : t
+-- ------------------------------------
+-- D; xs  |-a do { rec ss; ss' } : t
+--
+--                      xs1 = xs' /\ defs(ss)
+--                      xs2 = xs' - defs(ss)
+--                      ys1 = ys - defs(ss)
+--                      ys2 = ys /\ defs(ss)
+--
+--              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+--                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+--                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+
+dsCmdStmt ids local_vars out_ids
+        (RecStmt { recS_stmts = stmts
+                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
+                 , recS_ext = RecStmtTc { recS_later_rets = later_rets
+                                        , recS_rec_rets = rec_rets } })
+        env_ids = do
+    let
+        later_ids_set = mkVarSet later_ids
+        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
+        env2_id_set = mkDVarSet env2_ids
+        env2_ty = mkBigCoreVarTupTy env2_ids
+
+    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+    uniqs <- newUniqueSupply
+    env2_id <- newSysLocalDs env2_ty
+    let
+        later_ty = mkBigCoreVarTupTy later_ids
+        post_pair_ty = mkCorePairTy later_ty env2_ty
+        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
+
+    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
+
+    --- loop (...)
+
+    (core_loop, env1_id_set, env1_ids)
+               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
+
+    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+    let
+        env1_ty = mkBigCoreVarTupTy env1_ids
+        pre_pair_ty = mkCorePairTy env1_ty env2_ty
+        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
+                                        (mkBigCoreVarTup env2_ids)
+
+    pre_loop_fn <- matchEnv env_ids pre_loop_body
+
+    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+    let
+        env_ty = mkBigCoreVarTupTy env_ids
+        out_ty = mkBigCoreVarTupTy out_ids
+        core_body = do_premap ids env_ty pre_pair_ty out_ty
+                pre_loop_fn
+                (do_compose ids pre_pair_ty post_pair_ty out_ty
+                        (do_first ids env1_ty later_ty env2_ty
+                                core_loop)
+                        (do_arr ids post_pair_ty out_ty
+                                post_loop_fn))
+
+    return (core_body, env1_id_set `unionDVarSet` env2_id_set)
+
+dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
+
+--      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
+--            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
+
+dsRecCmd
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd
+        -> [Id]                 -- list of vars defined here and used later
+        -> [HsExpr GhcTc]       -- expressions corresponding to later_ids
+        -> [Id]                 -- list of vars fed back through the loop
+        -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids
+        -> DsM (CoreExpr,       -- desugared statement
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
+
+dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
+    let
+        later_id_set = mkVarSet later_ids
+        rec_id_set = mkVarSet rec_ids
+        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
+
+    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
+
+    core_later_rets <- mapM dsExpr later_rets
+    core_rec_rets <- mapM dsExpr rec_rets
+    let
+        -- possibly polymorphic version of vars of later_ids and rec_ids
+        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
+        out_ty = mkBigCoreVarTupTy out_ids
+
+        later_tuple = mkBigCoreTup core_later_rets
+        later_ty = mkBigCoreVarTupTy later_ids
+
+        rec_tuple = mkBigCoreTup core_rec_rets
+        rec_ty = mkBigCoreVarTupTy rec_ids
+
+        out_pair = mkCorePairExpr later_tuple rec_tuple
+        out_pair_ty = mkCorePairTy later_ty rec_ty
+
+    mk_pair_fn <- matchEnv out_ids out_pair
+
+    -- ss
+
+    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
+
+    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
+
+    rec_id <- newSysLocalDs rec_ty
+    let
+        env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
+        env1_ids = dVarSetElems env1_id_set
+        env1_ty = mkBigCoreVarTupTy env1_ids
+        in_pair_ty = mkCorePairTy env1_ty rec_ty
+        core_body = mkBigCoreTup (map selectVar env_ids)
+          where
+            selectVar v
+                | v `elemVarSet` rec_id_set
+                  = mkTupleSelector rec_ids v rec_id (Var rec_id)
+                | otherwise = Var v
+
+    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
+
+    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
+
+    let
+        env_ty = mkBigCoreVarTupTy env_ids
+        core_loop = do_loop ids env1_ty later_ty rec_ty
+                (do_premap ids in_pair_ty env_ty out_pair_ty
+                        squash_pair_fn
+                        (do_compose ids env_ty out_ty out_pair_ty
+                                core_stmts
+                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))
+
+    return (core_loop, env1_id_set, env1_ids)
+
+{-
+A sequence of statements (as in a rec) is desugared to an arrow between
+two environments (no stack)
+-}
+
+dsfixCmdStmts
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
+
+dsfixCmdStmts ids local_vars out_ids stmts
+  = trimInput (dsCmdStmts ids local_vars out_ids stmts)
+   -- TODO: Add levity polymorphism check for the resulting expression.
+   -- But I (Richard E.) don't know enough about arrows to do so.
+
+dsCmdStmts
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> [Id]                 -- list of vars in the input to these statements
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+dsCmdStmts ids local_vars out_ids [stmt] env_ids
+  = dsCmdLStmt ids local_vars out_ids stmt env_ids
+
+dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)
+    let local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
+    return (do_compose ids
+                (mkBigCoreVarTupTy env_ids)
+                (mkBigCoreVarTupTy env_ids')
+                (mkBigCoreVarTupTy out_ids)
+                core_stmt
+                core_stmts,
+              fv_stmt)
+
+dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
+
+-- Match a list of expressions against a list of patterns, left-to-right.
+
+matchSimplys :: [CoreExpr]              -- Scrutinees
+             -> HsMatchContext Name     -- Match kind
+             -> [LPat GhcTc]            -- Patterns they should match
+             -> CoreExpr                -- Return this if they all match
+             -> CoreExpr                -- Return this if they don't
+             -> DsM CoreExpr
+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
+    match_code <- matchSimplys exps ctxt pats result_expr fail_expr
+    matchSimply exp ctxt pat match_code fail_expr
+matchSimplys _ _ _ _ _ = panic "matchSimplys"
+
+-- List of leaf expressions, with set of variables bound in each
+
+leavesMatch :: LMatch GhcTc (Located (body GhcTc))
+            -> [(Located (body GhcTc), IdSet)]
+leavesMatch (dL->L _ (Match { m_pats = pats
+                            , m_grhss = GRHSs _ grhss (dL->L _ binds) }))
+  = let
+        defined_vars = mkVarSet (collectPatsBinders pats)
+                        `unionVarSet`
+                       mkVarSet (collectLocalBinders binds)
+    in
+    [(body,
+      mkVarSet (collectLStmtsBinders stmts)
+        `unionVarSet` defined_vars)
+    | (dL->L _ (GRHS _ stmts body)) <- grhss]
+leavesMatch _ = panic "leavesMatch"
+
+-- Replace the leaf commands in a match
+
+replaceLeavesMatch
+        :: Type                                 -- new result type
+        -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
+        -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command
+        -> ([Located (body' GhcTc)],            -- remaining leaf expressions
+            LMatch GhcTc (Located (body' GhcTc))) -- updated match
+replaceLeavesMatch _res_ty leaves
+                        (dL->L loc
+                          match@(Match { m_grhss = GRHSs x grhss binds }))
+  = let
+        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+    in
+    (leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
+replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
+
+replaceLeavesGRHS
+        :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type
+        -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command
+        -> ([Located (body' GhcTc)],              -- remaining leaf expressions
+            LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS
+replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))
+  = (leaves, cL loc (GRHS x stmts leaf))
+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
+replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
+
+-- Balanced fold of a non-empty list.
+
+foldb :: (a -> a -> a) -> [a] -> a
+foldb _ [] = error "foldb of empty list"
+foldb _ [x] = x
+foldb f xs = foldb f (fold_pairs xs)
+  where
+    fold_pairs [] = []
+    fold_pairs [x] = [x]
+    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+
+{-
+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The following functions to collect value variables from patterns are
+copied from HsUtils, with one change: we also collect the dictionary
+bindings (pat_binds) from ConPatOut.  We need them for cases like
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+                GT -> returnA -< z+x
+
+The type checker turns the case into
+
+                case compare x y of
+                  GT { p77 = plusInt } -> returnA -< p77 z x
+
+Here p77 is a local binding for the (+) operation.
+
+See comments in HsUtils for why the other version does not include
+these bindings.
+-}
+
+collectPatBinders :: LPat GhcTc -> [Id]
+collectPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat GhcTc] -> [Id]
+collectPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl :: LPat GhcTc -> [Id] -> [Id]
+-- See Note [Dictionary binders in ConPatOut]
+collectl (dL->L _ pat) bndrs
+  = go pat
+  where
+    go (VarPat _ (dL->L _ var))   = var : bndrs
+    go (WildPat _)                = bndrs
+    go (LazyPat _ pat)            = collectl pat bndrs
+    go (BangPat _ pat)            = collectl pat bndrs
+    go (AsPat _ (dL->L _ a) pat)  = a : collectl pat bndrs
+    go (ParPat _ pat)             = collectl pat bndrs
+
+    go (ListPat _ pats)           = foldr collectl bndrs pats
+    go (TuplePat _ pats _)        = foldr collectl bndrs pats
+    go (SumPat _ pat _ _)         = collectl pat bndrs
+
+    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps, pat_binds=ds}) =
+                                    collectEvBinders ds
+                                    ++ foldr collectl bndrs (hsConPatArgs ps)
+    go (LitPat _ _)               = bndrs
+    go (NPat {})                  = bndrs
+    go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs
+
+    go (SigPat _ pat _)           = collectl pat bndrs
+    go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
+    go (ViewPat _ _ pat)          = collectl pat bndrs
+    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
+    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
+
+collectEvBinders :: TcEvBinds -> [Id]
+collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
+
+add_ev_bndr :: EvBind -> [Id] -> [Id]
+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs
+                                       | otherwise = bs
+  -- A worry: what about coercion variable binders??
+
+collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+
+collectLStmtBinders :: LStmt GhcTc body -> [Id]
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt GhcTc body -> [Id]
+collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
+collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsBinds.hs
@@ -0,0 +1,1324 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching bindings (HsBinds and MonoBinds)
+
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
+                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   DsExpr( dsLExpr )
+import {-# SOURCE #-}   Match( matchWrapper )
+
+import DsMonad
+import DsGRHSs
+import DsUtils
+import Check ( checkGuardMatches )
+
+import HsSyn            -- lots of things
+import CoreSyn          -- lots of things
+import CoreOpt          ( simpleOptExpr )
+import OccurAnal        ( occurAnalyseExpr )
+import MkCore
+import CoreUtils
+import CoreArity ( etaExpand )
+import CoreUnfold
+import CoreFVs
+import Digraph
+
+import PrelNames
+import TyCon
+import TcEvidence
+import TcType
+import Type
+import Coercion
+import TysWiredIn ( typeNatKind, typeSymbolKind )
+import Id
+import MkId(proxyHashId)
+import Name
+import VarSet
+import Rules
+import VarEnv
+import Var( EvVar )
+import Outputable
+import Module
+import SrcLoc
+import Maybes
+import OrdList
+import Bag
+import BasicTypes
+import DynFlags
+import FastString
+import Util
+import UniqSet( nonDetEltsUniqSet )
+import MonadUtils
+import qualified GHC.LanguageExtensions as LangExt
+import Control.Monad
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring a MonoBinds
+*                                                                      *
+**********************************************************************-}
+
+-- | Desugar top level binds, strict binds are treated like normal
+-- binds since there is no good time to force before first usage.
+dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds binds
+     -- see Note [Strict binds checks]
+  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
+  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
+       ; mapBagM_ (top_level_err "strict bindings")             bang_binds
+       ; return nilOL }
+
+  | otherwise
+  = do { (force_vars, prs) <- dsLHsBinds binds
+       ; when debugIsOn $
+         do { xstrict <- xoptM LangExt.Strict
+            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
+              -- with -XStrict, even top-level vars are listed as force vars.
+
+       ; return (toOL prs) }
+
+  where
+    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
+    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
+
+    top_level_err desc (dL->L loc bind)
+      = putSrcSpanDs loc $
+        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
+                  2 (ppr bind))
+
+
+-- | Desugar all other kind of bindings, Ids of strict binds are returned to
+-- later be forced in the binding group body, see Note [Desugar Strict binds]
+dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBinds binds
+  = do { ds_bs <- mapBagM dsLHsBind binds
+       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
+                         id ([], []) ds_bs) }
+
+------------------------
+dsLHsBind :: LHsBind GhcTc
+          -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
+                                putSrcSpanDs loc $ dsHsBind dflags bind
+
+-- | Desugar a single binding (or group of recursive binds).
+dsHsBind :: DynFlags
+         -> HsBind GhcTc
+         -> DsM ([Id], [(Id,CoreExpr)])
+         -- ^ The Ids of strict binds, to be forced in the body of the
+         -- binding group see Note [Desugar Strict binds] and all
+         -- bindings and their desugared right hand sides.
+
+dsHsBind dflags (VarBind { var_id = var
+                         , var_rhs = expr
+                         , var_inline = inline_regardless })
+  = do  { core_expr <- dsLExpr expr
+                -- Dictionary bindings are always VarBinds,
+                -- so we only need do this here
+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
+                   | otherwise         = var
+        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr
+              force_var = if xopt LangExt.Strict dflags
+                          then [id]
+                          else []
+        ; return (force_var, [core_bind]) }
+
+dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
+                           , fun_matches = matches
+                           , fun_co_fn = co_fn
+                           , fun_tick = tick })
+ = do   { (args, body) <- matchWrapper
+                           (mkPrefixFunRhs (noLoc $ idName fun))
+                           Nothing matches
+        ; core_wrap <- dsHsWrapper co_fn
+        ; let body' = mkOptTickBox tick body
+              rhs   = core_wrap (mkLams args body')
+              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
+              force_var
+                  -- Bindings are strict when -XStrict is enabled
+                | xopt LangExt.Strict dflags
+                , matchGroupArity matches == 0 -- no need to force lambdas
+                = [id]
+                | isBangedHsBind b
+                = [id]
+                | otherwise
+                = []
+        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
+          --                          , ppr (mg_alts matches)
+          --                          , ppr args, ppr core_binds]) $
+          return (force_var, [core_binds]) }
+
+dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
+                         , pat_ext = NPatBindTc _ ty
+                         , pat_ticks = (rhs_tick, var_ticks) })
+  = do  { body_expr <- dsGuarded grhss ty
+        ; checkGuardMatches PatBindGuards grhss
+        ; let body' = mkOptTickBox rhs_tick body_expr
+              pat'  = decideBangHood dflags pat
+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
+          -- We silently ignore inline pragmas; no makeCorePair
+          -- Not so cool, but really doesn't matter
+        ; let force_var' = if isBangedLPat pat'
+                           then [force_var]
+                           else []
+        ; return (force_var', sel_binds) }
+
+dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                          , abs_exports = exports
+                          , abs_ev_binds = ev_binds
+                          , abs_binds = binds, abs_sig = has_sig })
+  = do { ds_binds <- addDictsDs (listToBag dicts) $
+                     dsLHsBinds binds
+                         -- addDictsDs: push type constraints deeper
+                         --             for inner pattern match check
+                         -- See Check, Note [Type and Term Equality Propagation]
+
+       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
+
+       -- dsAbsBinds does the hard work
+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
+
+dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
+
+
+-----------------------
+dsAbsBinds :: DynFlags
+           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
+           -> [CoreBind]                -- Desugared evidence bindings
+           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
+           -> Bool                      -- Single binding with signature
+           -> DsM ([Id], [(Id,CoreExpr)])
+
+dsAbsBinds dflags tyvars dicts exports
+           ds_ev_binds (force_vars, bind_prs) has_sig
+
+    -- A very important common case: one exported variable
+    -- Non-recursive bindings come through this way
+    -- So do self-recursive bindings
+  | [export] <- exports
+  , ABE { abe_poly = global_id, abe_mono = local_id
+        , abe_wrap = wrap, abe_prags = prags } <- export
+  , Just force_vars' <- case force_vars of
+                           []                  -> Just []
+                           [v] | v == local_id -> Just [global_id]
+                           _                   -> Nothing
+       -- If there is a variable to force, it's just the
+       -- single variable we are binding here
+  = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
+
+       ; let rhs = core_wrap $
+                   mkLams tyvars $ mkLams dicts $
+                   mkCoreLets ds_ev_binds $
+                   body
+
+             body | has_sig
+                  , [(_, lrhs)] <- bind_prs
+                  = lrhs
+                  | otherwise
+                  = mkLetRec bind_prs (Var local_id)
+
+       ; (spec_binds, rules) <- dsSpecs rhs prags
+
+       ; let global_id' = addIdSpecialisations global_id rules
+             main_bind  = makeCorePair dflags global_id'
+                                       (isDefaultMethod prags)
+                                       (dictArity dicts) rhs
+
+       ; return (force_vars', main_bind : fromOL spec_binds) }
+
+    -- Another common case: no tyvars, no dicts
+    -- In this case we can have a much simpler desugaring
+  | null tyvars, null dicts
+
+  = do { let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local
+                          , abe_prags = prags })
+              = do { core_wrap <- dsHsWrapper wrap
+                   ; return (makeCorePair dflags global
+                                          (isDefaultMethod prags)
+                                          0 (core_wrap (Var local))) }
+             mk_bind (XABExport _) = panic "dsAbsBinds"
+       ; main_binds <- mapM mk_bind exports
+
+       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
+
+    -- The general case
+    -- See Note [Desugaring AbsBinds]
+  | otherwise
+  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
+                              | (lcl_id, rhs) <- bind_prs ]
+                -- Monomorphic recursion possible, hence Rec
+             new_force_vars = get_new_force_vars force_vars
+             locals       = map abe_mono exports
+             all_locals   = locals ++ new_force_vars
+             tup_expr     = mkBigCoreVarTup all_locals
+             tup_ty       = exprType tup_expr
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_ev_binds $
+                            mkLet core_bind $
+                            tup_expr
+
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+
+        -- Find corresponding global or make up a new one: sometimes
+        -- we need to make new export to desugar strict binds, see
+        -- Note [Desugar Strict binds]
+       ; (exported_force_vars, extra_exports) <- get_exports force_vars
+
+       ; let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local, abe_prags = spec_prags })
+                          -- See Note [AbsBinds wrappers] in HsBinds
+                = do { tup_id  <- newSysLocalDs tup_ty
+                     ; core_wrap <- dsHsWrapper wrap
+                     ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
+                                 mkTupleSelector all_locals local tup_id $
+                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
+                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+                     ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                             `addIdSpecialisations` rules
+                           -- Kill the INLINE pragma because it applies to
+                           -- the user written (local) function.  The global
+                           -- Id is just the selector.  Hmm.
+                     ; return ((global', rhs) : fromOL spec_binds) }
+             mk_bind (XABExport _) = panic "dsAbsBinds"
+
+       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
+
+       ; return ( exported_force_vars
+                , (poly_tup_id, poly_tup_rhs) :
+                   concat export_binds_s) }
+  where
+    inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
+                             -- the inline pragma from the source
+                             -- The type checker put the inline pragma
+                             -- on the *global* Id, so we need to transfer it
+    inline_env
+      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
+                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
+                 , let prag = idInlinePragma gbl_id ]
+
+    add_inline :: Id -> Id    -- tran
+    add_inline lcl_id = lookupVarEnv inline_env lcl_id
+                        `orElse` lcl_id
+
+    global_env :: IdEnv Id -- Maps local Id to its global exported Id
+    global_env =
+      mkVarEnv [ (local, global)
+               | ABE { abe_mono = local, abe_poly = global } <- exports
+               ]
+
+    -- find variables that are not exported
+    get_new_force_vars lcls =
+      foldr (\lcl acc -> case lookupVarEnv global_env lcl of
+                           Just _ -> acc
+                           Nothing -> lcl:acc)
+            [] lcls
+
+    -- find exports or make up new exports for force variables
+    get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
+    get_exports lcls =
+      foldM (\(glbls, exports) lcl ->
+              case lookupVarEnv global_env lcl of
+                Just glbl -> return (glbl:glbls, exports)
+                Nothing   -> do export <- mk_export lcl
+                                let glbl = abe_poly export
+                                return (glbl:glbls, export:exports))
+            ([],[]) lcls
+
+    mk_export local =
+      do global <- newSysLocalDs
+                     (exprType (mkLams tyvars (mkLams dicts (Var local))))
+         return (ABE { abe_ext   = noExt
+                     , abe_poly  = global
+                     , abe_mono  = local
+                     , abe_wrap  = WpHole
+                     , abe_prags = SpecPrags [] })
+
+-- | This is where we apply INLINE and INLINABLE pragmas. All we need to
+-- do is to attach the unfolding information to the Id.
+--
+-- Other decisions about whether to inline are made in
+-- `calcUnfoldingGuidance` but the decision about whether to then expose
+-- the unfolding in the interface file is made in `TidyPgm.addExternal`
+-- using this information.
+------------------------
+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
+             -> (Id, CoreExpr)
+makeCorePair dflags gbl_id is_default_method dict_arity rhs
+  | is_default_method    -- Default methods are *always* inlined
+                         -- See Note [INLINE and default methods] in TcInstDcls
+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+
+  | otherwise
+  = case inlinePragmaSpec inline_prag of
+          NoUserInline -> (gbl_id, rhs)
+          NoInline     -> (gbl_id, rhs)
+          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline       -> inline_pair
+
+  where
+    inline_prag   = idInlinePragma gbl_id
+    inlinable_unf = mkInlinableUnfolding dflags rhs
+    inline_pair
+       | Just arity <- inlinePragmaSat inline_prag
+        -- Add an Unfolding for an INLINE (but not for NOINLINE)
+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+       , let real_arity = dict_arity + arity
+        -- NB: The arity in the InlineRule takes account of the dictionaries
+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
+         , etaExpand real_arity rhs)
+
+       | otherwise
+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
+         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+
+{-
+Note [Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the general AbsBinds case we desugar the binding to this:
+
+       tup a (d:Num a) = let fm = ...gm...
+                             gm = ...fm...
+                         in (fm,gm)
+       f a d = case tup a d of { (fm,gm) -> fm }
+       g a d = case tup a d of { (fm,gm) -> fm }
+
+Note [Rules and inlining]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Common special case: no type or dictionary abstraction
+This is a bit less trivial than you might suppose
+The naive way would be to desugar to something like
+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
+        M.f = f_lcl             -- Generated from "exports"
+But we don't want that, because if M.f isn't exported,
+it'll be inlined unconditionally at every call site (its rhs is
+trivial).  That would be ok unless it has RULES, which would
+thereby be completely lost.  Bad, bad, bad.
+
+Instead we want to generate
+        M.f = ...f_lcl...
+        f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore),
+and f_lcl is rapidly inlined away.
+
+This does not happen in the same way to polymorphic binds,
+because they desugar to
+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+Although I'm a bit worried about whether full laziness might
+float the f_lcl binding out and then inline M.f at its call site
+
+Note [Specialising in no-dict case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if there are no tyvars or dicts, we may have specialisation pragmas.
+Class methods can generate
+      AbsBinds [] [] [( ... spec-prag]
+         { AbsBinds [tvs] [dicts] ...blah }
+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
+
+  class  (Real a, Fractional a) => RealFrac a  where
+    round :: (Integral b) => a -> b
+
+  instance  RealFrac Float  where
+    {-# SPECIALIZE round :: Float -> Int #-}
+
+The top-level AbsBinds for $cround has no tyvars or dicts (because the
+instance does not).  But the method is locally overloaded!
+
+Note [Abstracting over tyvars only]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When abstracting over type variable only (not dictionaries), we don't really need to
+built a tuple and select from it, as we do in the general case. Instead we can take
+
+        AbsBinds [a,b] [ ([a,b], fg, fl, _),
+                         ([b],   gg, gl, _) ]
+                { fl = e1
+                  gl = e2
+                   h = e3 }
+
+and desugar it to
+
+        fg = /\ab. let B in e1
+        gg = /\b. let a = () in let B in S(e2)
+        h  = /\ab. let B in e3
+
+where B is the *non-recursive* binding
+        fl = fg a b
+        gl = gg b
+        h  = h a b    -- See (b); note shadowing!
+
+Notice (a) g has a different number of type variables to f, so we must
+             use the mkArbitraryType thing to fill in the gaps.
+             We use a type-let to do that.
+
+         (b) The local variable h isn't in the exports, and rather than
+             clone a fresh copy we simply replace h by (h a b), where
+             the two h's have different types!  Shadowing happens here,
+             which looks confusing but works fine.
+
+         (c) The result is *still* quadratic-sized if there are a lot of
+             small bindings.  So if there are more than some small
+             number (10), we filter the binding set B by the free
+             variables of the particular RHS.  Tiresome.
+
+Why got to this trouble?  It's a common case, and it removes the
+quadratic-sized tuple desugaring.  Less clutter, hopefully faster
+compilation, especially in a case where there are a *lot* of
+bindings.
+
+
+Note [Eta-expanding INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   foo :: Eq a => a -> a
+   {-# INLINE foo #-}
+   foo x = ...
+
+If (foo d) ever gets floated out as a common sub-expression (which can
+happen as a result of method sharing), there's a danger that we never
+get to do the inlining, which is a Terribly Bad thing given that the
+user said "inline"!
+
+To avoid this we pre-emptively eta-expand the definition, so that foo
+has the arity with which it is declared in the source code.  In this
+example it has arity 2 (one for the Eq and one for x). Doing this
+should mean that (foo d) is a PAP and we don't share it.
+
+Note [Nested arities]
+~~~~~~~~~~~~~~~~~~~~~
+For reasons that are not entirely clear, method bindings come out looking like
+this:
+
+  AbsBinds [] [] [$cfromT <= [] fromT]
+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool
+    { AbsBinds [] [] [fromT <= [] fromT_1]
+        fromT :: T Bool -> Bool
+        { fromT_1 ((TBool b)) = not b } } }
+
+Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
+gotten from the binding for fromT_1.
+
+It might be better to have just one level of AbsBinds, but that requires more
+thought!
+
+
+Note [Desugar Strict binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma
+
+Desugaring strict variable bindings looks as follows (core below ==>)
+
+  let !x = rhs
+  in  body
+==>
+  let x = rhs
+  in x `seq` body -- seq the variable
+
+and if it is a pattern binding the desugaring looks like
+
+  let !pat = rhs
+  in body
+==>
+  let x = rhs -- bind the rhs to a new variable
+      pat = x
+  in x `seq` body -- seq the new variable
+
+if there is no variable in the pattern desugaring looks like
+
+  let False = rhs
+  in body
+==>
+  let x = case rhs of {False -> (); _ -> error "Match failed"}
+  in x `seq` body
+
+In order to force the Ids in the binding group they are passed around
+in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.
+
+Consider a recursive group like this
+
+  letrec
+     f : g = rhs[f,g]
+  in <body>
+
+Without `Strict`, we get a translation like this:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (fm,gm)
+
+  in let f = /\a. case t a of (fm,_) -> fm
+  in let g = /\a. case t a of (_,gm) -> gm
+  in <body>
+
+Here `tm` is the monomorphic binding for `rhs`.
+
+With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
+Alas, `tm` isn't in scope in the `in <body>` part.
+
+The simplest thing is to return it in the polymorphic
+tuple `t`, thus:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (tm, fm, gm)
+
+  in let f = /\a. case t a of (_,fm,_) -> fm
+  in let g = /\a. case t a of (_,_,gm) -> gm
+  in let tm = /\a. case t a of (tm,_,_) -> tm
+  in tm `seq` <body>
+
+
+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more
+detailed explanation of the desugaring of strict bindings.
+
+Note [Strict binds checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several checks around properly formed strict bindings. They
+all link to this Note. These checks must be here in the desugarer because
+we cannot know whether or not a type is unlifted until after zonking, due
+to levity polymorphism. These checks all used to be handled in the typechecker
+in checkStrictBinds (before Jan '17).
+
+We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
+
+  x :: Char
+  (# True, x #) = blah
+
+is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.
+
+Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.
+Define a "strict bind" to be either an unlifted bind or a banged bind.
+
+The restrictions are:
+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
+
+  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
+     surprised by the strictness of an unlifted bind.) Checked in first clause
+     of DsExpr.ds_val_bind.
+
+  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
+     variables or constraints.) Checked in first clause
+     of DsExpr.ds_val_bind.
+
+  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
+
+-}
+
+------------------------
+dsSpecs :: CoreExpr     -- Its rhs
+        -> TcSpecPrags
+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
+               , [CoreRule] )           -- Rules for the Global Ids
+-- See Note [Handling SPECIALISE pragmas] in TcBinds
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+       ; let (spec_binds_s, rules) = unzip pairs
+       ; return (concatOL spec_binds_s, rules) }
+
+dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
+                                -- Nothing => RULE is for an imported Id
+                                --            rhs is in the Id's unfolding
+       -> Located TcSpecPrag
+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
+  | isJust (isClassOpId_maybe poly_id)
+  = putSrcSpanDs loc $
+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
+                          <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- There is no point in trying to specialise a class op
+                            -- Moreover, classops don't (currently) have an inl_sat arity set
+                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+  | no_act_spec && isNeverActive rule_act
+  = putSrcSpanDs loc $
+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
+                          <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
+                            -- See Note [Activation pragmas for SPECIALISE]
+
+  | otherwise
+  = putSrcSpanDs loc $
+    do { uniq <- newUnique
+       ; let poly_name = idName poly_id
+             spec_occ  = mkSpecOcc (getOccName poly_name)
+             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
+               -- spec_co looks like
+               --         \spec_bndrs. [] spec_args
+               -- perhaps with the body of the lambda wrapped in some WpLets
+               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
+
+       ; core_app <- dsHsWrapper spec_app
+
+       ; let ds_lhs  = core_app (Var poly_id)
+             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
+       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
+         --                         , text "spec_co:" <+> ppr spec_co
+         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
+         dflags <- getDynFlags
+       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
+           Left msg -> do { warnDs NoReason msg; return Nothing } ;
+           Right (rule_bndrs, _fn, args) -> do
+
+       { this_mod <- getModule
+       ; let fn_unf    = realIdUnfolding poly_id
+             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
+             spec_id   = mkLocalId spec_name spec_ty
+                            `setInlinePragma` inl_prag
+                            `setIdUnfolding`  spec_unf
+             arity_decrease = count isValArg args - count isId spec_bndrs
+
+       ; rule <- dsMkUserRule this_mod is_local_id
+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
+                        rule_act poly_name
+                        rule_bndrs args
+                        (mkVarApps (Var spec_id) spec_bndrs)
+
+       ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
+
+-- Commented out: see Note [SPECIALISE on INLINE functions]
+--       ; when (isInlinePragma id_inl)
+--              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
+--                        <+> quotes (ppr poly_name))
+
+       ; return (Just (unitOL (spec_id, spec_rhs), rule))
+            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
+            --     makeCorePair overwrites the unfolding, which we have
+            --     just created using specUnfolding
+       } } }
+  where
+    is_local_id = isJust mb_poly_rhs
+    poly_rhs | Just rhs <-  mb_poly_rhs
+             = rhs          -- Local Id; this is its rhs
+             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+             = unfolding    -- Imported Id; this is its unfolding
+                            -- Use realIdUnfolding so we get the unfolding
+                            -- even when it is a loop breaker.
+                            -- We want to specialise recursive functions!
+             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+                            -- The type checker has checked that it *has* an unfolding
+
+    id_inl = idInlinePragma poly_id
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
+             | not is_local_id  -- See Note [Specialising imported functions]
+                                 -- in OccurAnal
+             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+             | otherwise                               = id_inl
+     -- Get the INLINE pragma from SPECIALISE declaration, or,
+     -- failing that, from the original Id
+
+    spec_prag_act = inlinePragmaActivation spec_inl
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    -- no_act_spec is True if the user didn't write an explicit
+    -- phase specification in the SPECIALISE pragma
+    no_act_spec = case inlinePragmaSpec spec_inl of
+                    NoInline -> isNeverActive  spec_prag_act
+                    _        -> isAlwaysActive spec_prag_act
+    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
+             | otherwise   = spec_prag_act                   -- Specified by user
+
+
+dsMkUserRule :: Module -> Bool -> RuleName -> Activation
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
+    let rule = mkRule this_mod False is_local name act fn bndrs args rhs
+    dflags <- getDynFlags
+    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
+        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
+    return rule
+
+ruleOrphWarn :: CoreRule -> SDoc
+ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule
+
+{- Note [SPECIALISE on INLINE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to warn that using SPECIALISE for a function marked INLINE
+would be a no-op; but it isn't!  Especially with worker/wrapper split
+we might have
+   {-# INLINE f #-}
+   f :: Ord a => Int -> a -> ...
+   f d x y = case x of I# x' -> $wf d x' y
+
+We might want to specialise 'f' so that we in turn specialise '$wf'.
+We can't even /name/ '$wf' in the source code, so we can't specialise
+it even if we wanted to.  #10721 is a case in point.
+
+Note [Activation pragmas for SPECIALISE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From a user SPECIALISE pragma for f, we generate
+  a) A top-level binding    spec_fn = rhs
+  b) A RULE                 f dOrd = spec_fn
+
+We need two pragma-like things:
+
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
+                           activation on SPEC), unless overriden by SPEC INLINE
+
+* Activation of RULE: from SPECIALISE pragma (if activation given)
+                      otherwise from f's inline pragma
+
+This is not obvious (see #5237)!
+
+Examples      Rule activation   Inline prag on spec'd fn
+---------------------------------------------------------------------
+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
+                                  copy f's prag
+
+NOINLINE f
+SPEC [n] f :: ty            [n]   NOINLINE
+                                  copy f's prag
+
+NOINLINE [k] f
+SPEC [n] f :: ty            [n]   NOINLINE [k]
+                                  copy f's prag
+
+INLINE [k] f
+SPEC [n] f :: ty            [n]   INLINE [k]
+                                  copy f's prag
+
+SPEC INLINE [n] f :: ty     [n]   INLINE [n]
+                                  (ignore INLINE prag on f,
+                                  same activation for rule and spec'd fn)
+
+NOINLINE [k] f
+SPEC f :: ty                [n]   INLINE [k]
+
+
+************************************************************************
+*                                                                      *
+\subsection{Adding inline pragmas}
+*                                                                      *
+************************************************************************
+-}
+
+decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
+                 -> Either SDoc ([Var], Id, [CoreExpr])
+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
+-- may add some extra dictionary binders (see Note [Free dictionaries])
+--
+-- Returns an error message if the LHS isn't of the expected shape
+-- Note [Decomposing the left-hand side of a RULE]
+decomposeRuleLhs dflags orig_bndrs orig_lhs
+  | not (null unbound)    -- Check for things unbound on LHS
+                          -- See Note [Unused spec binders]
+  = Left (vcat (map dead_msg unbound))
+  | Var funId <- fun2
+  , Just con <- isDataConId_maybe funId
+  = Left (constructor_msg con) -- See Note [No RULES on datacons]
+  | Just (fn_id, args) <- decompose fun2 args2
+  , let extra_bndrs = mk_extra_bndrs fn_id args
+  = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+    --                                  , text "orig_lhs:" <+> ppr orig_lhs
+    --                                  , text "lhs1:"     <+> ppr lhs1
+    --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs
+    --                                  , text "fn_id:" <+> ppr fn_id
+    --                                  , text "args:"   <+> ppr args]) $
+    Right (orig_bndrs ++ extra_bndrs, fn_id, args)
+
+  | otherwise
+  = Left bad_shape_msg
+ where
+   lhs1         = drop_dicts orig_lhs
+   lhs2         = simpleOptExpr dflags lhs1  -- See Note [Simplify rule LHS]
+   (fun2,args2) = collectArgs lhs2
+
+   lhs_fvs    = exprFreeVars lhs2
+   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
+
+   orig_bndr_set = mkVarSet orig_bndrs
+
+        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
+        -- and extra dict binders: Note [Free dictionaries in rule LHS]
+   mk_extra_bndrs fn_id args
+     = scopedSort unbound_tvs ++ unbound_dicts
+     where
+       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]
+       unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)
+                       | d <- unbound_vars, isDictId d ]
+       unbound_vars  = [ v | v <- exprsFreeVarsList args
+                           , not (v `elemVarSet` orig_bndr_set)
+                           , not (v == fn_id) ]
+         -- fn_id: do not quantify over the function itself, which may
+         -- itself be a dictionary (in pathological cases, #10251)
+
+   decompose (Var fn_id) args
+      | not (fn_id `elemVarSet` orig_bndr_set)
+      = Just (fn_id, args)
+
+   decompose _ _ = Nothing
+
+   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")
+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
+                              , text "Orig lhs:" <+> ppr orig_lhs])
+   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr
+                             , text "is not bound in RULE lhs"])
+                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
+                              , text "Orig lhs:" <+> ppr orig_lhs
+                              , text "optimised lhs:" <+> ppr lhs2 ])
+   pp_bndr bndr
+    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)
+    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))
+    | otherwise    = text "variable"      <+> quotes (ppr bndr)
+
+   constructor_msg con = vcat
+     [ text "A constructor," <+> ppr con <>
+         text ", appears as outermost match in RULE lhs."
+     , text "This rule will be ignored." ]
+
+   drop_dicts :: CoreExpr -> CoreExpr
+   drop_dicts e
+       = wrap_lets needed bnds body
+     where
+       needed = orig_bndr_set `minusVarSet` exprFreeVars body
+       (bnds, body) = split_lets (occurAnalyseExpr e)
+           -- The occurAnalyseExpr drops dead bindings which is
+           -- crucial to ensure that every binding is used later;
+           -- which in turn makes wrap_lets work right
+
+   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
+   split_lets (Let (NonRec d r) body)
+     | isDictId d
+     = ((d,r):bs, body')
+     where (bs, body') = split_lets body
+
+    -- handle "unlifted lets" too, needed for "map/coerce"
+   split_lets (Case r d _ [(DEFAULT, _, body)])
+     | isCoVar d
+     = ((d,r):bs, body')
+     where (bs, body') = split_lets body
+
+   split_lets e = ([], e)
+
+   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
+   wrap_lets _ [] body = body
+   wrap_lets needed ((d, r) : bs) body
+     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
+     | otherwise                         = wrap_lets needed bs body
+     where
+       rhs_fvs = exprFreeVars r
+       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
+
+{-
+Note [Decomposing the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several things going on here.
+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
+* simpleOptExpr: see Note [Simplify rule LHS]
+* extra_dict_bndrs: see Note [Free dictionaries]
+
+Note [Free tyvars on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)), where alpha
+is an unbound meta-tyvar.  The zonker in TcHsSyn is careful not to
+turn the free alpha into Any (as it usually does).  Instead it turns it
+into a TyVar 'a'.  See TcHsSyn Note [Zonking the LHS of a RULE].
+
+Now we must quantify over that 'a'.  It's /really/ inconvenient to do that
+in the zonker, because the HsExpr data type is very large.  But it's /easy/
+to do it here in the desugarer.
+
+Moreover, we have to do something rather similar for dictionaries;
+see Note [Free dictionaries on rule LHS].   So that's why we look for
+type variables free on the LHS, and quantify over them.
+
+Note [Free dictionaries on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
+which is presumably in scope at the function definition site, we can quantify
+over it too.  *Any* dict with that type will do.
+
+So for example when you have
+        f :: Eq a => a -> a
+        f = <rhs>
+        ... SPECIALISE f :: Int -> Int ...
+
+Then we get the SpecPrag
+        SpecPrag (f Int dInt)
+
+And from that we want the rule
+
+        RULE forall dInt. f Int dInt = f_spec
+        f_spec = let f = <rhs> in f Int dInt
+
+But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
+Name, and you can't bind them in a lambda or forall without getting things
+confused.   Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.
+
+Note [Drop dictionary bindings on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+drop_dicts drops dictionary bindings on the LHS where possible.
+   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
+     --> f d
+   Reasoning here is that there is only one d:Eq [Int], and so we can
+   quantify over it. That makes 'd' free in the LHS, but that is later
+   picked up by extra_dict_bndrs (Note [Dead spec binders]).
+
+   NB 1: We can only drop the binding if the RHS doesn't bind
+         one of the orig_bndrs, which we assume occur on RHS.
+         Example
+            f :: (Eq a) => b -> a -> a
+            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
+         Here we want to end up with
+            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
+         Of course, the ($dfEqlist d) in the pattern makes it less likely
+         to match, but there is no other way to get d:Eq a
+
+   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+         the evidence bindings to be wrapped around the outside of the
+         LHS.  (After simplOptExpr they'll usually have been inlined.)
+         dsHsWrapper does dependency analysis, so that civilised ones
+         will be simple NonRec bindings.  We don't handle recursive
+         dictionaries!
+
+    NB3: In the common case of a non-overloaded, but perhaps-polymorphic
+         specialisation, we don't need to bind *any* dictionaries for use
+         in the RHS. For example (#8331)
+             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
+             useAbstractMonad :: MonadAbstractIOST m => m Int
+         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
+         but the RHS uses no dictionaries, so we want to end up with
+             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
+                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
+
+   #8848 is a good example of where there are some interesting
+   dictionary bindings to discard.
+
+The drop_dicts algorithm is based on these observations:
+
+  * Given (let d = rhs in e) where d is a DictId,
+    matching 'e' will bind e's free variables.
+
+  * So we want to keep the binding if one of the needed variables (for
+    which we need a binding) is in fv(rhs) but not already in fv(e).
+
+  * The "needed variables" are simply the orig_bndrs.  Consider
+       f :: (Eq a, Show b) => a -> b -> String
+       ... SPECIALISE f :: (Show b) => Int -> b -> String ...
+    Then orig_bndrs includes the *quantified* dictionaries of the type
+    namely (dsb::Show b), but not the one for Eq Int
+
+So we work inside out, applying the above criterion at each step.
+
+
+Note [Simplify rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+simplOptExpr occurrence-analyses and simplifies the LHS:
+
+   (a) Inline any remaining dictionary bindings (which hopefully
+       occur just once)
+
+   (b) Substitute trivial lets, so that they don't get in the way.
+       Note that we substitute the function too; we might
+       have this as a LHS:  let f71 = M.f Int in f71
+
+   (c) Do eta reduction.  To see why, consider the fold/build rule,
+       which without simplification looked like:
+          fold k z (build (/\a. g a))  ==>  ...
+       This doesn't match unless you do eta reduction on the build argument.
+       Similarly for a LHS like
+         augment g (build h)
+       we do not want to get
+         augment (\a. g a) (build h)
+       otherwise we don't match when given an argument like
+          augment (\a. h a a) (build h)
+
+Note [Matching seqId]
+~~~~~~~~~~~~~~~~~~~
+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
+and this code turns it back into an application of seq!
+See Note [Rules for seq] in MkId for the details.
+
+Note [Unused spec binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        f :: a -> a
+        ... SPECIALISE f :: Eq a => a -> a ...
+It's true that this *is* a more specialised type, but the rule
+we get is something like this:
+        f_spec d = f
+        RULE: f = f_spec d
+Note that the rule is bogus, because it mentions a 'd' that is
+not bound on the LHS!  But it's a silly specialisation anyway, because
+the constraint is unused.  We could bind 'd' to (error "unused")
+but it seems better to reject the program because it's almost certainly
+a mistake.  That's what the isDeadBinder call detects.
+
+Note [No RULES on datacons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Previously, `RULES` like
+
+    "JustNothing" forall x . Just x = Nothing
+
+were allowed. Simon Peyton Jones says this seems to have been a
+mistake, that such rules have never been supported intentionally,
+and that he doesn't know if they can break in horrible ways.
+Furthermore, Ben Gamari and Reid Barton are considering trying to
+detect the presence of "static data" that the simplifier doesn't
+need to traverse at all. Such rules do not play well with that.
+So for now, we ban them altogether as requested by #13290. See also #7398.
+
+
+************************************************************************
+*                                                                      *
+                Desugaring evidence
+*                                                                      *
+************************************************************************
+
+-}
+
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole            = return $ \e -> e
+dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)
+dsHsWrapper (WpEvLam ev)      = return $ Lam ev
+dsHsWrapper (WpTyLam tv)      = return $ Lam tv
+dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds
+                                   ; return (mkCoreLets bs) }
+dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
+                                   ; w2 <- dsHsWrapper c2
+                                   ; return (w1 . w2) }
+ -- See comments on WpFun in TcEvidence for an explanation of what
+ -- the specification of this clause is
+dsHsWrapper (WpFun c1 c2 t1 doc)
+                              = do { x  <- newSysLocalDsNoLP t1
+                                   ; w1 <- dsHsWrapper c1
+                                   ; w2 <- dsHsWrapper c2
+                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+                                         arg     = w1 (Var x)
+                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
+                                   ; if ok
+                                     then return (\e -> (Lam x (w2 (app e arg))))
+                                     else return id }  -- this return is irrelevant
+dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)
+                                return $ \e -> mkCastDs e co
+dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
+                                   ; return (\e -> App e core_tm) }
+
+--------------------------------------
+dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
+dsTcEvBinds_s []       = return []
+dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null
+                         dsTcEvBinds b
+
+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [CoreBind]
+dsEvBinds bs
+  = do { ds_bs <- mapBagM dsEvBind bs
+       ; return (mk_ev_binds ds_bs) }
+
+mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
+-- We do SCC analysis of the evidence bindings, /after/ desugaring
+-- them. This is convenient: it means we can use the CoreSyn
+-- free-variable functions rather than having to do accurate free vars
+-- for EvTerm.
+mk_ev_binds ds_binds
+  = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
+  where
+    edges :: [ Node EvVar (EvVar,CoreExpr) ]
+    edges = foldrBag ((:) . mk_node) [] ds_binds
+
+    mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
+    mk_node b@(var, rhs)
+      = DigraphNode { node_payload = b
+                    , node_key = var
+                    , node_dependencies = nonDetEltsUniqSet $
+                                          exprFreeVars rhs `unionVarSet`
+                                          coVarsOfType (varType var) }
+      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
+      -- is still deterministic even if the edges are in nondeterministic order
+      -- as explained in Note [Deterministic SCC] in Digraph.
+
+    ds_scc (AcyclicSCC (v,r)) = NonRec v r
+    ds_scc (CyclicSCC prs)    = Rec prs
+
+dsEvBind :: EvBind -> DsM (Id, CoreExpr)
+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
+
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvTerms
+*                                                                      *
+**********************************************************************-}
+
+dsEvTerm :: EvTerm -> DsM CoreExpr
+dsEvTerm (EvExpr e)          = return e
+dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev
+dsEvTerm (EvFun { et_tvs = tvs, et_given = given
+                , et_binds = ev_binds, et_body = wanted_id })
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; return $ (mkLams (tvs ++ given) $
+                   mkCoreLets ds_ev_binds $
+                   Var wanted_id) }
+
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring Typeable dictionaries
+*                                                                      *
+**********************************************************************-}
+
+dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Return a CoreExpr :: Typeable ty
+-- This code is tightly coupled to the representation
+-- of TypeRep, in base library Data.Typeable.Internals
+dsEvTypeable ty ev
+  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable
+       ; let kind = typeKind ty
+             Just typeable_data_con
+                 = tyConSingleDataCon_maybe tyCl    -- "Data constructor"
+                                                    -- for Typeable
+
+       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a
+
+       -- Package up the method as `Typeable` dictionary
+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }
+
+type TypeRepExpr = CoreExpr
+
+-- | Returns a @CoreExpr :: TypeRep ty@
+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
+ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
+  = do { mkTrCon <- dsLookupGlobalId mkTrConName
+                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
+       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
+       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
+                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
+
+       ; tc_rep <- tyConRep tc                      -- :: TyCon
+       ; let ks = tyConAppArgs ty
+             -- Construct a SomeTypeRep
+             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
+             toSomeTypeRep t ev = do
+                 rep <- getRep ev t
+                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
+       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t
+       ; let -- :: [SomeTypeRep]
+             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps
+
+         -- Note that we use the kind of the type, not the TyCon from which it
+         -- is constructed since the latter may be kind polymorphic whereas the
+         -- former we know is not (we checked in the solver).
+       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
+                                         , Type ty
+                                         , tc_rep
+                                         , kind_args ]
+       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
+       ; return expr
+       }
+
+ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
+  | Just (t1,t2) <- splitAppTy_maybe ty
+  = do { e1  <- getRep ev1 t1
+       ; e2  <- getRep ev2 t2
+       ; mkTrApp <- dsLookupGlobalId mkTrAppName
+                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+                    --            TypeRep a -> TypeRep b -> TypeRep (a b)
+       ; let (k1, k2) = splitFunTy (typeKind t1)
+       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
+                            [ e1, e2 ]
+       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
+       ; return expr
+       }
+
+ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
+  | Just (t1,t2) <- splitFunTy_maybe ty
+  = do { e1 <- getRep ev1 t1
+       ; e2 <- getRep ev2 t2
+       ; mkTrFun <- dsLookupGlobalId mkTrFunName
+                    -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).
+                    --            TypeRep a -> TypeRep b -> TypeRep (a -> b)
+       ; let r1 = getRuntimeRep t1
+             r2 = getRuntimeRep t2
+       ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])
+                         [ e1, e2 ]
+       }
+
+ds_ev_typeable ty (EvTypeableTyLit ev)
+  = -- See Note [Typeable for Nat and Symbol] in TcInteract
+    do { fun  <- dsLookupGlobalId tr_fun
+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
+       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
+  where
+    ty_kind = typeKind ty
+
+    -- tr_fun is the Name of
+    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep a
+    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
+    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName
+           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
+           | otherwise = panic "dsEvTypeable: unknown type lit kind"
+
+ds_ev_typeable ty ev
+  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
+
+getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@
+       -> Type            -- ^ The type @ty@
+       -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
+                          -- namely @typeRep# dict@
+-- Remember that
+--   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
+getRep ev ty
+  = do { typeable_expr <- dsEvTerm ev
+       ; typeRepId     <- dsLookupGlobalId typeRepIdName
+       ; let ty_args = [typeKind ty, ty]
+       ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }
+
+tyConRep :: TyCon -> DsM CoreExpr
+-- Returns CoreExpr :: TyCon
+tyConRep tc
+  | Just tc_rep_nm <- tyConRepName_maybe tc
+  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
+       ; return (Var tc_rep_id) }
+  | otherwise
+  = pprPanic "tyConRep" (ppr tc)
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsCCall.hs
@@ -0,0 +1,379 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+
+Desugaring foreign calls
+-}
+
+{-# LANGUAGE CPP #-}
+module DsCCall
+        ( dsCCall
+        , mkFCall
+        , unboxArg
+        , boxResult
+        , resultWrapper
+        ) where
+
+#include "HsVersions.h"
+
+
+import GhcPrelude
+
+import CoreSyn
+
+import DsMonad
+import CoreUtils
+import MkCore
+import MkId
+import ForeignCall
+import DataCon
+import DsUtils
+
+import TcType
+import Type
+import Id   ( Id )
+import Coercion
+import PrimOp
+import TysPrim
+import TyCon
+import TysWiredIn
+import BasicTypes
+import Literal
+import PrelNames
+import DynFlags
+import Outputable
+import Util
+
+import Data.Maybe
+
+{-
+Desugaring of @ccall@s consists of adding some state manipulation,
+unboxing any boxed primitive arguments and boxing the result if
+desired.
+
+The state stuff just consists of adding in
+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
+
+The unboxing is straightforward, as all information needed to unbox is
+available from the type.  For each boxed-primitive argument, we
+transform:
+\begin{verbatim}
+   _ccall_ foo [ r, t1, ... tm ] e1 ... em
+   |
+   |
+   V
+   case e1 of { T1# x1# ->
+   ...
+   case em of { Tm# xm# -> xm#
+   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
+   } ... }
+\end{verbatim}
+
+The reboxing of a @_ccall_@ result is a bit tricker: the types don't
+contain information about the state-pairing functions so we have to
+keep a list of \tr{(type, s-p-function)} pairs.  We transform as
+follows:
+\begin{verbatim}
+   ccall# foo [ r, t1#, ... tm# ] e1# ... em#
+   |
+   |
+   V
+   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
+          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+\end{verbatim}
+-}
+
+dsCCall :: CLabelString -- C routine to invoke
+        -> [CoreExpr]   -- Arguments (desugared)
+                        -- Precondition: none have levity-polymorphic types
+        -> Safety       -- Safety of the call
+        -> Type         -- Type of the result: IO t
+        -> DsM CoreExpr -- Result, of type ???
+
+dsCCall lbl args may_gc result_ty
+  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
+       (ccall_result_ty, res_wrapper) <- boxResult result_ty
+       uniq <- newUnique
+       dflags <- getDynFlags
+       let
+           target = StaticTarget NoSourceText lbl Nothing True
+           the_fcall    = CCall (CCallSpec target CCallConv may_gc)
+           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
+       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+
+mkFCall :: DynFlags -> Unique -> ForeignCall
+        -> [CoreExpr]     -- Args
+        -> Type           -- Result type
+        -> CoreExpr
+-- Construct the ccall.  The only tricky bit is that the ccall Id should have
+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
+--      [I forget *why* it should have no free vars!]
+-- For example:
+--      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
+--
+-- Here we build a ccall thus
+--      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
+--                      a b s x c
+mkFCall dflags uniq the_fcall val_args res_ty
+  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level
+    mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
+  where
+    arg_tys = map exprType val_args
+    body_ty = (mkVisFunTys arg_tys res_ty)
+    tyvars  = tyCoVarsOfTypeWellScoped body_ty
+    ty      = mkInvForAllTys tyvars body_ty
+    the_fcall_id = mkFCallId dflags uniq the_fcall ty
+
+unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic
+         -> DsM (CoreExpr,              -- To pass as the actual argument
+                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
+                )
+-- Example: if the arg is e::Int, unboxArg will return
+--      (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
+
+-- always returns a non-levity-polymorphic expression
+
+unboxArg arg
+  -- Primitive types: nothing to unbox
+  | isPrimitiveType arg_ty
+  = return (arg, \body -> body)
+
+  -- Recursive newtypes
+  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
+  = unboxArg (mkCastDs arg co)
+
+  -- Booleans
+  | Just tc <- tyConAppTyCon_maybe arg_ty,
+    tc `hasKey` boolTyConKey
+  = do dflags <- getDynFlags
+       prim_arg <- newSysLocalDs intPrimTy
+       return (Var prim_arg,
+              \ body -> Case (mkWildCase arg arg_ty intPrimTy
+                                       [(DataAlt falseDataCon,[],mkIntLit dflags 0),
+                                        (DataAlt trueDataCon, [],mkIntLit dflags 1)])
+                                        -- In increasing tag order!
+                             prim_arg
+                             (exprType body)
+                             [(DEFAULT,[],body)])
+
+  -- Data types with a single constructor, which has a single, primitive-typed arg
+  -- This deals with Int, Float etc; also Ptr, ForeignPtr
+  | is_product_type && data_con_arity == 1
+  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
+                        -- Typechecker ensures this
+    do case_bndr <- newSysLocalDs arg_ty
+       prim_arg <- newSysLocalDs data_con_arg_ty1
+       return (Var prim_arg,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+              )
+
+  -- Byte-arrays, both mutable and otherwise; hack warning
+  -- We're looking for values of type ByteArray, MutableByteArray
+  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
+  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+  | is_product_type &&
+    data_con_arity == 3 &&
+    isJust maybe_arg3_tycon &&
+    (arg3_tycon ==  byteArrayPrimTyCon ||
+     arg3_tycon ==  mutableByteArrayPrimTyCon)
+  = do case_bndr <- newSysLocalDs arg_ty
+       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+       return (Var arr_cts_var,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+              )
+
+  | otherwise
+  = do l <- getSrcSpanDs
+       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+  where
+    arg_ty                                      = exprType arg
+    maybe_product_type                          = splitDataProductType_maybe arg_ty
+    is_product_type                             = isJust maybe_product_type
+    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
+    data_con_arity                              = dataConSourceArity data_con
+    (data_con_arg_ty1 : _)                      = data_con_arg_tys
+
+    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
+    Just arg3_tycon                = maybe_arg3_tycon
+
+boxResult :: Type
+          -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+--      either (IO t),
+--      or maybe just t for a side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall.  This result type
+-- will be of the form
+--      State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t.  If t is simply (), then
+-- the result type will be
+--      State# RealWorld -> (# State# RealWorld #)
+
+boxResult result_ty
+  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
+        -- isIOType_maybe handles the case where the type is a
+        -- simple wrapping of IO.  E.g.
+        --      newtype Wrap a = W (IO a)
+        -- No coercion necessary because its a non-recursive newtype
+        -- (If we wanted to handle a *recursive* newtype too, we'd need
+        -- another case, and a coercion.)
+        -- The result is IO t, so wrap the result in an IO constructor
+  = do  { res <- resultWrapper io_res_ty
+        ; let extra_result_tys
+                = case res of
+                     (Just ty,_)
+                       | isUnboxedTupleType ty
+                       -> let Just ls = tyConAppArgs_maybe ty in tail ls
+                     _ -> []
+
+              return_result state anss
+                = mkCoreUbxTup
+                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+                    (state : anss)
+
+        ; (ccall_res_ty, the_alt) <- mk_alt return_result res
+
+        ; state_id <- newSysLocalDs realWorldStatePrimTy
+        ; let io_data_con = head (tyConDataCons io_tycon)
+              toIOCon     = dataConWrapId io_data_con
+
+              wrap the_call =
+                              mkApps (Var toIOCon)
+                                     [ Type io_res_ty,
+                                       Lam state_id $
+                                       mkWildCase (App the_call (Var state_id))
+                                             ccall_res_ty
+                                             (coreAltType the_alt)
+                                             [the_alt]
+                                     ]
+
+        ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }
+
+boxResult result_ty
+  = do -- It isn't IO, so do unsafePerformIO
+       -- It's not conveniently available, so we inline it
+       res <- resultWrapper result_ty
+       (ccall_res_ty, the_alt) <- mk_alt return_result res
+       let
+           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
+                                           ccall_res_ty
+                                           (coreAltType the_alt)
+                                           [the_alt]
+       return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
+  where
+    return_result _ [ans] = ans
+    return_result _ _     = panic "return_result: expected single result"
+
+
+mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
+       -> (Maybe Type, Expr Var -> Expr Var)
+       -> DsM (Type, (AltCon, [Id], Expr Var))
+mk_alt return_result (Nothing, wrap_result)
+  = do -- The ccall returns ()
+       state_id <- newSysLocalDs realWorldStatePrimTy
+       let
+             the_rhs = return_result (Var state_id)
+                                     [wrap_result (panic "boxResult")]
+
+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
+             the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
+
+       return (ccall_res_ty, the_alt)
+
+mk_alt return_result (Just prim_res_ty, wrap_result)
+  = -- The ccall returns a non-() value
+    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
+             -- True because resultWrapper ensures it is so
+    do { result_id <- newSysLocalDs prim_res_ty
+       ; state_id <- newSysLocalDs realWorldStatePrimTy
+       ; let the_rhs = return_result (Var state_id)
+                                [wrap_result (Var result_id)]
+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
+             the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
+       ; return (ccall_res_ty, the_alt) }
+
+
+resultWrapper :: Type
+              -> DsM (Maybe Type,               -- Type of the expected result, if any
+                      CoreExpr -> CoreExpr)     -- Wrapper for the result
+-- resultWrapper deals with the result *value*
+-- E.g. foreign import foo :: Int -> IO T
+-- Then resultWrapper deals with marshalling the 'T' part
+-- So if    resultWrapper ty = (Just ty_rep, marshal)
+--  then      marshal (e :: ty_rep) :: ty
+-- That is, 'marshal' wrape the result returned by the foreign call,
+-- of type ty_rep, into the value Haskell expected, of type 'ty'
+--
+-- Invariant: ty_rep is always a primitive type
+--            i.e. (isPrimitiveType ty_rep) is True
+
+resultWrapper result_ty
+  -- Base case 1: primitive types
+  | isPrimitiveType result_ty
+  = return (Just result_ty, \e -> e)
+
+  -- Base case 2: the unit type ()
+  | Just (tc,_) <- maybe_tc_app
+  , tc `hasKey` unitTyConKey
+  = return (Nothing, \_ -> Var unitDataConId)
+
+  -- Base case 3: the boolean type
+  | Just (tc,_) <- maybe_tc_app
+  , tc `hasKey` boolTyConKey
+  = do { dflags <- getDynFlags
+       ; let marshal_bool e
+               = mkWildCase e intPrimTy boolTy
+                   [ (DEFAULT                   ,[],Var trueDataConId )
+                   , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)]
+       ; return (Just intPrimTy, marshal_bool) }
+
+  -- Newtypes
+  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
+  = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
+       ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
+
+  -- The type might contain foralls (eg. for dummy type arguments,
+  -- referring to 'Ptr a' is legal).
+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+  = do { (maybe_ty, wrapper) <- resultWrapper rest
+       ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
+
+  -- Data types with a single constructor, which has a single arg
+  -- This includes types like Ptr and ForeignPtr
+  | Just (tycon, tycon_arg_tys) <- maybe_tc_app
+  , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials
+  , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
+  = do { dflags <- getDynFlags
+       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+       ; let narrow_wrapper = maybeNarrow dflags tycon
+             marshal_con e  = Var (dataConWrapId data_con)
+                              `mkTyApps` tycon_arg_tys
+                              `App` wrapper (narrow_wrapper e)
+       ; return (maybe_ty, marshal_con) }
+
+  | otherwise
+  = pprPanic "resultWrapper" (ppr result_ty)
+  where
+    maybe_tc_app = splitTyConApp_maybe result_ty
+
+-- When the result of a foreign call is smaller than the word size, we
+-- need to sign- or zero-extend the result up to the word size.  The C
+-- standard appears to say that this is the responsibility of the
+-- caller, not the callee.
+
+maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
+maybeNarrow dflags tycon
+  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
+  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
+  | tycon `hasKey` int32TyConKey
+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
+
+  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
+  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
+  | tycon `hasKey` word32TyConKey
+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
+  | otherwise                     = id
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hs
@@ -0,0 +1,1168 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring expressions.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
+              , dsValBinds, dsLit, dsSyntaxExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Match
+import MatchLit
+import DsBinds
+import DsGRHSs
+import DsListComp
+import DsUtils
+import DsArrows
+import DsMonad
+import Check ( checkGuardMatches )
+import Name
+import NameEnv
+import FamInstEnv( topNormaliseType )
+import DsMeta
+import HsSyn
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types
+import TcType
+import TcEvidence
+import TcRnMonad
+import TcHsSyn
+import Type
+import CoreSyn
+import CoreUtils
+import MkCore
+
+import DynFlags
+import CostCentre
+import Id
+import MkId
+import Module
+import ConLike
+import DataCon
+import TysWiredIn
+import PrelNames
+import BasicTypes
+import Maybes
+import VarEnv
+import SrcLoc
+import Util
+import Bag
+import Outputable
+import PatSyn
+
+import Control.Monad
+
+{-
+************************************************************************
+*                                                                      *
+                dsLocalBinds, dsValBinds
+*                                                                      *
+************************************************************************
+-}
+
+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsLocalBinds (dL->L _   (EmptyLocalBinds _))  body = return body
+dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+                                                   dsValBinds binds body
+dsLocalBinds (dL->L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
+dsLocalBinds _                                _    = panic "dsLocalBinds"
+
+-------------------------
+-- caller sets location
+dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsValBinds (XValBindsLR (NValBinds binds _)) body
+  = foldrM ds_val_bind body binds
+dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"
+
+-------------------------
+dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsIPBinds (IPBinds ev_binds ip_binds) body
+  = do  { ds_binds <- dsTcEvBinds ev_binds
+        ; let inner = mkCoreLets ds_binds body
+                -- The dict bindings may not be in
+                -- dependency order; hence Rec
+        ; foldrM ds_ip_bind inner ip_binds }
+  where
+    ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body
+      = do e' <- dsLExpr e
+           return (Let (NonRec n e') body)
+    ds_ip_bind _ _ = panic "dsIPBinds"
+dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
+
+-------------------------
+-- caller sets location
+ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
+-- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+  | [dL->L loc bind] <- bagToList hsbinds
+        -- Non-recursive, non-overloaded bindings only come in ones
+        -- ToDo: in some bizarre case it's conceivable that there
+        --       could be dict binds in the 'binds'.  (See the notes
+        --       below.  Then pattern-match would fail.  Urk.)
+  , isUnliftedHsBind bind
+  = putSrcSpanDs loc $
+     -- see Note [Strict binds checks] in DsBinds
+    if is_polymorphic bind
+    then errDsCoreExpr (poly_bind_err bind)
+            -- data Ptr a = Ptr Addr#
+            -- f x = let p@(Ptr y) = ... in ...
+            -- Here the binding for 'p' is polymorphic, but does
+            -- not mix with an unlifted binding for 'y'.  You should
+            -- use a bang pattern.  #6078.
+
+    else do { when (looksLazyPatBind bind) $
+              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
+        -- Complain about a binding that looks lazy
+        --    e.g.    let I# y = x in ...
+        -- Remember, in checkStrictBinds we are going to do strict
+        -- matching, so (for software engineering reasons) we insist
+        -- that the strictness is manifest on each binding
+        -- However, lone (unboxed) variables are ok
+
+
+            ; dsUnliftedBind bind body }
+  where
+    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
+                     = not (null tvs && null evs)
+    is_polymorphic _ = False
+
+    unlifted_must_be_bang bind
+      = hang (text "Pattern bindings containing unlifted types should use" $$
+              text "an outermost bang pattern:")
+           2 (ppr bind)
+
+    poly_bind_err bind
+      = hang (text "You can't mix polymorphic and unlifted bindings:")
+           2 (ppr bind) $$
+        text "Probable fix: add a type signature"
+
+ds_val_bind (is_rec, binds) _body
+  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds
+  = ASSERT( isRec is_rec )
+    errDsCoreExpr $
+    hang (text "Recursive bindings for unlifted types aren't allowed:")
+       2 (vcat (map ppr (bagToList binds)))
+
+-- Ordinary case for bindings; none should be unlifted
+ds_val_bind (is_rec, binds) body
+  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
+               -- we should never produce a non-recursive list of multiple binds
+
+        ; (force_vars,prs) <- dsLHsBinds binds
+        ; let body' = foldr seqVar body force_vars
+        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
+          case prs of
+            [] -> return body
+            _  -> return (Let (Rec prs) body') }
+        -- Use a Rec regardless of is_rec.
+        -- Why? Because it allows the binds to be all
+        -- mixed up, which is what happens in one rare case
+        -- Namely, for an AbsBind with no tyvars and no dicts,
+        --         but which does have dictionary bindings.
+        -- See notes with TcSimplify.inferLoop [NO TYVARS]
+        -- It turned out that wrapping a Rec here was the easiest solution
+        --
+        -- NB The previous case dealt with unlifted bindings, so we
+        --    only have to deal with lifted ones now; so Rec is ok
+
+------------------
+dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+               , abs_exports = exports
+               , abs_ev_binds = ev_binds
+               , 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)
+                            body1 lbinds
+       ; ds_binds <- dsTcEvBinds_s ev_binds
+       ; return (mkCoreLets ds_binds body2) }
+
+dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
+                        , fun_matches = matches
+                        , fun_co_fn = co_fn
+                        , fun_tick = tick }) body
+               -- Can't be a bang pattern (that looks like a PatBind)
+               -- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))
+                                     Nothing matches
+       ; MASSERT( null args ) -- Functions aren't lifted
+       ; MASSERT( isIdHsWrapper co_fn )
+       ; let rhs' = mkOptTickBox tick rhs
+       ; return (bindNonRec fun rhs' body) }
+
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
+                        , pat_ext = NPatBindTc _ ty }) body
+  =     -- let C x# y# = rhs in body
+        -- ==> case rhs of C x# y# -> body
+    do { rhs <- dsGuarded grhss ty
+       ; checkGuardMatches PatBindGuards grhss
+       ; let upat = unLoc pat
+             eqn = EqnInfo { eqn_pats = [upat],
+                             eqn_orig = FromSource,
+                             eqn_rhs = cantFailMatchResult body }
+       ; var    <- selectMatchVar upat
+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+       ; return (bindNonRec var rhs result) }
+
+dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
+*                                                                      *
+************************************************************************
+-}
+
+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
+
+dsLExpr (dL->L loc e)
+  = putSrcSpanDs loc $
+    do { core_expr <- dsExpr e
+   -- uncomment this check to test the hsExprType function in TcHsSyn
+   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
+   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
+   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
+       ; return core_expr }
+
+-- | Variant of 'dsLExpr' that ensures that the result is not levity
+-- polymorphic. This should be used when the resulting expression will
+-- be an argument to some other function.
+-- See Note [Levity polymorphism checking] in DsMonad
+-- See Note [Levity polymorphism invariants] in CoreSyn
+dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
+dsLExprNoLP (dL->L loc e)
+  = putSrcSpanDs loc $
+    do { e' <- dsExpr e
+       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
+       ; return e' }
+
+dsExpr :: HsExpr GhcTc -> DsM CoreExpr
+dsExpr = ds_expr False
+
+ds_expr :: Bool   -- are we directly inside an HsWrap?
+                  -- See Wrinkle in Note [Detecting forced eta expansion]
+        -> HsExpr GhcTc -> DsM CoreExpr
+ds_expr _ (HsPar _ e)            = dsLExpr e
+ds_expr _ (ExprWithTySig _ e _)  = dsLExpr e
+ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var
+ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
+ds_expr w (HsConLikeOut _ con)   = dsConLike w con
+ds_expr _ (HsIPVar {})           = panic "dsExpr: HsIPVar"
+ds_expr _ (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
+
+ds_expr _ (HsLit _ lit)
+  = do { warnAboutOverflowedLit lit
+       ; dsLit (convertLit lit) }
+
+ds_expr _ (HsOverLit _ lit)
+  = do { warnAboutOverflowedOverLit lit
+       ; dsOverLit lit }
+
+ds_expr _ (HsWrap _ co_fn e)
+  = do { e' <- ds_expr True e    -- This is the one place where we recurse to
+                                 -- ds_expr (passing True), rather than dsExpr
+       ; wrap' <- dsHsWrapper co_fn
+       ; dflags <- getDynFlags
+       ; let wrapped_e = wrap' e'
+             wrapped_ty = exprType wrapped_e
+       ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]
+       ; warnAboutIdentities dflags e' wrapped_ty
+       ; return wrapped_e }
+
+ds_expr _ (NegApp _ (dL->L loc
+                      (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
+                  neg_expr)
+  = do { expr' <- putSrcSpanDs loc $ do
+          { warnAboutOverflowedOverLit
+              (lit { ol_val = HsIntegral (negateIntegralLit i) })
+          ; dsOverLit lit }
+       ; dsSyntaxExpr neg_expr [expr'] }
+
+ds_expr _ (NegApp _ expr neg_expr)
+  = do { expr' <- dsLExpr expr
+       ; dsSyntaxExpr neg_expr [expr'] }
+
+ds_expr _ (HsLam _ a_Match)
+  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
+
+ds_expr _ (HsLamCase _ matches)
+  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
+       ; return $ Lam discrim_var matching_code }
+
+ds_expr _ e@(HsApp _ fun arg)
+  = do { fun' <- dsLExpr fun
+       ; dsWhenNoErrs (dsLExprNoLP arg)
+                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
+
+ds_expr _ (HsAppType _ e _)
+    -- ignore type arguments here; they're in the wrappers instead at this point
+  = dsLExpr e
+
+{-
+Note [Desugaring vars]
+~~~~~~~~~~~~~~~~~~~~~~
+In one situation we can get a *coercion* variable in a HsVar, namely
+the support method for an equality superclass:
+   class (a~b) => C a b where ...
+   instance (blah) => C (T a) (T b) where ..
+Then we get
+   $dfCT :: forall ab. blah => C (T a) (T b)
+   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
+
+   $c$p1C :: forall ab. blah => (T a ~ T b)
+   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
+
+That 'g' in the 'in' part is an evidence variable, and when
+converting to core it must become a CO.
+
+Operator sections.  At first it looks as if we can convert
+\begin{verbatim}
+        (expr op)
+\end{verbatim}
+to
+\begin{verbatim}
+        \x -> op expr x
+\end{verbatim}
+
+But no!  expr might be a redex, and we can lose laziness badly this
+way.  Consider
+\begin{verbatim}
+        map (expr op) xs
+\end{verbatim}
+for example.  So we convert instead to
+\begin{verbatim}
+        let y = expr in \x -> op y x
+\end{verbatim}
+If \tr{expr} is actually just a variable, say, then the simplifier
+will sort it out.
+-}
+
+ds_expr _ e@(OpApp _ e1 op e2)
+  = -- for the type of y, we need the type of op's 2nd argument
+    do { op' <- dsLExpr op
+       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
+                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
+
+ds_expr _ (SectionL _ expr op)       -- Desugar (e !) to ((!) e)
+  = do { op' <- dsLExpr op
+       ; dsWhenNoErrs (dsLExprNoLP expr)
+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
+
+-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
+ds_expr _ e@(SectionR _ op expr) = do
+    core_op <- dsLExpr op
+    -- for the type of x, we need the type of op's 2nd argument
+    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+        -- See comment with SectionL
+    y_core <- dsLExpr expr
+    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
+                 (\[x_id, y_id] -> bindNonRec y_id y_core $
+                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
+                                                          core_op [Var x_id, Var y_id]))
+
+ds_expr _ (ExplicitTuple _ tup_args boxity)
+  = do { let go (lam_vars, args) (dL->L _ (Missing ty))
+                    -- For every missing expression, we need
+                    -- another lambda in the desugaring.
+               = do { lam_var <- newSysLocalDsNoLP ty
+                    ; return (lam_var : lam_vars, Var lam_var : args) }
+             go (lam_vars, args) (dL->L _ (Present _ expr))
+                    -- Expressions that are present don't generate
+                    -- lambdas, just arguments.
+               = do { core_expr <- dsLExprNoLP expr
+                    ; return (lam_vars, core_expr : args) }
+             go _ _ = panic "ds_expr"
+
+       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
+                -- The reverse is because foldM goes left-to-right
+                      (\(lam_vars, args) -> mkCoreLams lam_vars $
+                                            mkCoreTupBoxity boxity args) }
+
+ds_expr _ (ExplicitSum types alt arity expr)
+  = do { dsWhenNoErrs (dsLExprNoLP expr)
+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)
+                                     (map (Type . getRuntimeRep) types ++
+                                      map Type types ++
+                                      [core_expr]) ) }
+
+ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do
+    dflags <- getDynFlags
+    if gopt Opt_SccProfilingOn dflags
+      then do
+        mod_name <- getModule
+        count <- goptM Opt_ProfCountEntries
+        let nm = sl_fs cc
+        flavour <- ExprCC <$> getCCIndexM nm
+        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
+               <$> dsLExpr expr
+      else dsLExpr expr
+
+ds_expr _ (HsCoreAnn _ _ _ expr)
+  = dsLExpr expr
+
+ds_expr _ (HsCase _ discrim matches)
+  = do { core_discrim <- dsLExpr discrim
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
+       ; return (bindNonRec discrim_var core_discrim matching_code) }
+
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+--       This is to avoid silliness in breakpoints
+ds_expr _ (HsLet _ binds body) = do
+    body' <- dsLExpr body
+    dsLocalBinds binds body'
+
+-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
+-- because the interpretation of `stmts' depends on what sort of thing it is.
+--
+ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ DoExpr        (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt  (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr       (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp     (dL->L _ stmts)) = dsMonadComp stmts
+
+ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
+  = do { pred <- dsLExpr guard_expr
+       ; b1 <- dsLExpr then_expr
+       ; b2 <- dsLExpr else_expr
+       ; case mb_fun of
+           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
+           Nothing  -> return $ mkIfThenElse pred b1 b2 }
+
+ds_expr _ (HsMultiIf res_ty alts)
+  | null alts
+  = mkErrorExpr
+
+  | otherwise
+  = do { match_result <- liftM (foldr1 combineMatchResults)
+                               (mapM (dsGRHS IfAlt res_ty) alts)
+       ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))
+       ; error_expr   <- mkErrorExpr
+       ; extractMatchResult match_result error_expr }
+  where
+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
+                               (text "multi-way if")
+
+{-
+\noindent
+\underline{\bf Various data construction things}
+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+
+ds_expr _ (ExplicitList elt_ty wit xs)
+  = dsExplicitList elt_ty wit xs
+
+ds_expr _ (ArithSeq expr witness seq)
+  = case witness of
+     Nothing -> dsArithSeq expr seq
+     Just fl -> do { newArithSeq <- dsArithSeq expr seq
+                   ; dsSyntaxExpr fl [newArithSeq] }
+
+{-
+Static Pointers
+~~~~~~~~~~~~~~~
+
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
+    g = ... static f ...
+==>
+    g = ... makeStatic loc f ...
+-}
+
+ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do
+    expr_ds <- dsLExprNoLP expr
+    let ty = exprType expr_ds
+    makeStaticId <- dsLookupGlobalId makeStaticName
+
+    dflags <- getDynFlags
+    let (line, col) = case loc of
+           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
+                            , srcLocCol  $ realSrcSpanStart r
+                            )
+           _             -> (0, 0)
+        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
+                     [ Type intTy              , Type intTy
+                     , mkIntExprInt dflags line, mkIntExprInt dflags col
+                     ]
+
+    putSrcSpanDs loc $ return $
+      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
+
+{-
+\noindent
+\underline{\bf Record construction and update}
+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
+\begin{verbatim}
+        T { op2 = e }
+==>
+        let err = /\a -> recConErr a
+        T (recConErr t1 "M.hs/230/op1")
+          e
+          (recConErr t1 "M.hs/230/op3")
+\end{verbatim}
+@recConErr@ then converts its argument string into a proper message
+before printing it as
+\begin{verbatim}
+        M.hs, line 230: missing field op1 was evaluated
+\end{verbatim}
+
+We also handle @C{}@ as valid construction syntax for an unlabelled
+constructor @C@, setting all of @C@'s fields to bottom.
+-}
+
+ds_expr _ (RecordCon { rcon_flds = rbinds
+                     , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+                                              , rcon_con_like = con_like }})
+  = do { con_expr' <- dsExpr con_expr
+       ; let
+             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
+             -- A newtype in the corner should be opaque;
+             -- hence TcType.tcSplitFunTys
+
+             mk_arg (arg_ty, fl)
+               = case findField (rec_flds rbinds) (flSelector fl) of
+                   (rhs:rhss) -> ASSERT( null rhss )
+                                 dsLExprNoLP rhs
+                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
+             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
+
+             labels = conLikeFieldLabels con_like
+
+       ; con_args <- if null labels
+                     then mapM unlabelled_bottom arg_tys
+                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
+
+       ; return (mkCoreApps con_expr' con_args) }
+
+{-
+Record update is a little harder. Suppose we have the decl:
+\begin{verbatim}
+        data T = T1 {op1, op2, op3 :: Int}
+               | T2 {op4, op2 :: Int}
+               | T3
+\end{verbatim}
+Then we translate as follows:
+\begin{verbatim}
+        r { op2 = e }
+===>
+        let op2 = e in
+        case r of
+          T1 op1 _ op3 -> T1 op1 op2 op3
+          T2 op4 _     -> T2 op4 op2
+          other        -> recUpdError "M.hs/230"
+\end{verbatim}
+It's important that we use the constructor Ids for @T1@, @T2@ etc on the
+RHSs, and do not generate a Core constructor application directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+Note [Update for GADTs]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a b where
+     T1 :: { f1 :: a } -> T a Int
+
+Then the wrapper function for T1 has type
+   $WT1 :: a -> T a Int
+But if x::T a b, then
+   x { f1 = v } :: T a b   (not T a Int!)
+So we need to cast (T a Int) to (T a b).  Sigh.
+
+-}
+
+ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
+                          , rupd_ext = RecordUpdTc
+                              { rupd_cons = cons_to_upd
+                              , rupd_in_tys = in_inst_tys
+                              , rupd_out_tys = out_inst_tys
+                              , rupd_wrap = dict_req_wrap }} )
+  | null fields
+  = dsLExpr record_expr
+  | otherwise
+  = ASSERT2( notNull cons_to_upd, ppr expr )
+
+    do  { record_expr' <- dsLExpr record_expr
+        ; field_binds' <- mapM ds_field fields
+        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
+              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
+
+        -- It's important to generate the match with matchWrapper,
+        -- and the right hand sides with applications of the wrapper Id
+        -- so that everything works when we are doing fancy unboxing on the
+        -- constructor arguments.
+        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
+        ; ([discrim_var], matching_code)
+                <- matchWrapper RecUpd Nothing
+                                      (MG { mg_alts = noLoc alts
+                                          , mg_ext = MatchGroupTc [in_ty] out_ty
+                                          , mg_origin = FromSource })
+                                     -- FromSource is not strictly right, but we
+                                     -- want incomplete pattern-match warnings
+
+        ; return (add_field_binds field_binds' $
+                  bindNonRec discrim_var record_expr' matching_code) }
+  where
+    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
+      -- Clone the Id in the HsRecField, because its Name is that
+      -- of the record selector, and we must not make that a local binder
+      -- else we shadow other uses of the record selector
+      -- Hence 'lcl_id'.  Cf #2735
+    ds_field (dL->L _ rec_field)
+      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
+           ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
+           ; lcl_id <- newSysLocalDs (idType fld_id)
+           ; return (idName fld_id, lcl_id, rhs) }
+
+    add_field_binds [] expr = expr
+    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
+
+        -- Awkwardly, for families, the match goes
+        -- from instance type to family type
+    (in_ty, out_ty) =
+      case (head cons_to_upd) of
+        RealDataCon data_con ->
+          let tycon = dataConTyCon data_con in
+          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
+        PatSynCon pat_syn ->
+          ( patSynInstResTy pat_syn in_inst_tys
+          , patSynInstResTy pat_syn out_inst_tys)
+    mk_alt upd_fld_env con
+      = do { let (univ_tvs, ex_tvs, eq_spec,
+                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
+                 user_tvs =
+                   case con of
+                     RealDataCon data_con -> dataConUserTyVars data_con
+                     PatSynCon _          -> univ_tvs ++ ex_tvs
+                       -- The order here is because of the order in `TcPatSyn`.
+                 in_subst  = zipTvSubst univ_tvs in_inst_tys
+                 out_subst = zipTvSubst univ_tvs out_inst_tys
+
+                -- I'm not bothering to clone the ex_tvs
+           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
+           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
+           ; let field_labels = conLikeFieldLabels con
+                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+                                         field_labels arg_ids
+                 mk_val_arg fl pat_arg_id
+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
+
+                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
+                        -- Reconstruct with the WrapId so that unpacking happens
+                 wrap = mkWpEvVarApps theta_vars                                <.>
+                        dict_req_wrap                                           <.>
+                        mkWpTyApps    [ lookupTyVar out_subst tv
+                                          `orElse` mkTyVarTy tv
+                                      | tv <- user_tvs
+                                      , not (tv `elemVarEnv` wrap_subst) ]
+                          -- Be sure to use user_tvs (which may be ordered
+                          -- differently than `univ_tvs ++ ex_tvs) above.
+                          -- See Note [DataCon user type variable binders]
+                          -- in DataCon.
+                 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
+
+                        -- Tediously wrap the application in a cast
+                        -- Note [Update for GADTs]
+                 wrapped_rhs =
+                  case con of
+                    RealDataCon data_con ->
+                      let
+                        wrap_co =
+                          mkTcTyConAppCo Nominal
+                            (dataConTyCon data_con)
+                            [ lookup tv ty
+                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
+                        lookup univ_tv ty =
+                          case lookupVarEnv wrap_subst univ_tv of
+                            Just co' -> co'
+                            Nothing  -> mkTcReflCo Nominal ty
+                        in if null eq_spec
+                             then rhs
+                             else mkLHsWrap (mkWpCastN wrap_co) rhs
+                    -- eq_spec is always null for a PatSynCon
+                    PatSynCon _ -> rhs
+
+                 wrap_subst =
+                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
+                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
+                           , let tv = eqSpecTyVar spec ]
+
+                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
+
+                 pat = noLoc $ ConPatOut { pat_con = noLoc con
+                                         , pat_tvs = ex_tvs
+                                         , pat_dicts = eqs_vars ++ theta_vars
+                                         , pat_binds = emptyTcEvBinds
+                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
+                                         , pat_arg_tys = in_inst_tys
+                                         , pat_wrap = req_wrap }
+           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
+
+-- Here is where we desugar the Template Haskell brackets and escapes
+
+-- Template Haskell stuff
+
+ds_expr _ (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"
+ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
+ds_expr _ (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
+
+-- Arrow notation extension
+ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
+
+-- Hpc Support
+
+ds_expr _ (HsTick _ tickish e) = do
+  e' <- dsLExpr e
+  return (Tick tickish e')
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+ds_expr _ (HsBinTick _ ixT ixF e) = do
+  e2 <- dsLExpr e
+  do { ASSERT(exprType e2 `eqType` boolTy)
+       mkBinaryTickBox ixT ixF e2
+     }
+
+ds_expr _ (HsTickPragma _ _ _ _ expr) = do
+  dflags <- getDynFlags
+  if gopt Opt_Hpc dflags
+    then panic "dsExpr:HsTickPragma"
+    else dsLExpr expr
+
+-- HsSyn constructs that just shouldn't be here:
+ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
+ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
+ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
+ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"
+
+
+------------------------------
+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
+dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
+                         , syn_arg_wraps = arg_wraps
+                         , syn_res_wrap  = res_wrap })
+             arg_exprs
+  = do { fun            <- dsExpr expr
+       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
+       ; core_res_wrap  <- dsHsWrapper res_wrap
+       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
+                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
+  where
+    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+
+findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
+findField rbinds sel
+  = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds
+                       , sel == idName (unLoc $ hsRecFieldId fld) ]
+
+{-
+%--------------------------------------------------------------------
+
+Note [Desugaring explicit lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explicit lists are desugared in a cleverer way to prevent some
+fruitless allocations.  Essentially, whenever we see a list literal
+[x_1, ..., x_n] we generate the corresponding expression in terms of
+build:
+
+Explicit lists (literals) are desugared to allow build/foldr fusion when
+beneficial. This is a bit of a trade-off,
+
+ * build/foldr fusion can generate far larger code than the corresponding
+   cons-chain (e.g. see #11707)
+
+ * even when it doesn't produce more code, build can still fail to fuse,
+   requiring that the simplifier do more work to bring the expression
+   back into cons-chain form; this costs compile time
+
+ * when it works, fusion can be a significant win. Allocations are reduced
+   by up to 25% in some nofib programs. Specifically,
+
+        Program           Size    Allocs   Runtime  CompTime
+        rewrite          +0.0%    -26.3%      0.02     -1.8%
+           ansi          -0.3%    -13.8%      0.00     +0.0%
+           lift          +0.0%     -8.7%      0.00     -2.3%
+
+At the moment we use a simple heuristic to determine whether build will be
+fruitful: for small lists we assume the benefits of fusion will be worthwhile;
+for long lists we assume that the benefits will be outweighted by the cost of
+code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
+won't work at all if rewrite rules are disabled, so we don't use the build-based
+desugaring in this case.
+
+We used to have a more complex heuristic which would try to break the list into
+"static" and "dynamic" parts and only build-desugar the dynamic part.
+Unfortunately, determining "static-ness" reliably is a bit tricky and the
+heuristic at times produced surprising behavior (see #11710) so it was dropped.
+-}
+
+{- | The longest list length which we will desugar using @build@.
+
+This is essentially a magic number and its setting is unfortunate rather
+arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
+is to avoid deforesting large static data into large(r) code. Ideally we'd
+want a smaller threshold with larger consumers and vice-versa, but we have no
+way of knowing what will be consuming our list in the desugaring impossible to
+set generally correctly.
+
+The effect of reducing this number will be that 'build' fusion is applied
+less often. From a runtime performance perspective, applying 'build' more
+liberally on "moderately" sized lists should rarely hurt and will often it can
+only expose further optimization opportunities; if no fusion is possible it will
+eventually get rule-rewritten back to a list). We do, however, pay in compile
+time.
+-}
+maxBuildLength :: Int
+maxBuildLength = 32
+
+dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
+               -> DsM CoreExpr
+-- See Note [Desugaring explicit lists]
+dsExplicitList elt_ty Nothing xs
+  = do { dflags <- getDynFlags
+       ; xs' <- mapM dsLExprNoLP xs
+       ; if xs' `lengthExceeds` maxBuildLength
+                -- Don't generate builds if the list is very long.
+         || null xs'
+                -- Don't generate builds when the [] constructor will do
+         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
+                -- Don't generate a build if there are no rules to eliminate it!
+                -- See Note [Desugaring RULE left hand sides] in Desugar
+         then return $ mkListExpr elt_ty xs'
+         else mkBuildExpr elt_ty (mk_build_list xs') }
+  where
+    mk_build_list xs' (cons, _) (nil, _)
+      = return (foldr (App . App (Var cons)) (Var nil) xs')
+
+dsExplicitList elt_ty (Just fln) xs
+  = do { list <- dsExplicitList elt_ty Nothing xs
+       ; dflags <- getDynFlags
+       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
+
+dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
+dsArithSeq expr (From from)
+  = App <$> dsExpr expr <*> dsLExprNoLP from
+dsArithSeq expr (FromTo from to)
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from Nothing to
+       expr' <- dsExpr expr
+       from' <- dsLExprNoLP from
+       to'   <- dsLExprNoLP to
+       return $ mkApps expr' [from', to']
+dsArithSeq expr (FromThen from thn)
+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
+dsArithSeq expr (FromThenTo from thn to)
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from (Just thn) to
+       expr' <- dsExpr expr
+       from' <- dsLExprNoLP from
+       thn'  <- dsLExprNoLP thn
+       to'   <- dsLExprNoLP to
+       return $ mkApps expr' [from', thn', to']
+
+{-
+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
+handled in DsListComp).  Basically does the translation given in the
+Haskell 98 report:
+-}
+
+dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsDo stmts
+  = goL stmts
+  where
+    goL [] = panic "dsDo"
+    goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+
+    go _ (LastStmt _ body _ _) stmts
+      = ASSERT( null stmts ) dsLExpr body
+        -- The 'return' op isn't used for 'do' expressions
+
+    go _ (BodyStmt _ rhs then_expr _) stmts
+      = do { rhs2 <- dsLExpr rhs
+           ; warnDiscardedDoBindings rhs (exprType rhs2)
+           ; rest <- goL stmts
+           ; dsSyntaxExpr then_expr [rhs2, rest] }
+
+    go _ (LetStmt _ binds) stmts
+      = do { rest <- goL stmts
+           ; dsLocalBinds binds rest }
+
+    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
+      = do  { body     <- goL stmts
+            ; rhs'     <- dsLExpr rhs
+            ; var   <- selectSimpleMatchVarL pat
+            ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                      res1_ty (cantFailMatchResult body)
+            ; match_code <- handle_failure pat match fail_op
+            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+    go _ (ApplicativeStmt body_ty args mb_join) stmts
+      = do {
+             let
+               (pats, rhss) = unzip (map (do_arg . snd) args)
+
+               do_arg (ApplicativeArgOne _ pat expr _) =
+                 (pat, dsLExpr expr)
+               do_arg (ApplicativeArgMany _ stmts ret pat) =
+                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+               do_arg (XApplicativeArg _) = panic "dsDo"
+
+               arg_tys = map hsLPatType pats
+
+           ; rhss' <- sequence rhss
+
+           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
+
+           ; let fun = cL noSrcSpan $ HsLam noExt $
+                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
+                                                       body']
+                      , mg_ext = MatchGroupTc arg_tys body_ty
+                      , mg_origin = Generated }
+
+           ; fun' <- dsLExpr fun
+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
+           ; case mb_join of
+               Nothing -> return expr
+               Just join_op -> dsSyntaxExpr join_op [expr] }
+
+    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
+                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
+                    , recS_ext = RecStmtTc
+                        { recS_bind_ty = bind_ty
+                        , recS_rec_rets = rec_rets
+                        , recS_ret_ty = body_ty} }) stmts
+      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
+      where
+        new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
+                                         mfix_app bind_op
+                                         noSyntaxExpr  -- Tuple cannot fail
+
+        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
+        rec_tup_pats = map nlVarPat tup_ids
+        later_pats   = rec_tup_pats
+        rets         = map noLoc rec_rets
+        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
+        mfix_arg     = noLoc $ HsLam noExt
+                           (MG { mg_alts = noLoc [mkSimpleMatch
+                                                    LambdaExpr
+                                                    [mfix_pat] body]
+                               , mg_ext = MatchGroupTc [tup_ty] body_ty
+                               , mg_origin = Generated })
+        mfix_pat     = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
+        body         = noLoc $ HsDo body_ty
+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
+        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
+        ret_stmt     = noLoc $ mkLastStmt ret_app
+                     -- This LastStmt will be desugared with dsDo,
+                     -- which ignores the return_op in the LastStmt,
+                     -- so we must apply the return_op explicitly
+
+    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
+    go _ (TransStmt {}) _ = panic "dsDo TransStmt"
+    go _ (XStmtLR   {}) _ = panic "dsDo XStmtLR"
+
+handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+    -- In a do expression, pattern-match failure just calls
+    -- the monadic 'fail' rather than throwing an exception
+handle_failure pat match fail_op
+  | matchCanFail match
+  = do { dflags <- getDynFlags
+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+       ; extractMatchResult match fail_expr }
+  | otherwise
+  = extractMatchResult match (error "It can't fail")
+
+mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
+                         showPpr dflags (getLoc pat)
+
+{-
+************************************************************************
+*                                                                      *
+   Desugaring Variables
+*                                                                      *
+************************************************************************
+-}
+
+dsHsVar :: Bool  -- are we directly inside an HsWrap?
+                 -- See Wrinkle in Note [Detecting forced eta expansion]
+        -> Id -> DsM CoreExpr
+dsHsVar w var
+  | not w
+  , let bad_tys = badUseOfLevPolyPrimop var ty
+  , not (null bad_tys)
+  = do { levPolyPrimopErr var ty bad_tys
+       ; return unitExpr }  -- return something eminently safe
+
+  | otherwise
+  = return (varToCoreExpr var)   -- See Note [Desugaring vars]
+
+  where
+    ty = idType var
+
+dsConLike :: Bool  -- as in dsHsVar
+          -> ConLike -> DsM CoreExpr
+dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc)
+dsConLike _ (PatSynCon ps)   = return $ case patSynBuilder ps of
+  Just (id, add_void)
+    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
+    | otherwise -> Var id
+  _ -> pprPanic "dsConLike" (ppr ps)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+-}
+
+-- Warn about certain types of values discarded in monadic bindings (#3263)
+warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
+       ; warn_wrong <- woptM Opt_WarnWrongDoBind
+       ; when (warn_unused || warn_wrong) $
+    do { fam_inst_envs <- dsGetFamInstEnvs
+       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
+
+           -- Warn about discarding non-() things in 'monadic' binding
+       ; if warn_unused && not (isUnitTy norm_elt_ty)
+         then warnDs (Reason Opt_WarnUnusedDoBind)
+                     (badMonadBind rhs elt_ty)
+         else
+
+           -- Warn about discarding m a things in 'monadic' binding of the same type,
+           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+           when warn_wrong $
+                do { case tcSplitAppTy_maybe norm_elt_ty of
+                         Just (elt_m_ty, _)
+                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
+                            -> warnDs (Reason Opt_WarnWrongDoBind)
+                                      (badMonadBind rhs elt_ty)
+                         _ -> return () } } }
+
+  | otherwise   -- RHS does have type of form (m ty), which is weird
+  = return ()   -- but at lesat this warning is irrelevant
+
+badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
+badMonadBind rhs elt_ty
+  = vcat [ hang (text "A do-notation statement discarded a result of type")
+              2 (quotes (ppr elt_ty))
+         , hang (text "Suppress this warning by saying")
+              2 (quotes $ text "_ <-" <+> ppr rhs)
+         ]
+
+{-
+************************************************************************
+*                                                                      *
+   Forced eta expansion and levity polymorphism
+*                                                                      *
+************************************************************************
+
+Note [Detecting forced eta expansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We cannot have levity polymorphic function arguments. See
+Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
+functions that take levity polymorphism arguments, as long as these
+functions are eta-reduced. (See #12708 for an example.)
+
+However, we absolutely cannot do this for functions that have no
+binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
+tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.
+
+Detecting when this is about to happen is a bit tricky, though. When
+the desugarer is looking at the Id itself (let's be concrete and
+suppose we have (#,#)), we don't know whether it will be levity
+polymorphic. So the right spot seems to be to look after the Id has
+been applied to its type arguments. To make the algorithm efficient,
+it's important to be able to spot ((#,#) @a @b @c @d) without looking
+past all the type arguments. We thus require that
+  * The body of an HsWrap is not an HsWrap.
+With that representation invariant, we simply look inside every HsWrap
+to see if its body is an HsVar whose Id hasNoBinding. Then, we look
+at the wrapped type. If it has any levity polymorphic arguments, reject.
+
+Interestingly, this approach does not look to see whether the Id in
+question will be eta expanded. The logic is this:
+  * Either the Id in question is saturated or not.
+  * If it is, then it surely can't have levity polymorphic arguments.
+    If its wrapped type contains levity polymorphic arguments, reject.
+  * If it's not, then it can't be eta expanded with levity polymorphic
+    argument. If its wrapped type contains levity polymorphic arguments, reject.
+So, either way, we're good to reject.
+
+Wrinkle
+~~~~~~~
+Not all polymorphic Ids are wrapped in
+HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type
+application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id
+without a wrapper, then that is surely problem and we can reject.
+
+We thus have a parameter to `dsExpr` that tracks whether or not we are
+directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when
+we're not directly in an HsWrap, reject.
+
+-}
+
+-- | Takes an expression and its instantiated type. If the expression is an
+-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
+-- issue an error. See Note [Detecting forced eta expansion]
+checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
+checkForcedEtaExpansion expr ty
+  | Just var <- case expr of
+                  HsVar _ (dL->L _ var)           -> Just var
+                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
+                  _                               -> Nothing
+  , let bad_tys = badUseOfLevPolyPrimop var ty
+  , not (null bad_tys)
+  = levPolyPrimopErr var ty bad_tys
+checkForcedEtaExpansion _ _ = return ()
+
+-- | Is this a hasNoBinding Id with a levity-polymorphic type?
+-- Returns the arguments that are levity polymorphic if they are bad;
+-- or an empty list otherwise
+-- See Note [Detecting forced eta expansion]
+badUseOfLevPolyPrimop :: Id -> Type -> [Type]
+badUseOfLevPolyPrimop id ty
+  | hasNoBinding id
+  = filter isTypeLevPoly arg_tys
+  | otherwise
+  = []
+  where
+    (binders, _) = splitPiTys ty
+    arg_tys      = mapMaybe binderRelevantType_maybe binders
+
+levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
+levPolyPrimopErr primop ty bad_tys
+  = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
+                      2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
+                 , hang (text "Levity-polymorphic arguments:")
+                      2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]
diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hs-boot
@@ -0,0 +1,10 @@
+module DsExpr where
+import HsSyn       ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
+import DsMonad     ( DsM )
+import CoreSyn     ( CoreExpr )
+import HsExtension ( GhcTc)
+
+dsExpr  :: HsExpr GhcTc -> DsM CoreExpr
+dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsForeign.hs
@@ -0,0 +1,819 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1998
+
+
+Desugaring foreign declarations (see also DsCCall).
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsForeign ( dsForeigns ) where
+
+#include "HsVersions.h"
+import GhcPrelude
+
+import TcRnMonad        -- temp
+
+import CoreSyn
+
+import DsCCall
+import DsMonad
+
+import HsSyn
+import DataCon
+import CoreUnfold
+import Id
+import Literal
+import Module
+import Name
+import Type
+import RepType
+import TyCon
+import Coercion
+import TcEnv
+import TcType
+
+import CmmExpr
+import CmmUtils
+import HscTypes
+import ForeignCall
+import TysWiredIn
+import TysPrim
+import PrelNames
+import BasicTypes
+import SrcLoc
+import Outputable
+import FastString
+import DynFlags
+import Platform
+import OrdList
+import Pair
+import Util
+import Hooks
+import Encoding
+
+import Data.Maybe
+import Data.List
+
+{-
+Desugaring of @foreign@ declarations is naturally split up into
+parts, an @import@ and an @export@  part. A @foreign import@
+declaration
+\begin{verbatim}
+  foreign import cc nm f :: prim_args -> IO prim_res
+\end{verbatim}
+is the same as
+\begin{verbatim}
+  f :: prim_args -> IO prim_res
+  f a1 ... an = _ccall_ nm cc a1 ... an
+\end{verbatim}
+so we reuse the desugaring code in @DsCCall@ to deal with these.
+-}
+
+type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
+                              -- the occurrence analyser will sort it all out
+
+dsForeigns :: [LForeignDecl GhcTc]
+           -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+
+dsForeigns' :: [LForeignDecl GhcTc]
+            -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns' []
+  = return (NoStubs, nilOL)
+dsForeigns' fos = do
+    fives <- mapM do_ldecl fos
+    let
+        (hs, cs, idss, bindss) = unzip4 fives
+        fe_ids = concat idss
+        fe_init_code = map foreignExportInitialiser fe_ids
+    --
+    return (ForeignStubs
+             (vcat hs)
+             (vcat cs $$ vcat fe_init_code),
+            foldr (appOL . toOL) nilOL bindss)
+  where
+   do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)
+
+   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
+      traceIf (text "fi start" <+> ppr id)
+      let id' = unLoc id
+      (bs, h, c) <- dsFImport id' co spec
+      traceIf (text "fi end" <+> ppr id)
+      return (h, c, [], bs)
+
+   do_decl (ForeignExport { fd_name = (dL->L _ id)
+                          , fd_e_ext = co
+                          , fd_fe = CExport
+                              (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
+      (h, c, _, _) <- dsFExport id co ext_nm cconv False
+      return (h, c, [id], [])
+   do_decl (XForeignDecl _) = panic "dsForeigns'"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign import}
+*                                                                      *
+************************************************************************
+
+Desugaring foreign imports is just the matter of creating a binding
+that on its RHS unboxes its arguments, performs the external call
+(using the @CCallOp@ primop), before boxing the result up and returning it.
+
+However, we create a worker/wrapper pair, thus:
+
+        foreign import f :: Int -> IO Int
+==>
+        f x = IO ( \s -> case x of { I# x# ->
+                         case fw s x# of { (# s1, y# #) ->
+                         (# s1, I# y# #)}})
+
+        fw s x# = ccall f s x#
+
+The strictness/CPR analyser won't do this automatically because it doesn't look
+inside returned tuples; but inlining this wrapper is a Really Good Idea
+because it exposes the boxing to the call site.
+-}
+
+dsFImport :: Id
+          -> Coercion
+          -> ForeignImport
+          -> DsM ([Binding], SDoc, SDoc)
+dsFImport id co (CImport cconv safety mHeader spec _) =
+    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
+
+dsCImport :: Id
+          -> Coercion
+          -> CImportSpec
+          -> CCallConv
+          -> Safety
+          -> Maybe Header
+          -> DsM ([Binding], SDoc, SDoc)
+dsCImport id co (CLabel cid) cconv _ _ = do
+   dflags <- getDynFlags
+   let ty  = pFst $ coercionKind co
+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
+             Just tycon
+              | tyConUnique tycon == funPtrTyConKey ->
+                 IsFunction
+             _ -> IsData
+   (resTy, foRhs) <- resultWrapper ty
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
+    let
+        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
+        rhs' = Cast rhs co
+        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
+    in
+    return ([(id, rhs')], empty, empty)
+
+dsCImport id co (CFunction target) cconv@PrimCallConv safety _
+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
+dsCImport id co (CFunction target) cconv safety mHeader
+  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
+dsCImport id co CWrapper cconv _ _
+  = dsFExportDynamic id co cconv
+
+-- For stdcall labels, if the type was a FunPtr or newtype thereof,
+-- then we need to calculate the size of the arguments in order to add
+-- the @n suffix to the label.
+fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info dflags StdCallConv ty
+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
+    tyConUnique tc == funPtrTyConKey
+  = let
+       (bndrs, _) = tcSplitPiTys arg_ty
+       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
+fun_type_arg_stdcall_info _ _other_conv _
+  = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign calls}
+*                                                                      *
+************************************************************************
+-}
+
+dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
+        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id co fcall mDeclHeader = do
+    let
+        ty                   = pFst $ coercionKind co
+        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty
+        (arg_tys, io_res_ty) = tcSplitFunTys rho
+
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
+
+    let
+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
+
+    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
+
+    ccall_uniq <- newUnique
+    work_uniq  <- newUnique
+
+    dflags <- getDynFlags
+    (fcall', cDoc) <-
+              case fcall of
+              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
+                               CApiConv safety) ->
+               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
+                  let fcall' = CCall (CCallSpec
+                                      (StaticTarget NoSourceText
+                                                    wrapperName mUnitId
+                                                    True)
+                                      CApiConv safety)
+                      c = includes
+                       $$ fun_proto <+> braces (cRet <> semi)
+                      includes = vcat [ text "#include \"" <> ftext h
+                                        <> text "\""
+                                      | Header _ h <- nub headers ]
+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      cRet
+                       | isVoidRes =                   cCall
+                       | otherwise = text "return" <+> cCall
+                      cCall = if isFun
+                              then ppr cName <> parens argVals
+                              else if null arg_tys
+                                    then ppr cName
+                                    else panic "dsFCall: Unexpected arguments to FFI value import"
+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
+                                   Just (_ioTyCon, res_ty) -> res_ty
+                                   Nothing                 -> io_res_ty
+                      isVoidRes = raw_res_ty `eqType` unitTy
+                      (mHeader, cResType)
+                       | isVoidRes = (Nothing, text "void")
+                       | otherwise = toCType raw_res_ty
+                      pprCconv = ccallConvAttribute CApiConv
+                      mHeadersArgTypeList
+                          = [ (header, cType <+> char 'a' <> int n)
+                            | (t, n) <- zip arg_tys [1..]
+                            , let (header, cType) = toCType t ]
+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
+                      argTypes = if null argTypeList
+                                 then text "void"
+                                 else hsep $ punctuate comma argTypeList
+                      mHeaders' = mDeclHeader : mHeader : mHeaders
+                      headers = catMaybes mHeaders'
+                      argVals = hsep $ punctuate comma
+                                    [ char 'a' <> int n
+                                    | (_, n) <- zip arg_tys [1..] ]
+                  return (fcall', c)
+              _ ->
+                  return (fcall, empty)
+    let
+        -- Build the worker
+        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
+        tvs           = map binderVar tv_bndrs
+        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
+        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
+
+        -- Build the wrapper
+        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
+        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        wrap_rhs'    = Cast wrap_rhs co
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
+                                                (length args) wrap_rhs'
+
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Primitive calls}
+*                                                                      *
+************************************************************************
+
+This is for `@foreign import prim@' declarations.
+
+Currently, at the core level we pretend that these primitive calls are
+foreign calls. It may make more sense in future to have them as a distinct
+kind of Id, or perhaps to bundle them with PrimOps since semantically and
+for calling convention they are really prim ops.
+-}
+
+dsPrimCall :: Id -> Coercion -> ForeignCall
+           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsPrimCall fn_id co fcall = do
+    let
+        ty                   = pFst $ coercionKind co
+        (tvs, fun_ty)        = tcSplitForAllTys ty
+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
+
+    ccall_uniq <- newUnique
+    dflags <- getDynFlags
+    let
+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
+        rhs      = mkLams tvs (mkLams args call_app)
+        rhs'     = Cast rhs co
+    return ([(fn_id, rhs')], empty, empty)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign export}
+*                                                                      *
+************************************************************************
+
+The function that does most of the work for `@foreign export@' declarations.
+(see below for the boilerplate code a `@foreign export@' declaration expands
+ into.)
+
+For each `@foreign export foo@' in a module M we generate:
+\begin{itemize}
+\item a C function `@foo@', which calls
+\item a Haskell stub `@M.\$ffoo@', which calls
+\end{itemize}
+the user-written Haskell function `@M.foo@'.
+-}
+
+dsFExport :: Id                 -- Either the exported Id,
+                                -- or the foreign-export-dynamic constructor
+          -> Coercion           -- Coercion between the Haskell type callable
+                                -- from C, and its representation type
+          -> CLabelString       -- The name to export to C land
+          -> CCallConv
+          -> Bool               -- True => foreign export dynamic
+                                --         so invoke IO action that's hanging off
+                                --         the first argument's stable pointer
+          -> DsM ( SDoc         -- contents of Module_stub.h
+                 , SDoc         -- contents of Module_stub.c
+                 , String       -- string describing type to pass to createAdj.
+                 , Int          -- size of args to stub function
+                 )
+
+dsFExport fn_id co ext_name cconv isDyn = do
+    let
+       ty                     = pSnd $ coercionKind co
+       (bndrs, orig_res_ty)   = tcSplitPiTys ty
+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
+       -- We must use tcSplits here, because we want to see
+       -- the (IO t) in the corner of the type!
+       fe_arg_tys | isDyn     = tail fe_arg_tys'
+                  | otherwise = fe_arg_tys'
+
+       -- Look at the result type of the exported function, orig_res_ty
+       -- If it's IO t, return         (t, True)
+       -- If it's plain t, return      (t, False)
+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
+                                -- The function already returns IO t
+                                Just (_ioTyCon, res_ty) -> (res_ty, True)
+                                -- The function returns t
+                                Nothing                 -> (orig_res_ty, False)
+
+    dflags <- getDynFlags
+    return $
+      mkFExportCBits dflags ext_name
+                     (if isDyn then Nothing else Just fn_id)
+                     fe_arg_tys res_ty is_IO_res_ty cconv
+
+{-
+@foreign import "wrapper"@ (previously "foreign export dynamic") lets
+you dress up Haskell IO actions of some fixed type behind an
+externally callable interface (i.e., as a C function pointer). Useful
+for callbacks and stuff.
+
+\begin{verbatim}
+type Fun = Bool -> Int -> IO Int
+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
+
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
+
+f :: Fun -> IO (FunPtr Fun)
+f cback =
+   bindIO (newStablePtr cback)
+          (\StablePtr sp# -> IO (\s1# ->
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
+                 (# s2#, a# #) -> (# s2#, A# a# #)))
+
+foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
+
+-- and the helper in C: (approximately; see `mkFExportCBits` below)
+
+f_helper(StablePtr s, HsBool b, HsInt i)
+{
+        Capability *cap;
+        cap = rts_lock();
+        rts_evalIO(&cap,
+                   rts_apply(rts_apply(deRefStablePtr(s),
+                                       rts_mkBool(b)), rts_mkInt(i)));
+        rts_unlock(cap);
+}
+\end{verbatim}
+-}
+
+dsFExportDynamic :: Id
+                 -> Coercion
+                 -> CCallConv
+                 -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic id co0 cconv = do
+    mod <- getModule
+    dflags <- getDynFlags
+    let fe_nm = mkFastString $ zEncodeString
+            (moduleStableString mod ++ "$" ++ toCName dflags id)
+        -- Construct the label based on the passed id, don't use names
+        -- depending on Unique. See #13807 and Note [Unique Determinism].
+    cback <- newSysLocalDs arg_ty
+    newStablePtrId <- dsLookupGlobalId newStablePtrName
+    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
+    let
+        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
+        export_ty     = mkVisFunTy stable_ptr_ty arg_ty
+    bindIOId <- dsLookupGlobalId bindIOName
+    stbl_value <- newSysLocalDs stable_ptr_ty
+    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
+    let
+         {-
+          The arguments to the external function which will
+          create a little bit of (template) code on the fly
+          for allowing the (stable pointed) Haskell closure
+          to be entered using an external calling convention
+          (stdcall, ccall).
+         -}
+        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)
+                        , Var stbl_value
+                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
+                        , Lit (mkLitString typestring)
+                        ]
+          -- name of external entry point providing these services.
+          -- (probably in the RTS.)
+        adjustor   = fsLit "createAdjustor"
+
+          -- Determine the number of bytes of arguments to the stub function,
+          -- so that we can attach the '@N' suffix to its label if it is a
+          -- stdcall on Windows.
+        mb_sz_args = case cconv of
+                        StdCallConv -> Just args_size
+                        _           -> Nothing
+
+    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
+        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
+
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkApps (Var bindIOId)
+                        [ Type stable_ptr_ty
+                        , Type res_ty
+                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+                        , Lam stbl_value ccall_adj
+                        ]
+
+        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
+               -- Never inline the f.e.d. function, because the litlit
+               -- might not be in scope in other modules.
+
+    return ([fed], h_code, c_code)
+
+ where
+  ty                       = pFst (coercionKind co0)
+  (tvs,sans_foralls)       = tcSplitForAllTys ty
+  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
+        -- Must have an IO type; hence Just
+
+
+toCName :: DynFlags -> Id -> String
+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
+
+{-
+*
+
+\subsection{Generating @foreign export@ stubs}
+
+*
+
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function
+using the hugs/ghc rts invocation API.
+-}
+
+mkFExportCBits :: DynFlags
+               -> FastString
+               -> Maybe Id      -- Just==static, Nothing==dynamic
+               -> [Type]
+               -> Type
+               -> Bool          -- True <=> returns an IO type
+               -> CCallConv
+               -> (SDoc,
+                   SDoc,
+                   String,      -- the argument reps
+                   Int          -- total size of arguments
+                  )
+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
+ = (header_bits, c_bits, type_string,
+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
+         -- NB. the calculation here isn't strictly speaking correct.
+         -- We have a primitive Haskell type (eg. Int#, Double#), and
+         -- we want to know the size, when passed on the C stack, of
+         -- the associated C type (eg. HsInt, HsDouble).  We don't have
+         -- this information to hand, but we know what GHC's conventions
+         -- are for passing around the primitive Haskell types, so we
+         -- use that instead.  I hope the two coincide --SDM
+    )
+ where
+  -- list the arguments to the C function
+  arg_info :: [(SDoc,           -- arg name
+                SDoc,           -- C type
+                Type,           -- Haskell type
+                CmmType)]       -- the CmmType
+  arg_info  = [ let stg_type = showStgType ty in
+                (arg_cname n stg_type,
+                 stg_type,
+                 ty,
+                 typeCmmType dflags (getPrimTyOf ty))
+              | (ty,n) <- zip arg_htys [1::Int ..] ]
+
+  arg_cname n stg_ty
+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
+                      text "args" <> brackets (int (n-1))
+        | otherwise = text ('a':show n)
+
+  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
+  libffi = sLibFFI (settings dflags) && isNothing maybe_target
+
+  type_string
+      -- libffi needs to know the result type too:
+      | libffi    = primTyDescChar dflags res_hty : arg_type_string
+      | otherwise = arg_type_string
+
+  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
+                -- just the real args
+
+  -- add some auxiliary args; the stable ptr in the wrapper case, and
+  -- a slot for the dummy return address in the wrapper + ccall case
+  aug_arg_info
+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
+    | otherwise              = arg_info
+
+  stable_ptr_arg =
+        (text "the_stableptr", text "StgStablePtr", undefined,
+         typeCmmType dflags (mkStablePtrPrimTy alphaTy))
+
+  -- stuff to do with the return type of the C function
+  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
+
+  cResType | res_hty_is_unit = text "void"
+           | otherwise       = showStgType res_hty
+
+  -- when the return type is integral and word-sized or smaller, it
+  -- must be assigned as type ffi_arg (#3516).  To see what type
+  -- libffi is expecting here, take a look in its own testsuite, e.g.
+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
+  ffi_cResType
+     | is_ffi_arg_type = text "ffi_arg"
+     | otherwise       = cResType
+     where
+       res_ty_key = getUnique (getName (typeTyCon res_hty))
+       is_ffi_arg_type = res_ty_key `notElem`
+              [floatTyConKey, doubleTyConKey,
+               int64TyConKey, word64TyConKey]
+
+  -- Now we can cook up the prototype for the exported function.
+  pprCconv = ccallConvAttribute cc
+
+  header_bits = text "extern" <+> fun_proto <> semi
+
+  fun_args
+    | null aug_arg_info = text "void"
+    | otherwise         = hsep $ punctuate comma
+                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
+
+  fun_proto
+    | libffi
+      = text "void" <+> ftext c_nm <>
+          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
+    | otherwise
+      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
+
+  -- the target which will form the root of what we ask rts_evalIO to run
+  the_cfun
+     = case maybe_target of
+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+
+  cap = text "cap" <> comma
+
+  -- the expression we give to rts_evalIO
+  expr_to_run
+     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
+       where
+          appArg acc (arg_cname, _, arg_hty, _)
+             = text "rts_apply"
+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+  -- various other bits for inside the fn
+  declareResult = text "HaskellObj ret;"
+  declareCResult | res_hty_is_unit = empty
+                 | otherwise       = cResType <+> text "cret;"
+
+  assignCResult | res_hty_is_unit = empty
+                | otherwise       =
+                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+  -- an extern decl for the fn being called
+  extern_decl
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+
+  -- finally, the whole darn thing
+  c_bits =
+    space $$
+    extern_decl $$
+    fun_proto  $$
+    vcat
+     [ lbrace
+     ,   text "Capability *cap;"
+     ,   declareResult
+     ,   declareCResult
+     ,   text "cap = rts_lock();"
+          -- create the application + perform it.
+     ,   text "rts_evalIO" <> parens (
+                char '&' <> cap <>
+                text "rts_apply" <> parens (
+                    cap <>
+                    text "(HaskellObj)"
+                 <> ptext (if is_IO_res_ty
+                                then (sLit "runIO_closure")
+                                else (sLit "runNonIO_closure"))
+                 <> comma
+                 <> expr_to_run
+                ) <+> comma
+               <> text "&ret"
+             ) <> semi
+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+                                                <> comma <> text "cap") <> semi
+     ,   assignCResult
+     ,   text "rts_unlock(cap);"
+     ,   ppUnless res_hty_is_unit $
+         if libffi
+                  then char '*' <> parens (ffi_cResType <> char '*') <>
+                       text "resp = cret;"
+                  else text "return cret;"
+     , rbrace
+     ]
+
+
+foreignExportInitialiser :: Id -> SDoc
+foreignExportInitialiser hs_fn =
+   -- Initialise foreign exports by registering a stable pointer from an
+   -- __attribute__((constructor)) function.
+   -- The alternative is to do this from stginit functions generated in
+   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
+   -- on binary sizes and link times because the static linker will think that
+   -- all modules that are imported directly or indirectly are actually used by
+   -- the program.
+   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+   vcat
+    [ text "static void stginit_export_" <> ppr hs_fn
+         <> text "() __attribute__((constructor));"
+    , text "static void stginit_export_" <> ppr hs_fn <> text "()"
+    , braces (text "foreignExportStablePtr"
+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+       <> semi)
+    ]
+
+
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> text (showFFIType t)
+
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> text (showFFIType t)
+
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
+showFFIType :: Type -> String
+showFFIType t = getOccString (getName (typeTyCon t))
+
+toCType :: Type -> (Maybe Header, SDoc)
+toCType = f False
+    where f voidOK t
+           -- First, if we have (Ptr t) of (FunPtr t), then we need to
+           -- convert t to a C type and put a * after it. If we don't
+           -- know a type for t, then "void" is fine, though.
+           | Just (ptr, [t']) <- splitTyConApp_maybe t
+           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
+              = case f True t' of
+                (mh, cType') ->
+                    (mh, cType' <> char '*')
+           -- Otherwise, if we have a type constructor application, then
+           -- see if there is a C type associated with that constructor.
+           -- Note that we aren't looking through type synonyms or
+           -- anything, as it may be the synonym that is annotated.
+           | Just tycon <- tyConAppTyConPicky_maybe t
+           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
+              = (mHeader, ftext cType)
+           -- If we don't know a C type for this type, then try looking
+           -- through one layer of type synonym etc.
+           | Just t' <- coreView t
+              = f voidOK t'
+           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
+           -- (which is marshalled like a Ptr)
+           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
+              = (Nothing, text "const void*")
+           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
+              = (Nothing, text "void*")
+           -- Otherwise we don't know the C type. If we are allowing
+           -- void then return that; otherwise something has gone wrong.
+           | voidOK = (Nothing, text "void")
+           | otherwise
+              = pprPanic "toCType" (ppr t)
+
+typeTyCon :: Type -> TyCon
+typeTyCon ty
+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
+  = tc
+  | otherwise
+  = pprPanic "DsForeign.typeTyCon" (ppr ty)
+
+insertRetAddr :: DynFlags -> CCallConv
+              -> [(SDoc, SDoc, Type, CmmType)]
+              -> [(SDoc, SDoc, Type, CmmType)]
+insertRetAddr dflags CCallConv args
+    = case platformArch platform of
+      ArchX86_64
+       | platformOS platform == OSMinGW32 ->
+          -- On other Windows x86_64 we insert the return address
+          -- after the 4th argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 4 args = ret_addr_arg dflags : args
+              go n (arg:args) = arg : go (n+1) args
+              go _ [] = []
+          in go 0 args
+       | otherwise ->
+          -- On other x86_64 platforms we insert the return address
+          -- after the 6th integer argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 6 args = ret_addr_arg dflags : args
+              go n (arg@(_,_,_,rep):args)
+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
+               | otherwise  = arg : go n     args
+              go _ [] = []
+          in go 0 args
+      _ ->
+          ret_addr_arg dflags : args
+    where platform = targetPlatform dflags
+insertRetAddr _ _ args = args
+
+ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
+ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
+                       typeCmmType dflags addrPrimTy)
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#).
+getPrimTyOf :: Type -> UnaryType
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitDataProductType_maybe rep_ty of
+     Just (_, _, data_con, [prim_ty]) ->
+        ASSERT(dataConSourceArity data_con == 1)
+        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
+        prim_ty
+     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
+  where
+        rep_ty = unwrapType ty
+
+-- represent a primitive type as a Char, for building a string that
+-- described the foreign function type.  The types are size-dependent,
+-- e.g. 'W' is a signed 32-bit integer.
+primTyDescChar :: DynFlags -> Type -> Char
+primTyDescChar dflags ty
+ | ty `eqType` unitTy = 'v'
+ | otherwise
+ = case typePrimRep1 (getPrimTyOf ty) of
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> 'L'
+     Word64Rep   -> 'l'
+     AddrRep     -> 'p'
+     FloatRep    -> 'f'
+     DoubleRep   -> 'd'
+     _           -> pprPanic "primTyDescChar" (ppr ty)
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = ('W','w')
+       | wORD_SIZE dflags == 8  = ('L','l')
+       | otherwise              = panic "primTyDescChar"
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -0,0 +1,150 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Matching guarded right-hand-sides (GRHSs)
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} Match   ( matchSinglePatVar )
+
+import HsSyn
+import MkCore
+import CoreSyn
+import CoreUtils (bindNonRec)
+
+import Check (genCaseTmCs2)
+import DsMonad
+import DsUtils
+import Type   ( Type )
+import Name
+import Util
+import SrcLoc
+import Outputable
+
+{-
+@dsGuarded@ is used for pattern bindings.
+It desugars:
+\begin{verbatim}
+        | g1 -> e1
+        ...
+        | gn -> en
+        where binds
+\end{verbatim}
+producing an expression with a runtime error in the corner if
+necessary.  The type argument gives the type of the @ei@.
+-}
+
+dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
+dsGuarded grhss rhs_ty = do
+    match_result <- dsGRHSs PatBindRhs grhss rhs_ty
+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
+    extractMatchResult match_result error_expr
+
+-- In contrast, @dsGRHSs@ produces a @MatchResult@.
+
+dsGRHSs :: HsMatchContext Name
+        -> GRHSs GhcTc (LHsExpr GhcTc)          -- Guarded RHSs
+        -> Type                                 -- Type of RHS
+        -> DsM MatchResult
+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
+  = ASSERT( notNull grhss )
+    do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
+       ; let match_result1 = foldr1 combineMatchResults match_results
+             match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+                             -- NB: nested dsLet inside matchResult
+       ; return match_result2 }
+dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
+
+dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
+       -> DsM MatchResult
+dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
+  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
+dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"
+dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
+
+{-
+************************************************************************
+*                                                                      *
+*  matchGuard : make a MatchResult from a guarded RHS                  *
+*                                                                      *
+************************************************************************
+-}
+
+matchGuards :: [GuardStmt GhcTc]     -- Guard
+            -> HsStmtContext Name    -- Context
+            -> LHsExpr GhcTc         -- RHS
+            -> Type                  -- Type of RHS of guard
+            -> DsM MatchResult
+
+-- See comments with HsExpr.Stmt re what a BodyStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)
+
+matchGuards [] _ rhs _
+  = do  { core_rhs <- dsLExpr rhs
+        ; return (cantFailMatchResult core_rhs) }
+
+        -- BodyStmts must be guards
+        -- Turn an "otherwise" guard is a no-op.  This ensures that
+        -- you don't get a "non-exhaustive eqns" message when the guards
+        -- finish in "otherwise".
+        -- NB:  The success of this clause depends on the typechecker not
+        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
+        --      If it does, you'll get bogus overlap warnings
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
+  | Just addTicks <- isTrueLHsExpr e = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    return (adjustMatchResultDs addTicks match_result)
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    pred_expr <- dsLExpr expr
+    return (mkGuardedMatchResult pred_expr match_result)
+
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    return (adjustMatchResultDs (dsLocalBinds binds) match_result)
+        -- NB the dsLet occurs inside the match_result
+        -- Reason: dsLet takes the body expression as its argument
+        --         so we can't desugar the bindings without the
+        --         body expression in hand
+
+matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
+    let upat = unLoc pat
+        dicts = collectEvVarsPat upat
+    match_var <- selectMatchVar upat
+    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
+    match_result <- addDictsDs dicts $
+                    addTmCsDs tm_cs  $
+                      -- See Note [Type and Term Equality Propagation] in Check
+                    matchGuards stmts ctx rhs rhs_ty
+    core_rhs <- dsLExpr bind_rhs
+    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
+                                       match_result
+    pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
+
+matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
+matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
+matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"
+matchGuards (ApplicativeStmt {} : _) _ _ _ =
+  panic "matchGuards ApplicativeLastStmt"
+matchGuards (XStmtLR {} : _) _ _ _ =
+  panic "matchGuards XStmtLR"
+
+{-
+Should {\em fail} if @e@ returns @D@
+\begin{verbatim}
+f x | p <- e', let C y# = e, f y# = r1
+    | otherwise          = r2
+\end{verbatim}
+-}
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsListComp.hs
@@ -0,0 +1,693 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring list comprehensions, monad comprehensions and array comprehensions
+-}
+
+{-# LANGUAGE CPP, NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsListComp ( dsListComp, dsMonadComp ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+
+import HsSyn
+import TcHsSyn
+import CoreSyn
+import MkCore
+
+import DsMonad          -- the monadery used in the desugarer
+import DsUtils
+
+import DynFlags
+import CoreUtils
+import Id
+import Type
+import TysWiredIn
+import Match
+import PrelNames
+import SrcLoc
+import Outputable
+import TcType
+import ListSetOps( getNth )
+import Util
+
+{-
+List comprehensions may be desugared in one of two ways: ``ordinary''
+(as you would expect if you read SLPJ's book) and ``with foldr/build
+turned on'' (if you read Gill {\em et al.}'s paper on the subject).
+
+There will be at least one ``qualifier'' in the input.
+-}
+
+dsListComp :: [ExprLStmt GhcTc]
+           -> Type              -- Type of entire list
+           -> DsM CoreExpr
+dsListComp lquals res_ty = do
+    dflags <- getDynFlags
+    let quals = map unLoc lquals
+        elt_ty = case tcTyConAppArgs res_ty of
+                   [elt_ty] -> elt_ty
+                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
+
+    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
+       -- Either rules are switched off, or we are ignoring what there are;
+       -- Either way foldr/build won't happen, so use the more efficient
+       -- Wadler-style desugaring
+       || isParallelComp quals
+       -- Foldr-style desugaring can't handle parallel list comprehensions
+        then deListComp quals (mkNilExpr elt_ty)
+        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
+             -- Foldr/build should be enabled, so desugar
+             -- into foldrs and builds
+
+  where
+    -- We must test for ParStmt anywhere, not just at the head, because an extension
+    -- to list comprehensions would be to add brackets to specify the associativity
+    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
+    -- mix of possibly a single element in length, so we do this to leave the possibility open
+    isParallelComp = any isParallelStmt
+
+    isParallelStmt (ParStmt {}) = True
+    isParallelStmt _            = False
+
+
+-- This function lets you desugar a inner list comprehension and a list of the binders
+-- of that comprehension that we need in the outer comprehension into such an expression
+-- and the type of the elements that it outputs (tuples of binders)
+dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
+dsInnerListComp (ParStmtBlock _ stmts bndrs _)
+  = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
+             list_ty          = mkListTy bndrs_tuple_type
+
+             -- really use original bndrs below!
+       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
+
+       ; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
+
+-- This function factors out commonality between the desugaring strategies for GroupStmt.
+-- Given such a statement it gives you back an expression representing how to compute the transformed
+-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
+dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc)
+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
+                       , trS_by = by, trS_using = using }) = do
+    let (from_bndrs, to_bndrs) = unzip binderMap
+
+    let from_bndrs_tys  = map idType from_bndrs
+        to_bndrs_tys    = map idType to_bndrs
+
+        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
+
+    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+                                                        from_bndrs noSyntaxExpr)
+
+    -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+    -- function required? If so, create that desugared function and add to arguments
+    usingExpr' <- dsLExpr using
+    usingArgs' <- case by of
+                    Nothing   -> return [expr']
+                    Just by_e -> do { by_e' <- dsLExpr by_e
+                                    ; lam' <- matchTuple from_bndrs by_e'
+                                    ; return [lam', expr'] }
+
+    -- Create an unzip function for the appropriate arity and element types and find "map"
+    unzip_stuff' <- mkUnzipBind form from_bndrs_tys
+    map_id <- dsLookupGlobalId mapName
+
+    -- Generate the expressions to build the grouped list
+    let -- First we apply the grouping function to the inner list
+        inner_list_expr' = mkApps usingExpr' usingArgs'
+        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
+        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
+        -- the "b" to be a tuple of "to" lists!
+        -- Then finally we bind the unzip function around that expression
+        bound_unzipped_inner_list_expr'
+          = case unzip_stuff' of
+              Nothing -> inner_list_expr'
+              Just (unzip_fn', unzip_rhs') ->
+                Let (Rec [(unzip_fn', unzip_rhs')]) $
+                mkApps (Var map_id) $
+                [ Type (mkListTy from_tup_ty)
+                , Type to_bndrs_tup_ty
+                , Var unzip_fn'
+                , inner_list_expr' ]
+
+    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
+      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
+
+    -- Build a pattern that ensures the consumer binds into the NEW binders,
+    -- which hold lists rather than single values
+    let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!
+    return (bound_unzipped_inner_list_expr', pat)
+
+dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
+*                                                                      *
+************************************************************************
+
+Just as in Phil's chapter~7 in SLPJ, using the rules for
+optimally-compiled list comprehensions.  This is what Kevin followed
+as well, and I quite happily do the same.  The TQ translation scheme
+transforms a list of qualifiers (either boolean expressions or
+generators) into a single expression which implements the list
+comprehension.  Because we are generating 2nd-order polymorphic
+lambda-calculus, calls to NIL and CONS must be applied to a type
+argument, as well as their usual value arguments.
+\begin{verbatim}
+TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
+
+(Rule C)
+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
+
+(Rule B)
+TQ << [ e | b , qs ] ++ L >> =
+    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
+
+(Rule A')
+TQ << [ e | p <- L1, qs ]  ++  L2 >> =
+  letrec
+    h = \ u1 ->
+          case u1 of
+            []        ->  TE << L2 >>
+            (u2 : u3) ->
+                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
+                    [] (h u3)
+  in
+    h ( TE << L1 >> )
+
+"h", "u1", "u2", and "u3" are new variables.
+\end{verbatim}
+
+@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
+is the TE translation scheme.  Note that we carry around the @L@ list
+already desugared.  @dsListComp@ does the top TE rule mentioned above.
+
+To the above, we add an additional rule to deal with parallel list
+comprehensions.  The translation goes roughly as follows:
+     [ e | p1 <- e11, let v1 = e12, p2 <- e13
+         | q1 <- e21, let v2 = e22, q2 <- e23]
+     =>
+     [ e | ((x1, .., xn), (y1, ..., ym)) <-
+               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
+                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
+where (x1, .., xn) are the variables bound in p1, v1, p2
+      (y1, .., ym) are the variables bound in q1, v2, q2
+
+In the translation below, the ParStmt branch translates each parallel branch
+into a sub-comprehension, and desugars each independently.  The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
+-}
+
+deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
+
+deListComp [] _ = panic "deListComp"
+
+deListComp (LastStmt _ body _ _ : quals) list
+  =     -- Figure 7.4, SLPJ, p 135, rule C above
+    ASSERT( null quals )
+    do { core_body <- dsLExpr body
+       ; return (mkConsExpr (exprType core_body) core_body list) }
+
+        -- Non-last: must be a guard
+deListComp (BodyStmt _ guard _ _ : quals) list = do  -- rule B above
+    core_guard <- dsLExpr guard
+    core_rest <- deListComp quals list
+    return (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt _ binds : quals) list = do
+    core_rest <- deListComp quals list
+    dsLocalBinds binds core_rest
+
+deListComp (stmt@(TransStmt {}) : quals) list = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    deBindComp pat inner_list_expr quals list
+
+deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
+    core_list1 <- dsLExprNoLP list1
+    deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
+  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+       ; let (exps, qual_tys) = unzip exps_and_qual_tys
+
+       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+        -- Deal with [e | pat <- zip l1 .. ln] in example above
+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+                    quals list }
+  where
+        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
+
+        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+        pat  = mkBigLHsPatTupId pats
+        pats = map mkBigLHsVarPatTupId bndrs_s
+
+deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
+
+deListComp (ApplicativeStmt {} : _) _ =
+  panic "deListComp ApplicativeStmt"
+
+deListComp (XStmtLR {} : _) _ =
+  panic "deListComp XStmtLR"
+
+deBindComp :: OutPat GhcTc
+           -> CoreExpr
+           -> [ExprStmt GhcTc]
+           -> CoreExpr
+           -> DsM (Expr Id)
+deBindComp pat core_list1 quals core_list2 = do
+    let u3_ty@u1_ty = exprType core_list1       -- two names, same thing
+
+        -- u1_ty is a [alpha] type, and u2_ty = alpha
+    let u2_ty = hsLPatType pat
+
+    let res_ty = exprType core_list2
+        h_ty   = u1_ty `mkVisFunTy` res_ty
+
+       -- no levity polymorphism here, as list comprehensions don't work
+       -- with RebindableSyntax. NB: These are *not* monad comps.
+    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
+
+    -- the "fail" value ...
+    let
+        core_fail   = App (Var h) (Var u3)
+        letrec_body = App (Var h) core_list1
+
+    rest_expr <- deListComp quals core_fail
+    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
+
+    let
+        rhs = Lam u1 $
+              Case (Var u1) u1 res_ty
+                   [(DataAlt nilDataCon,  [],       core_list2),
+                    (DataAlt consDataCon, [u2, u3], core_match)]
+                        -- Increasing order of tag
+
+    return (Let (Rec [(h, rhs)]) letrec_body)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
+*                                                                      *
+************************************************************************
+
+@dfListComp@ are the rules used with foldr/build turned on:
+
+\begin{verbatim}
+TE[ e | ]            c n = c e n
+TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let
+                                f = \ x b -> case x of
+                                                  p -> TE[ e | q ] c b
+                                                  _ -> b
+                           in
+                           foldr f n l
+\end{verbatim}
+-}
+
+dfListComp :: Id -> Id            -- 'c' and 'n'
+           -> [ExprStmt GhcTc]    -- the rest of the qual's
+           -> DsM CoreExpr
+
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt _ body _ _ : quals)
+  = ASSERT( null quals )
+    do { core_body <- dsLExprNoLP body
+       ; return (mkApps (Var c_id) [core_body, Var n_id]) }
+
+        -- Non-last: must be a guard
+dfListComp c_id n_id (BodyStmt _ guard _ _  : quals) = do
+    core_guard <- dsLExpr guard
+    core_rest <- dfListComp c_id n_id quals
+    return (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt _ binds : quals) = do
+    -- new in 1.3, local bindings
+    core_rest <- dfListComp c_id n_id quals
+    dsLocalBinds binds core_rest
+
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    -- Anyway, we bind the newly grouped list via the generic binding function
+    dfBindComp c_id n_id (pat, inner_list_expr) quals
+
+dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
+    -- evaluate the two lists
+    core_list1 <- dsLExpr list1
+
+    -- Do the rest of the work in the generic binding builder
+    dfBindComp c_id n_id (pat, core_list1) quals
+
+dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
+dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
+dfListComp _ _ (ApplicativeStmt {} : _) =
+  panic "dfListComp ApplicativeStmt"
+dfListComp _ _ (XStmtLR {} : _) =
+  panic "dfListComp XStmtLR"
+
+dfBindComp :: Id -> Id             -- 'c' and 'n'
+           -> (LPat GhcTc, CoreExpr)
+           -> [ExprStmt GhcTc]     -- the rest of the qual's
+           -> DsM CoreExpr
+dfBindComp c_id n_id (pat, core_list1) quals = do
+    -- find the required type
+    let x_ty   = hsLPatType pat
+    let b_ty   = idType n_id
+
+    -- create some new local id's
+    b <- newSysLocalDs b_ty
+    x <- newSysLocalDs x_ty
+
+    -- build rest of the comprehesion
+    core_rest <- dfListComp c_id b quals
+
+    -- build the pattern match
+    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
+                pat core_rest (Var b)
+
+    -- now build the outermost foldr, and return
+    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
+*                                                                      *
+************************************************************************
+-}
+
+mkZipBind :: [Type] -> DsM (Id, CoreExpr)
+-- mkZipBind [t1, t2]
+-- = (zip, \as1:[t1] as2:[t2]
+--         -> case as1 of
+--              [] -> []
+--              (a1:as'1) -> case as2 of
+--                              [] -> []
+--                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
+
+mkZipBind elt_tys = do
+    ass  <- mapM newSysLocalDs  elt_list_tys
+    as'  <- mapM newSysLocalDs  elt_tys
+    as's <- mapM newSysLocalDs  elt_list_tys
+
+    zip_fn <- newSysLocalDs zip_fn_ty
+
+    let inner_rhs = mkConsExpr elt_tuple_ty
+                        (mkBigCoreVarTup as')
+                        (mkVarApps (Var zip_fn) as's)
+        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
+
+    return (zip_fn, mkLams ass zip_body)
+  where
+    elt_list_tys      = map mkListTy elt_tys
+    elt_tuple_ty      = mkBigCoreTupTy elt_tys
+    elt_tuple_list_ty = mkListTy elt_tuple_ty
+
+    zip_fn_ty         = mkVisFunTys elt_list_tys elt_tuple_list_ty
+
+    mk_case (as, a', as') rest
+          = Case (Var as) as elt_tuple_list_ty
+                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),
+                   (DataAlt consDataCon, [a', as'], rest)]
+                        -- Increasing order of tag
+
+
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
+-- mkUnzipBind [t1, t2]
+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
+--     -> case ax of
+--      (x1, x2) -> case axs of
+--                (xs1, xs2) -> (x1 : xs1, x2 : xs2))
+--      ([], [])
+--      ys)
+--
+-- We use foldr here in all cases, even if rules are turned off, because we may as well!
+mkUnzipBind ThenForm _
+ = return Nothing    -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys
+  = do { ax  <- newSysLocalDs elt_tuple_ty
+       ; axs <- newSysLocalDs elt_list_tuple_ty
+       ; ys  <- newSysLocalDs elt_tuple_list_ty
+       ; xs  <- mapM newSysLocalDs elt_tys
+       ; xss <- mapM newSysLocalDs elt_list_tys
+
+       ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+             tupled_concat_expression = mkBigCoreTup concat_expressions
+
+             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+             folder_body = mkLams [ax, axs] folder_body_outer_case
+
+       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
+  where
+    elt_tuple_ty       = mkBigCoreTupTy elt_tys
+    elt_tuple_list_ty  = mkListTy elt_tuple_ty
+    elt_list_tys       = map mkListTy elt_tys
+    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys
+
+    unzip_fn_ty        = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty
+
+    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
+
+-- Translation for monad comprehensions
+
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsMcStmts []                          = panic "dsMcStmts"
+dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
+
+dsMcStmt (LastStmt _ body _ ret_op) stmts
+  = ASSERT( null stmts )
+    do { body' <- dsLExpr body
+       ; dsSyntaxExpr ret_op [body'] }
+
+--   [ .. | let binds, stmts ]
+dsMcStmt (LetStmt _ binds) stmts
+  = do { rest <- dsMcStmts stmts
+       ; dsLocalBinds binds rest }
+
+--   [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
+  = do { rhs' <- dsLExpr rhs
+       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+--   [ .. | exp, stmts ]
+--
+dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
+  = do { exp'       <- dsLExpr exp
+       ; rest       <- dsMcStmts stmts
+       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
+       ; dsSyntaxExpr then_exp [guard_exp', rest] }
+
+-- Group statements desugar like this:
+--
+--   [| (q, then group by e using f); rest |]
+--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+--         case unzip n_tup of qv' -> [| rest |]
+--
+-- where   variables (v1:t1, ..., vk:tk) are bound by q
+--         qv = (v1, ..., vk)
+--         qt = (t1, ..., tk)
+--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+--         n_tup :: n qt
+--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+                    , trS_by = by, trS_using = using
+                    , trS_ret = return_op, trS_bind = bind_op
+                    , trS_ext = n_tup_ty'  -- n (a,b,c)
+                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+  = do { let (from_bndrs, to_bndrs) = unzip bndrs
+
+       ; let from_bndr_tys = map idType from_bndrs     -- Types ty
+
+
+       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
+
+       -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+       -- function required? If so, create that desugared function and add to arguments
+       ; usingExpr' <- dsLExpr using
+       ; usingArgs' <- case by of
+                         Nothing   -> return [expr']
+                         Just by_e -> do { by_e' <- dsLExpr by_e
+                                         ; lam' <- matchTuple from_bndrs by_e'
+                                         ; return [lam', expr'] }
+
+       -- Generate the expressions to build the grouped list
+       -- Build a pattern that ensures the consumer binds into the NEW binders,
+       -- which hold monads rather than single values
+       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
+
+       ; body        <- dsMcStmts stmts_rest
+       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'
+       ; tup_n_var'  <- newSysLocalDs tup_n_ty'
+       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
+       ; us          <- newUniqueSupply
+       ; let rhs'  = mkApps usingExpr' usingArgs'
+             body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
+
+       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+--   [ body | qs1 | qs2 | qs3 ]
+--     ->  [ body | (bndrs1, (bndrs2, bndrs3))
+--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+--   mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
+ = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
+       ; mzip_op'    <- dsExpr mzip_op
+
+       ; let -- The pattern variables
+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
+             -- Pattern with tuples of variables
+             -- [v1,v2,v3]  =>  (v1, (v2, v3))
+             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+                                  mkBoxedTupleTy [t1,t2]))
+                               exps_w_tys
+
+       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
+  where
+    ds_inner (ParStmtBlock _ stmts bndrs return_op)
+       = do { exp <- dsInnerMonadComp stmts bndrs return_op
+            ; return (exp, mkBigCoreVarTupTy bndrs) }
+    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+--       returns the Core term
+--  \x. case x of (a,b,c) -> body
+matchTuple ids body
+  = do { us <- newUniqueSupply
+       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat GhcTc
+             -> CoreExpr        -- ^ the desugared rhs of the bind statement
+             -> SyntaxExpr GhcTc
+             -> SyntaxExpr GhcTc
+             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T
+             -> [ExprLStmt GhcTc]
+             -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
+  = do  { body     <- dsMcStmts stmts
+        ; var      <- selectSimpleMatchVarL pat
+        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                  res1_ty (cantFailMatchResult body)
+        ; match_code <- handle_failure pat match fail_op
+        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+  where
+    -- In a monad comprehension expression, pattern-match failure just calls
+    -- the monadic `fail` rather than throwing an exception
+    handle_failure pat match fail_op
+      | matchCanFail match
+        = do { dflags <- getDynFlags
+             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+             ; extractMatchResult match fail_expr }
+      | otherwise
+        = extractMatchResult match (error "It can't fail")
+
+    mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+    mk_fail_msg dflags pat
+        = "Pattern match failure in monad comprehension at " ++
+          showPpr dflags (getLoc pat)
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+--    dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+--       [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [ExprLStmt GhcTc]
+                 -> [Id]               -- Return a tuple of these variables
+                 -> SyntaxExpr GhcTc   -- The monomorphic "return" operator
+                 -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+  = dsMcStmts (stmts ++
+                 [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])
+
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+--   unzip :: m (a,b,..) -> (m a,m b,..)
+--   unzip m_tuple = ( liftM selN1 m_tuple
+--                   , liftM selN2 m_tuple
+--                   , .. )
+--
+--   mkMcUnzipM fmap ys [t1, t2]
+--     = ( fmap (selN1 :: (t1, t2) -> t1) ys
+--       , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+           -> HsExpr GhcTcId    -- fmap
+           -> Id                -- Of type n (a,b,c)
+           -> [Type]            -- [a,b,c]   (not levity-polymorphic)
+           -> DsM CoreExpr      -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+  = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+  = do { fmap_op' <- dsExpr fmap_op
+       ; xs       <- mapM newSysLocalDs elt_tys
+       ; let tup_ty = mkBigCoreTupTy elt_tys
+       ; tup_xs   <- newSysLocalDs tup_ty
+
+       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b
+                           [ Type tup_ty, Type (getNth elt_tys i)
+                           , mk_sel i, Var ys]
+
+             mk_sel n = Lam tup_xs $
+                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
+
+       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsMeta.hs
@@ -0,0 +1,2738 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2006
+--
+-- The purpose of this module is to transform an HsExpr into a CoreExpr which
+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
+-- input HsExpr. We do this in the DsM monad, which supplies access to
+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames.  It's much more convenient to do it here, because
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
+-----------------------------------------------------------------------------
+
+module DsMeta( dsBracket ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   DsExpr ( dsExpr )
+
+import MatchLit
+import DsMonad
+
+import qualified Language.Haskell.TH as TH
+
+import HsSyn
+import PrelNames
+-- To avoid clashes with DsMeta.varName we must make a local alias for
+-- OccName.varName we do this by removing varName from the import of
+-- OccName above, making a qualified instance of OccName and using
+-- OccNameAlias.varName where varName ws previously used in this file.
+import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
+
+import Module
+import Id
+import Name hiding( isVarOcc, isTcOcc, varName, tcName )
+import THNames
+import NameEnv
+import TcType
+import TyCon
+import TysWiredIn
+import CoreSyn
+import MkCore
+import CoreUtils
+import SrcLoc
+import Unique
+import BasicTypes
+import Outputable
+import Bag
+import DynFlags
+import FastString
+import ForeignCall
+import Util
+import Maybes
+import MonadUtils
+
+import Data.ByteString ( unpack )
+import Control.Monad
+import Data.List
+
+-----------------------------------------------------------------------------
+dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
+-- Returns a CoreExpr of type TH.ExpQ
+-- The quoted thing is parameterised over Name, even though it has
+-- been type checked.  We don't want all those type decorations!
+
+dsBracket brack splices
+  = dsExtendMetaEnv new_bit (do_brack brack)
+  where
+    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
+                        | PendingTcSplice n e <- splices]
+
+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }
+    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
+
+{- -------------- Examples --------------------
+
+  [| \x -> x |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (var x1)
+
+
+  [| \x -> $(f [| x |]) |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (f (var x1))
+-}
+
+
+-------------------------------------------------------
+--                      Declarations
+-------------------------------------------------------
+
+repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)
+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
+                 ; pat' <- addBinds ss (repLP pat)
+                 ; wrapGenSyms ss pat' }
+
+repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
+repTopDs group@(HsGroup { hs_valds   = valds
+                        , hs_splcds  = splcds
+                        , hs_tyclds  = tyclds
+                        , hs_derivds = derivds
+                        , hs_fixds   = fixds
+                        , hs_defds   = defds
+                        , hs_fords   = fords
+                        , hs_warnds  = warnds
+                        , hs_annds   = annds
+                        , hs_ruleds  = ruleds
+                        , hs_docs    = docs })
+ = do { let { bndrs  = hsScopedTvBinders valds
+                       ++ hsGroupBinders group
+                       ++ hsPatSynSelectors valds
+            ; instds = tyclds >>= group_instds } ;
+        ss <- mkGenSyms bndrs ;
+
+        -- Bind all the names mainly to avoid repeated use of explicit strings.
+        -- Thus we get
+        --      do { t :: String <- genSym "T" ;
+        --           return (Data t [] ...more t's... }
+        -- The other important reason is that the output must mention
+        -- only "T", not "Foo:T" where Foo is the current module
+
+        decls <- addBinds ss (
+                  do { val_ds   <- rep_val_binds valds
+                     ; _        <- mapM no_splice splcds
+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
+                     ; inst_ds  <- mapM repInstD instds
+                     ; deriv_ds <- mapM repStandaloneDerivD derivds
+                     ; fix_ds   <- mapM repFixD fixds
+                     ; _        <- mapM no_default_decl defds
+                     ; for_ds   <- mapM repForD fords
+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
+                                                           warnds)
+                     ; ann_ds   <- mapM repAnnD annds
+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
+                                                            ruleds)
+                     ; _        <- mapM no_doc docs
+
+                        -- more needed
+                     ;  return (de_loc $ sort_by_loc $
+                                val_ds ++ catMaybes tycl_ds ++ role_ds
+                                       ++ (concat fix_ds)
+                                       ++ inst_ds ++ rule_ds ++ for_ds
+                                       ++ ann_ds ++ deriv_ds) }) ;
+
+        decl_ty <- lookupType decQTyConName ;
+        let { core_list = coreList' decl_ty decls } ;
+
+        dec_ty <- lookupType decTyConName ;
+        q_decs  <- repSequenceQ dec_ty core_list ;
+
+        wrapGenSyms ss q_decs
+      }
+  where
+    no_splice (dL->L loc _)
+      = notHandledL loc "Splices within declaration brackets" empty
+    no_default_decl (dL->L loc decl)
+      = notHandledL loc "Default declarations" (ppr decl)
+    no_warn (dL->L loc (Warning _ thing _))
+      = notHandledL loc "WARNING and DEPRECATION pragmas" $
+                    text "Pragma for declaration of" <+> ppr thing
+    no_warn _ = panic "repTopDs"
+    no_doc (dL->L loc _)
+      = notHandledL loc "Haddock documentation" empty
+repTopDs (XHsGroup _) = panic "repTopDs"
+
+hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
+-- See Note [Scoped type variables in bindings]
+hsScopedTvBinders binds
+  = concatMap get_scoped_tvs sigs
+  where
+    sigs = case binds of
+             ValBinds           _ _ sigs  -> sigs
+             XValBindsLR (NValBinds _ sigs) -> sigs
+
+get_scoped_tvs :: LSig GhcRn -> [Name]
+get_scoped_tvs (dL->L _ signature)
+  | TypeSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig (hswc_body sig)
+  | ClassOpSig _ _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | PatSynSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | otherwise
+  = []
+  where
+    get_scoped_tvs_from_sig sig
+      -- Both implicit and explicit quantified variables
+      -- We need the implicit ones for   f :: forall (a::k). blah
+      --    here 'k' scopes too
+      | HsIB { hsib_ext = implicit_vars
+             , hsib_body = hs_ty } <- sig
+      , (explicit_vars, _) <- splitLHsForAllTy hs_ty
+      = implicit_vars ++ hsLTyVarNames explicit_vars
+    get_scoped_tvs_from_sig (XHsImplicitBndrs _)
+      = panic "get_scoped_tvs_from_sig"
+
+{- Notes
+
+Note [Scoped type variables in bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall a. a -> a
+   f x = x::a
+Here the 'forall a' brings 'a' into scope over the binding group.
+To achieve this we
+
+  a) Gensym a binding for 'a' at the same time as we do one for 'f'
+     collecting the relevant binders with hsScopedTvBinders
+
+  b) When processing the 'forall', don't gensym
+
+The relevant places are signposted with references to this Note
+
+Note [Scoped type variables in class and instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Scoped type variables may occur in default methods and default
+signatures. We need to bring the type variables in 'foralls'
+into the scope of the method bindings.
+
+Consider
+   class Foo a where
+     foo :: forall (b :: k). a -> Proxy b -> Proxy b
+     foo _ x = (x :: Proxy b)
+
+We want to ensure that the 'b' in the type signature and the default
+implementation are the same, so we do the following:
+
+  a) Before desugaring the signature and binding of 'foo', use
+     get_scoped_tvs to collect type variables in 'forall' and
+     create symbols for them.
+  b) Use 'addBinds' to bring these symbols into the scope of the type
+     signatures and bindings.
+  c) Use these symbols to generate Core for the class/instance declaration.
+
+Note that when desugaring the signatures, we lookup the type variables
+from the scope rather than recreate symbols for them. See more details
+in "rep_ty_sig" and in Trac#14885.
+
+Note [Binders and occurrences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+        Data "T" [] [Con "MkT" []] []
+and *not*
+        Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in.   We do *not* clone, though; no need for this:
+        Data "T79" ....
+
+But if we see this:
+        data T = MkT
+        foo = reifyDecl T
+
+then we must desugar to
+        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
+
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
+And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
+
+Note [Don't quantify implicit type variables in quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you're not careful, it's suprisingly easy to take this quoted declaration:
+
+  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
+      idProxy x = x
+    |]
+
+and have Template Haskell turn it into this:
+
+  idProxy :: forall k proxy (b :: k). proxy b -> proxy b
+  idProxy x = x
+
+Notice that we explicitly quantified the variable `k`! The latter declaration
+isn't what the user wrote in the first place.
+
+Usually, the culprit behind these bugs is taking implicitly quantified type
+variables (often from the hsib_vars field of HsImplicitBinders) and putting
+them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
+-}
+
+-- represent associated family instances
+--
+repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+
+repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $
+                                                  repFamilyDecl (L loc fam)
+
+repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repSynDecl tc1 bndrs rhs
+       ; return (Just (loc, dec)) }
+
+repTyClD (dL->L loc (DataDecl { tcdLName = tc
+                              , tcdTyVars = tvs
+                              , tcdDataDefn = defn }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repDataDefn tc1 (Left bndrs) defn
+       ; return (Just (loc, dec)) }
+
+repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+                             tcdTyVars = tvs, tcdFDs = fds,
+                             tcdSigs = sigs, tcdMeths = meth_binds,
+                             tcdATs = ats, tcdATDefs = atds }))
+  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
+       ; dec  <- addTyVarBinds tvs $ \bndrs ->
+           do { cxt1   <- repLContext cxt
+          -- See Note [Scoped type variables in class and instance declarations]
+              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
+              ; fds1   <- repLFunDeps fds
+              ; ats1   <- repFamilyDecls ats
+              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds
+              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
+              ; wrapGenSyms ss decls2 }
+       ; return $ Just (loc, dec)
+       }
+
+repTyClD _ = panic "repTyClD"
+
+-------------------------
+repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))
+  = do { tycon1 <- lookupLOcc tycon
+       ; roles1 <- mapM repRole roles
+       ; roles2 <- coreList roleTyConName roles1
+       ; dec <- repRoleAnnotD tycon1 roles2
+       ; return (loc, dec) }
+repRoleD _ = panic "repRoleD"
+
+-------------------------
+repDataDefn :: Core TH.Name
+            -> Either (Core [TH.TyVarBndrQ])
+                        -- the repTyClD case
+                      (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+                        -- the repDataFamInstD case
+            -> HsDataDefn GhcRn
+            -> DsM (Core TH.DecQ)
+repDataDefn tc opts
+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
+                      , dd_cons = cons, dd_derivs = mb_derivs })
+  = do { cxt1     <- repLContext cxt
+       ; derivs1  <- repDerivs mb_derivs
+       ; case (new_or_data, cons) of
+           (NewType, [con])  -> do { con'  <- repC con
+                                   ; ksig' <- repMaybeLTy ksig
+                                   ; repNewtype cxt1 tc opts ksig' con'
+                                                derivs1 }
+           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
+                                       <+> pprQuotedList
+                                       (getConNames $ unLoc $ head cons))
+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
+                               ; consL <- mapM repC cons
+                               ; cons1 <- coreList conQTyConName consL
+                               ; repData cxt1 tc opts ksig' cons1
+                                         derivs1 }
+       }
+repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
+
+repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
+           -> LHsType GhcRn
+           -> DsM (Core TH.DecQ)
+repSynDecl tc bndrs ty
+  = do { ty1 <- repLTy ty
+       ; repTySyn tc bndrs ty1 }
+
+repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo      = info
+                                          , fdLName     = tc
+                                          , fdTyVars    = tvs
+                                          , fdResultSig = dL->L _ resultSig
+                                          , fdInjectivityAnn = injectivity }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
+             mkHsQTvs tvs = HsQTvs { hsq_ext = []
+                                   , hsq_explicit = tvs }
+             resTyVar = case resultSig of
+                     TyVarSig _ bndr -> mkHsQTvs [bndr]
+                     _               -> mkHsQTvs []
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                addTyClTyVarBinds resTyVar $ \_ ->
+           case info of
+             ClosedTypeFamily Nothing ->
+                 notHandled "abstract closed type family" (ppr decl)
+             ClosedTypeFamily (Just eqns) ->
+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
+                  ; eqns2  <- coreList tySynEqnQTyConName eqns1
+                  ; result <- repFamilyResultSig resultSig
+                  ; inj    <- repInjectivityAnn injectivity
+                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
+             OpenTypeFamily ->
+               do { result <- repFamilyResultSig resultSig
+                  ; inj    <- repInjectivityAnn injectivity
+                  ; repOpenFamilyD tc1 bndrs result inj }
+             DataFamily ->
+               do { kind <- repFamilyResultSigToMaybeKind resultSig
+                  ; repDataFamilyD tc1 bndrs kind }
+       ; return (loc, dec)
+       }
+repFamilyDecl _ = panic "repFamilyDecl"
+
+-- | Represent result signature of a type family
+repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
+repFamilyResultSig (NoSig _)         = repNoSig
+repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
+                                          ; repKindSig ki' }
+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
+                                          ; repTyVarSig bndr' }
+repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
+
+-- | Represent result signature using a Maybe Kind. Used with data families,
+-- where the result signature can be either missing or a kind but never a named
+-- result variable.
+repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
+                              -> DsM (Core (Maybe TH.KindQ))
+repFamilyResultSigToMaybeKind (NoSig _) =
+    do { coreNothing kindQTyConName }
+repFamilyResultSigToMaybeKind (KindSig _ ki) =
+    do { ki' <- repLTy ki
+       ; coreJust kindQTyConName ki' }
+repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
+
+-- | Represent injectivity annotation of a type family
+repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
+                  -> DsM (Core (Maybe TH.InjectivityAnn))
+repInjectivityAnn Nothing =
+    do { coreNothing injAnnTyConName }
+repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
+    do { lhs'   <- lookupBinder (unLoc lhs)
+       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
+       ; rhs2   <- coreList nameTyConName rhs1
+       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
+       ; coreJust injAnnTyConName injAnn }
+
+repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
+
+repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)
+repAssocTyFamDefaultD = repTyFamInstD
+
+-------------------------
+-- represent fundeps
+--
+repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
+repLFunDeps fds = repList funDepTyConName repLFunDep fds
+
+repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
+repLFunDep (dL->L _ (xs, ys))
+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
+        repFunDep xs' ys'
+
+-- Represent instance declarations
+--
+repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
+  = do { dec <- repTyFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
+  = do { dec <- repDataFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
+  = do { dec <- repClsInstD cls_decl
+       ; return (loc, dec) }
+repInstD _ = panic "repInstD"
+
+repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
+                         , cid_sigs = sigs, cid_tyfam_insts = ats
+                         , cid_datafam_insts = adts
+                         , cid_overlap_mode = overlap
+                         })
+  = addSimpleTyVarBinds tvs $
+            -- We must bring the type variables into scope, so their
+            -- occurrences don't fail, even though the binders don't
+            -- appear in the resulting data structure
+            --
+            -- But we do NOT bring the binders of 'binds' into scope
+            -- because they are properly regarded as occurrences
+            -- For example, the method names should be bound to
+            -- the selector Ids, not to fresh names (#5410)
+            --
+            do { cxt1     <- repLContext cxt
+               ; inst_ty1 <- repLTy inst_ty
+          -- See Note [Scoped type variables in class and instance declarations]
+               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
+               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
+               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
+               ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
+               ; rOver  <- repOverlap (fmap unLoc overlap)
+               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
+               ; wrapGenSyms ss decls2 }
+ where
+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+repClsInstD (XClsInstDecl _) = panic "repClsInstD"
+
+repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
+                                          , deriv_type     = ty }))
+  = do { dec <- addSimpleTyVarBinds tvs $
+                do { cxt'     <- repLContext cxt
+                   ; strat'   <- repDerivStrategy strat
+                   ; inst_ty' <- repLTy inst_ty
+                   ; repDeriv strat' cxt' inst_ty' }
+       ; return (loc, dec) }
+  where
+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+repStandaloneDerivD _ = panic "repStandaloneDerivD"
+
+repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
+repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+  = do { eqn1 <- repTyFamEqn eqn
+       ; repTySynInst eqn1 }
+
+repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn (HsIB { hsib_ext = var_names
+                  , hsib_body = FamEqn { feqn_tycon = tc_name
+                                       , feqn_bndrs = mb_bndrs
+                                       , feqn_pats = tys
+                                       , feqn_fixity = fixity
+                                       , feqn_rhs  = rhs }})
+  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]
+       ; let hs_tvs = HsQTvs { hsq_ext = var_names
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
+            ; rhs1 <- repLTy rhs
+            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
+     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
+           checkTys _ = panic "repTyFamEqn:checkTys"
+repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
+repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
+
+repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)
+repTyArgs f [] = f
+repTyArgs f (HsValArg ty : as) = do { f' <- f
+                                    ; ty' <- repLTy ty
+                                    ; repTyArgs (repTapp f' ty') as }
+repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
+                                       ; ki' <- repLTy ki
+                                       ; repTyArgs (repTappKind f' ki') as }
+repTyArgs f (HsArgPar _ : as) = repTyArgs f as
+
+repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
+repDataFamInstD (DataFamInstDecl { dfid_eqn =
+                  (HsIB { hsib_ext = var_names
+                        , hsib_body = FamEqn { feqn_tycon = tc_name
+                                             , feqn_bndrs = mb_bndrs
+                                             , feqn_pats  = tys
+                                             , feqn_fixity = fixity
+                                             , feqn_rhs   = defn }})})
+  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]
+       ; let hs_tvs = HsQTvs { hsq_ext = var_names
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
+            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
+
+      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
+            checkTys _ = panic "repDataFamInstD:checkTys"
+
+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "repDataFamInstD"
+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "repDataFamInstD"
+
+repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
+repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+                                  , fd_fi = CImport (dL->L _ cc)
+                                                    (dL->L _ s) mch cis _ }))
+ = do MkC name' <- lookupLOcc name
+      MkC typ' <- repHsSigType typ
+      MkC cc' <- repCCallConv cc
+      MkC s' <- repSafety s
+      cis' <- conv_cimportspec cis
+      MkC str <- coreStringLit (static ++ chStr ++ cis')
+      dec <- rep2 forImpDName [cc', s', str, name', typ']
+      return (loc, dec)
+ where
+    conv_cimportspec (CLabel cls)
+      = notHandled "Foreign label" (doubleQuotes (ppr cls))
+    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
+                            = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
+                            = panic "conv_cimportspec: values not supported yet"
+    conv_cimportspec CWrapper = return "wrapper"
+    -- these calling conventions do not support headers and the static keyword
+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
+    static = case cis of
+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
+                 _ -> ""
+    chStr = case mch of
+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
+            _ -> ""
+repForD decl = notHandled "Foreign declaration" (ppr decl)
+
+repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
+repCCallConv CCallConv          = rep2 cCallName []
+repCCallConv StdCallConv        = rep2 stdCallName []
+repCCallConv CApiConv           = rep2 cApiCallName []
+repCCallConv PrimCallConv       = rep2 primCallName []
+repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
+
+repSafety :: Safety -> DsM (Core TH.Safety)
+repSafety PlayRisky = rep2 unsafeName []
+repSafety PlayInterruptible = rep2 interruptibleName []
+repSafety PlaySafe = rep2 safeName []
+
+repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
+  = do { MkC prec' <- coreIntLit prec
+       ; let rep_fn = case dir of
+                        InfixL -> infixLDName
+                        InfixR -> infixRDName
+                        InfixN -> infixNDName
+       ; let do_one name
+              = do { MkC name' <- lookupLOcc name
+                   ; dec <- rep2 rep_fn [prec', name']
+                   ; return (loc,dec) }
+       ; mapM do_one names }
+repFixD _ = panic "repFixD"
+
+repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repRuleD (dL->L loc (HsRule { rd_name = n
+                            , rd_act = act
+                            , rd_tyvs = ty_bndrs
+                            , rd_tmvs = tm_bndrs
+                            , rd_lhs = lhs
+                            , rd_rhs = rhs }))
+  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+            ; ss <- mkGenSyms tm_bndr_names
+            ; rule <- addBinds ss $
+                      do { ty_bndrs' <- case ty_bndrs of
+                             Nothing -> coreNothingList tyVarBndrQTyConName
+                             Just _  -> coreJustList tyVarBndrQTyConName
+                                          ex_bndrs
+                         ; tm_bndrs' <- repList ruleBndrQTyConName
+                                                repRuleBndr
+                                                tm_bndrs
+                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
+                         ; act' <- repPhases act
+                         ; lhs' <- repLE lhs
+                         ; rhs' <- repLE rhs
+                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+           ; wrapGenSyms ss rule  }
+       ; return (loc, rule) }
+repRuleD _ = panic "repRuleD"
+
+ruleBndrNames :: LRuleBndr GhcRn -> [Name]
+ruleBndrNames (dL->L _ (RuleBndr _ n))      = [unLoc n]
+ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
+  = unLoc n : vars
+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+  = panic "ruleBndrNames"
+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+  = panic "ruleBndrNames"
+ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"
+ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
+
+repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
+repRuleBndr (dL->L _ (RuleBndr _ n))
+  = do { MkC n' <- lookupLBinder n
+       ; rep2 ruleVarName [n'] }
+repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
+  = do { MkC n'  <- lookupLBinder n
+       ; MkC ty' <- repLTy (hsSigWcType sig)
+       ; rep2 typedRuleVarName [n', ty'] }
+repRuleBndr _ = panic "repRuleBndr"
+
+repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
+  = do { target <- repAnnProv ann_prov
+       ; exp'   <- repE exp
+       ; dec    <- repPragAnn target exp'
+       ; return (loc, dec) }
+repAnnD _ = panic "repAnnD"
+
+repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
+repAnnProv (ValueAnnProvenance (dL->L _ n))
+  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
+       ; rep2 valueAnnotationName [ n' ] }
+repAnnProv (TypeAnnProvenance (dL->L _ n))
+  = do { MkC n' <- globalVar n
+       ; rep2 typeAnnotationName [ n' ] }
+repAnnProv ModuleAnnProvenance
+  = rep2 moduleAnnotationName []
+
+-------------------------------------------------------
+--                      Constructors
+-------------------------------------------------------
+
+repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
+repC (dL->L _ (ConDeclH98 { con_name   = con
+                          , con_forall = (dL->L _ False)
+                          , con_mb_cxt = Nothing
+                          , con_args   = args }))
+  = repDataCon con args
+
+repC (dL->L _ (ConDeclH98 { con_name = con
+                          , con_forall = (dL->L _ is_existential)
+                          , con_ex_tvs = con_tvs
+                          , con_mb_cxt = mcxt
+                          , con_args = args }))
+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con args
+            ; ctxt' <- repMbContext mcxt
+            ; if not is_existential && isNothing mcxt
+              then return c'
+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
+            }
+       }
+
+repC (dL->L _ (ConDeclGADT { con_names  = cons
+                           , con_qvars  = qtvs
+                           , con_mb_cxt = mcxt
+                           , con_args   = args
+                           , con_res_ty = res_ty }))
+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
+  , Nothing <- mcxt      -- No context
+                         -- ==> no need for a forall
+  = repGadtDataCons cons args res_ty
+
+  | otherwise
+  = addTyVarBinds qtvs $ \ ex_bndrs ->
+             -- See Note [Don't quantify implicit type variables in quotes]
+    do { c'    <- repGadtDataCons cons args res_ty
+       ; ctxt' <- repMbContext mcxt
+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
+         then return c'
+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+
+repC _ = panic "repC"
+
+
+repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
+repMbContext Nothing          = repContext []
+repMbContext (Just (dL->L _ cxt)) = repContext cxt
+
+repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
+
+repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
+
+repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
+repBangTy ty = do
+  MkC u <- repSrcUnpackedness su'
+  MkC s <- repSrcStrictness ss'
+  MkC b <- rep2 bangName [u, s]
+  MkC t <- repLTy ty'
+  rep2 bangTypeName [b, t]
+  where
+    (su', ss', ty') = case unLoc ty of
+            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
+            _ -> (NoSrcUnpack, NoSrcStrict, ty)
+
+-------------------------------------------------------
+--                      Deriving clauses
+-------------------------------------------------------
+
+repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
+repDerivs (dL->L _ clauses)
+  = repList derivClauseQTyConName repDerivClause clauses
+
+repDerivClause :: LHsDerivingClause GhcRn
+               -> DsM (Core TH.DerivClauseQ)
+repDerivClause (dL->L _ (HsDerivingClause
+                          { deriv_clause_strategy = dcs
+                          , deriv_clause_tys      = (dL->L _ dct) }))
+  = do MkC dcs' <- repDerivStrategy dcs
+       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
+       rep2 derivClauseName [dcs',dct']
+  where
+    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
+    rep_deriv_ty ty = repLTy ty
+repDerivClause _ = panic "repDerivClause"
+
+rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
+               -> DsM ([GenSymBind], [Core TH.DecQ])
+-- Represent signatures and methods in class/instance declarations.
+-- See Note [Scoped type variables in class and instance declarations]
+--
+-- Why not use 'repBinds': we have already created symbols for methods in
+-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
+-- these fun_id via 'collectHsValBinders decs', which would lead to the
+-- instance declarations failing in TH.
+rep_sigs_binds sigs binds
+  = do { let tvs = concatMap get_scoped_tvs sigs
+       ; ss <- mkGenSyms tvs
+       ; sigs1 <- addBinds ss $ rep_sigs sigs
+       ; binds1 <- addBinds ss $ rep_binds binds
+       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
+
+-------------------------------------------------------
+--   Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
+        -- We silently ignore ones we don't recognise
+rep_sigs = concatMapM rep_sig
+
+rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_sig (dL->L loc (TypeSig _ nms ty))
+  = mapM (rep_wc_ty_sig sigDName loc ty) nms
+rep_sig (dL->L loc (PatSynSig _ nms ty))
+  = mapM (rep_patsyn_ty_sig loc ty) nms
+rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))
+  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms
+  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms
+rep_sig d@(dL->L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
+rep_sig (dL->L _   (FixSig {}))          = return [] -- fixity sigs at top level
+rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (dL->L loc (SpecSig _ nm tys ispec))
+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
+rep_sig (dL->L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc
+rep_sig (dL->L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
+rep_sig (dL->L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
+rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))
+  = rep_complete_sig cls mty loc
+rep_sig _ = panic "rep_sig"
+
+rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
+           -> DsM (SrcSpan, Core TH.DecQ)
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations].
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig mk_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
+                                    explicit_tvs
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)
+                       then return th_ty
+                       else repTForall th_explicit_tvs th_ctxt th_ty
+       ; sig     <- repProto mk_sig nm1 ty1
+       ; return (loc, sig) }
+rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
+
+rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
+                  -> DsM (SrcSpan, Core TH.DecQ)
+-- represents a pattern synonym type signature;
+-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
+--
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_patsyn_ty_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
+       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_reqs  <- repLContext reqs
+       ; th_provs <- repLContext provs
+       ; th_ty    <- repLTy ty
+       ; ty1      <- repTForall th_univs th_reqs =<<
+                       repTForall th_exis th_provs th_ty
+       ; sig      <- repProto patSynSigDName nm1 ty1
+       ; return (loc, sig) }
+rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
+
+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
+              -> DsM (SrcSpan, Core TH.DecQ)
+rep_wc_ty_sig mk_sig loc sig_ty nm
+  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
+
+rep_inline :: Located Name
+           -> InlinePragma      -- Never defaultInlinePragma
+           -> SrcSpan
+           -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_inline nm ispec loc
+  = do { nm1    <- lookupLOcc nm
+       ; inline <- repInline $ inl_inline ispec
+       ; rm     <- repRuleMatch $ inl_rule ispec
+       ; phases <- repPhases $ inl_act ispec
+       ; pragma <- repPragInl nm1 inline rm phases
+       ; return [(loc, pragma)]
+       }
+
+rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
+               -> SrcSpan
+               -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialise nm ty ispec loc
+  = do { nm1 <- lookupLOcc nm
+       ; ty1 <- repHsSigType ty
+       ; phases <- repPhases $ inl_act ispec
+       ; let inline = inl_inline ispec
+       ; pragma <- if noUserInlineSpec inline
+                   then -- SPECIALISE
+                     repPragSpec nm1 ty1 phases
+                   else -- SPECIALISE INLINE
+                     do { inline1 <- repInline inline
+                        ; repPragSpecInl nm1 ty1 inline1 phases }
+       ; return [(loc, pragma)]
+       }
+
+rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
+                   -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialiseInst ty loc
+  = do { ty1    <- repHsSigType ty
+       ; pragma <- repPragSpecInst ty1
+       ; return [(loc, pragma)] }
+
+repInline :: InlineSpec -> DsM (Core TH.Inline)
+repInline NoInline  = dataCon noInlineDataConName
+repInline Inline    = dataCon inlineDataConName
+repInline Inlinable = dataCon inlinableDataConName
+repInline spec      = notHandled "repInline" (ppr spec)
+
+repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
+repRuleMatch ConLike = dataCon conLikeDataConName
+repRuleMatch FunLike = dataCon funLikeDataConName
+
+repPhases :: Activation -> DsM (Core TH.Phases)
+repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
+                                  ; dataCon' beforePhaseDataConName [arg] }
+repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
+                                  ; dataCon' fromPhaseDataConName [arg] }
+repPhases _                  = dataCon allPhasesDataConName
+
+rep_complete_sig :: Located [Located Name]
+                 -> Maybe (Located Name)
+                 -> SrcSpan
+                 -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_complete_sig (dL->L _ cls) mty loc
+  = do { mty' <- repMaybe nameTyConName lookupLOcc mty
+       ; cls' <- repList nameTyConName lookupLOcc cls
+       ; sig <- repPragComplete cls' mty'
+       ; return [(loc, sig)] }
+
+-------------------------------------------------------
+--                      Types
+-------------------------------------------------------
+
+addSimpleTyVarBinds :: [Name]                -- the binders to be added
+                    -> DsM (Core (TH.Q a))   -- action in the ext env
+                    -> DsM (Core (TH.Q a))
+addSimpleTyVarBinds names thing_inside
+  = do { fresh_names <- mkGenSyms names
+       ; term <- addBinds fresh_names thing_inside
+       ; wrapGenSyms fresh_names term }
+
+addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
+                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
+                -> DsM (Core (TH.Q a))
+addHsTyVarBinds exp_tvs thing_inside
+  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
+       ; term <- addBinds fresh_exp_names $
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (exp_tvs `zip` fresh_exp_names)
+                    ; thing_inside kbs }
+       ; wrapGenSyms fresh_exp_names term }
+  where
+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+
+addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
+              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
+              -> DsM (Core (TH.Q a))
+-- gensym a list of type variables and enter them into the meta environment;
+-- the computations passed as the second argument is executed in that extended
+-- meta environment and gets the *new* names on Core-level as an argument
+addTyVarBinds (HsQTvs { hsq_ext = imp_tvs
+                      , hsq_explicit = exp_tvs })
+              thing_inside
+  = addSimpleTyVarBinds imp_tvs $
+    addHsTyVarBinds exp_tvs $
+    thing_inside
+addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
+
+addTyClTyVarBinds :: LHsQTyVars GhcRn
+                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
+                  -> DsM (Core (TH.Q a))
+
+-- Used for data/newtype declarations, and family instances,
+-- so that the nested type variables work right
+--    instance C (T a) where
+--      type W (T a) = blah
+-- The 'a' in the type instance is the one bound by the instance decl
+addTyClTyVarBinds tvs m
+  = do { let tv_names = hsAllLTyVarNames tvs
+       ; env <- dsGetMetaEnv
+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
+            -- Make fresh names for the ones that are not already in scope
+            -- This makes things work for family declarations
+
+       ; term <- addBinds freshNames $
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (hsQTvExplicit tvs)
+                    ; m kbs }
+
+       ; wrapGenSyms freshNames term }
+  where
+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
+                       ; repTyVarBndrWithKind tv v }
+
+-- Produce kinded binder constructors from the Haskell tyvar binders
+--
+repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
+                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm
+  = repPlainTV nm
+repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm
+  = repLTy ki >>= repKindedTV nm
+repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"
+
+-- | Represent a type variable binder
+repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )
+  = do { nm' <- lookupBinder nm
+       ; repPlainTV nm' }
+repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))
+  = do { nm' <- lookupBinder nm
+       ; ki' <- repLTy ki
+       ; repKindedTV nm' ki' }
+repTyVarBndr _ = panic "repTyVarBndr"
+
+-- represent a type context
+--
+repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
+repLContext ctxt = repContext (unLoc ctxt)
+
+repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
+repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
+                     repCtxt preds
+
+repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
+repHsSigType (HsIB { hsib_ext = implicit_tvs
+                   , hsib_body = body })
+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
+  = addSimpleTyVarBinds implicit_tvs $
+      -- See Note [Don't quantify implicit type variables in quotes]
+    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
+    do { th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; if null explicit_tvs && null (unLoc ctxt)
+         then return th_ty
+         else repTForall th_explicit_tvs th_ctxt th_ty }
+repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"
+
+repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
+repHsSigWcType (HsWC { hswc_body = sig1 })
+  = repHsSigType sig1
+repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"
+
+-- yield the representation of a list of types
+repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
+repLTys tys = mapM repLTy tys
+
+-- represent a type
+repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
+repLTy ty = repTy (unLoc ty)
+
+repForall :: ForallVisFlag -> HsType GhcRn -> DsM (Core TH.TypeQ)
+-- Arg of repForall is always HsForAllTy or HsQualTy
+repForall fvf ty
+ | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
+ = addHsTyVarBinds tvs $ \bndrs ->
+   do { ctxt1  <- repLContext ctxt
+      ; ty1    <- repLTy tau
+      ; case fvf of
+          ForallVis   -> repTForallVis bndrs ty1    -- forall a      -> {...}
+          ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}
+      }
+
+repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
+repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf         ty
+repTy ty@(HsQualTy {})                = repForall ForallInvis ty
+
+repTy (HsTyVar _ _ (dL->L _ n))
+  | isLiftedTypeKindTyConName n       = repTStar
+  | n `hasKey` constraintKindTyConKey = repTConstraint
+  | n `hasKey` funTyConKey            = repArrowTyCon
+  | isTvOcc occ   = do tv1 <- lookupOcc n
+                       repTvar tv1
+  | isDataOcc occ = do tc1 <- lookupOcc n
+                       repPromotedDataCon tc1
+  | n == eqTyConName = repTequality
+  | otherwise     = do tc1 <- lookupOcc n
+                       repNamedTyCon tc1
+  where
+    occ = nameOccName n
+
+repTy (HsAppTy _ f a)       = do
+                                f1 <- repLTy f
+                                a1 <- repLTy a
+                                repTapp f1 a1
+repTy (HsAppKindTy _ ty ki) = do
+                                ty1 <- repLTy ty
+                                ki1 <- repLTy ki
+                                repTappKind ty1 ki1
+repTy (HsFunTy _ f a)       = do
+                                f1   <- repLTy f
+                                a1   <- repLTy a
+                                tcon <- repArrowTyCon
+                                repTapps tcon [f1, a1]
+repTy (HsListTy _ t)        = do
+                                t1   <- repLTy t
+                                tcon <- repListTyCon
+                                repTapp tcon t1
+repTy (HsTupleTy _ HsUnboxedTuple tys) = do
+                                tys1 <- repLTys tys
+                                tcon <- repUnboxedTupleTyCon (length tys)
+                                repTapps tcon tys1
+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
+                                 tcon <- repTupleTyCon (length tys)
+                                 repTapps tcon tys1
+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
+                                 tcon <- repUnboxedSumTyCon (length tys)
+                                 repTapps tcon tys1
+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+                                   `nlHsAppTy` ty2)
+repTy (HsParTy _ t)         = repLTy t
+repTy (HsStarTy _ _) =  repTStar
+repTy (HsKindSig _ t k)     = do
+                                t1 <- repLTy t
+                                k1 <- repLTy k
+                                repTSig t1 k1
+repTy (HsSpliceTy _ splice)      = repSplice splice
+repTy (HsExplicitListTy _ _ tys) = do
+                                    tys1 <- repLTys tys
+                                    repTPromotedList tys1
+repTy (HsExplicitTupleTy _ tys) = do
+                                    tys1 <- repLTys tys
+                                    tcon <- repPromotedTupleTyCon (length tys)
+                                    repTapps tcon tys1
+repTy (HsTyLit _ lit) = do
+                          lit' <- repTyLit lit
+                          repTLit lit'
+repTy (HsWildCardTy _) = repTWildCard
+repTy (HsIParamTy _ n t) = do
+                             n' <- rep_implicit_param_name (unLoc n)
+                             t' <- repLTy t
+                             repTImplicitParam n' t'
+
+repTy ty                      = notHandled "Exotic form of type" (ppr ty)
+
+repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
+                            rep2 numTyLitName [iExpr]
+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
+                            ; rep2 strTyLitName [s']
+                            }
+
+-- | Represent a type wrapped in a Maybe
+repMaybeLTy :: Maybe (LHsKind GhcRn)
+            -> DsM (Core (Maybe TH.TypeQ))
+repMaybeLTy = repMaybe kindQTyConName repLTy
+
+repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
+repRole (dL->L _ (Just Nominal))          = rep2 nominalRName []
+repRole (dL->L _ (Just Representational)) = rep2 representationalRName []
+repRole (dL->L _ (Just Phantom))          = rep2 phantomRName []
+repRole (dL->L _ Nothing)                 = rep2 inferRName []
+repRole _ = panic "repRole: Impossible Match" -- due to #15884
+
+-----------------------------------------------------------------------------
+--              Splices
+-----------------------------------------------------------------------------
+
+repSplice :: HsSplice GhcRn -> DsM (Core a)
+-- See Note [How brackets and nested splices are handled] in TcSplice
+-- We return a CoreExpr of any old type; the context should know
+repSplice (HsTypedSplice   _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
+repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)
+repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)
+
+rep_splice :: Name -> DsM (Core a)
+rep_splice splice_name
+ = do { mb_val <- dsLookupMetaEnv splice_name
+       ; case mb_val of
+           Just (DsSplice e) -> do { e' <- dsExpr e
+                                   ; return (MkC e') }
+           _ -> pprPanic "HsSplice" (ppr splice_name) }
+                        -- Should not happen; statically checked
+
+-----------------------------------------------------------------------------
+--              Expressions
+-----------------------------------------------------------------------------
+
+repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
+repLEs es = repList expQTyConName repLE es
+
+-- FIXME: some of these panics should be converted into proper error messages
+--        unless we can make sure that constructs, which are plainly not
+--        supported in TH already lead to error messages at an earlier stage
+repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
+repLE (dL->L loc e) = putSrcSpanDs loc (repE e)
+
+repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
+repE (HsVar _ (dL->L _ x)) =
+  do { mb_val <- dsLookupMetaEnv x
+     ; case mb_val of
+        Nothing            -> do { str <- globalVar x
+                                 ; repVarOrCon x str }
+        Just (DsBound y)   -> repVarOrCon x (coreVar y)
+        Just (DsSplice e)  -> do { e' <- dsExpr e
+                                 ; return (MkC e') } }
+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
+repE (HsOverLabel _ _ s) = repOverLabel s
+
+repE e@(HsRecFld _ f) = case f of
+  Unambiguous x _ -> repE (HsVar noExt (noLoc x))
+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
+  XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
+
+        -- Remember, we're desugaring renamer output here, so
+        -- HsOverlit can definitely occur
+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))
+                   = do { ms' <- mapM repMatchTup ms
+                        ; core_ms <- coreList matchQTyConName ms'
+                        ; repLamCase core_ms }
+repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType _ e t) = do { a <- repLE e
+                            ; s <- repLTy (hswc_body t)
+                            ; repAppType a s }
+
+repE (OpApp _ e1 op e2) =
+  do { arg1 <- repLE e1;
+       arg2 <- repLE e2;
+       the_op <- repLE op ;
+       repInfixApp arg1 the_op arg2 }
+repE (NegApp _ x _)      = do
+                              a         <- repLE x
+                              negateVar <- lookupOcc negateName >>= repVar
+                              negateVar `repApp` a
+repE (HsPar _ x)            = repLE x
+repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))
+                          = do { arg <- repLE e
+                               ; ms2 <- mapM repMatchTup ms
+                               ; core_ms2 <- coreList matchQTyConName ms2
+                               ; repCaseE arg core_ms2 }
+repE (HsIf _ _ x y z)       = do
+                              a <- repLE x
+                              b <- repLE y
+                              c <- repLE z
+                              repCond a b c
+repE (HsMultiIf _ alts)
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; expr' <- repMultiIf (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) expr' }
+repE (HsLet _ (dL->L _ bs) e)       = do { (ss,ds) <- repBinds bs
+                                     ; e2 <- addBinds ss (repLE e)
+                                     ; z <- repLetE ds e2
+                                     ; wrapGenSyms ss z }
+
+-- FIXME: I haven't got the types here right yet
+repE e@(HsDo _ ctxt (dL->L _ sts))
+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+ | ListComp <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repComp (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+ | MDoExpr <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repMDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+  | otherwise
+  = notHandled "monad comprehension and [: :]" (ppr e)
+
+repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
+repE e@(ExplicitTuple _ es boxed)
+  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
+  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
+                       ; repTup xs }
+  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
+                       ; repUnboxedTup xs }
+
+repE (ExplicitSum _ alt arity e)
+ = do { e1 <- repLE e
+      ; repUnboxedSum e1 alt arity }
+
+repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
+ = do { x <- lookupLOcc c;
+        fs <- repFields flds;
+        repRecCon x fs }
+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
+ = do { x <- repLE e;
+        fs <- repUpdFields flds;
+        repRecUpd x fs }
+
+repE (ExprWithTySig _ e ty)
+  = do { e1 <- repLE e
+       ; t1 <- repHsSigWcType ty
+       ; repSigExp e1 t1 }
+
+repE (ArithSeq _ _ aseq) =
+  case aseq of
+    From e              -> do { ds1 <- repLE e; repFrom ds1 }
+    FromThen e1 e2      -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             repFromThen ds1 ds2
+    FromTo   e1 e2      -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             repFromTo ds1 ds2
+    FromThenTo e1 e2 e3 -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             ds3 <- repLE e3
+                             repFromThenTo ds1 ds2 ds3
+
+repE (HsSpliceE _ splice)  = repSplice splice
+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
+repE (HsUnboundVar _ uv)   = do
+                               occ   <- occNameLit (unboundVarOcc uv)
+                               sname <- repNameS occ
+                               repUnboundVar sname
+
+repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
+repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
+repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)
+repE e                     = notHandled "Expression form" (ppr e)
+
+-----------------------------------------------------------------------------
+-- Building representations of auxillary structures like Match, Clause, Stmt,
+
+repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
+repMatchTup (dL->L _ (Match { m_pats = [p]
+                            , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+  do { ss1 <- mkGenSyms (collectPatBinders p)
+     ; addBinds ss1 $ do {
+     ; p1 <- repLP p
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+     ; gs    <- repGuards guards
+     ; match <- repMatch p1 gs ds
+     ; wrapGenSyms (ss1++ss2) match }}}
+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
+
+repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
+repClauseTup (dL->L _ (Match { m_pats = ps
+                             , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+  do { ss1 <- mkGenSyms (collectPatsBinders ps)
+     ; addBinds ss1 $ do {
+       ps1 <- repLPs ps
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+       gs <- repGuards guards
+     ; clause <- repClause ps1 gs ds
+     ; wrapGenSyms (ss1++ss2) clause }}}
+repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
+repClauseTup _ = panic "repClauseTup"
+
+repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)
+repGuards [dL->L _ (GRHS _ [] e)]
+  = do {a <- repLE e; repNormal a }
+repGuards other
+  = do { zs <- mapM repLGRHS other
+       ; let (xs, ys) = unzip zs
+       ; gd <- repGuarded (nonEmptyCoreList ys)
+       ; wrapGenSyms (concat xs) gd }
+
+repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
+         -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))
+  = do { guarded <- repLNormalGE e1 e2
+       ; return ([], guarded) }
+repLGRHS (dL->L _ (GRHS _ ss rhs))
+  = do { (gs, ss') <- repLSts ss
+       ; rhs' <- addBinds gs $ repLE rhs
+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
+       ; return (gs, guarded) }
+repLGRHS _ = panic "repLGRHS"
+
+repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
+repFields (HsRecFields { rec_flds = flds })
+  = repList fieldExpQTyConName rep_fld flds
+  where
+    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
+            -> DsM (Core (TH.Q TH.FieldExp))
+    rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
+                               ; e  <- repLE (hsRecFieldArg fld)
+                               ; repFieldExp fn e }
+
+repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
+repUpdFields = repList fieldExpQTyConName rep_fld
+  where
+    rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
+    rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of
+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)
+                                   ; e  <- repLE (hsRecFieldArg fld)
+                                   ; repFieldExp fn e }
+      _                      -> notHandled "Ambiguous record updates" (ppr fld)
+
+
+
+-----------------------------------------------------------------------------
+-- Representing Stmt's is tricky, especially if bound variables
+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
+-- First gensym new names for every variable in any of the patterns.
+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
+-- if variables didn't shaddow, the static gensym wouldn't be necessary
+-- and we could reuse the original names (x and x).
+--
+-- do { x'1 <- gensym "x"
+--    ; x'2 <- gensym "x"
+--    ; doE [ BindSt (pvar x'1) [| f 1 |]
+--          , BindSt (pvar x'2) [| f x |]
+--          , NoBindSt [| g x |]
+--          ]
+--    }
+
+-- The strategy is to translate a whole list of do-bindings by building a
+-- bigger environment, and a bigger set of meta bindings
+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
+-- of the expressions within the Do
+
+-----------------------------------------------------------------------------
+-- The helper function repSts computes the translation of each sub expression
+-- and a bunch of prefix bindings denoting the dynamic renaming.
+
+repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repLSts stmts = repSts (map unLoc stmts)
+
+repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repSts (BindStmt _ p e _ _ : ss) =
+   do { e2 <- repLE e
+      ; ss1 <- mkGenSyms (collectPatBinders p)
+      ; addBinds ss1 $ do {
+      ; p1 <- repLP p;
+      ; (ss2,zs) <- repSts ss
+      ; z <- repBindSt p1 e2
+      ; return (ss1++ss2, z : zs) }}
+repSts (LetStmt _ (dL->L _ bs) : ss) =
+   do { (ss1,ds) <- repBinds bs
+      ; z <- repLetSt ds
+      ; (ss2,zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) }
+repSts (BodyStmt _ e _ _ : ss) =
+   do { e2 <- repLE e
+      ; z <- repNoBindSt e2
+      ; (ss2,zs) <- repSts ss
+      ; return (ss2, z : zs) }
+repSts (ParStmt _ stmt_blocks _ _ : ss) =
+   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
+      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
+            ss1 = concat ss_s
+      ; z <- repParSt stmt_blocks2
+      ; (ss2, zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) }
+   where
+     rep_stmt_block :: ParStmtBlock GhcRn GhcRn
+                    -> DsM ([GenSymBind], Core [TH.StmtQ])
+     rep_stmt_block (ParStmtBlock _ stmts _ _) =
+       do { (ss1, zs) <- repSts (map unLoc stmts)
+          ; zs1 <- coreList stmtQTyConName zs
+          ; return (ss1, zs1) }
+     rep_stmt_block (XParStmtBlock{}) = panic "repSts"
+repSts [LastStmt _ e _ _]
+  = do { e2 <- repLE e
+       ; z <- repNoBindSt e2
+       ; return ([], [z]) }
+repSts (stmt@RecStmt{} : ss)
+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)
+       ; ss1 <- mkGenSyms binders
+       -- Bring all of binders in the recursive group into scope for the
+       -- whole group.
+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
+       ; MASSERT(sort ss1 == sort ss1_other)
+       ; z <- repRecSt (nonEmptyCoreList rss)
+       ; (ss2,zs) <- addBinds ss1 (repSts ss)
+       ; return (ss1++ss2, z : zs) }
+repSts []    = return ([],[])
+repSts other = notHandled "Exotic statement" (ppr other)
+
+
+-----------------------------------------------------------
+--                      Bindings
+-----------------------------------------------------------
+
+repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
+repBinds (EmptyLocalBinds _)
+  = do  { core_list <- coreList decQTyConName []
+        ; return ([], core_list) }
+
+repBinds (HsIPBinds _ (IPBinds _ decs))
+ = do   { ips <- mapM rep_implicit_param_bind decs
+        ; core_list <- coreList decQTyConName
+                                (de_loc (sort_by_loc ips))
+        ; return ([], core_list)
+        }
+
+repBinds b@(HsIPBinds _ XHsIPBinds {})
+ = notHandled "Implicit parameter binds extension" (ppr b)
+
+repBinds (HsValBinds _ decs)
+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
+                -- No need to worry about detailed scopes within
+                -- the binding group, because we are talking Names
+                -- here, so we can safely treat it as a mutually
+                -- recursive group
+                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
+        ; ss        <- mkGenSyms bndrs
+        ; prs       <- addBinds ss (rep_val_binds decs)
+        ; core_list <- coreList decQTyConName
+                                (de_loc (sort_by_loc prs))
+        ; return (ss, core_list) }
+repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
+
+rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))
+ = do { name <- case ename of
+                    Left (dL->L _ n) -> rep_implicit_param_name n
+                    Right _ ->
+                        panic "rep_implicit_param_bind: post typechecking"
+      ; rhs' <- repE rhs
+      ; ipb <- repImplicitParamBind name rhs'
+      ; return (loc, ipb) }
+rep_implicit_param_bind (dL->L _ b@(XIPBind _))
+ = notHandled "Implicit parameter bind extension" (ppr b)
+rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"
+                            -- due to #15884
+
+rep_implicit_param_name :: HsIPName -> DsM (Core String)
+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
+
+rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+-- Assumes: all the binders of the binding are already in the meta-env
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
+ = do { core1 <- rep_binds (unionManyBags (map snd binds))
+      ; core2 <- rep_sigs sigs
+      ; return (core1 ++ core2) }
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
+
+rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds = mapM rep_bind . bagToList
+
+rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+-- Assumes: all the binders of the binding are already in the meta-env
+
+-- Note GHC treats declarations of a variable (not a pattern)
+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
+-- with an empty list of patterns
+rep_bind (dL->L loc (FunBind
+                 { fun_id = fn,
+                   fun_matches = MG { mg_alts
+                           = (dL->L _ [dL->L _ (Match
+                                       { m_pats = []
+                                       , m_grhss = GRHSs _ guards
+                                                     (dL->L _ wheres) }
+                                      )]) } }))
+ = do { (ss,wherecore) <- repBinds wheres
+        ; guardcore <- addBinds ss (repGuards guards)
+        ; fn'  <- lookupLBinder fn
+        ; p    <- repPvar fn'
+        ; ans  <- repVal p guardcore wherecore
+        ; ans' <- wrapGenSyms ss ans
+        ; return (loc, ans') }
+
+rep_bind (dL->L loc (FunBind { fun_id = fn
+                             , fun_matches = MG { mg_alts = (dL->L _ ms) } }))
+ =   do { ms1 <- mapM repClauseTup ms
+        ; fn' <- lookupLBinder fn
+        ; ans <- repFun fn' (nonEmptyCoreList ms1)
+        ; return (loc, ans) }
+
+rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
+
+rep_bind (dL->L loc (PatBind { pat_lhs = pat
+                             , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))
+ =   do { patcore <- repLP pat
+        ; (ss,wherecore) <- repBinds wheres
+        ; guardcore <- addBinds ss (repGuards guards)
+        ; ans  <- repVal patcore guardcore wherecore
+        ; ans' <- wrapGenSyms ss ans
+        ; return (loc, ans') }
+rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
+
+rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
+ =   do { v' <- lookupBinder v
+        ; e2 <- repLE e
+        ; x <- repNormal e2
+        ; patcore <- repPvar v'
+        ; empty_decls <- coreList decQTyConName []
+        ; ans <- repVal patcore x empty_decls
+        ; return (srcLocSpan (getSrcLoc v), ans) }
+
+rep_bind (dL->L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
+rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id   = syn
+                                       , psb_args = args
+                                       , psb_def  = pat
+                                       , psb_dir  = dir })))
+  = do { syn'      <- lookupLBinder syn
+       ; dir'      <- repPatSynDir dir
+       ; ss        <- mkGenArgSyms args
+       ; patSynD'  <- addBinds ss (
+         do { args'  <- repPatSynArgs args
+            ; pat'   <- repLP pat
+            ; repPatSynD syn' args' dir' pat' })
+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'
+       ; return (loc, patSynD'') }
+  where
+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
+    -- for Record Pattern Synonyms we want to conflate the selector
+    -- and the pattern-only names in order to provide a nicer TH
+    -- API. Whereas inside GHC, record pattern synonym selectors and
+    -- their pattern-only bound right hand sides have different names,
+    -- we want to treat them the same in TH. This is the reason why we
+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.
+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)
+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
+    mkGenArgSyms (RecCon fields)
+      = do { let pats = map (unLoc . recordPatSynPatVar) fields
+                 sels = map (unLoc . recordPatSynSelectorId) fields
+           ; ss <- mkGenSyms sels
+           ; return $ replaceNames (zip sels pats) ss }
+
+    replaceNames selsPats genSyms
+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
+                    , sel == sel' ]
+
+    wrapGenArgSyms :: HsPatSynDetails (Located Name)
+                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
+    wrapGenArgSyms (RecCon _) _  dec = return dec
+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
+
+rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))
+  = panic "rep_bind: XPatSynBind"
+rep_bind (dL->L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"
+rep_bind _                          = panic "rep_bind: Impossible match!"
+                                      -- due to #15884
+
+repPatSynD :: Core TH.Name
+           -> Core TH.PatSynArgsQ
+           -> Core TH.PatSynDirQ
+           -> Core TH.PatQ
+           -> DsM (Core TH.DecQ)
+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
+  = rep2 patSynDName [syn, args, dir, pat]
+
+repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
+repPatSynArgs (PrefixCon args)
+  = do { args' <- repList nameTyConName lookupLOcc args
+       ; repPrefixPatSynArgs args' }
+repPatSynArgs (InfixCon arg1 arg2)
+  = do { arg1' <- lookupLOcc arg1
+       ; arg2' <- lookupLOcc arg2
+       ; repInfixPatSynArgs arg1' arg2' }
+repPatSynArgs (RecCon fields)
+  = do { sels' <- repList nameTyConName lookupLOcc sels
+       ; repRecordPatSynArgs sels' }
+  where sels = map recordPatSynSelectorId fields
+
+repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
+
+repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
+
+repRecordPatSynArgs :: Core [TH.Name]
+                    -> DsM (Core TH.PatSynArgsQ)
+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
+
+repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
+repPatSynDir Unidirectional        = rep2 unidirPatSynName []
+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))
+  = do { clauses' <- mapM repClauseTup clauses
+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
+repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
+
+repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
+
+
+-----------------------------------------------------------------------------
+-- Since everything in a Bind is mutually recursive we need rename all
+-- all the variables simultaneously. For example:
+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
+-- do { f'1 <- gensym "f"
+--    ; g'2 <- gensym "g"
+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
+--      ]}
+-- This requires collecting the bindings (f'1 <- gensym "f"), and the
+-- environment ( f |-> f'1 ) from each binding, and then unioning them
+-- together. As we do this we collect GenSymBinds's which represent the renamed
+-- variables bound by the Bindings. In order not to lose track of these
+-- representations we build a shadow datatype MB with the same structure as
+-- MonoBinds, but which has slots for the representations
+
+
+-----------------------------------------------------------------------------
+-- GHC allows a more general form of lambda abstraction than specified
+-- by Haskell 98. In particular it allows guarded lambda's like :
+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
+-- (\ p1 .. pn -> exp) by causing an error.
+
+repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
+repLambda (dL->L _ (Match { m_pats = ps
+                          , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]
+                                              (dL->L _ (EmptyLocalBinds _)) } ))
+ = do { let bndrs = collectPatsBinders ps ;
+      ; ss  <- mkGenSyms bndrs
+      ; lam <- addBinds ss (
+                do { xs <- repLPs ps; body <- repLE e; repLam xs body })
+      ; wrapGenSyms ss lam }
+
+repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)
+
+
+-----------------------------------------------------------------------------
+--                      Patterns
+-- repP deals with patterns.  It assumes that we have already
+-- walked over the pattern(s) once to collect the binders, and
+-- have extended the environment.  So every pattern-bound
+-- variable should already appear in the environment.
+
+-- Process a list of patterns
+repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
+repLPs ps = repList patQTyConName repLP ps
+
+repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
+repLP p = repP (unLoc p)
+
+repP :: Pat GhcRn -> DsM (Core TH.PatQ)
+repP (WildPat _)        = repPwild
+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }
+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p
+                             ; repPaspat x' p1 }
+repP (ParPat _ p)       = repLP p
+repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
+                                ; e' <- repE (syn_expr e)
+                                ; repPview e' p}
+repP (TuplePat _ ps boxed)
+  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
+  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
+repP (SumPat _ p alt arity) = do { p1 <- repLP p
+                                 ; repPunboxedSum p1 alt arity }
+repP (ConPatIn dc details)
+ = do { con_str <- lookupLOcc dc
+      ; case details of
+         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
+         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
+                            ; repPrec con_str fps }
+         InfixCon p1 p2 -> do { p1' <- repLP p1;
+                                p2' <- repLP p2;
+                                repPinfix p1' con_str p2' }
+   }
+ where
+   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
+   rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
+                              ; MkC p <- repLP (hsRecFieldArg fld)
+                              ; rep2 fieldPatName [v,p] }
+
+repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l
+                                         ; repPlit a }
+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (SigPat _ p t) = do { p' <- repLP p
+                         ; t' <- repLTy (hsSigWcType t)
+                         ; repPsig p' t' }
+repP (SplicePat _ splice) = repSplice splice
+
+repP other = notHandled "Exotic pattern" (ppr other)
+
+----------------------------------------------------------
+-- Declaration ordering helpers
+
+sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
+sort_by_loc xs = sortBy comp xs
+    where comp x y = compare (fst x) (fst y)
+
+de_loc :: [(a, b)] -> [b]
+de_loc = map snd
+
+----------------------------------------------------------
+--      The meta-environment
+
+-- A name/identifier association for fresh names of locally bound entities
+type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
+                                -- I.e.         (x, x_id) means
+                                --      let x_id = gensym "x" in ...
+
+-- Generate a fresh name for a locally bound entity
+
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+-- We can use the existing name.  For example:
+--      [| \x_77 -> x_77 + x_77 |]
+-- desugars to
+--      do { x_77 <- genSym "x"; .... }
+-- We use the same x_77 in the desugared program, but with the type Bndr
+-- instead of Int
+--
+-- We do make it an Internal name, though (hence localiseName)
+--
+-- Nevertheless, it's monadic because we have to generate nameTy
+mkGenSyms ns = do { var_ty <- lookupType nameTyConName
+                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
+
+
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+-- Add a list of fresh names for locally bound entities to the
+-- meta environment (which is part of the state carried around
+-- by the desugarer monad)
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
+
+-- Look up a locally bound name
+--
+lookupLBinder :: Located Name -> DsM (Core TH.Name)
+lookupLBinder n = lookupBinder (unLoc n)
+
+lookupBinder :: Name -> DsM (Core TH.Name)
+lookupBinder = lookupOcc
+  -- Binders are brought into scope before the pattern or what-not is
+  -- desugared.  Moreover, in instance declaration the binder of a method
+  -- will be the selector Id and hence a global; so we need the
+  -- globalVar case of lookupOcc
+
+-- Look up a name that is either locally bound or a global name
+--
+--  * If it is a global name, generate the "original name" representation (ie,
+--   the <module>:<name> form) for the associated entity
+--
+lookupLOcc :: Located Name -> DsM (Core TH.Name)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupLOcc n = lookupOcc (unLoc n)
+
+lookupOcc :: Name -> DsM (Core TH.Name)
+lookupOcc n
+  = do {  mb_val <- dsLookupMetaEnv n ;
+          case mb_val of
+                Nothing           -> globalVar n
+                Just (DsBound x)  -> return (coreVar x)
+                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
+    }
+
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+--      f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+  | isExternalName name
+  = do  { MkC mod <- coreStringLit name_mod
+        ; MkC pkg <- coreStringLit name_pkg
+        ; MkC occ <- nameLit name
+        ; rep2 mk_varg [pkg,mod,occ] }
+  | otherwise
+  = do  { MkC occ <- nameLit name
+        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
+        ; rep2 mkNameLName [occ,uni] }
+  where
+      mod = ASSERT( isExternalName name) nameModule name
+      name_mod = moduleNameString (moduleName mod)
+      name_pkg = unitIdString (moduleUnitId mod)
+      name_occ = nameOccName name
+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+              | OccName.isVarOcc  name_occ = mkNameG_vName
+              | OccName.isTcOcc   name_occ = mkNameG_tcName
+              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
+
+lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
+           -> DsM Type  -- The type
+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+                          return (mkTyConApp tc []) }
+
+wrapGenSyms :: [GenSymBind]
+            -> Core (TH.Q a) -> DsM (Core (TH.Q a))
+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
+--      --> bindQ (gensym nm1) (\ id1 ->
+--          bindQ (gensym nm2 (\ id2 ->
+--          y))
+
+wrapGenSyms binds body@(MkC b)
+  = do  { var_ty <- lookupType nameTyConName
+        ; go var_ty binds }
+  where
+    [elt_ty] = tcTyConAppArgs (exprType b)
+        -- b :: Q a, so we can get the type 'a' by looking at the
+        -- argument type. NB: this relies on Q being a data/newtype,
+        -- not a type synonym
+
+    go _ [] = return body
+    go var_ty ((name,id) : binds)
+      = do { MkC body'  <- go var_ty binds
+           ; lit_str    <- nameLit name
+           ; gensym_app <- repGensym lit_str
+           ; repBindQ var_ty elt_ty
+                      gensym_app (MkC (Lam id body')) }
+
+nameLit :: Name -> DsM (Core String)
+nameLit n = coreStringLit (occNameString (nameOccName n))
+
+occNameLit :: OccName -> DsM (Core String)
+occNameLit name = coreStringLit (occNameString name)
+
+
+-- %*********************************************************************
+-- %*                                                                   *
+--              Constructing code
+-- %*                                                                   *
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC :: Core a -> CoreExpr
+unC (MkC x) = x
+
+rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
+rep2 n xs = do { id <- dsLookupGlobalId n
+               ; return (MkC (foldl' App (Var id) xs)) }
+
+dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
+dataCon' n args = do { id <- dsLookupDataCon n
+                     ; return $ MkC $ mkCoreConApps id args }
+
+dataCon :: Name -> DsM (Core a)
+dataCon n = dataCon' n []
+
+
+-- %*********************************************************************
+-- %*                                                                   *
+--              The 'smart constructors'
+-- %*                                                                   *
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
+
+repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repPunboxedSum (MkC p) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumPName [ p
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
+repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
+
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde (MkC p) = rep2 tildePName [p]
+
+repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPbang (MkC p) = rep2 bangPName [p]
+
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
+
+repPwild  :: DsM (Core TH.PatQ)
+repPwild = rep2 wildPName []
+
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist (MkC ps) = rep2 listPName [ps]
+
+repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+--------------- Expressions -----------------
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+                   | otherwise                  = repVar str
+
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar (MkC s) = rep2 varEName [s]
+
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon (MkC s) = rep2 conEName [s]
+
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit (MkC c) = rep2 litEName [c]
+
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
+
+repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
+
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
+
+repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup (MkC es) = rep2 tupEName [es]
+
+repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
+
+repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repUnboxedSum (MkC e) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumEName [ e
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
+repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
+
+repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
+repMultiIf (MkC alts) = rep2 multiIfEName [alts]
+
+repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
+
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repMDoE (MkC ss) = rep2 mdoEName [ss]
+
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
+
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
+
+repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
+
+repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
+
+------------ Guards ----
+repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
+             -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+                      e' <- repLE e
+                      repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
+
+------------- Stmts -------------------
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
+
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt (MkC ds) = rep2 letSName [ds]
+
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt (MkC e) = rep2 noBindSName [e]
+
+repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
+repParSt (MkC sss) = rep2 parSName [sss]
+
+repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
+repRecSt (MkC ss) = rep2 recSName [ss]
+
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom (MkC x) = rep2 fromEName [x]
+
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+repData :: Core TH.CxtQ -> Core TH.Name
+        -> Either (Core [TH.TyVarBndrQ])
+                  (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+        -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
+        -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
+repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
+        (MkC derivs)
+  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name
+           -> Either (Core [TH.TyVarBndrQ])
+                     (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+           -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
+           -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
+         -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs)
+  = rep2 tySynDName [nm, tvs, rhs]
+
+repInst :: Core (Maybe TH.Overlap) ->
+           Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
+                                                              [o, cxt, ty, ds]
+
+repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
+                 -> DsM (Core (Maybe TH.DerivStrategyQ))
+repDerivStrategy mds =
+  case mds of
+    Nothing -> nothing
+    Just ds ->
+      case unLoc ds of
+        StockStrategy    -> just =<< repStockStrategy
+        AnyclassStrategy -> just =<< repAnyclassStrategy
+        NewtypeStrategy  -> just =<< repNewtypeStrategy
+        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)
+                               via_strat <- repViaStrategy ty'
+                               just via_strat
+  where
+  nothing = coreNothing derivStrategyQTyConName
+  just    = coreJust    derivStrategyQTyConName
+
+repStockStrategy :: DsM (Core TH.DerivStrategyQ)
+repStockStrategy = rep2 stockStrategyName []
+
+repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
+repAnyclassStrategy = rep2 anyclassStrategyName []
+
+repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
+repNewtypeStrategy = rep2 newtypeStrategyName []
+
+repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
+repViaStrategy (MkC t) = rep2 viaStrategyName [t]
+
+repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
+repOverlap mb =
+  case mb of
+    Nothing -> nothing
+    Just o ->
+      case o of
+        NoOverlap _    -> nothing
+        Overlappable _ -> just =<< dataCon overlappableDataConName
+        Overlapping _  -> just =<< dataCon overlappingDataConName
+        Overlaps _     -> just =<< dataCon overlapsDataConName
+        Incoherent _   -> just =<< dataCon incoherentDataConName
+  where
+  nothing = coreNothing overlapTyConName
+  just    = coreJust overlapTyConName
+
+
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
+         -> Core [TH.FunDep] -> Core [TH.DecQ]
+         -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
+  = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repDeriv :: Core (Maybe TH.DerivStrategyQ)
+         -> Core TH.CxtQ -> Core TH.TypeQ
+         -> DsM (Core TH.DecQ)
+repDeriv (MkC ds) (MkC cxt) (MkC ty)
+  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
+
+repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
+           -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
+  = rep2 pragInlDName [nm, inline, rm, phases]
+
+repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
+            -> DsM (Core TH.DecQ)
+repPragSpec (MkC nm) (MkC ty) (MkC phases)
+  = rep2 pragSpecDName [nm, ty, phases]
+
+repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
+               -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+  = rep2 pragSpecInlDName [nm, ty, inline, phases]
+
+repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
+
+repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
+
+repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
+            -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
+            -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
+
+repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
+
+repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst (MkC eqn)
+    = rep2 tySynInstDName [eqn]
+
+repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
+               -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
+    = rep2 dataFamilyDName [nm, tvs, kind]
+
+repOpenFamilyD :: Core TH.Name
+               -> Core [TH.TyVarBndrQ]
+               -> Core TH.FamilyResultSigQ
+               -> Core (Maybe TH.InjectivityAnn)
+               -> DsM (Core TH.DecQ)
+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
+    = rep2 openTypeFamilyDName [nm, tvs, result, inj]
+
+repClosedFamilyD :: Core TH.Name
+                 -> Core [TH.TyVarBndrQ]
+                 -> Core TH.FamilyResultSigQ
+                 -> Core (Maybe TH.InjectivityAnn)
+                 -> Core [TH.TySynEqnQ]
+                 -> DsM (Core TH.DecQ)
+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
+    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
+
+repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
+               Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
+  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
+
+repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+
+repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
+
+repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
+
+repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+repDataCon :: Located Name
+           -> HsConDeclDetails GhcRn
+           -> DsM (Core TH.ConQ)
+repDataCon con details
+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
+         repConstr details Nothing [con']
+
+repGadtDataCons :: [Located Name]
+                -> HsConDeclDetails GhcRn
+                -> LHsType GhcRn
+                -> DsM (Core TH.ConQ)
+repGadtDataCons cons details res_ty
+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+         repConstr details (Just res_ty) cons'
+
+-- Invariant:
+--   * for plain H98 data constructors second argument is Nothing and third
+--     argument is a singleton list
+--   * for GADTs data constructors second argument is (Just return_type) and
+--     third argument is a non-empty list
+repConstr :: HsConDeclDetails GhcRn
+          -> Maybe (LHsType GhcRn)
+          -> [Core TH.Name]
+          -> DsM (Core TH.ConQ)
+repConstr (PrefixCon ps) Nothing [con]
+    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps
+         rep2 normalCName [unC con, unC arg_tys]
+
+repConstr (PrefixCon ps) (Just res_ty) cons
+    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps
+         res_ty' <- repLTy res_ty
+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
+
+repConstr (RecCon ips) resTy cons
+    = do args     <- concatMapM rep_ip (unLoc ips)
+         arg_vtys <- coreList varBangTypeQTyConName args
+         case resTy of
+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
+           Just res_ty -> do
+             res_ty' <- repLTy res_ty
+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+                                unC res_ty']
+
+    where
+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+
+      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)
+                          ; MkC ty <- repBangTy  t
+                          ; rep2 varBangTypeName [v,ty] }
+
+repConstr (InfixCon st1 st2) Nothing [con]
+    = do arg1 <- repBangTy st1
+         arg2 <- repBangTy st2
+         rep2 infixCName [unC arg1, unC con, unC arg2]
+
+repConstr (InfixCon {}) (Just _) _ =
+    panic "repConstr: infix GADT constructor should be in a PrefixCon"
+repConstr _ _ _ =
+    panic "repConstr: invariant violated"
+
+------------ Types -------------------
+
+repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
+           -> DsM (Core TH.TypeQ)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty)
+    = rep2 forallTName [tvars, ctxt, ty]
+
+repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ
+              -> DsM (Core TH.TypeQ)
+repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
+
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
+
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
+
+repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
+
+repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTapps f []     = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
+
+repTequality :: DsM (Core TH.TypeQ)
+repTequality = rep2 equalityTName []
+
+repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTPromotedList []     = repPromotedNilTyCon
+repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon
+                              ; f <- repTapp tcon t
+                              ; t' <- repTPromotedList ts
+                              ; repTapp f t'
+                              }
+
+repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
+repTLit (MkC lit) = rep2 litTName [lit]
+
+repTWildCard :: DsM (Core TH.TypeQ)
+repTWildCard = rep2 wildCardTName []
+
+repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
+
+repTStar :: DsM (Core TH.TypeQ)
+repTStar = rep2 starKName []
+
+repTConstraint :: DsM (Core TH.TypeQ)
+repTConstraint = rep2 constraintKName []
+
+--------- Type constructors --------------
+
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
+
+repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ
+             -> DsM (Core TH.TypeQ)
+repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
+
+repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = do dflags <- getDynFlags
+                     rep2 tupleTName [mkIntExprInt dflags i]
+
+repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repUnboxedTupleTyCon i = do dflags <- getDynFlags
+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]
+
+repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
+-- Note: not Core TH.SumArity; it's easier to be direct here
+repUnboxedSumTyCon arity = do dflags <- getDynFlags
+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]
+
+repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon = rep2 arrowTName []
+
+repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon = rep2 listTName []
+
+repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repPromotedDataCon (MkC s) = rep2 promotedTName [s]
+
+repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+repPromotedTupleTyCon i = do dflags <- getDynFlags
+                             rep2 promotedTupleTName [mkIntExprInt dflags i]
+
+repPromotedNilTyCon :: DsM (Core TH.TypeQ)
+repPromotedNilTyCon = rep2 promotedNilTName []
+
+repPromotedConsTyCon :: DsM (Core TH.TypeQ)
+repPromotedConsTyCon = rep2 promotedConsTName []
+
+------------ TyVarBndrs -------------------
+
+repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+repPlainTV (MkC nm) = rep2 plainTVName [nm]
+
+repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
+
+----------------------------------------------------------
+--       Type family result signature
+
+repNoSig :: DsM (Core TH.FamilyResultSigQ)
+repNoSig = rep2 noSigName []
+
+repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
+repKindSig (MkC ki) = rep2 kindSigName [ki]
+
+repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
+
+----------------------------------------------------------
+--              Literals
+
+repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
+repLiteral (HsStringPrim _ bs)
+  = do dflags   <- getDynFlags
+       word8_ty <- lookupType word8TyConName
+       let w8s = unpack bs
+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
+                                  [mkWordLit dflags (toInteger w8)]) w8s
+       rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
+repLiteral lit
+  = do lit' <- case lit of
+                   HsIntPrim _ i    -> mk_integer i
+                   HsWordPrim _ w   -> mk_integer w
+                   HsInt _ i        -> mk_integer (il_value i)
+                   HsFloatPrim _ r  -> mk_rational r
+                   HsDoublePrim _ r -> mk_rational r
+                   HsCharPrim _ c   -> mk_char c
+                   _ -> return lit
+       lit_expr <- dsLit lit'
+       case mb_lit_name of
+          Just lit_name -> rep2 lit_name [lit_expr]
+          Nothing -> notHandled "Exotic literal" (ppr lit)
+  where
+    mb_lit_name = case lit of
+                 HsInteger _ _ _  -> Just integerLName
+                 HsInt _ _        -> Just integerLName
+                 HsIntPrim _ _    -> Just intPrimLName
+                 HsWordPrim _ _   -> Just wordPrimLName
+                 HsFloatPrim _ _  -> Just floatPrimLName
+                 HsDoublePrim _ _ -> Just doublePrimLName
+                 HsChar _ _       -> Just charLName
+                 HsCharPrim _ _   -> Just charPrimLName
+                 HsString _ _     -> Just stringLName
+                 HsRat _ _ _      -> Just rationalLName
+                 _                -> Nothing
+
+mk_integer :: Integer -> DsM (HsLit GhcRn)
+mk_integer  i = do integer_ty <- lookupType integerTyConName
+                   return $ HsInteger NoSourceText i integer_ty
+
+mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
+mk_rational r = do rat_ty <- lookupType rationalTyConName
+                   return $ HsRat noExt r rat_ty
+mk_string :: FastString -> DsM (HsLit GhcRn)
+mk_string s = return $ HsString NoSourceText s
+
+mk_char :: Char -> DsM (HsLit GhcRn)
+mk_char c = return $ HsChar NoSourceText c
+
+repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
+repOverloadedLiteral (OverLit { ol_val = val})
+  = do { lit <- mk_lit val; repLiteral lit }
+        -- The type Rational will be in the environment, because
+        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+        -- and rationalL is sucked in when any TH stuff is used
+repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
+
+mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
+mk_lit (HsIntegral i)     = mk_integer  (il_value i)
+mk_lit (HsFractional f)   = mk_rational f
+mk_lit (HsIsString _ s)   = mk_string   s
+
+repNameS :: Core String -> DsM (Core TH.Name)
+repNameS (MkC name) = rep2 mkNameSName [name]
+
+--------------- Miscellaneous -------------------
+
+repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
+
+repBindQ :: Type -> Type        -- a and b
+         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
+repBindQ ty_a ty_b (MkC x) (MkC y)
+  = rep2 bindQName [Type ty_a, Type ty_b, x, y]
+
+repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
+repSequenceQ ty_a (MkC list)
+  = rep2 sequenceQName [Type ty_a, list]
+
+repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repUnboundVar (MkC name) = rep2 unboundVarEName [name]
+
+repOverLabel :: FastString -> DsM (Core TH.ExpQ)
+repOverLabel fs = do
+                    (MkC s) <- coreStringLit $ unpackFS fs
+                    rep2 labelEName [s]
+
+
+------------ Lists -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+repList :: Name -> (a  -> DsM (Core b))
+                    -> [a] -> DsM (Core [b])
+repList tc_name f args
+  = do { args1 <- mapM f args
+       ; coreList tc_name args1 }
+
+coreList :: Name    -- Of the TyCon of the element type
+         -> [Core a] -> DsM (Core [a])
+coreList tc_name es
+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type       -- The element type
+          -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+  -- The list must be non-empty so we can get the element type
+  -- Otherwise use coreList
+nonEmptyCoreList []           = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+coreStringLit :: String -> DsM (Core String)
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+------------------- Maybe ------------------
+
+repMaybe :: Name -> (a -> DsM (Core b))
+                    -> Maybe a -> DsM (Core (Maybe b))
+repMaybe tc_name _ Nothing   = coreNothing tc_name
+repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
+
+-- | Construct Core expression for Nothing of a given type name
+coreNothing :: Name        -- ^ Name of the TyCon of the element type
+            -> DsM (Core (Maybe a))
+coreNothing tc_name =
+    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
+
+-- | Construct Core expression for Nothing of a given type
+coreNothing' :: Type       -- ^ The element type
+             -> Core (Maybe a)
+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
+
+-- | Store given Core expression in a Just of a given type name
+coreJust :: Name        -- ^ Name of the TyCon of the element type
+         -> Core a -> DsM (Core (Maybe a))
+coreJust tc_name es
+  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
+
+-- | Store given Core expression in a Just of a given type
+coreJust' :: Type       -- ^ The element type
+          -> Core a -> Core (Maybe a)
+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
+
+------------------- Maybe Lists ------------------
+
+repMaybeList :: Name -> (a -> DsM (Core b))
+                        -> Maybe [a] -> DsM (Core (Maybe [b]))
+repMaybeList tc_name _ Nothing = coreNothingList tc_name
+repMaybeList tc_name f (Just args)
+  = do { elt_ty <- lookupType tc_name
+       ; args1 <- mapM f args
+       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+
+coreNothingList :: Name -> DsM (Core (Maybe [a]))
+coreNothingList tc_name
+  = do { elt_ty <- lookupType tc_name
+       ; return $ coreNothing' (mkListTy elt_ty) }
+
+coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
+coreJustList tc_name args
+  = do { elt_ty <- lookupType tc_name
+       ; return $ coreJust' (mkListTy elt_ty) args }
+
+------------ Literals & Variables -------------------
+
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = do dflags <- getDynFlags
+                  return (MkC (mkIntExprInt dflags i))
+
+coreIntegerLit :: Integer -> DsM (Core Integer)
+coreIntegerLit i = fmap MkC (mkIntegerExpr i)
+
+coreVar :: Id -> Core TH.Name   -- The Id has type Name
+coreVar id = MkC (Var id)
+
+----------------- Failure -----------------------
+notHandledL :: SrcSpan -> String -> SDoc -> DsM a
+notHandledL loc what doc
+  | isGoodSrcSpan loc
+  = putSrcSpanDs loc $ notHandled what doc
+  | otherwise
+  = notHandled what doc
+
+notHandled :: String -> SDoc -> DsM a
+notHandled what doc = failWithDs msg
+  where
+    msg = hang (text what <+> text "not (yet) handled by Template Haskell")
+             2 doc
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsMonad.hs
@@ -0,0 +1,628 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+@DsMonad@: monadery used in desugaring
+-}
+
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
+{-# LANGUAGE ViewPatterns #-}
+
+module DsMonad (
+        DsM, mapM, mapAndUnzipM,
+        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
+        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
+        Applicative(..),(<$>),
+
+        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
+        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
+        newFailLocalDs, newPredVarDs,
+        getSrcSpanDs, putSrcSpanDs,
+        mkPrintUnqualifiedDs,
+        newUnique,
+        UniqSupply, newUniqueSupply,
+        getGhcModeDs, dsGetFamInstEnvs,
+        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
+        dsLookupDataCon, dsLookupConLike,
+
+        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
+
+        -- Getting and setting EvVars and term constraints in local environment
+        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
+
+        -- Iterations for pm checking
+        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
+
+        -- Warnings and errors
+        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
+        failWithDs, failDs, discardWarningsDs,
+        askNoErrsDs,
+
+        -- Data types
+        DsMatchContext(..),
+        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
+        CanItFail(..), orFail,
+
+        -- Levity polymorphism
+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
+
+        -- Trace injection
+        pprRuntimeTrace
+    ) where
+
+import GhcPrelude
+
+import TcRnMonad
+import FamInstEnv
+import CoreSyn
+import MkCore    ( unitExpr )
+import CoreUtils ( exprType, isExprLevPoly )
+import HsSyn
+import TcIface
+import TcMType ( checkForLevPolyX, formatLevPolyErr )
+import PrelNames
+import RdrName
+import HscTypes
+import Bag
+import BasicTypes ( Origin )
+import DataCon
+import ConLike
+import TyCon
+import PmExpr
+import Id
+import Module
+import Outputable
+import SrcLoc
+import Type
+import UniqSupply
+import Name
+import NameEnv
+import DynFlags
+import ErrUtils
+import FastString
+import Var (EvVar)
+import UniqFM ( lookupWithDefaultUFM )
+import Literal ( mkLitString )
+import CostCentreState
+
+import Data.IORef
+
+{-
+************************************************************************
+*                                                                      *
+                Data types for the desugarer
+*                                                                      *
+************************************************************************
+-}
+
+data DsMatchContext
+  = DsMatchContext (HsMatchContext Name) SrcSpan
+  deriving ()
+
+instance Outputable DsMatchContext where
+  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
+
+data EquationInfo
+  = EqnInfo { eqn_pats :: [Pat GhcTc]
+              -- ^ The patterns for an equation
+              --
+              -- NB: We have /already/ applied 'decideBangHood' to
+              -- these patterns.  See Note [decideBangHood] in "DsUtils"
+
+            , eqn_orig :: Origin
+              -- ^ Was this equation present in the user source?
+              --
+              -- This helps us avoid warnings on patterns that GHC elaborated.
+              --
+              -- For instance, the pattern @-1 :: Word@ gets desugared into
+              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
+              -- literal for /both/ of these cases.
+
+            , eqn_rhs  :: MatchResult
+              -- ^ What to do after match
+            }
+
+instance Outputable EquationInfo where
+    ppr (EqnInfo pats _ _) = ppr pats
+
+type DsWrapper = CoreExpr -> CoreExpr
+idDsWrapper :: DsWrapper
+idDsWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+--      \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+  = MatchResult
+        CanItFail       -- Tells whether the failure expression is used
+        (CoreExpr -> DsM CoreExpr)
+                        -- Takes a expression to plug in at the
+                        -- failure point(s). The expression should
+                        -- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail :: CanItFail -> CanItFail -> CanItFail
+orFail CantFail CantFail = CantFail
+orFail _        _        = CanFail
+
+{-
+************************************************************************
+*                                                                      *
+                Monad functions
+*                                                                      *
+************************************************************************
+-}
+
+-- Compatibility functions
+fixDs :: (a -> DsM a) -> DsM a
+fixDs    = fixM
+
+type DsWarning = (SrcSpan, SDoc)
+        -- Not quite the same as a WarnMsg, we have an SDoc here
+        -- and we'll do the print_unqual stuff later on to turn it
+        -- into a Doc.
+
+-- | Run a 'DsM' action inside the 'TcM' monad.
+initDsTc :: DsM a -> TcM a
+initDsTc thing_inside
+  = do { tcg_env  <- getGblEnv
+       ; msg_var  <- getErrsVar
+       ; hsc_env  <- getTopEnv
+       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; setEnvs envs thing_inside
+       }
+
+-- | Run a 'DsM' action inside the 'IO' monad.
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
+initDs hsc_env tcg_env thing_inside
+  = do { msg_var <- newIORef emptyMessages
+       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; runDs hsc_env envs thing_inside
+       }
+
+-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
+mkDsEnvsFromTcGbl :: MonadIO m
+                  => HscEnv -> IORef Messages -> TcGblEnv
+                  -> m (DsGblEnv, DsLclEnv)
+mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+  = do { pm_iter_var <- liftIO $ newIORef 0
+       ; cc_st_var   <- liftIO $ newIORef newCostCentreState
+       ; let dflags   = hsc_dflags hsc_env
+             this_mod = tcg_mod tcg_env
+             type_env = tcg_type_env tcg_env
+             rdr_env  = tcg_rdr_env tcg_env
+             fam_inst_env = tcg_fam_inst_env tcg_env
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ tcg_complete_matches tcg_env
+       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+                           msg_var pm_iter_var cc_st_var complete_matches
+       }
+
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
+runDs hsc_env (ds_gbl, ds_lcl) thing_inside
+  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
+                              (tryM thing_inside)
+       ; msgs   <- readIORef (ds_msgs ds_gbl)
+       ; let final_res
+               | errorsFound dflags msgs = Nothing
+               | Right r <- res          = Just r
+               | otherwise               = panic "initDs"
+       ; return (msgs, final_res)
+       }
+  where dflags = hsc_dflags hsc_env
+
+-- | Run a 'DsM' action in the context of an existing 'ModGuts'
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
+initDsWithModGuts hsc_env guts thing_inside
+  = do { pm_iter_var <- newIORef 0
+       ; cc_st_var   <- newIORef newCostCentreState
+       ; msg_var <- newIORef emptyMessages
+       ; let dflags   = hsc_dflags hsc_env
+             type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
+             rdr_env  = mg_rdr_env guts
+             fam_inst_env = mg_fam_inst_env guts
+             this_mod = mg_module guts
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ mg_complete_sigs guts
+
+             bindsToIds (NonRec v _)   = [v]
+             bindsToIds (Rec    binds) = map fst binds
+             ids = concatMap bindsToIds (mg_binds guts)
+
+             envs  = mkDsEnvs dflags this_mod rdr_env type_env
+                              fam_inst_env msg_var pm_iter_var
+                              cc_st_var complete_matches
+       ; runDs hsc_env envs thing_inside
+       }
+
+initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
+-- Spin up a TcM context so that we can run the constraint solver
+-- Returns any error messages generated by the constraint solver
+-- and (Just res) if no error happened; Nothing if an error happened
+--
+-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
+--             only to immediately refine it to a TcS monad.
+-- Better perhaps to make TcS into its own monad, rather than building on TcS
+-- But that may in turn interact with plugins
+
+initTcDsForSolver thing_inside
+  = do { (gbl, lcl) <- getEnvs
+       ; hsc_env    <- getTopEnv
+
+       ; let DsGblEnv { ds_mod = mod
+                      , ds_fam_inst_env = fam_inst_env } = gbl
+
+             DsLclEnv { dsl_loc = loc }                  = lcl
+
+       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
+         thing_inside }
+
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+         -> IORef Messages -> IORef Int -> IORef CostCentreState
+         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
+         complete_matches
+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
+                             if_rec_types = Just (mod, return type_env) }
+        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
+                             False -- not boot!
+        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
+        completeMatchMap = mkCompleteMatchMap complete_matches
+        gbl_env = DsGblEnv { ds_mod     = mod
+                           , ds_fam_inst_env = fam_inst_env
+                           , ds_if_env  = (if_genv, if_lenv)
+                           , ds_unqual  = mkPrintUnqualified dflags rdr_env
+                           , ds_msgs    = msg_var
+                           , ds_complete_matches = completeMatchMap
+                           , ds_cc_st   = cc_st_var
+                           }
+        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
+                           , dsl_loc     = real_span
+                           , dsl_dicts   = emptyBag
+                           , dsl_tm_cs   = emptyBag
+                           , dsl_pm_iter = pmvar
+                           }
+    in (gbl_env, lcl_env)
+
+
+{-
+************************************************************************
+*                                                                      *
+                Operations in the monad
+*                                                                      *
+************************************************************************
+
+And all this mysterious stuff is so we can occasionally reach out and
+grab one or more names.  @newLocalDs@ isn't exported---exported
+functions are defined with it.  The difference in name-strings makes
+it easier to read debugging output.
+
+Note [Levity polymorphism checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the "Levity Polymorphism" paper (PLDI '17), levity
+polymorphism is forbidden in precisely two places: in the type of a bound
+term-level argument and in the type of an argument to a function. The paper
+explains it more fully, but briefly: expressions in these contexts need to be
+stored in registers, and it's hard (read, impossible) to store something
+that's levity polymorphic.
+
+We cannot check for bad levity polymorphism conveniently in the type checker,
+because we can't tell, a priori, which levity metavariables will be solved.
+At one point, I (Richard) thought we could check in the zonker, but it's hard
+to know where precisely are the abstracted variables and the arguments. So
+we check in the desugarer, the only place where we can see the Core code and
+still report respectable syntax to the user. This covers the vast majority
+of cases; see calls to DsMonad.dsNoLevPoly and friends.
+
+Levity polymorphism is also prohibited in the types of binders, and the
+desugarer checks for this in GHC-generated Ids. (The zonker handles
+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
+The newSysLocalDs variant is used in the vast majority of cases where
+the binder is obviously not levity polymorphic, omitting the check.
+It would be nice to ASSERT that there is no levity polymorphism here,
+but we can't, because of the fixM in DsArrows. It's all OK, though:
+Core Lint will catch an error here.
+
+However, the desugarer is the wrong place for certain checks. In particular,
+the desugarer can't report a sensible error message if an HsWrapper is malformed.
+After all, GHC itself produced the HsWrapper. So we store some message text
+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
+desugarer.
+
+There are a few more checks in places where Core is generated outside the
+desugarer. For example, in datatype and class declarations, where levity
+polymorphism is checked for during validity checking. It would be nice to
+have one central place for all this, but that doesn't seem possible while
+still reporting nice error messages.
+
+-}
+
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Id -> Type -> DsM Id
+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
+
+duplicateLocalDs :: Id -> DsM Id
+duplicateLocalDs old_local
+  = do  { uniq <- newUnique
+        ; return (setIdUnique old_local uniq) }
+
+newPredVarDs :: PredType -> DsM Var
+newPredVarDs pred
+ = newSysLocalDs pred
+
+newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDsNoLP  = mk_local (fsLit "ds")
+
+-- this variant should be used when the caller can be sure that the variable type
+-- is not levity-polymorphic. It is necessary when the type is knot-tied because
+-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
+newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
+newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
+  -- the fail variable is used only in a situation where we can tell that
+  -- levity-polymorphism is impossible.
+
+newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
+newSysLocalsDs = mapM newSysLocalDs
+
+mk_local :: FastString -> Type -> DsM Id
+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
+                                      ppr ty)  -- could improve the msg with another
+                                               -- parameter indicating context
+                    ; mkSysLocalOrCoVarM fs ty }
+
+{-
+We can also reach out and either set/grab location information from
+the @SrcSpan@ being carried around.
+-}
+
+getGhcModeDs :: DsM GhcMode
+getGhcModeDs =  getDynFlags >>= return . ghcMode
+
+-- | Get in-scope type constraints (pm check)
+getDictsDs :: DsM (Bag EvVar)
+getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
+
+-- | Add in-scope type constraints (pm check)
+addDictsDs :: Bag EvVar -> DsM a -> DsM a
+addDictsDs ev_vars
+  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
+
+-- | Get in-scope term constraints (pm check)
+getTmCsDs :: DsM (Bag SimpleEq)
+getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
+
+-- | Add in-scope term constraints (pm check)
+addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
+addTmCsDs tm_cs
+  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
+
+-- | Increase the counter for elapsed pattern match check iterations.
+-- If the current counter is already over the limit, fail
+incrCheckPmIterDs :: DsM Int
+incrCheckPmIterDs = do
+  env <- getLclEnv
+  cnt <- readTcRef (dsl_pm_iter env)
+  max_iters <- maxPmCheckIterations <$> getDynFlags
+  if cnt >= max_iters
+    then failM
+    else updTcRef (dsl_pm_iter env) (+1)
+  return cnt
+
+-- | Reset the counter for pattern match check iterations to zero
+resetPmIterDs :: DsM ()
+resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
+
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv
+                  ; return (RealSrcSpan (dsl_loc env)) }
+
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs (UnhelpfulSpan {}) thing_inside
+  = thing_inside
+putSrcSpanDs (RealSrcSpan real_span) thing_inside
+  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
+
+-- | Emit a warning for the current source location
+-- NB: Warns whether or not -Wxyz is set
+warnDs :: WarnReason -> SDoc -> DsM ()
+warnDs reason warn
+  = do { env <- getGblEnv
+       ; loc <- getSrcSpanDs
+       ; dflags <- getDynFlags
+       ; let msg = makeIntoWarning reason $
+                   mkWarnMsg dflags loc (ds_unqual env) warn
+       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+
+-- | Emit a warning only if the correct WarnReason is set in the DynFlags
+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
+warnIfSetDs flag warn
+  = whenWOptM flag $
+    warnDs (Reason flag) warn
+
+errDs :: SDoc -> DsM ()
+errDs err
+  = do  { env <- getGblEnv
+        ; loc <- getSrcSpanDs
+        ; dflags <- getDynFlags
+        ; let msg = mkErrMsg dflags loc (ds_unqual env) err
+        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+
+-- | Issue an error, but return the expression for (), so that we can continue
+-- reporting errors.
+errDsCoreExpr :: SDoc -> DsM CoreExpr
+errDsCoreExpr err
+  = do { errDs err
+       ; return unitExpr }
+
+failWithDs :: SDoc -> DsM a
+failWithDs err
+  = do  { errDs err
+        ; failM }
+
+failDs :: DsM a
+failDs = failM
+
+-- (askNoErrsDs m) runs m
+-- If m fails,
+--    then (askNoErrsDs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrsDs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+--
+-- c.f. TcRnMonad.askNoErrs
+askNoErrsDs :: DsM a -> DsM (a, Bool)
+askNoErrsDs thing_inside
+ = do { errs_var <- newMutVar emptyMessages
+      ; env <- getGblEnv
+      ; mb_res <- tryM $  -- Be careful to catch exceptions
+                          -- so that we propagate errors correctly
+                          -- (#13642)
+                  setGblEnv (env { ds_msgs = errs_var }) $
+                  thing_inside
+
+      -- Propagate errors
+      ; msgs@(warns, errs) <- readMutVar errs_var
+      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+
+      -- And return
+      ; case mb_res of
+           Left _    -> failM
+           Right res -> do { dflags <- getDynFlags
+                           ; let errs_found = errorsFound dflags msgs
+                           ; return (res, not errs_found) } }
+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
+
+instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
+    lookupThing = dsLookupGlobal
+
+dsLookupGlobal :: Name -> DsM TyThing
+-- Very like TcEnv.tcLookupGlobal
+dsLookupGlobal name
+  = do  { env <- getGblEnv
+        ; setEnvs (ds_if_env env)
+                  (tcIfaceGlobal name) }
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name
+  = tyThingId <$> dsLookupGlobal name
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+  = tyThingTyCon <$> dsLookupGlobal name
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+  = tyThingDataCon <$> dsLookupGlobal name
+
+dsLookupConLike :: Name -> DsM ConLike
+dsLookupConLike name
+  = tyThingConLike <$> dsLookupGlobal name
+
+
+dsGetFamInstEnvs :: DsM FamInstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+dsGetFamInstEnvs
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
+
+dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
+
+-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
+dsGetCompleteMatches tc = do
+  eps <- getEps
+  env <- getGblEnv
+  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
+      eps_matches_list = lookup_completes $ eps_complete_matches eps
+      env_matches_list = lookup_completes $ ds_complete_matches env
+  return $ eps_matches_list ++ env_matches_list
+
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv thing_inside
+  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
+
+discardWarningsDs :: DsM a -> DsM a
+-- Ignore warnings inside the thing inside;
+-- used to ignore inaccessable cases etc. inside generated code
+discardWarningsDs thing_inside
+  = do  { env <- getGblEnv
+        ; old_msgs <- readTcRef (ds_msgs env)
+
+        ; result <- thing_inside
+
+        -- Revert messages to old_msgs
+        ; writeTcRef (ds_msgs env) old_msgs
+
+        ; return result }
+
+-- | Fail with an error message if the type is levity polymorphic.
+dsNoLevPoly :: Type -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
+
+-- | Check an expression for levity polymorphism, failing if it is
+-- levity polymorphic.
+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPolyExpr e doc
+  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
+  | otherwise       = return ()
+
+-- | Runs the thing_inside. If there are no errors, then returns the expr
+-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
+-- of levity polymorphism checks and then avoiding making a core App.
+-- (If we make a core App on a levity polymorphic argument, detecting how
+-- to handle the let/app invariant might call isUnliftedType, which panics
+-- on a levity polymorphic type.)
+-- See #12709 for an example of why this machinery is necessary.
+dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
+dsWhenNoErrs thing_inside mk_expr
+  = do { (result, no_errs) <- askNoErrsDs thing_inside
+       ; return $ if no_errs
+                  then mk_expr result
+                  else unitExpr }
+
+-- | Inject a trace message into the compiled program. Whereas
+-- pprTrace prints out information *while compiling*, pprRuntimeTrace
+-- captures that information and causes it to be printed *at runtime*
+-- using Debug.Trace.trace.
+--
+--   pprRuntimeTrace hdr doc expr
+--
+-- will produce an expression that looks like
+--
+--   trace (hdr + doc) expr
+--
+-- When using this to debug a module that Debug.Trace depends on,
+-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
+-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
+-- but that doesn't seem worth the effort and maintenance cost.
+pprRuntimeTrace :: String   -- ^ header
+                -> SDoc     -- ^ information to output
+                -> CoreExpr -- ^ expression
+                -> DsM CoreExpr
+pprRuntimeTrace str doc expr = do
+  traceId <- dsLookupGlobalId traceName
+  unpackCStringId <- dsLookupGlobalId unpackCStringName
+  dflags <- getDynFlags
+  let message :: CoreExpr
+      message = App (Var unpackCStringId) $
+                Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
+  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsUsage.hs
@@ -0,0 +1,373 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsUsage (
+    -- * Dependency/fingerprinting code (used by MkIface)
+    mkUsageInfo, mkUsedNames, mkDependencies
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import HscTypes
+import TcRnTypes
+import Name
+import NameSet
+import Module
+import Outputable
+import Util
+import UniqSet
+import UniqFM
+import Fingerprint
+import Maybes
+import Packages
+import Finder
+
+import Control.Monad (filterM)
+import Data.List
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import System.Directory
+import System.FilePath
+
+{- Note [Module self-dependency]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+RnNames.calculateAvails asserts the invariant that a module must not occur in
+its own dep_orphs or dep_finsts. However, if we aren't careful this can occur
+in the presence of hs-boot files: Consider that we have two modules, A and B,
+both with hs-boot files,
+
+    A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A
+    A.hs-boot declares an orphan instance A.hs defines the orphan instance
+
+In this case, B's dep_orphs will contain A due to its SOURCE import of A.
+Consequently, A will contain itself in its imp_orphs due to its import of B.
+This fact would end up being recorded in A's interface file. This would then
+break the invariant asserted by calculateAvails that a module does not itself in
+its dep_orphs. This was the cause of #14128.
+
+-}
+
+-- | Extract information from the rename and typecheck phases to produce
+-- a dependencies information for the module being compiled.
+--
+-- The first argument is additional dependencies from plugins
+mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
+mkDependencies iuid pluginModules
+          (TcGblEnv{ tcg_mod = mod,
+                    tcg_imports = imports,
+                    tcg_th_used = th_var
+                  })
+ = do
+      -- Template Haskell used?
+      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]
+          plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)
+      th_used <- readIORef th_var
+      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)
+                                             (moduleName mod))
+                -- M.hi-boot can be in the imp_dep_mods, but we must remove
+                -- it before recording the modules on which this one depends!
+                -- (We want to retain M.hi-boot in imp_dep_mods so that
+                --  loadHiBootInterface can see if M's direct imports depend
+                --  on M.hi-boot, and hence that we should do the hi-boot consistency
+                --  check.)
+
+          dep_orphs = filter (/= mod) (imp_orphs imports)
+                -- We must also remove self-references from imp_orphs. See
+                -- Note [Module self-dependency]
+
+          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
+
+          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) raw_pkgs
+               | otherwise = raw_pkgs
+
+          -- Set the packages required to be Safe according to Safe Haskell.
+          -- See Note [RnNames . Tracking Trust Transitively]
+          sorted_pkgs = sort (Set.toList pkgs)
+          trust_pkgs  = imp_trust_pkgs imports
+          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
+
+      return Deps { dep_mods   = dep_mods,
+                    dep_pkgs   = dep_pkgs',
+                    dep_orphs  = dep_orphs,
+                    dep_plgins = dep_plgins,
+                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
+                    -- sort to get into canonical order
+                    -- NB. remember to use lexicographic ordering
+
+mkUsedNames :: TcGblEnv -> NameSet
+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
+
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
+            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]
+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
+  pluginModules
+  = do
+    eps <- hscEPS hsc_env
+    hashes <- mapM getFileHash dependent_files
+    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules
+    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
+                                       dir_imp_mods used_names
+        usages = mod_usages ++ [ UsageFile { usg_file_path = f
+                                           , usg_file_hash = hash }
+                               | (f, hash) <- zip dependent_files hashes ]
+                            ++ [ UsageMergedRequirement
+                                    { usg_mod = mod,
+                                      usg_mod_hash = hash
+                                    }
+                               | (mod, hash) <- merged ]
+                            ++ concat plugin_usages
+    usages `seqList` return usages
+    -- seq the list of Usages returned: occasionally these
+    -- don't get evaluated for a while and we can end up hanging on to
+    -- the entire collection of Ifaces.
+
+{- Note [Plugin dependencies]
+Modules for which plugins were used in the compilation process, should be
+recompiled whenever one of those plugins changes. But how do we know if a
+plugin changed from the previous time a module was compiled?
+
+We could try storing the fingerprints of the interface files of plugins in
+the interface file of the module. And see if there are changes between
+compilation runs. However, this is pretty much a non-option because interface
+fingerprints of plugin modules are fairly stable, unless you compile plugins
+with optimisations turned on, and give basically all binders an INLINE pragma.
+
+So instead:
+
+  * For plugins that were built locally: we store the filepath and hash of the
+    object files of the module with the `plugin` binder, and the object files of
+    modules that are dependencies of the plugin module and belong to the same
+    `UnitId` as the plugin
+  * For plugins in an external package: we store the filepath and hash of
+    the dynamic library containing the plugin module.
+
+During recompilation we then compare the hashes of those files again to see
+if anything has changed.
+
+One issue with this approach is that object files are currently (GHC 8.6.1)
+not created fully deterministicly, which could sometimes induce accidental
+recompilation of a module for which plugins were used in the compile process.
+
+One way to improve this is to either:
+
+  * Have deterministic object file creation
+  * Create and store implementation hashes, which would be based on the Core
+    of the module and the implementation hashes of its dependencies, and then
+    compare implementation hashes for recompilation. Creation of implementation
+    hashes is however potentially expensive.
+-}
+mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]
+mkPluginUsage hsc_env pluginModule
+  = case lookupPluginModuleWithSuggestions dflags pNm Nothing of
+    LookupFound _ pkg -> do
+    -- The plugin is from an external package:
+    -- search for the library files containing the plugin.
+      let searchPaths = collectLibraryPaths dflags [pkg]
+          useDyn = WayDyn `elem` ways dflags
+          suffix = if useDyn then soExt platform else "a"
+          libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix
+                    | searchPath <- searchPaths
+                    , libLoc     <- packageHsLibs dflags pkg
+                    ]
+          -- we also try to find plugin library files by adding WayDyn way,
+          -- if it isn't already present (see trac #15492)
+          paths =
+            if useDyn
+              then libLocs
+              else
+                let dflags'  = updateWays (addWay' WayDyn dflags)
+                    dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc
+                               | searchPath <- searchPaths
+                               , dlibLoc    <- packageHsLibs dflags' pkg
+                               ]
+                in libLocs ++ dlibLocs
+      files <- filterM doesFileExist paths
+      case files of
+        [] ->
+          pprPanic
+             ( "mkPluginUsage: missing plugin library, tried:\n"
+              ++ unlines paths
+             )
+             (ppr pNm)
+        _  -> mapM hashFile (nub files)
+    _ -> do
+      foundM <- findPluginModule hsc_env pNm
+      case foundM of
+      -- The plugin was built locally: look up the object file containing
+      -- the `plugin` binder, and all object files belong to modules that are
+      -- transitive dependencies of the plugin that belong to the same package.
+        Found ml _ -> do
+          pluginObject <- hashFile (ml_obj_file ml)
+          depObjects   <- catMaybes <$> mapM lookupObjectFile deps
+          return (nub (pluginObject : depObjects))
+        _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)
+  where
+    dflags   = hsc_dflags hsc_env
+    platform = targetPlatform dflags
+    pNm      = moduleName (mi_module pluginModule)
+    pPkg     = moduleUnitId (mi_module pluginModule)
+    deps     = map fst (dep_mods (mi_deps pluginModule))
+
+    -- Lookup object file for a plugin dependency,
+    -- from the same package as the plugin.
+    lookupObjectFile nm = do
+      foundM <- findImportedModule hsc_env nm Nothing
+      case foundM of
+        Found ml m
+          | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml)
+          | otherwise              -> return Nothing
+        _ -> pprPanic "mkPluginUsage: no object for dependency"
+                      (ppr pNm <+> ppr nm)
+
+    hashFile f = do
+      fExist <- doesFileExist f
+      if fExist
+         then do
+            h <- getFileHash f
+            return (UsageFile f h)
+         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)
+
+mk_mod_usage_info :: PackageIfaceTable
+              -> HscEnv
+              -> Module
+              -> ImportedMods
+              -> NameSet
+              -> [Usage]
+mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
+  = mapMaybe mkUsage usage_mods
+  where
+    hpt = hsc_HPT hsc_env
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+    used_mods    = moduleEnvKeys ent_map
+    dir_imp_mods = moduleEnvKeys direct_imports
+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
+    usage_mods   = sortBy stableModuleCmp all_mods
+                        -- canonical order is imported, to avoid interface-file
+                        -- wobblage.
+
+    -- ent_map groups together all the things imported and used
+    -- from a particular module
+    ent_map :: ModuleEnv [OccName]
+    ent_map  = nonDetFoldUniqSet add_mv emptyModuleEnv used_names
+     -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
+     -- in ent_hashs
+     where
+      add_mv name mv_map
+        | isWiredInName name = mv_map  -- ignore wired-in names
+        | otherwise
+        = case nameModule_maybe name of
+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
+                -- See Note [Internal used_names]
+
+             Just mod ->
+                -- See Note [Identity versus semantic module]
+                let mod' = if isHoleModule mod
+                            then mkModule this_pkg (moduleName mod)
+                            else mod
+                -- This lambda function is really just a
+                -- specialised (++); originally came about to
+                -- avoid quadratic behaviour (trac #2680)
+                in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]
+            where occ = nameOccName name
+
+    -- We want to create a Usage for a home module if
+    --  a) we used something from it; has something in used_names
+    --  b) we imported it, even if we used nothing from it
+    --     (need to recompile if its export list changes: export_fprint)
+    mkUsage :: Module -> Maybe Usage
+    mkUsage mod
+      | isNothing maybe_iface           -- We can't depend on it if we didn't
+                                        -- load its interface.
+      || mod == this_mod                -- We don't care about usages of
+                                        -- things in *this* module
+      = Nothing
+
+      | moduleUnitId mod /= this_pkg
+      = Just UsagePackageModule{ usg_mod      = mod,
+                                 usg_mod_hash = mod_hash,
+                                 usg_safe     = imp_safe }
+        -- for package modules, we record the module hash only
+
+      | (null used_occs
+          && isNothing export_hash
+          && not is_direct_import
+          && not finsts_mod)
+      = Nothing                 -- Record no usage info
+        -- for directly-imported modules, we always want to record a usage
+        -- on the orphan hash.  This is what triggers a recompilation if
+        -- an orphan is added or removed somewhere below us in the future.
+
+      | otherwise
+      = Just UsageHomeModule {
+                      usg_mod_name = moduleName mod,
+                      usg_mod_hash = mod_hash,
+                      usg_exports  = export_hash,
+                      usg_entities = Map.toList ent_hashs,
+                      usg_safe     = imp_safe }
+      where
+        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
+                -- In one-shot mode, the interfaces for home-package
+                -- modules accumulate in the PIT not HPT.  Sigh.
+
+        Just iface   = maybe_iface
+        finsts_mod   = mi_finsts    iface
+        hash_env     = mi_hash_fn   iface
+        mod_hash     = mi_mod_hash  iface
+        export_hash | depend_on_exports = Just (mi_exp_hash iface)
+                    | otherwise         = Nothing
+
+        by_is_safe (ImportedByUser imv) = imv_is_safe imv
+        by_is_safe _ = False
+        (is_direct_import, imp_safe)
+            = case lookupModuleEnv direct_imports mod of
+                -- ezyang: I'm not sure if any is the correct
+                -- metric here. If safety was guaranteed to be uniform
+                -- across all imports, why did the old code only look
+                -- at the first import?
+                Just bys -> (True, any by_is_safe bys)
+                Nothing  -> (False, safeImplicitImpsReq dflags)
+                -- Nothing case is for references to entities which were
+                -- not directly imported (NB: the "implicit" Prelude import
+                -- counts as directly imported!  An entity is not directly
+                -- imported if, e.g., we got a reference to it from a
+                -- reexport of another module.)
+
+        used_occs = lookupModuleEnv ent_map mod `orElse` []
+
+        -- Making a Map here ensures that (a) we remove duplicates
+        -- when we have usages on several subordinates of a single parent,
+        -- and (b) that the usages emerge in a canonical order, which
+        -- is why we use Map rather than OccEnv: Map works
+        -- using Ord on the OccNames, which is a lexicographic ordering.
+        ent_hashs :: Map OccName Fingerprint
+        ent_hashs = Map.fromList (map lookup_occ used_occs)
+
+        lookup_occ occ =
+            case hash_env occ of
+                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
+                Just r  -> r
+
+        depend_on_exports = is_direct_import
+        {- True
+              Even if we used 'import M ()', we have to register a
+              usage on the export list because we are sensitive to
+              changes in orphan instances/rules.
+           False
+              In GHC 6.8.x we always returned true, and in
+              fact it recorded a dependency on *all* the
+              modules underneath in the dependency tree.  This
+              happens to make orphans work right, but is too
+              expensive: it'll read too many interface files.
+              The 'isNothing maybe_iface' check above saved us
+              from generating many of these usages (at least in
+              one-shot mode), but that's even more bogus!
+        -}
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsUtils.hs
@@ -0,0 +1,1001 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Utilities for desugaring
+
+This module exports some utility functions of no great interest.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Utility functions for constructing Core syntax, principally for desugaring
+module DsUtils (
+        EquationInfo(..),
+        firstPat, shiftEqns,
+
+        MatchResult(..), CanItFail(..), CaseAlt(..),
+        cantFailMatchResult, alwaysFailMatchResult,
+        extractMatchResult, combineMatchResults,
+        adjustMatchResult,  adjustMatchResultDs,
+        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
+        matchCanFail, mkEvalMatchResult,
+        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
+        wrapBind, wrapBinds,
+
+        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
+
+        seqVar,
+
+        -- LHs tuples
+        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
+        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
+
+        mkSelectorBinds,
+
+        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
+        isTrueLHsExpr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} Match  ( matchSimply )
+import {-# SOURCE #-} DsExpr ( dsLExpr )
+
+import HsSyn
+import TcHsSyn
+import TcType( tcSplitTyConApp )
+import CoreSyn
+import DsMonad
+
+import CoreUtils
+import MkCore
+import MkId
+import Id
+import Literal
+import TyCon
+import DataCon
+import PatSyn
+import Type
+import Coercion
+import TysPrim
+import TysWiredIn
+import BasicTypes
+import ConLike
+import UniqSet
+import UniqSupply
+import Module
+import PrelNames
+import Name( isInternalName )
+import Outputable
+import SrcLoc
+import Util
+import DynFlags
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import TcEvidence
+
+import Control.Monad    ( zipWithM )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{ Selecting match variables}
+*                                                                      *
+************************************************************************
+
+We're about to match against some patterns.  We want to make some
+@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
+hand, which should indeed be bound to the pattern as a whole, then use it;
+otherwise, make one up.
+-}
+
+selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
+
+-- (selectMatchVars ps tys) chooses variables of type tys
+-- to use for matching ps against.  If the pattern is a variable,
+-- we try to use that, to save inventing lots of fresh variables.
+--
+-- OLD, but interesting note:
+--    But even if it is a variable, its type might not match.  Consider
+--      data T a where
+--        T1 :: Int -> T Int
+--        T2 :: a   -> T a
+--
+--      f :: T a -> a -> Int
+--      f (T1 i) (x::Int) = x
+--      f (T2 i) (y::a)   = 0
+--    Then we must not choose (x::Int) as the matching variable!
+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
+
+selectMatchVars :: [Pat GhcTc] -> DsM [Id]
+-- Postcondition: the returned Ids have Internal Names
+selectMatchVars ps = mapM selectMatchVar ps
+
+selectMatchVar :: Pat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))
+                                  -- Note [Localise pattern binders]
+selectMatchVar (AsPat _ var _) = return (unLoc var)
+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
+                                  -- OK, better make up one...
+
+{- Note [Localise pattern binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider     module M where
+               [Just a] = e
+After renaming it looks like
+             module M where
+               [Just M.a] = e
+
+We don't generalise, since it's a pattern binding, monomorphic, etc,
+so after desugaring we may get something like
+             M.a = case e of (v:_) ->
+                   case v of Just M.a -> M.a
+Notice the "M.a" in the pattern; after all, it was in the original
+pattern.  However, after optimisation those pattern binders can become
+let-binders, and then end up floated to top level.  They have a
+different *unique* by then (the simplifier is good about maintaining
+proper scoping), but it's BAD to have two top-level bindings with the
+External Name M.a, because that turns into two linker symbols for M.a.
+It's quite rare for this to actually *happen* -- the only case I know
+of is tc003 compiled with the 'hpc' way -- but that only makes it
+all the more annoying.
+
+To avoid this, we craftily call 'localiseId' in the desugarer, which
+simply turns the External Name for the Id into an Internal one, but
+doesn't change the unique.  So the desugarer produces this:
+             M.a{r8} = case e of (v:_) ->
+                       case v of Just a{r8} -> M.a{r8}
+The unique is still 'r8', but the binding site in the pattern
+is now an Internal Name.  Now the simplifier's usual mechanisms
+will propagate that Name to all the occurrence sites, as well as
+un-shadowing it, so we'll get
+             M.a{r8} = case e of (v:_) ->
+                       case v of Just a{s77} -> a{s77}
+In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
+runs on the output of the desugarer, so all is well by the end of
+the desugaring pass.
+
+See also Note [MatchIds] in Match.hs
+
+************************************************************************
+*                                                                      *
+* type synonym EquationInfo and access functions for its pieces        *
+*                                                                      *
+************************************************************************
+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
+
+The ``equation info'' used by @match@ is relatively complicated and
+worthy of a type synonym and a few handy functions.
+-}
+
+firstPat :: EquationInfo -> Pat GhcTc
+firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
+
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+-- Drop the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
+
+-- Functions on MatchResults
+
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _)  = True
+matchCanFail (MatchResult CantFail _) = False
+
+alwaysFailMatchResult :: MatchResult
+alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
+
+cantFailMatchResult :: CoreExpr -> MatchResult
+cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
+
+extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
+extractMatchResult (MatchResult CantFail match_fn) _
+  = match_fn (error "It can't fail!")
+
+extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
+    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
+    body <- match_fn if_it_fails
+    return (mkCoreLet fail_bind body)
+
+
+combineMatchResults :: MatchResult -> MatchResult -> MatchResult
+combineMatchResults (MatchResult CanFail      body_fn1)
+                    (MatchResult can_it_fail2 body_fn2)
+  = MatchResult can_it_fail2 body_fn
+  where
+    body_fn fail = do body2 <- body_fn2 fail
+                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
+                      body1 <- body_fn1 duplicatable_expr
+                      return (Let fail_bind body1)
+
+combineMatchResults match_result1@(MatchResult CantFail _) _
+  = match_result1
+
+adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
+
+adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
+
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
+
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body   -- NB: this function must deal with term
+  | new==old    = body  -- variables, type variables or coercion variables
+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
+
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = Case (Var var) var (exprType body)
+                        [(DEFAULT, [], body)]
+
+mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
+mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
+
+-- (mkViewMatchResult var' viewExpr mr) makes the expression
+-- let var' = viewExpr in mr
+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
+mkViewMatchResult var' viewExpr =
+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
+
+mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
+mkEvalMatchResult var ty
+  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
+
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
+  = MatchResult CanFail (\fail -> do body <- body_fn fail
+                                     return (mkIfThenElse pred_expr body fail))
+
+mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
+                        -> Type                      -- Type of the case
+                        -> [(Literal, MatchResult)]  -- Alternatives
+                        -> MatchResult               -- Literals are all unlifted
+mkCoPrimCaseMatchResult var ty match_alts
+  = MatchResult CanFail mk_case
+  where
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
+
+    sorted_alts = sortWith fst match_alts       -- Right order for a Case
+    mk_alt fail (lit, MatchResult _ body_fn)
+       = ASSERT( not (litIsLifted lit) )
+         do body <- body_fn fail
+            return (LitAlt lit, [], body)
+
+data CaseAlt a = MkCaseAlt{ alt_pat :: a,
+                            alt_bndrs :: [Var],
+                            alt_wrapper :: HsWrapper,
+                            alt_result :: MatchResult }
+
+mkCoAlgCaseMatchResult
+  :: Id                 -- Scrutinee
+  -> Type               -- Type of exp
+  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
+  -> MatchResult
+mkCoAlgCaseMatchResult var ty match_alts
+  | isNewtype  -- Newtype case; use a let
+  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
+
+  | otherwise
+  = mkDataConCase var ty match_alts
+  where
+    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
+
+        -- [Interesting: because of GADTs, we can't rely on the type of
+        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
+
+    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
+      = ASSERT( notNull match_alts ) head match_alts
+    -- Stuff for newtype
+    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1
+    var_ty        = idType var
+    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes
+                                                -- (not that splitTyConApp does, these days)
+    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
+
+mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
+
+sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
+sort_alts = sortWith (dataConTag . alt_pat)
+
+mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
+mkPatSynCase var ty alt fail = do
+    matcher <- dsLExpr $ mkLHsWrap wrapper $
+                         nlHsTyApp matcher [getRuntimeRep ty, ty]
+    let MatchResult _ mkCont = match_result
+    cont <- mkCoreLams bndrs <$> mkCont fail
+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+  where
+    MkCaseAlt{ alt_pat = psyn,
+               alt_bndrs = bndrs,
+               alt_wrapper = wrapper,
+               alt_result = match_result} = alt
+    (matcher, needs_void_lam) = patSynMatcher psyn
+
+    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
+    -- on these extra Void# arguments
+    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
+                         | otherwise      = cont
+
+mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
+mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
+mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
+  where
+    con1          = alt_pat alt1
+    tycon         = dataConTyCon con1
+    data_cons     = tyConDataCons tycon
+    match_results = map alt_result alts
+
+    sorted_alts :: [CaseAlt DataCon]
+    sorted_alts  = sort_alts alts
+
+    var_ty       = idType var
+    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
+                                          -- (not that splitTyConApp does, these days)
+
+    mk_case :: CoreExpr -> DsM CoreExpr
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
+
+    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
+    mk_alt fail MkCaseAlt{ alt_pat = con,
+                           alt_bndrs = args,
+                           alt_result = MatchResult _ body_fn }
+      = do { body <- body_fn fail
+           ; case dataConBoxer con of {
+                Nothing -> return (DataAlt con, args, body) ;
+                Just (DCB boxer) ->
+        do { us <- newUniqueSupply
+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
+
+    mk_default :: CoreExpr -> [CoreAlt]
+    mk_default fail | exhaustive_case = []
+                    | otherwise       = [(DEFAULT, [], fail)]
+
+    fail_flag :: CanItFail
+    fail_flag | exhaustive_case
+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+              | otherwise
+              = CanFail
+
+    mentioned_constructors = mkUniqSet $ map alt_pat alts
+    un_mentioned_constructors
+        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Desugarer's versions of some Core functions}
+*                                                                      *
+************************************************************************
+-}
+
+mkErrorAppDs :: Id              -- The error function
+             -> Type            -- Type to which it should be applied
+             -> SDoc            -- The error message string to pass
+             -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg = do
+    src_loc <- getSrcSpanDs
+    dflags <- getDynFlags
+    let
+        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
+        core_msg = Lit (mkLitString full_msg)
+        -- mkLitString returns a result of type String#
+    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
+
+{-
+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
+
+Note [Desugaring seq (1)]  cf #1031
+~~~~~~~~~~~~~~~~~~~~~~~~~
+   f x y = x `seq` (y `seq` (# x,y #))
+
+The [CoreSyn let/app invariant] means that, other things being equal, because
+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
+
+   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
+
+But that is bad for two reasons:
+  (a) we now evaluate y before x, and
+  (b) we can't bind v to an unboxed pair
+
+Seq is very, very special!  So we recognise it right here, and desugar to
+        case x of _ -> case y of _ -> (# x,y #)
+
+Note [Desugaring seq (2)]  cf #2273
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   let chp = case b of { True -> fst x; False -> 0 }
+   in chp `seq` ...chp...
+Here the seq is designed to plug the space leak of retaining (snd x)
+for too long.
+
+If we rely on the ordinary inlining of seq, we'll get
+   let chp = case b of { True -> fst x; False -> 0 }
+   case chp of _ { I# -> ...chp... }
+
+But since chp is cheap, and the case is an alluring contet, we'll
+inline chp into the case scrutinee.  Now there is only one use of chp,
+so we'll inline a second copy.  Alas, we've now ruined the purpose of
+the seq, by re-introducing the space leak:
+    case (case b of {True -> fst x; False -> 0}) of
+      I# _ -> ...case b of {True -> fst x; False -> 0}...
+
+We can try to avoid doing this by ensuring that the binder-swap in the
+case happens, so we get his at an early stage:
+   case chp of chp2 { I# -> ...chp2... }
+But this is fragile.  The real culprit is the source program.  Perhaps we
+should have said explicitly
+   let !chp2 = chp in ...chp2...
+
+But that's painful.  So the code here does a little hack to make seq
+more robust: a saturated application of 'seq' is turned *directly* into
+the case expression, thus:
+   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
+   e1 `seq` e2 ==> case x of _ -> e2
+
+So we desugar our example to:
+   let chp = case b of { True -> fst x; False -> 0 }
+   case chp of chp { I# -> ...chp... }
+And now all is well.
+
+The reason it's a hack is because if you define mySeq=seq, the hack
+won't work on mySeq.
+
+Note [Desugaring seq (3)] cf #2409
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The isLocalId ensures that we don't turn
+        True `seq` e
+into
+        case True of True { ... }
+which stupidly tries to bind the datacon 'True'.
+-}
+
+-- NB: Make sure the argument is not levity polymorphic
+mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
+  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
+  where
+    case_bndr = case arg1 of
+                   Var v1 | isInternalName (idName v1)
+                          -> v1        -- Note [Desugaring seq (2) and (3)]
+                   _      -> mkWildValBinder ty1
+
+mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
+
+-- NB: No argument can be levity polymorphic
+mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
+
+mkCastDs :: CoreExpr -> Coercion -> CoreExpr
+-- We define a desugarer-specific version of CoreUtils.mkCast,
+-- because in the immediate output of the desugarer, we can have
+-- apparently-mis-matched coercions:  E.g.
+--     let a = b
+--     in (x :: a) |> (co :: b ~ Int)
+-- Lint know about type-bindings for let and does not complain
+-- So here we do not make the assertion checks that we make in
+-- CoreUtils.mkCast; and we do less peephole optimisation too
+mkCastDs e co | isReflCo co = e
+              | otherwise   = Cast e co
+
+{-
+************************************************************************
+*                                                                      *
+               Tuples and selector bindings
+*                                                                      *
+************************************************************************
+
+This is used in various places to do with lazy patterns.
+For each binder $b$ in the pattern, we create a binding:
+\begin{verbatim}
+    b = case v of pat' -> b'
+\end{verbatim}
+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
+
+ToDo: making these bindings should really depend on whether there's
+much work to be done per binding.  If the pattern is complex, it
+should be de-mangled once, into a tuple (and then selected from).
+Otherwise the demangling can be in-line in the bindings (as here).
+
+Boring!  Boring!  One error message per binder.  The above ToDo is
+even more helpful.  Something very similar happens for pattern-bound
+expressions.
+
+Note [mkSelectorBinds]
+~~~~~~~~~~~~~~~~~~~~~~
+mkSelectorBinds is used to desugar a pattern binding {p = e},
+in a binding group:
+  let { ...; p = e; ... } in body
+where p binds x,y (this list of binders can be empty).
+There are two cases.
+
+------ Special case (A) -------
+  For a pattern that is just a variable,
+     let !x = e in body
+  ==>
+     let x = e in x `seq` body
+  So we return the binding, with 'x' as the variable to seq.
+
+------ Special case (B) -------
+  For a pattern that is essentially just a tuple:
+      * A product type, so cannot fail
+      * Only one level, so that
+          - generating multiple matches is fine
+          - seq'ing it evaluates the same as matching it
+  Then instead we generate
+       { v = e
+       ; x = case v of p -> x
+       ; y = case v of p -> y }
+  with 'v' as the variable to force
+
+------ General case (C) -------
+  In the general case we generate these bindings:
+       let { ...; p = e; ... } in body
+  ==>
+       let { t = case e of p -> (x,y)
+           ; x = case t of (x,y) -> x
+           ; y = case t of (x,y) -> y }
+       in t `seq` body
+
+  Note that we return 't' as the variable to force if the pattern
+  is strict (i.e. with -XStrict or an outermost-bang-pattern)
+
+  Note that (A) /includes/ the situation where
+
+   * The pattern binds exactly one variable
+        let !(Just (Just x) = e in body
+     ==>
+       let { t = case e of Just (Just v) -> Unit v
+           ; v = case t of Unit v -> v }
+       in t `seq` body
+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
+    Note that forcing 't' makes the pattern match happen,
+    but does not force 'v'.
+
+  * The pattern binds no variables
+        let !(True,False) = e in body
+    ==>
+        let t = case e of (True,False) -> ()
+        in t `seq` body
+
+
+------ Examples ----------
+  *   !(_, (_, a)) = e
+    ==>
+      t = case e of (_, (_, a)) -> Unit a
+      a = case t of Unit a -> a
+
+    Note that
+     - Forcing 't' will force the pattern to match fully;
+       e.g. will diverge if (snd e) is bottom
+     - But 'a' itself is not forced; it is wrapped in a one-tuple
+       (see Note [One-tuples] in TysWiredIn)
+
+  *   !(Just x) = e
+    ==>
+      t = case e of Just x -> Unit x
+      x = case t of Unit x -> x
+
+    Again, forcing 't' will fail if 'e' yields Nothing.
+
+Note that even though this is rather general, the special cases
+work out well:
+
+* One binder, not -XStrict:
+
+    let Just (Just v) = e in body
+  ==>
+    let t = case e of Just (Just v) -> Unit v
+        v = case t of Unit v -> v
+    in body
+  ==>
+    let v = case (case e of Just (Just v) -> Unit v) of
+              Unit v -> v
+    in body
+  ==>
+    let v = case e of Just (Just v) -> v
+    in body
+
+* Non-recursive, -XStrict
+     let p = e in body
+  ==>
+     let { t = case e of p -> (x,y)
+         ; x = case t of (x,y) -> x
+         ; y = case t of (x,y) -> x }
+     in t `seq` body
+  ==> {inline seq, float x,y bindings inwards}
+     let t = case e of p -> (x,y) in
+     case t of t' ->
+     let { x = case t' of (x,y) -> x
+         ; y = case t' of (x,y) -> x } in
+     body
+  ==> {inline t, do case of case}
+     case e of p ->
+     let t = (x,y) in
+     let { x = case t' of (x,y) -> x
+         ; y = case t' of (x,y) -> x } in
+     body
+  ==> {case-cancellation, drop dead code}
+     case e of p -> body
+
+* Special case (B) is there to avoid fruitlessly taking the tuple
+  apart and rebuilding it. For example, consider
+     { K x y = e }
+  where K is a product constructor.  Then general case (A) does:
+     { t = case e of K x y -> (x,y)
+     ; x = case t of (x,y) -> x
+     ; y = case t of (x,y) -> y }
+  In the lazy case we can't optimise out this fruitless taking apart
+  and rebuilding.  Instead (B) builds
+     { v = e
+     ; x = case v of K x y -> x
+     ; y = case v of K x y -> y }
+  which is better.
+-}
+
+mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
+                -> LPat GhcTc     -- ^ The pattern
+                -> CoreExpr       -- ^ Expression to which the pattern is bound
+                -> DsM (Id,[(Id,CoreExpr)])
+                -- ^ Id the rhs is bound to, for desugaring strict
+                -- binds (see Note [Desugar Strict binds] in DsBinds)
+                -- and all the desugared binds
+
+mkSelectorBinds ticks pat val_expr
+  | (dL->L _ (VarPat _ (dL->L _ v))) <- pat'     -- Special case (A)
+  = return (v, [(v, val_expr)])
+
+  | is_flat_prod_lpat pat'           -- Special case (B)
+  = do { let pat_ty = hsLPatType pat'
+       ; val_var <- newSysLocalDsNoLP pat_ty
+
+       ; let mk_bind tick bndr_var
+               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
+               -- Remember, 'pat' binds 'bv'
+               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
+                                       (Var bndr_var)
+                                       (Var bndr_var)  -- Neat hack
+                      -- Neat hack: since 'pat' can't fail, the
+                      -- "fail-expr" passed to matchSimply is not
+                      -- used. But it /is/ used for its type, and for
+                      -- that bndr_var is just the ticket.
+                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }
+
+       ; binds <- zipWithM mk_bind ticks' binders
+       ; return ( val_var, (val_var, val_expr) : binds) }
+
+  | otherwise                          -- General case (C)
+  = do { tuple_var  <- newSysLocalDs tuple_ty
+       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
+       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
+                                   local_tuple error_expr
+       ; let mk_tup_bind tick binder
+               = (binder, mkOptTickBox tick $
+                          mkTupleSelector1 local_binders binder
+                                           tuple_var (Var tuple_var))
+             tup_binds = zipWith mk_tup_bind ticks' binders
+       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
+  where
+    pat' = strip_bangs pat
+           -- Strip the bangs before looking for case (A) or (B)
+           -- The incoming pattern may well have a bang on it
+
+    binders = collectPatBinders pat'
+    ticks'  = ticks ++ repeat []
+
+    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
+    local_tuple   = mkBigCoreVarTup1 binders
+    tuple_ty      = exprType local_tuple
+
+strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
+-- Remove outermost bangs and parens
+strip_bangs (dL->L _ (ParPat _ p))  = strip_bangs p
+strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp                      = lp
+
+is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
+is_flat_prod_lpat = is_flat_prod_pat . unLoc
+
+is_flat_prod_pat :: Pat (GhcPass p) -> Bool
+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con  = (dL->L _ pcon)
+                            , pat_args = ps})
+  | RealDataCon con <- pcon
+  , isProductTyCon (dataConTyCon con)
+  = all is_triv_lpat (hsConPatArgs ps)
+is_flat_prod_pat _ = False
+
+is_triv_lpat :: LPat (GhcPass p) -> Bool
+is_triv_lpat = is_triv_pat . unLoc
+
+is_triv_pat :: Pat (GhcPass p) -> Bool
+is_triv_pat (VarPat {})  = True
+is_triv_pat (WildPat{})  = True
+is_triv_pat (ParPat _ p) = is_triv_lpat p
+is_triv_pat _            = False
+
+
+{- *********************************************************************
+*                                                                      *
+  Creating big tuples and their types for full Haskell expressions.
+  They work over *Ids*, and create tuples replete with their types,
+  which is whey they are not in HsUtils.
+*                                                                      *
+********************************************************************* -}
+
+mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
+mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
+mkLHsPatTup [lpat] = lpat
+mkLHsPatTup lpats  = cL (getLoc (head lpats)) $
+                     mkVanillaTuplePat lpats Boxed
+
+mkLHsVarPatTup :: [Id] -> LPat GhcTc
+mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
+
+mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
+
+-- The Big equivalents for the source tuple expressions
+mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
+mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
+
+mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
+mkBigLHsTupId = mkChunkified mkLHsTupleExpr
+
+-- The Big equivalents for the source tuple patterns
+mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
+mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
+
+mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
+mkBigLHsPatTupId = mkChunkified mkLHsPatTup
+
+{-
+************************************************************************
+*                                                                      *
+        Code for pattern-matching and other failures
+*                                                                      *
+************************************************************************
+
+Generally, we handle pattern matching failure like this: let-bind a
+fail-variable, and use that variable if the thing fails:
+\begin{verbatim}
+        let fail.33 = error "Help"
+        in
+        case x of
+                p1 -> ...
+                p2 -> fail.33
+                p3 -> fail.33
+                p4 -> ...
+\end{verbatim}
+Then
+\begin{itemize}
+\item
+If the case can't fail, then there'll be no mention of @fail.33@, and the
+simplifier will later discard it.
+
+\item
+If it can fail in only one way, then the simplifier will inline it.
+
+\item
+Only if it is used more than once will the let-binding remain.
+\end{itemize}
+
+There's a problem when the result of the case expression is of
+unboxed type.  Then the type of @fail.33@ is unboxed too, and
+there is every chance that someone will change the let into a case:
+\begin{verbatim}
+        case error "Help" of
+          fail.33 -> case ....
+\end{verbatim}
+
+which is of course utterly wrong.  Rather than drop the condition that
+only boxed types can be let-bound, we just turn the fail into a function
+for the primitive case:
+\begin{verbatim}
+        let fail.33 :: Void -> Int#
+            fail.33 = \_ -> error "Help"
+        in
+        case x of
+                p1 -> ...
+                p2 -> fail.33 void
+                p3 -> fail.33 void
+                p4 -> ...
+\end{verbatim}
+
+Now @fail.33@ is a function, so it can be let-bound.
+
+We would *like* to use join points here; in fact, these "fail variables" are
+paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
+CPS functions - i.e. they take "join points" as parameters. It's not impossible
+to imagine extending our type system to allow passing join points around (very
+carefully), but we certainly don't support it now.
+
+99.99% of the time, the fail variables wind up as join points in short order
+anyway, and the Void# doesn't do much harm.
+-}
+
+mkFailurePair :: CoreExpr       -- Result type of the whole case expression
+              -> DsM (CoreBind, -- Binds the newly-created fail variable
+                                -- to \ _ -> expression
+                      CoreExpr) -- Fail variable applied to realWorld#
+-- See Note [Failure thunks and CPR]
+mkFailurePair expr
+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)
+       ; fail_fun_arg <- newSysLocalDs voidPrimTy
+       ; let real_arg = setOneShotLambda fail_fun_arg
+       ; return (NonRec fail_fun_var (Lam real_arg expr),
+                 App (Var fail_fun_var) (Var voidPrimId)) }
+  where
+    ty = exprType expr
+
+{-
+Note [Failure thunks and CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This note predates join points as formal entities (hence the quotation marks).
+We can't use actual join points here (see above); if we did, this would also
+solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
+join points] in WorkWrap.)
+
+When we make a failure point we ensure that it
+does not look like a thunk. Example:
+
+   let fail = \rw -> error "urk"
+   in case x of
+        [] -> fail realWorld#
+        (y:ys) -> case ys of
+                    [] -> fail realWorld#
+                    (z:zs) -> (y,z)
+
+Reason: we know that a failure point is always a "join point" and is
+entered at most once.  Adding a dummy 'realWorld' token argument makes
+it clear that sharing is not an issue.  And that in turn makes it more
+CPR-friendly.  This matters a lot: if you don't get it right, you lose
+the tail call property.  For example, see #3403.
+
+
+************************************************************************
+*                                                                      *
+              Ticks
+*                                                                      *
+********************************************************************* -}
+
+mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
+mkOptTickBox = flip (foldr Tick)
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+       uq <- newUnique
+       this_mod <- getModule
+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
+       let
+           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
+           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
+       --
+       return $ Case e bndr1 boolTy
+                       [ (DataAlt falseDataCon, [], falseBox)
+                       , (DataAlt trueDataCon,  [], trueBox)
+                       ]
+
+
+
+-- *******************************************************************
+
+{- Note [decideBangHood]
+~~~~~~~~~~~~~~~~~~~~~~~~
+With -XStrict we may make /outermost/ patterns more strict.
+E.g.
+       let (Just x) = e in ...
+          ==>
+       let !(Just x) = e in ...
+and
+       f x = e
+          ==>
+       f !x = e
+
+This adjustment is done by decideBangHood,
+
+  * Just before constructing an EqnInfo, in Match
+      (matchWrapper and matchSinglePat)
+
+  * When desugaring a pattern-binding in DsBinds.dsHsBind
+
+Note that it is /not/ done recursively.  See the -XStrict
+spec in the user manual.
+
+Specifically:
+   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
+   !pat    => !pat   -- always
+   pat     => !pat   -- when -XStrict
+   pat     => pat    -- otherwise
+-}
+
+
+-- | Use -XStrict to add a ! or remove a ~
+-- See Note [decideBangHood]
+decideBangHood :: DynFlags
+               -> LPat GhcTc  -- ^ Original pattern
+               -> LPat GhcTc  -- Pattern with bang if necessary
+decideBangHood dflags lpat
+  | not (xopt LangExt.Strict dflags)
+  = lpat
+  | otherwise   --  -XStrict
+  = go lpat
+  where
+    go lp@(dL->L l p)
+      = case p of
+           ParPat x p    -> cL l (ParPat x (go p))
+           LazyPat _ lp' -> lp'
+           BangPat _ _   -> lp
+           _             -> cL l (BangPat noExt lp)
+
+-- | Unconditionally make a 'Pat' strict.
+addBang :: LPat GhcTc -- ^ Original pattern
+        -> LPat GhcTc -- ^ Banged pattern
+addBang = go
+  where
+    go lp@(dL->L l p)
+      = case p of
+           ParPat x p    -> cL l (ParPat x (go p))
+           LazyPat _ lp' -> cL l (BangPat noExt lp')
+                                  -- Should we bring the extension value over?
+           BangPat _ _   -> lp
+           _             -> cL l (BangPat noExt lp)
+
+isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
+
+-- Returns Just {..} if we're sure that the expression is True
+-- I.e.   * 'True' datacon
+--        * 'otherwise' Id
+--        * Trivial wappings of these
+-- The arguments to Just are any HsTicks that we have found,
+-- because we still want to tick then, even it they are always evaluated.
+isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))
+  |  v `hasKey` otherwiseIdKey
+     || v `hasKey` getUnique trueDataConId
+                                              = Just return
+        -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (dL->L _ (HsTick _ tickish e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do wrapped <- ticks x
+                     return (Tick tickish wrapped))
+   -- This encodes that the result is constant True for Hpc tick purposes;
+   -- which is specifically what isTrueLHsExpr is trying to find out.
+isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do e <- ticks x
+                     this_mod <- getModule
+                     return (Tick (HpcTick this_mod ixT) e))
+
+isTrueLHsExpr (dL->L _ (HsPar _ e))   = isTrueLHsExpr e
+isTrueLHsExpr _                       = Nothing
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/ExtractDocs.hs
@@ -0,0 +1,350 @@
+-- | Extract docs from the renamer output so they can be be serialized.
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module ExtractDocs (extractDocs) where
+
+import GhcPrelude
+import Bag
+import HsBinds
+import HsDoc
+import HsDecls
+import HsExtension
+import HsTypes
+import HsUtils
+import Name
+import NameSet
+import SrcLoc
+import TcRnTypes
+
+import Control.Applicative
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Semigroup
+
+-- | Extract docs from renamer output.
+extractDocs :: TcGblEnv
+            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
+            -- ^
+            -- 1. Module header
+            -- 2. Docs on top level declarations
+            -- 3. Docs on arguments
+extractDocs TcGblEnv { tcg_semantic_mod = mod
+                     , tcg_rn_decls = mb_rn_decls
+                     , tcg_insts = insts
+                     , tcg_fam_insts = fam_insts
+                     , tcg_doc_hdr = mb_doc_hdr
+                     } =
+    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
+  where
+    (doc_map, arg_map) = maybe (M.empty, M.empty)
+                               (mkMaps local_insts)
+                               mb_decls_with_docs
+    mb_decls_with_docs = topDecls <$> mb_rn_decls
+    local_insts = filter (nameIsLocalOrFrom mod)
+                         $ map getName insts ++ map getName fam_insts
+
+-- | Create decl and arg doc-maps by looping through the declarations.
+-- For each declaration, find its names, its subordinates, and its doc strings.
+mkMaps :: [Name]
+       -> [(LHsDecl GhcRn, [HsDocString])]
+       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
+mkMaps instances decls =
+    ( f' (map (nubByName fst) decls')
+    , f  (filterMapping (not . M.null) args)
+    )
+  where
+    (decls', args) = unzip (map mappings decls)
+
+    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
+    f' = M.fromListWith appendDocs . concat
+
+    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
+    filterMapping p = map (filter (p . snd))
+
+    mappings :: (LHsDecl GhcRn, [HsDocString])
+             -> ( [(Name, HsDocString)]
+                , [(Name, Map Int (HsDocString))]
+                )
+    mappings (L l decl, docStrs) =
+           (dm, am)
+      where
+        doc = concatDocs docStrs
+        args = declTypeDocs decl
+
+        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
+        subs = subordinates instanceMap decl
+
+        (subDocs, subArgs) =
+          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
+
+        ns = names l decl
+        subNs = [ n | (n, _, _) <- subs ]
+        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
+        am = [(n, args) | n <- ns] ++ zip subNs subArgs
+
+    instanceMap :: Map SrcSpan Name
+    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
+
+    names :: SrcSpan -> HsDecl GhcRn -> [Name]
+    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
+                                                                 -- Note [1].
+      where loc = case d of
+              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
+                                  -- for TFs
+              _ -> getInstLoc d
+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+    names _ decl = getMainDeclBinder decl
+
+{-
+Note [1]:
+---------
+We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+inside them. That should work for normal user-written instances (from
+looking at GHC sources). We can assume that commented instances are
+user-written. This lets us relate Names (from ClsInsts) to comments
+(associated with InstDecls and DerivDecls).
+-}
+
+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+sigNameNoLoc :: Sig pass -> [IdP pass]
+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns
+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns
+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]
+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+sigNameNoLoc _                             = []
+
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc = \case
+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+  DataFamInstD _ (DataFamInstDecl
+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l
+  TyFamInstD _ (TyFamInstDecl
+    -- Since CoAxioms' Names refer to the whole line for type family instances
+    -- in particular, we need to dig a bit deeper to pull out the entire
+    -- equation. This does not happen for data family instances, for some
+    -- reason.
+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l
+  ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  XInstDecl _ -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
+subordinates :: Map SrcSpan Name
+             -> HsDecl GhcRn
+             -> [(Name, [(HsDocString)], Map Int (HsDocString))]
+subordinates instMap decl = case decl of
+  InstD _ (ClsInstD _ d) -> do
+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+      FamEqn { feqn_tycon = (dL->L l _)
+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+
+  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
+    -> dataSubs (feqn_rhs d)
+  TyClD _ d | isClassDecl d -> classSubs d
+            | isDataDecl  d -> dataSubs (tcdDataDefn d)
+  _ -> []
+  where
+    classSubs dd = [ (name, doc, declTypeDocs d)
+                   | (dL->L _ d, doc) <- classDecls dd
+                   , name <- getMainDeclBinder d, not (isValD d)
+                   ]
+    dataSubs :: HsDataDefn GhcRn
+             -> [(Name, [HsDocString], Map Int (HsDocString))]
+    dataSubs dd = constrs ++ fields ++ derivs
+      where
+        cons = map unLoc $ (dd_cons dd)
+        constrs = [ ( unLoc cname
+                    , maybeToList $ fmap unLoc $ con_doc c
+                    , conArgDocs c)
+                  | c <- cons, cname <- getConNames c ]
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
+                  | RecCon flds <- map getConArgs cons
+                  , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+                  , (dL->L _ n) <- ns ]
+        derivs  = [ (instName, [unLoc doc], M.empty)
+                  | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) }
+                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $
+                           unLoc $ dd_derivs dd
+                  , Just instName <- [M.lookup l instMap] ]
+
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
+conArgDocs con = case getConArgs con of
+                   PrefixCon args -> go 0 (map unLoc args ++ ret)
+                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+                   RecCon _ -> go 1 ret
+  where
+    go n (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+    go n (_ : tys) = go (n+1) tys
+    go _ [] = M.empty
+
+    ret = case con of
+            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+            _ -> []
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _ _) = True
+isValD _ = False
+
+-- | All the sub declarations of a class (that we handle), ordered by
+-- source location, with documentation attached if it exists.
+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+  where
+    decls = docs ++ defs ++ sigs ++ ats
+    docs  = mkDecls tcdDocs (DocD noExt) class_
+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
+    sigs  = mkDecls tcdSigs (SigD noExt) class_
+    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
+declTypeDocs = \case
+  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))
+  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))
+  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))
+  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))
+  TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
+  _                                 -> M.empty
+
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+  where
+    go _ [] = []
+    go s (x:xs)
+      | y `elemNameSet` s = go s xs
+      | otherwise         = let s' = extendNameSet s y
+                            in x : go s' xs
+      where
+        y = f x
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsType GhcRn -> Map Int (HsDocString)
+typeDocs = go 0
+  where
+    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
+    go n (HsFunTy _ (dL->L _
+                      (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) =
+       M.insert n x $ go (n+1) ty
+    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+    go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc
+    go _ _ = M.empty
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+ungroup group_ =
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt)  group_ ++
+  mkDecls hs_derivds             (DerivD noExt) group_ ++
+  mkDecls hs_defds               (DefD noExt)   group_ ++
+  mkDecls hs_fords               (ForD noExt)   group_ ++
+  mkDecls hs_docs                (DocD noExt)   group_ ++
+  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ ++
+  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ ++
+  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_
+  where
+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs
+    typesigs _ = error "expected ValBindsOut"
+
+    valbinds (XValBindsLR (NValBinds binds _)) =
+      concatMap bagToList . snd . unzip $ binds
+    valbinds _ = error "expected ValBindsOut"
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortOn getLoc
+
+-- | Collect docs and attach them to the right declarations.
+--
+-- A declaration may have multiple doc strings attached to it.
+collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
+-- ^ This is an example.
+collectDocs = go Nothing []
+  where
+    go Nothing _ [] = []
+    go (Just prev) docs [] = finished prev docs []
+    go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds)
+      | Nothing <- prev = go Nothing (str:docs) ds
+      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
+    go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) =
+      go prev (str:docs) ds
+    go Nothing docs (d:ds) = go (Just d) docs ds
+    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
+
+    finished decl docs rest = (decl, reverse docs) : rest
+
+-- | Filter out declarations that we don't handle in Haddock
+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterDecls = filter (isHandled . unLoc . fst)
+  where
+    isHandled (ForD _ (ForeignImport {})) = True
+    isHandled (TyClD {})  = True
+    isHandled (InstD {})  = True
+    isHandled (DerivD {}) = True
+    isHandled (SigD _ d)  = isUserSig d
+    isHandled (ValD {})   = True
+    -- we keep doc declarations to be able to get at named docs
+    isHandled (DocD {})   = True
+    isHandled _ = False
+
+
+-- | Go through all class declarations and filter their sub-declarations
+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterClasses decls = [ if isClassD d then (cL loc (filterClass d), doc) else x
+                      | x@(dL->L loc d, doc) <- decls ]
+  where
+    filterClass (TyClD x c) =
+      TyClD x $ c { tcdSigs =
+        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
+    filterClass _ = error "expected TyClD"
+
+-- | Was this signature given by the user?
+isUserSig :: Sig name -> Bool
+isUserSig TypeSig {}    = True
+isUserSig ClassOpSig {} = True
+isUserSig PatSynSig {}  = True
+isUserSig _             = False
+
+isClassD :: HsDecl a -> Bool
+isClassD (TyClD _ d) = isClassDecl d
+isClassD _ = False
+
+-- | Take a field of declarations from a data structure and create HsDecls
+-- using the given constructor
+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+mkDecls field con struct = [ cL loc (con decl)
+                           | (dL->L loc decl) <- field struct ]
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Match.hs
@@ -0,0 +1,1129 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The @match@ function
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Match ( match, matchEquations, matchWrapper, matchSimply
+             , matchSinglePat, matchSinglePatVar ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
+
+import BasicTypes ( Origin(..) )
+import DynFlags
+import HsSyn
+import TcHsSyn
+import TcEvidence
+import TcRnMonad
+import Check
+import CoreSyn
+import Literal
+import CoreUtils
+import MkCore
+import DsMonad
+import DsBinds
+import DsGRHSs
+import DsUtils
+import Id
+import ConLike
+import DataCon
+import PatSyn
+import MatchCon
+import MatchLit
+import Type
+import Coercion ( eqCoercion )
+import TyCon( isNewTyCon )
+import TysWiredIn
+import SrcLoc
+import Maybes
+import Util
+import Name
+import Outputable
+import BasicTypes ( isGenerated, il_value, fl_value )
+import FastString
+import Unique
+import UniqDFM
+
+import Control.Monad( when, unless )
+import Data.List ( groupBy )
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+                The main matching function
+*                                                                      *
+************************************************************************
+
+The function @match@ is basically the same as in the Wadler chapter
+from "The Implementation of Functional Programming Languages",
+except it is monadised, to carry around the name supply, info about
+annotations, etc.
+
+Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
+\begin{enumerate}
+\item
+A list of $n$ variable names, those variables presumably bound to the
+$n$ expressions being matched against the $n$ patterns.  Using the
+list of $n$ expressions as the first argument showed no benefit and
+some inelegance.
+
+\item
+The second argument, a list giving the ``equation info'' for each of
+the $m$ equations:
+\begin{itemize}
+\item
+the $n$ patterns for that equation, and
+\item
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
+the front'' of the matching code, as in:
+\begin{verbatim}
+let <binds>
+in  <matching-code>
+\end{verbatim}
+\item
+and finally: (ToDo: fill in)
+
+The right way to think about the ``after-match function'' is that it
+is an embryonic @CoreExpr@ with a ``hole'' at the end for the
+final ``else expression''.
+\end{itemize}
+
+There is a data type, @EquationInfo@, defined in module @DsMonad@.
+
+An experiment with re-ordering this information about equations (in
+particular, having the patterns available in column-major order)
+showed no benefit.
+
+\item
+A default expression---what to evaluate if the overall pattern-match
+fails.  This expression will (almost?) always be
+a measly expression @Var@, unless we know it will only be used once
+(as we do in @glue_success_exprs@).
+
+Leaving out this third argument to @match@ (and slamming in lots of
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
+impossible to share the default expressions.  (Also, it stands no
+chance of working in our post-upheaval world of @Locals@.)
+\end{enumerate}
+
+Note: @match@ is often called via @matchWrapper@ (end of this module),
+a function that does much of the house-keeping that goes with a call
+to @match@.
+
+It is also worth mentioning the {\em typical} way a block of equations
+is desugared with @match@.  At each stage, it is the first column of
+patterns that is examined.  The steps carried out are roughly:
+\begin{enumerate}
+\item
+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
+bindings to the second component of the equation-info):
+\item
+Now {\em unmix} the equations into {\em blocks} [w\/ local function
+@match_groups@], in which the equations in a block all have the same
+ match group.
+(see ``the mixture rule'' in SLPJ).
+\item
+Call the right match variant on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern.
+\end{enumerate}
+
+We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
+And gluing the ``success expressions'' together isn't quite so pretty.
+
+This  @match@ uses @tidyEqnInfo@
+to get `as'- and `twiddle'-patterns out of the way (tidying), before
+applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+un}mixes the equations], producing a list of equation-info
+blocks, each block having as its first column patterns compatible with each other.
+
+Note [Match Ids]
+~~~~~~~~~~~~~~~~
+Most of the matching functions take an Id or [Id] as argument.  This Id
+is the scrutinee(s) of the match. The desugared expression may
+sometimes use that Id in a local binding or as a case binder.  So it
+should not have an External name; Lint rejects non-top-level binders
+with External names (#13043).
+
+See also Note [Localise pattern binders] in DsUtils
+-}
+
+type MatchId = Id   -- See Note [Match Ids]
+
+match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with
+                          -- ^ See Note [Match Ids]
+      -> Type             -- ^ Type of the case expression
+      -> [EquationInfo]   -- ^ Info about patterns, etc. (type synonym below)
+      -> DsM MatchResult  -- ^ Desugared result!
+
+match [] ty eqns
+  = ASSERT2( not (null eqns), ppr ty )
+    return (foldr1 combineMatchResults match_results)
+  where
+    match_results = [ ASSERT( null (eqn_pats eqn) )
+                      eqn_rhs eqn
+                    | eqn <- eqns ]
+
+match vars@(v:_) ty eqns    -- Eqns *can* be empty
+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+    do  { dflags <- getDynFlags
+                -- Tidy the first pattern, generating
+                -- auxiliary bindings if necessary
+        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+
+                -- Group the equations and match each group in turn
+        ; let grouped = groupEquations dflags tidy_eqns
+
+         -- print the view patterns that are commoned up to help debug
+        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+
+        ; match_results <- match_groups grouped
+        ; return (adjustMatchResult (foldr (.) id aux_binds) $
+                  foldr1 combineMatchResults match_results) }
+  where
+    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
+    dropGroup = map snd
+
+    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
+    -- Result list of [MatchResult] is always non-empty
+    match_groups [] = matchEmpty v ty
+    match_groups gs = mapM match_group gs
+
+    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+    match_group [] = panic "match_group"
+    match_group eqns@((group,_) : _)
+        = case group of
+            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
+            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
+            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
+            PgAny     -> matchVariables  vars ty (dropGroup eqns)
+            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
+            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
+            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
+            PgBang    -> matchBangs      vars ty (dropGroup eqns)
+            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
+            PgView {} -> matchView       vars ty (dropGroup eqns)
+            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
+
+    -- FIXME: we should also warn about view patterns that should be
+    -- commoned up but are not
+
+    -- print some stuff to see what's getting grouped
+    -- use -dppr-debug to see the resolution of overloaded literals
+    debug eqns =
+        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
+                                           case p of PgView e _ -> e:acc
+                                                     _ -> acc) [] group) eqns
+            maybeWarn [] = return ()
+            maybeWarn l = warnDs NoReason (vcat l)
+        in
+          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
+                       (filter (not . null) gs))
+
+matchEmpty :: MatchId -> Type -> DsM [MatchResult]
+-- See Note [Empty case expressions]
+matchEmpty var res_ty
+  = return [MatchResult CanFail mk_seq]
+  where
+    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
+                                      [(DEFAULT, [], fail)]
+
+matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
+
+matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchBangs (var:vars) ty eqns
+  = do  { match_result <- match (var:vars) ty $
+                          map (decomposeFirstPat getBangPat) eqns
+        ; return (mkEvalMatchResult var ty match_result) }
+matchBangs [] _ _ = panic "matchBangs"
+
+matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the coercion to the match variable and then match that
+matchCoercion (var:vars) ty (eqns@(eqn1:_))
+  = do  { let CoPat _ co pat _ = firstPat eqn1
+        ; let pat_ty' = hsPatType pat
+        ; var' <- newUniqueId var pat_ty'
+        ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getCoPat) eqns
+        ; core_wrap <- dsHsWrapper co
+        ; let bind = NonRec var' (core_wrap (Var var))
+        ; return (mkCoLetMatchResult bind match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
+
+matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the view function to the match variable and then match that
+matchView (var:vars) ty (eqns@(eqn1:_))
+  = do  { -- we could pass in the expr from the PgView,
+         -- but this needs to extract the pat anyway
+         -- to figure out the type of the fresh variable
+         let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1
+         -- do the rest of the compilation
+        ; let pat_ty' = hsPatType pat
+        ; var' <- newUniqueId var pat_ty'
+        ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getViewPat) eqns
+         -- compile the view expressions
+        ; viewExpr' <- dsLExpr viewExpr
+        ; return (mkViewMatchResult var'
+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+                    match_result) }
+matchView _ _ _ = panic "matchView"
+
+matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
+-- Since overloaded list patterns are treated as view patterns,
+-- the code is roughly the same as for matchView
+  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
+       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
+       ; match_result <- match (var':vars) ty $
+                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
+       ; e' <- dsSyntaxExpr e [Var var]
+       ; return (mkViewMatchResult var' e' match_result) }
+matchOverloadedList _ _ _ = panic "matchOverloadedList"
+
+-- decompose the first pattern and leave the rest alone
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
+        = eqn { eqn_pats = extractpat pat : pats}
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
+getCoPat (CoPat _ _ pat _)   = pat
+getCoPat _                   = panic "getCoPat"
+getBangPat (BangPat _ pat  ) = unLoc pat
+getBangPat _                 = panic "getBangPat"
+getViewPat (ViewPat _ _ pat) = unLoc pat
+getViewPat _                 = panic "getViewPat"
+getOLPat (ListPat (ListPatTc ty (Just _)) pats)
+        = ListPat (ListPatTc ty Nothing)  pats
+getOLPat _                   = panic "getOLPat"
+
+{-
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The list of EquationInfo can be empty, arising from
+    case x of {}   or    \case {}
+In that situation we desugar to
+    case x of { _ -> error "pattern match failure" }
+The *desugarer* isn't certain whether there really should be no
+alternatives, so it adds a default case, as it always does.  A later
+pass may remove it if it's inaccessible.  (See also Note [Empty case
+alternatives] in CoreSyn.)
+
+We do *not* desugar simply to
+   error "empty case"
+or some such, because 'x' might be bound to (error "hello"), in which
+case we want to see that "hello" exception, not (error "empty case").
+See also Note [Case elimination: lifted case] in Simplify.
+
+
+************************************************************************
+*                                                                      *
+                Tidying patterns
+*                                                                      *
+************************************************************************
+
+Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
+which will be scrutinised.
+
+This makes desugaring the pattern match simpler by transforming some of
+the patterns to simpler forms. (Tuples to Constructor Patterns)
+
+Among other things in the resulting Pattern:
+* Variables and irrefutable(lazy) patterns are replaced by Wildcards
+* As patterns are replaced by the patterns they wrap.
+
+The bindings created by the above patterns are put into the returned wrapper
+instead.
+
+This means a definition of the form:
+  f x = rhs
+when called with v get's desugared to the equivalent of:
+  let x = v
+  in
+  f _ = rhs
+
+The same principle holds for as patterns (@) and
+irrefutable/lazy patterns (~).
+In the case of irrefutable patterns the irrefutable pattern is pushed into
+the binding.
+
+Pattern Constructors which only represent syntactic sugar are converted into
+their desugared representation.
+This usually means converting them to Constructor patterns but for some
+depends on enabled extensions. (Eg OverloadedLists)
+
+GHC also tries to convert overloaded Literals into regular ones.
+
+The result of this tidying is that the column of patterns will include
+only these which can be assigned a PatternGroup (see patGroup).
+
+-}
+
+tidyEqnInfo :: Id -> EquationInfo
+            -> DsM (DsWrapper, EquationInfo)
+        -- DsM'd because of internal call to dsLHsBinds
+        --      and mkSelectorBinds.
+        -- "tidy1" does the interesting stuff, looking at
+        -- one pattern and fiddling the list of bindings.
+        --
+        -- POST CONDITION: head pattern in the EqnInfo is
+        --      one of these for which patGroup is defined.
+
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
+  = panic "tidyEqnInfo"
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
+  = do { (wrap, pat') <- tidy1 v orig pat
+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
+
+tidy1 :: Id                  -- The Id being scrutinised
+      -> Origin              -- Was this a pattern the user wrote?
+      -> Pat GhcTc           -- The pattern against which it is to be matched
+      -> DsM (DsWrapper,     -- Extra bindings to do before the match
+              Pat GhcTc)     -- Equivalent pattern
+
+-------------------------------------------------------
+--      (pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) and returns any created bindings in the wrapper.
+
+tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)
+tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
+tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p
+
+        -- case v of { x -> mr[] }
+        -- = case v of { _ -> let x=v in mr[] }
+tidy1 v _ (VarPat _ (dL->L _ var))
+  = return (wrapBind var v, WildPat (idType var))
+
+        -- case v of { x@p -> mr[] }
+        -- = case v of { p -> let x=v in mr[] }
+tidy1 v o (AsPat _ (dL->L _ var) pat)
+  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)
+        ; return (wrapBind var v . wrap, pat') }
+
+{- now, here we handle lazy patterns:
+    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
+                        v2 = case v of p -> v2 : ... : bs )
+
+    where the v_i's are the binders in the pattern.
+
+    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
+
+    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
+-}
+
+tidy1 v _ (LazyPat _ pat)
+    -- This is a convenient place to check for unlifted types under a lazy pattern.
+    -- Doing this check during type-checking is unsatisfactory because we may
+    -- not fully know the zonked types yet. We sure do here.
+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
+        ; unless (null unlifted_bndrs) $
+          putSrcSpanDs (getLoc pat) $
+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+                       text "Unlifted variables:")
+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
+                                 unlifted_bndrs)))
+
+        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
+        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
+
+tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
+  = return (idDsWrapper, unLoc list_ConPat)
+  where
+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+                        (mkNilPat ty)
+                        pats
+
+tidy1 _ _ (TuplePat tys pats boxity)
+  = return (idDsWrapper, unLoc tuple_ConPat)
+  where
+    arity = length pats
+    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
+
+tidy1 _ _ (SumPat tys pat alt arity)
+  = return (idDsWrapper, unLoc sum_ConPat)
+  where
+    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
+
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ o (LitPat _ lit)
+  = do { unless (isGenerated o) $
+           warnAboutOverflowedLit lit
+       ; return (idDsWrapper, tidyLitPat lit) }
+
+-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)
+  = do { unless (isGenerated o) $
+           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
+                    | otherwise = lit
+           in warnAboutOverflowedOverLit lit'
+       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
+
+-- NPlusKPat: we may want to warn about the literals
+tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)
+  = do { unless (isGenerated o) $ do
+           warnAboutOverflowedOverLit lit1
+           warnAboutOverflowedOverLit lit2
+       ; return (idDsWrapper, n) }
+
+-- Everything else goes through unchanged...
+tidy1 _ _ non_interesting_pat
+  = return (idDsWrapper, non_interesting_pat)
+
+--------------------
+tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc
+              -> DsM (DsWrapper, Pat GhcTc)
+
+-- Discard par/sig under a bang
+tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p
+
+-- Push the bang-pattern inwards, in the hope that
+-- it may disappear next time
+tidy_bang_pat v o l (AsPat x v' p)
+  = tidy1 v o (AsPat x v' (cL l (BangPat noExt p)))
+tidy_bang_pat v o l (CoPat x w p t)
+  = tidy1 v o (CoPat x w (BangPat noExt (cL l p)) t)
+
+-- Discard bang around strict pattern
+tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p
+tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p
+tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p
+tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
+
+-- Data/newtype constructors
+tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
+                                 , pat_args = args
+                                 , pat_arg_tys = arg_tys })
+  -- Newtypes: push bang inwards (#9844)
+  =
+    if isNewTyCon (dataConTyCon dc)
+      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })
+      else tidy1 v o p  -- Data types: discard the bang
+    where
+      (ty:_) = dataConInstArgTys dc arg_tys
+
+-------------------
+-- Default case, leave the bang there:
+--    VarPat,
+--    LazyPat,
+--    WildPat,
+--    ViewPat,
+--    pattern synonyms (ConPatOut with PatSynCon)
+--    NPat,
+--    NPlusKPat
+--
+-- For LazyPat, remember that it's semantically like a VarPat
+--  i.e.  !(~p) is not like ~p, or p!  (#8952)
+--
+-- NB: SigPatIn, ConPatIn should not happen
+
+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExt (cL l p))
+
+-------------------
+push_bang_into_newtype_arg :: SrcSpan
+                           -> Type -- The type of the argument we are pushing
+                                   -- onto
+                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
+-- See Note [Bang patterns and newtypes]
+-- We are transforming   !(N p)   into   (N !p)
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
+  = ASSERT( null args)
+    PrefixCon [cL l (BangPat noExt arg)]
+push_bang_into_newtype_arg l _ty (RecCon rf)
+  | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf
+  , HsRecField { hsRecFieldArg = arg } <- fld
+  = ASSERT( null flds)
+    RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg
+                                           = cL l (BangPat noExt arg) })] })
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+  | HsRecFields { rec_flds = [] } <- rf
+  = PrefixCon [cL l (BangPat noExt (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
+  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
+
+{-
+Note [Bang patterns and newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the pattern  !(Just pat)  we can discard the bang, because
+the pattern is strict anyway. But for !(N pat), where
+  newtype NT = N Int
+we definitely can't discard the bang.  #9844.
+
+So what we do is to push the bang inwards, in the hope that it will
+get discarded there.  So we transform
+   !(N pat)   into    (N !pat)
+
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
+
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
+
+Now we get to the only interesting part; note: there are choices for
+translation [from Simon's notes]; translation~1:
+\begin{verbatim}
+deTwiddle [s,t] e
+\end{verbatim}
+returns
+\begin{verbatim}
+[ w = e,
+  s = case w of [s,t] -> s
+  t = case w of [s,t] -> t
+]
+\end{verbatim}
+
+Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
+evaluation of \tr{e}.  An alternative translation (No.~2):
+\begin{verbatim}
+[ w = case e of [s,t] -> (s,t)
+  s = case w of (s,t) -> s
+  t = case w of (s,t) -> t
+]
+\end{verbatim}
+
+************************************************************************
+*                                                                      *
+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
+*                                                                      *
+************************************************************************
+
+We might be able to optimise unmixing when confronted by
+only-one-constructor-possible, of which tuples are the most notable
+examples.  Consider:
+\begin{verbatim}
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+f j ...       = ...
+\end{verbatim}
+This definition would normally be unmixed into four equation blocks,
+one per equation.  But it could be unmixed into just one equation
+block, because if the one equation matches (on the first column),
+the others certainly will.
+
+You have to be careful, though; the example
+\begin{verbatim}
+f j ...       = ...
+-------------------
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+\end{verbatim}
+{\em must} be broken into two blocks at the line shown; otherwise, you
+are forcing unnecessary evaluation.  In any case, the top-left pattern
+always gives the cue.  You could then unmix blocks into groups of...
+\begin{description}
+\item[all variables:]
+As it is now.
+\item[constructors or variables (mixed):]
+Need to make sure the right names get bound for the variable patterns.
+\item[literals or variables (mixed):]
+Presumably just a variant on the constructor case (as it is now).
+\end{description}
+
+************************************************************************
+*                                                                      *
+*  matchWrapper: a convenient way to call @match@                      *
+*                                                                      *
+************************************************************************
+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
+
+Calls to @match@ often involve similar (non-trivial) work; that work
+is collected here, in @matchWrapper@.  This function takes as
+arguments:
+\begin{itemize}
+\item
+Typechecked @Matches@ (of a function definition, or a case or lambda
+expression)---the main input;
+\item
+An error message to be inserted into any (runtime) pattern-matching
+failure messages.
+\end{itemize}
+
+As results, @matchWrapper@ produces:
+\begin{itemize}
+\item
+A list of variables (@Locals@) that the caller must ``promise'' to
+bind to appropriate values; and
+\item
+a @CoreExpr@, the desugared output (main result).
+\end{itemize}
+
+The main actions of @matchWrapper@ include:
+\begin{enumerate}
+\item
+Flatten the @[TypecheckedMatch]@ into a suitable list of
+@EquationInfo@s.
+\item
+Create as many new variables as there are patterns in a pattern-list
+(in any one of the @EquationInfo@s).
+\item
+Create a suitable ``if it fails'' expression---a call to @error@ using
+the error-string input; the {\em type} of this fail value can be found
+by examining one of the RHS expressions in one of the @EquationInfo@s.
+\item
+Call @match@ with all of this information!
+\end{enumerate}
+-}
+
+matchWrapper
+  :: HsMatchContext Name               -- ^ For shadowing warning messages
+  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee, if we check a case expr
+  -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared
+  -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match')
+
+{-
+ There is one small problem with the Lambda Patterns, when somebody
+ writes something similar to:
+\begin{verbatim}
+    (\ (x:xs) -> ...)
+\end{verbatim}
+ he/she don't want a warning about incomplete patterns, that is done with
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+      it creates another equation if the match can fail
+      (see @DsExpr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+   List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
+one pattern, and match simply only accepts one pattern.
+
+JJQC 30-Nov-1997
+-}
+
+matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
+                             , mg_ext = MatchGroupTc arg_tys rhs_ty
+                             , mg_origin = origin })
+  = do  { dflags <- getDynFlags
+        ; locn   <- getSrcSpanDs
+
+        ; new_vars    <- case matches of
+                           []    -> mapM newSysLocalDsNoLP arg_tys
+                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
+
+        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
+
+        -- pattern match check warnings
+        ; unless (isGenerated origin) $
+          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
+          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
+              -- See Note [Type and Term Equality Propagation]
+          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
+
+        ; result_expr <- handleWarnings $
+                         matchEquations ctxt new_vars eqns_info rhs_ty
+        ; return (new_vars, result_expr) }
+  where
+    mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
+      = do { dflags <- getDynFlags
+           ; let upats = map (unLoc . decideBangHood dflags) pats
+                 dicts = collectEvVarsPats upats
+           ; tm_cs <- genCaseTmCs2 mb_scr upats vars
+           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
+                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
+                             dsGRHSs ctxt grhss rhs_ty
+           ; return (EqnInfo { eqn_pats = upats
+                             , eqn_orig = FromSource
+                             , eqn_rhs = match_result }) }
+    mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"
+    mk_eqn_info _ _  = panic "mk_eqn_info: Impossible Match" -- due to #15884
+
+    handleWarnings = if isGenerated origin
+                     then discardWarningsDs
+                     else id
+matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
+
+matchEquations  :: HsMatchContext Name
+                -> [MatchId] -> [EquationInfo] -> Type
+                -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+  = do  { let error_doc = matchContextErrString ctxt
+
+        ; match_result <- match vars rhs_ty eqns_info
+
+        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
+        ; extractMatchResult match_result fail_expr }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
+*                                                                      *
+************************************************************************
+
+@mkSimpleMatch@ is a wrapper for @match@ which deals with the
+situation where we want to match a single expression against a single
+pattern. It returns an expression.
+-}
+
+matchSimply :: CoreExpr                 -- ^ Scrutinee
+            -> HsMatchContext Name      -- ^ Match kind
+            -> LPat GhcTc               -- ^ Pattern it should match
+            -> CoreExpr                 -- ^ Return this if it matches
+            -> CoreExpr                 -- ^ Return this if it doesn't
+            -> DsM CoreExpr
+-- Do not warn about incomplete patterns; see matchSinglePat comments
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+    let
+      match_result = cantFailMatchResult result_expr
+      rhs_ty       = exprType fail_expr
+        -- Use exprType of fail_expr, because won't refine in the case of failure!
+    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
+    extractMatchResult match_result' fail_expr
+
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
+               -> Type -> MatchResult -> DsM MatchResult
+-- matchSinglePat ensures that the scrutinee is a variable
+-- and then calls matchSinglePatVar
+--
+-- matchSinglePat does not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where
+-- incomplete patterns are just fine
+
+matchSinglePat (Var var) ctx pat ty match_result
+  | not (isExternalName (idName var))
+  = matchSinglePatVar var ctx pat ty match_result
+
+matchSinglePat scrut hs_ctx pat ty match_result
+  = do { var           <- selectSimpleMatchVarL pat
+       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
+       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
+
+matchSinglePatVar :: Id   -- See Note [Match Ids]
+                  -> HsMatchContext Name -> LPat GhcTc
+                  -> Type -> MatchResult -> DsM MatchResult
+matchSinglePatVar var ctx pat ty match_result
+  = ASSERT2( isInternalName (idName var), ppr var )
+    do { dflags <- getDynFlags
+       ; locn   <- getSrcSpanDs
+
+                    -- Pattern match check warnings
+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+
+       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+                                , eqn_orig = FromSource
+                                , eqn_rhs  = match_result }
+       ; match [var] ty [eqn_info] }
+
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern classification
+*                                                                      *
+************************************************************************
+-}
+
+data PatGroup
+  = PgAny               -- Immediate match: variables, wildcards,
+                        --                  lazy patterns
+  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
+  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
+  | PgLit Literal       -- Literal patterns
+  | PgN   Rational      -- Overloaded numeric literals;
+                        -- see Note [Don't use Literal for PgN]
+  | PgOverS FastString  -- Overloaded string literals
+  | PgNpK Integer       -- n+k patterns
+  | PgBang              -- Bang patterns
+  | PgCo Type           -- Coercion patterns; the type is the type
+                        --      of the pattern *inside*
+  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
+                        -- the LHsExpr is the expression e
+           Type         -- the Type is the type of p (equivalently, the result type of e)
+  | PgOverloadedList
+
+{- Note [Don't use Literal for PgN]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously we had, as PatGroup constructors
+
+  | ...
+  | PgN   Literal       -- Overloaded literals
+  | PgNpK Literal       -- n+k patterns
+  | ...
+
+But Literal is really supposed to represent an *unboxed* literal, like Int#.
+We were sticking the literal from, say, an overloaded numeric literal pattern
+into a LitInt constructor. This didn't really make sense; and we now have
+the invariant that value in a LitInt must be in the range of the target
+machine's Int# type, and an overloaded literal could meaningfully be larger.
+
+Solution: For pattern grouping purposes, just store the literal directly in
+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
+for overloaded strings.
+-}
+
+groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+-- If the result is of form [g1, g2, g3],
+-- (a) all the (pg,eq) pairs in g1 have the same pg
+-- (b) none of the gi are empty
+-- The ordering of equations is unchanged
+groupEquations dflags eqns
+  = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+  where
+    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+subGroup :: (m -> [[EquationInfo]]) -- Map.elems
+         -> m -- Map.empty
+         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup
+         -> (a -> [EquationInfo] -> m -> m) -- Map.insert
+         -> [(a, EquationInfo)] -> [[EquationInfo]]
+-- Input is a particular group.  The result sub-groups the
+-- equations by with particular constructor, literal etc they match.
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+-- Parameterized by map operations to allow different implementations
+-- and constraints, eg. types without Ord instance.
+subGroup elems empty lookup insert group
+    = map reverse $ elems $ foldl' accumulate empty group
+  where
+    accumulate pg_map (pg, eqn)
+      = case lookup pg pg_map of
+          Just eqns -> insert pg (eqn:eqns) pg_map
+          Nothing   -> insert pg [eqn]      pg_map
+    -- pg_map :: Map a [EquationInfo]
+    -- Equations seen so far in reverse order of appearance
+
+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
+
+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupUniq =
+  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
+
+{- Note [Pattern synonym groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+  f (P a) = e1
+  f (P b) = e2
+    ...
+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
+same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.
+Consider (#11224)
+   -- readMaybe :: Read a => String -> Maybe a
+   pattern PRead :: Read a => () => a -> String
+   pattern PRead a <- (readMaybe -> Just a)
+
+   f (PRead (x::Int))  = e1
+   f (PRead (y::Bool)) = e2
+This is all fine: we match the string by trying to read an Int; if that
+fails we try to read a Bool. But clearly we can't combine the two into a single
+match.
+
+Conclusion: we can combine when we invoke PRead /at the same type/.  Hence
+in PgSyn we record the instantiaing types, and use them in sameGroup.
+
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not
+swap the Nothing and y!
+-}
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+-- Same group means that a single case expression
+-- or test will suffice to match both, *and* the order
+-- of testing within the group is insignificant.
+sameGroup PgAny         PgAny         = True
+sameGroup PgBang        PgBang        = True
+sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression
+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
+                                                -- eqTypes: See Note [Pattern synonym groups]
+sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
+sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
+sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
+sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
+sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
+        -- CoPats are in the same goup only if the type of the
+        -- enclosed pattern is the same. The patterns outside the CoPat
+        -- always have the same type, so this boils down to saying that
+        -- the two coercions are identical.
+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
+       -- ViewPats are in the same group iff the expressions
+       -- are "equal"---conservatively, we use syntactic equality
+sameGroup _          _          = False
+
+-- An approximation of syntactic equality used for determining when view
+-- exprs are in the same group.
+-- This function can always safely return false;
+-- but doing so will result in the application of the view function being repeated.
+--
+-- Currently: compare applications of literals and variables
+--            and anything else that we can do without involving other
+--            HsSyn types in the recursion
+--
+-- NB we can't assume that the two view expressions have the same type.  Consider
+--   f (e1 -> True) = ...
+--   f (e2 -> "hi") = ...
+viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+  where
+    lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
+    lexp e e' = exp (unLoc e) (unLoc e')
+
+    ---------
+    exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
+    -- real comparison is on HsExpr's
+    -- strip parens
+    exp (HsPar _ (dL->L _ e)) e'   = exp e e'
+    exp e (HsPar _ (dL->L _ e'))   = exp e e'
+    -- because the expressions do not necessarily have the same type,
+    -- we have to compare the wrappers
+    exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+    exp (HsVar _ i) (HsVar _ i') =  i == i'
+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
+    -- the instance for IPName derives using the id, so this works if the
+    -- above does
+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+    exp (HsOverLit _ l) (HsOverLit _ l') =
+        -- Overloaded lits are equal if they have the same type
+        -- and the data is the same.
+        -- this is coarser than comparing the SyntaxExpr's in l and l',
+        -- which resolve the overloading (e.g., fromInteger 1),
+        -- because these expressions get written as a bunch of different variables
+        -- (presumably to improve sharing)
+        eqType (overLitType l) (overLitType l') && l == l'
+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
+    -- the fixities have been straightened out by now, so it's safe
+    -- to ignore them?
+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
+        lexp l l' && lexp o o' && lexp ri ri'
+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
+        lexp e1 e1' && lexp e2 e2'
+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
+        lexp e1 e1' && lexp e2 e2'
+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
+        eq_list tup_arg es1 es2
+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
+        lexp e e' && lexp e1 e1' && lexp e2 e2'
+
+    -- Enhancement: could implement equality for more expressions
+    --   if it seems useful
+    -- But no need for HsLit, ExplicitList, ExplicitTuple,
+    -- because they cannot be functions
+    exp _ _  = False
+
+    ---------
+    syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
+    syn_exp (SyntaxExpr { syn_expr      = expr1
+                        , syn_arg_wraps = arg_wraps1
+                        , syn_res_wrap  = res_wrap1 })
+            (SyntaxExpr { syn_expr      = expr2
+                        , syn_arg_wraps = arg_wraps2
+                        , syn_res_wrap  = res_wrap2 })
+      = exp expr1 expr2 &&
+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
+        wrap res_wrap1 res_wrap2
+
+    ---------
+    tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (dL->L _ (Missing t1))   (dL->L _ (Missing t2))   = eqType t1 t2
+    tup_arg _ _ = False
+
+    ---------
+    wrap :: HsWrapper -> HsWrapper -> Bool
+    -- Conservative, in that it demands that wrappers be
+    -- syntactically identical and doesn't look under binders
+    --
+    -- Coarser notions of equality are possible
+    -- (e.g., reassociating compositions,
+    --        equating different ways of writing a coercion)
+    wrap WpHole WpHole = True
+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
+    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
+    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
+    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
+    -- Enhancement: could implement equality for more wrappers
+    --   if it seems useful (lams and lets)
+    wrap _ _ = False
+
+    ---------
+    ev_term :: EvTerm -> EvTerm -> Bool
+    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b
+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
+    ev_term _ _ = False
+
+    ---------
+    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+    eq_list _  []     []     = True
+    eq_list _  []     (_:_)  = False
+    eq_list _  (_:_)  []     = False
+    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
+
+patGroup :: DynFlags -> Pat GhcTc -> PatGroup
+patGroup _ (ConPatOut { pat_con = (dL->L _ con)
+                      , pat_arg_tys = tys })
+ | RealDataCon dcon <- con              = PgCon dcon
+ | PatSynCon psyn <- con                = PgSyn psyn tys
+patGroup _ (WildPat {})                 = PgAny
+patGroup _ (BangPat {})                 = PgBang
+patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =
+  case (oval, isJust mb_neg) of
+   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
+   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
+   (HsFractional r, False) -> PgN (fl_value r)
+   (HsFractional r, True ) -> PgN (-fl_value r)
+   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+                          PgOverS s
+patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =
+  case oval of
+   HsIntegral i -> PgNpK (il_value i)
+   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)
+                                                    -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)
+patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
+
+{-
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+WATCH OUT!  Consider
+
+        f (n+1) = ...
+        f (n+2) = ...
+        f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first.  Same goes for *overloaded* literal patterns
+        f 1 True = ...
+        f 2 False = ...
+        f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation!  Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+-}
diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Match.hs-boot
@@ -0,0 +1,37 @@
+module Match where
+
+import GhcPrelude
+import Var      ( Id )
+import TcType   ( Type )
+import DsMonad  ( DsM, EquationInfo, MatchResult )
+import CoreSyn  ( CoreExpr )
+import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )
+import Name     ( Name )
+import HsExtension ( GhcTc )
+
+match   :: [Id]
+        -> Type
+        -> [EquationInfo]
+        -> DsM MatchResult
+
+matchWrapper
+        :: HsMatchContext Name
+        -> Maybe (LHsExpr GhcTc)
+        -> MatchGroup GhcTc (LHsExpr GhcTc)
+        -> DsM ([Id], CoreExpr)
+
+matchSimply
+        :: CoreExpr
+        -> HsMatchContext Name
+        -> LPat GhcTc
+        -> CoreExpr
+        -> CoreExpr
+        -> DsM CoreExpr
+
+matchSinglePatVar
+        :: Id
+        -> HsMatchContext Name
+        -> LPat GhcTc
+        -> Type
+        -> MatchResult
+        -> DsM MatchResult
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/MatchCon.hs
@@ -0,0 +1,296 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching constructors
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module MatchCon ( matchConFamily, matchPatSyn ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} Match     ( match )
+
+import HsSyn
+import DsBinds
+import ConLike
+import BasicTypes ( Origin(..) )
+import TcType
+import DsMonad
+import DsUtils
+import MkCore   ( mkCoreLets )
+import Util
+import Id
+import NameEnv
+import FieldLabel ( flSelector )
+import SrcLoc
+import Outputable
+import Control.Monad(liftM)
+import Data.List (groupBy)
+
+{-
+We are confronted with the first column of patterns in a set of
+equations, all beginning with constructors from one ``family'' (e.g.,
+@[]@ and @:@ make up the @List@ ``family'').  We want to generate the
+alternatives for a @Case@ expression.  There are several choices:
+\begin{enumerate}
+\item
+Generate an alternative for every constructor in the family, whether
+they are used in this set of equations or not; this is what the Wadler
+chapter does.
+\begin{description}
+\item[Advantages:]
+(a)~Simple.  (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
+\item[Disadvantages:]
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set.  (b)~Have to look up a list of what
+constructors make up the whole family.
+\end{description}
+
+\item
+Generate an alternative for each constructor used, then add a default
+alternative in case some constructors in the family weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~Alternatives aren't generated for unused constructors.  (b)~The
+STG is quite happy with defaults.  (c)~No lookup in an environment needed.
+\item[Disadvantages:]
+(a)~A spurious default alternative may be generated.
+\end{description}
+
+\item
+``Do it right:'' generate an alternative for each constructor used,
+and add a default alternative if all constructors in the family
+weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~You will get cases with only one alternative (and no default),
+which should be amenable to optimisation.  Tuples are a common example.
+\item[Disadvantages:]
+(b)~Have to look up constructor families in TDE (as above).
+\end{description}
+\end{enumerate}
+
+We are implementing the ``do-it-right'' option for now.  The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
+
+The function @matchConFamily@ is concerned with this
+have-we-used-all-the-constructors? question; the local function
+@match_cons_used@ does all the real work.
+-}
+
+matchConFamily :: [Id]
+               -> Type
+               -> [[EquationInfo]]
+               -> DsM MatchResult
+-- Each group of eqns is for a single constructor
+matchConFamily (var:vars) ty groups
+  = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
+       return (mkCoAlgCaseMatchResult var ty alts)
+  where
+    toRealAlt alt = case alt_pat alt of
+        RealDataCon dcon -> alt{ alt_pat = dcon }
+        _ -> panic "matchConFamily: not RealDataCon"
+matchConFamily [] _ _ = panic "matchConFamily []"
+
+matchPatSyn :: [Id]
+            -> Type
+            -> [EquationInfo]
+            -> DsM MatchResult
+matchPatSyn (var:vars) ty eqns
+  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
+       return (mkCoSynCaseMatchResult var ty alt)
+  where
+    toSynAlt alt = case alt_pat alt of
+        PatSynCon psyn -> alt{ alt_pat = psyn }
+        _ -> panic "matchPatSyn: not PatSynCon"
+matchPatSyn _ _ _ = panic "matchPatSyn []"
+
+type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))
+
+matchOneConLike :: [Id]
+                -> Type
+                -> [EquationInfo]
+                -> DsM (CaseAlt ConLike)
+matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
+  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
+                           -- ex_tvs can only be tyvars as data types in source
+                           -- Haskell cannot mention covar yet (Aug 2018).
+                         ASSERT( tvs1 `equalLength` ex_tvs )
+                         arg_tys ++ mkTyVarTys tvs1
+
+              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
+        -- dataConInstOrigArgTys takes the univ and existential tyvars
+        -- and returns the types of the *value* args, which is what we want
+
+              match_group :: [Id]
+                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
+              -- All members of the group have compatible ConArgPats
+              match_group arg_vars arg_eqn_prs
+                = ASSERT( notNull arg_eqn_prs )
+                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
+                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'
+                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
+
+              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
+                                                             pat_binds = bind, pat_args = args
+                                                  } : pats }))
+                = do ds_bind <- dsTcEvBinds bind
+                     return ( wrapBinds (tvs `zip` tvs1)
+                            . wrapBinds (ds  `zip` dicts1)
+                            . mkCoreLets ds_bind
+                            , eqn { eqn_orig = Generated
+                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }
+                            )
+              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+
+        ; arg_vars <- selectConMatchVars val_arg_tys args1
+                -- Use the first equation as a source of
+                -- suggestions for the new variables
+
+        -- Divide into sub-groups; see Note [Record patterns]
+        ; let groups :: [[(ConArgPats, EquationInfo)]]
+              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
+                                               | eqn <- eqn1:eqns ]
+
+        ; match_results <- mapM (match_group arg_vars) groups
+
+        ; return $ MkCaseAlt{ alt_pat = con1,
+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
+                              alt_wrapper = wrapper1,
+                              alt_result = foldr1 combineMatchResults match_results } }
+  where
+    ConPatOut { pat_con = (dL->L _ con1)
+              , pat_arg_tys = arg_tys, pat_wrap = wrapper1,
+                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
+              = firstPat eqn1
+    fields1 = map flSelector (conLikeFieldLabels con1)
+
+    ex_tvs = conLikeExTyCoVars con1
+
+    -- Choose the right arg_vars in the right order for this group
+    -- Note [Record patterns]
+    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
+    select_arg_vars arg_vars ((arg_pats, _) : _)
+      | RecCon flds <- arg_pats
+      , let rpats = rec_flds flds
+      , not (null rpats)     -- Treated specially; cf conArgPats
+      = ASSERT2( fields1 `equalLength` arg_vars,
+                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )
+        map lookup_fld rpats
+      | otherwise
+      = arg_vars
+      where
+        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
+        lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env
+                                            (idName (unLoc (hsRecFieldId rpat)))
+    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
+matchOneConLike _ _ [] = panic "matchOneCon []"
+
+-----------------
+compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
+-- Two constructors have compatible argument patterns if the number
+-- and order of sub-matches is the same in both cases
+compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
+compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)
+compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)
+compatible_pats _                 _                 = True -- Prefix or infix con
+
+same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
+            -> Bool
+same_fields flds1 flds2
+  = all2 (\(dL->L _ f1) (dL->L _ f2)
+                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
+         (rec_flds flds1) (rec_flds flds2)
+
+
+-----------------
+selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
+selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys
+selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)
+selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
+
+conArgPats :: [Type]      -- Instantiated argument types
+                          -- Used only to fill in the types of WildPats, which
+                          -- are probably never looked at anyway
+           -> ConArgPats
+           -> [Pat GhcTc]
+conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps
+conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
+  | null rpats = map WildPat arg_tys
+        -- Important special case for C {}, which can be used for a
+        -- datacon that isn't declared to have fields at all
+  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats
+
+{-
+Note [Record patterns]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider
+         data T = T { x,y,z :: Bool }
+
+         f (T { y=True, x=False }) = ...
+
+We must match the patterns IN THE ORDER GIVEN, thus for the first
+one we match y=True before x=False.  See #246; or imagine
+matching against (T { y=False, x=undefined }): should fail without
+touching the undefined.
+
+Now consider:
+
+         f (T { y=True, x=False }) = ...
+         f (T { x=True, y= False}) = ...
+
+In the first we must test y first; in the second we must test x
+first.  So we must divide even the equations for a single constructor
+T into sub-goups, based on whether they match the same field in the
+same order.  That's what the (groupBy compatible_pats) grouping.
+
+All non-record patterns are "compatible" in this sense, because the
+positional patterns (T a b) and (a `T` b) all match the arguments
+in order.  Also T {} is special because it's equivalent to (T _ _).
+Hence the (null rpats) checks here and there.
+
+
+Note [Existentials in shift_con_pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        data T = forall a. Ord a => T a (a->Int)
+
+        f (T x f) True  = ...expr1...
+        f (T y g) False = ...expr2..
+
+When we put in the tyvars etc we get
+
+        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
+        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
+
+After desugaring etc we'll get a single case:
+
+        f = \t::T b::Bool ->
+            case t of
+               T a (d::Ord a) (x::a) (f::a->Int)) ->
+            case b of
+                True  -> ...expr1...
+                False -> ...expr2...
+
+*** We have to substitute [a/b, d/e] in expr2! **
+Hence
+                False -> ....((/\b\(e:Ord b).expr2) a d)....
+
+Originally I tried to use
+        (\b -> let e = d in expr2) a
+to do this substitution.  While this is "correct" in a way, it fails
+Lint, because e::Ord b but d::Ord a.
+
+-}
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/MatchLit.hs
@@ -0,0 +1,521 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching literal patterns
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module MatchLit ( dsLit, dsOverLit, hsLitKey
+                , tidyLitPat, tidyNPat
+                , matchLiterals, matchNPlusKPats, matchNPats
+                , warnAboutIdentities
+                , warnAboutOverflowedOverLit, warnAboutOverflowedLit
+                , warnAboutEmptyEnumerations
+                ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} Match  ( match )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
+
+import DsMonad
+import DsUtils
+
+import HsSyn
+
+import Id
+import CoreSyn
+import MkCore
+import TyCon
+import DataCon
+import TcHsSyn ( shortCutLit )
+import TcType
+import Name
+import Type
+import PrelNames
+import TysWiredIn
+import TysPrim
+import Literal
+import SrcLoc
+import Data.Ratio
+import Outputable
+import BasicTypes
+import DynFlags
+import Util
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Int
+import Data.Word
+import Data.Proxy
+
+{-
+************************************************************************
+*                                                                      *
+                Desugaring literals
+        [used to be in DsExpr, but DsMeta needs it,
+         and it's nice to avoid a loop]
+*                                                                      *
+************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+-}
+
+dsLit :: HsLit GhcRn -> DsM CoreExpr
+dsLit l = do
+  dflags <- getDynFlags
+  case l of
+    HsStringPrim _ s -> return (Lit (LitString s))
+    HsCharPrim   _ c -> return (Lit (LitChar c))
+    HsIntPrim    _ i -> return (Lit (mkLitIntWrap dflags i))
+    HsWordPrim   _ w -> return (Lit (mkLitWordWrap dflags w))
+    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap dflags i))
+    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))
+    HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))
+    HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
+    HsChar _ c       -> return (mkCharExpr c)
+    HsString _ str   -> mkStringExprFS str
+    HsInteger _ i _  -> mkIntegerExpr i
+    HsInt _ i        -> return (mkIntExpr dflags (il_value i))
+    XLit x           -> pprPanic "dsLit" (ppr x)
+    HsRat _ (FL _ _ val) ty -> do
+      num   <- mkIntegerExpr (numerator val)
+      denom <- mkIntegerExpr (denominator val)
+      return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+      where
+        (ratio_data_con, integer_ty)
+            = case tcSplitTyConApp ty of
+                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+                                       (head (tyConDataCons tycon), i_ty)
+                    x -> pprPanic "dsLit" (ppr x)
+
+dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
+-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
+-- (an expression for) the literal value itself.
+dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
+                   , ol_witness = witness }) = do
+  dflags <- getDynFlags
+  case shortCutLit dflags val ty of
+    Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]
+    _                          -> dsExpr witness
+dsOverLit XOverLit{} = panic "dsOverLit"
+{-
+Note [Literal short cut]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The type checker tries to do this short-cutting as early as possible, but
+because of unification etc, more information is available to the desugarer.
+And where it's possible to generate the correct literal right away, it's
+much better to do so.
+
+
+************************************************************************
+*                                                                      *
+                 Warnings about overflowed literals
+*                                                                      *
+************************************************************************
+
+Warn about functions like toInteger, fromIntegral, that convert
+between one type and another when the to- and from- types are the
+same.  Then it's probably (albeit not definitely) the identity
+-}
+
+warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
+warnAboutIdentities dflags (Var conv_fn) type_of_conv
+  | wopt Opt_WarnIdentities dflags
+  , idName conv_fn `elem` conversionNames
+  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
+  = warnDs (Reason Opt_WarnIdentities)
+           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
+                 , nest 2 $ text "can probably be omitted"
+           ])
+warnAboutIdentities _ _ _ = return ()
+
+conversionNames :: [Name]
+conversionNames
+  = [ toIntegerName, toRationalName
+    , fromIntegralName, realToFracName ]
+ -- We can't easily add fromIntegerName, fromRationalName,
+ -- because they are generated by literals
+
+
+-- | Emit warnings on overloaded integral literals which overflow the bounds
+-- implied by their type.
+warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
+warnAboutOverflowedOverLit hsOverLit = do
+  dflags <- getDynFlags
+  warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)
+
+-- | Emit warnings on integral literals which overflow the boudns implied by
+-- their type.
+warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
+warnAboutOverflowedLit hsLit = do
+  dflags <- getDynFlags
+  warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
+
+-- | Emit warnings on integral literals which overflow the bounds implied by
+-- their type.
+warnAboutOverflowedLiterals
+  :: DynFlags
+  -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon
+  -> DsM ()
+warnAboutOverflowedLiterals dflags lit
+ | wopt Opt_WarnOverflowedLiterals dflags
+ , Just (i, tc) <- lit
+ =  if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)
+
+    -- These only show up via the 'HsOverLit' route
+    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)
+    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)
+    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)
+    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)
+    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)
+    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)
+    else if tc == naturalTyConName then checkPositive i tc
+
+    -- These only show up via the 'HsLit' route
+    else if tc == intPrimTyConName    then check i tc (Proxy :: Proxy Int)
+    else if tc == int8PrimTyConName   then check i tc (Proxy :: Proxy Int8)
+    else if tc == int32PrimTyConName  then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64PrimTyConName  then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordPrimTyConName   then check i tc (Proxy :: Proxy Word)
+    else if tc == word8PrimTyConName  then check i tc (Proxy :: Proxy Word8)
+    else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)
+
+    else return ()
+
+  | otherwise = return ()
+  where
+
+    checkPositive :: Integer -> Name -> DsM ()
+    checkPositive i tc
+      = when (i < 0) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is negative but" <+> ppr tc
+                       <+> ptext (sLit "only supports positive numbers")
+                     ])
+
+    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
+    check i tc _proxy
+      = when (i < minB || i > maxB) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
+                       <+> integer minB <> text ".." <> integer maxB
+                     , sug ])
+      where
+        minB = toInteger (minBound :: a)
+        maxB = toInteger (maxBound :: a)
+        sug | minB == -i   -- Note [Suggest NegativeLiterals]
+            , i > 0
+            , not (xopt LangExt.NegativeLiterals dflags)
+            = text "If you are trying to write a large negative literal, use NegativeLiterals"
+            | otherwise = Outputable.empty
+
+{-
+Note [Suggest NegativeLiterals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you write
+  x :: Int8
+  x = -128
+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
+We get an erroneous suggestion for
+  x = 128
+but perhaps that does not matter too much.
+-}
+
+warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
+                           -> LHsExpr GhcTc -> DsM ()
+-- ^ Warns about @[2,3 .. 1]@ which returns the empty list.
+-- Only works for integral types, not floating point.
+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
+  | wopt Opt_WarnEmptyEnumerations dflags
+  , Just (from,tc) <- getLHsIntegralLit fromExpr
+  , Just mThn      <- traverse getLHsIntegralLit mThnExpr
+  , Just (to,_)    <- getLHsIntegralLit toExpr
+  , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
+        check _proxy
+          = when (null enumeration) $
+            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
+          where
+            enumeration :: [a]
+            enumeration = case mThn of
+                            Nothing      -> [fromInteger from                    .. fromInteger to]
+                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]
+
+  = if      tc == intTyConName    then check (Proxy :: Proxy Int)
+    else if tc == int8TyConName   then check (Proxy :: Proxy Int8)
+    else if tc == int16TyConName  then check (Proxy :: Proxy Int16)
+    else if tc == int32TyConName  then check (Proxy :: Proxy Int32)
+    else if tc == int64TyConName  then check (Proxy :: Proxy Int64)
+    else if tc == wordTyConName   then check (Proxy :: Proxy Word)
+    else if tc == word8TyConName  then check (Proxy :: Proxy Word8)
+    else if tc == word16TyConName then check (Proxy :: Proxy Word16)
+    else if tc == word32TyConName then check (Proxy :: Proxy Word32)
+    else if tc == word64TyConName then check (Proxy :: Proxy Word64)
+    else if tc == integerTyConName then check (Proxy :: Proxy Integer)
+    else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
+      -- We use 'Integer' because otherwise a negative 'Natural' literal
+      -- could cause a compile time crash (instead of a runtime one).
+      -- See the T10930b test case for an example of where this matters.
+    else return ()
+
+  | otherwise = return ()
+
+getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
+-- ^ See if the expression is an 'Integral' literal.
+-- Remember to look through automatically-added tick-boxes! (#8384)
+getLHsIntegralLit (dL->L _ (HsPar _ e))            = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsTick _ _ e))         = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (dL->L _ (HsLit _ lit))          = getSimpleIntegralLit lit
+getLHsIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the overloaded literal.
+getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (il_value i, tyConName tc)
+getIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the non-overloaded
+-- literal.
+getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
+getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
+getSimpleIntegralLit (HsInteger _ i ty)
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (i, tyConName tc)
+getSimpleIntegralLit _ = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+        Tidying lit pats
+*                                                                      *
+************************************************************************
+-}
+
+tidyLitPat :: HsLit GhcTc -> Pat GhcTc
+-- Result has only the following HsLits:
+--      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
+--      HsDoublePrim, HsStringPrim, HsString
+--  * HsInteger, HsRat, HsInt can't show up in LitPats
+--  * We get rid of HsChar right here
+tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
+tidyLitPat (HsString src s)
+  | lengthFS s <= 1     -- Short string literals only
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
+                                             [mkCharLitPat src c, pat] [charTy])
+                  (mkNilPat charTy) (unpackFS s)
+        -- The stringTy is the type of the whole pattern, not
+        -- the type to instantiate (:) or [] with!
+tidyLitPat lit = LitPat noExt lit
+
+----------------
+tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
+         -> Type
+         -> Pat GhcTc
+tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
+        -- False: Take short cuts only if the literal is not using rebindable syntax
+        --
+        -- Once that is settled, look for cases where the type of the
+        -- entire overloaded literal matches the type of the underlying literal,
+        -- and in that case take the short cut
+        -- NB: Watch out for weird cases like #3382
+        --        f :: Int -> Int
+        --        f "blah" = 4
+        --     which might be ok if we have 'instance IsString Int'
+        --
+  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
+                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
+  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
+                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
+  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
+                 = tidyLitPat (HsString NoSourceText str_lit)
+     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
+     -- If we do convert to the constructor form, we'll generate a case
+     -- expression on a Float# or Double# and that's not allowed in Core; see
+     -- #9238 and Note [Rules for floating-point comparisons] in PrelRules
+  where
+    -- Sometimes (like in test case
+    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
+    -- type-changing wrappers (for example, from Id Int to Int, for the identity
+    -- type family Id). In these cases, we can't do the short-cut.
+    type_change = not (outer_ty `eqType` ty)
+
+    mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
+    mk_con_pat con lit
+      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
+
+    mb_int_lit :: Maybe Integer
+    mb_int_lit = case (mb_neg, val) of
+                   (Nothing, HsIntegral i) -> Just (il_value i)
+                   (Just _,  HsIntegral i) -> Just (-(il_value i))
+                   _ -> Nothing
+
+    mb_str_lit :: Maybe FastString
+    mb_str_lit = case (mb_neg, val) of
+                   (Nothing, HsIsString _ s) -> Just s
+                   _ -> Nothing
+
+tidyNPat over_lit mb_neg eq outer_ty
+  = NPat outer_ty (noLoc over_lit) mb_neg eq
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on LitPat
+*                                                                      *
+************************************************************************
+-}
+
+matchLiterals :: [Id]
+              -> Type                   -- Type of the whole case expression
+              -> [[EquationInfo]]       -- All PgLits
+              -> DsM MatchResult
+
+matchLiterals (var:vars) ty sub_groups
+  = ASSERT( notNull sub_groups && all notNull sub_groups )
+    do  {       -- Deal with each group
+        ; alts <- mapM match_group sub_groups
+
+                -- Combine results.  For everything except String
+                -- we can use a case expression; for String we need
+                -- a chain of if-then-else
+        ; if isStringTy (idType var) then
+            do  { eq_str <- dsLookupGlobalId eqStringName
+                ; mrs <- mapM (wrap_str_guard eq_str) alts
+                ; return (foldr1 combineMatchResults mrs) }
+          else
+            return (mkCoPrimCaseMatchResult var ty alts)
+        }
+  where
+    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
+    match_group eqns
+        = do { dflags <- getDynFlags
+             ; let LitPat _ hs_lit = firstPat (head eqns)
+             ; match_result <- match vars ty (shiftEqns eqns)
+             ; return (hsLitKey dflags hs_lit, match_result) }
+
+    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
+        -- Equality check for string literals
+    wrap_str_guard eq_str (LitString s, mr)
+        = do { -- We now have to convert back to FastString. Perhaps there
+               -- should be separate LitBytes and LitString constructors?
+               let s'  = mkFastStringByteString s
+             ; lit    <- mkStringExprFS s'
+             ; let pred = mkApps (Var eq_str) [Var var, lit]
+             ; return (mkGuardedMatchResult pred mr) }
+    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
+
+matchLiterals [] _ _ = panic "matchLiterals []"
+
+---------------------------
+hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
+-- Get the Core literal corresponding to a HsLit.
+-- It only works for primitive types and strings;
+-- others have been removed by tidy
+-- For HsString, it produces a LitString, which really represents an _unboxed_
+-- string literal; and we deal with it in matchLiterals above. Otherwise, it
+-- produces a primitive Literal of type matching the original HsLit.
+-- In the case of the fixed-width numeric types, we need to wrap here
+-- because Literal has an invariant that the literal is in range, while
+-- HsLit does not.
+hsLitKey dflags (HsIntPrim    _ i) = mkLitIntWrap  dflags i
+hsLitKey dflags (HsWordPrim   _ w) = mkLitWordWrap dflags w
+hsLitKey dflags (HsInt64Prim  _ i) = mkLitInt64Wrap  dflags i
+hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w
+hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c
+hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)
+hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)
+hsLitKey _      (HsString _ s)     = LitString (bytesFS s)
+hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on NPat
+*                                                                      *
+************************************************************************
+-}
+
+matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
+  = do  { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1
+        ; lit_expr <- dsOverLit lit
+        ; neg_lit <- case mb_neg of
+                            Nothing  -> return lit_expr
+                            Just neg -> dsSyntaxExpr neg [lit_expr]
+        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
+        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
+        ; return (mkGuardedMatchResult pred_expr match_result) }
+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on n+k patterns
+*                                                                      *
+************************************************************************
+
+For an n+k pattern, we use the various magic expressions we've been given.
+We generate:
+\begin{verbatim}
+    if ge var lit then
+        let n = sub var lit
+        in  <expr-for-a-successful-match>
+    else
+        <try-next-pattern-or-whatever>
+\end{verbatim}
+-}
+
+matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var:vars) ty (eqn1:eqns)
+  = do  { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus
+                = firstPat eqn1
+        ; lit1_expr   <- dsOverLit lit1
+        ; lit2_expr   <- dsOverLit lit2
+        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
+        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
+        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+        ; match_result <- match vars ty eqns'
+        ; return  (mkGuardedMatchResult pred_expr               $
+                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $
+                   adjustMatchResult (foldr1 (.) wraps)         $
+                   match_result) }
+  where
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats })
+        = (wrapBind n n1, eqn { eqn_pats = pats })
+        -- The wrapBind is a no-op for the first equation
+    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
+
+matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/TmOracle.hs
@@ -0,0 +1,265 @@
+{-
+Author: George Karachalias <george.karachalias@cs.kuleuven.be>
+
+The term equality oracle. The main export of the module is function `tmOracle'.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+
+module TmOracle (
+
+        -- re-exported from PmExpr
+        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,
+        eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,
+        hsExprToPmExpr, pprPmExprWithParens,
+
+        -- the term oracle
+        tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,
+
+        -- misc.
+        toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import PmExpr
+
+import Id
+import Name
+import Type
+import HsLit
+import TcHsSyn
+import MonadUtils
+import Util
+import Outputable
+
+import NameEnv
+
+{-
+%************************************************************************
+%*                                                                      *
+                      The term equality oracle
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | The type of substitutions.
+type PmVarEnv = NameEnv PmExpr
+
+-- | The environment of the oracle contains
+--     1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
+--     2. A substitution we extend with every step and return as a result.
+type TmOracleEnv = (Bool, PmVarEnv)
+
+-- | Check whether a constraint (x ~ BOT) can succeed,
+-- given the resulting state of the term oracle.
+canDiverge :: Name -> TmState -> Bool
+canDiverge x (standby, (_unhandled, env))
+  -- If the variable seems not evaluated, there is a possibility for
+  -- constraint x ~ BOT to be satisfiable.
+  | PmExprVar y <- varDeepLookup env x -- seems not forced
+  -- If it is involved (directly or indirectly) in any equality in the
+  -- worklist, we can assume that it is already indirectly evaluated,
+  -- as a side-effect of equality checking. If not, then we can assume
+  -- that the constraint is satisfiable.
+  = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby
+  -- Variable x is already in WHNF so the constraint is non-satisfiable
+  | otherwise = False
+
+  where
+    isForcedByEq :: Name -> ComplexEq -> Bool
+    isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2
+
+-- | Check whether a variable is in the free variables of an expression
+varIn :: Name -> PmExpr -> Bool
+varIn x e = case e of
+  PmExprVar y    -> x == y
+  PmExprCon _ es -> any (x `varIn`) es
+  PmExprLit _    -> False
+  PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)
+  PmExprOther _  -> False
+
+-- | Flatten the DAG (Could be improved in terms of performance.).
+flattenPmVarEnv :: PmVarEnv -> PmVarEnv
+flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env
+
+-- | The state of the term oracle (includes complex constraints that cannot
+-- progress unless we get more information).
+type TmState = ([ComplexEq], TmOracleEnv)
+
+-- | Initial state of the oracle.
+initialTmState :: TmState
+initialTmState = ([], (False, emptyNameEnv))
+
+-- | Solve a complex equality (top-level).
+solveOneEq :: TmState -> ComplexEq -> Maybe TmState
+solveOneEq solver_env@(_,(_,env)) complex
+  = solveComplexEq solver_env -- do the actual *merging* with existing state
+  $ simplifyComplexEq               -- simplify as much as you can
+  $ applySubstComplexEq env complex -- replace everything we already know
+
+-- | Solve a complex equality.
+-- Nothing => definitely unsatisfiable
+-- Just tms => I have added the complex equality and added
+--             it to the tmstate; the result may or may not be
+--             satisfiable
+solveComplexEq :: TmState -> ComplexEq -> Maybe TmState
+solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
+  -- We cannot do a thing about these cases
+  (PmExprOther _,_)            -> Just (standby, (True, env))
+  (_,PmExprOther _)            -> Just (standby, (True, env))
+
+  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+    -- See Note [Undecidable Equality for Overloaded Literals]
+    True  -> Just solver_state
+    False -> Nothing
+
+  (PmExprCon c1 ts1, PmExprCon c2 ts2)
+    | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)
+    | otherwise -> Nothing
+  (PmExprCon _ [], PmExprEq t1 t2)
+    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)
+    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))
+  (PmExprEq t1 t2, PmExprCon _ [])
+    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)
+    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))
+
+  (PmExprVar x, PmExprVar y)
+    | x == y    -> Just solver_state
+    | otherwise -> extendSubstAndSolve x e2 solver_state
+
+  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state
+  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state
+
+  (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))
+
+  _ -> WARN( True, text "solveComplexEq: Catch all" <+> ppr eq )
+       Just (standby, (True, env)) -- I HATE CATCH-ALLS
+
+-- | Extend the substitution and solve the (possibly updated) constraints.
+extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState
+extendSubstAndSolve x e (standby, (unhandled, env))
+  = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)
+  where
+    -- Apply the substitution to the worklist and partition them to the ones
+    -- that had some progress and the rest. Then, recurse over the ones that
+    -- had some progress. Careful about performance:
+    -- See Note [Representation of Term Equalities] in deSugar/Check.hs
+    (changed, unchanged) = partitionWith (substComplexEq x e) standby
+    new_incr_state       = (unchanged, (unhandled, extendNameEnv env x e))
+
+-- | When we know that a variable is fresh, we do not actually have to
+-- check whether anything changes, we know that nothing does. Hence,
+-- `extendSubst` simply extends the substitution, unlike what
+-- `extendSubstAndSolve` does.
+extendSubst :: Id -> PmExpr -> TmState -> TmState
+extendSubst y e (standby, (unhandled, env))
+  | isNotPmExprOther simpl_e
+  = (standby, (unhandled, extendNameEnv env x simpl_e))
+  | otherwise = (standby, (True, env))
+  where
+    x = idName y
+    simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e
+
+-- | Simplify a complex equality.
+simplifyComplexEq :: ComplexEq -> ComplexEq
+simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)
+
+-- | Simplify an expression. The boolean indicates if there has been any
+-- simplification or if the operation was a no-op.
+simplifyPmExpr :: PmExpr -> (PmExpr, Bool)
+-- See Note [Deep equalities]
+simplifyPmExpr e = case e of
+  PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of
+                      (ts', bs) -> (PmExprCon c ts', or bs)
+  PmExprEq t1 t2 -> simplifyEqExpr t1 t2
+  _other_expr    -> (e, False) -- the others are terminals
+
+-- | Simplify an equality expression. The equality is given in parts.
+simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)
+-- See Note [Deep equalities]
+simplifyEqExpr e1 e2 = case (e1, e2) of
+  -- Varables
+  (PmExprVar x, PmExprVar y)
+    | x == y -> (truePmExpr, True)
+
+  -- Literals
+  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+    -- See Note [Undecidable Equality for Overloaded Literals]
+    True  -> (truePmExpr,  True)
+    False -> (falsePmExpr, True)
+
+  -- Can potentially be simplified
+  (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'
+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'
+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress
+  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'
+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'
+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress
+
+  -- Constructors
+  (PmExprCon c1 ts1, PmExprCon c2 ts2)
+    | c1 == c2 ->
+        let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1
+            (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2
+            (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'
+            worst_case  = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')
+        in  if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress
+               | all isTruePmExpr  tss  -> (truePmExpr, True)
+               | any isFalsePmExpr tss  -> (falsePmExpr, True)
+               | otherwise              -> (worst_case, False)
+    | otherwise -> (falsePmExpr, True)
+
+  -- We cannot do anything about the rest..
+  _other_equality -> (original, False)
+
+  where
+    original = PmExprEq e1 e2 -- reconstruct equality
+
+-- | Apply an (un-flattened) substitution to a simple equality.
+applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq
+applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
+
+-- | Apply an (un-flattened) substitution to a variable.
+varDeepLookup :: PmVarEnv -> Name -> PmExpr
+varDeepLookup env x
+  | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper
+  | otherwise                  = PmExprVar x          -- terminal
+{-# INLINE varDeepLookup #-}
+
+-- | Apply an (un-flattened) substitution to an expression.
+exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr
+exprDeepLookup env (PmExprVar x)    = varDeepLookup env x
+exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)
+exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)
+                                               (exprDeepLookup env e2)
+exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther
+
+-- | External interface to the term oracle.
+tmOracle :: TmState -> [ComplexEq] -> Maybe TmState
+tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs
+
+-- | Type of a PmLit
+pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(
+pmLitType (PmSLit   lit) = hsLitType   lit
+pmLitType (PmOLit _ lit) = overLitType lit
+
+{- Note [Deep equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving nested equalities is the most difficult part. The general strategy
+is the following:
+
+  * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just
+    (e1 ~ e2) and then treated recursively.
+
+  * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless
+    we know more about the inner equality (e1 ~ e2). That's exactly what
+    `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns
+    truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note
+    that it is not e but rather e', since it may perform some
+    simplifications deeper.
+-}
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -0,0 +1,564 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}
+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeLink: Bytecode assembler and linker
+module ByteCodeAsm (
+        assembleBCOs, assembleOneBCO,
+
+        bcoFreeNames,
+        SizedSeq, sizeSS, ssElts,
+        iNTERP_STACK_CHECK_THRESH
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import ByteCodeInstr
+import ByteCodeItbls
+import ByteCodeTypes
+import GHCi.RemoteTypes
+import GHCi
+
+import HscTypes
+import Name
+import NameSet
+import Literal
+import TyCon
+import FastString
+import StgCmmLayout     ( ArgRep(..) )
+import SMRep
+import DynFlags
+import Outputable
+import Platform
+import Util
+import Unique
+import UniqDSet
+
+-- From iserv
+import SizedSeq
+
+import Control.Monad
+import Control.Monad.ST ( runST )
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State.Strict
+
+import Data.Array.MArray
+
+import qualified Data.Array.Unboxed as Array
+import Data.Array.Base  ( UArray(..) )
+
+import Data.Array.Unsafe( castSTUArray )
+
+import Foreign
+import Data.Char        ( ord )
+import Data.List
+import Data.Map (Map)
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+
+-- -----------------------------------------------------------------------------
+-- Unlinked BCOs
+
+-- CompiledByteCode represents the result of byte-code
+-- compiling a bunch of functions and data types
+
+-- | Finds external references.  Remember to remove the names
+-- defined by this group of BCOs themselves
+bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
+bcoFreeNames bco
+  = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
+  where
+    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
+        = unionManyUniqDSets (
+             mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
+             mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
+             map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
+          )
+
+-- -----------------------------------------------------------------------------
+-- The bytecode assembler
+
+-- The object format for bytecodes is: 16 bits for the opcode, and 16
+-- for each field -- so the code can be considered a sequence of
+-- 16-bit ints.  Each field denotes either a stack offset or number of
+-- items on the stack (eg SLIDE), and index into the pointer table (eg
+-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
+-- bytecode address in this BCO.
+
+-- Top level assembler fn.
+assembleBCOs
+  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
+  -> Maybe ModBreaks
+  -> IO CompiledByteCode
+assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
+  itblenv <- mkITbls hsc_env tycons
+  bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
+  (bcos',ptrs) <- mallocStrings hsc_env bcos
+  return CompiledByteCode
+    { bc_bcos = bcos'
+    , bc_itbls =  itblenv
+    , bc_ffis = concat (map protoBCOFFIs proto_bcos)
+    , bc_strs = top_strs ++ ptrs
+    , bc_breaks = modbreaks
+    }
+
+-- Find all the literal strings and malloc them together.  We want to
+-- do this because:
+--
+--  a) It should be done when we compile the module, not each time we relink it
+--  b) For -fexternal-interpreter It's more efficient to malloc the strings
+--     as a single batch message, especially when compiling in parallel.
+--
+mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
+mallocStrings hsc_env ulbcos = do
+  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
+  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)
+  return (evalState (mapM splice ulbcos) ptrs, ptrs)
+ where
+  splice bco@UnlinkedBCO{..} = do
+    lits <- mapM spliceLit unlinkedBCOLits
+    ptrs <- mapM splicePtr unlinkedBCOPtrs
+    return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
+
+  spliceLit (BCONPtrStr _) = do
+    rptrs <- get
+    case rptrs of
+      (RemotePtr p : rest) -> do
+        put rest
+        return (BCONPtrWord (fromIntegral p))
+      _ -> panic "mallocStrings:spliceLit"
+  spliceLit other = return other
+
+  splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
+  splicePtr other = return other
+
+  collect UnlinkedBCO{..} = do
+    mapM_ collectLit unlinkedBCOLits
+    mapM_ collectPtr unlinkedBCOPtrs
+
+  collectLit (BCONPtrStr bs) = do
+    strs <- get
+    put (bs:strs)
+  collectLit _ = return ()
+
+  collectPtr (BCOPtrBCO bco) = collect bco
+  collectPtr _ = return ()
+
+
+assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
+assembleOneBCO hsc_env pbco = do
+  ubco <- assembleBCO (hsc_dflags hsc_env) pbco
+  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
+  return ubco'
+
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
+  -- pass 1: collect up the offsets of the local labels.
+  let asm = mapM_ (assembleI dflags) instrs
+
+      initial_offset = 0
+
+      -- Jump instructions are variable-sized, there are long and short variants
+      -- depending on the magnitude of the offset.  However, we can't tell what
+      -- size instructions we will need until we have calculated the offsets of
+      -- the labels, which depends on the size of the instructions...  So we
+      -- first create the label environment assuming that all jumps are short,
+      -- and if the final size is indeed small enough for short jumps, we are
+      -- done.  Otherwise, we repeat the calculation, and we force all jumps in
+      -- this BCO to be long.
+      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
+      ((n_insns, lbl_map), long_jumps)
+        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
+        | otherwise = ((n_insns0, lbl_map0), False)
+
+      env :: Word16 -> Word
+      env lbl = fromMaybe
+        (pprPanic "assembleBCO.findLabel" (ppr lbl))
+        (Map.lookup lbl lbl_map)
+
+  -- pass 2: run assembler and generate instructions, literals and pointers
+  let initial_state = (emptySS, emptySS, emptySS)
+  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
+
+  -- precomputed size should be equal to final size
+  ASSERT(n_insns == sizeSS final_insns) return ()
+
+  let asm_insns = ssElts final_insns
+      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
+      bitmap_arr = mkBitmapArray bsize bitmap
+      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
+
+  -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
+  -- objects, since they might get run too early.  Disable this until
+  -- we figure out what to do.
+  -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
+
+  return ul_bco
+
+mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
+-- Here the return type must be an array of Words, not StgWords,
+-- because the underlying ByteArray# will end up as a component
+-- of a BCO object.
+mkBitmapArray bsize bitmap
+  = Array.listArray (0, length bitmap) $
+      fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
+
+-- instrs nonptrs ptrs
+type AsmState = (SizedSeq Word16,
+                 SizedSeq BCONPtr,
+                 SizedSeq BCOPtr)
+
+data Operand
+  = Op Word
+  | SmallOp Word16
+  | LabelOp Word16
+-- (unused)  | LargeOp Word
+
+data Assembler a
+  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
+  | AllocLit [BCONPtr] (Word -> Assembler a)
+  | AllocLabel Word16 (Assembler a)
+  | Emit Word16 [Operand] (Assembler a)
+  | NullAsm a
+
+instance Functor Assembler where
+    fmap = liftM
+
+instance Applicative Assembler where
+    pure = NullAsm
+    (<*>) = ap
+
+instance Monad Assembler where
+  NullAsm x >>= f = f x
+  AllocPtr p k >>= f = AllocPtr p (k >=> f)
+  AllocLit l k >>= f = AllocLit l (k >=> f)
+  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)
+  Emit w ops k >>= f = Emit w ops (k >>= f)
+
+ioptr :: IO BCOPtr -> Assembler Word
+ioptr p = AllocPtr p return
+
+ptr :: BCOPtr -> Assembler Word
+ptr = ioptr . return
+
+lit :: [BCONPtr] -> Assembler Word
+lit l = AllocLit l return
+
+label :: Word16 -> Assembler ()
+label w = AllocLabel w (return ())
+
+emit :: Word16 -> [Operand] -> Assembler ()
+emit w ops = Emit w ops (return ())
+
+type LabelEnv = Word16 -> Word
+
+largeOp :: Bool -> Operand -> Bool
+largeOp long_jumps op = case op of
+   SmallOp _ -> False
+   Op w      -> isLarge w
+   LabelOp _ -> long_jumps
+-- LargeOp _ -> True
+
+runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
+runAsm dflags long_jumps e = go
+  where
+    go (NullAsm x) = return x
+    go (AllocPtr p_io k) = do
+      p <- lift p_io
+      w <- state $ \(st_i0,st_l0,st_p0) ->
+        let st_p1 = addToSS st_p0 p
+        in (sizeSS st_p0, (st_i0,st_l0,st_p1))
+      go $ k w
+    go (AllocLit lits k) = do
+      w <- state $ \(st_i0,st_l0,st_p0) ->
+        let st_l1 = addListToSS st_l0 lits
+        in (sizeSS st_l0, (st_i0,st_l1,st_p0))
+      go $ k w
+    go (AllocLabel _ k) = go k
+    go (Emit w ops k) = do
+      let largeOps = any (largeOp long_jumps) ops
+          opcode
+            | largeOps = largeArgInstr w
+            | otherwise = w
+          words = concatMap expand ops
+          expand (SmallOp w) = [w]
+          expand (LabelOp w) = expand (Op (e w))
+          expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
+--        expand (LargeOp w) = largeArg dflags w
+      state $ \(st_i0,st_l0,st_p0) ->
+        let st_i1 = addListToSS st_i0 (opcode : words)
+        in ((), (st_i1,st_l0,st_p0))
+      go k
+
+type LabelEnvMap = Map Word16 Word
+
+data InspectState = InspectState
+  { instrCount :: !Word
+  , ptrCount :: !Word
+  , litCount :: !Word
+  , lblEnv :: LabelEnvMap
+  }
+
+inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
+inspectAsm dflags long_jumps initial_offset
+  = go (InspectState initial_offset 0 0 Map.empty)
+  where
+    go s (NullAsm _) = (instrCount s, lblEnv s)
+    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
+      where n = ptrCount s
+    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
+      where n = litCount s
+    go s (AllocLabel lbl k) = go s' k
+      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
+    go s (Emit _ ops k) = go s' k
+      where
+        s' = s { instrCount = instrCount s + size }
+        size = sum (map count ops) + 1
+        largeOps = any (largeOp long_jumps) ops
+        count (SmallOp _) = 1
+        count (LabelOp _) = count (Op 0)
+        count (Op _) = if largeOps then largeArg16s dflags else 1
+--      count (LargeOp _) = largeArg16s dflags
+
+-- Bring in all the bci_ bytecode constants.
+#include "rts/Bytecodes.h"
+
+largeArgInstr :: Word16 -> Word16
+largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
+
+largeArg :: DynFlags -> Word -> [Word16]
+largeArg dflags w
+ | wORD_SIZE_IN_BITS dflags == 64
+           = [fromIntegral (w `shiftR` 48),
+              fromIntegral (w `shiftR` 32),
+              fromIntegral (w `shiftR` 16),
+              fromIntegral w]
+ | wORD_SIZE_IN_BITS dflags == 32
+           = [fromIntegral (w `shiftR` 16),
+              fromIntegral w]
+ | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
+
+largeArg16s :: DynFlags -> Word
+largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
+                   | otherwise                      = 2
+
+assembleI :: DynFlags
+          -> BCInstr
+          -> Assembler ()
+assembleI dflags i = case i of
+  STKCHECK n               -> emit bci_STKCHECK [Op n]
+  PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]
+  PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
+  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
+  PUSH8 o1                 -> emit bci_PUSH8 [SmallOp o1]
+  PUSH16 o1                -> emit bci_PUSH16 [SmallOp o1]
+  PUSH32 o1                -> emit bci_PUSH32 [SmallOp o1]
+  PUSH8_W o1               -> emit bci_PUSH8_W [SmallOp o1]
+  PUSH16_W o1              -> emit bci_PUSH16_W [SmallOp o1]
+  PUSH32_W o1              -> emit bci_PUSH32_W [SmallOp o1]
+  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
+                                 emit bci_PUSH_G [Op p]
+  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
+                                 emit bci_PUSH_G [Op p]
+  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto
+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
+                                 emit bci_PUSH_G [Op p]
+  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto
+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
+                                 emit bci_PUSH_ALTS [Op p]
+  PUSH_ALTS_UNLIFTED proto pk
+                           -> do let ul_bco = assembleBCO dflags proto
+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
+                                 emit (push_alts pk) [Op p]
+  PUSH_PAD8                -> emit bci_PUSH_PAD8 []
+  PUSH_PAD16               -> emit bci_PUSH_PAD16 []
+  PUSH_PAD32               -> emit bci_PUSH_PAD32 []
+  PUSH_UBX8 lit            -> do np <- literal lit
+                                 emit bci_PUSH_UBX8 [Op np]
+  PUSH_UBX16 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX16 [Op np]
+  PUSH_UBX32 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX32 [Op np]
+  PUSH_UBX lit nws         -> do np <- literal lit
+                                 emit bci_PUSH_UBX [Op np, SmallOp nws]
+
+  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []
+  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []
+  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []
+  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []
+  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []
+  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []
+  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []
+  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []
+  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []
+  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []
+  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []
+
+  SLIDE     n by           -> emit bci_SLIDE [SmallOp n, SmallOp by]
+  ALLOC_AP  n              -> emit bci_ALLOC_AP [SmallOp n]
+  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [SmallOp n]
+  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
+  MKAP      off sz         -> emit bci_MKAP [SmallOp off, SmallOp sz]
+  MKPAP     off sz         -> emit bci_MKPAP [SmallOp off, SmallOp sz]
+  UNPACK    n              -> emit bci_UNPACK [SmallOp n]
+  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]
+                                 emit bci_PACK [Op itbl_no, SmallOp sz]
+  LABEL     lbl            -> label lbl
+  TESTLT_I  i l            -> do np <- int i
+                                 emit bci_TESTLT_I [Op np, LabelOp l]
+  TESTEQ_I  i l            -> do np <- int i
+                                 emit bci_TESTEQ_I [Op np, LabelOp l]
+  TESTLT_W  w l            -> do np <- word w
+                                 emit bci_TESTLT_W [Op np, LabelOp l]
+  TESTEQ_W  w l            -> do np <- word w
+                                 emit bci_TESTEQ_W [Op np, LabelOp l]
+  TESTLT_F  f l            -> do np <- float f
+                                 emit bci_TESTLT_F [Op np, LabelOp l]
+  TESTEQ_F  f l            -> do np <- float f
+                                 emit bci_TESTEQ_F [Op np, LabelOp l]
+  TESTLT_D  d l            -> do np <- double d
+                                 emit bci_TESTLT_D [Op np, LabelOp l]
+  TESTEQ_D  d l            -> do np <- double d
+                                 emit bci_TESTEQ_D [Op np, LabelOp l]
+  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]
+  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]
+  CASEFAIL                 -> emit bci_CASEFAIL []
+  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
+  JMP       l              -> emit bci_JMP [LabelOp l]
+  ENTER                    -> emit bci_ENTER []
+  RETURN                   -> emit bci_RETURN []
+  RETURN_UBX rep           -> emit (return_ubx rep) []
+  CCALL off m_addr i       -> do np <- addr m_addr
+                                 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
+  BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray
+                                 q <- int (getKey uniq)
+                                 np <- addr cc
+                                 emit bci_BRK_FUN [Op p1, SmallOp index,
+                                                   Op q, Op np]
+
+  where
+    literal (LitLabel fs (Just sz) _)
+     | platformOS (targetPlatform dflags) == OSMinGW32
+         = litlabel (appendFS fs (mkFastString ('@':show sz)))
+     -- On Windows, stdcall labels have a suffix indicating the no. of
+     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
+    literal (LitLabel fs _ _) = litlabel fs
+    literal LitNullAddr       = int 0
+    literal (LitFloat r)      = float (fromRational r)
+    literal (LitDouble r)     = double (fromRational r)
+    literal (LitChar c)       = int (ord c)
+    literal (LitString bs)    = lit [BCONPtrStr bs]
+       -- LitString requires a zero-terminator when emitted
+    literal (LitNumber nt i _) = case nt of
+      LitNumInt     -> int (fromIntegral i)
+      LitNumWord    -> int (fromIntegral i)
+      LitNumInt64   -> int64 (fromIntegral i)
+      LitNumWord64  -> int64 (fromIntegral i)
+      LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
+      LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
+    -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
+    -- likely to elicit a crash (rather than corrupt memory) in case absence
+    -- analysis messed up.
+    literal LitRubbish         = int 0
+
+    litlabel fs = lit [BCONPtrLbl fs]
+    addr (RemotePtr a) = words [fromIntegral a]
+    float = words . mkLitF
+    double = words . mkLitD dflags
+    int = words . mkLitI
+    int64 = words . mkLitI64 dflags
+    words ws = lit (map BCONPtrWord ws)
+    word w = words [w]
+
+isLarge :: Word -> Bool
+isLarge n = n > 65535
+
+push_alts :: ArgRep -> Word16
+push_alts V   = bci_PUSH_ALTS_V
+push_alts P   = bci_PUSH_ALTS_P
+push_alts N   = bci_PUSH_ALTS_N
+push_alts L   = bci_PUSH_ALTS_L
+push_alts F   = bci_PUSH_ALTS_F
+push_alts D   = bci_PUSH_ALTS_D
+push_alts V16 = error "push_alts: vector"
+push_alts V32 = error "push_alts: vector"
+push_alts V64 = error "push_alts: vector"
+
+return_ubx :: ArgRep -> Word16
+return_ubx V   = bci_RETURN_V
+return_ubx P   = bci_RETURN_P
+return_ubx N   = bci_RETURN_N
+return_ubx L   = bci_RETURN_L
+return_ubx F   = bci_RETURN_F
+return_ubx D   = bci_RETURN_D
+return_ubx V16 = error "return_ubx: vector"
+return_ubx V32 = error "return_ubx: vector"
+return_ubx V64 = error "return_ubx: vector"
+
+-- Make lists of host-sized words for literals, so that when the
+-- words are placed in memory at increasing addresses, the
+-- bit pattern is correct for the host's word size and endianness.
+mkLitI   ::             Int    -> [Word]
+mkLitF   ::             Float  -> [Word]
+mkLitD   :: DynFlags -> Double -> [Word]
+mkLitI64 :: DynFlags -> Int64  -> [Word]
+
+mkLitF f
+   = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 f
+        f_arr <- castSTUArray arr
+        w0 <- readArray f_arr 0
+        return [w0 :: Word]
+     )
+
+mkLitD dflags d
+   | wORD_SIZE dflags == 4
+   = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 d
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        w1 <- readArray d_arr 1
+        return [w0 :: Word, w1]
+     )
+   | wORD_SIZE dflags == 8
+   = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 d
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        return [w0 :: Word]
+     )
+   | otherwise
+   = panic "mkLitD: Bad wORD_SIZE"
+
+mkLitI64 dflags ii
+   | wORD_SIZE dflags == 4
+   = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 ii
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        w1 <- readArray d_arr 1
+        return [w0 :: Word,w1]
+     )
+   | wORD_SIZE dflags == 8
+   = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 ii
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        return [w0 :: Word]
+     )
+   | otherwise
+   = panic "mkLitI64: Bad wORD_SIZE"
+
+mkLitI i = [fromIntegral i :: Word]
+
+iNTERP_STACK_CHECK_THRESH :: Int
+iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -0,0 +1,1960 @@
+{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fprof-auto-top #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeGen: Generate bytecode from Core
+module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import ByteCodeInstr
+import ByteCodeAsm
+import ByteCodeTypes
+
+import GHCi
+import GHCi.FFI
+import GHCi.RemoteTypes
+import BasicTypes
+import DynFlags
+import Outputable
+import Platform
+import Name
+import MkId
+import Id
+import ForeignCall
+import HscTypes
+import CoreUtils
+import CoreSyn
+import PprCore
+import Literal
+import PrimOp
+import CoreFVs
+import Type
+import RepType
+import Kind            ( isLiftedTypeKind )
+import DataCon
+import TyCon
+import Util
+import VarSet
+import TysPrim
+import ErrUtils
+import Unique
+import FastString
+import Panic
+import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )
+import StgCmmLayout
+import SMRep hiding (WordOff, ByteOff, wordsToBytes)
+import Bitmap
+import OrdList
+import Maybes
+import VarEnv
+
+import Data.List
+import Foreign
+import Control.Monad
+import Data.Char
+
+import UniqSupply
+import Module
+import Control.Arrow ( second )
+
+import Control.Exception
+import Data.Array
+import Data.ByteString (ByteString)
+import Data.Map (Map)
+import Data.IntMap (IntMap)
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified FiniteMap as Map
+import Data.Ord
+import GHC.Stack.CCS
+import Data.Either ( partitionEithers )
+
+-- -----------------------------------------------------------------------------
+-- Generating byte code for a complete module
+
+byteCodeGen :: HscEnv
+            -> Module
+            -> CoreProgram
+            -> [TyCon]
+            -> Maybe ModBreaks
+            -> IO CompiledByteCode
+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
+   = withTiming (pure dflags)
+                (text "ByteCodeGen"<+>brackets (ppr this_mod))
+                (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
+                (bndr, rhs) <- flattenBinds binds
+                return $ case exprIsTickedString_maybe rhs of
+                    Just str -> Left (bndr, str)
+                    _ -> Right (bndr, simpleFreeVars rhs)
+        stringPtrs <- allocateTopStrings hsc_env strings
+
+        us <- mkSplitUniqSupply 'y'
+        (BcM_State{..}, proto_bcos) <-
+           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
+             mapM schemeTopBind flatBinds
+
+        when (notNull ffis)
+             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
+
+        dumpIfSet_dyn dflags Opt_D_dump_BCOs
+           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+
+        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
+          (case modBreaks of
+             Nothing -> Nothing
+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
+
+        -- Squash space leaks in the CompiledByteCode.  This is really
+        -- important, because when loading a set of modules into GHCi
+        -- we don't touch the CompiledByteCode until the end when we
+        -- do linking.  Forcing out the thunks here reduces space
+        -- usage by more than 50% when loading a large number of
+        -- modules.
+        evaluate (seqCompiledByteCode cbc)
+
+        return cbc
+
+  where dflags = hsc_dflags hsc_env
+
+allocateTopStrings
+  :: HscEnv
+  -> [(Id, ByteString)]
+  -> IO [(Var, RemotePtr ())]
+allocateTopStrings hsc_env topStrings = do
+  let !(bndrs, strings) = unzip topStrings
+  ptrs <- iservCmd hsc_env $ MallocStrings strings
+  return $ zip bndrs ptrs
+
+{-
+Note [generating code for top-level string literal bindings]
+
+Here is a summary on how the byte code generator deals with top-level string
+literals:
+
+1. Top-level string literal bindings are separated from the rest of the module.
+
+2. The strings are allocated via iservCmd, in allocateTopStrings
+
+3. The mapping from binders to allocated strings (topStrings) are maintained in
+   BcM and used when generating code for variable references.
+-}
+
+-- -----------------------------------------------------------------------------
+-- Generating byte code for an expression
+
+-- Returns: the root BCO for this expression
+coreExprToBCOs :: HscEnv
+               -> Module
+               -> CoreExpr
+               -> IO UnlinkedBCO
+coreExprToBCOs hsc_env this_mod expr
+ = withTiming (pure dflags)
+              (text "ByteCodeGen"<+>brackets (ppr this_mod))
+              (const ()) $ do
+      -- create a totally bogus name for the top-level BCO; this
+      -- should be harmless, since it's never used for anything
+      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
+          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
+
+      -- the uniques are needed to generate fresh variables when we introduce new
+      -- let bindings for ticked expressions
+      us <- mkSplitUniqSupply 'y'
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
+         <- runBc hsc_env us this_mod Nothing emptyVarEnv $
+              schemeTopBind (invented_id, simpleFreeVars expr)
+
+      when (notNull mallocd)
+           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
+
+      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
+
+      assembleOneBCO hsc_env proto_bco
+  where dflags = hsc_dflags hsc_env
+
+-- The regular freeVars function gives more information than is useful to
+-- us here. simpleFreeVars does the impedance matching.
+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)
+
+-- -----------------------------------------------------------------------------
+-- Compilation schema for the bytecode generator
+
+type BCInstrList = OrdList BCInstr
+
+newtype ByteOff = ByteOff Int
+    deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+newtype WordOff = WordOff Int
+    deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+wordsToBytes :: DynFlags -> WordOff -> ByteOff
+wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
+
+-- Used when we know we have a whole number of words
+bytesToWords :: DynFlags -> ByteOff -> WordOff
+bytesToWords dflags (ByteOff bytes) =
+    let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
+    in if r == 0
+           then fromIntegral q
+           else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes
+
+wordSize :: DynFlags -> ByteOff
+wordSize dflags = ByteOff (wORD_SIZE dflags)
+
+type Sequel = ByteOff -- back off to this depth before ENTER
+
+type StackDepth = ByteOff
+
+-- | Maps Ids to their stack depth. This allows us to avoid having to mess with
+-- it after each push/pop.
+type BCEnv = Map Id StackDepth -- To find vars on the stack
+
+{-
+ppBCEnv :: BCEnv -> SDoc
+ppBCEnv p
+   = text "begin-env"
+     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
+     $$ text "end-env"
+     where
+        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
+        cmp_snd x y = compare (snd x) (snd y)
+-}
+
+-- Create a BCO and do a spot of peephole optimisation on the insns
+-- at the same time.
+mkProtoBCO
+   :: DynFlags
+   -> name
+   -> BCInstrList
+   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
+   -> Int
+   -> Word16
+   -> [StgWord]
+   -> Bool      -- True <=> is a return point, rather than a function
+   -> [FFIInfo]
+   -> ProtoBCO name
+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
+   = ProtoBCO {
+        protoBCOName = nm,
+        protoBCOInstrs = maybe_with_stack_check,
+        protoBCOBitmap = bitmap,
+        protoBCOBitmapSize = bitmap_size,
+        protoBCOArity = arity,
+        protoBCOExpr = origin,
+        protoBCOFFIs = ffis
+      }
+     where
+        -- Overestimate the stack usage (in words) of this BCO,
+        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
+        -- stack check.  (The interpreter always does a stack check
+        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
+        -- BCO anyway, so we only need to add an explicit one in the
+        -- (hopefully rare) cases when the (overestimated) stack use
+        -- exceeds iNTERP_STACK_CHECK_THRESH.
+        maybe_with_stack_check
+           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
+                -- don't do stack checks at return points,
+                -- everything is aggregated up to the top BCO
+                -- (which must be a function).
+                -- That is, unless the stack usage is >= AP_STACK_SPLIM,
+                -- see bug #1466.
+           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
+           = STKCHECK stack_usage : peep_d
+           | otherwise
+           = peep_d     -- the supposedly common case
+
+        -- We assume that this sum doesn't wrap
+        stack_usage = sum (map bciStackUse peep_d)
+
+        -- Merge local pushes
+        peep_d = peep (fromOL instrs_ordlist)
+
+        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
+           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
+        peep (PUSH_L off1 : PUSH_L off2 : rest)
+           = PUSH_LL off1 (off2-1) : peep rest
+        peep (i:rest)
+           = i : peep rest
+        peep []
+           = []
+
+argBits :: DynFlags -> [ArgRep] -> [Bool]
+argBits _      [] = []
+argBits dflags (rep : args)
+  | isFollowableArg rep  = False : argBits dflags args
+  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
+
+-- -----------------------------------------------------------------------------
+-- schemeTopBind
+
+-- Compile code for the right-hand side of a top-level binding
+
+schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
+schemeTopBind (id, rhs)
+  | Just data_con <- isDataConWorkId_maybe id,
+    isNullaryRepDataCon data_con = do
+    dflags <- getDynFlags
+        -- Special case for the worker of a nullary data con.
+        -- It'll look like this:        Nil = /\a -> Nil a
+        -- If we feed it into schemeR, we'll get
+        --      Nil = Nil
+        -- because mkConAppCode treats nullary constructor applications
+        -- by just re-using the single top-level definition.  So
+        -- for the worker itself, we must allocate it directly.
+    -- ioToBc (putStrLn $ "top level BCO")
+    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+
+  | otherwise
+  = schemeR [{- No free variables -}] (id, rhs)
+
+
+-- -----------------------------------------------------------------------------
+-- schemeR
+
+-- Compile code for a right-hand side, to give a BCO that,
+-- when executed with the free variables and arguments on top of the stack,
+-- will return with a pointer to the result on top of the stack, after
+-- removing the free variables and arguments.
+--
+-- Park the resulting BCO in the monad.  Also requires the
+-- variable to which this value was bound, so as to give the
+-- resulting BCO a name.
+
+schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
+                                -- will appear in the thunk.  Empty for
+                                -- top-level things, which have no free vars.
+        -> (Id, AnnExpr Id DVarSet)
+        -> BcM (ProtoBCO Name)
+schemeR fvs (nm, rhs)
+{-
+   | trace (showSDoc (
+              (char ' '
+               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
+               $$ pprCoreExpr (deAnnotate rhs)
+               $$ char ' '
+              ))) False
+   = undefined
+   | otherwise
+-}
+   = schemeR_wrk fvs nm rhs (collect rhs)
+
+collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
+collect (_, e) = go [] e
+  where
+    go xs e | Just e' <- bcView e = go xs e'
+    go xs (AnnLam x (_,e))
+      | typePrimRep (idType x) `lengthExceeds` 1
+      = multiValException
+      | otherwise
+      = go (x:xs) e
+    go xs not_lambda = (reverse xs, not_lambda)
+
+schemeR_wrk
+    :: [Id]
+    -> Id
+    -> AnnExpr Id DVarSet
+    -> ([Var], AnnExpr' Var DVarSet)
+    -> BcM (ProtoBCO Name)
+schemeR_wrk fvs nm original_body (args, body)
+   = do
+     dflags <- getDynFlags
+     let
+         all_args  = reverse args ++ fvs
+         arity     = length all_args
+         -- all_args are the args in reverse order.  We're compiling a function
+         -- \fv1..fvn x1..xn -> e
+         -- i.e. the fvs come first
+
+         -- Stack arguments always take a whole number of words, we never pack
+         -- them unlike constructor fields.
+         szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args
+         sum_szsb_args  = sum szsb_args
+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
+
+         -- make the arg bitmap
+         bits = argBits dflags (reverse (map bcIdArgRep all_args))
+         bitmap_size = genericLength bits
+         bitmap = mkBitmap dflags bits
+     body_code <- schemeER_wrk sum_szsb_args p_init body
+
+     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
+                 arity bitmap_size bitmap False{-not alts-})
+
+-- introduce break instructions for ticked expressions
+schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+schemeER_wrk d p rhs
+  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
+  = do  code <- schemeE d 0 p newRhs
+        cc_arr <- getCCArray
+        this_mod <- moduleName <$> getCurrentModule
+        dflags <- getDynFlags
+        let idOffSets = getVarOffSets dflags d p fvs
+        let breakInfo = CgBreakInfo
+                        { cgb_vars = idOffSets
+                        , cgb_resty = exprType (deAnnotate' newRhs)
+                        }
+        newBreakInfo tick_no breakInfo
+        dflags <- getDynFlags
+        let cc | interpreterProfiled dflags = cc_arr ! tick_no
+               | otherwise = toRemotePtr nullPtr
+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
+        return $ breakInstr `consOL` code
+   | otherwise = schemeE d 0 p rhs
+
+getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
+getVarOffSets dflags depth env = catMaybes . map getOffSet
+  where
+    getOffSet id = case lookupBCEnv_maybe id env of
+        Nothing     -> Nothing
+        Just offset ->
+            -- michalt: I'm not entirely sure why we need the stack
+            -- adjustment by 2 here. I initially thought that there's
+            -- something off with getIdValFromApStack (the only user of this
+            -- value), but it looks ok to me. My current hypothesis is that
+            -- this "adjustment" is needed due to stack manipulation for
+            -- BRK_FUN in Interpreter.c In any case, this is used only when
+            -- we trigger a breakpoint.
+            let !var_depth_ws =
+                    trunc16W $ bytesToWords dflags (depth - offset) + 2
+            in Just (id, var_depth_ws)
+
+truncIntegral16 :: Integral a => a -> Word16
+truncIntegral16 w
+    | w > fromIntegral (maxBound :: Word16)
+    = panic "stack depth overflow"
+    | otherwise
+    = fromIntegral w
+
+trunc16B :: ByteOff -> Word16
+trunc16B = truncIntegral16
+
+trunc16W :: WordOff -> Word16
+trunc16W = truncIntegral16
+
+fvsToEnv :: BCEnv -> DVarSet -> [Id]
+-- Takes the free variables of a right-hand side, and
+-- delivers an ordered list of the local variables that will
+-- be captured in the thunk for the RHS
+-- The BCEnv argument tells which variables are in the local
+-- environment: these are the ones that should be captured
+--
+-- The code that constructs the thunk, and the code that executes
+-- it, have to agree about this layout
+fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
+                      isId v,           -- Could be a type variable
+                      v `Map.member` p]
+
+-- -----------------------------------------------------------------------------
+-- schemeE
+
+returnUnboxedAtom
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr' Id DVarSet
+    -> ArgRep
+    -> BcM BCInstrList
+-- Returning an unlifted value.
+-- Heave it on the stack, SLIDE, and RETURN.
+returnUnboxedAtom d s p e e_rep = do
+    dflags <- getDynFlags
+    (push, szb) <- pushAtom d p e
+    return (push                                 -- value onto stack
+           `appOL`  mkSlideB dflags szb (d - s)  -- clear to sequel
+           `snocOL` RETURN_UBX e_rep)            -- go
+
+-- Compile code to apply the given expression to the remaining args
+-- on the stack, returning a HNF.
+schemeE
+    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+schemeE d s p e
+   | Just e' <- bcView e
+   = schemeE d s p e'
+
+-- Delegate tail-calls to schemeT.
+schemeE d s p e@(AnnApp _ _) = schemeT d s p e
+
+schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
+schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
+
+schemeE d s p e@(AnnVar v)
+    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
+    | otherwise                 = schemeT d s p e
+
+schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
+   | (AnnVar v, args_r_to_l) <- splitApp rhs,
+     Just data_con <- isDataConWorkId_maybe v,
+     dataConRepArity data_con == length args_r_to_l
+   = do -- Special case for a non-recursive let whose RHS is a
+        -- saturated constructor application.
+        -- Just allocate the constructor and carry on
+        alloc_code <- mkConAppCode d s p data_con args_r_to_l
+        dflags <- getDynFlags
+        let !d2 = d + wordSize dflags
+        body_code <- schemeE d2 s (Map.insert x d2 p) body
+        return (alloc_code `appOL` body_code)
+
+-- General case for let.  Generates correct, if inefficient, code in
+-- all situations.
+schemeE d s p (AnnLet binds (_,body)) = do
+     dflags <- getDynFlags
+     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
+                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
+         n_binds = genericLength xs
+
+         fvss  = map (fvsToEnv p' . fst) 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
+
+         -- 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
+         d' = d + wordsToBytes dflags n_binds
+         zipE = zipEqual "schemeE"
+
+         -- ToDo: don't build thunks for things with no free variables
+         build_thunk
+             :: StackDepth
+             -> [Id]
+             -> Word16
+             -> ProtoBCO Name
+             -> Word16
+             -> Word16
+             -> BcM BCInstrList
+         build_thunk _ [] size bco off arity
+            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
+           where
+                mkap | arity == 0 = MKAP
+                     | otherwise  = MKPAP
+         build_thunk dd (fv:fvs) size bco off arity = do
+              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
+              more_push_code <-
+                  build_thunk (dd + pushed_szb) fvs size bco off arity
+              return (push_code `appOL` more_push_code)
+
+         alloc_code = toOL (zipWith mkAlloc sizes arities)
+           where mkAlloc sz 0
+                    | is_tick     = ALLOC_AP_NOUPD sz
+                    | otherwise   = ALLOC_AP sz
+                 mkAlloc sz arity = ALLOC_PAP arity sz
+
+         is_tick = case binds of
+                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
+                     _other -> False
+
+         compile_bind d' fvs x rhs size arity off = do
+                bco <- schemeR fvs (x,rhs)
+                build_thunk d' fvs size bco off arity
+
+         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]
+            ]
+     body_code <- schemeE d' s p' body
+     thunk_codes <- sequence compile_binds
+     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
+
+-- Introduce a let binding for a ticked case expression. This rule
+-- *should* only fire when the expression was not already let-bound
+-- (the code gen for let bindings should take care of that).  Todo: we
+-- call exprFreeVars on a deAnnotated expression, this may not be the
+-- best way to calculate the free vars but it seemed like the least
+-- intrusive thing to do
+schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
+   | isLiftedTypeKind (typeKind ty)
+   = do   id <- newId ty
+          -- Todo: is emptyVarSet correct on the next line?
+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
+          schemeE d s p letExp
+
+   | otherwise
+   = do   -- If the result type is not definitely lifted, then we must generate
+          --   let f = \s . tick<n> e
+          --   in  f realWorld#
+          -- When we stop at the breakpoint, _result will have an unlifted
+          -- type and hence won't be bound in the environment, but the
+          -- breakpoint will otherwise work fine.
+          --
+          -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where
+          --    r :: RuntimeRep is a variable. This can happen in the
+          --    continuations for a pattern-synonym matcher
+          --    match = /\(r::RuntimeRep) /\(a::TYPE r).
+          --            \(k :: Int -> a) \(v::T).
+          --            case v of MkV n -> k n
+          -- Here (k n) :: a :: Type r, so we don't know if it's lifted
+          -- or not; but that should be fine provided we add that void arg.
+
+          id <- newId (mkVisFunTy realWorldStatePrimTy ty)
+          st <- newId realWorldStatePrimTy
+          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
+                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
+                                                    (emptyDVarSet, AnnVar realWorldPrimId)))
+          schemeE d s p letExp
+
+   where
+     exp' = deAnnotate' exp
+     fvs  = exprFreeVarsDSet exp'
+     ty   = exprType exp'
+
+-- ignore other kinds of tick
+schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
+
+schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
+        -- no alts: scrut is guaranteed to diverge
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
+   | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
+        -- Convert
+        --      case .... of x { (# V'd-thing, a #) -> ... }
+        -- to
+        --      case .... of a { DEFAULT -> ... }
+        -- because the return convention for both are identical.
+        --
+        -- Note that it does not matter losing the void-rep thing from the
+        -- envt (it won't be bound now) because we never look such things up.
+   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
+                   ([], [_])
+                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
+                   ([_], [])
+                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+                   _ -> Nothing
+   = res
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
+   | isUnboxedTupleCon dc
+   , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
+   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
+   | isUnboxedTupleType (idType bndr)
+   , Just ty <- case typePrimRep (idType bndr) of
+       [_]  -> Just (unwrapType (idType bndr))
+       []   -> Just voidPrimTy
+       _    -> Nothing
+       -- handles any pattern with a single non-void binder; in particular I/O
+       -- monad returns (# RealWorld#, a #)
+   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alts)
+   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
+
+schemeE _ _ _ expr
+   = pprPanic "ByteCodeGen.schemeE: unhandled case"
+               (pprCoreExpr (deAnnotate' expr))
+
+{-
+   Ticked Expressions
+   ------------------
+
+  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.
+
+-}
+
+-- Compile code to do a tail call.  Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter.  Four cases:
+--
+-- 0.  (Nasty hack).
+--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
+--     The int will be on the stack.  Generate a code sequence
+--     to convert it to the relevant constructor, SLIDE and ENTER.
+--
+-- 1.  The fn denotes a ccall.  Defer to generateCCall.
+--
+-- 2.  (Another nasty hack).  Spot (# a::V, b #) and treat
+--     it simply as  b  -- since the representations are identical
+--     (the V takes up zero stack space).  Also, spot
+--     (# b #) and treat it as  b.
+--
+-- 3.  Application of a constructor, by defn saturated.
+--     Split the args into ptrs and non-ptrs, and push the nonptrs,
+--     then the ptrs, and then do PACK and RETURN.
+--
+-- 4.  Otherwise, it must be a function call.  Push the args
+--     right to left, SLIDE and ENTER.
+
+schemeT :: StackDepth   -- Stack depth
+        -> Sequel       -- Sequel depth
+        -> BCEnv        -- stack env
+        -> AnnExpr' Id DVarSet
+        -> BcM BCInstrList
+
+schemeT d s p app
+
+   -- Case 0
+   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
+   = implement_tagToId d s p arg constr_names
+
+   -- Case 1
+   | Just (CCall ccall_spec) <- isFCallId_maybe fn
+   = if isSupportedCConv ccall_spec
+      then generateCCall d s p ccall_spec fn args_r_to_l
+      else unsupportedCConvException
+
+
+   -- Case 2: Constructor application
+   | Just con <- maybe_saturated_dcon
+   , isUnboxedTupleCon con
+   = case args_r_to_l of
+        [arg1,arg2] | isVAtom arg1 ->
+                  unboxedTupleReturn d s p arg2
+        [arg1,arg2] | isVAtom arg2 ->
+                  unboxedTupleReturn d s p arg1
+        _other -> multiValException
+
+   -- Case 3: Ordinary data constructor
+   | Just con <- maybe_saturated_dcon
+   = do alloc_con <- mkConAppCode d s p con args_r_to_l
+        dflags <- getDynFlags
+        return (alloc_con         `appOL`
+                mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
+                ENTER)
+
+   -- Case 4: Tail call of function
+   | otherwise
+   = doTailCall d s p fn args_r_to_l
+
+   where
+        -- Extract the args (R->L) and fn
+        -- The function will necessarily be a variable,
+        -- because we are compiling a tail call
+      (AnnVar fn, args_r_to_l) = splitApp app
+
+      -- Only consider this to be a constructor application iff it is
+      -- saturated.  Otherwise, we'll call the constructor wrapper.
+      n_args = length args_r_to_l
+      maybe_saturated_dcon
+        = case isDataConWorkId_maybe fn of
+                Just con | dataConRepArity con == n_args -> Just con
+                _ -> Nothing
+
+-- -----------------------------------------------------------------------------
+-- Generate code to build a constructor application,
+-- leaving it on top of the stack
+
+mkConAppCode
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> DataCon                  -- The data constructor
+    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
+    -> BcM BCInstrList
+mkConAppCode _ _ _ con []       -- Nullary constructor
+  = ASSERT( isNullaryRepDataCon con )
+    return (unitOL (PUSH_G (getName (dataConWorkId con))))
+        -- Instead of doing a PACK, which would allocate a fresh
+        -- copy of this constructor, use the single shared version.
+
+mkConAppCode orig_d _ p con args_r_to_l =
+    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
+  where
+    app_code = do
+        dflags <- getDynFlags
+
+        -- The args are initially in reverse order, but mkVirtHeapOffsets
+        -- expects them to be left-to-right.
+        let non_voids =
+                [ NonVoid (prim_rep, arg)
+                | arg <- reverse args_r_to_l
+                , let prim_rep = atomPrimRep arg
+                , not (isVoidRep prim_rep)
+                ]
+            (_, _, args_offsets) =
+                mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
+
+            do_pushery !d (arg : args) = do
+                (push, arg_bytes) <- case arg of
+                    (Padding l _) -> return $! pushPadding l
+                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
+                more_push_code <- do_pushery (d + arg_bytes) args
+                return (push `appOL` more_push_code)
+            do_pushery !d [] = do
+                let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d)
+                return (unitOL (PACK con n_arg_words))
+
+        -- Push on the stack in the reverse order.
+        do_pushery orig_d (reverse args_offsets)
+
+
+-- -----------------------------------------------------------------------------
+-- Returning an unboxed tuple with one non-void component (the only
+-- case we can handle).
+--
+-- Remember, we don't want to *evaluate* the component that is being
+-- returned, even if it is a pointed type.  We always just return.
+
+unboxedTupleReturn
+    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
+
+-- -----------------------------------------------------------------------------
+-- Generate code for a tail-call
+
+doTailCall
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> Id
+    -> [AnnExpr' Id DVarSet]
+    -> BcM BCInstrList
+doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
+  where
+  do_pushes !d [] reps = do
+        ASSERT( null reps ) return ()
+        (push_fn, sz) <- pushAtom d p (AnnVar fn)
+        dflags <- getDynFlags
+        ASSERT( sz == wordSize dflags ) return ()
+        let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)
+        return (push_fn `appOL` (slide `appOL` unitOL ENTER))
+  do_pushes !d args reps = do
+      let (push_apply, n, rest_of_reps) = findPushSeq reps
+          (these_args, rest_of_args) = splitAt n args
+      (next_d, push_code) <- push_seq d these_args
+      dflags <- getDynFlags
+      instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps
+      --                          ^^^ for the PUSH_APPLY_ instruction
+      return (push_code `appOL` (push_apply `consOL` instrs))
+
+  push_seq d [] = return (d, nilOL)
+  push_seq d (arg:args) = do
+    (push_code, sz) <- pushAtom d p arg
+    (final_d, more_push_code) <- push_seq (d + sz) args
+    return (final_d, push_code `appOL` more_push_code)
+
+-- v. similar to CgStackery.findMatch, ToDo: merge
+findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
+findPushSeq (P: P: P: P: P: P: rest)
+  = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (P: P: P: P: P: rest)
+  = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (P: P: P: P: rest)
+  = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (P: P: P: rest)
+  = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (P: P: rest)
+  = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (P: rest)
+  = (PUSH_APPLY_P, 1, rest)
+findPushSeq (V: rest)
+  = (PUSH_APPLY_V, 1, rest)
+findPushSeq (N: rest)
+  = (PUSH_APPLY_N, 1, rest)
+findPushSeq (F: rest)
+  = (PUSH_APPLY_F, 1, rest)
+findPushSeq (D: rest)
+  = (PUSH_APPLY_D, 1, rest)
+findPushSeq (L: rest)
+  = (PUSH_APPLY_L, 1, rest)
+findPushSeq _
+  = panic "ByteCodeGen.findPushSeq"
+
+-- -----------------------------------------------------------------------------
+-- Case expressions
+
+doCase
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr Id DVarSet
+    -> Id
+    -> [AnnAlt Id DVarSet]
+    -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder,
+                 -- don't enter the result
+    -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+  | typePrimRep (idType bndr) `lengthExceeds` 1
+  = multiValException
+  | otherwise
+  = do
+     dflags <- getDynFlags
+     let
+        profiling
+          | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+          | otherwise = rtsIsProfiled
+
+        -- Top of stack is the return itbl, as usual.
+        -- underneath it is the pointer to the alt_code BCO.
+        -- When an alt is entered, it assumes the returned value is
+        -- on top of the itbl.
+        ret_frame_size_b :: StackDepth
+        ret_frame_size_b = 2 * wordSize dflags
+
+        -- The extra frame we push to save/restor the CCCS when profiling
+        save_ccs_size_b | profiling = 2 * wordSize dflags
+                        | otherwise = 0
+
+        -- An unlifted value gets an extra info table pushed on top
+        -- when it is returned.
+        unlifted_itbl_size_b :: StackDepth
+        unlifted_itbl_size_b | isAlgCase = 0
+                            | otherwise = wordSize dflags
+
+        -- depth of stack after the return value has been pushed
+        d_bndr =
+            d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
+
+        -- depth of stack after the extra info table for an unboxed return
+        -- has been pushed, if any.  This is the stack depth at the
+        -- continuation.
+        d_alts = d_bndr + unlifted_itbl_size_b
+
+        -- Env in which to compile the alts, not including
+        -- any vars bound by the alts themselves
+        p_alts0 = Map.insert bndr d_bndr p
+
+        p_alts = case is_unboxed_tuple of
+                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
+                   Nothing       -> p_alts0
+
+        bndr_ty = idType bndr
+        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
+
+        -- given an alt, return a discr and code for it.
+        codeAlt (DEFAULT, _, (_,rhs))
+           = do rhs_code <- schemeE d_alts s p_alts rhs
+                return (NoDiscr, rhs_code)
+
+        codeAlt alt@(_, bndrs, (_,rhs))
+           -- primitive or nullary constructor alt: no need to UNPACK
+           | null real_bndrs = do
+                rhs_code <- schemeE d_alts s p_alts rhs
+                return (my_discr alt, rhs_code)
+           -- If an alt attempts to match on an unboxed tuple or sum, we must
+           -- bail out, as the bytecode compiler can't handle them.
+           -- (See #14608.)
+           | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
+           = multiValException
+           -- algebraic alt with some binders
+           | otherwise =
+             let (tot_wds, _ptrs_wds, args_offsets) =
+                     mkVirtHeapOffsets dflags NoHeader
+                         [ NonVoid (bcIdPrimRep id, id)
+                         | NonVoid id <- nonVoidIds real_bndrs
+                         ]
+                 size = WordOff tot_wds
+
+                 stack_bot = d_alts + wordsToBytes dflags size
+
+                 -- convert offsets from Sp into offsets into the virtual stack
+                 p' = Map.insertList
+                        [ (arg, stack_bot - ByteOff offset)
+                        | (NonVoid arg, offset) <- args_offsets ]
+                        p_alts
+             in do
+             MASSERT(isAlgCase)
+             rhs_code <- schemeE stack_bot s p' rhs
+             return (my_discr alt,
+                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)
+           where
+             real_bndrs = filterOut isTyVar bndrs
+
+        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
+        my_discr (DataAlt dc, _, _)
+           | isUnboxedTupleCon dc || isUnboxedSumCon dc
+           = multiValException
+           | otherwise
+           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
+        my_discr (LitAlt l, _, _)
+           = case l of LitNumber LitNumInt i  _  -> DiscrI (fromInteger i)
+                       LitNumber LitNumWord w _  -> DiscrW (fromInteger w)
+                       LitFloat r   -> DiscrF (fromRational r)
+                       LitDouble r  -> DiscrD (fromRational r)
+                       LitChar i    -> DiscrI (ord i)
+                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+
+        maybe_ncons
+           | not isAlgCase = Nothing
+           | otherwise
+           = case [dc | (DataAlt dc, _, _) <- alts] of
+                []     -> Nothing
+                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
+
+        -- the bitmap is relative to stack depth d, i.e. before the
+        -- BCO, info table and return value are pushed on.
+        -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+        -- except that here we build the bitmap from the known bindings of
+        -- things that are pointers, whereas in CgBindery the code builds the
+        -- bitmap from the free slots and unboxed bindings.
+        -- (ToDo: merge?)
+        --
+        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
+        -- The bitmap must cover the portion of the stack up to the sequel only.
+        -- Previously we were building a bitmap for the whole depth (d), but we
+        -- really want a bitmap up to depth (d-s).  This affects compilation of
+        -- case-of-case expressions, which is the only time we can be compiling a
+        -- case expression with s /= 0.
+        bitmap_size = trunc16W $ bytesToWords dflags (d - s)
+        bitmap_size' :: Int
+        bitmap_size' = fromIntegral bitmap_size
+        bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
+                        (sort (filter (< bitmap_size') rel_slots))
+          where
+          binds = Map.toList p
+          -- NB: unboxed tuple cases bind the scrut binder to the same offset
+          -- as one of the alt binders, so we have to remove any duplicates here:
+          rel_slots = nub $ map fromIntegral $ concat (map spread binds)
+          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
+                              | otherwise                      = []
+                where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
+
+     alt_stuff <- mapM codeAlt alts
+     alt_final <- mkMultiBranch maybe_ncons alt_stuff
+
+     let
+         alt_bco_name = getName bndr
+         alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
+                       0{-no arity-} bitmap_size bitmap True{-is alts-}
+--     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
+--            "\n      bitmap = " ++ show bitmap) $ do
+
+     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
+                           (d + ret_frame_size_b + save_ccs_size_b)
+                           p scrut
+     alt_bco' <- emitBc alt_bco
+     let push_alts
+            | isAlgCase = PUSH_ALTS alt_bco'
+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
+     return (push_alts `consOL` scrut_code)
+
+
+-- -----------------------------------------------------------------------------
+-- Deal with a CCall.
+
+-- Taggedly push the args onto the stack R->L,
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays.  Then, generate the marshalling
+-- (machine) code for the ccall, and create bytecodes to call that and
+-- then return in the right way.
+
+generateCCall
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> CCallSpec               -- where to call
+    -> Id                      -- of target, for type info
+    -> [AnnExpr' Id DVarSet]   -- args (atoms)
+    -> BcM BCInstrList
+generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
+ = do
+     dflags <- getDynFlags
+
+     let
+         -- useful constants
+         addr_size_b :: ByteOff
+         addr_size_b = wordSize dflags
+
+         -- Get the args on the stack, with tags and suitably
+         -- dereferenced for the CCall.  For each arg, return the
+         -- depth to the first word of the bits for that arg, and the
+         -- ArgRep of what was actually pushed.
+
+         pargs
+             :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
+         pargs _ [] = return []
+         pargs d (a:az)
+            = let arg_ty = unwrapType (exprType (deAnnotate' a))
+
+              in case tyConAppTyCon_maybe arg_ty of
+                    -- Don't push the FO; instead push the Addr# it
+                    -- contains.
+                    Just t
+                     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+                       -> do rest <- pargs (d + addr_size_b) az
+                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
+                     | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
+                       -> do rest <- pargs (d + addr_size_b) az
+                             code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
+                     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+                       -> do rest <- pargs (d + addr_size_b) az
+                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
+                    -- Default case: push taggedly, but otherwise intact.
+                    _
+                       -> do (code_a, sz_a) <- pushAtom d p a
+                             rest <- pargs (d + sz_a) az
+                             return ((code_a, atomPrimRep a) : rest)
+
+         -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
+         -- the stack but then advance it over the headers, so as to
+         -- point to the payload.
+         parg_ArrayishRep
+             :: Word16
+             -> StackDepth
+             -> BCEnv
+             -> AnnExpr' Id DVarSet
+             -> BcM BCInstrList
+         parg_ArrayishRep hdrSize d p a
+            = do (push_fo, _) <- pushAtom d p a
+                 -- The ptr points at the header.  Advance it over the
+                 -- header and then pretend this is an Addr#.
+                 return (push_fo `snocOL` SWIZZLE 0 hdrSize)
+
+     code_n_reps <- pargs d0 args_r_to_l
+     let
+         (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
+         a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
+
+         push_args    = concatOL pushs_arg
+         !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
+         a_reps_pushed_RAW
+            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+            = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
+            | otherwise
+            = reverse (tail a_reps_pushed_r_to_l)
+
+         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
+         -- push_args is the code to do that.
+         -- d_after_args is the stack depth once the args are on.
+
+         -- Get the result rep.
+         (returns_void, r_rep)
+            = case maybe_getCCallReturnRep (idType fn) of
+                 Nothing -> (True,  VoidRep)
+                 Just rr -> (False, rr)
+         {-
+         Because the Haskell stack grows down, the a_reps refer to
+         lowest to highest addresses in that order.  The args for the call
+         are on the stack.  Now push an unboxed Addr# indicating
+         the C function to call.  Then push a dummy placeholder for the
+         result.  Finally, emit a CCALL insn with an offset pointing to the
+         Addr# just pushed, and a literal field holding the mallocville
+         address of the piece of marshalling code we generate.
+         So, just prior to the CCALL insn, the stack looks like this
+         (growing down, as usual):
+
+            <arg_n>
+            ...
+            <arg_1>
+            Addr# address_of_C_fn
+            <placeholder-for-result#> (must be an unboxed type)
+
+         The interpreter then calls the marshall code mentioned
+         in the CCALL insn, passing it (& <placeholder-for-result#>),
+         that is, the addr of the topmost word in the stack.
+         When this returns, the placeholder will have been
+         filled in.  The placeholder is slid down to the sequel
+         depth, and we RETURN.
+
+         This arrangement makes it simple to do f-i-dynamic since the Addr#
+         value is the first arg anyway.
+
+         The marshalling code is generated specifically for this
+         call site, and so knows exactly the (Haskell) stack
+         offsets of the args, fn address and placeholder.  It
+         copies the args to the C stack, calls the stacked addr,
+         and parks the result back in the placeholder.  The interpreter
+         calls it as a normal C call, assuming it has a signature
+            void marshall_code ( StgWord* ptr_to_top_of_stack )
+         -}
+         -- resolve static address
+         maybe_static_target :: Maybe Literal
+         maybe_static_target =
+             case target of
+                 DynamicTarget -> Nothing
+                 StaticTarget _ _ _ False ->
+                   panic "generateCCall: unexpected FFI value import"
+                 StaticTarget _ target _ True ->
+                   Just (LitLabel target mb_size IsFunction)
+                   where
+                      mb_size
+                          | OSMinGW32 <- platformOS (targetPlatform dflags)
+                          , StdCallConv <- cconv
+                          = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
+                          | otherwise
+                          = Nothing
+
+     let
+         is_static = isJust maybe_static_target
+
+         -- Get the arg reps, zapping the leading Addr# in the dynamic case
+         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+                | is_static = a_reps_pushed_RAW
+                | otherwise = if null a_reps_pushed_RAW
+                              then panic "ByteCodeGen.generateCCall: dyn with no args"
+                              else tail a_reps_pushed_RAW
+
+         -- push the Addr#
+         (push_Addr, d_after_Addr)
+            | Just machlabel <- maybe_static_target
+            = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
+            | otherwise -- is already on the stack
+            = (nilOL, d_after_args)
+
+         -- Push the return placeholder.  For a call returning nothing,
+         -- this is a V (tag).
+         r_sizeW   = repSizeWords dflags r_rep
+         d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
+         push_r =
+             if returns_void
+                then nilOL
+                else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
+
+         -- generate the marshalling code we're going to call
+
+         -- Offset of the next stack frame down the stack.  The CCALL
+         -- instruction needs to describe the chunk of stack containing
+         -- the ccall args to the GC, so it needs to know how large it
+         -- is.  See comment in Interpreter.c with the CCALL instruction.
+         stk_offset   = trunc16W $ bytesToWords dflags (d_after_r - s)
+
+         conv = case cconv of
+           CCallConv -> FFICCall
+           StdCallConv -> FFIStdCall
+           _ -> panic "ByteCodeGen: unexpected calling convention"
+
+     -- the only difference in libffi mode is that we prepare a cif
+     -- describing the call type by calling libffi, and we attach the
+     -- address of this to the CCALL instruction.
+
+
+     let ffires = primRepToFFIType dflags r_rep
+         ffiargs = map (primRepToFFIType dflags) a_reps
+     hsc_env <- getHscEnv
+     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
+     recordFFIBc token
+
+     let
+         -- do the call
+         do_call      = unitOL (CCALL stk_offset token flags)
+           where flags = case safety of
+                           PlaySafe          -> 0x0
+                           PlayInterruptible -> 0x1
+                           PlayRisky         -> 0x2
+
+         -- slide and return
+         d_after_r_min_s = bytesToWords dflags (d_after_r - s)
+         wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
+                        `snocOL` RETURN_UBX (toArgRep r_rep)
+         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
+     return (
+         push_args `appOL`
+         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
+         )
+
+primRepToFFIType :: DynFlags -> PrimRep -> FFIType
+primRepToFFIType dflags r
+  = case r of
+     VoidRep     -> FFIVoid
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> FFISInt64
+     Word64Rep   -> FFIUInt64
+     AddrRep     -> FFIPointer
+     FloatRep    -> FFIFloat
+     DoubleRep   -> FFIDouble
+     _           -> panic "primRepToFFIType"
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = (FFISInt32, FFIUInt32)
+       | wORD_SIZE dflags == 8  = (FFISInt64, FFIUInt64)
+       | otherwise              = panic "primTyDescChar"
+
+-- Make a dummy literal, to be used as a placeholder for FFI return
+-- values on the stack.
+mkDummyLiteral :: DynFlags -> PrimRep -> Literal
+mkDummyLiteral dflags pr
+   = case pr of
+        IntRep    -> mkLitInt dflags 0
+        WordRep   -> mkLitWord dflags 0
+        Int64Rep  -> mkLitInt64 0
+        Word64Rep -> mkLitWord64 0
+        AddrRep   -> LitNullAddr
+        DoubleRep -> LitDouble 0
+        FloatRep  -> LitFloat 0
+        _         -> pprPanic "mkDummyLiteral" (ppr pr)
+
+
+-- Convert (eg)
+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
+--
+-- to  Just IntRep
+-- and check that an unboxed pair is returned wherein the first arg is V'd.
+--
+-- Alternatively, for call-targets returning nothing, convert
+--
+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
+--
+-- to  Nothing
+
+maybe_getCCallReturnRep :: Type -> Maybe PrimRep
+maybe_getCCallReturnRep fn_ty
+   = let
+       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
+       r_reps = typePrimRepArgs r_ty
+
+       blargh :: a -- Used at more than one type
+       blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+                         (pprType fn_ty)
+     in
+       case r_reps of
+         []            -> panic "empty typePrimRepArgs"
+         [VoidRep]     -> Nothing
+         [rep]
+           | isGcPtrRep rep -> blargh
+           | otherwise      -> Just rep
+
+                 -- if it was, it would be impossible to create a
+                 -- valid return value placeholder on the stack
+         _             -> blargh
+
+maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
+-- Detect and extract relevant info for the tagToEnum kludge.
+maybe_is_tagToEnum_call app
+  | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
+  , Just TagToEnumOp <- isPrimOpId_maybe v
+  = Just (snd arg, extract_constr_Names t)
+  | otherwise
+  = Nothing
+  where
+    extract_constr_Names ty
+           | rep_ty <- unwrapType ty
+           , Just tyc <- tyConAppTyCon_maybe rep_ty
+           , isDataTyCon tyc
+           = map (getName . dataConWorkId) (tyConDataCons tyc)
+           -- NOTE: use the worker name, not the source name of
+           -- the DataCon.  See DataCon.hs for details.
+           | otherwise
+           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
+
+{- -----------------------------------------------------------------------------
+Note [Implementing tagToEnum#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(implement_tagToId arg names) compiles code which takes an argument
+'arg', (call it i), and enters the i'th closure in the supplied list
+as a consequence.  The [Name] is a list of the constructors of this
+(enumeration) type.
+
+The code we generate is this:
+                push arg
+                push bogus-word
+
+                TESTEQ_I 0 L1
+                  PUSH_G <lbl for first data con>
+                  JMP L_Exit
+
+        L1:     TESTEQ_I 1 L2
+                  PUSH_G <lbl for second data con>
+                  JMP L_Exit
+        ...etc...
+        Ln:     TESTEQ_I n L_fail
+                  PUSH_G <lbl for last data con>
+                  JMP L_Exit
+
+        L_fail: CASEFAIL
+
+        L_exit: SLIDE 1 n
+                ENTER
+
+The 'bogus-word' push is because TESTEQ_I expects the top of the stack
+to have an info-table, and the next word to have the value to be
+tested.  This is very weird, but it's the way it is right now.  See
+Interpreter.c.  We don't acutally need an info-table here; we just
+need to have the argument to be one-from-top on the stack, hence pushing
+a 1-word null. See #8383.
+-}
+
+
+implement_tagToId
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr' Id DVarSet
+    -> [Name]
+    -> BcM BCInstrList
+-- See Note [Implementing tagToEnum#]
+implement_tagToId d s p arg names
+  = ASSERT( notNull names )
+    do (push_arg, arg_bytes) <- pushAtom d p arg
+       labels <- getLabelsBc (genericLength names)
+       label_fail <- getLabelBc
+       label_exit <- getLabelBc
+       dflags <- getDynFlags
+       let infos = zip4 labels (tail labels ++ [label_fail])
+                               [0 ..] names
+           steps = map (mkStep label_exit) infos
+           slide_ws = bytesToWords dflags (d - s + arg_bytes)
+
+       return (push_arg
+               `appOL` unitOL (PUSH_UBX LitNullAddr 1)
+                   -- Push bogus word (see Note [Implementing tagToEnum#])
+               `appOL` concatOL steps
+               `appOL` toOL [ LABEL label_fail, CASEFAIL,
+                              LABEL label_exit ]
+               `appOL` mkSlideW 1 (slide_ws + 1)
+                   -- "+1" to account for bogus word
+                   --      (see Note [Implementing tagToEnum#])
+               `appOL` unitOL ENTER)
+  where
+        mkStep l_exit (my_label, next_label, n, name_for_n)
+           = toOL [LABEL my_label,
+                   TESTEQ_I n next_label,
+                   PUSH_G name_for_n,
+                   JMP l_exit]
+
+
+-- -----------------------------------------------------------------------------
+-- pushAtom
+
+-- Push an atom onto the stack, returning suitable code & number of
+-- stack words used.
+--
+-- The env p must map each variable to the highest- numbered stack
+-- slot for it.  For example, if the stack has depth 4 and we
+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
+-- the tag in stack[5], the stack will have depth 6, and p must map v
+-- to 5 and not to 4.  Stack locations are numbered from zero, so a
+-- depth 6 stack has valid words 0 .. 5.
+
+pushAtom
+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
+pushAtom d p e
+   | Just e' <- bcView e
+   = pushAtom d p e'
+
+pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,
+   = return (nilOL, 0)          -- treated just like a variable V
+
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:
+-- The scrutinee of an empty case evaluates to bottom
+pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
+   = pushAtom d p a
+
+pushAtom d p (AnnVar var)
+   | [] <- typePrimRep (idType var)
+   = return (nilOL, 0)
+
+   | isFCallId var
+   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)
+
+   | Just primop <- isPrimOpId_maybe var
+   = do
+       dflags <-getDynFlags
+       return (unitOL (PUSH_PRIMOP primop), wordSize dflags)
+
+   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable
+   = do dflags <- getDynFlags
+
+        let !szb = idSizeCon dflags var
+            with_instr instr = do
+                let !off_b = trunc16B $ d - d_v
+                return (unitOL (instr off_b), wordSize dflags)
+
+        case szb of
+            1 -> with_instr PUSH8_W
+            2 -> with_instr PUSH16_W
+            4 -> with_instr PUSH32_W
+            _ -> do
+                let !szw = bytesToWords dflags szb
+                    !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
+                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
+        -- d - d_v           offset from TOS to the first slot of the object
+        --
+        -- d - d_v + sz - 1  offset from the TOS of the last slot of the object
+        --
+        -- Having found the last slot, we proceed to copy the right number of
+        -- slots on to the top of the stack.
+
+   | otherwise  -- var must be a global variable
+   = do topStrings <- getTopStrings
+        dflags <- getDynFlags
+        case lookupVarEnv topStrings var of
+            Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $
+              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
+            Nothing -> do
+                let sz = idSizeCon dflags var
+                MASSERT( sz == wordSize dflags )
+                return (unitOL (PUSH_G (getName var)), sz)
+
+
+pushAtom _ _ (AnnLit lit) = do
+     dflags <- getDynFlags
+     let code rep
+             = let size_words = WordOff (argRepSizeW dflags rep)
+               in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),
+                           wordsToBytes dflags size_words)
+
+     case lit of
+        LitLabel _ _ _   -> code N
+        LitFloat _       -> code F
+        LitDouble _      -> code D
+        LitChar _        -> code N
+        LitNullAddr      -> code N
+        LitString _      -> code N
+        LitRubbish       -> code N
+        LitNumber nt _ _ -> case nt of
+          LitNumInt     -> code N
+          LitNumWord    -> code N
+          LitNumInt64   -> code L
+          LitNumWord64  -> code L
+          -- No LitInteger's or LitNatural's should be left by the time this is
+          -- called. CorePrep should have converted them all to a real core
+          -- representation.
+          LitNumInteger -> panic "pushAtom: LitInteger"
+          LitNumNatural -> panic "pushAtom: LitNatural"
+
+pushAtom _ _ expr
+   = pprPanic "ByteCodeGen.pushAtom"
+              (pprCoreExpr (deAnnotate' expr))
+
+
+-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
+-- This is slightly different to @pushAtom@ due to the fact that we allow
+-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
+pushConstrAtom
+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
+
+pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =
+    return (unitOL (PUSH_UBX32 lit), 4)
+
+pushConstrAtom d p (AnnVar v)
+    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable
+        dflags <- getDynFlags
+        let !szb = idSizeCon dflags v
+            done instr = do
+                let !off = trunc16B $ d - d_v
+                return (unitOL (instr off), szb)
+        case szb of
+            1 -> done PUSH8
+            2 -> done PUSH16
+            4 -> done PUSH32
+            _ -> pushAtom d p (AnnVar v)
+
+pushConstrAtom d p expr = pushAtom d p expr
+
+pushPadding :: Int -> (BCInstrList, ByteOff)
+pushPadding !n = go n (nilOL, 0)
+  where
+    go n acc@(!instrs, !off) = case n of
+        0 -> acc
+        1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)
+        2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)
+        3 -> go 1 (go 2 acc)
+        4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)
+        _ -> go (n - 4) (go 4 acc)
+
+-- -----------------------------------------------------------------------------
+-- Given a bunch of alts code and their discrs, do the donkey work
+-- of making a multiway branch using a switch tree.
+-- What a load of hassle!
+
+mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
+                                -- a hint; generates better code
+                                -- Nothing is always safe
+              -> [(Discr, BCInstrList)]
+              -> BcM BCInstrList
+mkMultiBranch maybe_ncons raw_ways = do
+     lbl_default <- getLabelBc
+
+     let
+         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
+         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
+             -- shouldn't happen?
+
+         mkTree [val] range_lo range_hi
+            | range_lo == range_hi
+            = return (snd val)
+            | null defaults -- Note [CASEFAIL]
+            = do lbl <- getLabelBc
+                 return (testEQ (fst val) lbl
+                            `consOL` (snd val
+                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))
+            | otherwise
+            = return (testEQ (fst val) lbl_default `consOL` snd val)
+
+            -- Note [CASEFAIL] It may be that this case has no default
+            -- branch, but the alternatives are not exhaustive - this
+            -- happens for GADT cases for example, where the types
+            -- prove that certain branches are impossible.  We could
+            -- just assume that the other cases won't occur, but if
+            -- this assumption was wrong (because of a bug in GHC)
+            -- then the result would be a segfault.  So instead we
+            -- emit an explicit test and a CASEFAIL instruction that
+            -- causes the interpreter to barf() if it is ever
+            -- executed.
+
+         mkTree vals range_lo range_hi
+            = let n = length vals `div` 2
+                  vals_lo = take n vals
+                  vals_hi = drop n vals
+                  v_mid = fst (head vals_hi)
+              in do
+              label_geq <- getLabelBc
+              code_lo <- mkTree vals_lo range_lo (dec v_mid)
+              code_hi <- mkTree vals_hi v_mid range_hi
+              return (testLT v_mid label_geq
+                      `consOL` (code_lo
+                      `appOL`   unitOL (LABEL label_geq)
+                      `appOL`   code_hi))
+
+         the_default
+            = case defaults of
+                []         -> nilOL
+                [(_, def)] -> LABEL lbl_default `consOL` def
+                _          -> panic "mkMultiBranch/the_default"
+     instrs <- mkTree notd_ways init_lo init_hi
+     return (instrs `appOL` the_default)
+  where
+         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
+         notd_ways = sortBy (comparing fst) not_defaults
+
+         testLT (DiscrI i) fail_label = TESTLT_I i fail_label
+         testLT (DiscrW i) fail_label = TESTLT_W i fail_label
+         testLT (DiscrF i) fail_label = TESTLT_F i fail_label
+         testLT (DiscrD i) fail_label = TESTLT_D i fail_label
+         testLT (DiscrP i) fail_label = TESTLT_P i fail_label
+         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"
+
+         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
+         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
+         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
+         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
+         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
+         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"
+
+         -- None of these will be needed if there are no non-default alts
+         (init_lo, init_hi)
+            | null notd_ways
+            = panic "mkMultiBranch: awesome foursome"
+            | otherwise
+            = case fst (head notd_ways) of
+                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )
+                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )
+                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )
+                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )
+                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+                NoDiscr -> panic "mkMultiBranch NoDiscr"
+
+         (algMinBound, algMaxBound)
+            = case maybe_ncons of
+                 -- XXX What happens when n == 0?
+                 Just n  -> (0, fromIntegral n - 1)
+                 Nothing -> (minBound, maxBound)
+
+         isNoDiscr NoDiscr = True
+         isNoDiscr _       = False
+
+         dec (DiscrI i) = DiscrI (i-1)
+         dec (DiscrW w) = DiscrW (w-1)
+         dec (DiscrP i) = DiscrP (i-1)
+         dec other      = other         -- not really right, but if you
+                -- do cases on floating values, you'll get what you deserve
+
+         -- same snotty comment applies to the following
+         minF, maxF :: Float
+         minD, maxD :: Double
+         minF = -1.0e37
+         maxF =  1.0e37
+         minD = -1.0e308
+         maxD =  1.0e308
+
+
+-- -----------------------------------------------------------------------------
+-- Supporting junk for the compilation schemes
+
+-- Describes case alts
+data Discr
+   = DiscrI Int
+   | DiscrW Word
+   | DiscrF Float
+   | DiscrD Double
+   | DiscrP Word16
+   | NoDiscr
+    deriving (Eq, Ord)
+
+instance Outputable Discr where
+   ppr (DiscrI i) = int i
+   ppr (DiscrW w) = text (show w)
+   ppr (DiscrF f) = text (show f)
+   ppr (DiscrD d) = text (show d)
+   ppr (DiscrP i) = ppr i
+   ppr NoDiscr    = text "DEF"
+
+
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
+lookupBCEnv_maybe = Map.lookup
+
+idSizeW :: DynFlags -> Id -> WordOff
+idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
+
+idSizeCon :: DynFlags -> Id -> ByteOff
+idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
+
+bcIdArgRep :: Id -> ArgRep
+bcIdArgRep = toArgRep . bcIdPrimRep
+
+bcIdPrimRep :: Id -> PrimRep
+bcIdPrimRep id
+  | [rep] <- typePrimRepArgs (idType id)
+  = rep
+  | otherwise
+  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
+
+repSizeWords :: DynFlags -> PrimRep -> WordOff
+repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
+
+isFollowableArg :: ArgRep -> Bool
+isFollowableArg P = True
+isFollowableArg _ = False
+
+isVoidArg :: ArgRep -> Bool
+isVoidArg V = True
+isVoidArg _ = False
+
+-- See bug #1257
+multiValException :: a
+multiValException = throwGhcException (ProgramError
+  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
+   "  Possibly due to foreign import/export decls in source.\n"++
+   "  Workaround: use -fobject-code, or compile this module to .o separately."))
+
+-- | Indicate if the calling convention is supported
+isSupportedCConv :: CCallSpec -> Bool
+isSupportedCConv (CCallSpec _ cconv _) = case cconv of
+   CCallConv            -> True     -- we explicitly pattern match on every
+   StdCallConv          -> True     -- convention to ensure that a warning
+   PrimCallConv         -> False    -- is triggered when a new one is added
+   JavaScriptCallConv   -> False
+   CApiConv             -> False
+
+-- See bug #10462
+unsupportedCConvException :: a
+unsupportedCConvException = throwGhcException (ProgramError
+  ("Error: bytecode compiler can't handle some foreign calling conventions\n"++
+   "  Workaround: use -fobject-code, or compile this module to .o separately."))
+
+mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr
+mkSlideB dflags !nb !db = mkSlideW n d
+  where
+    !n = trunc16W $ bytesToWords dflags nb
+    !d = bytesToWords dflags db
+
+mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
+mkSlideW !n !ws
+    | ws > fromIntegral limit
+    -- If the amount to slide doesn't fit in a Word16, generate multiple slide
+    -- instructions
+    = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)
+    | ws == 0
+    = nilOL
+    | otherwise
+    = unitOL (SLIDE n $ fromIntegral ws)
+  where
+    limit :: Word16
+    limit = maxBound
+
+splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
+        -- The arguments are returned in *right-to-left* order
+splitApp e | Just e' <- bcView e = splitApp e'
+splitApp (AnnApp (_,f) (_,a))    = case splitApp f of
+                                      (f', as) -> (f', a:as)
+splitApp e                       = (e, [])
+
+
+bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
+-- The "bytecode view" of a term discards
+--  a) type abstractions
+--  b) type applications
+--  c) casts
+--  d) ticks (but not breakpoints)
+-- Type lambdas *can* occur in random expressions,
+-- whereas value lambdas cannot; that is why they are nuked here
+bcView (AnnCast (_,e) _)             = Just e
+bcView (AnnLam v (_,e)) | isTyVar v  = Just e
+bcView (AnnApp (_,e) (_, AnnType _)) = Just e
+bcView (AnnTick Breakpoint{} _)      = Nothing
+bcView (AnnTick _other_tick (_,e))   = Just e
+bcView _                             = Nothing
+
+isVAtom :: AnnExpr' Var ann -> Bool
+isVAtom e | Just e' <- bcView e = isVAtom e'
+isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)
+isVAtom (AnnCoercion {})        = True
+isVAtom _                     = False
+
+atomPrimRep :: AnnExpr' Id ann -> PrimRep
+atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
+atomPrimRep (AnnVar v)              = bcIdPrimRep v
+atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l)
+
+-- #12128:
+-- A case expression can be an atom because empty cases evaluate to bottom.
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep
+atomPrimRep (AnnCoercion {})        = VoidRep
+atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
+
+atomRep :: AnnExpr' Id ann -> ArgRep
+atomRep e = toArgRep (atomPrimRep e)
+
+-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
+-- has initial depth @original_depth@.  Return the values which the stack
+-- environment should map these items to.
+mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
+mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
+
+typeArgRep :: Type -> ArgRep
+typeArgRep = toArgRep . typePrimRep1
+
+-- -----------------------------------------------------------------------------
+-- The bytecode generator's monad
+
+data BcM_State
+   = BcM_State
+        { bcm_hsc_env :: HscEnv
+        , uniqSupply  :: UniqSupply      -- for generating fresh variable names
+        , thisModule  :: Module          -- current module (for breakpoints)
+        , nextlabel   :: Word16          -- for generating local labels
+        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
+                                         -- Should be free()d when it is GCd
+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints
+        , breakInfo   :: IntMap CgBreakInfo
+        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals
+          -- See Note [generating code for top-level string literal bindings].
+        }
+
+newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
+
+ioToBc :: IO a -> BcM a
+ioToBc io = BcM $ \st -> do
+  x <- io
+  return (st, x)
+
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
+      -> IdEnv (RemotePtr ())
+      -> BcM r
+      -> IO (BcM_State, r)
+runBc hsc_env us this_mod modBreaks topStrings (BcM m)
+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
+
+thenBc :: BcM a -> (a -> BcM b) -> BcM b
+thenBc (BcM expr) cont = BcM $ \st0 -> do
+  (st1, q) <- expr st0
+  let BcM k = cont q
+  (st2, r) <- k st1
+  return (st2, r)
+
+thenBc_ :: BcM a -> BcM b -> BcM b
+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
+  (st1, _) <- expr st0
+  (st2, r) <- cont st1
+  return (st2, r)
+
+returnBc :: a -> BcM a
+returnBc result = BcM $ \st -> (return (st, result))
+
+instance Functor BcM where
+    fmap = liftM
+
+instance Applicative BcM where
+    pure = returnBc
+    (<*>) = ap
+    (*>) = thenBc_
+
+instance Monad BcM where
+  (>>=) = thenBc
+  (>>)  = (*>)
+
+instance HasDynFlags BcM where
+    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
+
+getHscEnv :: BcM HscEnv
+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
+
+emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
+
+recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
+recordFFIBc a
+  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
+
+getLabelBc :: BcM Word16
+getLabelBc
+  = BcM $ \st -> do let nl = nextlabel st
+                    when (nl == maxBound) $
+                        panic "getLabelBc: Ran out of labels"
+                    return (st{nextlabel = nl + 1}, nl)
+
+getLabelsBc :: Word16 -> BcM [Word16]
+getLabelsBc n
+  = BcM $ \st -> let ctr = nextlabel st
+                 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+
+getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
+getCCArray = BcM $ \st ->
+  let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
+  return (st, modBreaks_ccs breaks)
+
+
+newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
+newBreakInfo ix info = BcM $ \st ->
+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
+
+newUnique :: BcM Unique
+newUnique = BcM $
+   \st -> case takeUniqFromSupply (uniqSupply st) of
+             (uniq, us) -> let newState = st { uniqSupply = us }
+                           in  return (newState, uniq)
+
+getCurrentModule :: BcM Module
+getCurrentModule = BcM $ \st -> return (st, thisModule st)
+
+getTopStrings :: BcM (IdEnv (RemotePtr ()))
+getTopStrings = BcM $ \st -> return (st, topStrings st)
+
+newId :: Type -> BcM Id
+newId ty = do
+    uniq <- newUnique
+    return $ mkSysLocal tickFS uniq ty
+
+tickFS :: FastString
+tickFS = fsLit "ticked"
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -0,0 +1,368 @@
+{-# LANGUAGE CPP, MagicHash #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeInstrs: Bytecode instruction definitions
+module ByteCodeInstr (
+        BCInstr(..), ProtoBCO(..), bciStackUse,
+  ) where
+
+#include "HsVersions.h"
+#include "../includes/MachDeps.h"
+
+import GhcPrelude
+
+import ByteCodeTypes
+import GHCi.RemoteTypes
+import GHCi.FFI (C_ffi_cif)
+import StgCmmLayout     ( ArgRep(..) )
+import PprCore
+import Outputable
+import FastString
+import Name
+import Unique
+import Id
+import CoreSyn
+import Literal
+import DataCon
+import VarSet
+import PrimOp
+import SMRep
+
+import Data.Word
+import GHC.Stack.CCS (CostCentre)
+
+-- ----------------------------------------------------------------------------
+-- Bytecode instructions
+
+data ProtoBCO a
+   = ProtoBCO {
+        protoBCOName       :: a,          -- name, in some sense
+        protoBCOInstrs     :: [BCInstr],  -- instrs
+        -- arity and GC info
+        protoBCOBitmap     :: [StgWord],
+        protoBCOBitmapSize :: Word16,
+        protoBCOArity      :: Int,
+        -- what the BCO came from
+        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
+        -- malloc'd pointers
+        protoBCOFFIs       :: [FFIInfo]
+   }
+
+type LocalLabel = Word16
+
+data BCInstr
+   -- Messing with the stack
+   = STKCHECK  Word
+
+   -- Push locals (existing bits of the stack)
+   | PUSH_L    !Word16{-offset-}
+   | PUSH_LL   !Word16 !Word16{-2 offsets-}
+   | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}
+
+   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
+   -- the stack will grow by 8, 16 or 32 bits)
+   | PUSH8  !Word16
+   | PUSH16 !Word16
+   | PUSH32 !Word16
+
+   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
+   -- value will take the whole word on the stack (i.e., the stack will gorw by
+   -- a word)
+   -- This is useful when extracting a packed constructor field for further use.
+   -- Currently we expect all values on the stack to take full words, except for
+   -- the ones used for PACK (i.e., actually constracting new data types, in
+   -- which case we use PUSH{8,16,32})
+   | PUSH8_W  !Word16
+   | PUSH16_W !Word16
+   | PUSH32_W !Word16
+
+   -- Push a ptr  (these all map to PUSH_G really)
+   | PUSH_G       Name
+   | PUSH_PRIMOP  PrimOp
+   | PUSH_BCO     (ProtoBCO Name)
+
+   -- Push an alt continuation
+   | PUSH_ALTS          (ProtoBCO Name)
+   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
+
+   -- Pushing 8, 16 and 32 bits of padding (for constructors).
+   | PUSH_PAD8
+   | PUSH_PAD16
+   | PUSH_PAD32
+
+   -- Pushing literals
+   | PUSH_UBX8  Literal
+   | PUSH_UBX16 Literal
+   | PUSH_UBX32 Literal
+   | PUSH_UBX   Literal Word16
+        -- push this int/float/double/addr, on the stack. Word16
+        -- is # of words to copy from literal pool.  Eitherness reflects
+        -- the difficulty of dealing with MachAddr here, mostly due to
+        -- the excessive (and unnecessary) restrictions imposed by the
+        -- designers of the new Foreign library.  In particular it is
+        -- quite impossible to convert an Addr to any other integral
+        -- type, and it appears impossible to get hold of the bits of
+        -- an addr, even though we need to assemble BCOs.
+
+   -- various kinds of application
+   | PUSH_APPLY_N
+   | PUSH_APPLY_V
+   | PUSH_APPLY_F
+   | PUSH_APPLY_D
+   | PUSH_APPLY_L
+   | PUSH_APPLY_P
+   | PUSH_APPLY_PP
+   | PUSH_APPLY_PPP
+   | PUSH_APPLY_PPPP
+   | PUSH_APPLY_PPPPP
+   | PUSH_APPLY_PPPPPP
+
+   | SLIDE     Word16{-this many-} Word16{-down by this much-}
+
+   -- To do with the heap
+   | ALLOC_AP  !Word16 -- make an AP with this many payload words
+   | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words
+   | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words
+   | MKAP      !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}
+   | MKPAP     !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
+   | UNPACK    !Word16 -- unpack N words from t.o.s Constr
+   | PACK      DataCon !Word16
+                        -- after assembly, the DataCon is an index into the
+                        -- itbl array
+   -- For doing case trees
+   | LABEL     LocalLabel
+   | TESTLT_I  Int    LocalLabel
+   | TESTEQ_I  Int    LocalLabel
+   | TESTLT_W  Word   LocalLabel
+   | TESTEQ_W  Word   LocalLabel
+   | TESTLT_F  Float  LocalLabel
+   | TESTEQ_F  Float  LocalLabel
+   | TESTLT_D  Double LocalLabel
+   | TESTEQ_D  Double LocalLabel
+
+   -- The Word16 value is a constructor number and therefore
+   -- stored in the insn stream rather than as an offset into
+   -- the literal pool.
+   | TESTLT_P  Word16 LocalLabel
+   | TESTEQ_P  Word16 LocalLabel
+
+   | CASEFAIL
+   | JMP              LocalLabel
+
+   -- For doing calls to C (via glue code generated by libffi)
+   | CCALL            Word16    -- stack frame size
+                      (RemotePtr C_ffi_cif) -- addr of the glue code
+                      Word16    -- flags.
+                                --
+                                -- 0x1: call is interruptible
+                                -- 0x2: call is unsafe
+                                --
+                                -- (XXX: inefficient, but I don't know
+                                -- what the alignment constraints are.)
+
+   -- For doing magic ByteArray passing to foreign calls
+   | SWIZZLE          Word16 -- to the ptr N words down the stack,
+                      Word16 -- add M (interpreted as a signed 16-bit entity)
+
+   -- To Infinity And Beyond
+   | ENTER
+   | RETURN             -- return a lifted value
+   | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
+
+   -- Breakpoints
+   | BRK_FUN          Word16 Unique (RemotePtr CostCentre)
+
+-- -----------------------------------------------------------------------------
+-- Printing bytecode instructions
+
+instance Outputable a => Outputable (ProtoBCO a) where
+   ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)
+      = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
+                <+> text (show ffis) <> colon)
+        $$ nest 3 (case origin of
+                      Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
+                                                       (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
+                      Right rhs -> pprCoreExprShort (deAnnotate rhs))
+        $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
+        $$ nest 3 (vcat (map ppr instrs))
+
+-- Print enough of the Core expression to enable the reader to find
+-- the expression in the -ddump-prep output.  That is, we need to
+-- include at least a binder.
+
+pprCoreExprShort :: CoreExpr -> SDoc
+pprCoreExprShort expr@(Lam _ _)
+  = let
+        (bndrs, _) = collectBinders expr
+    in
+    char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
+
+pprCoreExprShort (Case _expr var _ty _alts)
+ = text "case of" <+> ppr var
+
+pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
+pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
+
+pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
+pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
+
+pprCoreExprShort e = pprCoreExpr e
+
+pprCoreAltShort :: CoreAlt -> SDoc
+pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
+
+instance Outputable BCInstr where
+   ppr (STKCHECK n)          = text "STKCHECK" <+> ppr n
+   ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset
+   ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> ppr o1 <+> ppr o2
+   ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
+   ppr (PUSH8  offset)       = text "PUSH8  " <+> ppr offset
+   ppr (PUSH16 offset)       = text "PUSH16  " <+> ppr offset
+   ppr (PUSH32 offset)       = text "PUSH32  " <+> ppr offset
+   ppr (PUSH8_W  offset)     = text "PUSH8_W  " <+> ppr offset
+   ppr (PUSH16_W offset)     = text "PUSH16_W  " <+> ppr offset
+   ppr (PUSH32_W offset)     = text "PUSH32_W  " <+> ppr offset
+   ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
+   ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."
+                                               <> ppr op
+   ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco)
+   ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)
+   ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
+
+   ppr PUSH_PAD8             = text "PUSH_PAD8"
+   ppr PUSH_PAD16            = text "PUSH_PAD16"
+   ppr PUSH_PAD32            = text "PUSH_PAD32"
+
+   ppr (PUSH_UBX8  lit)      = text "PUSH_UBX8" <+> ppr lit
+   ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit
+   ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit
+   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+   ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"
+   ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"
+   ppr PUSH_APPLY_F          = text "PUSH_APPLY_F"
+   ppr PUSH_APPLY_D          = text "PUSH_APPLY_D"
+   ppr PUSH_APPLY_L          = text "PUSH_APPLY_L"
+   ppr PUSH_APPLY_P          = text "PUSH_APPLY_P"
+   ppr PUSH_APPLY_PP         = text "PUSH_APPLY_PP"
+   ppr PUSH_APPLY_PPP        = text "PUSH_APPLY_PPP"
+   ppr PUSH_APPLY_PPPP       = text "PUSH_APPLY_PPPP"
+   ppr PUSH_APPLY_PPPPP      = text "PUSH_APPLY_PPPPP"
+   ppr PUSH_APPLY_PPPPPP     = text "PUSH_APPLY_PPPPPP"
+
+   ppr (SLIDE n d)           = text "SLIDE   " <+> ppr n <+> ppr d
+   ppr (ALLOC_AP sz)         = text "ALLOC_AP   " <+> ppr sz
+   ppr (ALLOC_AP_NOUPD sz)   = text "ALLOC_AP_NOUPD   " <+> ppr sz
+   ppr (ALLOC_PAP arity sz)  = text "ALLOC_PAP   " <+> ppr arity <+> ppr sz
+   ppr (MKAP offset sz)      = text "MKAP    " <+> ppr sz <+> text "words,"
+                                               <+> ppr offset <+> text "stkoff"
+   ppr (MKPAP offset sz)     = text "MKPAP   " <+> ppr sz <+> text "words,"
+                                               <+> ppr offset <+> text "stkoff"
+   ppr (UNPACK sz)           = text "UNPACK  " <+> ppr sz
+   ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
+   ppr (LABEL     lab)       = text "__"       <> ppr lab <> colon
+   ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
+   ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
+   ppr (TESTLT_W  i lab)     = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+   ppr (TESTEQ_W  i lab)     = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+   ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
+   ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
+   ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
+   ppr (TESTEQ_D  d lab)     = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab
+   ppr (TESTLT_P  i lab)     = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
+   ppr CASEFAIL              = text "CASEFAIL"
+   ppr (JMP lab)             = text "JMP"      <+> ppr lab
+   ppr (CCALL off marshall_addr flags) = text "CCALL   " <+> ppr off
+                                                <+> text "marshall code at"
+                                               <+> text (show marshall_addr)
+                                               <+> (case flags of
+                                                      0x1 -> text "(interruptible)"
+                                                      0x2 -> text "(unsafe)"
+                                                      _   -> empty)
+   ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
+                                               <+> text "by" <+> ppr n
+   ppr ENTER                 = text "ENTER"
+   ppr RETURN                = text "RETURN"
+   ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk
+   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
+
+-- -----------------------------------------------------------------------------
+-- The stack use, in words, of each bytecode insn.  These _must_ be
+-- correct, or overestimates of reality, to be safe.
+
+-- NOTE: we aggregate the stack use from case alternatives too, so that
+-- we can do a single stack check at the beginning of a function only.
+
+-- This could all be made more accurate by keeping track of a proper
+-- stack high water mark, but it doesn't seem worth the hassle.
+
+protoBCOStackUse :: ProtoBCO a -> Word
+protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
+
+bciStackUse :: BCInstr -> Word
+bciStackUse STKCHECK{}            = 0
+bciStackUse PUSH_L{}              = 1
+bciStackUse PUSH_LL{}             = 2
+bciStackUse PUSH_LLL{}            = 3
+bciStackUse PUSH8{}               = 1  -- overapproximation
+bciStackUse PUSH16{}              = 1  -- overapproximation
+bciStackUse PUSH32{}              = 1  -- overapproximation on 64bit arch
+bciStackUse PUSH8_W{}             = 1  -- takes exactly 1 word
+bciStackUse PUSH16_W{}            = 1  -- takes exactly 1 word
+bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
+bciStackUse PUSH_G{}              = 1
+bciStackUse PUSH_PRIMOP{}         = 1
+bciStackUse PUSH_BCO{}            = 1
+bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_PAD8)           = 1  -- overapproximation
+bciStackUse (PUSH_PAD16)          = 1  -- overapproximation
+bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
+bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
+bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw
+bciStackUse PUSH_APPLY_N{}        = 1
+bciStackUse PUSH_APPLY_V{}        = 1
+bciStackUse PUSH_APPLY_F{}        = 1
+bciStackUse PUSH_APPLY_D{}        = 1
+bciStackUse PUSH_APPLY_L{}        = 1
+bciStackUse PUSH_APPLY_P{}        = 1
+bciStackUse PUSH_APPLY_PP{}       = 1
+bciStackUse PUSH_APPLY_PPP{}      = 1
+bciStackUse PUSH_APPLY_PPPP{}     = 1
+bciStackUse PUSH_APPLY_PPPPP{}    = 1
+bciStackUse PUSH_APPLY_PPPPPP{}   = 1
+bciStackUse ALLOC_AP{}            = 1
+bciStackUse ALLOC_AP_NOUPD{}      = 1
+bciStackUse ALLOC_PAP{}           = 1
+bciStackUse (UNPACK sz)           = fromIntegral sz
+bciStackUse LABEL{}               = 0
+bciStackUse TESTLT_I{}            = 0
+bciStackUse TESTEQ_I{}            = 0
+bciStackUse TESTLT_W{}            = 0
+bciStackUse TESTEQ_W{}            = 0
+bciStackUse TESTLT_F{}            = 0
+bciStackUse TESTEQ_F{}            = 0
+bciStackUse TESTLT_D{}            = 0
+bciStackUse TESTEQ_D{}            = 0
+bciStackUse TESTLT_P{}            = 0
+bciStackUse TESTEQ_P{}            = 0
+bciStackUse CASEFAIL{}            = 0
+bciStackUse JMP{}                 = 0
+bciStackUse ENTER{}               = 0
+bciStackUse RETURN{}              = 0
+bciStackUse RETURN_UBX{}          = 1
+bciStackUse CCALL{}               = 0
+bciStackUse SWIZZLE{}             = 0
+bciStackUse BRK_FUN{}             = 0
+
+-- These insns actually reduce stack use, but we need the high-tide level,
+-- so can't use this info.  Not that it matters much.
+bciStackUse SLIDE{}               = 0
+bciStackUse MKAP{}                = 0
+bciStackUse MKPAP{}               = 0
+bciStackUse PACK{}                = 1 -- worst case is PACK 0 words
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
+module ByteCodeItbls ( mkITbls ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import ByteCodeTypes
+import GHCi
+import DynFlags
+import HscTypes
+import Name             ( Name, getName )
+import NameEnv
+import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
+import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
+import RepType
+import StgCmmLayout     ( mkVirtConstrSizes )
+import StgCmmClosure    ( tagForCon, NonVoid (..) )
+import Util
+import Panic
+
+{-
+  Manufacturing of info tables for DataCons
+-}
+
+-- Make info tables for the data decls in this module
+mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
+mkITbls hsc_env tcs =
+  foldr plusNameEnv emptyNameEnv <$>
+    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
+ where
+  mkITbl :: HscEnv -> TyCon -> IO ItblEnv
+  mkITbl hsc_env tc
+    | dcs `lengthIs` n -- paranoia; this is an assertion.
+    = make_constr_itbls hsc_env dcs
+       where
+          dcs = tyConDataCons tc
+          n   = tyConFamilySize tc
+  mkITbl _ _ = panic "mkITbl"
+
+mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
+mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
+
+-- Assumes constructors are numbered from zero, not one
+make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
+make_constr_itbls hsc_env cons =
+  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
+ where
+  dflags = hsc_dflags hsc_env
+
+  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
+  mk_itbl dcon conNo = do
+     let rep_args = [ NonVoid prim_rep
+                    | arg <- dataConRepArgTys dcon
+                    , prim_rep <- typePrimRep arg ]
+
+         (tot_wds, ptr_wds) =
+             mkVirtConstrSizes dflags rep_args
+
+         ptrs'  = ptr_wds
+         nptrs' = tot_wds - ptr_wds
+         nptrs_really
+            | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
+            | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
+
+         descr = dataConIdentity dcon
+
+     r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
+                              conNo (tagForCon dflags dcon) descr)
+     return (getName dcon, ItblPtr r)
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -0,0 +1,184 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeLink: Bytecode assembler and linker
+module ByteCodeLink (
+        ClosureEnv, emptyClosureEnv, extendClosureEnv,
+        linkBCO, lookupStaticPtr,
+        lookupIE,
+        nameToCLabel, linkFail
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.BreakArray
+import SizedSeq
+
+import GHCi
+import ByteCodeTypes
+import HscTypes
+import Name
+import NameEnv
+import PrimOp
+import Module
+import FastString
+import Panic
+import Outputable
+import Util
+
+-- Standard libraries
+import Data.Array.Unboxed
+import Foreign.Ptr
+import GHC.Exts
+
+{-
+  Linking interpretables into something we can run
+-}
+
+type ClosureEnv = NameEnv (Name, ForeignHValue)
+
+emptyClosureEnv :: ClosureEnv
+emptyClosureEnv = emptyNameEnv
+
+extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
+extendClosureEnv cl_env pairs
+  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+
+{-
+  Linking interpretables into something we can run
+-}
+
+linkBCO
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  -> UnlinkedBCO
+  -> IO ResolvedBCO
+linkBCO hsc_env ie ce bco_ix breakarray
+           (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
+  -- fromIntegral Word -> Word64 should be a no op if Word is Word64
+  -- otherwise it will result in a cast to longlong on 32bit systems.
+  lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)
+  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
+  return (ResolvedBCO isLittleEndian arity insns bitmap
+              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+              (addListToSS emptySS ptrs))
+
+lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
+lookupLiteral _ _ (BCONPtrWord lit) = return lit
+lookupLiteral hsc_env _ (BCONPtrLbl  sym) = do
+  Ptr a# <- lookupStaticPtr hsc_env sym
+  return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do
+  Ptr a# <- lookupIE hsc_env ie nm
+  return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral _ _ (BCONPtrStr _) =
+  -- should be eliminated during assembleBCOs
+  panic "lookupLiteral: BCONPtrStr"
+
+lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
+lookupStaticPtr hsc_env addr_of_label_string = do
+  m <- lookupSymbol hsc_env addr_of_label_string
+  case m of
+    Just ptr -> return ptr
+    Nothing  -> linkFail "ByteCodeLink: can't find label"
+                  (unpackFS addr_of_label_string)
+
+lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
+lookupIE hsc_env ie con_nm =
+  case lookupNameEnv ie con_nm of
+    Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
+    Nothing -> do -- try looking up in the object files.
+       let sym_to_find1 = nameToCLabel con_nm "con_info"
+       m <- lookupSymbol hsc_env sym_to_find1
+       case m of
+          Just addr -> return addr
+          Nothing
+             -> do -- perhaps a nullary constructor?
+                   let sym_to_find2 = nameToCLabel con_nm "static_info"
+                   n <- lookupSymbol hsc_env sym_to_find2
+                   case n of
+                      Just addr -> return addr
+                      Nothing   -> linkFail "ByteCodeLink.lookupIE"
+                                      (unpackFS sym_to_find1 ++ " or " ++
+                                       unpackFS sym_to_find2)
+
+lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
+lookupPrimOp hsc_env primop = do
+  let sym_to_find = primopToCLabel primop "closure"
+  m <- lookupSymbol hsc_env (mkFastString sym_to_find)
+  case m of
+    Just p -> return (toRemotePtr p)
+    Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+
+resolvePtr
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  -> BCOPtr
+  -> IO ResolvedBCOPtr
+resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
+  | Just ix <- lookupNameEnv bco_ix nm =
+    return (ResolvedBCORef ix) -- ref to another BCO in this group
+  | Just (_, rhv) <- lookupNameEnv ce nm =
+    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
+  | otherwise =
+    ASSERT2(isExternalName nm, ppr nm)
+    do let sym_to_find = nameToCLabel nm "closure"
+       m <- lookupSymbol hsc_env sym_to_find
+       case m of
+         Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
+         Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
+resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
+  ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
+resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
+  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
+resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
+  return (ResolvedBCOPtrBreakArray breakarray)
+
+linkFail :: String -> String -> IO a
+linkFail who what
+   = throwGhcExceptionIO (ProgramError $
+        unlines [ "",who
+                , "During interactive linking, GHCi couldn't find the following symbol:"
+                , ' ' : ' ' : what
+                , "This may be due to you not asking GHCi to load extra object files,"
+                , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
+                , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
+                , "flags, or simply by naming the relevant files on the GHCi command line."
+                , "Alternatively, this link failure might indicate a bug in GHCi."
+                , "If you suspect the latter, please report this as a GHC bug:"
+                , "  https://www.haskell.org/ghc/reportabug"
+                ])
+
+
+nameToCLabel :: Name -> String -> FastString
+nameToCLabel n suffix = mkFastString label
+  where
+    encodeZ = zString . zEncodeFS
+    (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
+    packagePart = encodeZ (unitIdFS pkgKey)
+    modulePart  = encodeZ (moduleNameFS modName)
+    occPart     = encodeZ (occNameFS (nameOccName n))
+
+    label = concat
+        [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
+        , modulePart
+        , '_':occPart
+        , '_':suffix
+        ]
+
+
+primopToCLabel :: PrimOp -> String -> String
+primopToCLabel primop suffix = concat
+    [ "ghczmprim_GHCziPrimopWrappers_"
+    , zString (zEncodeFS (occNameFS (primOpOcc primop)))
+    , '_':suffix
+    ]
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/Debugger.hs
@@ -0,0 +1,234 @@
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHCi Interactive debugging commands
+--
+-- Pepe Iborra (supported by Google SoC) 2006
+--
+-- ToDo: lots of violation of layering here.  This module should
+-- decide whether it is above the GHC API (import GHC and nothing
+-- else) or below it.
+--
+-----------------------------------------------------------------------------
+
+module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
+
+import GhcPrelude
+
+import Linker
+import RtClosureInspect
+
+import GHCi
+import GHCi.RemoteTypes
+import GhcMonad
+import HscTypes
+import Id
+import IfaceSyn ( showToHeader )
+import IfaceEnv( newInteractiveBinder )
+import Name
+import Var hiding ( varName )
+import VarSet
+import UniqSet
+import Type
+import GHC
+import Outputable
+import PprTyThing
+import ErrUtils
+import MonadUtils
+import DynFlags
+import Exception
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.IORef
+
+-------------------------------------
+-- | The :print & friends commands
+-------------------------------------
+pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
+pprintClosureCommand bindThings force str = do
+  tythings <- (catMaybes . concat) `liftM`
+                 mapM (\w -> GHC.parseName w >>=
+                                mapM GHC.lookupName)
+                      (words str)
+  let ids = [id | AnId id <- tythings]
+
+  -- Obtain the terms and the recovered type information
+  (subst, terms) <- mapAccumLM go emptyTCvSubst ids
+
+  -- Apply the substitutions obtained after recovering the types
+  modifySession $ \hsc_env ->
+    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
+
+  -- Finally, print the Terms
+  unqual  <- GHC.getPrintUnqual
+  docterms <- mapM showTerm terms
+  dflags <- getDynFlags
+  liftIO $ (printOutputForUser dflags unqual . vcat)
+           (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
+                    ids
+                    docterms)
+ where
+   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
+   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
+   go subst id = do
+       let id' = id `setIdType` substTy subst (idType id)
+       term_    <- GHC.obtainTermFromId maxBound force id'
+       term     <- tidyTermTyVars term_
+       term'    <- if bindThings
+                     then bindSuspensions term
+                     else return term
+     -- Before leaving, we compare the type obtained to see if it's more specific
+     --  Then, we extract a substitution,
+     --  mapping the old tyvars to the reconstructed types.
+       let reconstructed_type = termType term
+       hsc_env <- getSession
+       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
+         Nothing     -> return (subst, term')
+         Just subst' -> do { dflags <- GHC.getSessionDynFlags
+                           ; liftIO $
+                               dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
+                                 (fsep $ [text "RTTI Improvement for", ppr id,
+                                  text "is the substitution:" , ppr subst'])
+                           ; return (subst `unionTCvSubst` subst', term')}
+
+   tidyTermTyVars :: GhcMonad m => Term -> m Term
+   tidyTermTyVars t =
+     withSession $ \hsc_env -> do
+     let env_tvs      = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
+         my_tvs       = termTyCoVars t
+         tvs          = env_tvs `minusVarSet` my_tvs
+         tyvarOccName = nameOccName . tyVarName
+         tidyEnv      = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
+           -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
+           -- forgets the ordering immediately by creating an env
+                        , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
+     return $ mapTermType (snd . tidyOpenType tidyEnv) t
+
+-- | Give names, and bind in the interactive environment, to all the suspensions
+--   included (inductively) in a term
+bindSuspensions :: GhcMonad m => Term -> m Term
+bindSuspensions t = do
+      hsc_env <- getSession
+      inScope <- GHC.getBindings
+      let ictxt        = hsc_IC hsc_env
+          prefix       = "_t"
+          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
+          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
+      availNames_var  <- liftIO $ newIORef availNames
+      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
+      let (names, tys, fhvs) = unzip3 stuff
+      let ids = [ mkVanillaGlobal name ty
+                | (name,ty) <- zip names tys]
+          new_ic = extendInteractiveContextWithIds ictxt ids
+          dl = hsc_dynLinker hsc_env
+      liftIO $ extendLinkEnv dl (zip names fhvs)
+      setSession hsc_env {hsc_IC = new_ic }
+      return t'
+     where
+
+--    Processing suspensions. Give names and recopilate info
+        nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
+                                   -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
+        nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
+                      {
+                        fSuspension = doSuspension hsc_env freeNames
+                      , fTerm = \ty dc v tt -> do
+                                    tt' <- sequence tt
+                                    let (terms,names) = unzip tt'
+                                    return (Term ty dc v terms, concat names)
+                      , fPrim    = \ty n ->return (Prim ty n,[])
+                      , fNewtypeWrap  =
+                                \ty dc t -> do
+                                    (term, names) <- t
+                                    return (NewtypeWrap ty dc term, names)
+                      , fRefWrap = \ty t -> do
+                                    (term, names) <- t
+                                    return (RefWrap ty term, names)
+                      }
+        doSuspension hsc_env freeNames ct ty hval _name = do
+          name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
+          n <- newGrimName hsc_env name
+          return (Suspension ct ty hval (Just n), [(n,ty,hval)])
+
+
+--  A custom Term printer to enable the use of Show instances
+showTerm :: GhcMonad m => Term -> m SDoc
+showTerm term = do
+    dflags       <- GHC.getSessionDynFlags
+    if gopt Opt_PrintEvldWithShow dflags
+       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
+       else cPprTerm cPprTermBase term
+ where
+  cPprShowable prec t@Term{ty=ty, val=fhv} =
+    if not (isFullyEvaluatedTerm t)
+     then return Nothing
+     else do
+        hsc_env <- getSession
+        dflags  <- GHC.getSessionDynFlags
+        do
+           (new_env, bname) <- bindToFreshName hsc_env ty "showme"
+           setSession new_env
+                      -- XXX: this tries to disable logging of errors
+                      -- does this still do what it is intended to do
+                      -- with the changed error handling and logging?
+           let noop_log _ _ _ _ _ _ = return ()
+               expr = "Prelude.return (Prelude.show " ++
+                         showPpr dflags bname ++
+                      ") :: Prelude.IO Prelude.String"
+               dl   = hsc_dynLinker hsc_env
+           _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
+           txt_ <- withExtendedLinkEnv dl
+                                       [(bname, fhv)]
+                                       (GHC.compileExprRemote expr)
+           let myprec = 10 -- application precedence. TODO Infix constructors
+           txt <- liftIO $ evalString hsc_env txt_
+           if not (null txt) then
+             return $ Just $ cparen (prec >= myprec && needsParens txt)
+                                    (text txt)
+            else return Nothing
+         `gfinally` do
+           setSession hsc_env
+           GHC.setSessionDynFlags dflags
+  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
+      cPprShowable prec t{ty=new_ty}
+  cPprShowable _ _ = return Nothing
+
+  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
+                                -- are redundant in an arbitrary Show output
+  needsParens ('(':_) = False
+  needsParens txt = ' ' `elem` txt
+
+
+  bindToFreshName hsc_env ty userName = do
+    name <- newGrimName hsc_env userName
+    let id       = mkVanillaGlobal name ty
+        new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
+    return (hsc_env {hsc_IC = new_ic }, name)
+
+--    Create new uniques and give them sequentially numbered names
+newGrimName :: MonadIO m => HscEnv -> String -> m Name
+newGrimName hsc_env userName
+  = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
+  where
+    occ = mkOccName varName userName
+
+pprTypeAndContents :: GhcMonad m => Id -> m SDoc
+pprTypeAndContents id = do
+  dflags  <- GHC.getSessionDynFlags
+  let pcontents = gopt Opt_PrintBindContents dflags
+      pprdId    = (pprTyThing showToHeader . AnId) id
+  if pcontents
+    then do
+      let depthBound = 100
+      -- If the value is an exception, make sure we catch it and
+      -- show the exception, rather than propagating the exception out.
+      e_term <- gtry $ GHC.obtainTermFromId depthBound False id
+      docs_term <- case e_term of
+                      Right term -> showTerm term
+                      Left  exn  -> return (text "*** Exception:" <+>
+                                            text (show (exn :: SomeException)))
+      return $ pprdId <+> equals <+> docs_term
+    else return pprdId
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/GHCi.hs
@@ -0,0 +1,667 @@
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}
+
+--
+-- | Interacting with the interpreter, whether it is running on an
+-- external process or in the current process.
+--
+module GHCi
+  ( -- * High-level interface to the interpreter
+    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
+  , resumeStmt
+  , abandonStmt
+  , evalIO
+  , evalString
+  , evalStringToIOString
+  , mallocData
+  , createBCOs
+  , addSptEntry
+  , mkCostCentres
+  , costCentreStackInfo
+  , newBreakArray
+  , enableBreakpoint
+  , breakpointStatus
+  , getBreakpointVar
+  , getClosure
+  , seqHValue
+
+  -- * The object-code linker
+  , initObjLinker
+  , lookupSymbol
+  , lookupClosure
+  , loadDLL
+  , loadArchive
+  , loadObj
+  , unloadObj
+  , addLibrarySearchPath
+  , removeLibrarySearchPath
+  , resolveObjs
+  , findSystemLibrary
+
+  -- * Lower-level API using messages
+  , iservCmd, Message(..), withIServ, stopIServ
+  , iservCall, readIServ, writeIServ
+  , purgeLookupSymbolCache
+  , freeHValueRefs
+  , mkFinalizedHValue
+  , wormhole, wormholeRef
+  , mkEvalOpts
+  , fromEvalResult
+  ) where
+
+import GhcPrelude
+
+import GHCi.Message
+#if defined(GHCI)
+import GHCi.Run
+#endif
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.BreakArray (BreakArray)
+import Fingerprint
+import HscTypes
+import UniqFM
+import Panic
+import DynFlags
+import ErrUtils
+import Outputable
+import Exception
+import BasicTypes
+import FastString
+import Util
+import Hooks
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Binary
+import Data.Binary.Put
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LB
+import Data.IORef
+import Foreign hiding (void)
+import GHC.Exts.Heap
+import GHC.Stack.CCS (CostCentre,CostCentreStack)
+import System.Exit
+import Data.Maybe
+import GHC.IO.Handle.Types (Handle)
+#if defined(mingw32_HOST_OS)
+import Foreign.C
+import GHC.IO.Handle.FD (fdToHandle)
+#else
+import System.Posix as Posix
+#endif
+import System.Directory
+import System.Process
+import GHC.Conc (getNumProcessors, pseq, par)
+
+{- Note [Remote GHCi]
+
+When the flag -fexternal-interpreter is given to GHC, interpreted code
+is run in a separate process called iserv, and we communicate with the
+external process over a pipe using Binary-encoded messages.
+
+Motivation
+~~~~~~~~~~
+
+When the interpreted code is running in a separate process, it can
+use a different "way", e.g. profiled or dynamic.  This means
+
+- compiling Template Haskell code with -prof does not require
+  building the code without -prof first
+
+- when GHC itself is profiled, it can interpret unprofiled code,
+  and the same applies to dynamic linking.
+
+- An unprofiled GHCi can load and run profiled code, which means it
+  can use the stack-trace functionality provided by profiling without
+  taking the performance hit on the compiler that profiling would
+  entail.
+
+For other reasons see remote-GHCi on the wiki.
+
+Implementation Overview
+~~~~~~~~~~~~~~~~~~~~~~~
+
+The main pieces are:
+
+- libraries/ghci, containing:
+  - types for talking about remote values (GHCi.RemoteTypes)
+  - the message protocol (GHCi.Message),
+  - implementation of the messages (GHCi.Run)
+  - implementation of Template Haskell (GHCi.TH)
+  - a few other things needed to run interpreted code
+
+- top-level iserv directory, containing the codefor the external
+  server.  This is a fairly simple wrapper, most of the functionality
+  is provided by modules in libraries/ghci.
+
+- This module (GHCi) which provides the interface to the server used
+  by the rest of GHC.
+
+GHC works with and without -fexternal-interpreter.  With the flag, all
+interpreted code is run by the iserv binary.  Without the flag,
+interpreted code is run in the same process as GHC.
+
+Things that do not work with -fexternal-interpreter
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+dynCompileExpr cannot work, because we have no way to run code of an
+unknown type in the remote process.  This API fails with an error
+message if it is used with -fexternal-interpreter.
+
+Other Notes on Remote GHCi
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+  * This wiki page has an implementation overview:
+    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter
+  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
+  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
+-}
+
+#if !defined(GHCI)
+needExtInt :: IO a
+needExtInt = throwIO
+  (InstallationError "this operation requires -fexternal-interpreter")
+#endif
+
+-- | Run a command in the interpreter's context.  With
+-- @-fexternal-interpreter@, the command is serialized and sent to an
+-- external iserv process, and the response is deserialized (hence the
+-- @Binary@ constraint).  With @-fno-external-interpreter@ we execute
+-- the command directly here.
+iservCmd :: Binary a => HscEnv -> Message a -> IO a
+iservCmd hsc_env@HscEnv{..} msg
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+     withIServ hsc_env $ \iserv ->
+       uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
+         iservCall iserv msg
+ | otherwise = -- Just run it directly
+#if defined(GHCI)
+   run msg
+#else
+   needExtInt
+#endif
+
+-- Note [uninterruptibleMask_ and iservCmd]
+--
+-- If we receive an async exception, such as ^C, while communicating
+-- with the iserv process then we will be out-of-sync and not be able
+-- to recoever.  Thus we use uninterruptibleMask_ during
+-- communication.  A ^C will be delivered to the iserv process (because
+-- signals get sent to the whole process group) which will interrupt
+-- the running computation and return an EvalException result.
+
+-- | Grab a lock on the 'IServ' and do something with it.
+-- Overloaded because this is used from TcM as well as IO.
+withIServ
+  :: (MonadIO m, ExceptionMonad m)
+  => HscEnv -> (IServ -> m a) -> m a
+withIServ HscEnv{..} action =
+  gmask $ \restore -> do
+    m <- liftIO $ takeMVar hsc_iserv
+      -- start the iserv process if we haven't done so yet
+    iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
+               `gonException` (liftIO $ putMVar hsc_iserv Nothing)
+      -- free any ForeignHValues that have been garbage collected.
+    let iserv' = iserv{ iservPendingFrees = [] }
+    a <- (do
+      liftIO $ when (not (null (iservPendingFrees iserv))) $
+        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
+        -- run the inner action
+      restore $ action iserv)
+          `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
+    liftIO $ putMVar hsc_iserv (Just iserv')
+    return a
+
+
+-- -----------------------------------------------------------------------------
+-- Wrappers around messages
+
+-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
+-- each of the results.
+evalStmt
+  :: HscEnv -> Bool -> EvalExpr ForeignHValue
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
+evalStmt hsc_env step foreign_expr = do
+  let dflags = hsc_dflags hsc_env
+  status <- withExpr foreign_expr $ \expr ->
+    iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
+  handleEvalStatus hsc_env status
+ where
+  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
+  withExpr (EvalThis fhv) cont =
+    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
+  withExpr (EvalApp fl fr) cont =
+    withExpr fl $ \fl' ->
+    withExpr fr $ \fr' ->
+    cont (EvalApp fl' fr')
+
+resumeStmt
+  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
+resumeStmt hsc_env step resume_ctxt = do
+  let dflags = hsc_dflags hsc_env
+  status <- withForeignRef resume_ctxt $ \rhv ->
+    iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
+  handleEvalStatus hsc_env status
+
+abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
+abandonStmt hsc_env resume_ctxt = do
+  withForeignRef resume_ctxt $ \rhv ->
+    iservCmd hsc_env (AbandonStmt rhv)
+
+handleEvalStatus
+  :: HscEnv -> EvalStatus [HValueRef]
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
+handleEvalStatus hsc_env status =
+  case status of
+    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
+    EvalComplete alloc res ->
+      EvalComplete alloc <$> addFinalizer res
+ where
+  addFinalizer (EvalException e) = return (EvalException e)
+  addFinalizer (EvalSuccess rs) = do
+    EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
+
+-- | Execute an action of type @IO ()@
+evalIO :: HscEnv -> ForeignHValue -> IO ()
+evalIO hsc_env fhv = do
+  liftIO $ withForeignRef fhv $ \fhv ->
+    iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
+
+-- | Execute an action of type @IO String@
+evalString :: HscEnv -> ForeignHValue -> IO String
+evalString hsc_env fhv = do
+  liftIO $ withForeignRef fhv $ \fhv ->
+    iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
+
+-- | Execute an action of type @String -> IO String@
+evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
+evalStringToIOString hsc_env fhv str = do
+  liftIO $ withForeignRef fhv $ \fhv ->
+    iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
+
+
+-- | Allocate and store the given bytes in memory, returning a pointer
+-- to the memory in the remote process.
+mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
+mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
+
+mkCostCentres
+  :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres hsc_env mod ccs =
+  iservCmd hsc_env (MkCostCentres mod ccs)
+
+-- | Create a set of BCOs that may be mutually recursive.
+createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
+createBCOs hsc_env rbcos = do
+  n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
+              Nothing -> liftIO getNumProcessors
+              Just n  -> return n
+  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
+  -- (-j<n>) parallelise the serialization.
+  if (n_jobs == 1)
+    then
+      iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])
+
+    else do
+      old_caps <- getNumCapabilities
+      if old_caps == n_jobs
+         then void $ evaluate puts
+         else bracket_ (setNumCapabilities n_jobs)
+                       (setNumCapabilities old_caps)
+                       (void $ evaluate puts)
+      iservCmd hsc_env (CreateBCOs puts)
+ where
+  puts = parMap doChunk (chunkList 100 rbcos)
+
+  -- make sure we force the whole lazy ByteString
+  doChunk c = pseq (LB.length bs) bs
+    where bs = runPut (put c)
+
+  -- We don't have the parallel package, so roll our own simple parMap
+  parMap _ [] = []
+  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
+    where fx = f x; fxs = parMap f xs
+
+addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
+addSptEntry hsc_env fpr ref =
+  withForeignRef ref $ \val ->
+    iservCmd hsc_env (AddSptEntry fpr val)
+
+costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
+costCentreStackInfo hsc_env ccs =
+  iservCmd hsc_env (CostCentreStackInfo ccs)
+
+newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
+newBreakArray hsc_env size = do
+  breakArray <- iservCmd hsc_env (NewBreakArray size)
+  mkFinalizedHValue hsc_env breakArray
+
+enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
+enableBreakpoint hsc_env ref ix b = do
+  withForeignRef ref $ \breakarray ->
+    iservCmd hsc_env (EnableBreakpoint breakarray ix b)
+
+breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
+breakpointStatus hsc_env ref ix = do
+  withForeignRef ref $ \breakarray ->
+    iservCmd hsc_env (BreakpointStatus breakarray ix)
+
+getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
+getBreakpointVar hsc_env ref ix =
+  withForeignRef ref $ \apStack -> do
+    mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
+    mapM (mkFinalizedHValue hsc_env) mb
+
+getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure hsc_env ref =
+  withForeignRef ref $ \hval -> do
+    mb <- iservCmd hsc_env (GetClosure hval)
+    mapM (mkFinalizedHValue hsc_env) mb
+
+seqHValue :: HscEnv -> ForeignHValue -> IO ()
+seqHValue hsc_env ref =
+  withForeignRef ref $ \hval ->
+    iservCmd hsc_env (Seq hval) >>= fromEvalResult
+
+-- -----------------------------------------------------------------------------
+-- Interface to the object-code linker
+
+initObjLinker :: HscEnv -> IO ()
+initObjLinker hsc_env = iservCmd hsc_env InitLinker
+
+lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol hsc_env@HscEnv{..} str
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+     -- Profiling of GHCi showed a lot of time and allocation spent
+     -- making cross-process LookupSymbol calls, so I added a GHC-side
+     -- cache which sped things up quite a lot.  We have to be careful
+     -- to purge this cache when unloading code though.
+     withIServ hsc_env $ \iserv@IServ{..} -> do
+       cache <- readIORef iservLookupSymbolCache
+       case lookupUFM cache str of
+         Just p -> return (Just p)
+         Nothing -> do
+           m <- uninterruptibleMask_ $
+                    iservCall iserv (LookupSymbol (unpackFS str))
+           case m of
+             Nothing -> return Nothing
+             Just r -> do
+               let p = fromRemotePtr r
+               writeIORef iservLookupSymbolCache $! addToUFM cache str p
+               return (Just p)
+ | otherwise =
+#if defined(GHCI)
+   fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+#else
+   needExtInt
+#endif
+
+lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
+lookupClosure hsc_env str =
+  iservCmd hsc_env (LookupClosure str)
+
+purgeLookupSymbolCache :: HscEnv -> IO ()
+purgeLookupSymbolCache hsc_env@HscEnv{..} =
+ when (gopt Opt_ExternalInterpreter hsc_dflags) $
+   withIServ hsc_env $ \IServ{..} ->
+     writeIORef iservLookupSymbolCache emptyUFM
+
+
+-- | loadDLL loads a dynamic library using the OS's native linker
+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
+-- an absolute pathname to the file, or a relative filename
+-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
+-- searches the standard locations for the appropriate library.
+--
+-- Returns:
+--
+-- Nothing      => success
+-- Just err_msg => failure
+loadDLL :: HscEnv -> String -> IO (Maybe String)
+loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
+
+loadArchive :: HscEnv -> String -> IO ()
+loadArchive hsc_env path = do
+  path' <- canonicalizePath path -- Note [loadObj and relative paths]
+  iservCmd hsc_env (LoadArchive path')
+
+loadObj :: HscEnv -> String -> IO ()
+loadObj hsc_env path = do
+  path' <- canonicalizePath path -- Note [loadObj and relative paths]
+  iservCmd hsc_env (LoadObj path')
+
+unloadObj :: HscEnv -> String -> IO ()
+unloadObj hsc_env path = do
+  path' <- canonicalizePath path -- Note [loadObj and relative paths]
+  iservCmd hsc_env (UnloadObj path')
+
+-- Note [loadObj and relative paths]
+-- the iserv process might have a different current directory from the
+-- GHC process, so we must make paths absolute before sending them
+-- over.
+
+addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
+addLibrarySearchPath hsc_env str =
+  fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
+
+removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
+removeLibrarySearchPath hsc_env p =
+  iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
+
+resolveObjs :: HscEnv -> IO SuccessFlag
+resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
+
+findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
+findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
+
+
+-- -----------------------------------------------------------------------------
+-- Raw calls and messages
+
+-- | Send a 'Message' and receive the response from the iserv process
+iservCall :: Binary a => IServ -> Message a -> IO a
+iservCall iserv@IServ{..} msg =
+  remoteCall iservPipe msg
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Read a value from the iserv process
+readIServ :: IServ -> Get a -> IO a
+readIServ iserv@IServ{..} get =
+  readPipe iservPipe get
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Send a value to the iserv process
+writeIServ :: IServ -> Put -> IO ()
+writeIServ iserv@IServ{..} put =
+  writePipe iservPipe put
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+handleIServFailure :: IServ -> SomeException -> IO a
+handleIServFailure IServ{..} e = do
+  ex <- getProcessExitCode iservProcess
+  case ex of
+    Just (ExitFailure n) ->
+      throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
+    _ -> do
+      terminateProcess iservProcess
+      _ <- waitForProcess iservProcess
+      throw e
+
+-- -----------------------------------------------------------------------------
+-- Starting and stopping the iserv process
+
+startIServ :: DynFlags -> IO IServ
+startIServ dflags = do
+  let flavour
+        | WayProf `elem` ways dflags = "-prof"
+        | WayDyn `elem` ways dflags = "-dyn"
+        | otherwise = ""
+      prog = pgm_i dflags ++ flavour
+      opts = getOpts dflags opt_i
+  debugTraceMsg dflags 3 $ text "Starting " <> text prog
+  let createProc = lookupHook createIservProcessHook
+                              (\cp -> do { (_,_,_,ph) <- createProcess cp
+                                         ; return ph })
+                              dflags
+  (ph, rh, wh) <- runWithPipes createProc prog opts
+  lo_ref <- newIORef Nothing
+  cache_ref <- newIORef emptyUFM
+  return $ IServ
+    { iservPipe = Pipe { pipeRead = rh
+                       , pipeWrite = wh
+                       , pipeLeftovers = lo_ref }
+    , iservProcess = ph
+    , iservLookupSymbolCache = cache_ref
+    , iservPendingFrees = []
+    }
+
+stopIServ :: HscEnv -> IO ()
+stopIServ HscEnv{..} =
+  gmask $ \_restore -> do
+    m <- takeMVar hsc_iserv
+    maybe (return ()) stop m
+    putMVar hsc_iserv Nothing
+ where
+  stop iserv = do
+    ex <- getProcessExitCode (iservProcess iserv)
+    if isJust ex
+       then return ()
+       else iservCall iserv Shutdown
+
+runWithPipes :: (CreateProcess -> IO ProcessHandle)
+             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+#if defined(mingw32_HOST_OS)
+foreign import ccall "io.h _close"
+   c__close :: CInt -> IO CInt
+
+foreign import ccall unsafe "io.h _get_osfhandle"
+   _get_osfhandle :: CInt -> IO CInt
+
+runWithPipes createProc prog opts = do
+    (rfd1, wfd1) <- createPipeFd -- we read on rfd1
+    (rfd2, wfd2) <- createPipeFd -- we write on wfd2
+    wh_client    <- _get_osfhandle wfd1
+    rh_client    <- _get_osfhandle rfd2
+    let args = show wh_client : show rh_client : opts
+    ph <- createProc (proc prog args)
+    rh <- mkHandle rfd1
+    wh <- mkHandle wfd2
+    return (ph, rh, wh)
+      where mkHandle :: CInt -> IO Handle
+            mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
+
+#else
+runWithPipes createProc prog opts = do
+    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
+    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
+    setFdOption rfd1 CloseOnExec True
+    setFdOption wfd2 CloseOnExec True
+    let args = show wfd1 : show rfd2 : opts
+    ph <- createProc (proc prog args)
+    closeFd wfd1
+    closeFd rfd2
+    rh <- fdToHandle rfd1
+    wh <- fdToHandle wfd2
+    return (ph, rh, wh)
+#endif
+
+-- -----------------------------------------------------------------------------
+{- Note [External GHCi pointers]
+
+We have the following ways to reference things in GHCi:
+
+HValue
+------
+
+HValue is a direct reference to a value in the local heap.  Obviously
+we cannot use this to refer to things in the external process.
+
+
+RemoteRef
+---------
+
+RemoteRef is a StablePtr to a heap-resident value.  When
+-fexternal-interpreter is used, this value resides in the external
+process's heap.  RemoteRefs are mostly used to send pointers in
+messages between GHC and iserv.
+
+A RemoteRef must be explicitly freed when no longer required, using
+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
+
+To get from a RemoteRef to an HValue you can use 'wormholeRef', which
+fails with an error message if -fexternal-interpreter is in use.
+
+ForeignRef
+----------
+
+A ForeignRef is a RemoteRef with a finalizer that will free the
+'RemoteRef' when it is garbage collected.  We mostly use ForeignHValue
+on the GHC side.
+
+The finalizer adds the RemoteRef to the iservPendingFrees list in the
+IServ record.  The next call to iservCmd will free any RemoteRefs in
+the list.  It was done this way rather than calling iservCmd directly,
+because I didn't want to have arbitrary threads calling iservCmd.  In
+principle it would probably be ok, but it seems less hairy this way.
+-}
+
+-- | Creates a 'ForeignRef' that will automatically release the
+-- 'RemoteRef' when it is no longer referenced.
+mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
+mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
+ where
+  !external = gopt Opt_ExternalInterpreter hsc_dflags
+  hvref = toHValueRef rref
+
+  free :: IO ()
+  free
+    | not external = freeRemoteRef hvref
+    | otherwise =
+      modifyMVar_ hsc_iserv $ \mb_iserv ->
+        case mb_iserv of
+          Nothing -> return Nothing -- already shut down
+          Just iserv@IServ{..} ->
+            return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
+
+freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
+freeHValueRefs _ [] = return ()
+freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
+
+-- | Convert a 'ForeignRef' to the value it references directly.  This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
+wormhole :: DynFlags -> ForeignRef a -> IO a
+wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
+
+-- | Convert an 'RemoteRef' to the value it references directly.  This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
+wormholeRef :: DynFlags -> RemoteRef a -> IO a
+wormholeRef dflags _r
+  | gopt Opt_ExternalInterpreter dflags
+  = throwIO (InstallationError
+      "this operation requires -fno-external-interpreter")
+#if defined(GHCI)
+  | otherwise
+  = localRef _r
+#else
+  | otherwise
+  = throwIO (InstallationError
+      "can't wormhole a value in a stage1 compiler")
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Misc utils
+
+mkEvalOpts :: DynFlags -> Bool -> EvalOpts
+mkEvalOpts dflags step =
+  EvalOpts
+    { useSandboxThread = gopt Opt_GhciSandbox dflags
+    , singleStep = step
+    , breakOnException = gopt Opt_BreakOnException dflags
+    , breakOnError = gopt Opt_BreakOnError dflags }
+
+fromEvalResult :: EvalResult a -> IO a
+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
+fromEvalResult (EvalSuccess a) = return a
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/Linker.hs
@@ -0,0 +1,1664 @@
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+--
+--  (c) The University of Glasgow 2002-2006
+--
+-- | The dynamic linker for GHCi.
+--
+-- This module deals with the top-level issues of dynamic linking,
+-- calling the object-code linker and the byte-code linker where
+-- necessary.
+module Linker ( getHValue, showLinkerState,
+                linkExpr, linkDecls, unload, withExtendedLinkEnv,
+                extendLinkEnv, deleteFromLinkEnv,
+                extendLoadedPkgs,
+                linkPackages, initDynLinker, linkModule,
+                linkCmdLineLibs,
+                uninitializedLinker
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHCi
+import GHCi.RemoteTypes
+import LoadIface
+import ByteCodeLink
+import ByteCodeAsm
+import ByteCodeTypes
+import TcRnMonad
+import Packages
+import DriverPhases
+import Finder
+import HscTypes
+import Name
+import NameEnv
+import Module
+import ListSetOps
+import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..))
+import DynFlags
+import BasicTypes
+import Outputable
+import Panic
+import Util
+import ErrUtils
+import SrcLoc
+import qualified Maybes
+import UniqDSet
+import FastString
+import Platform
+import SysTools
+import FileCleanup
+
+-- Standard libraries
+import Control.Monad
+
+import Data.Char (isSpace)
+import Data.IORef
+import Data.List
+import Data.Maybe
+import Control.Concurrent.MVar
+
+import System.FilePath
+import System.Directory
+import System.IO.Unsafe
+import System.Environment (lookupEnv)
+
+#if defined(mingw32_HOST_OS)
+import System.Win32.Info (getSystemDirectory)
+#endif
+
+import Exception
+
+{- **********************************************************************
+
+                        The Linker's state
+
+  ********************************************************************* -}
+
+{-
+The persistent linker state *must* match the actual state of the
+C dynamic linker at all times.
+
+The MVar used to hold the PersistentLinkerState contains a Maybe
+PersistentLinkerState. The MVar serves to ensure mutual exclusion between
+multiple loaded copies of the GHC library. The Maybe may be Nothing to
+indicate that the linker has not yet been initialised.
+
+The PersistentLinkerState maps Names to actual closures (for
+interpreted code only), for use during linking.
+-}
+
+uninitializedLinker :: IO DynLinker
+uninitializedLinker =
+  newMVar Nothing >>= (pure . DynLinker)
+
+uninitialised :: a
+uninitialised = panic "Dynamic linker not initialised"
+
+modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
+modifyPLS_ dl f =
+  modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised)
+
+modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
+modifyPLS dl f =
+  modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised)
+  where fmapFst f = fmap (\(x, y) -> (f x, y))
+
+readPLS :: DynLinker -> IO PersistentLinkerState
+readPLS dl =
+  (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl)
+
+modifyMbPLS_
+  :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
+modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f 
+
+emptyPLS :: DynFlags -> PersistentLinkerState
+emptyPLS _ = PersistentLinkerState {
+                        closure_env = emptyNameEnv,
+                        itbl_env    = emptyNameEnv,
+                        pkgs_loaded = init_pkgs,
+                        bcos_loaded = [],
+                        objs_loaded = [],
+                        temp_sos = [] }
+
+  -- Packages that don't need loading, because the compiler
+  -- shares them with the interpreted program.
+  --
+  -- The linker's symbol table is populated with RTS symbols using an
+  -- explicit list.  See rts/Linker.c for details.
+  where init_pkgs = map toInstalledUnitId [rtsUnitId]
+
+extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO ()
+extendLoadedPkgs dl pkgs =
+  modifyPLS_ dl $ \s ->
+      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
+
+extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()
+extendLinkEnv dl new_bindings =
+  modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do
+    let new_ce = extendClosureEnv closure_env new_bindings
+    return $! pls{ closure_env = new_ce }
+    -- strictness is important for not retaining old copies of the pls
+
+deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()
+deleteFromLinkEnv dl to_remove =
+  modifyPLS_ dl $ \pls -> do
+    let ce = closure_env pls
+    let new_ce = delListFromNameEnv ce to_remove
+    return pls{ closure_env = new_ce }
+
+-- | Get the 'HValue' associated with the given name.
+--
+-- May cause loading the module that contains the name.
+--
+-- Throws a 'ProgramError' if loading fails or the name cannot be found.
+getHValue :: HscEnv -> Name -> IO ForeignHValue
+getHValue hsc_env name = do
+  let dl = hsc_dynLinker hsc_env
+  initDynLinker hsc_env
+  pls <- modifyPLS dl $ \pls -> do
+           if (isExternalName name) then do
+             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
+                              [nameModule name]
+             if (failed ok) then throwGhcExceptionIO (ProgramError "")
+                            else return (pls', pls')
+            else
+             return (pls, pls)
+  case lookupNameEnv (closure_env pls) name of
+    Just (_,aa) -> return aa
+    Nothing
+        -> ASSERT2(isExternalName name, ppr name)
+           do let sym_to_find = nameToCLabel name "closure"
+              m <- lookupClosure hsc_env (unpackFS sym_to_find)
+              case m of
+                Just hvref -> mkFinalizedHValue hsc_env hvref
+                Nothing -> linkFail "ByteCodeLink.lookupCE"
+                             (unpackFS sym_to_find)
+
+linkDependencies :: HscEnv -> PersistentLinkerState
+                 -> SrcSpan -> [Module]
+                 -> IO (PersistentLinkerState, SuccessFlag)
+linkDependencies hsc_env pls span needed_mods = do
+--   initDynLinker (hsc_dflags hsc_env) dl
+   let hpt = hsc_HPT hsc_env
+       dflags = hsc_dflags hsc_env
+   -- The interpreter and dynamic linker can only handle object code built
+   -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
+   -- So here we check the build tag: if we're building a non-standard way
+   -- then we need to find & link object files built the "normal" way.
+   maybe_normal_osuf <- checkNonStdWay dflags span
+
+   -- Find what packages and linkables are required
+   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
+                               maybe_normal_osuf span needed_mods
+
+   -- Link the packages and modules required
+   pls1 <- linkPackages' hsc_env pkgs pls
+   linkModules hsc_env pls1 lnks
+
+
+-- | Temporarily extend the linker state.
+
+withExtendedLinkEnv :: (ExceptionMonad m) =>
+                       DynLinker -> [(Name,ForeignHValue)] -> m a -> m a
+withExtendedLinkEnv dl new_env action
+    = gbracket (liftIO $ extendLinkEnv dl new_env)
+               (\_ -> reset_old_env)
+               (\_ -> action)
+    where
+        -- Remember that the linker state might be side-effected
+        -- during the execution of the IO action, and we don't want to
+        -- lose those changes (we might have linked a new module or
+        -- package), so the reset action only removes the names we
+        -- added earlier.
+          reset_old_env = liftIO $ do
+            modifyPLS_ dl $ \pls ->
+                let cur = closure_env pls
+                    new = delListFromNameEnv cur (map fst new_env)
+                in return pls{ closure_env = new }
+
+
+-- | Display the persistent linker state.
+showLinkerState :: DynLinker -> DynFlags -> IO ()
+showLinkerState dl dflags
+  = do pls <- readPLS dl
+       putLogMsg dflags NoReason SevDump noSrcSpan
+          (defaultDumpStyle dflags)
+                 (vcat [text "----- Linker state -----",
+                        text "Pkgs:" <+> ppr (pkgs_loaded pls),
+                        text "Objs:" <+> ppr (objs_loaded pls),
+                        text "BCOs:" <+> ppr (bcos_loaded pls)])
+
+
+{- **********************************************************************
+
+                        Initialisation
+
+  ********************************************************************* -}
+
+-- | Initialise the dynamic linker.  This entails
+--
+--  a) Calling the C initialisation procedure,
+--
+--  b) Loading any packages specified on the command line,
+--
+--  c) Loading any packages specified on the command line, now held in the
+--     @-l@ options in @v_Opt_l@,
+--
+--  d) Loading any @.o\/.dll@ files specified on the command line, now held
+--     in @ldInputs@,
+--
+--  e) Loading any MacOS frameworks.
+--
+-- NOTE: This function is idempotent; if called more than once, it does
+-- nothing.  This is useful in Template Haskell, where we call it before
+-- trying to link.
+--
+initDynLinker :: HscEnv -> IO ()
+initDynLinker hsc_env = do
+  let dl = hsc_dynLinker hsc_env
+  modifyMbPLS_ dl $ \pls -> do
+    case pls of
+      Just  _ -> return pls
+      Nothing -> Just <$> reallyInitDynLinker hsc_env
+
+reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
+reallyInitDynLinker hsc_env = do
+  -- Initialise the linker state
+  let dflags = hsc_dflags hsc_env
+      pls0 = emptyPLS dflags
+
+  -- (a) initialise the C dynamic linker
+  initObjLinker hsc_env
+
+  -- (b) Load packages from the command-line (Note [preload packages])
+  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
+
+  -- steps (c), (d) and (e)
+  linkCmdLineLibs' hsc_env pls
+
+
+linkCmdLineLibs :: HscEnv -> IO ()
+linkCmdLineLibs hsc_env = do
+  let dl = hsc_dynLinker hsc_env
+  initDynLinker hsc_env
+  modifyPLS_ dl $ \pls -> do
+    linkCmdLineLibs' hsc_env pls
+
+linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
+linkCmdLineLibs' hsc_env pls =
+  do
+      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
+                           , libraryPaths = lib_paths_base})
+            = hsc_dflags hsc_env
+
+      -- (c) Link libraries from the command-line
+      let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
+
+      -- On Windows we want to add libpthread by default just as GCC would.
+      -- However because we don't know the actual name of pthread's dll we
+      -- need to defer this to the locateLib call so we can't initialize it
+      -- inside of the rts. Instead we do it here to be able to find the
+      -- import library for pthreads. See #13210.
+      let platform = targetPlatform dflags
+          os       = platformOS platform
+          minus_ls = case os of
+                       OSMinGW32 -> "pthread" : minus_ls_1
+                       _         -> minus_ls_1
+      -- See Note [Fork/Exec Windows]
+      gcc_paths <- getGCCPaths dflags os
+
+      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
+
+      maybePutStrLn dflags "Search directories (user):"
+      maybePutStr dflags (unlines $ map ("  "++) lib_paths_env)
+      maybePutStrLn dflags "Search directories (gcc):"
+      maybePutStr dflags (unlines $ map ("  "++) gcc_paths)
+
+      libspecs
+        <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls
+
+      -- (d) Link .o files from the command-line
+      classified_ld_inputs <- mapM (classifyLdInput dflags)
+                                [ f | FileOption _ f <- cmdline_ld_inputs ]
+
+      -- (e) Link any MacOS frameworks
+      let platform = targetPlatform dflags
+      let (framework_paths, frameworks) =
+            if platformUsesFrameworks platform
+             then (frameworkPaths dflags, cmdlineFrameworks dflags)
+              else ([],[])
+
+      -- Finally do (c),(d),(e)
+      let cmdline_lib_specs = catMaybes classified_ld_inputs
+                           ++ libspecs
+                           ++ map Framework frameworks
+      if null cmdline_lib_specs then return pls
+                                else do
+
+      -- Add directories to library search paths, this only has an effect
+      -- on Windows. On Unix OSes this function is a NOP.
+      let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)
+                                : framework_paths
+                               ++ lib_paths_base
+                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
+                      in nub $ map normalise paths
+      let lib_paths = nub $ lib_paths_base ++ gcc_paths
+      all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+
+      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
+                    cmdline_lib_specs
+      maybePutStr dflags "final link ... "
+      ok <- resolveObjs hsc_env
+
+      -- DLLs are loaded, reset the search paths
+      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+
+      if succeeded ok then maybePutStrLn dflags "done"
+      else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
+
+      return pls1
+
+{- Note [preload packages]
+
+Why do we need to preload packages from the command line?  This is an
+explanation copied from #2437:
+
+I tried to implement the suggestion from #3560, thinking it would be
+easy, but there are two reasons we link in packages eagerly when they
+are mentioned on the command line:
+
+  * So that you can link in extra object files or libraries that
+    depend on the packages. e.g. ghc -package foo -lbar where bar is a
+    C library that depends on something in foo. So we could link in
+    foo eagerly if and only if there are extra C libs or objects to
+    link in, but....
+
+  * Haskell code can depend on a C function exported by a package, and
+    the normal dependency tracking that TH uses can't know about these
+    dependencies. The test ghcilink004 relies on this, for example.
+
+I conclude that we need two -package flags: one that says "this is a
+package I want to make available", and one that says "this is a
+package I want to link in eagerly". Would that be too complicated for
+users?
+-}
+
+classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
+classifyLdInput dflags f
+  | isObjectFilename platform f = return (Just (Object f))
+  | isDynLibFilename platform f = return (Just (DLLPath f))
+  | otherwise          = do
+        putLogMsg dflags NoReason SevInfo noSrcSpan
+            (defaultUserStyle dflags)
+            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
+        return Nothing
+    where platform = targetPlatform dflags
+
+preloadLib
+  :: HscEnv -> [String] -> [String] -> PersistentLinkerState
+  -> LibrarySpec -> IO PersistentLinkerState
+preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
+  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
+  case lib_spec of
+    Object static_ish -> do
+      (b, pls1) <- preload_static lib_paths static_ish
+      maybePutStrLn dflags (if b  then "done" else "not found")
+      return pls1
+
+    Archive static_ish -> do
+      b <- preload_static_archive lib_paths static_ish
+      maybePutStrLn dflags (if b  then "done" else "not found")
+      return pls
+
+    DLL dll_unadorned -> do
+      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
+      case maybe_errstr of
+         Nothing -> maybePutStrLn dflags "done"
+         Just mm | platformOS platform /= OSDarwin ->
+           preloadFailed mm lib_paths lib_spec
+         Just mm | otherwise -> do
+           -- As a backup, on Darwin, try to also load a .so file
+           -- since (apparently) some things install that way - see
+           -- ticket #8770.
+           let libfile = ("lib" ++ dll_unadorned) <.> "so"
+           err2 <- loadDLL hsc_env libfile
+           case err2 of
+             Nothing -> maybePutStrLn dflags "done"
+             Just _  -> preloadFailed mm lib_paths lib_spec
+      return pls
+
+    DLLPath dll_path -> do
+      do maybe_errstr <- loadDLL hsc_env dll_path
+         case maybe_errstr of
+            Nothing -> maybePutStrLn dflags "done"
+            Just mm -> preloadFailed mm lib_paths lib_spec
+         return pls
+
+    Framework framework ->
+      if platformUsesFrameworks (targetPlatform dflags)
+      then do maybe_errstr <- loadFramework hsc_env framework_paths framework
+              case maybe_errstr of
+                 Nothing -> maybePutStrLn dflags "done"
+                 Just mm -> preloadFailed mm framework_paths lib_spec
+              return pls
+      else panic "preloadLib Framework"
+
+  where
+    dflags = hsc_dflags hsc_env
+
+    platform = targetPlatform dflags
+
+    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
+    preloadFailed sys_errmsg paths spec
+       = do maybePutStr dflags "failed.\n"
+            throwGhcExceptionIO $
+              CmdLineError (
+                    "user specified .o/.so/.DLL could not be loaded ("
+                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "
+                    ++ showLS spec ++ "\nAdditional directories searched:"
+                    ++ (if null paths then " (none)" else
+                        intercalate "\n" (map ("   "++) paths)))
+
+    -- Not interested in the paths in the static case.
+    preload_static _paths name
+       = do b <- doesFileExist name
+            if not b then return (False, pls)
+                     else if dynamicGhc
+                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
+                                      return (True, pls1)
+                             else  do loadObj hsc_env name
+                                      return (True, pls)
+
+    preload_static_archive _paths name
+       = do b <- doesFileExist name
+            if not b then return False
+                     else do if dynamicGhc
+                                 then throwGhcExceptionIO $
+                                      CmdLineError dynamic_msg
+                                 else loadArchive hsc_env name
+                             return True
+      where
+        dynamic_msg = unlines
+          [ "User-specified static library could not be loaded ("
+            ++ name ++ ")"
+          , "Loading static libraries is not supported in this configuration."
+          , "Try using a dynamic library instead."
+          ]
+
+
+{- **********************************************************************
+
+                        Link a byte-code expression
+
+  ********************************************************************* -}
+
+-- | Link a single expression, /including/ first linking packages and
+-- modules that this expression depends on.
+--
+-- Raises an IO exception ('ProgramError') if it can't find a compiled
+-- version of the dependents to link.
+--
+linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
+linkExpr hsc_env span root_ul_bco
+  = do {
+     -- Initialise the linker (if it's not been done already)
+   ; initDynLinker hsc_env
+
+     -- Extract the DynLinker value for passing into required places
+   ; let dl = hsc_dynLinker hsc_env
+
+     -- Take lock for the actual work.
+   ; modifyPLS dl $ \pls0 -> do {
+
+     -- Link the packages and modules required
+   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
+   ; if failed ok then
+        throwGhcExceptionIO (ProgramError "")
+     else do {
+
+     -- Link the expression itself
+     let ie = itbl_env pls
+         ce = closure_env pls
+
+     -- Link the necessary packages and linkables
+
+   ; let nobreakarray = error "no break array"
+         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
+   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
+   ; [root_hvref] <- createBCOs hsc_env [resolved]
+   ; fhv <- mkFinalizedHValue hsc_env root_hvref
+   ; return (pls, fhv)
+   }}}
+   where
+     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
+
+     needed_mods :: [Module]
+     needed_mods = [ nameModule n | n <- free_names,
+                     isExternalName n,      -- Names from other modules
+                     not (isWiredInName n)  -- Exclude wired-in names
+                   ]                        -- (see note below)
+        -- Exclude wired-in names because we may not have read
+        -- their interface files, so getLinkDeps will fail
+        -- All wired-in names are in the base package, which we link
+        -- by default, so we can safely ignore them here.
+
+dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
+
+
+checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
+checkNonStdWay dflags srcspan
+  | gopt Opt_ExternalInterpreter dflags = return Nothing
+    -- with -fexternal-interpreter we load the .o files, whatever way
+    -- they were built.  If they were built for a non-std way, then
+    -- we will use the appropriate variant of the iserv binary to load them.
+
+  | interpWays == haskellWays = return Nothing
+    -- Only if we are compiling with the same ways as GHC is built
+    -- with, can we dynamically load those object files. (see #3604)
+
+  | objectSuf dflags == normalObjectSuffix && not (null haskellWays)
+  = failNonStd dflags srcspan
+
+  | otherwise = return (Just (interpTag ++ "o"))
+  where
+    haskellWays = filter (not . wayRTSOnly) (ways dflags)
+    interpTag = case mkBuildTag interpWays of
+                  "" -> ""
+                  tag -> tag ++ "_"
+
+normalObjectSuffix :: String
+normalObjectSuffix = phaseInputExt StopLn
+
+failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
+failNonStd dflags srcspan = dieWith dflags srcspan $
+  text "Cannot load" <+> compWay <+>
+     text "objects when GHC is built" <+> ghciWay $$
+  text "To fix this, either:" $$
+  text "  (1) Use -fexternal-interpreter, or" $$
+  text "  (2) Build the program twice: once" <+>
+                       ghciWay <> text ", and then" $$
+  text "      with" <+> compWay <+>
+     text "using -osuf to set a different object file suffix."
+    where compWay
+            | WayDyn `elem` ways dflags = text "-dynamic"
+            | WayProf `elem` ways dflags = text "-prof"
+            | otherwise = text "normal"
+          ghciWay
+            | dynamicGhc = text "with -dynamic"
+            | rtsIsProfiled = text "with -prof"
+            | otherwise = text "the normal way"
+
+getLinkDeps :: HscEnv -> HomePackageTable
+            -> PersistentLinkerState
+            -> Maybe FilePath                   -- replace object suffices?
+            -> SrcSpan                          -- for error messages
+            -> [Module]                         -- If you need these
+            -> IO ([Linkable], [InstalledUnitId])     -- ... then link these first
+-- Fails with an IO exception if it can't find enough files
+
+getLinkDeps hsc_env hpt pls replace_osuf span mods
+-- Find all the packages and linkables that a set of modules depends on
+ = do {
+        -- 1.  Find the dependent home-pkg-modules/packages from each iface
+        -- (omitting modules from the interactive package, which is already linked)
+      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
+                                        emptyUniqDSet emptyUniqDSet;
+
+      ; let {
+        -- 2.  Exclude ones already linked
+        --      Main reason: avoid findModule calls in get_linkable
+            mods_needed = mods_s `minusList` linked_mods     ;
+            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
+
+            linked_mods = map (moduleName.linkableModule)
+                                (objs_loaded pls ++ bcos_loaded pls)  }
+
+        -- 3.  For each dependent module, find its linkable
+        --     This will either be in the HPT or (in the case of one-shot
+        --     compilation) we may need to use maybe_getFileLinkable
+      ; let { osuf = objectSuf dflags }
+      ; lnks_needed <- mapM (get_linkable osuf) mods_needed
+
+      ; return (lnks_needed, pkgs_needed) }
+  where
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+        -- The ModIface contains the transitive closure of the module dependencies
+        -- within the current package, *except* for boot modules: if we encounter
+        -- a boot module, we have to find its real interface and discover the
+        -- dependencies of that.  Hence we need to traverse the dependency
+        -- tree recursively.  See bug #936, testcase ghci/prog007.
+    follow_deps :: [Module]             -- modules to follow
+                -> UniqDSet ModuleName         -- accum. module dependencies
+                -> UniqDSet InstalledUnitId          -- accum. package dependencies
+                -> IO ([ModuleName], [InstalledUnitId]) -- result
+    follow_deps []     acc_mods acc_pkgs
+        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
+    follow_deps (mod:mods) acc_mods acc_pkgs
+        = do
+          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
+                        loadInterface msg mod (ImportByUser False)
+          iface <- case mb_iface of
+                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+                    Maybes.Succeeded iface -> return iface
+
+          when (mi_boot iface) $ link_boot_mod_error mod
+
+          let
+            pkg = moduleUnitId mod
+            deps  = mi_deps iface
+
+            pkg_deps = dep_pkgs deps
+            (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
+                    where is_boot (m,True)  = Left m
+                          is_boot (m,False) = Right m
+
+            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps
+            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
+            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps
+          --
+          if pkg /= this_pkg
+             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
+             else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
+                              acc_mods' acc_pkgs'
+        where
+            msg = text "need to link module" <+> ppr mod <+>
+                  text "due to use of Template Haskell"
+
+
+    link_boot_mod_error mod =
+        throwGhcExceptionIO (ProgramError (showSDoc dflags (
+            text "module" <+> ppr mod <+>
+            text "cannot be linked; it is only available as a boot module")))
+
+    no_obj :: Outputable a => a -> IO b
+    no_obj mod = dieWith dflags span $
+                     text "cannot find object file for module " <>
+                        quotes (ppr mod) $$
+                     while_linking_expr
+
+    while_linking_expr = text "while linking an interpreted expression"
+
+        -- This one is a build-system bug
+
+    get_linkable osuf mod_name      -- A home-package module
+        | Just mod_info <- lookupHpt hpt mod_name
+        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
+        | otherwise
+        = do    -- It's not in the HPT because we are in one shot mode,
+                -- so use the Finder to get a ModLocation...
+             mb_stuff <- findHomeModule hsc_env mod_name
+             case mb_stuff of
+                  Found loc mod -> found loc mod
+                  _ -> no_obj mod_name
+        where
+            found loc mod = do {
+                -- ...and then find the linkable for it
+               mb_lnk <- findObjectLinkableMaybe mod loc ;
+               case mb_lnk of {
+                  Nothing  -> no_obj mod ;
+                  Just lnk -> adjust_linkable lnk
+              }}
+
+            adjust_linkable lnk
+                | Just new_osuf <- replace_osuf = do
+                        new_uls <- mapM (adjust_ul new_osuf)
+                                        (linkableUnlinked lnk)
+                        return lnk{ linkableUnlinked=new_uls }
+                | otherwise =
+                        return lnk
+
+            adjust_ul new_osuf (DotO file) = do
+                MASSERT(osuf `isSuffixOf` file)
+                let file_base = fromJust (stripExtension osuf file)
+                    new_file = file_base <.> new_osuf
+                ok <- doesFileExist new_file
+                if (not ok)
+                   then dieWith dflags span $
+                          text "cannot find object file "
+                                <> quotes (text new_file) $$ while_linking_expr
+                   else return (DotO new_file)
+            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
+            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
+            adjust_ul _ l@(BCOs {}) = return l
+
+
+
+{- **********************************************************************
+
+              Loading a Decls statement
+
+  ********************************************************************* -}
+
+linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
+linkDecls hsc_env span cbc@CompiledByteCode{..} = do
+    -- Initialise the linker (if it's not been done already)
+    initDynLinker hsc_env
+
+    -- Extract the DynLinker for passing into required places
+    let dl = hsc_dynLinker hsc_env
+
+    -- Take lock for the actual work.
+    modifyPLS dl $ \pls0 -> do
+
+    -- Link the packages and modules required
+    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
+    if failed ok
+      then throwGhcExceptionIO (ProgramError "")
+      else do
+
+    -- Link the expression itself
+    let ie = plusNameEnv (itbl_env pls) bc_itbls
+        ce = closure_env pls
+
+    -- Link the necessary packages and linkables
+    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
+    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
+    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
+                   , itbl_env    = ie }
+    return (pls2, ())
+  where
+    free_names = uniqDSetToList $
+      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
+
+    needed_mods :: [Module]
+    needed_mods = [ nameModule n | n <- free_names,
+                    isExternalName n,       -- Names from other modules
+                    not (isWiredInName n)   -- Exclude wired-in names
+                  ]                         -- (see note below)
+    -- Exclude wired-in names because we may not have read
+    -- their interface files, so getLinkDeps will fail
+    -- All wired-in names are in the base package, which we link
+    -- by default, so we can safely ignore them here.
+
+{- **********************************************************************
+
+              Loading a single module
+
+  ********************************************************************* -}
+
+linkModule :: HscEnv -> Module -> IO ()
+linkModule hsc_env mod = do
+  initDynLinker hsc_env
+  let dl = hsc_dynLinker hsc_env
+  modifyPLS_ dl $ \pls -> do
+    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
+    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
+      else return pls'
+
+{- **********************************************************************
+
+                Link some linkables
+        The linkables may consist of a mixture of
+        byte-code modules and object modules
+
+  ********************************************************************* -}
+
+linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
+            -> IO (PersistentLinkerState, SuccessFlag)
+linkModules hsc_env pls linkables
+  = mask_ $ do  -- don't want to be interrupted by ^C in here
+
+        let (objs, bcos) = partition isObjectLinkable
+                              (concatMap partitionLinkable linkables)
+
+                -- Load objects first; they can't depend on BCOs
+        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
+
+        if failed ok_flag then
+                return (pls1, Failed)
+          else do
+                pls2 <- dynLinkBCOs hsc_env pls1 bcos
+                return (pls2, Succeeded)
+
+
+-- HACK to support f-x-dynamic in the interpreter; no other purpose
+partitionLinkable :: Linkable -> [Linkable]
+partitionLinkable li
+   = let li_uls = linkableUnlinked li
+         li_uls_obj = filter isObject li_uls
+         li_uls_bco = filter isInterpretable li_uls
+     in
+         case (li_uls_obj, li_uls_bco) of
+            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
+                           li {linkableUnlinked=li_uls_bco}]
+            _ -> [li]
+
+findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
+findModuleLinkable_maybe lis mod
+   = case [LM time nm us | LM time nm us <- lis, nm == mod] of
+        []   -> Nothing
+        [li] -> Just li
+        _    -> pprPanic "findModuleLinkable" (ppr mod)
+
+linkableInSet :: Linkable -> [Linkable] -> Bool
+linkableInSet l objs_loaded =
+  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
+        Nothing -> False
+        Just m  -> linkableTime l == linkableTime m
+
+
+{- **********************************************************************
+
+                The object-code linker
+
+  ********************************************************************* -}
+
+dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
+            -> IO (PersistentLinkerState, SuccessFlag)
+dynLinkObjs hsc_env pls objs = do
+        -- Load the object files and link them
+        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
+            pls1                     = pls { objs_loaded = objs_loaded' }
+            unlinkeds                = concatMap linkableUnlinked new_objs
+            wanted_objs              = map nameOfObject unlinkeds
+
+        if interpreterDynamic (hsc_dflags hsc_env)
+            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
+                    return (pls2, Succeeded)
+            else do mapM_ (loadObj hsc_env) wanted_objs
+
+                    -- Link them all together
+                    ok <- resolveObjs hsc_env
+
+                    -- If resolving failed, unload all our
+                    -- object modules and carry on
+                    if succeeded ok then do
+                            return (pls1, Succeeded)
+                      else do
+                            pls2 <- unload_wkr hsc_env [] pls1
+                            return (pls2, Failed)
+
+
+dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
+            -> IO PersistentLinkerState
+dynLoadObjs _       pls []   = return pls
+dynLoadObjs hsc_env pls objs = do
+    let dflags = hsc_dflags hsc_env
+    let platform = targetPlatform dflags
+    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
+    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
+    (soFile, libPath , libName) <-
+      newTempLibName dflags TFL_CurrentModule (soExt platform)
+    let
+        dflags2 = dflags {
+                      -- We don't want the original ldInputs in
+                      -- (they're already linked in), but we do want
+                      -- to link against previous dynLoadObjs
+                      -- libraries if there were any, so that the linker
+                      -- can resolve dependencies when it loads this
+                      -- library.
+                      ldInputs =
+                           concatMap (\l -> [ Option ("-l" ++ l) ])
+                                     (nub $ snd <$> temp_sos pls)
+                        ++ concatMap (\lp -> [ Option ("-L" ++ lp)
+                                                    , Option "-Xlinker"
+                                                    , Option "-rpath"
+                                                    , Option "-Xlinker"
+                                                    , Option lp ])
+                                     (nub $ fst <$> temp_sos pls)
+                        ++ concatMap
+                             (\lp ->
+                                 [ Option ("-L" ++ lp)
+                                 , Option "-Xlinker"
+                                 , Option "-rpath"
+                                 , Option "-Xlinker"
+                                 , Option lp
+                                 ])
+                             minus_big_ls
+                        -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+                        ++ map (\l -> Option ("-l" ++ l)) minus_ls,
+                      -- Add -l options and -L options from dflags.
+                      --
+                      -- When running TH for a non-dynamic way, we still
+                      -- need to make -l flags to link against the dynamic
+                      -- libraries, so we need to add WayDyn to ways.
+                      --
+                      -- Even if we're e.g. profiling, we still want
+                      -- the vanilla dynamic libraries, so we set the
+                      -- ways / build tag to be just WayDyn.
+                      ways = [WayDyn],
+                      buildTag = mkBuildTag [WayDyn],
+                      outputFile = Just soFile
+                  }
+    -- link all "loaded packages" so symbols in those can be resolved
+    -- Note: We are loading packages with local scope, so to see the
+    -- symbols in this link we must link all loaded packages again.
+    linkDynLib dflags2 objs (pkgs_loaded pls)
+
+    -- if we got this far, extend the lifetime of the library file
+    changeTempFilesLifetime dflags TFL_GhcSession [soFile]
+    m <- loadDLL hsc_env soFile
+    case m of
+        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
+        Just err -> panic ("Loading temp shared object failed: " ++ err)
+
+rmDupLinkables :: [Linkable]    -- Already loaded
+               -> [Linkable]    -- New linkables
+               -> ([Linkable],  -- New loaded set (including new ones)
+                   [Linkable])  -- New linkables (excluding dups)
+rmDupLinkables already ls
+  = go already [] ls
+  where
+    go already extras [] = (already, extras)
+    go already extras (l:ls)
+        | linkableInSet l already = go already     extras     ls
+        | otherwise               = go (l:already) (l:extras) ls
+
+{- **********************************************************************
+
+                The byte-code linker
+
+  ********************************************************************* -}
+
+
+dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]
+            -> IO PersistentLinkerState
+dynLinkBCOs hsc_env pls bcos = do
+
+        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
+            pls1                     = pls { bcos_loaded = bcos_loaded' }
+            unlinkeds :: [Unlinked]
+            unlinkeds                = concatMap linkableUnlinked new_bcos
+
+            cbcs :: [CompiledByteCode]
+            cbcs      = map byteCodeOfObject unlinkeds
+
+
+            ies        = map bc_itbls cbcs
+            gce       = closure_env pls
+            final_ie  = foldr plusNameEnv (itbl_env pls) ies
+
+        names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs
+
+        -- We only want to add the external ones to the ClosureEnv
+        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
+
+        -- Immediately release any HValueRefs we're not going to add
+        freeHValueRefs hsc_env (map snd to_drop)
+        -- Wrap finalizers on the ones we want to keep
+        new_binds <- makeForeignNamedHValueRefs hsc_env to_add
+
+        return pls1 { closure_env = extendClosureEnv gce new_binds,
+                      itbl_env    = final_ie }
+
+-- Link a bunch of BCOs and return references to their values
+linkSomeBCOs :: HscEnv
+             -> ItblEnv
+             -> ClosureEnv
+             -> [CompiledByteCode]
+             -> IO [(Name,HValueRef)]
+                        -- The returned HValueRefs are associated 1-1 with
+                        -- the incoming unlinked BCOs.  Each gives the
+                        -- value of the corresponding unlinked BCO
+
+linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
+ where
+  fun CompiledByteCode{..} inner accum =
+    case bc_breaks of
+      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)
+      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->
+                   inner ((breakarray, bc_bcos) : accum)
+
+  do_link [] = return []
+  do_link mods = do
+    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
+        names = map (unlinkedBCOName . snd) flat
+        bco_ix = mkNameEnv (zip names [0..])
+    resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco
+                         | (breakarray, bco) <- flat ]
+    hvrefs <- createBCOs hsc_env resolved
+    return (zip names hvrefs)
+
+-- | Useful to apply to the result of 'linkSomeBCOs'
+makeForeignNamedHValueRefs
+  :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
+makeForeignNamedHValueRefs hsc_env bindings =
+  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings
+
+{- **********************************************************************
+
+                Unload some object modules
+
+  ********************************************************************* -}
+
+-- ---------------------------------------------------------------------------
+-- | Unloading old objects ready for a new compilation sweep.
+--
+-- The compilation manager provides us with a list of linkables that it
+-- considers \"stable\", i.e. won't be recompiled this time around.  For
+-- each of the modules current linked in memory,
+--
+--   * if the linkable is stable (and it's the same one -- the user may have
+--     recompiled the module on the side), we keep it,
+--
+--   * otherwise, we unload it.
+--
+--   * we also implicitly unload all temporary bindings at this point.
+--
+unload :: HscEnv
+       -> [Linkable] -- ^ The linkables to *keep*.
+       -> IO ()
+unload hsc_env linkables
+  = mask_ $ do -- mask, so we're safe from Ctrl-C in here
+
+        -- Initialise the linker (if it's not been done already)
+        initDynLinker hsc_env
+
+        -- Extract DynLinker for passing into required places
+        let dl = hsc_dynLinker hsc_env
+
+        new_pls
+            <- modifyPLS dl $ \pls -> do
+                 pls1 <- unload_wkr hsc_env linkables pls
+                 return (pls1, pls1)
+
+        let dflags = hsc_dflags hsc_env
+        debugTraceMsg dflags 3 $
+          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
+        debugTraceMsg dflags 3 $
+          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
+        return ()
+
+unload_wkr :: HscEnv
+           -> [Linkable]                -- stable linkables
+           -> PersistentLinkerState
+           -> IO PersistentLinkerState
+-- Does the core unload business
+-- (the wrapper blocks exceptions and deals with the PLS get and put)
+
+unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..}  = do
+  -- NB. careful strictness here to avoid keeping the old PLS when
+  -- we're unloading some code.  -fghci-leak-check with the tests in
+  -- testsuite/ghci can detect space leaks here.
+
+  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
+
+      discard keep l = not (linkableInSet l keep)
+
+      (objs_to_unload, remaining_objs_loaded) =
+         partition (discard objs_to_keep) objs_loaded
+      (bcos_to_unload, remaining_bcos_loaded) =
+         partition (discard bcos_to_keep) bcos_loaded
+
+  mapM_ unloadObjs objs_to_unload
+  mapM_ unloadObjs bcos_to_unload
+
+  -- If we unloaded any object files at all, we need to purge the cache
+  -- of lookupSymbol results.
+  when (not (null (objs_to_unload ++
+                   filter (not . null . linkableObjs) bcos_to_unload))) $
+    purgeLookupSymbolCache hsc_env
+
+  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
+
+      -- Note that we want to remove all *local*
+      -- (i.e. non-isExternal) names too (these are the
+      -- temporary bindings from the command line).
+      keep_name (n,_) = isExternalName n &&
+                        nameModule n `elemModuleSet` bcos_retained
+
+      itbl_env'     = filterNameEnv keep_name itbl_env
+      closure_env'  = filterNameEnv keep_name closure_env
+
+      !new_pls = pls { itbl_env = itbl_env',
+                       closure_env = closure_env',
+                       bcos_loaded = remaining_bcos_loaded,
+                       objs_loaded = remaining_objs_loaded }
+
+  return new_pls
+  where
+    unloadObjs :: Linkable -> IO ()
+    unloadObjs lnk
+      | dynamicGhc = return ()
+        -- We don't do any cleanup when linking objects with the
+        -- dynamic linker.  Doing so introduces extra complexity for
+        -- not much benefit.
+      | otherwise
+      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]
+                -- The components of a BCO linkable may contain
+                -- dot-o files.  Which is very confusing.
+                --
+                -- But the BCO parts can be unlinked just by
+                -- letting go of them (plus of course depopulating
+                -- the symbol table which is done in the main body)
+
+{- **********************************************************************
+
+                Loading packages
+
+  ********************************************************************* -}
+
+data LibrarySpec
+   = Object FilePath    -- Full path name of a .o file, including trailing .o
+                        -- For dynamic objects only, try to find the object
+                        -- file in all the directories specified in
+                        -- v_Library_paths before giving up.
+
+   | Archive FilePath   -- Full path name of a .a file, including trailing .a
+
+   | DLL String         -- "Unadorned" name of a .DLL/.so
+                        --  e.g.    On unix     "qt"  denotes "libqt.so"
+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"
+                        --  loadDLL is platform-specific and adds the lib/.so/.DLL
+                        --  suffixes platform-dependently
+
+   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library
+                        -- (ends with .dll or .so).
+
+   | Framework String   -- Only used for darwin, but does no harm
+
+-- If this package is already part of the GHCi binary, we'll already
+-- have the right DLLs for this package loaded, so don't try to
+-- load them again.
+--
+-- But on Win32 we must load them 'again'; doing so is a harmless no-op
+-- as far as the loader is concerned, but it does initialise the list
+-- of DLL handles that rts/Linker.c maintains, and that in turn is
+-- used by lookupSymbol.  So we must call addDLL for each library
+-- just to get the DLL handle into the list.
+partOfGHCi :: [PackageName]
+partOfGHCi
+ | isWindowsHost || isDarwinHost = []
+ | otherwise = map (PackageName . mkFastString)
+                   ["base", "template-haskell", "editline"]
+
+showLS :: LibrarySpec -> String
+showLS (Object nm)    = "(static) " ++ nm
+showLS (Archive nm)   = "(static archive) " ++ nm
+showLS (DLL nm)       = "(dynamic) " ++ nm
+showLS (DLLPath nm)   = "(dynamic) " ++ nm
+showLS (Framework nm) = "(framework) " ++ nm
+
+-- | Link exactly the specified packages, and their dependents (unless of
+-- course they are already linked).  The dependents are linked
+-- automatically, and it doesn't matter what order you specify the input
+-- packages.
+--
+linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()
+-- NOTE: in fact, since each module tracks all the packages it depends on,
+--       we don't really need to use the package-config dependencies.
+--
+-- However we do need the package-config stuff (to find aux libs etc),
+-- and following them lets us load libraries in the right order, which
+-- perhaps makes the error message a bit more localised if we get a link
+-- failure.  So the dependency walking code is still here.
+
+linkPackages hsc_env new_pkgs = do
+  -- It's probably not safe to try to load packages concurrently, so we take
+  -- a lock.
+  initDynLinker hsc_env
+  let dl = hsc_dynLinker hsc_env
+  modifyPLS_ dl $ \pls -> do
+    linkPackages' hsc_env new_pkgs pls
+
+linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
+             -> IO PersistentLinkerState
+linkPackages' hsc_env new_pks pls = do
+    pkgs' <- link (pkgs_loaded pls) new_pks
+    return $! pls { pkgs_loaded = pkgs' }
+  where
+     dflags = hsc_dflags hsc_env
+
+     link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]
+     link pkgs new_pkgs =
+         foldM link_one pkgs new_pkgs
+
+     link_one pkgs new_pkg
+        | new_pkg `elem` pkgs   -- Already linked
+        = return pkgs
+
+        | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg
+        = do {  -- Link dependents first
+               pkgs' <- link pkgs (depends pkg_cfg)
+                -- Now link the package itself
+             ; linkPackage hsc_env pkg_cfg
+             ; return (new_pkg : pkgs') }
+
+        | otherwise
+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))
+
+
+linkPackage :: HscEnv -> PackageConfig -> IO ()
+linkPackage hsc_env pkg
+   = do
+        let dflags    = hsc_dflags hsc_env
+            platform  = targetPlatform dflags
+            is_dyn = interpreterDynamic dflags
+            dirs | is_dyn    = Packages.libraryDynDirs pkg
+                 | otherwise = Packages.libraryDirs pkg
+
+        let hs_libs   =  Packages.hsLibraries pkg
+            -- The FFI GHCi import lib isn't needed as
+            -- compiler/ghci/Linker.hs + rts/Linker.c link the
+            -- interpreted references to FFI to the compiled FFI.
+            -- We therefore filter it out so that we don't get
+            -- duplicate symbol errors.
+            hs_libs'  =  filter ("HSffi" /=) hs_libs
+
+        -- Because of slight differences between the GHC dynamic linker and
+        -- the native system linker some packages have to link with a
+        -- different list of libraries when using GHCi. Examples include: libs
+        -- that are actually gnu ld scripts, and the possibility that the .a
+        -- libs do not exactly match the .so/.dll equivalents. So if the
+        -- package file provides an "extra-ghci-libraries" field then we use
+        -- that instead of the "extra-libraries" field.
+            extra_libs =
+                      (if null (Packages.extraGHCiLibraries pkg)
+                            then Packages.extraLibraries pkg
+                            else Packages.extraGHCiLibraries pkg)
+                      ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
+        -- See Note [Fork/Exec Windows]
+        gcc_paths <- getGCCPaths dflags (platformOS platform)
+        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
+
+        hs_classifieds
+           <- mapM (locateLib hsc_env True  dirs_env gcc_paths) hs_libs'
+        extra_classifieds
+           <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs
+        let classifieds = hs_classifieds ++ extra_classifieds
+
+        -- Complication: all the .so's must be loaded before any of the .o's.
+        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]
+            dlls       = [ dll  | DLL dll        <- classifieds ]
+            objs       = [ obj  | Object obj     <- classifieds ]
+            archs      = [ arch | Archive arch   <- classifieds ]
+
+        -- Add directories to library search paths
+        let dll_paths  = map takeDirectory known_dlls
+            all_paths  = nub $ map normalise $ dll_paths ++ dirs
+        all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+
+        maybePutStr dflags
+            ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
+
+        -- See comments with partOfGHCi
+        when (packageName pkg `notElem` partOfGHCi) $ do
+            loadFrameworks hsc_env platform pkg
+            -- See Note [Crash early load_dyn and locateLib]
+            -- Crash early if can't load any of `known_dlls`
+            mapM_ (load_dyn hsc_env True) known_dlls
+            -- For remaining `dlls` crash early only when there is surely
+            -- no package's DLL around ... (not is_dyn)
+            mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls
+
+        -- After loading all the DLLs, we can load the static objects.
+        -- Ordering isn't important here, because we do one final link
+        -- step to resolve everything.
+        mapM_ (loadObj hsc_env) objs
+        mapM_ (loadArchive hsc_env) archs
+
+        maybePutStr dflags "linking ... "
+        ok <- resolveObjs hsc_env
+
+        -- DLLs are loaded, reset the search paths
+        -- Import libraries will be loaded via loadArchive so only
+        -- reset the DLL search path after all archives are loaded
+        -- as well.
+        mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+
+        if succeeded ok
+           then maybePutStrLn dflags "done."
+           else let errmsg = "unable to load package `"
+                             ++ sourcePackageIdString pkg ++ "'"
+                 in throwGhcExceptionIO (InstallationError errmsg)
+
+{-
+Note [Crash early load_dyn and locateLib]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a package is "normal" (exposes it's code from more than zero Haskell
+modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then
+it has it's code compiled and linked into the DLL, which GHCi linker picks
+when loading the package's code (see the big comment in the beginning of
+`locateLib`).
+
+When loading DLLs, GHCi linker simply calls the system's `dlopen` or
+`LoadLibrary` APIs. This is quite different from the case when GHCi linker
+loads an object file or static library. When loading an object file or static
+library GHCi linker parses them and resolves all symbols "manually".
+These object file or static library may reference some external symbols
+defined in some external DLLs. And GHCi should know which these
+external DLLs are.
+
+But when GHCi loads a DLL, it's the *system* linker who manages all
+the necessary dependencies, and it is able to load this DLL not having
+any extra info. Thus we don't *have to* crash in this case even if we
+are unable to load any supposed dependencies explicitly.
+
+Suppose during GHCi session a client of the package wants to
+`foreign import` a symbol which isn't exposed by the package DLL, but
+is exposed by such an external (dependency) DLL.
+If the DLL isn't *explicitly* loaded because `load_dyn` failed to do
+this, then the client code eventually crashes because the GHCi linker
+isn't able to locate this symbol (GHCi linker maintains a list of
+explicitly loaded DLLs it looks into when trying to find a symbol).
+
+This is why we still should try to load all the dependency DLLs
+even though we know that the system linker loads them implicitly when
+loading the package DLL.
+
+Why we still keep the `crash_early` opportunity then not allowing such
+a permissive behaviour for any DLLs? Well, we, perhaps, improve a user
+experience in some cases slightly.
+
+But if it happens there exist other corner cases where our current
+usage of `crash_early` flag is overly restrictive, we may lift the
+restriction very easily.
+-}
+
+-- we have already searched the filesystem; the strings passed to load_dyn
+-- can be passed directly to loadDLL.  They are either fully-qualified
+-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,
+-- loadDLL is going to search the system paths to find the library.
+load_dyn :: HscEnv -> Bool -> FilePath -> IO ()
+load_dyn hsc_env crash_early dll = do
+  r <- loadDLL hsc_env dll
+  case r of
+    Nothing  -> return ()
+    Just err ->
+      if crash_early
+        then cmdLineErrorIO err
+        else let dflags = hsc_dflags hsc_env in
+          when (wopt Opt_WarnMissedExtraSharedLib dflags)
+            $ putLogMsg dflags
+                (Reason Opt_WarnMissedExtraSharedLib) SevWarning
+                  noSrcSpan (defaultUserStyle dflags)(note err)
+  where
+    note err = vcat $ map text
+      [ err
+      , "It's OK if you don't want to use symbols from it directly."
+      , "(the package DLL is loaded by the system linker"
+      , " which manages dependencies by itself)." ]
+
+loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
+loadFrameworks hsc_env platform pkg
+    = when (platformUsesFrameworks platform) $ mapM_ load frameworks
+  where
+    fw_dirs    = Packages.frameworkDirs pkg
+    frameworks = Packages.frameworks pkg
+
+    load fw = do  r <- loadFramework hsc_env fw_dirs fw
+                  case r of
+                    Nothing  -> return ()
+                    Just err -> cmdLineErrorIO ("can't load framework: "
+                                                ++ fw ++ " (" ++ err ++ ")" )
+
+-- Try to find an object file for a given library in the given paths.
+-- If it isn't present, we assume that addDLL in the RTS can find it,
+-- which generally means that it should be a dynamic library in the
+-- standard system search path.
+-- For GHCi we tend to prefer dynamic libraries over static ones as
+-- they are easier to load and manage, have less overhead.
+locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String
+          -> IO LibrarySpec
+locateLib hsc_env is_hs lib_dirs gcc_dirs lib
+  | not is_hs
+    -- For non-Haskell libraries (e.g. gmp, iconv):
+    --   first look in library-dirs for a dynamic library (on User paths only)
+    --   (libfoo.so)
+    --   then  try looking for import libraries on Windows (on User paths only)
+    --   (.dll.a, .lib)
+    --   first look in library-dirs for a dynamic library (on GCC paths only)
+    --   (libfoo.so)
+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)
+    --   then  try looking for import libraries on Windows (on GCC paths only)
+    --   (.dll.a, .lib)
+    --   then  look in library-dirs for a static library (libfoo.a)
+    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
+    --   then  try looking for import libraries on Windows (.dll.a, .lib)
+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)
+    --   then  try "gcc --print-file-name" to search gcc's search path
+    --       for a dynamic library (#5289)
+    --   otherwise, assume loadDLL can find it
+    --
+    --   The logic is a bit complicated, but the rationale behind it is that
+    --   loading a shared library for us is O(1) while loading an archive is
+    --   O(n). Loading an import library is also O(n) so in general we prefer
+    --   shared libraries because they are simpler and faster.
+    --
+  = findDll   user `orElse`
+    tryImpLib user `orElse`
+    findDll   gcc  `orElse`
+    findSysDll     `orElse`
+    tryImpLib gcc  `orElse`
+    findArchive    `orElse`
+    tryGcc         `orElse`
+    assumeDll
+
+  | loading_dynamic_hs_libs -- search for .so libraries first.
+  = findHSDll     `orElse`
+    findDynObject `orElse`
+    assumeDll
+
+  | otherwise
+    -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a
+  = findObject  `orElse`
+    findArchive `orElse`
+    assumeDll
+
+   where
+     dflags = hsc_dflags hsc_env
+     dirs   = lib_dirs ++ gcc_dirs
+     gcc    = False
+     user   = True
+
+     obj_file
+       | is_hs && loading_profiled_hs_libs = lib <.> "p_o"
+       | otherwise = lib <.> "o"
+     dyn_obj_file = lib <.> "dyn_o"
+     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
+                  , lib <.> "a" -- native code has no lib_tag
+                  , "lib" ++ lib, lib
+                  ]
+     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
+
+     loading_profiled_hs_libs = interpreterProfiled dflags
+     loading_dynamic_hs_libs  = interpreterDynamic dflags
+
+     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"
+                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
+                    ]
+
+     hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
+     hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
+
+     so_name     = mkSOName platform lib
+     lib_so_name = "lib" ++ so_name
+     dyn_lib_file = case (arch, os) of
+                             (ArchX86_64, OSSolaris2) -> "64" </> so_name
+                             _ -> so_name
+
+     findObject    = liftM (fmap Object)  $ findFile dirs obj_file
+     findDynObject = liftM (fmap Object)  $ findFile dirs dyn_obj_file
+     findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name
+                     in  apply (map local arch_files)
+     findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
+     findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs
+                     in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
+     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $
+                        findSystemLibrary hsc_env so_name
+     tryGcc        = let search   = searchForLibUsingGcc dflags
+                         dllpath  = liftM (fmap DLLPath)
+                         short    = dllpath $ search so_name lib_dirs
+                         full     = dllpath $ search lib_so_name lib_dirs
+                         gcc name = liftM (fmap Archive) $ search name lib_dirs
+                         files    = import_libs ++ arch_files
+                     in apply $ short : full : map gcc files
+     tryImpLib re = case os of
+                       OSMinGW32 ->
+                        let dirs' = if re == user then lib_dirs else gcc_dirs
+                            implib name = liftM (fmap Archive) $
+                                            findFile dirs' name
+                        in apply (map implib import_libs)
+                       _         -> return Nothing
+
+     assumeDll   = return (DLL lib)
+     infixr `orElse`
+     f `orElse` g = f >>= maybe g return
+
+     apply []     = return Nothing
+     apply (x:xs) = do x' <- x
+                       if isJust x'
+                          then return x'
+                          else apply xs
+
+     platform = targetPlatform dflags
+     arch = platformArch platform
+     os = platformOS platform
+
+searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
+searchForLibUsingGcc dflags so dirs = do
+   -- GCC does not seem to extend the library search path (using -L) when using
+   -- --print-file-name. So instead pass it a new base location.
+   str <- askLd dflags (map (FileOption "-B") dirs
+                          ++ [Option "--print-file-name", Option so])
+   let file = case lines str of
+                []  -> ""
+                l:_ -> l
+   if (file == so)
+      then return Nothing
+      else do b <- doesFileExist file -- file could be a folder (see #16063)
+              return (if b then Just file else Nothing)
+
+-- | Retrieve the list of search directory GCC and the System use to find
+--   libraries and components. See Note [Fork/Exec Windows].
+getGCCPaths :: DynFlags -> OS -> IO [FilePath]
+getGCCPaths dflags os
+  = case os of
+      OSMinGW32 ->
+        do gcc_dirs <- getGccSearchDirectory dflags "libraries"
+           sys_dirs <- getSystemDirectories
+           return $ nub $ gcc_dirs ++ sys_dirs
+      _         -> return []
+
+-- | Cache for the GCC search directories as this can't easily change
+--   during an invocation of GHC. (Maybe with some env. variable but we'll)
+--   deal with that highly unlikely scenario then.
+{-# NOINLINE gccSearchDirCache #-}
+gccSearchDirCache :: IORef [(String, [String])]
+gccSearchDirCache = unsafePerformIO $ newIORef []
+
+-- Note [Fork/Exec Windows]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+-- fork/exec is expensive on Windows, for each time we ask GCC for a library we
+-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
+-- So instead get a list of location that GCC would search and use findDirs
+-- which hopefully is written in an optimized mannor to take advantage of
+-- caching. At the very least we remove the overhead of the fork/exec and waits
+-- which dominate a large percentage of startup time on Windows.
+getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]
+getGccSearchDirectory dflags key = do
+    cache <- readIORef gccSearchDirCache
+    case lookup key cache of
+      Just x  -> return x
+      Nothing -> do
+        str <- askLd dflags [Option "--print-search-dirs"]
+        let line = dropWhile isSpace str
+            name = key ++ ": ="
+        if null line
+          then return []
+          else do let val = split $ find name line
+                  dirs <- filterM doesDirectoryExist val
+                  modifyIORef' gccSearchDirCache ((key, dirs):)
+                  return val
+      where split :: FilePath -> [FilePath]
+            split r = case break (==';') r of
+                        (s, []    ) -> [s]
+                        (s, (_:xs)) -> s : split xs
+
+            find :: String -> String -> String
+            find r x = let lst = lines x
+                           val = filter (r `isPrefixOf`) lst
+                       in if null val
+                             then []
+                             else case break (=='=') (head val) of
+                                     (_ , [])    -> []
+                                     (_, (_:xs)) -> xs
+
+-- | Get a list of system search directories, this to alleviate pressure on
+-- the findSysDll function.
+getSystemDirectories :: IO [FilePath]
+#if defined(mingw32_HOST_OS)
+getSystemDirectories = fmap (:[]) getSystemDirectory
+#else
+getSystemDirectories = return []
+#endif
+
+-- | Merge the given list of paths with those in the environment variable
+--   given. If the variable does not exist then just return the identity.
+addEnvPaths :: String -> [String] -> IO [String]
+addEnvPaths name list
+  = do -- According to POSIX (chapter 8.3) a zero-length prefix means current
+       -- working directory. Replace empty strings in the env variable with
+       -- `working_dir` (see also #14695).
+       working_dir <- getCurrentDirectory
+       values <- lookupEnv name
+       case values of
+         Nothing  -> return list
+         Just arr -> return $ list ++ splitEnv working_dir arr
+    where
+      splitEnv :: FilePath -> String -> [String]
+      splitEnv working_dir value =
+        case break (== envListSep) value of
+          (x, []    ) ->
+            [if null x then working_dir else x]
+          (x, (_:xs)) ->
+            (if null x then working_dir else x) : splitEnv working_dir xs
+#if defined(mingw32_HOST_OS)
+      envListSep = ';'
+#else
+      envListSep = ':'
+#endif
+
+-- ----------------------------------------------------------------------------
+-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
+
+-- Darwin / MacOS X only: load a framework
+-- a framework is a dynamic library packaged inside a directory of the same
+-- name. They are searched for in different paths than normal libraries.
+loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
+loadFramework hsc_env extraPaths rootname
+   = do { either_dir <- tryIO getHomeDirectory
+        ; let homeFrameworkPath = case either_dir of
+                                  Left _ -> []
+                                  Right dir -> [dir </> "Library/Frameworks"]
+              ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
+        ; mb_fwk <- findFile ps fwk_file
+        ; case mb_fwk of
+            Just fwk_path -> loadDLL hsc_env fwk_path
+            Nothing       -> return (Just "not found") }
+                -- Tried all our known library paths, but dlopen()
+                -- has no built-in paths for frameworks: give up
+   where
+     fwk_file = rootname <.> "framework" </> rootname
+        -- sorry for the hardcoded paths, I hope they won't change anytime soon:
+     defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
+
+{- **********************************************************************
+
+                Helper functions
+
+  ********************************************************************* -}
+
+maybePutStr :: DynFlags -> String -> IO ()
+maybePutStr dflags s
+    = when (verbosity dflags > 1) $
+          putLogMsg dflags
+              NoReason
+              SevInteractive
+              noSrcSpan
+              (defaultUserStyle dflags)
+              (text s)
+
+maybePutStrLn :: DynFlags -> String -> IO ()
+maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -0,0 +1,1355 @@
+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHC Interactive support for inspecting arbitrary closures at runtime
+--
+-- Pepe Iborra (supported by Google SoC) 2006
+--
+-----------------------------------------------------------------------------
+module RtClosureInspect(
+     -- * Entry points and types
+     cvObtainTerm,
+     cvReconstructType,
+     improveRTTIType,
+     Term(..),
+
+     -- * Utils
+     isFullyEvaluatedTerm,
+     termType, mapTermType, termTyCoVars,
+     foldTerm, TermFold(..),
+     cPprTerm, cPprTermBase,
+
+     constrClosToName -- exported to use in test T4891
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHCi
+import GHCi.RemoteTypes
+import HscTypes
+
+import DataCon
+import Type
+import RepType
+import qualified Unify as U
+import Var
+import TcRnMonad
+import TcType
+import TcMType
+import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
+import TcUnify
+import TcEnv
+
+import TyCon
+import Name
+import OccName
+import Module
+import IfaceEnv
+import Util
+import VarSet
+import BasicTypes       ( Boxity(..) )
+import TysPrim
+import PrelNames
+import TysWiredIn
+import DynFlags
+import Outputable as Ppr
+import GHC.Char
+import GHC.Exts.Heap
+import SMRep ( roundUpTo )
+
+import Control.Monad
+import Data.Maybe
+import Data.List
+#if defined(INTEGER_GMP)
+import GHC.Exts
+import Data.Array.Base
+import GHC.Integer.GMP.Internals
+#elif defined(INTEGER_SIMPLE)
+import GHC.Exts
+import GHC.Integer.Simple.Internals
+#endif
+import qualified Data.Sequence as Seq
+import Data.Sequence (viewl, ViewL(..))
+import Foreign
+import System.IO.Unsafe
+
+
+---------------------------------------------
+-- * A representation of semi evaluated Terms
+---------------------------------------------
+
+data Term = Term { ty        :: RttiType
+                 , dc        :: Either String DataCon
+                               -- Carries a text representation if the datacon is
+                               -- not exported by the .hi file, which is the case
+                               -- for private constructors in -O0 compiled libraries
+                 , val       :: ForeignHValue
+                 , subTerms  :: [Term] }
+
+          | Prim { ty        :: RttiType
+                 , valRaw    :: [Word] }
+
+          | Suspension { ctype    :: ClosureType
+                       , ty       :: RttiType
+                       , val      :: ForeignHValue
+                       , bound_to :: Maybe Name   -- Useful for printing
+                       }
+          | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
+                               -- newtype constructors. A NewtypeWrap is just a
+                               -- made-up tag saying "heads up, there used to be
+                               -- a newtype constructor here".
+                         ty           :: RttiType
+                       , dc           :: Either String DataCon
+                       , wrapped_term :: Term }
+          | RefWrap    {       -- The contents of a reference
+                         ty           :: RttiType
+                       , wrapped_term :: Term }
+
+termType :: Term -> RttiType
+termType t = ty t
+
+isFullyEvaluatedTerm :: Term -> Bool
+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
+isFullyEvaluatedTerm Prim {}            = True
+isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
+isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
+isFullyEvaluatedTerm _                  = False
+
+instance Outputable (Term) where
+ ppr t | Just doc <- cPprTerm cPprTermBase t = doc
+       | otherwise = panic "Outputable Term instance"
+
+----------------------------------------
+-- Runtime Closure information functions
+----------------------------------------
+
+isThunk :: GenClosure a -> Bool
+isThunk ThunkClosure{} = True
+isThunk APClosure{} = True
+isThunk APStackClosure{} = True
+isThunk _             = False
+
+-- Lookup the name in a constructor closure
+constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
+constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
+   let occName = mkOccName OccName.dataName occ
+       modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
+   Right `fmap` lookupOrigIO hsc_env modName occName
+constrClosToName _hsc_env clos =
+   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
+
+-----------------------------------
+-- * Traversals for Terms
+-----------------------------------
+type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
+
+data TermFold a = TermFold { fTerm        :: TermProcessor a a
+                           , fPrim        :: RttiType -> [Word] -> a
+                           , fSuspension  :: ClosureType -> RttiType -> ForeignHValue
+                                            -> Maybe Name -> a
+                           , fNewtypeWrap :: RttiType -> Either String DataCon
+                                            -> a -> a
+                           , fRefWrap     :: RttiType -> a -> a
+                           }
+
+
+data TermFoldM m a =
+                   TermFoldM {fTermM        :: TermProcessor a (m a)
+                            , fPrimM        :: RttiType -> [Word] -> m a
+                            , fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue
+                                             -> Maybe Name -> m a
+                            , fNewtypeWrapM :: RttiType -> Either String DataCon
+                                            -> a -> m a
+                            , fRefWrapM     :: RttiType -> a -> m a
+                           }
+
+foldTerm :: TermFold a -> Term -> a
+foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
+foldTerm tf (Prim ty    v   ) = fPrim tf ty v
+foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
+foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
+foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
+
+
+foldTermM :: Monad m => TermFoldM m a -> Term -> m a
+foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
+foldTermM tf (Prim ty    v   ) = fPrimM tf ty v
+foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
+foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc
+foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty
+
+idTermFold :: TermFold Term
+idTermFold = TermFold {
+              fTerm = Term,
+              fPrim = Prim,
+              fSuspension  = Suspension,
+              fNewtypeWrap = NewtypeWrap,
+              fRefWrap = RefWrap
+                      }
+
+mapTermType :: (RttiType -> Type) -> Term -> Term
+mapTermType f = foldTerm idTermFold {
+          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
+          fSuspension = \ct ty hval n ->
+                          Suspension ct (f ty) hval n,
+          fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
+          fRefWrap    = \ty t -> RefWrap (f ty) t}
+
+mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term
+mapTermTypeM f = foldTermM TermFoldM {
+          fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,
+          fPrimM       = (return.) . Prim,
+          fSuspensionM = \ct ty hval n ->
+                          f ty >>= \ty' -> return $ Suspension ct ty' hval n,
+          fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
+          fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
+
+termTyCoVars :: Term -> TyCoVarSet
+termTyCoVars = foldTerm TermFold {
+            fTerm       = \ty _ _ tt   ->
+                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
+            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
+            fPrim       = \ _ _ -> emptyVarSet,
+            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
+            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
+    where concatVarEnv = foldr unionVarSet emptyVarSet
+
+----------------------------------
+-- Pretty printing of terms
+----------------------------------
+
+type Precedence        = Int
+type TermPrinterM m    = Precedence -> Term -> m SDoc
+
+app_prec,cons_prec, max_prec ::Int
+max_prec  = 10
+app_prec  = max_prec
+cons_prec = 5 -- TODO Extract this info from GHC itself
+
+pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
+
+ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
+  tt_docs <- mapM (y app_prec) tt
+  return $ cparen (not (null tt) && p >= app_prec)
+                  (text dc_tag <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
+{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
+  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
+    <+> hsep (map (ppr_term1 True) tt)
+-} -- TODO Printing infix constructors properly
+  = do { tt_docs' <- mapM (y app_prec) tt
+       ; return $ ifPprDebug (show_tm tt_docs')
+                             (show_tm (dropList (dataConTheta dc) tt_docs'))
+                  -- Don't show the dictionary arguments to
+                  -- constructors unless -dppr-debug is on
+       }
+  where
+    show_tm tt_docs
+      | null tt_docs = ppr dc
+      | otherwise    = cparen (p >= app_prec) $
+                       sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+ppr_termM y p RefWrap{wrapped_term=t}  = do
+  contents <- y app_prec t
+  return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
+  -- The constructor name is wired in here ^^^ for the sake of simplicity.
+  -- I don't think mutvars are going to change in a near future.
+  -- In any case this is solely a presentation matter: MutVar# is
+  -- a datatype with no constructors, implemented by the RTS
+  -- (hence there is no way to obtain a datacon and print it).
+ppr_termM _ _ t = ppr_termM1 t
+
+
+ppr_termM1 :: Monad m => Term -> m SDoc
+ppr_termM1 Prim{valRaw=words, ty=ty} =
+    return $ repPrim (tyConAppTyCon ty) words
+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
+    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
+ppr_termM1 Suspension{ty=ty, bound_to=Just n}
+--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
+  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
+ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
+ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
+
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+  | Just (tc,_) <- tcSplitTyConApp_maybe ty
+  , ASSERT(isNewTyCon tc) True
+  , Just new_dc <- tyConSingleDataCon_maybe tc = do
+             real_term <- y max_prec t
+             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
+
+-------------------------------------------------------
+-- Custom Term Pretty Printers
+-------------------------------------------------------
+
+-- We can want to customize the representation of a
+--  term depending on its type.
+-- However, note that custom printers have to work with
+--  type representations, instead of directly with types.
+-- We cannot use type classes here, unless we employ some
+--  typerep trickery (e.g. Weirich's RepLib tricks),
+--  which I didn't. Therefore, this code replicates a lot
+--  of what type classes provide for free.
+
+type CustomTermPrinter m = TermPrinterM m
+                         -> [Precedence -> Term -> (m (Maybe SDoc))]
+
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- and returns the output of the first successful printer, or the default printer
+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
+cPprTerm printers_ = go 0 where
+  printers = printers_ go
+  go prec t = do
+    let default_ = Just `liftM` pprTermM go prec t
+        mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
+    mdoc <- firstJustM mb_customDocs
+    case mdoc of
+      Nothing -> panic "cPprTerm"
+      Just doc -> return $ cparen (prec>app_prec+1) doc
+
+  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
+  firstJustM [] = return Nothing
+
+-- Default set of custom printers. Note that the recursion knot is explicit
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
+cPprTermBase y =
+  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
+                                      . mapM (y (-1))
+                                      . subTerms)
+  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
+           ppr_list
+  , ifTerm' (isTyCon intTyCon    . ty) ppr_int
+  , ifTerm' (isTyCon charTyCon   . ty) ppr_char
+  , ifTerm' (isTyCon floatTyCon  . ty) ppr_float
+  , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
+  , ifTerm' (isIntegerTy         . ty) ppr_integer
+  ]
+ where
+   ifTerm :: (Term -> Bool)
+          -> (Precedence -> Term -> m SDoc)
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
+
+   ifTerm' :: (Term -> Bool)
+          -> (Precedence -> Term -> m (Maybe SDoc))
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm' pred f prec t@Term{}
+       | pred t    = f prec t
+   ifTerm' _ _ _ _  = return Nothing
+
+   isTupleTy ty    = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (isBoxedTupleTyCon tc)
+
+   isTyCon a_tc ty = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (a_tc == tc)
+
+   isIntegerTy ty = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (tyConName tc == integerTyConName)
+
+   ppr_int, ppr_char, ppr_float, ppr_double
+      :: Precedence -> Term -> m (Maybe SDoc)
+   ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
+      return (Just (Ppr.int (fromIntegral w)))
+   ppr_int _ _ = return Nothing
+
+   ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
+      return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
+   ppr_char _ _ = return Nothing
+
+   ppr_float   _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> poke p w >> peek (castPtr p)
+      return (Just (Ppr.float f))
+   ppr_float _ _ = return Nothing
+
+   ppr_double  _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> poke p w >> peek (castPtr p)
+      return (Just (Ppr.double f))
+   -- let's assume that if we get two words, we're on a 32-bit
+   -- machine. There's no good way to get a DynFlags to check the word
+   -- size here.
+   ppr_double  _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> do
+                  poke p (fromIntegral w1 :: Word32)
+                  poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
+                  peek (castPtr p)
+      return (Just (Ppr.double f))
+   ppr_double _ _ = return Nothing
+
+   ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
+#if defined(INTEGER_GMP)
+   -- Reconstructing Integers is a bit of a pain. This depends deeply
+   -- on the integer-gmp representation, so it'll break if that
+   -- changes (but there are several tests in
+   -- tests/ghci.debugger/scripts that will tell us if this is wrong).
+   --
+   --   data Integer
+   --     = S# Int#
+   --     | Jp# {-# UNPACK #-} !BigNat
+   --     | Jn# {-# UNPACK #-} !BigNat
+   --
+   --   data BigNat = BN# ByteArray#
+   --
+   ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
+      return (Just (Ppr.integer (S# (word2Int# w))))
+   ppr_integer _ Term{dc=Right con,
+                      subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
+      -- We don't need to worry about sizes that are not an integral
+      -- number of words, because luckily GMP uses arrays of words
+      -- (see GMP_LIMB_SHIFT).
+      let
+        !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
+        constr
+          | "Jp#" <- getOccString (dataConName con) = Jp#
+          | otherwise = Jn#
+      return (Just (Ppr.integer (constr (BN# arr#))))
+#elif defined(INTEGER_SIMPLE)
+   -- As with the GMP case, this depends deeply on the integer-simple
+   -- representation.
+   --
+   -- @
+   -- data Integer = Positive !Digits | Negative !Digits | Naught
+   --
+   -- data Digits = Some !Word# !Digits
+   --             | None
+   -- @
+   --
+   -- NB: the above has some type synonyms expanded out for the sake of brevity
+   ppr_integer _ Term{subTerms=[]} =
+      return (Just (Ppr.integer Naught))
+   ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}
+        | Just digits <- get_digits digitTerm
+        = return (Just (Ppr.integer (constr digits)))
+      where
+        get_digits :: Term -> Maybe Digits
+        get_digits Term{subTerms=[]} = Just None
+        get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}
+          = Some w <$> get_digits t
+        get_digits _ = Nothing
+
+        constr
+          | "Positive" <- getOccString (dataConName con) = Positive
+          | otherwise = Negative
+#endif
+   ppr_integer _ _ = return Nothing
+
+   --Note pprinting of list terms is not lazy
+   ppr_list :: Precedence -> Term -> m SDoc
+   ppr_list p (Term{subTerms=[h,t]}) = do
+       let elems      = h : getListTerms t
+           isConsLast = not (termType (last elems) `eqType` termType h)
+           is_string  = all (isCharTy . ty) elems
+           chars = [ chr (fromIntegral w)
+                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
+
+       print_elems <- mapM (y cons_prec) elems
+       if is_string
+        then return (Ppr.doubleQuotes (Ppr.text chars))
+        else if isConsLast
+        then return $ cparen (p >= cons_prec)
+                    $ pprDeeperList fsep
+                    $ punctuate (space<>colon) print_elems
+        else return $ brackets
+                    $ pprDeeperList fcat
+                    $ punctuate comma print_elems
+
+        where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+              getListTerms Term{subTerms=[]}    = []
+              getListTerms t@Suspension{}       = [t]
+              getListTerms t = pprPanic "getListTerms" (ppr t)
+   ppr_list _ _ = panic "doList"
+
+
+repPrim :: TyCon -> [Word] -> SDoc
+repPrim t = rep where
+   rep x
+    -- Char# uses native machine words, whereas Char's Storable instance uses
+    -- Int32, so we have to read it as an Int.
+    | t == charPrimTyCon             = text $ show (chr (build x :: Int))
+    | t == intPrimTyCon              = text $ show (build x :: Int)
+    | t == wordPrimTyCon             = text $ show (build x :: Word)
+    | t == floatPrimTyCon            = text $ show (build x :: Float)
+    | t == doublePrimTyCon           = text $ show (build x :: Double)
+    | t == int32PrimTyCon            = text $ show (build x :: Int32)
+    | t == word32PrimTyCon           = text $ show (build x :: Word32)
+    | t == int64PrimTyCon            = text $ show (build x :: Int64)
+    | t == word64PrimTyCon           = text $ show (build x :: Word64)
+    | t == addrPrimTyCon             = text $ show (nullPtr `plusPtr` build x)
+    | t == stablePtrPrimTyCon        = text "<stablePtr>"
+    | t == stableNamePrimTyCon       = text "<stableName>"
+    | t == statePrimTyCon            = text "<statethread>"
+    | t == proxyPrimTyCon            = text "<proxy>"
+    | t == realWorldTyCon            = text "<realworld>"
+    | t == threadIdPrimTyCon         = text "<ThreadId>"
+    | t == weakPrimTyCon             = text "<Weak>"
+    | t == arrayPrimTyCon            = text "<array>"
+    | t == smallArrayPrimTyCon       = text "<smallArray>"
+    | t == byteArrayPrimTyCon        = text "<bytearray>"
+    | t == mutableArrayPrimTyCon     = text "<mutableArray>"
+    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
+    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
+    | t == mutVarPrimTyCon           = text "<mutVar>"
+    | t == mVarPrimTyCon             = text "<mVar>"
+    | t == tVarPrimTyCon             = text "<tVar>"
+    | otherwise                      = char '<' <> ppr t <> char '>'
+    where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
+--   This ^^^ relies on the representation of Haskell heap values being
+--   the same as in a C array.
+
+-----------------------------------
+-- Type Reconstruction
+-----------------------------------
+{-
+Type Reconstruction is type inference done on heap closures.
+The algorithm walks the heap generating a set of equations, which
+are solved with syntactic unification.
+A type reconstruction equation looks like:
+
+  <datacon reptype>  =  <actual heap contents>
+
+The full equation set is generated by traversing all the subterms, starting
+from a given term.
+
+The only difficult part is that newtypes are only found in the lhs of equations.
+Right hand sides are missing them. We can either (a) drop them from the lhs, or
+(b) reconstruct them in the rhs when possible.
+
+The function congruenceNewtypes takes a shot at (b)
+-}
+
+
+-- A (non-mutable) tau type containing
+-- existentially quantified tyvars.
+--    (since GHC type language currently does not support
+--     existentials, we leave these variables unquantified)
+type RttiType = Type
+
+-- An incomplete type as stored in GHCi:
+--  no polymorphism: no quantifiers & all tyvars are skolem.
+type GhciType = Type
+
+
+-- The Type Reconstruction monad
+--------------------------------
+type TR a = TcM a
+
+runTR :: HscEnv -> TR a -> IO a
+runTR hsc_env thing = do
+  mb_val <- runTR_maybe hsc_env thing
+  case mb_val of
+    Nothing -> error "unable to :print the term"
+    Just x  -> return x
+
+runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
+runTR_maybe hsc_env thing_inside
+  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
+       ; return res }
+
+-- | Term Reconstruction trace
+traceTR :: SDoc -> TR ()
+traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
+
+
+-- Semantically different to recoverM in TcRnMonad
+-- recoverM retains the errors in the first action,
+--  whereas recoverTc here does not
+recoverTR :: TR a -> TR a -> TR a
+recoverTR = tryTcDiscardingErrs
+
+trIO :: IO a -> TR a
+trIO = liftTcM . liftIO
+
+liftTcM :: TcM a -> TR a
+liftTcM = id
+
+newVar :: Kind -> TR TcType
+newVar = liftTcM . newFlexiTyVarTy
+
+newOpenVar :: TR TcType
+newOpenVar = liftTcM newOpenFlexiTyVarTy
+
+instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars tvs
+  = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
+
+type RttiInstantiation = [(TcTyVar, TyVar)]
+   -- Associates the typechecker-world meta type variables
+   -- (which are mutable and may be refined), to their
+   -- debugger-world RuntimeUnk counterparts.
+   -- If the TcTyVar has not been refined by the runtime type
+   -- elaboration, then we want to turn it back into the
+   -- original RuntimeUnk
+
+-- | Returns the instantiated type scheme ty', and the
+--   mapping from new (instantiated) -to- old (skolem) type variables
+instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
+instScheme (tvs, ty)
+  = do { (subst, tvs') <- instTyVars tvs
+       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
+       ; return (substTy subst ty, rtti_inst) }
+
+applyRevSubst :: RttiInstantiation -> TR ()
+-- Apply the *reverse* substitution in-place to any un-filled-in
+-- meta tyvars.  This recovers the original debugger-world variable
+-- unless it has been refined by new information from the heap
+applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
+  where
+    do_pair (tc_tv, rtti_tv)
+      = do { tc_ty <- zonkTcTyVar tc_tv
+           ; case tcGetTyVar_maybe tc_ty of
+               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
+               _                        -> return () }
+
+-- Adds a constraint of the form t1 == t2
+-- t1 is expected to come from walking the heap
+-- t2 is expected to come from a datacon signature
+-- Before unification, congruenceNewtypes needs to
+-- do its magic.
+addConstraint :: TcType -> TcType -> TR ()
+addConstraint actual expected = do
+    traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
+    recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
+                                    text "with", ppr expected]) $
+      discardResult $
+      captureConstraints $
+      do { (ty1, ty2) <- congruenceNewtypes actual expected
+         ; unifyType Nothing ty1 ty2 }
+     -- TOMDO: what about the coercion?
+     -- we should consider family instances
+
+
+-- | Term reconstruction
+--
+-- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
+-- representation of the object. Subterms (objects in the payload) are also
+-- built up to the given `max_depth`. After `max_depth` any subterms will appear
+-- as `Suspension`s. Any thunks found while traversing the object will be forced
+-- based on `force` parameter.
+--
+-- Types of terms will be refined based on constructors we find during term
+-- reconstruction. See `cvReconstructType` for an overview of how type
+-- reconstruction works.
+--
+cvObtainTerm
+    :: HscEnv
+    -> Int      -- ^ How many times to recurse for subterms
+    -> Bool     -- ^ Force thunks
+    -> RttiType -- ^ Type of the object to reconstruct
+    -> ForeignHValue   -- ^ Object to reconstruct
+    -> IO Term
+cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
+  -- we quantify existential tyvars as universal,
+  -- as this is needed to be able to manipulate
+  -- them properly
+   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
+       sigma_old_ty = mkInvForAllTys old_tvs old_tau
+   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
+   term <-
+     if null old_tvs
+      then do
+        term  <- go max_depth sigma_old_ty sigma_old_ty hval
+        term' <- zonkTerm term
+        return $ fixFunDictionaries $ expandNewtypes term'
+      else do
+              (old_ty', rev_subst) <- instScheme quant_old_ty
+              my_ty <- newOpenVar
+              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
+                                          addConstraint my_ty old_ty')
+              term  <- go max_depth my_ty sigma_old_ty hval
+              new_ty <- zonkTcType (termType term)
+              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
+                 then do
+                      traceTR (text "check2 passed")
+                      addConstraint new_ty old_ty'
+                      applyRevSubst rev_subst
+                      zterm' <- zonkTerm term
+                      return ((fixFunDictionaries . expandNewtypes) zterm')
+                 else do
+                      traceTR (text "check2 failed" <+> parens
+                                       (ppr term <+> text "::" <+> ppr new_ty))
+                      -- we have unsound types. Replace constructor types in
+                      -- subterms with tyvars
+                      zterm' <- mapTermTypeM
+                                 (\ty -> case tcSplitTyConApp_maybe ty of
+                                           Just (tc, _:_) | tc /= funTyCon
+                                               -> newOpenVar
+                                           _   -> return ty)
+                                 term
+                      zonkTerm zterm'
+   traceTR (text "Term reconstruction completed." $$
+            text "Term obtained: " <> ppr term $$
+            text "Type obtained: " <> ppr (termType term))
+   return term
+    where
+  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
+   -- I believe that my_ty should not have any enclosing
+   -- foralls, nor any free RuntimeUnk skolems;
+   -- that is partly what the quantifyType stuff achieved
+   --
+   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
+  go 0 my_ty _old_ty a = do
+    traceTR (text "Gave up reconstructing a term after" <>
+                  int max_depth <> text " steps")
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    return (Suspension (tipe (info clos)) my_ty a Nothing)
+  go !max_depth my_ty old_ty a = do
+    let monomorphic = not(isTyVarTy my_ty)
+    -- This ^^^ is a convention. The ancestor tests for
+    -- monomorphism and passes a type instead of a tv
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    case clos of
+-- Thunks we may want to force
+      t | isThunk t && force -> do
+         traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
+         liftIO $ GHCi.seqHValue hsc_env a
+         go (pred max_depth) my_ty old_ty a
+-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If
+-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as
+-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead
+-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).
+      BlackholeClosure{indirectee=ind} -> do
+         traceTR (text "Following a BLACKHOLE")
+         ind_clos <- trIO (GHCi.getClosure hsc_env ind)
+         let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)
+         case ind_clos of
+           -- TSO and BLOCKING_QUEUE cases
+           BlockingQueueClosure{} -> return_bh_value
+           OtherClosure info _ _
+             | tipe info == TSO -> return_bh_value
+           UnsupportedClosure info
+             | tipe info == TSO -> return_bh_value
+           -- Otherwise follow the indirectee
+           -- (NOTE: This code will break if we support TSO in ghc-heap one day)
+           _ -> go max_depth my_ty old_ty ind
+-- We always follow indirections
+      IndClosure{indirectee=ind} -> do
+         traceTR (text "Following an indirection" )
+         go max_depth my_ty old_ty ind
+-- We also follow references
+      MutVarClosure{var=contents}
+         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
+             -> do
+                  -- Deal with the MutVar# primitive
+                  -- It does not have a constructor at all,
+                  -- so we simulate the following one
+                  -- MutVar# :: contents_ty -> MutVar# s contents_ty
+         traceTR (text "Following a MutVar")
+         contents_tv <- newVar liftedTypeKind
+         MASSERT(isUnliftedType my_ty)
+         (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy
+                            contents_ty (mkTyConApp tycon [world,contents_ty])
+         addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty
+         x <- go (pred max_depth) contents_tv contents_ty contents
+         return (RefWrap my_ty x)
+
+ -- The interesting case
+      ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
+        traceTR (text "entering a constructor " <> ppr dArgs <+>
+                      if monomorphic
+                        then parens (text "already monomorphic: " <> ppr my_ty)
+                        else Ppr.empty)
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
+        (mb_dc, _)   <- tryTc (tcLookupDataCon dcname)
+        case mb_dc of
+          Nothing -> do -- This can happen for private constructors compiled -O0
+                        -- where the .hi descriptor does not export them
+                        -- In such case, we return a best approximation:
+                        --  ignore the unpointed args, and recover the pointeds
+                        -- This preserves laziness, and should be safe.
+                       traceTR (text "Not constructor" <+> ppr dcname)
+                       let dflags = hsc_dflags hsc_env
+                           tag = showPpr dflags dcname
+                       vars     <- replicateM (length pArgs)
+                                              (newVar liftedTypeKind)
+                       subTerms <- sequence $ zipWith (\x tv ->
+                           go (pred max_depth) tv tv x) pArgs vars
+                       return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
+          Just dc -> do
+            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
+            subTtypes <- getDataConArgTys dc my_ty
+            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
+            return (Term my_ty (Right dc) a subTerms)
+
+      -- This is to support printing of Integers. It's not a general
+      -- mechanism by any means; in particular we lose the size in
+      -- bytes of the array.
+      ArrWordsClosure{bytes=b, arrWords=ws} -> do
+         traceTR (text "ByteArray# closure, size " <> ppr b)
+         return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])
+
+-- The otherwise case: can be a Thunk,AP,PAP,etc.
+      _ -> do
+         traceTR (text "Unknown closure:" <+>
+                  text (show (fmap (const ()) clos)))
+         return (Suspension (tipe (info clos)) my_ty a Nothing)
+
+  -- insert NewtypeWraps around newtypes
+  expandNewtypes = foldTerm idTermFold { fTerm = worker } where
+   worker ty dc hval tt
+     | Just (tc, args) <- tcSplitTyConApp_maybe ty
+     , isNewTyCon tc
+     , wrapped_type    <- newTyConInstRhs tc args
+     , Just dc'        <- tyConSingleDataCon_maybe tc
+     , t'              <- worker wrapped_type dc hval tt
+     = NewtypeWrap ty (Right dc') t'
+     | otherwise = Term ty dc hval tt
+
+
+   -- Avoid returning types where predicates have been expanded to dictionaries.
+  fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
+      worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
+                          | otherwise  = Suspension ct ty hval n
+
+extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
+                -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
+extractSubTerms recurse clos = liftM thdOf3 . go 0 0
+  where
+    array = dataArgs clos
+
+    go ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go ptr_i arr_i (ty:tys)
+      | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+      , isUnboxedTupleTyCon tc
+                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+      = do (ptr_i, arr_i, terms0) <-
+               go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
+      | otherwise
+      = case typePrimRepArgs ty of
+          [rep_ty] ->  do
+            (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i ty rep_ty
+            (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+            return (ptr_i, arr_i, term0 : terms1)
+          rep_tys -> do
+           (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
+
+    go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
+      tv <- newVar liftedTypeKind
+      (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i tv rep_ty
+      (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
+      return (ptr_i, arr_i, term0 : terms1)
+
+    go_rep ptr_i arr_i ty rep
+      | isGcPtrRep rep = do
+          t <- recurse ty $ (ptrArgs clos)!!ptr_i
+          return (ptr_i + 1, arr_i, t)
+      | otherwise = do
+          -- This is a bit involved since we allow packing multiple fields
+          -- within a single word. See also
+          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
+          dflags <- getDynFlags
+          let word_size = wORD_SIZE dflags
+              big_endian = wORDS_BIGENDIAN dflags
+              size_b = primRepSizeB dflags rep
+              -- Align the start offset (eg, 2-byte value should be 2-byte
+              -- aligned). But not more than to a word. The offset calculation
+              -- should be the same with the offset calculation in
+              -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.
+              !aligned_idx = roundUpTo arr_i (min word_size size_b)
+              !new_arr_i = aligned_idx + size_b
+              ws | size_b < word_size =
+                     [index size_b aligned_idx word_size big_endian]
+                 | otherwise =
+                     let (q, r) = size_b `quotRem` word_size
+                     in ASSERT( r == 0 )
+                        [ array!!i
+                        | o <- [0.. q - 1]
+                        , let i = (aligned_idx `quot` word_size) + o
+                        ]
+          return (ptr_i, new_arr_i, Prim ty ws)
+
+    unboxedTupleTerm ty terms
+      = Term ty (Right (tupleDataCon Unboxed (length terms)))
+                (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
+
+    -- Extract a sub-word sized field from a word
+    index item_size_b index_b word_size big_endian =
+        (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
+      where
+        mask :: Word
+        mask = case item_size_b of
+            1 -> 0xFF
+            2 -> 0xFFFF
+            4 -> 0xFFFFFFFF
+            _ -> panic ("Weird byte-index: " ++ show index_b)
+        (q,r) = index_b `quotRem` word_size
+        word = array!!q
+        moveBytes = if big_endian
+                    then word_size - (r + item_size_b) * 8
+                    else r * 8
+
+
+-- | Fast, breadth-first Type reconstruction
+--
+-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
+-- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
+-- This is used for improving type information in debugger. For example, if we
+-- have a polymorphic function:
+--
+--     sumNumList :: Num a => [a] -> a
+--     sumNumList [] = 0
+--     sumNumList (x : xs) = x + sumList xs
+--
+-- and add a breakpoint to it:
+--
+--     ghci> break sumNumList
+--     ghci> sumNumList ([0 .. 9] :: [Int])
+--
+-- ghci shows us more precise types than just `a`s:
+--
+--     Stopped in Main.sumNumList, debugger.hs:3:23-39
+--     _result :: Int = _
+--     x :: Int = 0
+--     xs :: [Int] = _
+--
+cvReconstructType
+    :: HscEnv
+    -> Int       -- ^ How many times to recurse for subterms
+    -> GhciType  -- ^ Type to refine
+    -> ForeignHValue  -- ^ Refine the type using this value
+    -> IO (Maybe Type)
+cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
+   traceTR (text "RTTI started with initial type " <> ppr old_ty)
+   let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
+   new_ty <-
+       if null old_tvs
+        then return old_ty
+        else do
+          (old_ty', rev_subst) <- instScheme sigma_old_ty
+          my_ty <- newOpenVar
+          when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
+                                      addConstraint my_ty old_ty')
+          search (isMonomorphic `fmap` zonkTcType my_ty)
+                 (\(ty,a) -> go ty a)
+                 (Seq.singleton (my_ty, hval))
+                 max_depth
+          new_ty <- zonkTcType my_ty
+          if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
+            then do
+                 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
+                 addConstraint my_ty old_ty'
+                 applyRevSubst rev_subst
+                 zonkRttiType new_ty
+            else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
+                 return old_ty
+   traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
+   return new_ty
+    where
+--  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
+  search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+                                int max_depth <> text " steps")
+  search stop expand l d =
+    case viewl l of
+      EmptyL  -> return ()
+      x :< xx -> unlessM stop $ do
+                  new <- expand x
+                  search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
+
+   -- returns unification tasks,since we are going to want a breadth-first search
+  go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
+  go my_ty a = do
+    traceTR (text "go" <+> ppr my_ty)
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    case clos of
+      BlackholeClosure{indirectee=ind} -> go my_ty ind
+      IndClosure{indirectee=ind} -> go my_ty ind
+      MutVarClosure{var=contents} -> do
+         tv'   <- newVar liftedTypeKind
+         world <- newVar liftedTypeKind
+         addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
+         return [(tv', contents)]
+      ConstrClosure{ptrArgs=pArgs} -> do
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
+        traceTR (text "Constr1" <+> ppr dcname)
+        (mb_dc, _) <- tryTc (tcLookupDataCon dcname)
+        case mb_dc of
+          Nothing-> do
+            forM pArgs $ \x -> do
+              tv <- newVar liftedTypeKind
+              return (tv, x)
+
+          Just dc -> do
+            arg_tys <- getDataConArgTys dc my_ty
+            (_, itys) <- findPtrTyss 0 arg_tys
+            traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+            return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs
+      _ -> return []
+
+findPtrTys :: Int  -- Current pointer index
+           -> Type -- Type
+           -> TR (Int, [(Int, Type)])
+findPtrTys i ty
+  | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+  , isUnboxedTupleTyCon tc
+  = findPtrTyss i elem_tys
+
+  | otherwise
+  = case typePrimRep ty of
+      [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
+            | otherwise      -> return (i,     [])
+      prim_reps              ->
+        foldM (\(i, extras) prim_rep ->
+                if isGcPtrRep prim_rep
+                  then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+                  else return (i, extras))
+              (i, []) prim_reps
+
+findPtrTyss :: Int
+            -> [Type]
+            -> TR (Int, [(Int, Type)])
+findPtrTyss i tys = foldM step (i, []) tys
+  where step (i, discovered) elem_ty = do
+          (i, extras) <- findPtrTys i elem_ty
+          return (i, discovered ++ extras)
+
+
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
+improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty
+
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty)
+-- return the types of the arguments.  This is RTTI-land, so 'ty' might
+-- not be fully known.  Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+--
+-- I believe that con_app_ty should not have any enclosing foralls
+getDataConArgTys dc con_app_ty
+  = do { let rep_con_app_ty = unwrapType con_app_ty
+       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
+                   $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
+       ; ASSERT( all isTyVar ex_tvs ) return ()
+                 -- ex_tvs can only be tyvars as data types in source
+                 -- Haskell cannot mention covar yet (Aug 2018)
+       ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
+       ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
+              -- See Note [Constructor arg types]
+       ; let con_arg_tys = substTys subst (dataConRepArgTys dc)
+       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))
+       ; return con_arg_tys }
+  where
+    univ_tvs = dataConUnivTyVars dc
+    ex_tvs   = dataConExTyCoVars dc
+
+{- Note [Constructor arg types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a GADT (cf #7386)
+   data family D a b
+   data instance D [a] a where
+     MkT :: a -> D [a] (Maybe a)
+     ...
+
+In getDataConArgTys
+* con_app_ty is the known type (from outside) of the constructor application,
+  say D [Int] Int
+
+* The data constructor MkT has a (representation) dataConTyCon = DList,
+  say where
+    data DList a where
+      MkT :: a -> DList a (Maybe a)
+      ...
+
+So the dataConTyCon of the data constructor, DList, differs from
+the "outside" type, D. So we can't straightforwardly decompose the
+"outside" type, and we end up in the "_" branch of the case.
+
+Then we match the dataConOrigResTy of the data constructor against the
+outside type, hoping to get a substitution that tells how to instantiate
+the *representation* type constructor.   This looks a bit delicate to
+me, but it seems to work.
+-}
+
+-- Soundness checks
+--------------------
+{-
+This is not formalized anywhere, so hold to your seats!
+RTTI in the presence of newtypes can be a tricky and unsound business.
+
+Example:
+~~~~~~~~~
+Suppose we are doing RTTI for a partially evaluated
+closure t, the real type of which is t :: MkT Int, for
+
+   newtype MkT a = MkT [Maybe a]
+
+The table below shows the results of RTTI and the improvement
+calculated for different combinations of evaluatedness and :type t.
+Regard the two first columns as input and the next two as output.
+
+  # |     t     |  :type t  | rtti(t)  | improv.    | result
+    ------------------------------------------------------------
+  1 |     _     |    t b    |    a     | none       | OK
+  2 |     _     |   MkT b   |    a     | none       | OK
+  3 |     _     |   t Int   |    a     | none       | OK
+
+  If t is not evaluated at *all*, we are safe.
+
+  4 |  (_ : _)  |    t b    |   [a]    | t = []     | UNSOUND
+  5 |  (_ : _)  |   MkT b   |  MkT a   | none       | OK (compensating for the missing newtype)
+  6 |  (_ : _)  |   t Int   |  [Int]   | t = []     | UNSOUND
+
+  If a is a minimal whnf, we run into trouble. Note that
+  row 5 above does newtype enrichment on the ty_rtty parameter.
+
+  7 | (Just _:_)|    t b    |[Maybe a] | t = [],    | UNSOUND
+    |                       |          | b = Maybe a|
+
+  8 | (Just _:_)|   MkT b   |  MkT a   |  none      | OK
+  9 | (Just _:_)|   t Int   |   FAIL   |  none      | OK
+
+  And if t is any more evaluated than whnf, we are still in trouble.
+  Because constraints are solved in top-down order, when we reach the
+  Maybe subterm what we got is already unsound. This explains why the
+  row 9 fails to complete.
+
+  10 | (Just _:_)|  t Int  | [Maybe a]   |  FAIL    | OK
+  11 | (Just 1:_)|  t Int  | [Maybe Int] |  FAIL    | OK
+
+  We can undo the failure in row 9 by leaving out the constraint
+  coming from the type signature of t (i.e., the 2nd column).
+  Note that this type information is still used
+  to calculate the improvement. But we fail
+  when trying to calculate the improvement, as there is no unifier for
+  t Int = [Maybe a] or t Int = [Maybe Int].
+
+
+  Another set of examples with t :: [MkT (Maybe Int)]  \equiv  [[Maybe (Maybe Int)]]
+
+  # |     t     |    :type t    |  rtti(t)    | improvement | result
+    ---------------------------------------------------------------------
+  1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = []      |
+    |           |               |             | b = Maybe a |
+
+The checks:
+~~~~~~~~~~~
+Consider a function obtainType that takes a value and a type and produces
+the Term representation and a substitution (the improvement).
+Assume an auxiliar rtti' function which does the actual job if recovering
+the type, but which may produce a false type.
+
+In pseudocode:
+
+  rtti' :: a -> IO Type  -- Does not use the static type information
+
+  obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
+  obtainType v old_ty = do
+       rtti_ty <- rtti' v
+       if monomorphic rtti_ty || (check rtti_ty old_ty)
+        then ...
+         else return Nothing
+  where check rtti_ty old_ty = check1 rtti_ty &&
+                              check2 rtti_ty old_ty
+
+  check1 :: Type -> Bool
+  check2 :: Type -> Type -> Bool
+
+Now, if rtti' returns a monomorphic type, we are safe.
+If that is not the case, then we consider two conditions.
+
+
+1. To prevent the class of unsoundness displayed by
+   rows 4 and 7 in the example: no higher kind tyvars
+   accepted.
+
+  check1 (t a)   = NO
+  check1 (t Int) = NO
+  check1 ([] a)  = YES
+
+2. To prevent the class of unsoundness shown by row 6,
+   the rtti type should be structurally more
+   defined than the old type we are comparing it to.
+  check2 :: NewType -> OldType -> Bool
+  check2 a  _        = True
+  check2 [a] a       = True
+  check2 [a] (t Int) = False
+  check2 [a] (t a)   = False  -- By check1 we never reach this equation
+  check2 [Int] a     = True
+  check2 [Int] (t Int) = True
+  check2 [Maybe a]   (t Int) = False
+  check2 [Maybe Int] (t Int) = True
+  check2 (Maybe [a])   (m [Int]) = False
+  check2 (Maybe [Int]) (m [Int]) = True
+
+-}
+
+check1 :: QuantifiedType -> Bool
+check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
+ where
+   isHigherKind = not . null . fst . splitPiTys
+
+check2 :: QuantifiedType -> QuantifiedType -> Bool
+check2 (_, rtti_ty) (_, old_ty)
+  | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
+  = case () of
+      _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
+        -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
+      _ | Just _ <- splitAppTy_maybe old_ty
+        -> isMonomorphicOnNonPhantomArgs rtti_ty
+      _ -> True
+  | otherwise = True
+
+-- Dealing with newtypes
+--------------------------
+{-
+ congruenceNewtypes does a parallel fold over two Type values,
+ compensating for missing newtypes on both sides.
+ This is necessary because newtypes are not present
+ in runtime, but sometimes there is evidence available.
+   Evidence can come from DataCon signatures or
+ from compile-time type inference.
+ What we are doing here is an approximation
+ of unification modulo a set of equations derived
+ from newtype definitions. These equations should be the
+ same as the equality coercions generated for newtypes
+ in System Fc. The idea is to perform a sort of rewriting,
+ taking those equations as rules, before launching unification.
+
+ The caller must ensure the following.
+ The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
+ The 2nd type (rhs) comes from a DataCon type signature.
+ Rewriting (i.e. adding/removing a newtype wrapper) can happen
+ in both types, but in the rhs it is restricted to the result type.
+
+   Note that it is very tricky to make this 'rewriting'
+ work with the unification implemented by TcM, where
+ substitutions are operationally inlined. The order in which
+ constraints are unified is vital as we cannot modify
+ anything that has been touched by a previous unification step.
+Therefore, congruenceNewtypes is sound only if the types
+recovered by the RTTI mechanism are unified Top-Down.
+-}
+congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
+congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
+ where
+   go l r
+ -- TyVar lhs inductive case
+    | Just tv <- getTyVar_maybe l
+    , isTcTyVar tv
+    , isMetaTyVar tv
+    = recoverTR (return r) $ do
+         Indirect ty_v <- readMetaTyVar tv
+         traceTR $ fsep [text "(congruence) Following indirect tyvar:",
+                          ppr tv, equals, ppr ty_v]
+         go ty_v r
+-- FunTy inductive case
+    | Just (l1,l2) <- splitFunTy_maybe l
+    , Just (r1,r2) <- splitFunTy_maybe r
+    = do r2' <- go l2 r2
+         r1' <- go l1 r1
+         return (mkVisFunTy r1' r2')
+-- TyconApp Inductive case; this is the interesting bit.
+    | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
+    , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
+    , tycon_l /= tycon_r
+    = upgrade tycon_l r
+
+    | otherwise = return r
+
+    where upgrade :: TyCon -> Type -> TR Type
+          upgrade new_tycon ty
+            | not (isNewTyCon new_tycon) = do
+              traceTR (text "(Upgrade) Not matching newtype evidence: " <>
+                       ppr new_tycon <> text " for " <> ppr ty)
+              return ty
+            | otherwise = do
+               traceTR (text "(Upgrade) upgraded " <> ppr ty <>
+                        text " in presence of newtype evidence " <> ppr new_tycon)
+               (_, vars) <- instTyVars (tyConTyVars new_tycon)
+               let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
+                   rep_ty = unwrapType ty'
+               _ <- liftTcM (unifyType Nothing ty rep_ty)
+        -- assumes that reptype doesn't ^^^^ touch tyconApp args
+               return ty'
+
+
+zonkTerm :: Term -> TcM Term
+zonkTerm = foldTermM (TermFoldM
+             { fTermM = \ty dc v tt -> zonkRttiType ty    >>= \ty' ->
+                                       return (Term ty' dc v tt)
+             , fSuspensionM  = \ct ty v b -> zonkRttiType ty >>= \ty ->
+                                             return (Suspension ct ty v b)
+             , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
+                                           return$ NewtypeWrap ty' dc t
+             , fRefWrapM     = \ty t -> return RefWrap  `ap`
+                                        zonkRttiType ty `ap` return t
+             , fPrimM        = (return.) . Prim })
+
+zonkRttiType :: TcType -> TcM Type
+-- Zonk the type, replacing any unbound Meta tyvars
+-- by RuntimeUnk skolems, safely out of Meta-tyvar-land
+zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi
+                    ; zonkTcTypeToTypeX ze ty }
+
+--------------------------------------------------------------------------------
+-- Restore Class predicates out of a representation type
+dictsView :: Type -> Type
+dictsView ty = ty
+
+
+-- Use only for RTTI types
+isMonomorphic :: RttiType -> Bool
+isMonomorphic ty = noExistentials && noUniversals
+ where (tvs, _, ty')  = tcSplitSigmaTy ty
+       noExistentials = noFreeVarsOfType ty'
+       noUniversals   = null tvs
+
+-- Use only for RTTI types
+isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
+isMonomorphicOnNonPhantomArgs ty
+  | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)
+  , phantom_vars  <- tyConPhantomTyVars tc
+  , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
+                           , tyv `notElem` phantom_vars]
+  = all isMonomorphicOnNonPhantomArgs concrete_args
+  | Just (ty1, ty2) <- splitFunTy_maybe ty
+  = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
+  | otherwise = isMonomorphic ty
+
+tyConPhantomTyVars :: TyCon -> [TyVar]
+tyConPhantomTyVars tc
+  | isAlgTyCon tc
+  , Just dcs <- tyConDataCons_maybe tc
+  , dc_vars  <- concatMap dataConUnivTyVars dcs
+  = tyConTyVars tc \\ dc_vars
+tyConPhantomTyVars _ = []
+
+type QuantifiedType = ([TyVar], Type)
+   -- Make the free type variables explicit
+   -- The returned Type should have no top-level foralls (I believe)
+
+quantifyType :: Type -> QuantifiedType
+-- Generalize the type: find all free and forall'd tyvars
+-- and return them, together with the type inside, which
+-- should not be a forall type.
+--
+-- Thus (quantifyType (forall a. a->[b]))
+-- returns ([a,b], a -> [b])
+
+quantifyType ty = ( filter isTyVar $
+                    tyCoVarsOfTypeWellScoped rho
+                  , rho)
+  where
+    (_tvs, rho) = tcSplitForAllTys ty
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieAst.hs
@@ -0,0 +1,1760 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module HieAst ( mkHieFile ) where
+
+import GhcPrelude
+
+import Avail                      ( Avails )
+import Bag                        ( Bag, bagToList )
+import BasicTypes
+import BooleanFormula
+import Class                      ( FunDep )
+import CoreUtils                  ( exprType )
+import ConLike                    ( conLikeName )
+import Config                     ( cProjectVersion )
+import Desugar                    ( deSugarExpr )
+import FieldLabel
+import HsSyn
+import HscTypes
+import Module                     ( ModuleName, ml_hs_file )
+import MonadUtils                 ( concatMapM, liftIO )
+import Name                       ( Name, nameSrcSpan, setNameLoc )
+import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
+import SrcLoc
+import TcHsSyn                    ( hsLitType, hsPatType )
+import Type                       ( mkVisFunTys, Type )
+import TysWiredIn                 ( mkListTy, mkSumTy )
+import Var                        ( Id, Var, setVarName, varName, varType )
+import TcRnTypes
+import MkIface                    ( mkIfaceExports )
+
+import HieTypes
+import HieUtils
+
+import qualified Data.Array as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Data                  ( Data, Typeable )
+import Data.List                  ( foldl1' )
+import Data.Maybe                 ( listToMaybe )
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class  ( lift )
+
+-- These synonyms match those defined in main/GHC.hs
+type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]
+                         , Maybe [(LIE GhcRn, Avails)]
+                         , Maybe LHsDocString )
+type TypecheckedSource = LHsBinds GhcTc
+
+
+{- Note [Name Remapping]
+The Typechecker introduces new names for mono names in AbsBinds.
+We don't care about the distinction between mono and poly bindings,
+so we replace all occurrences of the mono name with the poly name.
+-}
+newtype HieState = HieState
+  { name_remapping :: NameEnv Id
+  }
+
+initState :: HieState
+initState = HieState emptyNameEnv
+
+class ModifyState a where -- See Note [Name Remapping]
+  addSubstitution :: a -> a -> HieState -> HieState
+
+instance ModifyState Name where
+  addSubstitution _ _ hs = hs
+
+instance ModifyState Id where
+  addSubstitution mono poly hs =
+    hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
+
+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
+modifyState = foldr go id
+  where
+    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
+    go _ f = f
+
+type HieM = ReaderT HieState Hsc
+
+-- | Construct an 'HieFile' from the outputs of the typechecker.
+mkHieFile :: ModSummary
+          -> TcGblEnv
+          -> RenamedSource -> Hsc HieFile
+mkHieFile ms ts rs = do
+  let tc_binds = tcg_binds ts
+  (asts', arr) <- getCompressedAsts tc_binds rs
+  let Just src_file = ml_hs_file $ ms_location ms
+  src <- liftIO $ BS.readFile src_file
+  return $ HieFile
+      { hie_version = curHieVersion
+      , hie_ghc_version = BSC.pack cProjectVersion
+      , hie_hs_file = src_file
+      , hie_module = ms_mod ms
+      , hie_types = arr
+      , hie_asts = asts'
+      -- mkIfaceExports sorts the AvailInfos for stability
+      , hie_exports = mkIfaceExports (tcg_exports ts)
+      , hie_hs_src = src
+      }
+
+getCompressedAsts :: TypecheckedSource -> RenamedSource
+  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
+getCompressedAsts ts rs = do
+  asts <- enrichHie ts rs
+  return $ compressTypes asts
+
+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
+    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
+    rasts <- processGrp hsGrp
+    imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
+    exps <- toHie $ fmap (map $ IEC Export . fst) exports
+    let spanFile children = case children of
+          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
+          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
+                             (realSrcSpanEnd   $ nodeSpan $ last children)
+
+        modulify xs =
+          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
+
+        asts = HieASTs
+          $ resolveTyVarScopes
+          $ M.map (modulify . mergeSortAsts)
+          $ M.fromListWith (++)
+          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+
+        flat_asts = concat
+          [ tasts
+          , rasts
+          , imps
+          , exps
+          ]
+    return asts
+  where
+    processGrp grp = concatM
+      [ toHie $ fmap (RS ModuleScope ) hs_valds grp
+      , toHie $ hs_splcds grp
+      , toHie $ hs_tyclds grp
+      , toHie $ hs_derivds grp
+      , toHie $ hs_fixds grp
+      , toHie $ hs_defds grp
+      , toHie $ hs_fords grp
+      , toHie $ hs_warnds grp
+      , toHie $ hs_annds grp
+      , toHie $ hs_ruleds grp
+      ]
+
+getRealSpan :: SrcSpan -> Maybe Span
+getRealSpan (RealSrcSpan sp) = Just sp
+getRealSpan _ = Nothing
+
+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"
+
+bindingsOnly :: [Context Name] -> [HieAST a]
+bindingsOnly [] = []
+bindingsOnly (C c n : xs) = case nameSrcSpan n of
+  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
+    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
+          info = mempty{identInfo = S.singleton c}
+  _ -> bindingsOnly xs
+
+concatM :: Monad m => [m [a]] -> m [a]
+concatM xs = concat <$> sequence xs
+
+{- Note [Capturing Scopes and other non local information]
+toHie is a local tranformation, but scopes of bindings cannot be known locally,
+hence we have to push the relevant info down into the binding nodes.
+We use the following types (*Context and *Scoped) to wrap things and
+carry the required info
+(Maybe Span) always carries the span of the entire binding, including rhs
+-}
+data Context a = C ContextInfo a -- Used for names and bindings
+
+data RContext a = RC RecFieldContext a
+data RFContext a = RFC RecFieldContext (Maybe Span) a
+-- ^ context for record fields
+
+data IEContext a = IEC IEType a
+-- ^ context for imports/exports
+
+data BindContext a = BC BindType Scope a
+-- ^ context for imports/exports
+
+data PatSynFieldContext a = PSC (Maybe Span) a
+-- ^ context for pattern synonym fields.
+
+data SigContext a = SC SigInfo a
+-- ^ context for type signatures
+
+data SigInfo = SI SigType (Maybe Span)
+
+data SigType = BindSig | ClassSig | InstSig
+
+data RScoped a = RS Scope a
+-- ^ Scope spans over everything to the right of a, (mostly) not
+-- including a itself
+-- (Includes a in a few special cases like recursive do bindings) or
+-- let/where bindings
+
+-- | Pattern scope
+data PScoped a = PS (Maybe Span)
+                    Scope       -- ^ use site of the pattern
+                    Scope       -- ^ pattern to the right of a, not including a
+                    a
+  deriving (Typeable, Data) -- Pattern Scope
+
+{- Note [TyVar Scopes]
+Due to -XScopedTypeVariables, type variables can be in scope quite far from
+their original binding. We resolve the scope of these type variables
+in a separate pass
+-}
+data TScoped a = TS TyVarScope a -- TyVarScope
+
+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
+-- ^ First scope remains constant
+-- Second scope is used to build up the scope of a tyvar over
+-- things to its right, ala RScoped
+
+-- | Each element scopes over the elements to the right
+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
+listScopes _ [] = []
+listScopes rhsScope [pat] = [RS rhsScope pat]
+listScopes rhsScope (pat : pats) = RS sc pat : pats'
+  where
+    pats'@((RS scope p):_) = listScopes rhsScope pats
+    sc = combineScopes scope $ mkScope $ getLoc p
+
+-- | 'listScopes' specialised to 'PScoped' things
+patScopes
+  :: Maybe Span
+  -> Scope
+  -> Scope
+  -> [LPat (GhcPass p)]
+  -> [PScoped (LPat (GhcPass p))]
+patScopes rsp useScope patScope xs =
+  map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
+    listScopes patScope (map dL xs)
+
+-- | 'listScopes' specialised to 'TVScoped' things
+tvScopes
+  :: TyVarScope
+  -> Scope
+  -> [LHsTyVarBndr a]
+  -> [TVScoped (LHsTyVarBndr a)]
+tvScopes tvScope rhsScope xs =
+  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
+
+{- Note [Scoping Rules for SigPat]
+Explicitly quantified variables in pattern type signatures are not
+brought into scope in the rhs, but implicitly quantified variables
+are (HsWC and HsIB).
+This is unlike other signatures, where explicitly quantified variables
+are brought into the RHS Scope
+For example
+foo :: forall a. ...;
+foo = ... -- a is in scope here
+
+bar (x :: forall a. a -> a) = ... -- a is not in scope here
+--   ^ a is in scope here (pattern body)
+
+bax (x :: a) = ... -- a is in scope here
+Because of HsWC and HsIB pass on their scope to their children
+we must wrap the LHsType in pattern signatures in a
+Shielded explictly, so that the HsWC/HsIB scope is not passed
+on the the LHsType
+-}
+
+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
+
+type family ProtectedSig a where
+  ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
+                                                GhcRn
+                                                (Shielded (LHsType GhcRn)))
+  ProtectedSig GhcTc = NoExt
+
+class ProtectSig a where
+  protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
+
+instance (HasLoc a) => HasLoc (Shielded a) where
+  loc (SH _ a) = loc a
+
+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
+  toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
+
+instance ProtectSig GhcTc where
+  protectSig _ _ = NoExt
+
+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)"
+
+class HasLoc a where
+  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
+  -- know what their implicit bindings are scoping over
+  loc :: a -> SrcSpan
+
+instance HasLoc thing => HasLoc (TScoped thing) where
+  loc (TS _ a) = loc a
+
+instance HasLoc thing => HasLoc (PScoped thing) where
+  loc (PS _ _ _ a) = loc a
+
+instance HasLoc (LHsQTyVars GhcRn) where
+  loc (HsQTvs _ vs) = loc vs
+  loc _ = noSrcSpan
+
+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
+  loc (HsIB _ a) = loc a
+  loc _ = noSrcSpan
+
+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
+  loc (HsWC _ a) = loc a
+  loc _ = noSrcSpan
+
+instance HasLoc (Located a) where
+  loc (L l _) = l
+
+instance HasLoc a => HasLoc [a] where
+  loc [] = noSrcSpan
+  loc xs = foldl1' combineSrcSpans $ map loc xs
+
+instance HasLoc a => HasLoc (FamEqn s a) where
+  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
+  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
+                                              [loc a, loc tvs, loc b, loc c]
+  loc _ = noSrcSpan
+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
+  loc (HsValArg tm) = loc tm
+  loc (HsTypeArg _ ty) = loc ty
+  loc (HsArgPar sp)  = sp
+
+instance HasLoc (HsDataDefn GhcRn) where
+  loc def@(HsDataDefn{}) = loc $ dd_cons def
+    -- Only used for data family instances, so we only need rhs
+    -- Most probably the rest will be unhelpful anyway
+  loc _ = noSrcSpan
+
+instance HasLoc (Pat (GhcPass a)) where
+  loc (dL -> L l _) = l
+
+-- | The main worker class
+class ToHie a where
+  toHie :: a -> HieM [HieAST Type]
+
+-- | Used to collect type info
+class Data a => HasType a where
+  getTypeNode :: a -> HieM [HieAST Type]
+
+instance (ToHie a) => ToHie [a] where
+  toHie = concatMapM toHie
+
+instance (ToHie a) => ToHie (Bag a) where
+  toHie = toHie . bagToList
+
+instance (ToHie a) => ToHie (Maybe a) where
+  toHie = maybe (pure []) toHie
+
+instance ToHie (Context (Located NoExt)) where
+  toHie _ = pure []
+
+instance ToHie (TScoped NoExt) where
+  toHie _ = pure []
+
+instance ToHie (IEContext (Located ModuleName)) where
+  toHie (IEC c (L (RealSrcSpan span) mname)) =
+      pure $ [Node (NodeInfo S.empty [] idents) span []]
+    where details = mempty{identInfo = S.singleton (IEThing c)}
+          idents = M.singleton (Left mname) details
+  toHie _ = pure []
+
+instance ToHie (Context (Located Var)) where
+  toHie c = case c of
+      C context (L (RealSrcSpan span) name')
+        -> do
+        m <- asks name_remapping
+        let name = case lookupNameEnv m (varName name') of
+              Just var -> var
+              Nothing-> name'
+        pure
+          [Node
+            (NodeInfo S.empty [] $
+              M.singleton (Right $ varName name)
+                          (IdentifierDetails (Just $ varType name')
+                                             (S.singleton context)))
+            span
+            []]
+      _ -> pure []
+
+instance ToHie (Context (Located Name)) where
+  toHie c = case c of
+      C context (L (RealSrcSpan span) name') -> do
+        m <- asks name_remapping
+        let name = case lookupNameEnv m name' of
+              Just var -> varName var
+              Nothing -> name'
+        pure
+          [Node
+            (NodeInfo S.empty [] $
+              M.singleton (Right name)
+                          (IdentifierDetails Nothing
+                                             (S.singleton context)))
+            span
+            []]
+      _ -> pure []
+
+-- | Dummy instances - never called
+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
+  toHie _ = pure []
+instance ToHie (TScoped (LHsWcType GhcTc)) where
+  toHie _ = pure []
+instance ToHie (SigContext (LSig GhcTc)) where
+  toHie _ = pure []
+instance ToHie (TScoped Type) where
+  toHie _ = pure []
+
+instance HasType (LHsBind GhcRn) where
+  getTypeNode (L spn bind) = makeNode bind spn
+
+instance HasType (LHsBind GhcTc) where
+  getTypeNode (L spn bind) = case bind of
+      FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
+      _ -> makeNode bind spn
+
+instance HasType (LPat GhcRn) where
+  getTypeNode (dL -> L spn pat) = makeNode pat spn
+
+instance HasType (LPat GhcTc) where
+  getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
+
+instance HasType (LHsExpr GhcRn) where
+  getTypeNode (L spn e) = makeNode e spn
+
+-- | This instance tries to construct 'HieAST' nodes which include the type of
+-- the expression. It is not yet possible to do this efficiently for all
+-- expression forms, so we skip filling in the type for those inputs.
+--
+-- 'HsApp', for example, doesn't have any type information available directly on
+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
+-- query the type of that. Yet both the desugaring call and the type query both
+-- involve recursive calls to the function and argument! This is particularly
+-- problematic when you realize that the HIE traversal will eventually visit
+-- those nodes too and ask for their types again.
+--
+-- Since the above is quite costly, we just skip cases where computing the
+-- expression's type is going to be expensive.
+--
+-- See #16233
+instance HasType (LHsExpr GhcTc) where
+  getTypeNode e@(L spn e') = lift $
+    -- Some expression forms have their type immediately available
+    let tyOpt = case e' of
+          HsLit _ l -> Just (hsLitType l)
+          HsOverLit _ o -> Just (overLitType o)
+
+          HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
+          HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
+          HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
+
+          ExplicitList  ty _ _   -> Just (mkListTy ty)
+          ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)
+          HsDo          ty _ _   -> Just ty
+          HsMultiIf     ty _     -> Just ty
+
+          _ -> Nothing
+
+    in
+    case tyOpt of
+      _ | skipDesugaring e' -> fallback
+        | otherwise -> do
+            hs_env <- Hsc $ \e w -> return (e,w)
+            (_,mbe) <- liftIO $ deSugarExpr hs_env e
+            maybe fallback (makeTypeNode e' spn . exprType) mbe
+    where
+      fallback = makeNode e' spn
+
+      matchGroupType :: MatchGroupTc -> Type
+      matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
+
+      -- | Skip desugaring of these expressions for performance reasons.
+      --
+      -- See impact on Haddock output (esp. missing type annotations or links)
+      -- before marking more things here as 'False'. See impact on Haddock
+      -- performance before marking more things as 'True'.
+      skipDesugaring :: HsExpr a -> Bool
+      skipDesugaring e = case e of
+        HsVar{}        -> False
+        HsUnboundVar{} -> False
+        HsConLikeOut{} -> False
+        HsRecFld{}     -> False
+        HsOverLabel{}  -> False
+        HsIPVar{}      -> False
+        HsWrap{}       -> False
+        _              -> True
+
+instance ( ToHie (Context (Located (IdP a)))
+         , ToHie (MatchGroup a (LHsExpr a))
+         , ToHie (PScoped (LPat a))
+         , ToHie (GRHSs a (LHsExpr a))
+         , ToHie (LHsExpr a)
+         , ToHie (Located (PatSynBind a a))
+         , HasType (LHsBind a)
+         , ModifyState (IdP a)
+         , Data (HsBind a)
+         ) => ToHie (BindContext (LHsBind a)) where
+  toHie (BC context scope b@(L span bind)) =
+    concatM $ getTypeNode b : case bind of
+      FunBind{fun_id = name, fun_matches = matches} ->
+        [ toHie $ C (ValBind context scope $ getRealSpan span) name
+        , toHie matches
+        ]
+      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
+        [ toHie $ PS (getRealSpan span) scope NoScope lhs
+        , toHie rhs
+        ]
+      VarBind{var_rhs = expr} ->
+        [ toHie expr
+        ]
+      AbsBinds{abs_exports = xs, abs_binds = binds} ->
+        [ local (modifyState xs) $ -- Note [Name Remapping]
+            toHie $ fmap (BC context scope) binds
+        ]
+      PatSynBind _ psb ->
+        [ toHie $ L span psb -- PatSynBinds only occur at the top level
+        ]
+      XHsBindsLR _ -> []
+
+instance ( ToHie (LMatch a body)
+         ) => ToHie (MatchGroup a body) where
+  toHie mg = concatM $ case mg of
+    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
+      [ pure $ locOnly span
+      , toHie alts
+      ]
+    MG{} -> []
+    XMatchGroup _ -> []
+
+instance ( ToHie (Context (Located (IdP a)))
+         , ToHie (PScoped (LPat a))
+         , ToHie (HsPatSynDir a)
+         ) => ToHie (Located (PatSynBind a a)) where
+    toHie (L sp psb) = concatM $ case psb of
+      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
+        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
+        , toHie $ toBind dets
+        , toHie $ PS Nothing lhsScope NoScope pat
+        , toHie dir
+        ]
+        where
+          lhsScope = combineScopes varScope detScope
+          varScope = mkLScope var
+          detScope = case dets of
+            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
+            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
+            (RecCon r) -> foldr go NoScope r
+          go (RecordPatSynField a b) c = combineScopes c
+            $ combineScopes (mkLScope a) (mkLScope b)
+          detSpan = case detScope of
+            LocalScope a -> Just a
+            _ -> Nothing
+          toBind (PrefixCon args) = PrefixCon $ map (C Use) args
+          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
+          toBind (RecCon r) = RecCon $ map (PSC detSpan) r
+      XPatSynBind _ -> []
+
+instance ( ToHie (MatchGroup a (LHsExpr a))
+         ) => ToHie (HsPatSynDir a) where
+  toHie dir = case dir of
+    ExplicitBidirectional mg -> toHie mg
+    _ -> pure []
+
+instance ( a ~ GhcPass p
+         , ToHie body
+         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
+         , ToHie (PScoped (LPat a))
+         , ToHie (GRHSs a body)
+         , Data (Match a body)
+         ) => ToHie (LMatch (GhcPass p) body) where
+  toHie (L span m ) = concatM $ makeNode m span : case m of
+    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->
+      [ toHie mctx
+      , let rhsScope = mkScope $ grhss_span grhss
+          in toHie $ patScopes Nothing rhsScope NoScope pats
+      , toHie grhss
+      ]
+    XMatch _ -> []
+
+instance ( ToHie (Context (Located a))
+         ) => ToHie (HsMatchContext a) where
+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
+  toHie (StmtCtxt a) = toHie a
+  toHie _ = pure []
+
+instance ( ToHie (HsMatchContext a)
+         ) => ToHie (HsStmtContext a) where
+  toHie (PatGuard a) = toHie a
+  toHie (ParStmtCtxt a) = toHie a
+  toHie (TransStmtCtxt a) = toHie a
+  toHie _ = pure []
+
+instance ( a ~ GhcPass p
+         , ToHie (Context (Located (IdP a)))
+         , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
+         , ToHie (LHsExpr a)
+         , ToHie (TScoped (LHsSigWcType a))
+         , ProtectSig a
+         , ToHie (TScoped (ProtectedSig a))
+         , HasType (LPat a)
+         , Data (HsSplice a)
+         ) => ToHie (PScoped (LPat (GhcPass p))) where
+  toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
+    concatM $ getTypeNode lpat : case opat of
+      WildPat _ ->
+        []
+      VarPat _ lname ->
+        [ toHie $ C (PatternBind scope pscope rsp) lname
+        ]
+      LazyPat _ p ->
+        [ toHie $ PS rsp scope pscope p
+        ]
+      AsPat _ lname pat ->
+        [ toHie $ C (PatternBind scope
+                                 (combineScopes (mkLScope (dL pat)) pscope)
+                                 rsp)
+                    lname
+        , toHie $ PS rsp scope pscope pat
+        ]
+      ParPat _ pat ->
+        [ toHie $ PS rsp scope pscope pat
+        ]
+      BangPat _ pat ->
+        [ toHie $ PS rsp scope pscope pat
+        ]
+      ListPat _ pats ->
+        [ toHie $ patScopes rsp scope pscope pats
+        ]
+      TuplePat _ pats _ ->
+        [ toHie $ patScopes rsp scope pscope pats
+        ]
+      SumPat _ pat _ _ ->
+        [ toHie $ PS rsp scope pscope pat
+        ]
+      ConPatIn c dets ->
+        [ toHie $ C Use c
+        , toHie $ contextify dets
+        ]
+      ConPatOut {pat_con = con, pat_args = dets}->
+        [ toHie $ C Use $ fmap conLikeName con
+        , toHie $ contextify dets
+        ]
+      ViewPat _ expr pat ->
+        [ toHie expr
+        , toHie $ PS rsp scope pscope pat
+        ]
+      SplicePat _ sp ->
+        [ toHie $ L ospan sp
+        ]
+      LitPat _ _ ->
+        []
+      NPat _ _ _ _ ->
+        []
+      NPlusKPat _ n _ _ _ _ ->
+        [ toHie $ C (PatternBind scope pscope rsp) n
+        ]
+      SigPat _ pat sig ->
+        [ toHie $ PS rsp scope pscope pat
+        , let cscope = mkLScope (dL pat) in
+            toHie $ TS (ResolvedScopes [cscope, scope, pscope])
+                       (protectSig @a cscope sig)
+              -- See Note [Scoping Rules for SigPat]
+        ]
+      CoPat _ _ _ _ ->
+        []
+      XPat _ -> []
+    where
+      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
+      contextify (InfixCon a b) = InfixCon a' b'
+        where [a', b'] = patScopes rsp scope pscope [a,b]
+      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
+      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
+        where
+          go (RS fscope (L spn (HsRecField lbl pat pun))) =
+            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
+          scoped_fds = listScopes pscope fds
+
+instance ( ToHie body
+         , ToHie (LGRHS a body)
+         , ToHie (RScoped (LHsLocalBinds a))
+         ) => ToHie (GRHSs a body) where
+  toHie grhs = concatM $ case grhs of
+    GRHSs _ grhss binds ->
+     [ toHie grhss
+     , toHie $ RS (mkScope $ grhss_span grhs) binds
+     ]
+    XGRHSs _ -> []
+
+instance ( ToHie (Located body)
+         , ToHie (RScoped (GuardLStmt a))
+         , Data (GRHS a (Located body))
+         ) => ToHie (LGRHS a (Located body)) where
+  toHie (L span g) = concatM $ makeNode g span : case g of
+    GRHS _ guards body ->
+      [ toHie $ listScopes (mkLScope body) guards
+      , toHie body
+      ]
+    XGRHS _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (Context (Located (IdP a)))
+         , HasType (LHsExpr a)
+         , ToHie (PScoped (LPat a))
+         , ToHie (MatchGroup a (LHsExpr a))
+         , ToHie (LGRHS a (LHsExpr a))
+         , ToHie (RContext (HsRecordBinds a))
+         , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
+         , ToHie (ArithSeqInfo a)
+         , ToHie (LHsCmdTop a)
+         , ToHie (RScoped (GuardLStmt a))
+         , ToHie (RScoped (LHsLocalBinds a))
+         , ToHie (TScoped (LHsWcType (NoGhcTc a)))
+         , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
+         , Data (HsExpr a)
+         , Data (HsSplice a)
+         , Data (HsTupArg a)
+         , Data (AmbiguousFieldOcc a)
+         ) => ToHie (LHsExpr (GhcPass p)) where
+  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
+      HsVar _ (L _ var) ->
+        [ toHie $ C Use (L mspan var)
+             -- Patch up var location since typechecker removes it
+        ]
+      HsUnboundVar _ _ ->
+        []
+      HsConLikeOut _ con ->
+        [ toHie $ C Use $ L mspan $ conLikeName con
+        ]
+      HsRecFld _ fld ->
+        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
+        ]
+      HsOverLabel _ _ _ -> []
+      HsIPVar _ _ -> []
+      HsOverLit _ _ -> []
+      HsLit _ _ -> []
+      HsLam _ mg ->
+        [ toHie mg
+        ]
+      HsLamCase _ mg ->
+        [ toHie mg
+        ]
+      HsApp _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsAppType _ expr sig ->
+        [ toHie expr
+        , toHie $ TS (ResolvedScopes []) sig
+        ]
+      OpApp _ a b c ->
+        [ toHie a
+        , toHie b
+        , toHie c
+        ]
+      NegApp _ a _ ->
+        [ toHie a
+        ]
+      HsPar _ a ->
+        [ toHie a
+        ]
+      SectionL _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      SectionR _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      ExplicitTuple _ args _ ->
+        [ toHie args
+        ]
+      ExplicitSum _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsCase _ expr matches ->
+        [ toHie expr
+        , toHie matches
+        ]
+      HsIf _ _ a b c ->
+        [ toHie a
+        , toHie b
+        , toHie c
+        ]
+      HsMultiIf _ grhss ->
+        [ toHie grhss
+        ]
+      HsLet _ binds expr ->
+        [ toHie $ RS (mkLScope expr) binds
+        , toHie expr
+        ]
+      HsDo _ _ (L ispan stmts) ->
+        [ pure $ locOnly ispan
+        , toHie $ listScopes NoScope stmts
+        ]
+      ExplicitList _ _ exprs ->
+        [ toHie exprs
+        ]
+      RecordCon {rcon_con_name = name, rcon_flds = binds}->
+        [ toHie $ C Use name
+        , toHie $ RC RecFieldAssign $ binds
+        ]
+      RecordUpd {rupd_expr = expr, rupd_flds = upds}->
+        [ toHie expr
+        , toHie $ map (RC RecFieldAssign) upds
+        ]
+      ExprWithTySig _ expr sig ->
+        [ toHie expr
+        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
+        ]
+      ArithSeq _ _ info ->
+        [ toHie info
+        ]
+      HsSCC _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsCoreAnn _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsProc _ pat cmdtop ->
+        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
+        , toHie cmdtop
+        ]
+      HsStatic _ expr ->
+        [ toHie expr
+        ]
+      HsTick _ _ expr ->
+        [ toHie expr
+        ]
+      HsBinTick _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsTickPragma _ _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsWrap _ _ a ->
+        [ toHie $ L mspan a
+        ]
+      HsBracket _ b ->
+        [ toHie b
+        ]
+      HsRnBracketOut _ b p ->
+        [ toHie b
+        , toHie p
+        ]
+      HsTcBracketOut _ b p ->
+        [ toHie b
+        , toHie p
+        ]
+      HsSpliceE _ x ->
+        [ toHie $ L mspan x
+        ]
+      XExpr _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (LHsExpr a)
+         , Data (HsTupArg a)
+         ) => ToHie (LHsTupArg (GhcPass p)) where
+  toHie (L span arg) = concatM $ makeNode arg span : case arg of
+    Present _ expr ->
+      [ toHie expr
+      ]
+    Missing _ -> []
+    XTupArg _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (PScoped (LPat a))
+         , ToHie (LHsExpr a)
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (LHsLocalBinds a))
+         , ToHie (RScoped (ApplicativeArg a))
+         , ToHie (Located body)
+         , Data (StmtLR a a (Located body))
+         , Data (StmtLR a a (Located (HsExpr a)))
+         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
+  toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
+      LastStmt _ body _ _ ->
+        [ toHie body
+        ]
+      BindStmt _ pat body _ _ ->
+        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
+        , toHie body
+        ]
+      ApplicativeStmt _ stmts _ ->
+        [ concatMapM (toHie . RS scope . snd) stmts
+        ]
+      BodyStmt _ body _ _ ->
+        [ toHie body
+        ]
+      LetStmt _ binds ->
+        [ toHie $ RS scope binds
+        ]
+      ParStmt _ parstmts _ _ ->
+        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
+                          toHie $ listScopes NoScope stmts)
+                     parstmts
+        ]
+      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
+        [ toHie $ listScopes scope stmts
+        , toHie using
+        , toHie by
+        ]
+      RecStmt {recS_stmts = stmts} ->
+        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
+        ]
+      XStmtLR _ -> []
+
+instance ( ToHie (LHsExpr a)
+         , ToHie (PScoped (LPat a))
+         , ToHie (BindContext (LHsBind a))
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (HsValBindsLR a a))
+         , Data (HsLocalBinds a)
+         ) => ToHie (RScoped (LHsLocalBinds a)) where
+  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
+      EmptyLocalBinds _ -> []
+      HsIPBinds _ _ -> []
+      HsValBinds _ valBinds ->
+        [ toHie $ RS (combineScopes scope $ mkScope sp)
+                      valBinds
+        ]
+      XHsLocalBindsLR _ -> []
+
+instance ( ToHie (BindContext (LHsBind a))
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (XXValBindsLR a a))
+         ) => ToHie (RScoped (HsValBindsLR a a)) where
+  toHie (RS sc v) = concatM $ case v of
+    ValBinds _ binds sigs ->
+      [ toHie $ fmap (BC RegularBind sc) binds
+      , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+      ]
+    XValBindsLR x -> [ toHie $ RS sc x ]
+
+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
+  toHie (RS sc (NValBinds binds sigs)) = concatM $
+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+    ]
+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
+  toHie (RS sc (NValBinds binds sigs)) = concatM $
+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+    ]
+
+instance ( ToHie (RContext (LHsRecField a arg))
+         ) => ToHie (RContext (HsRecFields a arg)) where
+  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
+
+instance ( ToHie (RFContext (Located label))
+         , ToHie arg
+         , HasLoc arg
+         , Data label
+         , Data arg
+         ) => ToHie (RContext (LHsRecField' label arg)) where
+  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
+    HsRecField label expr _ ->
+      [ toHie $ RFC c (getRealSpan $ loc expr) label
+      , toHie expr
+      ]
+
+removeDefSrcSpan :: Name -> Name
+removeDefSrcSpan n = setNameLoc n noSrcSpan
+
+instance ToHie (RFContext (LFieldOcc GhcRn)) where
+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of
+    FieldOcc name _ ->
+      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+      ]
+    XFieldOcc _ -> []
+
+instance ToHie (RFContext (LFieldOcc GhcTc)) where
+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of
+    FieldOcc var _ ->
+      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      in [ toHie $ C (RecField c rhs) (L nspan var')
+         ]
+    XFieldOcc _ -> []
+
+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
+    Unambiguous name _ ->
+      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+      ]
+    Ambiguous _name _ ->
+      [ ]
+    XAmbiguousFieldOcc _ -> []
+
+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
+    Unambiguous var _ ->
+      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      in [ toHie $ C (RecField c rhs) (L nspan var')
+         ]
+    Ambiguous var _ ->
+      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      in [ toHie $ C (RecField c rhs) (L nspan var')
+         ]
+    XAmbiguousFieldOcc _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (PScoped (LPat a))
+         , ToHie (BindContext (LHsBind a))
+         , ToHie (LHsExpr a)
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (HsValBindsLR a a))
+         , Data (StmtLR a a (Located (HsExpr a)))
+         , Data (HsLocalBinds a)
+         ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
+  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
+    [ toHie $ PS Nothing sc NoScope pat
+    , toHie expr
+    ]
+  toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
+    [ toHie $ listScopes NoScope stmts
+    , toHie $ PS Nothing sc NoScope pat
+    ]
+  toHie (RS _ (XApplicativeArg _)) = pure []
+
+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
+  toHie (PrefixCon args) = toHie args
+  toHie (RecCon rec) = toHie rec
+  toHie (InfixCon a b) = concatM [ toHie a, toHie b]
+
+instance ( ToHie (LHsCmd a)
+         , Data  (HsCmdTop a)
+         ) => ToHie (LHsCmdTop a) where
+  toHie (L span top) = concatM $ makeNode top span : case top of
+    HsCmdTop _ cmd ->
+      [ toHie cmd
+      ]
+    XCmdTop _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (PScoped (LPat a))
+         , ToHie (BindContext (LHsBind a))
+         , ToHie (LHsExpr a)
+         , ToHie (MatchGroup a (LHsCmd a))
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (HsValBindsLR a a))
+         , Data (HsCmd a)
+         , Data (HsCmdTop a)
+         , Data (StmtLR a a (Located (HsCmd a)))
+         , Data (HsLocalBinds a)
+         , Data (StmtLR a a (Located (HsExpr a)))
+         ) => ToHie (LHsCmd (GhcPass p)) where
+  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
+      HsCmdArrApp _ a b _ _ ->
+        [ toHie a
+        , toHie b
+        ]
+      HsCmdArrForm _ a _ _ cmdtops ->
+        [ toHie a
+        , toHie cmdtops
+        ]
+      HsCmdApp _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsCmdLam _ mg ->
+        [ toHie mg
+        ]
+      HsCmdPar _ a ->
+        [ toHie a
+        ]
+      HsCmdCase _ expr alts ->
+        [ toHie expr
+        , toHie alts
+        ]
+      HsCmdIf _ _ a b c ->
+        [ toHie a
+        , toHie b
+        , toHie c
+        ]
+      HsCmdLet _ binds cmd' ->
+        [ toHie $ RS (mkLScope cmd') binds
+        , toHie cmd'
+        ]
+      HsCmdDo _ (L ispan stmts) ->
+        [ pure $ locOnly ispan
+        , toHie $ listScopes NoScope stmts
+        ]
+      HsCmdWrap _ _ _ -> []
+      XCmd _ -> []
+
+instance ToHie (TyClGroup GhcRn) where
+  toHie (TyClGroup _ classes roles instances) = concatM
+    [ toHie classes
+    , toHie roles
+    , toHie instances
+    ]
+  toHie (XTyClGroup _) = pure []
+
+instance ToHie (LTyClDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      FamDecl {tcdFam = fdecl} ->
+        [ toHie (L span fdecl)
+        ]
+      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
+        [ toHie $ C (Decl SynDec $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
+        , toHie typ
+        ]
+      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
+        [ toHie $ C (Decl DataDec $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
+        , toHie defn
+        ]
+        where
+          quant_scope = mkLScope $ dd_ctxt defn
+          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
+          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
+          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
+          deriv_sc = mkLScope $ dd_derivs defn
+      ClassDecl { tcdCtxt = context
+                , tcdLName = name
+                , tcdTyVars = vars
+                , tcdFDs = deps
+                , tcdSigs = sigs
+                , tcdMeths = meths
+                , tcdATs = typs
+                , tcdATDefs = deftyps
+                } ->
+        [ toHie $ C (Decl ClassDec $ getRealSpan span) name
+        , toHie context
+        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
+        , toHie deps
+        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
+        , toHie $ fmap (BC InstanceBind ModuleScope) meths
+        , toHie typs
+        , concatMapM (pure . locOnly . getLoc) deftyps
+        , toHie deftyps
+        ]
+        where
+          context_scope = mkLScope context
+          rhs_scope = foldl1' combineScopes $ map mkScope
+            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
+      XTyClDecl _ -> []
+
+instance ToHie (LFamilyDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      FamilyDecl _ info name vars _ sig inj ->
+        [ toHie $ C (Decl FamDec $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes [rhsSpan]) vars
+        , toHie info
+        , toHie $ RS injSpan sig
+        , toHie inj
+        ]
+        where
+          rhsSpan = sigSpan `combineScopes` injSpan
+          sigSpan = mkScope $ getLoc sig
+          injSpan = maybe NoScope (mkScope . getLoc) inj
+      XFamilyDecl _ -> []
+
+instance ToHie (FamilyInfo GhcRn) where
+  toHie (ClosedTypeFamily (Just eqns)) = concatM $
+    [ concatMapM (pure . locOnly . getLoc) eqns
+    , toHie $ map go eqns
+    ]
+    where
+      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
+  toHie _ = pure []
+
+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
+  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
+      NoSig _ ->
+        []
+      KindSig _ k ->
+        [ toHie k
+        ]
+      TyVarSig _ bndr ->
+        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
+        ]
+      XFamilyResultSig _ -> []
+
+instance ToHie (Located (FunDep (Located Name))) where
+  toHie (L span fd@(lhs, rhs)) = concatM $
+    [ makeNode fd span
+    , toHie $ map (C Use) lhs
+    , toHie $ map (C Use) rhs
+    ]
+
+instance (ToHie rhs, HasLoc rhs)
+    => ToHie (TScoped (FamEqn GhcRn rhs)) where
+  toHie (TS _ f) = toHie f
+
+instance (ToHie rhs, HasLoc rhs)
+    => ToHie (FamEqn GhcRn rhs) where
+  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
+    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+    , toHie pats
+    , toHie rhs
+    ]
+    where scope = combineScopes patsScope rhsScope
+          patsScope = mkScope (loc pats)
+          rhsScope = mkScope (loc rhs)
+  toHie (XFamEqn _) = pure []
+
+instance ToHie (LInjectivityAnn GhcRn) where
+  toHie (L span ann) = concatM $ makeNode ann span : case ann of
+      InjectivityAnn lhs rhs ->
+        [ toHie $ C Use lhs
+        , toHie $ map (C Use) rhs
+        ]
+
+instance ToHie (HsDataDefn GhcRn) where
+  toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
+    [ toHie ctx
+    , toHie mkind
+    , toHie cons
+    , toHie derivs
+    ]
+  toHie (XHsDataDefn _) = pure []
+
+instance ToHie (HsDeriving GhcRn) where
+  toHie (L span clauses) = concatM
+    [ pure $ locOnly span
+    , toHie clauses
+    ]
+
+instance ToHie (LHsDerivingClause GhcRn) where
+  toHie (L span cl) = concatM $ makeNode cl span : case cl of
+      HsDerivingClause _ strat (L ispan tys) ->
+        [ toHie strat
+        , pure $ locOnly ispan
+        , toHie $ map (TS (ResolvedScopes [])) tys
+        ]
+      XHsDerivingClause _ -> []
+
+instance ToHie (Located (DerivStrategy GhcRn)) where
+  toHie (L span strat) = concatM $ makeNode strat span : case strat of
+      StockStrategy -> []
+      AnyclassStrategy -> []
+      NewtypeStrategy -> []
+      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
+
+instance ToHie (Located OverlapMode) where
+  toHie (L span _) = pure $ locOnly span
+
+instance ToHie (LConDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ConDeclGADT { con_names = names, con_qvars = qvars
+                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
+        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
+        , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
+        , toHie ctx
+        , toHie args
+        , toHie typ
+        ]
+        where
+          rhsScope = combineScopes argsScope tyScope
+          ctxScope = maybe NoScope mkLScope ctx
+          argsScope = condecl_scope args
+          tyScope = mkLScope typ
+      ConDeclH98 { con_name = name, con_ex_tvs = qvars
+                 , con_mb_cxt = ctx, con_args = dets } ->
+        [ toHie $ C (Decl ConDec $ getRealSpan span) name
+        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
+        , toHie ctx
+        , toHie dets
+        ]
+        where
+          rhsScope = combineScopes ctxScope argsScope
+          ctxScope = maybe NoScope mkLScope ctx
+          argsScope = condecl_scope dets
+      XConDecl _ -> []
+    where condecl_scope args = case args of
+            PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
+            InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
+            RecCon x -> mkLScope x
+
+instance ToHie (Located [LConDeclField GhcRn]) where
+  toHie (L span decls) = concatM $
+    [ pure $ locOnly span
+    , toHie decls
+    ]
+
+instance ( HasLoc thing
+         , ToHie (TScoped thing)
+         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
+  toHie (TS sc (HsIB ibrn a)) = concatM $
+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+      , toHie $ TS sc a
+      ]
+    where span = loc a
+  toHie (TS _ (XHsImplicitBndrs _)) = pure []
+
+instance ( HasLoc thing
+         , ToHie (TScoped thing)
+         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
+  toHie (TS sc (HsWC names a)) = concatM $
+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
+      , toHie $ TS sc a
+      ]
+    where span = loc a
+  toHie (TS _ (XHsWildCardBndrs _)) = pure []
+
+instance ToHie (SigContext (LSig GhcRn)) where
+  toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
+      TypeSig _ names typ ->
+        [ toHie $ map (C TyDecl) names
+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+        ]
+      PatSynSig _ names typ ->
+        [ toHie $ map (C TyDecl) names
+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+        ]
+      ClassOpSig _ _ names typ ->
+        [ case styp of
+            ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
+            _  -> toHie $ map (C $ TyDecl) names
+        , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
+        ]
+      IdSig _ _ -> []
+      FixSig _ fsig ->
+        [ toHie $ L sp fsig
+        ]
+      InlineSig _ name _ ->
+        [ toHie $ (C Use) name
+        ]
+      SpecSig _ name typs _ ->
+        [ toHie $ (C Use) name
+        , toHie $ map (TS (ResolvedScopes [])) typs
+        ]
+      SpecInstSig _ _ typ ->
+        [ toHie $ TS (ResolvedScopes []) typ
+        ]
+      MinimalSig _ _ form ->
+        [ toHie form
+        ]
+      SCCFunSig _ _ name mtxt ->
+        [ toHie $ (C Use) name
+        , pure $ maybe [] (locOnly . getLoc) mtxt
+        ]
+      CompleteMatchSig _ _ (L ispan names) typ ->
+        [ pure $ locOnly ispan
+        , toHie $ map (C Use) names
+        , toHie $ fmap (C Use) typ
+        ]
+      XSig _ -> []
+
+instance ToHie (LHsType GhcRn) where
+  toHie x = toHie $ TS (ResolvedScopes []) x
+
+instance ToHie (TScoped (LHsType GhcRn)) where
+  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
+      HsForAllTy _ _ bndrs body ->
+        [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
+        , toHie body
+        ]
+      HsQualTy _ ctx body ->
+        [ toHie ctx
+        , toHie body
+        ]
+      HsTyVar _ _ var ->
+        [ toHie $ C Use var
+        ]
+      HsAppTy _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsAppKindTy _ ty ki ->
+        [ toHie ty
+        , toHie $ TS (ResolvedScopes []) ki
+        ]
+      HsFunTy _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsListTy _ a ->
+        [ toHie a
+        ]
+      HsTupleTy _ _ tys ->
+        [ toHie tys
+        ]
+      HsSumTy _ tys ->
+        [ toHie tys
+        ]
+      HsOpTy _ a op b ->
+        [ toHie a
+        , toHie $ C Use op
+        , toHie b
+        ]
+      HsParTy _ a ->
+        [ toHie a
+        ]
+      HsIParamTy _ ip ty ->
+        [ toHie ip
+        , toHie ty
+        ]
+      HsKindSig _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsSpliceTy _ a ->
+        [ toHie $ L span a
+        ]
+      HsDocTy _ a _ ->
+        [ toHie a
+        ]
+      HsBangTy _ _ ty ->
+        [ toHie ty
+        ]
+      HsRecTy _ fields ->
+        [ toHie fields
+        ]
+      HsExplicitListTy _ _ tys ->
+        [ toHie tys
+        ]
+      HsExplicitTupleTy _ tys ->
+        [ toHie tys
+        ]
+      HsTyLit _ _ -> []
+      HsWildCardTy _ -> []
+      HsStarTy _ _ -> []
+      XHsType _ -> []
+
+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
+  toHie (HsValArg tm) = toHie tm
+  toHie (HsTypeArg _ ty) = toHie ty
+  toHie (HsArgPar sp) = pure $ locOnly sp
+
+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
+  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
+      UserTyVar _ var ->
+        [ toHie $ C (TyVarBind sc tsc) var
+        ]
+      KindedTyVar _ var kind ->
+        [ toHie $ C (TyVarBind sc tsc) var
+        , toHie kind
+        ]
+      XTyVarBndr _ -> []
+
+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
+  toHie (TS sc (HsQTvs implicits vars)) = concatM $
+    [ pure $ bindingsOnly bindings
+    , toHie $ tvScopes sc NoScope vars
+    ]
+    where
+      varLoc = loc vars
+      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
+  toHie (TS _ (XLHsQTyVars _)) = pure []
+
+instance ToHie (LHsContext GhcRn) where
+  toHie (L span tys) = concatM $
+      [ pure $ locOnly span
+      , toHie tys
+      ]
+
+instance ToHie (LConDeclField GhcRn) where
+  toHie (L span field) = concatM $ makeNode field span : case field of
+      ConDeclField _ fields typ _ ->
+        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
+        , toHie typ
+        ]
+      XConDeclField _ -> []
+
+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
+  toHie (From expr) = toHie expr
+  toHie (FromThen a b) = concatM $
+    [ toHie a
+    , toHie b
+    ]
+  toHie (FromTo a b) = concatM $
+    [ toHie a
+    , toHie b
+    ]
+  toHie (FromThenTo a b c) = concatM $
+    [ toHie a
+    , toHie b
+    , toHie c
+    ]
+
+instance ToHie (LSpliceDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      SpliceDecl _ splice _ ->
+        [ toHie splice
+        ]
+      XSpliceDecl _ -> []
+
+instance ToHie (HsBracket a) where
+  toHie _ = pure []
+
+instance ToHie PendingRnSplice where
+  toHie _ = pure []
+
+instance ToHie PendingTcSplice where
+  toHie _ = pure []
+
+instance ToHie (LBooleanFormula (Located Name)) where
+  toHie (L span form) = concatM $ makeNode form span : case form of
+      Var a ->
+        [ toHie $ C Use a
+        ]
+      And forms ->
+        [ toHie forms
+        ]
+      Or forms ->
+        [ toHie forms
+        ]
+      Parens f ->
+        [ toHie f
+        ]
+
+instance ToHie (Located HsIPName) where
+  toHie (L span e) = makeNode e span
+
+instance ( ToHie (LHsExpr a)
+         , Data (HsSplice a)
+         ) => ToHie (Located (HsSplice a)) where
+  toHie (L span sp) = concatM $ makeNode sp span : case sp of
+      HsTypedSplice _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsUntypedSplice _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsQuasiQuote _ _ _ ispan _ ->
+        [ pure $ locOnly ispan
+        ]
+      HsSpliced _ _ _ ->
+        []
+      HsSplicedT _ ->
+        []
+      XSplice _ -> []
+
+instance ToHie (LRoleAnnotDecl GhcRn) where
+  toHie (L span annot) = concatM $ makeNode annot span : case annot of
+      RoleAnnotDecl _ var roles ->
+        [ toHie $ C Use var
+        , concatMapM (pure . locOnly . getLoc) roles
+        ]
+      XRoleAnnotDecl _ -> []
+
+instance ToHie (LInstDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ClsInstD _ d ->
+        [ toHie $ L span d
+        ]
+      DataFamInstD _ d ->
+        [ toHie $ L span d
+        ]
+      TyFamInstD _ d ->
+        [ toHie $ L span d
+        ]
+      XInstDecl _ -> []
+
+instance ToHie (LClsInstDecl GhcRn) where
+  toHie (L span decl) = concatM
+    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
+    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
+    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
+    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
+    , toHie $ cid_tyfam_insts decl
+    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
+    , toHie $ cid_datafam_insts decl
+    , toHie $ cid_overlap_mode decl
+    ]
+
+instance ToHie (LDataFamInstDecl GhcRn) where
+  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
+instance ToHie (LTyFamInstDecl GhcRn) where
+  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
+instance ToHie (Context a)
+         => ToHie (PatSynFieldContext (RecordPatSynField a)) where
+  toHie (PSC sp (RecordPatSynField a b)) = concatM $
+    [ toHie $ C (RecField RecFieldDecl sp) a
+    , toHie $ C Use b
+    ]
+
+instance ToHie (LDerivDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      DerivDecl _ typ strat overlap ->
+        [ toHie $ TS (ResolvedScopes []) typ
+        , toHie strat
+        , toHie overlap
+        ]
+      XDerivDecl _ -> []
+
+instance ToHie (LFixitySig GhcRn) where
+  toHie (L span sig) = concatM $ makeNode sig span : case sig of
+      FixitySig _ vars _ ->
+        [ toHie $ map (C Use) vars
+        ]
+      XFixitySig _ -> []
+
+instance ToHie (LDefaultDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      DefaultDecl _ typs ->
+        [ toHie typs
+        ]
+      XDefaultDecl _ -> []
+
+instance ToHie (LForeignDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
+        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes []) sig
+        , toHie fi
+        ]
+      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
+        [ toHie $ C Use name
+        , toHie $ TS (ResolvedScopes []) sig
+        , toHie fe
+        ]
+      XForeignDecl _ -> []
+
+instance ToHie ForeignImport where
+  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
+    [ locOnly a
+    , locOnly b
+    , locOnly c
+    ]
+
+instance ToHie ForeignExport where
+  toHie (CExport (L a _) (L b _)) = pure $ concat $
+    [ locOnly a
+    , locOnly b
+    ]
+
+instance ToHie (LWarnDecls GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      Warnings _ _ warnings ->
+        [ toHie warnings
+        ]
+      XWarnDecls _ -> []
+
+instance ToHie (LWarnDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      Warning _ vars _ ->
+        [ toHie $ map (C Use) vars
+        ]
+      XWarnDecl _ -> []
+
+instance ToHie (LAnnDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      HsAnnotation _ _ prov expr ->
+        [ toHie prov
+        , toHie expr
+        ]
+      XAnnDecl _ -> []
+
+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
+  toHie (ValueAnnProvenance a) = toHie $ C Use a
+  toHie (TypeAnnProvenance a) = toHie $ C Use a
+  toHie ModuleAnnProvenance = pure []
+
+instance ToHie (LRuleDecls GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      HsRules _ _ rules ->
+        [ toHie rules
+        ]
+      XRuleDecls _ -> []
+
+instance ToHie (LRuleDecl GhcRn) where
+  toHie (L _ (XRuleDecl _)) = pure []
+  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
+        [ makeNode r span
+        , pure $ locOnly $ getLoc rname
+        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+        , toHie $ map (RS $ mkScope span) bndrs
+        , toHie exprA
+        , toHie exprB
+        ]
+    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
+          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
+          exprA_sc = mkLScope exprA
+          exprB_sc = mkLScope exprB
+
+instance ToHie (RScoped (LRuleBndr GhcRn)) where
+  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
+      RuleBndr _ var ->
+        [ toHie $ C (ValBind RegularBind sc Nothing) var
+        ]
+      RuleBndrSig _ var typ ->
+        [ toHie $ C (ValBind RegularBind sc Nothing) var
+        , toHie $ TS (ResolvedScopes [sc]) typ
+        ]
+      XRuleBndr _ -> []
+
+instance ToHie (LImportDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
+        [ toHie $ IEC Import name
+        , toHie $ fmap (IEC ImportAs) as
+        , maybe (pure []) goIE hidden
+        ]
+      XImportDecl _ -> []
+    where
+      goIE (hiding, (L sp liens)) = concatM $
+        [ pure $ locOnly sp
+        , toHie $ map (IEC c) liens
+        ]
+        where
+         c = if hiding then ImportHiding else Import
+
+instance ToHie (IEContext (LIE GhcRn)) where
+  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
+      IEVar _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEThingAbs _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEThingAll _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEThingWith _ n _ ns flds ->
+        [ toHie $ IEC c n
+        , toHie $ map (IEC c) ns
+        , toHie $ map (IEC c) flds
+        ]
+      IEModuleContents _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEGroup _ _ _ -> []
+      IEDoc _ _ -> []
+      IEDocNamed _ _ -> []
+      XIE _ -> []
+
+instance ToHie (IEContext (LIEWrappedName Name)) where
+  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
+      IEName n ->
+        [ toHie $ C (IEThing c) n
+        ]
+      IEPattern p ->
+        [ toHie $ C (IEThing c) p
+        ]
+      IEType n ->
+        [ toHie $ C (IEThing c) n
+        ]
+
+instance ToHie (IEContext (Located (FieldLbl Name))) where
+  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
+      FieldLabel _ _ n ->
+        [ toHie $ C (IEThing c) $ L span n
+        ]
diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieBin.hs
@@ -0,0 +1,273 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where
+
+import GhcPrelude
+
+import Binary
+import BinIface                   ( getDictFastString )
+import FastMutInt
+import FastString                 ( FastString )
+import Module                     ( Module )
+import Name
+import NameCache
+import Outputable
+import PrelInfo
+import SrcLoc
+import UniqSupply                 ( takeUniqFromSupply )
+import Unique
+import UniqFM
+
+import qualified Data.Array as A
+import Data.IORef
+import Data.List                  ( mapAccumR )
+import Data.Word                  ( Word32 )
+import Control.Monad              ( replicateM )
+import System.Directory           ( createDirectoryIfMissing )
+import System.FilePath            ( takeDirectory )
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+  = ExternalName !Module !OccName !SrcSpan
+  | LocalName !OccName !SrcSpan
+  | KnownKeyName !Unique
+  deriving (Eq)
+
+instance Ord HieName where
+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+    -- Not actually non determinstic as it is a KnownKey
+  compare ExternalName{} _ = LT
+  compare LocalName{} ExternalName{} = GT
+  compare LocalName{} _ = LT
+  compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+  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
+
+
+data HieSymbolTable = HieSymbolTable
+  { hie_symtab_next :: !FastMutInt
+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
+  }
+
+data HieDictionary = HieDictionary
+  { hie_dict_next :: !FastMutInt -- The next index to use
+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
+  }
+
+initBinMemSize :: Int
+initBinMemSize = 1024*1024
+
+writeHieFile :: Binary a => FilePath -> a -> IO ()
+writeHieFile hie_file_path hiefile = do
+  bh0 <- openBinMem initBinMemSize
+
+  -- remember where the dictionary pointer will go
+  dict_p_p <- tellBin bh0
+  put_ bh0 dict_p_p
+
+  -- remember where the symbol table pointer will go
+  symtab_p_p <- tellBin bh0
+  put_ bh0 symtab_p_p
+
+  -- Make some intial state
+  symtab_next <- newFastMutInt
+  writeFastMutInt symtab_next 0
+  symtab_map <- newIORef emptyUFM
+  let hie_symtab = HieSymbolTable {
+                      hie_symtab_next = symtab_next,
+                      hie_symtab_map  = symtab_map }
+  dict_next_ref <- newFastMutInt
+  writeFastMutInt dict_next_ref 0
+  dict_map_ref <- newIORef emptyUFM
+  let hie_dict = HieDictionary {
+                      hie_dict_next = dict_next_ref,
+                      hie_dict_map  = dict_map_ref }
+
+  -- put the main thing
+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
+                                           (putName hie_symtab)
+                                           (putFastString hie_dict)
+  put_ bh hiefile
+
+  -- write the symtab pointer at the front of the file
+  symtab_p <- tellBin bh
+  putAt bh symtab_p_p symtab_p
+  seekBin bh symtab_p
+
+  -- write the symbol table itself
+  symtab_next' <- readFastMutInt symtab_next
+  symtab_map'  <- readIORef symtab_map
+  putSymbolTable bh symtab_next' symtab_map'
+
+  -- write the dictionary pointer at the fornt of the file
+  dict_p <- tellBin bh
+  putAt bh dict_p_p dict_p
+  seekBin bh dict_p
+
+  -- write the dictionary itself
+  dict_next <- readFastMutInt dict_next_ref
+  dict_map  <- readIORef dict_map_ref
+  putDictionary bh dict_next dict_map
+
+  -- and send the result to the file
+  createDirectoryIfMissing True (takeDirectory hie_file_path)
+  writeBinMem bh hie_file_path
+  return ()
+
+readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)
+readHieFile nc file = do
+  bh0 <- readBinMem file
+
+  dict  <- get_dictionary bh0
+
+  -- read the symbol table so we are capable of reading the actual data
+  (bh1, nc') <- do
+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
+                                               (getDictFastString dict)
+      (nc', symtab) <- get_symbol_table bh1
+      let bh1' = setUserData bh1
+               $ newReadState (getSymTabName symtab)
+                              (getDictFastString dict)
+      return (bh1', nc')
+
+  -- load the actual data
+  hiefile <- get bh1
+  return (hiefile, nc')
+  where
+    get_dictionary bin_handle = do
+      dict_p <- get bin_handle
+      data_p <- tellBin bin_handle
+      seekBin bin_handle dict_p
+      dict <- getDictionary bin_handle
+      seekBin bin_handle data_p
+      return dict
+
+    get_symbol_table bh1 = do
+      symtab_p <- get bh1
+      data_p'  <- tellBin bh1
+      seekBin bh1 symtab_p
+      (nc', symtab) <- getSymbolTable bh1 nc
+      seekBin bh1 data_p'
+      return (nc', symtab)
+
+putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+putFastString HieDictionary { hie_dict_next = j_r,
+                              hie_dict_map  = out_r}  bh f
+  = do
+    out <- readIORef out_r
+    let unique = getUnique f
+    case lookupUFM out unique of
+        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
+        Nothing -> do
+           j <- readFastMutInt j_r
+           put_ bh (fromIntegral j :: Word32)
+           writeFastMutInt j_r (j + 1)
+           writeIORef out_r $! addToUFM out unique (j, f)
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
+putSymbolTable bh next_off symtab = do
+  put_ bh next_off
+  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
+  mapM_ (putHieName bh) names
+
+getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)
+getSymbolTable bh namecache = do
+  sz <- get bh
+  od_names <- replicateM sz (getHieName bh)
+  let arr = A.listArray (0,sz-1) names
+      (namecache', names) = mapAccumR fromHieName namecache od_names
+  return (namecache', arr)
+
+getSymTabName :: SymbolTable -> BinHandle -> IO Name
+getSymTabName st bh = do
+  i :: Word32 <- get bh
+  return $ st A.! (fromIntegral i)
+
+putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName (HieSymbolTable next ref) bh name = do
+  symmap <- readIORef ref
+  case lookupUFM symmap name of
+    Just (off, ExternalName mod occ (UnhelpfulSpan _))
+      | isGoodSrcSpan (nameSrcSpan name) -> do
+      let hieName = ExternalName mod occ (nameSrcSpan name)
+      writeIORef ref $! addToUFM symmap name (off, hieName)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, LocalName _occ span)
+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do
+      writeIORef ref $! addToUFM symmap name (off, toHieName name)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)
+    Nothing -> do
+        off <- readFastMutInt next
+        writeFastMutInt next (off+1)
+        writeIORef ref $! addToUFM symmap name (off, toHieName name)
+        put_ bh (fromIntegral off :: Word32)
+
+  where
+    notLocal :: HieName -> Bool
+    notLocal LocalName{} = False
+    notLocal _ = True
+
+
+-- ** Converting to and from `HieName`'s
+
+toHieName :: Name -> HieName
+toHieName name
+  | isKnownKeyName name = KnownKeyName (nameUnique name)
+  | isExternalName name = ExternalName (nameModule name)
+                                       (nameOccName name)
+                                       (nameSrcSpan name)
+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
+
+fromHieName :: NameCache -> HieName -> (NameCache, Name)
+fromHieName nc (ExternalName mod occ span) =
+    let cache = nsNames nc
+    in case lookupOrigNameCache cache mod occ of
+         Just name -> (nc, name)
+         Nothing ->
+           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+               name       = mkExternalName uniq mod occ span
+               new_cache  = extendNameCache cache mod occ name
+           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+fromHieName nc (LocalName occ span) =
+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+        name       = mkInternalName uniq occ span
+    in ( nc{ nsUniqs = us }, name )
+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
+    Nothing -> pprPanic "fromHieName:unknown known-key unique"
+                        (ppr (unpkUnique u))
+    Just n -> (nc, n)
+
+-- ** Reading and writing `HieName`'s
+
+putHieName :: BinHandle -> HieName -> IO ()
+putHieName bh (ExternalName mod occ span) = do
+  putByte bh 0
+  put_ bh (mod, occ, span)
+putHieName bh (LocalName occName span) = do
+  putByte bh 1
+  put_ bh (occName, span)
+putHieName bh (KnownKeyName uniq) = do
+  putByte bh 2
+  put_ bh $ unpkUnique uniq
+
+getHieName :: BinHandle -> IO HieName
+getHieName bh = do
+  t <- getByte bh
+  case t of
+    0 -> do
+      (modu, occ, span) <- get bh
+      return $ ExternalName modu occ span
+    1 -> do
+      (occ, span) <- get bh
+      return $ LocalName occ span
+    2 -> do
+      (c,i) <- get bh
+      return $ KnownKeyName $ mkUnique c i
+    _ -> panic "HieBin.getHieName: invalid tag"
diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieDebug.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module HieDebug where
+
+import GhcPrelude
+
+import SrcLoc
+import Module
+import FastString
+import Outputable
+
+import HieTypes
+import HieBin
+import HieUtils
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Function    ( on )
+import Data.List        ( sortOn )
+import Data.Foldable    ( toList )
+
+ppHies :: Outputable a => (HieASTs a) -> SDoc
+ppHies (HieASTs asts) = M.foldrWithKey go "" asts
+  where
+    go k a rest = vcat $
+      [ "File: " <> ppr k
+      , ppHie a
+      , rest
+      ]
+
+ppHie :: Outputable a => HieAST a -> SDoc
+ppHie = go 0
+  where
+    go n (Node inf sp children) = hang header n rest
+      where
+        rest = vcat $ map (go (n+2)) children
+        header = hsep
+          [ "Node"
+          , ppr sp
+          , ppInfo inf
+          ]
+
+ppInfo :: Outputable a => NodeInfo a -> SDoc
+ppInfo ni = hsep
+  [ ppr $ toList $ nodeAnnotations ni
+  , ppr $ nodeType ni
+  , ppr $ M.toList $ nodeIdentifiers ni
+  ]
+
+type Diff a = a -> a -> [SDoc]
+
+diffFile :: Diff HieFile
+diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
+
+diffAsts :: (Outputable a, Eq 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 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
+      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
+     ++ (diffList diffType `on` nodeType) info1 info2
+     ++ (diffIdents `on` nodeIdentifiers) info1 info2
+    diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
+    diffIdent (a,b) (c,d) = diffName a c
+                         ++ eqDiff b d
+    diffName (Right a) (Right b) = case (a,b) of
+      (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')
+      (LocalName o _, ExternalName _ o' _) -> eqDiff o o'
+      _ -> eqDiff a b
+    diffName a b = eqDiff a b
+
+type DiffIdent = Either ModuleName HieName
+
+normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
+normalizeIdents = sortOn fst . map (first toHieName) . M.toList
+  where
+    first f (a,b) = (fmap f a, b)
+
+diffList :: Diff a -> Diff [a]
+diffList f xs ys
+  | length xs == length ys = concat $ zipWith f xs ys
+  | otherwise = ["length of lists doesn't match"]
+
+eqDiff :: (Outputable a, Eq a) => Diff a
+eqDiff a b
+  | a == b = []
+  | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]
+
+validAst :: HieAST a -> Either SDoc ()
+validAst (Node _ span children) = do
+  checkContainment children
+  checkSorted children
+  mapM_ validAst children
+  where
+    checkSorted [] = return ()
+    checkSorted [_] = return ()
+    checkSorted (x:y:xs)
+      | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)
+      | otherwise = Left $ hsep
+          [ ppr $ nodeSpan x
+          , "is not to the left of"
+          , ppr $ nodeSpan y
+          ]
+    checkContainment [] = return ()
+    checkContainment (x:xs)
+      | span `containsSpan` (nodeSpan x) = checkContainment xs
+      | otherwise = Left $ hsep
+          [ ppr $ span
+          , "does not contain"
+          , ppr $ nodeSpan x
+          ]
+
+-- | 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
+  where
+    refMap = generateReferencesMap asts
+    valid (Left _) _ = []
+    valid (Right n) refs = concatMap inScope refs
+      where
+        mapRef = foldMap getScopeFromContext . identInfo . snd
+        scopes = case foldMap mapRef refs of
+          Just xs -> xs
+          Nothing -> []
+        inScope (sp, dets)
+          |  definedInAsts asts n
+          && any isOccurrence (identInfo dets)
+            = case scopes of
+              [] -> []
+              _ -> if any (`scopeContainsSpan` sp) scopes
+                   then []
+                   else return $ hsep $
+                     [ "Name", ppr n, "at position", ppr sp
+                     , "doesn't occur in calculated scope", ppr scopes]
+          | otherwise = []
diff --git a/compiler/hieFile/HieTypes.hs b/compiler/hieFile/HieTypes.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieTypes.hs
@@ -0,0 +1,514 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module HieTypes where
+
+import GhcPrelude
+
+import Binary
+import FastString                 ( FastString )
+import IfaceType
+import Module                     ( ModuleName, Module )
+import Name                       ( Name )
+import Outputable hiding ( (<>) )
+import SrcLoc                     ( RealSrcSpan )
+import Avail
+
+import qualified Data.Array as A
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.ByteString            ( ByteString )
+import Data.Data                  ( Typeable, Data )
+import Data.Semigroup             ( Semigroup(..) )
+import Data.Word                  ( Word8 )
+import Control.Applicative        ( (<|>) )
+
+type Span = RealSrcSpan
+
+-- | Current version of @.hie@ files
+curHieVersion :: Word8
+curHieVersion = 0
+
+{- |
+GHC builds up a wealth of information about Haskell source as it compiles it.
+@.hie@ files are a way of persisting some of this information to disk so that
+external tools that need to work with haskell source don't need to parse,
+typecheck, and rename all over again. These files contain:
+
+  * a simplified AST
+
+       * nodes are annotated with source positions and types
+       * identifiers are annotated with scope information
+
+  * the raw bytes of the initial Haskell source
+
+Besides saving compilation cycles, @.hie@ files also offer a more stable
+interface than the GHC API.
+-}
+data HieFile = HieFile
+    { hie_version :: Word8
+    -- ^ version of the HIE format
+
+    , hie_ghc_version :: ByteString
+    -- ^ Version of GHC that produced this file
+
+    , hie_hs_file :: FilePath
+    -- ^ Initial Haskell source file path
+
+    , hie_module :: Module
+    -- ^ The module this HIE file is for
+
+    , hie_types :: A.Array TypeIndex HieTypeFlat
+    -- ^ Types referenced in the 'hie_asts'.
+    --
+    -- See Note [Efficient serialization of redundant type info]
+
+    , hie_asts :: HieASTs TypeIndex
+    -- ^ Type-annotated abstract syntax trees
+
+    , hie_exports :: [AvailInfo]
+    -- ^ The names that this module exports
+
+    , hie_hs_src :: ByteString
+    -- ^ Raw bytes of the initial Haskell source
+    }
+
+instance Binary HieFile where
+  put_ bh hf = do
+    put_ bh $ hie_version hf
+    put_ bh $ hie_ghc_version hf
+    put_ bh $ hie_hs_file hf
+    put_ bh $ hie_module hf
+    put_ bh $ hie_types hf
+    put_ bh $ hie_asts hf
+    put_ bh $ hie_exports hf
+    put_ bh $ hie_hs_src hf
+
+  get bh = HieFile
+    <$> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+
+
+{-
+Note [Efficient serialization of redundant type info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The type information in .hie files is highly repetitive and redundant. For
+example, consider the expression
+
+    const True 'a'
+
+There is a lot of shared structure between the types of subterms:
+
+  * const True 'a' ::                 Bool
+  * const True     ::         Char -> Bool
+  * const          :: Bool -> Char -> Bool
+
+Since all 3 of these types need to be stored in the .hie file, it is worth
+making an effort to deduplicate this shared structure. The trick is to define
+a new data type that is a flattened version of 'Type':
+
+    data HieType a = HAppTy a a  -- data Type = AppTy Type Type
+                   | HFunTy a a  --           | FunTy Type Type
+                   | ...
+
+    type TypeIndex = Int
+
+Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',
+where the 'TypeIndex's in the 'HieType' are references to other elements of the
+array. Types recovered from GHC are deduplicated and stored in this compressed
+form with sharing of subtrees.
+-}
+
+type TypeIndex = Int
+
+-- | A flattened version of 'Type'.
+--
+-- See Note [Efficient serialization of redundant type info]
+data HieType a
+  = HTyVarTy Name
+  | HAppTy a (HieArgs a)
+  | HTyConApp IfaceTyCon (HieArgs a)
+  | HForAllTy ((Name, a),ArgFlag) a
+  | HFunTy  a a
+  | HQualTy a a           -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')
+  | HLitTy IfaceTyLit
+  | HCastTy a
+  | HCoercionTy
+    deriving (Functor, Foldable, Traversable, Eq)
+
+type HieTypeFlat = HieType TypeIndex
+
+-- | Roughly isomorphic to the original core 'Type'.
+newtype HieTypeFix = Roll (HieType (HieTypeFix))
+
+instance Binary (HieType TypeIndex) where
+  put_ bh (HTyVarTy n) = do
+    putByte bh 0
+    put_ bh n
+  put_ bh (HAppTy a b) = do
+    putByte bh 1
+    put_ bh a
+    put_ bh b
+  put_ bh (HTyConApp n xs) = do
+    putByte bh 2
+    put_ bh n
+    put_ bh xs
+  put_ bh (HForAllTy bndr a) = do
+    putByte bh 3
+    put_ bh bndr
+    put_ bh a
+  put_ bh (HFunTy a b) = do
+    putByte bh 4
+    put_ bh a
+    put_ bh b
+  put_ bh (HQualTy a b) = do
+    putByte bh 5
+    put_ bh a
+    put_ bh b
+  put_ bh (HLitTy l) = do
+    putByte bh 6
+    put_ bh l
+  put_ bh (HCastTy a) = do
+    putByte bh 7
+    put_ bh a
+  put_ bh (HCoercionTy) = putByte bh 8
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> HTyVarTy <$> get bh
+      1 -> HAppTy <$> get bh <*> get bh
+      2 -> HTyConApp <$> get bh <*> get bh
+      3 -> HForAllTy <$> get bh <*> get bh
+      4 -> HFunTy <$> get bh <*> get bh
+      5 -> HQualTy <$> get bh <*> get bh
+      6 -> HLitTy <$> get bh
+      7 -> HCastTy <$> get bh
+      8 -> return HCoercionTy
+      _ -> panic "Binary (HieArgs Int): invalid tag"
+
+
+-- | A list of type arguments along with their respective visibilities (ie. is
+-- this an argument that would return 'True' for 'isVisibleArgFlag'?).
+newtype HieArgs a = HieArgs [(Bool,a)]
+  deriving (Functor, Foldable, Traversable, Eq)
+
+instance Binary (HieArgs TypeIndex) where
+  put_ bh (HieArgs xs) = put_ bh xs
+  get bh = HieArgs <$> get bh
+
+-- | Mapping from filepaths (represented using 'FastString') to the
+-- corresponding AST
+newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }
+  deriving (Functor, Foldable, Traversable)
+
+instance Binary (HieASTs TypeIndex) where
+  put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
+  get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
+
+
+data HieAST a =
+  Node
+    { nodeInfo :: NodeInfo a
+    , nodeSpan :: Span
+    , nodeChildren :: [HieAST a]
+    } deriving (Functor, Foldable, Traversable)
+
+instance Binary (HieAST TypeIndex) where
+  put_ bh ast = do
+    put_ bh $ nodeInfo ast
+    put_ bh $ nodeSpan ast
+    put_ bh $ nodeChildren ast
+
+  get bh = Node
+    <$> get bh
+    <*> get bh
+    <*> get bh
+
+
+-- | The information stored in one AST node.
+--
+-- The type parameter exists to provide flexibility in representation of types
+-- (see Note [Efficient serialization of redundant type info]).
+data NodeInfo a = NodeInfo
+    { nodeAnnotations :: S.Set (FastString,FastString)
+    -- ^ (name of the AST node constructor, name of the AST node Type)
+
+    , nodeType :: [a]
+    -- ^ The Haskell types of this node, if any.
+
+    , nodeIdentifiers :: NodeIdentifiers a
+    -- ^ All the identifiers and their details
+    } deriving (Functor, Foldable, Traversable)
+
+instance Binary (NodeInfo TypeIndex) where
+  put_ bh ni = do
+    put_ bh $ S.toAscList $ nodeAnnotations ni
+    put_ bh $ nodeType ni
+    put_ bh $ M.toList $ nodeIdentifiers ni
+  get bh = NodeInfo
+    <$> fmap (S.fromDistinctAscList) (get bh)
+    <*> get bh
+    <*> fmap (M.fromList) (get bh)
+
+type Identifier = Either ModuleName Name
+
+type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
+
+-- | Information associated with every identifier
+--
+-- We need to include types with identifiers because sometimes multiple
+-- identifiers occur in the same span(Overloaded Record Fields and so on)
+data IdentifierDetails a = IdentifierDetails
+  { identType :: Maybe a
+  , identInfo :: S.Set ContextInfo
+  } deriving (Eq, Functor, Foldable, Traversable)
+
+instance Outputable a => Outputable (IdentifierDetails a) where
+  ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)
+
+instance Semigroup (IdentifierDetails a) where
+  d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
+                               (S.union (identInfo d1) (identInfo d2))
+
+instance Monoid (IdentifierDetails a) where
+  mempty = IdentifierDetails Nothing S.empty
+
+instance Binary (IdentifierDetails TypeIndex) where
+  put_ bh dets = do
+    put_ bh $ identType dets
+    put_ bh $ S.toAscList $ identInfo dets
+  get bh =  IdentifierDetails
+    <$> get bh
+    <*> fmap (S.fromDistinctAscList) (get bh)
+
+
+-- | Different contexts under which identifiers exist
+data ContextInfo
+  = Use                -- ^ regular variable
+  | MatchBind
+  | IEThing IEType     -- ^ import/export
+  | TyDecl
+
+  -- | Value binding
+  | ValBind
+      BindType     -- ^ whether or not the binding is in an instance
+      Scope        -- ^ scope over which the value is bound
+      (Maybe Span) -- ^ span of entire binding
+
+  -- | Pattern binding
+  --
+  -- This case is tricky because the bound identifier can be used in two
+  -- distinct scopes. Consider the following example (with @-XViewPatterns@)
+  --
+  -- @
+  -- do (b, a, (a -> True)) <- bar
+  --    foo a
+  -- @
+  --
+  -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and
+  -- in the rest of the @do@-block in @foo a@.
+  | PatternBind
+      Scope        -- ^ scope /in the pattern/ (the variable bound can be used
+                   -- further in the pattern)
+      Scope        -- ^ rest of the scope outside the pattern
+      (Maybe Span) -- ^ span of entire binding
+
+  | ClassTyDecl (Maybe Span)
+
+  -- | Declaration
+  | Decl
+      DeclType     -- ^ type of declaration
+      (Maybe Span) -- ^ span of entire binding
+
+  -- | Type variable
+  | TyVarBind Scope TyVarScope
+
+  -- | Record field
+  | RecField RecFieldContext (Maybe Span)
+    deriving (Eq, Ord, Show)
+
+instance Outputable ContextInfo where
+  ppr = text . show
+
+instance Binary ContextInfo where
+  put_ bh Use = putByte bh 0
+  put_ bh (IEThing t) = do
+    putByte bh 1
+    put_ bh t
+  put_ bh TyDecl = putByte bh 2
+  put_ bh (ValBind bt sc msp) = do
+    putByte bh 3
+    put_ bh bt
+    put_ bh sc
+    put_ bh msp
+  put_ bh (PatternBind a b c) = do
+    putByte bh 4
+    put_ bh a
+    put_ bh b
+    put_ bh c
+  put_ bh (ClassTyDecl sp) = do
+    putByte bh 5
+    put_ bh sp
+  put_ bh (Decl a b) = do
+    putByte bh 6
+    put_ bh a
+    put_ bh b
+  put_ bh (TyVarBind a b) = do
+    putByte bh 7
+    put_ bh a
+    put_ bh b
+  put_ bh (RecField a b) = do
+    putByte bh 8
+    put_ bh a
+    put_ bh b
+  put_ bh MatchBind = putByte bh 9
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> return Use
+      1 -> IEThing <$> get bh
+      2 -> return TyDecl
+      3 -> ValBind <$> get bh <*> get bh <*> get bh
+      4 -> PatternBind <$> get bh <*> get bh <*> get bh
+      5 -> ClassTyDecl <$> get bh
+      6 -> Decl <$> get bh <*> get bh
+      7 -> TyVarBind <$> get bh <*> get bh
+      8 -> RecField <$> get bh <*> get bh
+      9 -> return MatchBind
+      _ -> panic "Binary ContextInfo: invalid tag"
+
+
+-- | Types of imports and exports
+data IEType
+  = Import
+  | ImportAs
+  | ImportHiding
+  | Export
+    deriving (Eq, Enum, Ord, Show)
+
+instance Binary IEType where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data RecFieldContext
+  = RecFieldDecl
+  | RecFieldAssign
+  | RecFieldMatch
+  | RecFieldOcc
+    deriving (Eq, Enum, Ord, Show)
+
+instance Binary RecFieldContext where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data BindType
+  = RegularBind
+  | InstanceBind
+    deriving (Eq, Ord, Show, Enum)
+
+instance Binary BindType where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data DeclType
+  = FamDec     -- ^ type or data family
+  | SynDec     -- ^ type synonym
+  | DataDec    -- ^ data declaration
+  | ConDec     -- ^ constructor declaration
+  | PatSynDec  -- ^ pattern synonym
+  | ClassDec   -- ^ class declaration
+  | InstDec    -- ^ instance declaration
+    deriving (Eq, Ord, Show, Enum)
+
+instance Binary DeclType where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data Scope
+  = NoScope
+  | LocalScope Span
+  | ModuleScope
+    deriving (Eq, Ord, Show, Typeable, Data)
+
+instance Outputable Scope where
+  ppr NoScope = text "NoScope"
+  ppr (LocalScope sp) = text "LocalScope" <+> ppr sp
+  ppr ModuleScope = text "ModuleScope"
+
+instance Binary Scope where
+  put_ bh NoScope = putByte bh 0
+  put_ bh (LocalScope span) = do
+    putByte bh 1
+    put_ bh span
+  put_ bh ModuleScope = putByte bh 2
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> return NoScope
+      1 -> LocalScope <$> get bh
+      2 -> return ModuleScope
+      _ -> panic "Binary Scope: invalid tag"
+
+
+-- | Scope of a type variable.
+--
+-- This warrants a data type apart from 'Scope' because of complexities
+-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For
+-- example, consider:
+--
+-- @
+-- foo, bar, baz :: forall a. a -> a
+-- @
+--
+-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we
+-- need a list of scopes to keep track of this. Furthermore, this list cannot be
+-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.
+--
+-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@
+-- which later gets resolved into a 'ResolvedScopes'.
+data TyVarScope
+  = ResolvedScopes [Scope]
+
+  -- | Unresolved scopes should never show up in the final @.hie@ file
+  | UnresolvedScope
+        [Name]        -- ^ names of the definitions over which the scope spans
+        (Maybe Span)  -- ^ the location of the instance/class declaration for
+                      -- the case where the type variable is declared in a
+                      -- method type signature
+    deriving (Eq, Ord)
+
+instance Show TyVarScope where
+  show (ResolvedScopes sc) = show sc
+  show _ = error "UnresolvedScope"
+
+instance Binary TyVarScope where
+  put_ bh (ResolvedScopes xs) = do
+    putByte bh 0
+    put_ bh xs
+  put_ bh (UnresolvedScope ns span) = do
+    putByte bh 1
+    put_ bh ns
+    put_ bh span
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> ResolvedScopes <$> get bh
+      1 -> UnresolvedScope <$> get bh <*> get bh
+      _ -> panic "Binary TyVarScope: invalid tag"
diff --git a/compiler/hieFile/HieUtils.hs b/compiler/hieFile/HieUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieUtils.hs
@@ -0,0 +1,455 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module HieUtils where
+
+import GhcPrelude
+
+import CoreMap
+import DynFlags                   ( DynFlags )
+import FastString                 ( FastString, mkFastString )
+import IfaceType
+import Name hiding (varName)
+import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )
+import SrcLoc
+import ToIface
+import TyCon
+import TyCoRep
+import Type
+import Var
+import VarEnv
+
+import HieTypes
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Array as A
+import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )
+import Data.Maybe                 ( maybeToList )
+import Data.Monoid
+import Data.Traversable           ( for )
+import Control.Monad.Trans.State.Strict hiding (get)
+
+
+generateReferencesMap
+  :: Foldable f
+  => f (HieAST a)
+  -> M.Map Identifier [(Span, IdentifierDetails a)]
+generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
+  where
+    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
+      where
+        this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
+
+renderHieType :: DynFlags -> HieTypeFix -> String
+renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty
+  where sty = defaultUserStyle df
+
+resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
+resolveVisibility kind ty_args
+  = go (mkEmptyTCvSubst in_scope) kind ty_args
+  where
+    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
+
+    go _   _                   []     = []
+    go env ty                  ts
+      | Just ty' <- coreView ty
+      = go env ty' ts
+    go env (ForAllTy (Bndr tv vis) res) (t:ts)
+      | isVisibleArgFlag vis = (True , t) : ts'
+      | otherwise            = (False, t) : ts'
+      where
+        ts' = go (extendTvSubst env tv t) res ts
+
+    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
+      = (True,t) : (go env res ts)
+
+    go env (TyVarTy tv) ts
+      | Just ki <- lookupTyVar env tv = go env ki ts
+    go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded
+
+foldType :: (HieType a -> a) -> HieTypeFix -> a
+foldType f (Roll t) = f $ fmap (foldType f) t
+
+hieTypeToIface :: HieTypeFix -> IfaceType
+hieTypeToIface = foldType go
+  where
+    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
+    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
+    go (HLitTy l) = IfaceLitTy l
+    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
+                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
+    go (HFunTy a b)     = IfaceFunTy VisArg   a    b
+    go (HQualTy pred b) = IfaceFunTy InvisArg pred b
+    go (HCastTy a) = a
+    go HCoercionTy = IfaceTyVar "<coercion type>"
+    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
+
+    -- This isn't fully faithful - we can't produce the 'Inferred' case
+    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
+    hieToIfaceArgs (HieArgs xs) = go' xs
+      where
+        go' [] = IA_Nil
+        go' ((True ,x):xs) = IA_Arg x Required $ go' xs
+        go' ((False,x):xs) = IA_Arg x Specified $ go' xs
+
+data HieTypeState
+  = HTS
+    { tyMap      :: !(TypeMap TypeIndex)
+    , htyTable   :: !(IM.IntMap HieTypeFlat)
+    , freshIndex :: !TypeIndex
+    }
+
+initialHTS :: HieTypeState
+initialHTS = HTS emptyTypeMap IM.empty 0
+
+freshTypeIndex :: State HieTypeState TypeIndex
+freshTypeIndex = do
+  index <- gets freshIndex
+  modify' $ \hts -> hts { freshIndex = index+1 }
+  return index
+
+compressTypes
+  :: HieASTs Type
+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
+compressTypes asts = (a, arr)
+  where
+    (a, (HTS _ m i)) = flip runState initialHTS $
+      for asts $ \typ -> do
+        i <- getTypeIndex typ
+        return i
+    arr = A.array (0,i-1) (IM.toList m)
+
+recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
+recoverFullType i m = go i
+  where
+    go i = Roll $ fmap go (m A.! i)
+
+getTypeIndex :: Type -> State HieTypeState TypeIndex
+getTypeIndex t
+  | otherwise = do
+      tm <- gets tyMap
+      case lookupTypeMap tm t of
+        Just i -> return i
+        Nothing -> do
+          ht <- go t
+          extendHTS t ht
+  where
+    extendHTS t ht = do
+      i <- freshTypeIndex
+      modify' $ \(HTS tm tt fi) ->
+        HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi
+      return i
+
+    go (TyVarTy v) = return $ HTyVarTy $ varName v
+    go ty@(AppTy _ _) = do
+      let (head,args) = splitAppTys ty
+          visArgs = HieArgs $ resolveVisibility (typeKind head) args
+      ai <- getTypeIndex head
+      argsi <- mapM getTypeIndex visArgs
+      return $ HAppTy ai argsi
+    go (TyConApp f xs) = do
+      let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
+      is <- mapM getTypeIndex visArgs
+      return $ HTyConApp (toIfaceTyCon f) is
+    go (ForAllTy (Bndr v a) t) = do
+      k <- getTypeIndex (varType v)
+      i <- getTypeIndex t
+      return $ HForAllTy ((varName v,k),a) i
+    go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do
+      ai <- getTypeIndex a
+      bi <- getTypeIndex b
+      return $ case af of
+                 InvisArg -> HQualTy ai bi
+                 VisArg   -> HFunTy ai bi
+    go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
+    go (CastTy t _) = do
+      i <- getTypeIndex t
+      return $ HCastTy i
+    go (CoercionTy _) = return HCoercionTy
+
+resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)
+resolveTyVarScopes asts = M.map go asts
+  where
+    go ast = resolveTyVarScopeLocal ast asts
+
+resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
+resolveTyVarScopeLocal ast asts = go ast
+  where
+    resolveNameScope dets = dets{identInfo =
+      S.map resolveScope (identInfo dets)}
+    resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =
+      TyVarBind sc $ ResolvedScopes
+        [ LocalScope binding
+        | name <- names
+        , Just binding <- [getNameBinding name asts]
+        ]
+    resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =
+      TyVarBind sc $ ResolvedScopes
+        [ LocalScope binding
+        | name <- names
+        , Just binding <- [getNameBindingInClass name sp asts]
+        ]
+    resolveScope scope = scope
+    go (Node info span children) = Node info' span $ map go children
+      where
+        info' = info { nodeIdentifiers = idents }
+        idents = M.map resolveNameScope $ nodeIdentifiers info
+
+getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
+getNameBinding n asts = do
+  (_,msp) <- getNameScopeAndBinding n asts
+  msp
+
+getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
+getNameScope n asts = do
+  (scopes,_) <- getNameScopeAndBinding n asts
+  return scopes
+
+getNameBindingInClass
+  :: Name
+  -> Span
+  -> M.Map FastString (HieAST a)
+  -> Maybe Span
+getNameBindingInClass n sp asts = do
+  ast <- M.lookup (srcSpanFile sp) asts
+  getFirst $ foldMap First $ do
+    child <- flattenAst ast
+    dets <- maybeToList
+      $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
+    let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
+    return (getFirst binding)
+
+getNameScopeAndBinding
+  :: Name
+  -> M.Map FastString (HieAST a)
+  -> Maybe ([Scope], Maybe Span)
+getNameScopeAndBinding n asts = case nameSrcSpan n of
+  RealSrcSpan sp -> do -- @Maybe
+    ast <- M.lookup (srcSpanFile sp) asts
+    defNode <- selectLargestContainedBy sp ast
+    getFirst $ foldMap First $ do -- @[]
+      node <- flattenAst defNode
+      dets <- maybeToList
+        $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
+      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
+      let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
+      return $ Just (scopes, getFirst binding)
+  _ -> Nothing
+
+getScopeFromContext :: ContextInfo -> Maybe [Scope]
+getScopeFromContext (ValBind _ sc _) = Just [sc]
+getScopeFromContext (PatternBind a b _) = Just [a, b]
+getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
+getScopeFromContext (Decl _ _) = Just [ModuleScope]
+getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
+getScopeFromContext (TyVarBind a _) = Just [a]
+getScopeFromContext _ = Nothing
+
+getBindSiteFromContext :: ContextInfo -> Maybe Span
+getBindSiteFromContext (ValBind _ _ sp) = sp
+getBindSiteFromContext (PatternBind _ _ sp) = sp
+getBindSiteFromContext _ = Nothing
+
+flattenAst :: HieAST a -> [HieAST a]
+flattenAst n =
+  n : concatMap flattenAst (nodeChildren n)
+
+smallestContainingSatisfying
+  :: Span
+  -> (HieAST a -> Bool)
+  -> HieAST a
+  -> Maybe (HieAST a)
+smallestContainingSatisfying sp cond node
+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat
+      [ foldMap (First . smallestContainingSatisfying sp cond) $
+          nodeChildren node
+      , First $ if cond node then Just node else Nothing
+      ]
+  | sp `containsSpan` nodeSpan node = Nothing
+  | otherwise = Nothing
+
+selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
+selectLargestContainedBy sp node
+  | sp `containsSpan` nodeSpan node = Just node
+  | nodeSpan node `containsSpan` sp =
+      getFirst $ foldMap (First . selectLargestContainedBy sp) $
+        nodeChildren node
+  | otherwise = Nothing
+
+selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
+selectSmallestContaining sp node
+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat
+      [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node
+      , First (Just node)
+      ]
+  | sp `containsSpan` nodeSpan node = Nothing
+  | otherwise = Nothing
+
+definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool
+definedInAsts asts n = case nameSrcSpan n of
+  RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts
+  _ -> False
+
+isOccurrence :: ContextInfo -> Bool
+isOccurrence Use = True
+isOccurrence _ = False
+
+scopeContainsSpan :: Scope -> Span -> Bool
+scopeContainsSpan NoScope _ = False
+scopeContainsSpan ModuleScope _ = True
+scopeContainsSpan (LocalScope a) b = a `containsSpan` b
+
+-- | One must contain the other. Leaf nodes cannot contain anything
+combineAst :: HieAST Type -> HieAST Type -> HieAST Type
+combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
+  | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)
+  | aSpn `containsSpan` bSpn = combineAst b a
+combineAst a (Node xs span children) = Node xs span (insertAst a children)
+
+-- | Insert an AST in a sorted list of disjoint Asts
+insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
+insertAst x = mergeAsts [x]
+
+-- | Merge two nodes together.
+--
+-- Precondition and postcondition: elements in 'nodeType' are ordered.
+combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
+(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =
+  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
+  where
+    mergeSorted :: [Type] -> [Type] -> [Type]
+    mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of
+                                        LT -> a : mergeSorted as lb
+                                        EQ -> a : mergeSorted as bs
+                                        GT -> b : mergeSorted la bs
+    mergeSorted as [] = as
+    mergeSorted [] bs = bs
+
+
+{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.
+
+In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
+different nodes in an AST tree should either have disjoint spans (in
+which case you can say for sure which one comes first) or one span
+should be completely contained in the other (in which case the contained
+span corresponds to some child node).
+
+However, since Haskell does have position-altering pragmas it /is/
+possible for spans to be overlapping. Here is an example of a source file
+in which @foozball@ and @quuuuuux@ have overlapping spans:
+
+@
+module Baz where
+
+# line 3 "Baz.hs"
+foozball :: Int
+foozball = 0
+
+# line 3 "Baz.hs"
+bar, quuuuuux :: Int
+bar = 1
+quuuuuux = 2
+@
+
+In these cases, we just do our best to produce sensible `HieAST`'s. The blame
+should be laid at the feet of whoever wrote the line pragmas in the first place
+(usually the C preprocessor...).
+-}
+mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
+mergeAsts xs [] = xs
+mergeAsts [] ys = ys
+mergeAsts xs@(a:as) ys@(b:bs)
+  | span_a `containsSpan`   span_b = mergeAsts (combineAst a b : as) bs
+  | span_b `containsSpan`   span_a = mergeAsts as (combineAst a b : bs)
+  | span_a `rightOf`        span_b = b : mergeAsts xs bs
+  | span_a `leftOf`         span_b = a : mergeAsts as ys
+
+  -- These cases are to work around ASTs that are not fully disjoint
+  | span_a `startsRightOf`  span_b = b : mergeAsts as ys
+  | otherwise                      = a : mergeAsts as ys
+  where
+    span_a = nodeSpan a
+    span_b = nodeSpan b
+
+rightOf :: Span -> Span -> Bool
+rightOf s1 s2
+  = (srcSpanStartLine s1, srcSpanStartCol s1)
+       >= (srcSpanEndLine s2, srcSpanEndCol s2)
+    && (srcSpanFile s1 == srcSpanFile s2)
+
+leftOf :: Span -> Span -> Bool
+leftOf s1 s2
+  = (srcSpanEndLine s1, srcSpanEndCol s1)
+       <= (srcSpanStartLine s2, srcSpanStartCol s2)
+    && (srcSpanFile s1 == srcSpanFile s2)
+
+startsRightOf :: Span -> Span -> Bool
+startsRightOf s1 s2
+  = (srcSpanStartLine s1, srcSpanStartCol s1)
+       >= (srcSpanStartLine s2, srcSpanStartCol s2)
+
+-- | combines and sorts ASTs using a merge sort
+mergeSortAsts :: [HieAST Type] -> [HieAST Type]
+mergeSortAsts = go . map pure
+  where
+    go [] = []
+    go [xs] = xs
+    go xss = go (mergePairs xss)
+    mergePairs [] = []
+    mergePairs [xs] = [xs]
+    mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
+
+simpleNodeInfo :: FastString -> FastString -> NodeInfo a
+simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
+
+locOnly :: SrcSpan -> [HieAST a]
+locOnly (RealSrcSpan span) =
+  [Node e span []]
+    where e = NodeInfo S.empty [] M.empty
+locOnly _ = []
+
+mkScope :: SrcSpan -> Scope
+mkScope (RealSrcSpan sp) = LocalScope sp
+mkScope _ = NoScope
+
+mkLScope :: Located a -> Scope
+mkLScope = mkScope . getLoc
+
+combineScopes :: Scope -> Scope -> Scope
+combineScopes ModuleScope _ = ModuleScope
+combineScopes _ ModuleScope = ModuleScope
+combineScopes NoScope x = x
+combineScopes x NoScope = x
+combineScopes (LocalScope a) (LocalScope b) =
+  mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)
+
+{-# INLINEABLE makeNode #-}
+makeNode
+  :: (Applicative m, Data a)
+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
+  -> m [HieAST b]
+makeNode x spn = pure $ case spn of
+  RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]
+  _ -> []
+  where
+    cons = mkFastString . show . toConstr $ x
+    typ = mkFastString . show . typeRepTyCon . typeOf $ x
+
+{-# INLINEABLE makeTypeNode #-}
+makeTypeNode
+  :: (Applicative m, Data a)
+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
+  -> Type                    -- ^ type to associate with the node
+  -> m [HieAST Type]
+makeTypeNode x spn etyp = pure $ case spn of
+  RealSrcSpan span ->
+    [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+  _ -> []
+  where
+    cons = mkFastString . show . toConstr $ x
+    typ = mkFastString . show . typeRepTyCon . typeOf $ x
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hsSyn/Convert.hs
@@ -0,0 +1,1986 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+This module converts Template Haskell syntax into HsSyn
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
+                convertToHsType,
+                thRdrNameGuesses ) where
+
+import GhcPrelude
+
+import HsSyn as Hs
+import PrelNames
+import RdrName
+import qualified Name
+import Module
+import RdrHsSyn
+import OccName
+import SrcLoc
+import Type
+import qualified Coercion ( Role(..) )
+import TysWiredIn
+import BasicTypes as Hs
+import ForeignCall
+import Unique
+import ErrUtils
+import Bag
+import Lexeme
+import Util
+import FastString
+import Outputable
+import MonadUtils ( foldrM )
+
+import qualified Data.ByteString as BS
+import Control.Monad( unless, liftM, ap )
+
+import Data.Maybe( catMaybes, isNothing )
+import Language.Haskell.TH as TH hiding (sigP)
+import Language.Haskell.TH.Syntax as TH
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import System.IO.Unsafe
+
+-------------------------------------------------------------------
+--              The external interface
+
+convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
+convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
+  where
+    cvt_dec d = wrapMsg "declaration" d (cvtDec d)
+
+convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
+convertToHsExpr loc e
+  = initCvt loc $ wrapMsg "expression" e $ cvtl e
+
+convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
+convertToPat loc p
+  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
+
+convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
+convertToHsType loc t
+  = initCvt loc $ wrapMsg "type" t $ cvtType t
+
+-------------------------------------------------------------------
+newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
+        -- Push down the source location;
+        -- Can fail, with a single error message
+
+-- NB: If the conversion succeeds with (Right x), there should
+--     be no exception values hiding in x
+-- Reason: so a (head []) in TH code doesn't subsequently
+--         make GHC crash when it tries to walk the generated tree
+
+-- Use the loc everywhere, for lack of anything better
+-- In particular, we want it on binding locations, so that variables bound in
+-- the spliced-in declarations get a location that at least relates to the splice point
+
+instance Functor CvtM where
+    fmap = liftM
+
+instance Applicative CvtM where
+    pure x = CvtM $ \loc -> Right (loc,x)
+    (<*>) = ap
+
+instance Monad CvtM where
+  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
+                                  Left err -> Left err
+                                  Right (loc',v) -> unCvtM (k v) loc'
+
+initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
+initCvt loc (CvtM m) = fmap snd (m loc)
+
+force :: a -> CvtM ()
+force a = a `seq` return ()
+
+failWith :: MsgDoc -> CvtM a
+failWith m = CvtM (\_ -> Left m)
+
+getL :: CvtM SrcSpan
+getL = CvtM (\loc -> Right (loc,loc))
+
+setL :: SrcSpan -> CvtM ()
+setL loc = CvtM (\_ -> Right (loc, ()))
+
+returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
+returnL x = CvtM (\loc -> Right (loc, cL loc x))
+
+returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
+returnJustL = fmap Just . returnL
+
+wrapParL :: HasSrcSpan a =>
+            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
+
+wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
+-- E.g  wrapMsg "declaration" dec thing
+wrapMsg what item (CvtM m)
+  = CvtM (\loc -> case m loc of
+                     Left err -> Left (err $$ getPprStyle msg)
+                     Right v  -> Right v)
+  where
+        -- Show the item in pretty syntax normally,
+        -- but with all its constructors if you say -dppr-debug
+    msg sty = hang (text "When splicing a TH" <+> text what <> colon)
+                 2 (if debugStyle sty
+                    then text (show item)
+                    else text (pprint item))
+
+wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
+wrapL (CvtM m) = CvtM (\loc -> case m loc of
+                               Left err -> Left err
+                               Right (loc',v) -> Right (loc',cL loc v))
+
+-------------------------------------------------------------------
+cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
+cvtDecs = fmap catMaybes . mapM cvtDec
+
+cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
+cvtDec (TH.ValD pat body ds)
+  | TH.VarP s <- pat
+  = do  { s' <- vNameL s
+        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
+        ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }
+
+  | otherwise
+  = do  { pat' <- cvtPat pat
+        ; body' <- cvtGuard body
+        ; ds' <- cvtLocalDecs (text "a where clause") ds
+        ; returnJustL $ Hs.ValD noExt $
+          PatBind { pat_lhs = pat'
+                  , pat_rhs = GRHSs noExt body' (noLoc ds')
+                  , pat_ext = noExt
+                  , pat_ticks = ([],[]) } }
+
+cvtDec (TH.FunD nm cls)
+  | null cls
+  = failWith (text "Function binding for"
+                 <+> quotes (text (TH.pprint nm))
+                 <+> text "has no equations")
+  | otherwise
+  = do  { nm' <- vNameL nm
+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
+        ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }
+
+cvtDec (TH.SigD nm typ)
+  = do  { nm' <- vNameL nm
+        ; ty' <- cvtType typ
+        ; returnJustL $ Hs.SigD noExt
+                                    (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
+
+cvtDec (TH.InfixD fx nm)
+  -- Fixity signatures are allowed for variables, constructors, and types
+  -- the renamer automatically looks for types during renaming, even when
+  -- the RdrName says it's a variable or a constructor. So, just assume
+  -- it's a variable or constructor and proceed.
+  = do { nm' <- vcNameL nm
+       ; returnJustL (Hs.SigD noExt (FixSig noExt
+                                      (FixitySig noExt [nm'] (cvtFixity fx)))) }
+
+cvtDec (PragmaD prag)
+  = cvtPragmaD prag
+
+cvtDec (TySynD tc tvs rhs)
+  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
+        ; rhs' <- cvtType rhs
+        ; returnJustL $ TyClD noExt $
+          SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'
+                  , tcdFixity = Prefix
+                  , tcdRhs = rhs' } }
+
+cvtDec (DataD ctxt tc tvs ksig constrs derivs)
+  = do  { let isGadtCon (GadtC    _ _ _) = True
+              isGadtCon (RecGadtC _ _ _) = True
+              isGadtCon (ForallC  _ _ c) = isGadtCon c
+              isGadtCon _                = False
+              isGadtDecl  = all isGadtCon constrs
+              isH98Decl   = all (not . isGadtCon) constrs
+        ; unless (isGadtDecl || isH98Decl)
+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"
+                        <+> text "constructors"))
+        ; unless (isNothing ksig || isGadtDecl)
+                 (failWith (text "Kind signatures are only allowed on GADTs"))
+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+        ; ksig' <- cvtKind `traverse` ksig
+        ; cons' <- mapM cvtConstr constrs
+        ; derivs' <- cvtDerivs derivs
+        ; let defn = HsDataDefn { dd_ext = noExt
+                                , dd_ND = DataType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = ksig'
+                                , dd_cons = cons', dd_derivs = derivs' }
+        ; returnJustL $ TyClD noExt (DataDecl
+                                        { tcdDExt = noExt
+                                        , tcdLName = tc', tcdTyVars = tvs'
+                                        , tcdFixity = Prefix
+                                        , tcdDataDefn = defn }) }
+
+cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
+  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+        ; ksig' <- cvtKind `traverse` ksig
+        ; con' <- cvtConstr constr
+        ; derivs' <- cvtDerivs derivs
+        ; let defn = HsDataDefn { dd_ext = noExt
+                                , dd_ND = NewType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = ksig'
+                                , dd_cons = [con']
+                                , dd_derivs = derivs' }
+        ; returnJustL $ TyClD noExt (DataDecl
+                                    { tcdDExt = noExt
+                                    , tcdLName = tc', tcdTyVars = tvs'
+                                    , tcdFixity = Prefix
+                                    , tcdDataDefn = defn }) }
+
+cvtDec (ClassD ctxt cl tvs fds decs)
+  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
+        ; fds'  <- mapM cvt_fundep fds
+        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs
+        ; unless (null adts')
+            (failWith $ (text "Default data instance declarations"
+                     <+> text "are not allowed:")
+                   $$ (Outputable.ppr adts'))
+        ; returnJustL $ TyClD noExt $
+          ClassDecl { tcdCExt = noExt
+                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+                    , tcdFixity = Prefix
+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
+                    , tcdMeths = binds'
+                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
+                              -- no docs in TH ^^
+        }
+
+cvtDec (InstanceD o ctxt ty decs)
+  = do  { let doc = text "an instance declaration"
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
+        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
+        ; ctxt' <- cvtContext funPrec ctxt
+        ; (dL->L loc ty') <- cvtType ty
+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
+        ; returnJustL $ InstD noExt $ ClsInstD noExt $
+          ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'
+                      , cid_binds = binds'
+                      , cid_sigs = Hs.mkClassOpSigs sigs'
+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
+                      , cid_overlap_mode = fmap (cL loc . overlap) o } }
+  where
+  overlap pragma =
+    case pragma of
+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
+
+
+
+
+cvtDec (ForeignD ford)
+  = do { ford' <- cvtForD ford
+       ; returnJustL $ ForD noExt ford' }
+
+cvtDec (DataFamilyD tc tvs kind)
+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
+       ; result <- cvtMaybeKindToFamilyResultSig kind
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
+
+cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
+       ; ksig' <- cvtKind `traverse` ksig
+       ; cons' <- mapM cvtConstr constrs
+       ; derivs' <- cvtDerivs derivs
+       ; let defn = HsDataDefn { dd_ext = noExt
+                               , dd_ND = DataType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = ksig'
+                               , dd_cons = cons', dd_derivs = derivs' }
+
+       ; returnJustL $ InstD noExt $ DataFamInstD
+           { dfid_ext = noExt
+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_ext = noExt
+                                  , feqn_tycon = tc'
+                                  , feqn_bndrs = bndrs'
+                                  , feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
+
+cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
+       ; ksig' <- cvtKind `traverse` ksig
+       ; con' <- cvtConstr constr
+       ; derivs' <- cvtDerivs derivs
+       ; let defn = HsDataDefn { dd_ext = noExt
+                               , dd_ND = NewType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = ksig'
+                               , dd_cons = [con'], dd_derivs = derivs' }
+       ; returnJustL $ InstD noExt $ DataFamInstD
+           { dfid_ext = noExt
+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_ext = noExt
+                                  , feqn_tycon = tc'
+                                  , feqn_bndrs = bndrs'
+                                  , feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
+
+cvtDec (TySynInstD eqn)
+  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn
+        ; returnJustL $ InstD noExt $ TyFamInstD
+            { tfid_ext = noExt
+            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
+
+cvtDec (OpenTypeFamilyD head)
+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'
+       }
+
+cvtDec (ClosedTypeFamilyD head eqns)
+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
+       ; eqns' <- mapM cvtTySynEqn eqns
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
+                           result' injectivity' }
+
+cvtDec (TH.RoleAnnotD tc roles)
+  = do { tc' <- tconNameL tc
+       ; let roles' = map (noLoc . cvtRole) roles
+       ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }
+
+cvtDec (TH.StandaloneDerivD ds cxt ty)
+  = do { cxt' <- cvtContext funPrec cxt
+       ; ds'  <- traverse cvtDerivStrategy ds
+       ; (dL->L loc ty') <- cvtType ty
+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
+       ; returnJustL $ DerivD noExt $
+         DerivDecl { deriv_ext =noExt
+                   , deriv_strategy = ds'
+                   , deriv_type = mkLHsSigWcType inst_ty'
+                   , deriv_overlap_mode = Nothing } }
+
+cvtDec (TH.DefaultSigD nm typ)
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType typ
+       ; returnJustL $ Hs.SigD noExt
+                     $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
+
+cvtDec (TH.PatSynD nm args dir pat)
+  = do { nm'   <- cNameL nm
+       ; args' <- cvtArgs args
+       ; dir'  <- cvtDir nm' dir
+       ; pat'  <- cvtPat pat
+       ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $
+           PSB noExt nm' args' pat' dir' }
+  where
+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
+    cvtArgs (TH.RecordPatSyn sels)
+      = do { sels' <- mapM vNameL sels
+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
+
+    cvtDir _ Unidir          = return Unidirectional
+    cvtDir _ ImplBidir       = return ImplicitBidirectional
+    cvtDir n (ExplBidir cls) =
+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
+         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
+
+cvtDec (TH.PatSynSigD nm ty)
+  = do { nm' <- cNameL nm
+       ; ty' <- cvtPatSynSigTy ty
+       ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
+
+-- Implicit parameter bindings are handled in cvtLocalDecs and
+-- cvtImplicitParamBind. They are not allowed in any other scope, so
+-- reaching this case indicates an error.
+cvtDec (TH.ImplicitParamBindD _ _)
+  = failWith (text "Implicit parameter binding only allowed in let or where")
+
+----------------
+cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
+cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
+  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
+       ; (head_ty, args) <- split_ty_app lhs
+       ; case head_ty of
+           ConT nm -> do { nm' <- tconNameL nm
+                         ; rhs' <- cvtType rhs
+                         ; let args' = map wrap_tyarg args
+                         ; returnL $ mkHsImplicitBndrs
+                            $ FamEqn { feqn_ext    = noExt
+                                     , feqn_tycon  = nm'
+                                     , feqn_bndrs  = mb_bndrs'
+                                     , feqn_pats   = args'
+                                     , feqn_fixity = Prefix
+                                     , feqn_rhs    = rhs' } }
+           InfixT t1 nm t2 -> do { nm' <- tconNameL nm
+                                 ; args' <- mapM cvtType [t1,t2]
+                                 ; rhs' <- cvtType rhs
+                                 ; returnL $ mkHsImplicitBndrs
+                                      $ FamEqn { feqn_ext    = noExt
+                                               , feqn_tycon  = nm'
+                                               , feqn_bndrs  = mb_bndrs'
+                                               , feqn_pats   =
+                                                (map HsValArg args') ++ args
+                                               , feqn_fixity = Hs.Infix
+                                               , feqn_rhs    = rhs' } }
+           _ -> failWith $ text "Invalid type family instance LHS:"
+                          <+> text (show lhs)
+        }
+
+----------------
+cvt_ci_decs :: MsgDoc -> [TH.Dec]
+            -> CvtM (LHsBinds GhcPs,
+                     [LSig GhcPs],
+                     [LFamilyDecl GhcPs],
+                     [LTyFamInstDecl GhcPs],
+                     [LDataFamInstDecl GhcPs])
+-- Convert the declarations inside a class or instance decl
+-- ie signatures, bindings, and associated types
+cvt_ci_decs doc decs
+  = do  { decs' <- cvtDecs decs
+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
+        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
+        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
+        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
+          --We use FromSource as the origin of the bind
+          -- because the TH declaration is user-written
+        ; return (listToBag binds', sigs', fams', ats', adts') }
+
+----------------
+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
+             -> CvtM ( LHsContext GhcPs
+                     , Located RdrName
+                     , LHsQTyVars GhcPs)
+cvt_tycl_hdr cxt tc tvs
+  = do { cxt' <- cvtContext funPrec cxt
+       ; tc'  <- tconNameL tc
+       ; tvs' <- cvtTvs tvs
+       ; return (cxt', tc', tvs')
+       }
+
+cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
+               -> CvtM ( LHsContext GhcPs
+                       , Located RdrName
+                       , Maybe [LHsTyVarBndr GhcPs]
+                       , HsTyPats GhcPs)
+cvt_datainst_hdr cxt bndrs tys
+  = do { cxt' <- cvtContext funPrec cxt
+       ; bndrs' <- traverse (mapM cvt_tv) bndrs
+       ; (head_ty, args) <- split_ty_app tys
+       ; case head_ty of
+          ConT nm -> do { nm' <- tconNameL nm
+                        ; let args' = map wrap_tyarg args
+                        ; return (cxt', nm', bndrs', args') }
+          InfixT t1 nm t2 -> do { nm' <- tconNameL nm
+                                ; args' <- mapM cvtType [t1,t2]
+                                ; return (cxt', nm', bndrs',
+                                         ((map HsValArg args') ++ args)) }
+          _ -> failWith $ text "Invalid type instance header:"
+                          <+> text (show tys) }
+
+----------------
+cvt_tyfam_head :: TypeFamilyHead
+               -> CvtM ( Located RdrName
+                       , LHsQTyVars GhcPs
+                       , Hs.LFamilyResultSig GhcPs
+                       , Maybe (Hs.LInjectivityAnn GhcPs))
+
+cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
+  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
+       ; result' <- cvtFamilyResultSig result
+       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
+       ; return (tc', tyvars', result', injectivity') }
+
+-------------------------------------------------------------------
+--              Partitioning declarations
+-------------------------------------------------------------------
+
+is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
+is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
+is_fam_decl decl = Right decl
+
+is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
+is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+  = Left (cL loc d)
+is_tyfam_inst decl
+  = Right decl
+
+is_datafam_inst :: LHsDecl GhcPs
+                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
+is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
+  = Left (cL loc d)
+is_datafam_inst decl
+  = Right decl
+
+is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
+is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
+is_sig decl                        = Right decl
+
+is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
+is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)
+is_bind decl                         = Right decl
+
+is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
+is_ip_bind decl             = Right decl
+
+mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
+mkBadDecMsg doc bads
+  = sep [ text "Illegal declaration(s) in" <+> doc <> colon
+        , nest 2 (vcat (map Outputable.ppr bads)) ]
+
+---------------------------------------------------
+--      Data types
+---------------------------------------------------
+
+cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
+
+cvtConstr (NormalC c strtys)
+  = do  { c'   <- cNameL c
+        ; tys' <- mapM cvt_arg strtys
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
+
+cvtConstr (RecC c varstrtys)
+  = do  { c'    <- cNameL c
+        ; args' <- mapM cvt_id_arg varstrtys
+        ; returnL $ mkConDeclH98 c' Nothing Nothing
+                                   (RecCon (noLoc args')) }
+
+cvtConstr (InfixC st1 c st2)
+  = do  { c'   <- cNameL c
+        ; st1' <- cvt_arg st1
+        ; st2' <- cvt_arg st2
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
+
+cvtConstr (ForallC tvs ctxt con)
+  = do  { tvs'      <- cvtTvs tvs
+        ; ctxt'     <- cvtContext funPrec ctxt
+        ; (dL->L _ con')  <- cvtConstr con
+        ; returnL $ add_forall tvs' ctxt' con' }
+  where
+    add_cxt lcxt         Nothing           = Just lcxt
+    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
+      = Just (cL loc (cxt1 ++ cxt2))
+
+    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
+      = con { con_forall = noLoc $ not (null all_tvs)
+            , con_qvars  = mkHsQTvs all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
+
+    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
+      = con { con_forall = noLoc $ not (null all_tvs)
+            , con_ex_tvs = all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs
+
+    add_forall _ _ (XConDecl _) = panic "cvtConstr"
+
+cvtConstr (GadtC c strtys ty)
+  = do  { c'      <- mapM cNameL c
+        ; args    <- mapM cvt_arg strtys
+        ; (dL->L _ ty') <- cvtType ty
+        ; c_ty    <- mk_arr_apps args ty'
+        ; returnL $ fst $ mkGadtDecl c' c_ty}
+
+cvtConstr (RecGadtC c varstrtys ty)
+  = do  { c'       <- mapM cNameL c
+        ; ty'      <- cvtType ty
+        ; rec_flds <- mapM cvt_id_arg varstrtys
+        ; let rec_ty = noLoc (HsFunTy noExt
+                                           (noLoc $ HsRecTy noExt rec_flds) ty')
+        ; returnL $ fst $ mkGadtDecl c' rec_ty }
+
+cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
+cvtSrcUnpackedness SourceUnpack         = SrcUnpack
+
+cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
+cvtSrcStrictness NoSourceStrictness = NoSrcStrict
+cvtSrcStrictness SourceLazy         = SrcLazy
+cvtSrcStrictness SourceStrict       = SrcStrict
+
+cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
+cvt_arg (Bang su ss, ty)
+  = do { ty'' <- cvtType ty
+       ; let ty' = parenthesizeHsType appPrec ty''
+             su' = cvtSrcUnpackedness su
+             ss' = cvtSrcStrictness ss
+       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
+
+cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
+cvt_id_arg (i, str, ty)
+  = do  { (dL->L li i') <- vNameL i
+        ; ty' <- cvt_arg (str,ty)
+        ; return $ noLoc (ConDeclField
+                          { cd_fld_ext = noExt
+                          , cd_fld_names
+                              = [cL li $ FieldOcc noExt (cL li i')]
+                          , cd_fld_type =  ty'
+                          , cd_fld_doc = Nothing}) }
+
+cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
+cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
+                  ; returnL cs' }
+
+cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
+                               ; ys' <- mapM tNameL ys
+                               ; returnL (xs', ys') }
+
+
+------------------------------------------
+--      Foreign declarations
+------------------------------------------
+
+cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
+cvtForD (ImportF callconv safety from nm ty)
+  -- the prim and javascript calling conventions do not support headers
+  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
+  | callconv == TH.Prim || callconv == TH.JavaScript
+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
+                    (CFunction (StaticTarget (SourceText from)
+                                             (mkFastString from) Nothing
+                                             True))
+                    (noLoc $ quotedSourceText from))
+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
+                                 (mkFastString (TH.nameBase nm))
+                                 from (noLoc $ quotedSourceText from)
+  = mk_imp impspec
+  | otherwise
+  = failWith $ text (show from) <+> text "is not a valid ccall impent"
+  where
+    mk_imp impspec
+      = do { nm' <- vNameL nm
+           ; ty' <- cvtType ty
+           ; return (ForeignImport { fd_i_ext = noExt
+                                   , fd_name = nm'
+                                   , fd_sig_ty = mkLHsSigType ty'
+                                   , fd_fi = impspec })
+           }
+    safety' = case safety of
+                     Unsafe     -> PlayRisky
+                     Safe       -> PlaySafe
+                     Interruptible -> PlayInterruptible
+
+cvtForD (ExportF callconv as nm ty)
+  = do  { nm' <- vNameL nm
+        ; ty' <- cvtType ty
+        ; let e = CExport (noLoc (CExportStatic (SourceText as)
+                                                (mkFastString as)
+                                                (cvt_conv callconv)))
+                                                (noLoc (SourceText as))
+        ; return $ ForeignExport { fd_e_ext = noExt
+                                 , fd_name = nm'
+                                 , fd_sig_ty = mkLHsSigType ty'
+                                 , fd_fe = e } }
+
+cvt_conv :: TH.Callconv -> CCallConv
+cvt_conv TH.CCall      = CCallConv
+cvt_conv TH.StdCall    = StdCallConv
+cvt_conv TH.CApi       = CApiConv
+cvt_conv TH.Prim       = PrimCallConv
+cvt_conv TH.JavaScript = JavaScriptCallConv
+
+------------------------------------------
+--              Pragmas
+------------------------------------------
+
+cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
+cvtPragmaD (InlineP nm inline rm phases)
+  = do { nm' <- vNameL nm
+       ; let dflt = dfltActivation inline
+       ; let src TH.NoInline  = "{-# NOINLINE"
+             src TH.Inline    = "{-# INLINE"
+             src TH.Inlinable = "{-# INLINABLE"
+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline
+                                 , inl_inline = cvtInline inline
+                                 , inl_rule   = cvtRuleMatch rm
+                                 , inl_act    = cvtPhases phases dflt
+                                 , inl_sat    = Nothing }
+       ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }
+
+cvtPragmaD (SpecialiseP nm ty inline phases)
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType ty
+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
+             src TH.Inline    = "{-# SPECIALISE INLINE"
+             src TH.Inlinable = "{-# SPECIALISE INLINE"
+       ; let (inline', dflt,srcText) = case inline of
+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,
+                                src inline1)
+               Nothing      -> (NoUserInline,   AlwaysActive,
+                                "{-# SPECIALISE")
+       ; let ip = InlinePragma { inl_src    = SourceText srcText
+                               , inl_inline = inline'
+                               , inl_rule   = Hs.FunLike
+                               , inl_act    = cvtPhases phases dflt
+                               , inl_sat    = Nothing }
+       ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
+
+cvtPragmaD (SpecialiseInstP ty)
+  = do { ty' <- cvtType ty
+       ; returnJustL $ Hs.SigD noExt $
+         SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
+
+cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
+  = do { let nm' = mkFastString nm
+       ; let act = cvtPhases phases AlwaysActive
+       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
+       ; lhs'   <- cvtl lhs
+       ; rhs'   <- cvtl rhs
+       ; returnJustL $ Hs.RuleD noExt
+            $ HsRules { rds_ext = noExt
+                      , rds_src = SourceText "{-# RULES"
+                      , rds_rules = [noLoc $
+                          HsRule { rd_ext  = noExt
+                                 , rd_name = (noLoc (quotedSourceText nm,nm'))
+                                 , rd_act  = act
+                                 , rd_tyvs = ty_bndrs'
+                                 , rd_tmvs = tm_bndrs'
+                                 , rd_lhs  = lhs'
+                                 , rd_rhs  = rhs' }] }
+
+          }
+
+cvtPragmaD (AnnP target exp)
+  = do { exp' <- cvtl exp
+       ; target' <- case target of
+         ModuleAnnotation  -> return ModuleAnnProvenance
+         TypeAnnotation n  -> do
+           n' <- tconName n
+           return (TypeAnnProvenance  (noLoc n'))
+         ValueAnnotation n -> do
+           n' <- vcName n
+           return (ValueAnnProvenance (noLoc n'))
+       ; returnJustL $ Hs.AnnD noExt
+                     $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'
+       }
+
+cvtPragmaD (LineP line file)
+  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
+       ; return Nothing
+       }
+cvtPragmaD (CompleteP cls mty)
+  = do { cls' <- noLoc <$> mapM cNameL cls
+       ; mty'  <- traverse tconNameL mty
+       ; returnJustL $ Hs.SigD noExt
+                   $ CompleteMatchSig noExt NoSourceText cls' mty' }
+
+dfltActivation :: TH.Inline -> Activation
+dfltActivation TH.NoInline = NeverActive
+dfltActivation _           = AlwaysActive
+
+cvtInline :: TH.Inline -> Hs.InlineSpec
+cvtInline TH.NoInline  = Hs.NoInline
+cvtInline TH.Inline    = Hs.Inline
+cvtInline TH.Inlinable = Hs.Inlinable
+
+cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
+cvtRuleMatch TH.ConLike = Hs.ConLike
+cvtRuleMatch TH.FunLike = Hs.FunLike
+
+cvtPhases :: TH.Phases -> Activation -> Activation
+cvtPhases AllPhases       dflt = dflt
+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
+
+cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
+cvtRuleBndr (RuleVar n)
+  = do { n' <- vNameL n
+       ; return $ noLoc $ Hs.RuleBndr noExt n' }
+cvtRuleBndr (TypedRuleVar n ty)
+  = do { n'  <- vNameL n
+       ; ty' <- cvtType ty
+       ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }
+
+---------------------------------------------------
+--              Declarations
+---------------------------------------------------
+
+cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
+cvtLocalDecs doc ds
+  = case partitionWith is_ip_bind ds of
+      ([], []) -> return (EmptyLocalBinds noExt)
+      ([], _) -> do
+        ds' <- cvtDecs ds
+        let (binds, prob_sigs) = partitionWith is_bind ds'
+        let (sigs, bads) = partitionWith is_sig prob_sigs
+        unless (null bads) (failWith (mkBadDecMsg doc bads))
+        return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
+      (ip_binds, []) -> do
+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
+        return (HsIPBinds noExt (IPBinds noExt binds))
+      ((_:_), (_:_)) ->
+        failWith (text "Implicit parameters mixed with other bindings")
+
+cvtClause :: HsMatchContext RdrName
+          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtClause ctxt (Clause ps body wheres)
+  = do  { ps' <- cvtPats ps
+        ; let pps = map (parenthesizePat appPrec) ps'
+        ; g'  <- cvtGuard body
+        ; ds' <- cvtLocalDecs (text "a where clause") wheres
+        ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
+
+cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
+cvtImplicitParamBind n e = do
+    n' <- wrapL (ipName n)
+    e' <- cvtl e
+    returnL (IPBind noExt (Left n') e')
+
+-------------------------------------------------------------------
+--              Expressions
+-------------------------------------------------------------------
+
+cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
+cvtl e = wrapL (cvt e)
+  where
+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
+    cvt (LitE l)
+      | overloadedLit l = go cvtOverLit (HsOverLit noExt)
+                             (hsOverLitNeedsParens appPrec)
+      | otherwise       = go cvtLit (HsLit noExt)
+                             (hsLitNeedsParens appPrec)
+      where
+        go :: (Lit -> CvtM (l GhcPs))
+           -> (l GhcPs -> HsExpr GhcPs)
+           -> (l GhcPs -> Bool)
+           -> CvtM (HsExpr GhcPs)
+        go cvt_lit mk_expr is_compound_lit = do
+          l' <- cvt_lit l
+          let e' = mk_expr l'
+          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
+    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
+    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
+    cvt (AppTypeE e t) = do { e' <- cvtl e
+                            ; t' <- cvtType t
+                            ; let tp = parenthesizeHsType appPrec t'
+                            ; return $ HsAppType noExt e'
+                                     $ mkHsWildCardBndrs tp }
+    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
+                               -- own expression to avoid pretty-printing
+                               -- oddities that can result from zero-argument
+                               -- lambda expressions. See #13856.
+    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
+                            ; let pats = map (parenthesizePat appPrec) ps'
+                            ; return $ HsLam noExt (mkMatchGroup FromSource
+                                             [mkSimpleMatch LambdaExpr
+                                             pats e'])}
+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; return $ HsLamCase noExt
+                                                   (mkMatchGroup FromSource ms')
+                            }
+    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
+                                 -- Note [Dropping constructors]
+                                 -- Singleton tuples treated like nothing (just parens)
+    cvt (TupE es)      = do { es' <- mapM cvtl es
+                            ; return $ ExplicitTuple noExt
+                                             (map (noLoc . (Present noExt)) es')
+                                                                         Boxed }
+    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
+                                   ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) es')
+                                                                       Unboxed }
+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
+                                       ; unboxedSumChecks alt arity
+                                       ; return $ ExplicitSum noExt
+                                                                   alt arity e'}
+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
+                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
+    cvt (MultiIfE alts)
+      | null alts      = failWith (text "Multi-way if-expression with no alternatives")
+      | otherwise      = do { alts' <- mapM cvtpair alts
+                            ; return $ HsMultiIf noExt alts' }
+    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
+                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; return $ HsCase noExt e'
+                                                 (mkMatchGroup FromSource ms') }
+    cvt (DoE ss)       = cvtHsDo DoExpr ss
+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss
+    cvt (CompE ss)     = cvtHsDo ListComp ss
+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
+                            ; return $ ArithSeq noExt Nothing dd' }
+    cvt (ListE xs)
+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
+                                          ; return (HsLit noExt l') }
+             -- Note [Converting strings]
+      | otherwise       = do { xs' <- mapM cvtl xs
+                             ; return $ ExplicitList noExt Nothing xs'
+                             }
+
+    -- Infix expressions
+    cvt (InfixE (Just x) s (Just y)) =
+      do { x' <- cvtl x
+         ; s' <- cvtl s
+         ; y' <- cvtl y
+         ; let px = parenthesizeHsExpr opPrec x'
+               py = parenthesizeHsExpr opPrec y'
+         ; wrapParL (HsPar noExt)
+           $ OpApp noExt px s' py }
+           -- Parenthesise both arguments and result,
+           -- to ensure this operator application does
+           -- does not get re-associated
+           -- See Note [Operator association]
+    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionR noExt s' y' }
+                                            -- See Note [Sections in HsSyn] in HsExpr
+    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionL noExt x' s' }
+
+    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s
+                                          ; return $ HsPar noExt s' }
+                                       -- Can I indicate this is an infix thing?
+                                       -- Note [Dropping constructors]
+
+    cvt (UInfixE x s y)  = do { x' <- cvtl x
+                              ; let x'' = case unLoc x' of
+                                            OpApp {} -> x'
+                                            _ -> mkLHsPar x'
+                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]
+
+    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
+                              ; let pe = parenthesizeHsExpr sigPrec e'
+                              ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }
+    cvt (RecConE c flds) = do { c' <- cNameL c
+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
+    cvt (RecUpdE e flds) = do { e' <- cvtl e
+                              ; flds'
+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
+                                           flds
+                              ; return $ mkRdrRecordUpd e' flds' }
+    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e
+    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
+                              -- important, because UnboundVarE may contain
+                              -- constructor names - see #14627.
+                              { s' <- vcName s
+                              ; return $ HsVar noExt (noLoc s') }
+    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }
+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
+
+{- Note [Dropping constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
+we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
+could meet @UInfix@ constructors containing the @TupE [e]@. For example:
+
+  UInfixE x * (TupE [UInfixE y + z])
+
+If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
+and the above expression would be reassociated to
+
+  OpApp (OpApp x * y) + z
+
+which we don't want.
+-}
+
+cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
+       -> CvtM (LHsRecField' t (LHsExpr GhcPs))
+cvtFld f (v,e)
+  = do  { v' <- vNameL v; e' <- cvtl e
+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
+                                     , hsRecFieldArg = e'
+                                     , hsRecPun      = False}) }
+
+cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
+cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
+cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
+cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
+
+{- Note [Operator assocation]
+We must be quite careful about adding parens:
+  * Infix (UInfix ...) op arg      Needs parens round the first arg
+  * Infix (Infix ...) op arg       Needs parens round the first arg
+  * UInfix (UInfix ...) op arg     No parens for first arg
+  * UInfix (Infix ...) op arg      Needs parens round first arg
+
+
+Note [Converting UInfix]
+~~~~~~~~~~~~~~~~~~~~~~~~
+When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
+the trees to reflect the fixities of the underlying operators:
+
+  UInfixE x * (UInfixE y + z) ---> (x * y) + z
+
+This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
+@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
+right-biased for types and left-biased for everything else. So we left-bias the
+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
+
+Sample input:
+
+  UInfixE
+   (UInfixE x op1 y)
+   op2
+   (UInfixE z op3 w)
+
+Sample output:
+
+  OpApp
+    (OpApp
+      (OpApp x op1 y)
+      op2
+      z)
+    op3
+    w
+
+The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
+biasing.
+-}
+
+{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
+The produced tree of infix expressions will be left-biased, provided @x@ is.
+
+We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
+is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
+this holds for both branches (of @cvtOpApp@), provided we assume it holds for
+the recursive calls to @cvtOpApp@.
+
+When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
+since we have already run @cvtl@ on it.
+-}
+cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
+cvtOpApp x op1 (UInfixE y op2 z)
+  = do { l <- wrapL $ cvtOpApp x op1 y
+       ; cvtOpApp l op2 z }
+cvtOpApp x op y
+  = do { op' <- cvtl op
+       ; y' <- cvtl y
+       ; return (OpApp noExt x op' y') }
+
+-------------------------------------
+--      Do notation and statements
+-------------------------------------
+
+cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
+cvtHsDo do_or_lc stmts
+  | null stmts = failWith (text "Empty stmt list in do-block")
+  | otherwise
+  = do  { stmts' <- cvtStmts stmts
+        ; let Just (stmts'', last') = snocView stmts'
+
+        ; last'' <- case last' of
+                    (dL->L loc (BodyStmt _ body _ _))
+                      -> return (cL loc (mkLastStmt body))
+                    _ -> failWith (bad_last last')
+
+        ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
+  where
+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
+                         , nest 2 $ Outputable.ppr stmt
+                         , text "(It should be an expression.)" ]
+
+cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
+cvtStmts = mapM cvtStmt
+
+cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
+cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
+                            ; returnL $ LetStmt noExt (noLoc ds') }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
+                            ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }
+  where
+    cvt_one ds = do { ds' <- cvtStmts ds
+                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
+
+cvtMatch :: HsMatchContext RdrName
+         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtMatch ctxt (TH.Match p body decs)
+  = do  { p' <- cvtPat p
+        ; let lp = case p' of
+                     (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875
+                     _                    -> p'
+        ; g' <- cvtGuard body
+        ; decs' <- cvtLocalDecs (text "a where clause") decs
+        ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
+
+cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
+cvtGuard (GuardedB pairs) = mapM cvtpair pairs
+cvtGuard (NormalB e)      = do { e' <- cvtl e
+                               ; g' <- returnL $ GRHS noExt [] e'; return [g'] }
+
+cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
+                              ; g' <- returnL $ mkBodyStmt ge'
+                              ; returnL $ GRHS noExt [g'] rhs' }
+cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
+                              ; returnL $ GRHS noExt gs' rhs' }
+
+cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
+cvtOverLit (IntegerL i)
+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
+cvtOverLit (RationalL r)
+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }
+cvtOverLit (StringL s)
+  = do { let { s' = mkFastString s }
+       ; force s'
+       ; return $ mkHsIsString (quotedSourceText s) s'
+       }
+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
+-- An Integer is like an (overloaded) '3' in a Haskell source program
+-- Similarly 3.5 for fractionals
+
+{- Note [Converting strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
+a string literal for "xy".  Of course, we might hope to get
+(LitE (StringL "xy")), but not always, and allCharLs fails quickly
+if it isn't a literal string
+-}
+
+allCharLs :: [TH.Exp] -> Maybe String
+-- Note [Converting strings]
+-- NB: only fire up this setup for a non-empty list, else
+--     there's a danger of returning "" for [] :: [Int]!
+allCharLs xs
+  = case xs of
+      LitE (CharL c) : ys -> go [c] ys
+      _                   -> Nothing
+  where
+    go cs []                    = Just (reverse cs)
+    go cs (LitE (CharL c) : ys) = go (c:cs) ys
+    go _  _                     = Nothing
+
+cvtLit :: Lit -> CvtM (HsLit GhcPs)
+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
+cvtLit (FloatPrimL f)
+  = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
+cvtLit (DoublePrimL f)
+  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
+cvtLit (StringL s)     = do { let { s' = mkFastString s }
+                            ; force s'
+                            ; return $ HsString (quotedSourceText s) s' }
+cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
+                            ; force s'
+                            ; return $ HsStringPrim NoSourceText s' }
+cvtLit (BytesPrimL (Bytes fptr off sz)) = do
+  let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->
+             BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)
+  force bs
+  return $ HsStringPrim NoSourceText bs
+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
+        -- cvtLit should not be called on IntegerL, RationalL
+        -- That precondition is established right here in
+        -- Convert.hs, hence panic
+
+quotedSourceText :: String -> SourceText
+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
+
+cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
+cvtPats pats = mapM cvtPat pats
+
+cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
+cvtPat pat = wrapL (cvtp pat)
+
+cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
+cvtp (TH.LitP l)
+  | overloadedLit l    = do { l' <- cvtOverLit l
+                            ; return (mkNPat (noLoc l') Nothing) }
+                                  -- Not right for negative patterns;
+                                  -- need to think about that!
+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
+cvtp (TH.VarP s)       = do { s' <- vName s
+                            ; return $ Hs.VarPat noExt (noLoc s') }
+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExt p' }
+                                         -- Note [Dropping constructors]
+cvtp (TupP ps)         = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Boxed }
+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Unboxed }
+cvtp (UnboxedSumP p alt arity)
+                       = do { p' <- cvtPat p
+                            ; unboxedSumChecks alt arity
+                            ; return $ SumPat noExt p' alt arity }
+cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
+                            ; let pps = map (parenthesizePat appPrec) ps'
+                            ; return $ ConPatIn s' (PrefixCon pps) }
+cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
+                            ; wrapParL (ParPat noExt) $
+                              ConPatIn s' $
+                              InfixCon (parenthesizePat opPrec p1')
+                                       (parenthesizePat opPrec p2') }
+                            -- See Note [Operator association]
+cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
+cvtp (ParensP p)       = do { p' <- cvtPat p;
+                            ; case unLoc p' of  -- may be wrapped ConPatIn
+                                ParPat {} -> return $ unLoc p'
+                                _         -> return $ ParPat noExt p' }
+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }
+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }
+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
+                            ; return $ AsPat noExt s' p' }
+cvtp TH.WildP          = return $ WildPat noExt
+cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
+                            ; return $ ConPatIn c'
+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }
+cvtp (ListP ps)        = do { ps' <- cvtPats ps
+                            ; return
+                                   $ ListPat noExt ps'}
+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
+                            ; return $ SigPat noExt p' (mkLHsSigWcType t') }
+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
+                            ; return $ ViewPat noExt e' p'}
+
+cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
+cvtPatFld (s,p)
+  = do  { (dL->L ls s') <- vNameL s
+        ; p' <- cvtPat p
+        ; return (noLoc $ HsRecField { hsRecFieldLbl
+                                         = cL ls $ mkFieldOcc (cL ls s')
+                                     , hsRecFieldArg = p'
+                                     , hsRecPun      = False}) }
+
+{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
+The produced tree of infix patterns will be left-biased, provided @x@ is.
+
+See the @cvtOpApp@ documentation for how this function works.
+-}
+cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
+cvtOpAppP x op1 (UInfixP y op2 z)
+  = do { l <- wrapL $ cvtOpAppP x op1 y
+       ; cvtOpAppP l op2 z }
+cvtOpAppP x op y
+  = do { op' <- cNameL op
+       ; y' <- cvtPat y
+       ; return (ConPatIn op' (InfixCon x y')) }
+
+-----------------------------------------------------------
+--      Types and type variables
+
+cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
+
+cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
+cvt_tv (TH.PlainTV nm)
+  = do { nm' <- tNameL nm
+       ; returnL $ UserTyVar noExt nm' }
+cvt_tv (TH.KindedTV nm ki)
+  = do { nm' <- tNameL nm
+       ; ki' <- cvtKind ki
+       ; returnL $ KindedTyVar noExt nm' ki' }
+
+cvtRole :: TH.Role -> Maybe Coercion.Role
+cvtRole TH.NominalR          = Just Coercion.Nominal
+cvtRole TH.RepresentationalR = Just Coercion.Representational
+cvtRole TH.PhantomR          = Just Coercion.Phantom
+cvtRole TH.InferR            = Nothing
+
+cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
+cvtContext p tys = do { preds' <- mapM cvtPred tys
+                      ; parenthesizeHsContext p <$> returnL preds' }
+
+cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
+cvtPred = cvtType
+
+cvtDerivClause :: TH.DerivClause
+               -> CvtM (LHsDerivingClause GhcPs)
+cvtDerivClause (TH.DerivClause ds ctxt)
+  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt
+       ; ds'   <- traverse cvtDerivStrategy ds
+       ; returnL $ HsDerivingClause noExt ds' ctxt' }
+
+cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
+cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy
+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
+cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy
+cvtDerivStrategy (TH.ViaStrategy ty) = do
+  ty' <- cvtType ty
+  returnL $ Hs.ViaStrategy (mkLHsSigType ty')
+
+cvtType :: TH.Type -> CvtM (LHsType GhcPs)
+cvtType = cvtTypeKind "type"
+
+cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
+cvtTypeKind ty_str ty
+  = do { (head_ty, tys') <- split_ty_app ty
+       ; let m_normals = mapM extract_normal tys'
+                                where extract_normal (HsValArg ty) = Just ty
+                                      extract_normal _ = Nothing
+
+       ; case head_ty of
+           TupleT n
+            | Just normals <- m_normals
+            , normals `lengthIs` n         -- Saturated
+               -> if n==1 then return (head normals) -- Singleton tuples treated
+                                                     -- like nothing (ie just parens)
+                          else returnL (HsTupleTy noExt
+                                        HsBoxedOrConstraintTuple normals)
+            | n == 1
+               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
+            | otherwise
+            -> mk_apps
+               (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
+               tys'
+           UnboxedTupleT n
+             | Just normals <- m_normals
+             , normals `lengthIs` n               -- Saturated
+             -> returnL (HsTupleTy noExt HsUnboxedTuple normals)
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))
+                tys'
+           UnboxedSumT n
+             | n < 2
+            -> failWith $
+                   vcat [ text "Illegal sum arity:" <+> text (show n)
+                        , nest 2 $
+                            text "Sums must have an arity of at least 2" ]
+             | Just normals <- m_normals
+             , normals `lengthIs` n -- Saturated
+             -> returnL (HsSumTy noExt normals)
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))
+                tys'
+           ArrowT
+             | Just normals <- m_normals
+             , [x',y'] <- normals -> do
+                 x'' <- case unLoc x' of
+                          HsFunTy{}    -> returnL (HsParTy noExt x')
+                          HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
+                          HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324
+                          _            -> return $
+                                          parenthesizeHsType sigPrec x'
+                 let y'' = parenthesizeHsType sigPrec y'
+                 returnL (HsFunTy noExt x'' y'')
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))
+                tys'
+           ListT
+             | Just normals <- m_normals
+             , [x'] <- normals -> do
+                returnL (HsListTy noExt x')
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))
+                tys'
+
+           VarT nm -> do { nm' <- tNameL nm
+                         ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
+           ConT nm -> do { nm' <- tconName nm
+                         ; -- ConT can contain both data constructor (i.e.,
+                           -- promoted) names and other (i.e, unpromoted)
+                           -- names, as opposed to PromotedT, which can only
+                           -- contain data constructor names. See #15572.
+                           let prom = if isRdrDataCon nm'
+                                      then IsPromoted
+                                      else NotPromoted
+                         ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
+
+           ForallT tvs cxt ty
+             | null tys'
+             -> do { tvs' <- cvtTvs tvs
+                   ; cxt' <- cvtContext funPrec cxt
+                   ; ty'  <- cvtType ty
+                   ; loc <- getL
+                   ; let hs_ty  = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty
+                         rho_ty = mkHsQualTy cxt loc cxt' ty'
+
+                   ; return hs_ty }
+
+           ForallVisT tvs ty
+             | null tys'
+             -> do { tvs' <- cvtTvs tvs
+                   ; ty'  <- cvtType ty
+                   ; loc  <- getL
+                   ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }
+
+           SigT ty ki
+             -> do { ty' <- cvtType ty
+                   ; ki' <- cvtKind ki
+                   ; mk_apps (HsKindSig noExt ty' ki') tys'
+                   }
+
+           LitT lit
+             -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'
+
+           WildCardT
+             -> mk_apps mkAnonWildCardTy tys'
+
+           InfixT t1 s t2
+             -> do { s'  <- tconName s
+                   ; t1' <- cvtType t1
+                   ; t2' <- cvtType t2
+                   ; mk_apps
+                      (HsTyVar noExt NotPromoted (noLoc s'))
+                      ([HsValArg t1', HsValArg t2'] ++ tys')
+                   }
+
+           UInfixT t1 s t2
+             -> do { t2' <- cvtType t2
+                   ; t <- cvtOpAppT t1 s t2'
+                   ; mk_apps (unLoc t) tys'
+                   } -- Note [Converting UInfix]
+
+           ParensT t
+             -> do { t' <- cvtType t
+                   ; mk_apps (HsParTy noExt t') tys'
+                   }
+
+           PromotedT nm -> do { nm' <- cName nm
+                              ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))
+                                        tys' }
+                 -- Promoted data constructor; hence cName
+
+           PromotedTupleT n
+              | n == 1
+              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
+              | Just normals <- m_normals
+              , normals `lengthIs` n   -- Saturated
+              -> returnL (HsExplicitTupleTy noExt normals)
+              | otherwise
+              -> mk_apps
+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))
+                 tys'
+
+           PromotedNilT
+             -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'
+
+           PromotedConsT  -- See Note [Representing concrete syntax in types]
+                          -- in Language.Haskell.TH.Syntax
+              | Just normals <- m_normals
+              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals
+              -> do
+                  returnL (HsExplicitListTy noExt ip (ty1:tys2))
+              | otherwise
+              -> mk_apps
+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))
+                 tys'
+
+           StarT
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))
+                tys'
+
+           ConstraintT
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))
+                tys'
+
+           EqualityT
+             | Just normals <- m_normals
+             , [x',y'] <- normals ->
+                   let px = parenthesizeHsType opPrec x'
+                       py = parenthesizeHsType opPrec y'
+                   in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)
+               -- The long-term goal is to remove the above case entirely and
+               -- subsume it under the case for InfixT. See #15815, comment:6,
+               -- for more details.
+
+             | otherwise ->
+                   mk_apps (HsTyVar noExt NotPromoted
+                            (noLoc eqTyCon_RDR)) tys'
+           ImplicitParamT n t
+             -> do { n' <- wrapL $ ipName n
+                   ; t' <- cvtType t
+                   ; returnL (HsIParamTy noExt n' t')
+                   }
+
+           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
+    }
+
+-- | Constructs an application of a type to arguments passed in a list.
+mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
+mk_apps head_ty type_args = do
+  head_ty' <- returnL head_ty
+  -- We must parenthesize the function type in case of an explicit
+  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
+  -- _must_ be parentheses around `Maybe :: Type -> Type`.
+  let phead_ty :: LHsType GhcPs
+      phead_ty = parenthesizeHsType sigPrec head_ty'
+
+      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
+      go [] = pure head_ty'
+      go (arg:args) =
+        case arg of
+          HsValArg ty  -> do p_ty <- add_parens ty
+                             mk_apps (HsAppTy noExt phead_ty p_ty) args
+          HsTypeArg l ki -> do p_ki <- add_parens ki
+                               mk_apps (HsAppKindTy l phead_ty p_ki) args
+          HsArgPar _   -> mk_apps (HsParTy noExt phead_ty) args
+
+  go type_args
+   where
+    -- See Note [Adding parens for splices]
+    add_parens lt@(dL->L _ t)
+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
+      | otherwise                   = return lt
+
+wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
+wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty
+wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
+wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
+
+-- ---------------------------------------------------------------------
+-- Note [Adding parens for splices]
+{-
+The hsSyn representation of parsed source explicitly contains all the original
+parens, as written in the source.
+
+When a Template Haskell (TH) splice is evaluated, the original splice is first
+renamed and type checked and then finally converted to core in DsMeta. This core
+is then run in the TH engine, and the result comes back as a TH AST.
+
+In the process, all parens are stripped out, as they are not needed.
+
+This Convert module then converts the TH AST back to hsSyn AST.
+
+In order to pretty-print this hsSyn AST, parens need to be adde back at certain
+points so that the code is readable with its original meaning.
+
+So scattered through Convert.hs are various points where parens are added.
+
+See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289
+-}
+-- ---------------------------------------------------------------------
+
+-- | Constructs an arrow type with a specified return type
+mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
+    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty
+                             ; return (HsFunTy noExt arg ret_ty_l) }
+
+split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
+split_ty_app ty = go ty []
+  where
+    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
+    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
+                                 ; go ty (HsTypeArg noSrcSpan ki':as') }
+    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
+    go f as           = return (f,as)
+
+cvtTyLit :: TH.TyLit -> HsTyLit
+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
+
+{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
+application @x `op` y@. The produced tree of infix types will be right-biased,
+provided @y@ is.
+
+See the @cvtOpApp@ documentation for how this function works.
+-}
+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
+cvtOpAppT (UInfixT x op2 y) op1 z
+  = do { l <- cvtOpAppT y op1 z
+       ; cvtOpAppT x op2 l }
+cvtOpAppT x op y
+  = do { op' <- tconNameL op
+       ; x' <- cvtType x
+       ; returnL (mkHsOpTy x' op' y) }
+
+cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
+cvtKind = cvtTypeKind "kind"
+
+-- | Convert Maybe Kind to a type family result signature. Used with data
+-- families where naming of the result is not possible (thus only kind or no
+-- signature is possible).
+cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
+                              -> CvtM (LFamilyResultSig GhcPs)
+cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExt)
+cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
+                                             ; returnL (Hs.KindSig noExt ki') }
+
+-- | Convert type family result signature. Used with both open and closed type
+-- families.
+cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
+cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExt)
+cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki
+                                           ; returnL (Hs.KindSig noExt  ki') }
+cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
+                                           ; returnL (Hs.TyVarSig noExt tv) }
+
+-- | Convert injectivity annotation of a type family.
+cvtInjectivityAnnotation :: TH.InjectivityAnn
+                         -> CvtM (Hs.LInjectivityAnn GhcPs)
+cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
+  = do { annLHS' <- tNameL annLHS
+       ; annRHS' <- mapM tNameL annRHS
+       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
+
+cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
+-- pattern synonym types are of peculiar shapes, which is why we treat
+-- them separately from regular types;
+-- see Note [Pattern synonym type signatures and Template Haskell]
+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
+  | null exis, null provs = cvtType (ForallT univs reqs ty)
+  | null univs, null reqs = do { l   <- getL
+                               ; ty' <- cvtType (ForallT exis provs ty)
+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []
+                                                         , hst_xqual = noExt
+                                                         , hst_body = ty' }) }
+  | null reqs             = do { l      <- getL
+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs
+                               ; ty'    <- cvtType (ForallT exis provs ty)
+                               ; let forTy = HsForAllTy
+                                              { hst_fvf = ForallInvis
+                                              , hst_bndrs = univs'
+                                              , hst_xforall = noExt
+                                              , hst_body = cL l cxtTy }
+                                     cxtTy = HsQualTy { hst_ctxt = cL l []
+                                                      , hst_xqual = noExt
+                                                      , hst_body = ty' }
+                               ; return $ cL l forTy }
+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
+cvtPatSynSigTy ty         = cvtType ty
+
+-----------------------------------------------------------
+cvtFixity :: TH.Fixity -> Hs.Fixity
+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
+   where
+     cvt_dir TH.InfixL = Hs.InfixL
+     cvt_dir TH.InfixR = Hs.InfixR
+     cvt_dir TH.InfixN = Hs.InfixN
+
+-----------------------------------------------------------
+
+
+-----------------------------------------------------------
+-- some useful things
+
+overloadedLit :: Lit -> Bool
+-- True for literals that Haskell treats as overloaded
+overloadedLit (IntegerL  _) = True
+overloadedLit (RationalL _) = True
+overloadedLit _             = False
+
+-- Checks that are performed when converting unboxed sum expressions and
+-- patterns alike.
+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
+unboxedSumChecks alt arity
+    | alt > arity
+    = failWith $ text "Sum alternative"    <+> text (show alt)
+             <+> text "exceeds its arity," <+> text (show arity)
+    | alt <= 0
+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
+                      , nest 2 $ text "Sum alternatives must start from 1" ]
+    | arity < 2
+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
+                      , nest 2 $ text "Sums must have an arity of at least 2" ]
+    | otherwise
+    = return ()
+
+-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
+-- using the provided 'LHsQTyVars' and 'LHsType'.
+mkHsForAllTy :: [TH.TyVarBndr]
+             -- ^ The original Template Haskell type variable binders
+             -> SrcSpan
+             -- ^ The location of the returned 'LHsType' if it needs an
+             --   explicit forall
+             -> ForallVisFlag
+             -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)
+             --   or invisible (e.g., @forall a.@)
+             -> LHsQTyVars GhcPs
+             -- ^ The converted type variable binders
+             -> LHsType GhcPs
+             -- ^ The converted rho type
+             -> LHsType GhcPs
+             -- ^ The complete type, quantified with a forall if necessary
+mkHsForAllTy tvs loc fvf tvs' rho_ty
+  | null tvs  = rho_ty
+  | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf
+                                    , hst_bndrs = hsQTvExplicit tvs'
+                                    , hst_xforall = noExt
+                                    , hst_body = rho_ty }
+
+-- | If passed an empty 'TH.Cxt', this simply returns the third argument
+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
+-- 'LHsContext' and 'LHsType'.
+
+-- It's important that we don't build an HsQualTy if the context is empty,
+-- as the pretty-printer for HsType _always_ prints contexts, even if
+-- they're empty. See #13183.
+mkHsQualTy :: TH.Cxt
+           -- ^ The original Template Haskell context
+           -> SrcSpan
+           -- ^ The location of the returned 'LHsType' if it needs an
+           --   explicit context
+           -> LHsContext GhcPs
+           -- ^ The converted context
+           -> LHsType GhcPs
+           -- ^ The converted tau type
+           -> LHsType GhcPs
+           -- ^ The complete type, qualified with a context if necessary
+mkHsQualTy ctxt loc ctxt' ty
+  | null ctxt = ty
+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExt
+                                  , hst_ctxt  = ctxt'
+                                  , hst_body  = ty }
+
+--------------------------------------------------------------------
+--      Turning Name back into RdrName
+--------------------------------------------------------------------
+
+-- variable names
+vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
+
+-- Variable names
+vNameL n = wrapL (vName n)
+vName n = cvtName OccName.varName n
+
+-- Constructor function names; this is Haskell source, hence srcDataName
+cNameL n = wrapL (cName n)
+cName n = cvtName OccName.dataName n
+
+-- Variable *or* constructor names; check by looking at the first char
+vcNameL n = wrapL (vcName n)
+vcName n = if isVarName n then vName n else cName n
+
+-- Type variable names
+tNameL n = wrapL (tName n)
+tName n = cvtName OccName.tvName n
+
+-- Type Constructor names
+tconNameL n = wrapL (tconName n)
+tconName n = cvtName OccName.tcClsName n
+
+ipName :: String -> CvtM HsIPName
+ipName n
+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
+       ; return (HsIPName (fsLit n)) }
+
+cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
+cvtName ctxt_ns (TH.Name occ flavour)
+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
+  | otherwise
+  = do { loc <- getL
+       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
+       ; force rdr_name
+       ; return rdr_name }
+  where
+    occ_str = TH.occString occ
+
+okOcc :: OccName.NameSpace -> String -> Bool
+okOcc ns str
+  | OccName.isVarNameSpace ns     = okVarOcc str
+  | OccName.isDataConNameSpace ns = okConOcc str
+  | otherwise                     = okTcOcc  str
+
+-- Determine the name space of a name in a type
+--
+isVarName :: TH.Name -> Bool
+isVarName (TH.Name occ _)
+  = case TH.occString occ of
+      ""    -> False
+      (c:_) -> startsVarId c || startsVarSym c
+
+badOcc :: OccName.NameSpace -> String -> SDoc
+badOcc ctxt_ns occ
+  = text "Illegal" <+> pprNameSpace ctxt_ns
+        <+> text "name:" <+> quotes (text occ)
+
+thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
+-- This turns a TH Name into a RdrName; used for both binders and occurrences
+-- See Note [Binders in Template Haskell]
+-- The passed-in name space tells what the context is expecting;
+--      use it unless the TH name knows what name-space it comes
+--      from, in which case use the latter
+--
+-- We pass in a SrcSpan (gotten from the monad) because this function
+-- is used for *binders* and if we make an Exact Name we want it
+-- to have a binding site inside it.  (cf #5434)
+--
+-- ToDo: we may generate silly RdrNames, by passing a name space
+--       that doesn't match the string, like VarName ":+",
+--       which will give confusing error messages later
+--
+-- The strict applications ensure that any buried exceptions get forced
+thRdrName loc ctxt_ns th_occ th_name
+  = case th_name of
+     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
+     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)
+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)
+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
+              | otherwise                           -> mkRdrUnqual $! occ
+              -- We check for built-in syntax here, because the TH
+              -- user might have written a (NameS "(,,)"), for example
+  where
+    occ :: OccName.OccName
+    occ = mk_occ ctxt_ns th_occ
+
+-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
+-- See #13776.
+thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
+thOrigRdrName occ th_ns pkg mod =
+  let occ' = mk_occ (mk_ghc_ns th_ns) occ
+  in case isBuiltInOcc_maybe occ' of
+       Just name -> nameRdrName name
+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
+
+thRdrNameGuesses :: TH.Name -> [RdrName]
+thRdrNameGuesses (TH.Name occ flavour)
+  -- This special case for NameG ensures that we don't generate duplicates in the output list
+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
+  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
+                                        | gns <- guessed_nss]
+  where
+    -- guessed_ns are the name spaces guessed from looking at the TH name
+    guessed_nss
+      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
+      | otherwise                       = [OccName.varName, OccName.tvName]
+    occ_str = TH.occString occ
+
+-- The packing and unpacking is rather turgid :-(
+mk_occ :: OccName.NameSpace -> String -> OccName.OccName
+mk_occ ns occ = OccName.mkOccName ns occ
+
+mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
+mk_ghc_ns TH.DataName  = OccName.dataName
+mk_ghc_ns TH.TcClsName = OccName.tcClsName
+mk_ghc_ns TH.VarName   = OccName.varName
+
+mk_mod :: TH.ModName -> ModuleName
+mk_mod mod = mkModuleName (TH.modString mod)
+
+mk_pkg :: TH.PkgName -> UnitId
+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
+
+mk_uniq :: Int -> Unique
+mk_uniq u = mkUniqueGrimily u
+
+{-
+Note [Binders in Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this TH term construction:
+  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
+     ; x2 <- TH.newName "x"   -- Builds a NameU
+     ; x3 <- TH.newName "x"
+
+     ; let x = mkName "x"     -- mkName :: String -> TH.Name
+                              -- Builds a NameS
+
+     ; return (LamE (..pattern [x1,x2]..) $
+               LamE (VarPat x3) $
+               ..tuple (x1,x2,x3,x)) }
+
+It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
+
+a) We don't want to complain about "x" being bound twice in
+   the pattern [x1,x2]
+b) We don't want x3 to shadow the x1,x2
+c) We *do* want 'x' (dynamically bound with mkName) to bind
+   to the innermost binding of "x", namely x3.
+d) When pretty printing, we want to print a unique with x1,x2
+   etc, else they'll all print as "x" which isn't very helpful
+
+When we convert all this to HsSyn, the TH.Names are converted with
+thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
+Achieving (a) is a bit awkward, because
+   - We must check for duplicate and shadowed names on Names,
+     not RdrNames, *after* renaming.
+     See Note [Collect binders only after renaming] in HsUtils
+
+   - But to achieve (a) we must distinguish between the Exact
+     RdrNames arising from TH and the Unqual RdrNames that would
+     come from a user writing \[x,x] -> blah
+
+So in Convert.thRdrName we translate
+   TH Name                          RdrName
+   --------------------------------------------------------
+   NameU (arising from newName) --> Exact (Name{ System })
+   NameS (arising from mkName)  --> Unqual
+
+Notice that the NameUs generate *System* Names.  Then, when
+figuring out shadowing and duplicates, we can filter out
+System Names.
+
+This use of System Names fits with other uses of System Names, eg for
+temporary variables "a". Since there are lots of things called "a" we
+usually want to print the name with the unique, and that is indeed
+the way System Names are printed.
+
+There's a small complication of course; see Note [Looking up Exact
+RdrNames] in RnEnv.
+-}
+
+{-
+Note [Pattern synonym type signatures and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In general, the type signature of a pattern synonym
+
+  pattern P x1 x2 .. xn = <some-pattern>
+
+is of the form
+
+   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+with the following parts:
+
+   1) the (possibly empty lists of) universally quantified type
+      variables `univs` and required constraints `reqs` on them.
+   2) the (possibly empty lists of) existentially quantified type
+      variables `exis` and the provided constraints `provs` on them.
+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
+      x2, .., xn, respectively
+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
+
+Due to the two forall quantifiers and constraint contexts (either of
+which might be empty), pattern synonym type signatures are treated
+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
+`typecheck/TcSplice.hs`:
+
+   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
+       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
+
+           ForallT univs reqs (ForallT exis provs ty)
+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+   (b) When converting pattern synonyms from TH.Dec to HsSyn in
+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an
+       appropriate Haskell pattern synonym type of the form
+
+         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+       where initial empty `univs` type variables or an empty `reqs`
+       constraint context are represented *explicitly* as `() =>`.
+
+   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
+       return its *full* type, i.e.:
+
+           ForallT univs reqs (ForallT exis provs ty)
+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+The key point is to always represent a pattern synonym's *full* type
+in cases (a) and (c) to make it clear which of the two forall
+quantifiers and/or constraint contexts are specified, and which are
+not. See GHC's user's guide on pattern synonyms for more information
+about pattern synonym type signatures.
+
+-}
diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hsSyn/HsDumpAst.hs
@@ -0,0 +1,220 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb
+-- traversal which falls back to displaying based on the constructor name, so
+-- can be used to dump anything having a @Data.Data@ instance.
+
+module HsDumpAst (
+        -- * Dumping ASTs
+        showAstData,
+        BlankSrcSpan(..),
+    ) where
+
+import GhcPrelude
+
+import Data.Data hiding (Fixity)
+import Bag
+import BasicTypes
+import FastString
+import NameSet
+import Name
+import DataCon
+import SrcLoc
+import HsSyn
+import OccName hiding (occName)
+import Var
+import Module
+import Outputable
+
+import qualified Data.ByteString as B
+
+data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
+                  deriving (Eq,Show)
+
+-- | Show a GHC syntax tree. This parameterised because it is also used for
+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
+-- out, to avoid comparing locations, only structure
+showAstData :: Data a => BlankSrcSpan -> a -> SDoc
+showAstData b a0 = blankLine $$ showAstData' a0
+  where
+    showAstData' :: Data a => a -> SDoc
+    showAstData' =
+      generic
+              `ext1Q` list
+              `extQ` string `extQ` fastString `extQ` srcSpan
+              `extQ` lit `extQ` litr `extQ` litt
+              `extQ` bytestring
+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var
+              `extQ` dataCon
+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
+              `extQ` fixity
+              `ext2Q` located
+
+      where generic :: Data a => a -> SDoc
+            generic t = parens $ text (showConstr (toConstr t))
+                                  $$ vcat (gmapQ showAstData' t)
+
+            string :: String -> SDoc
+            string     = text . normalize_newlines . show
+
+            fastString :: FastString -> SDoc
+            fastString s = braces $
+                            text "FastString: "
+                         <> text (normalize_newlines . show $ s)
+
+            bytestring :: B.ByteString -> SDoc
+            bytestring = text . normalize_newlines . show
+
+            list []    = brackets empty
+            list [x]   = brackets (showAstData' x)
+            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)
+                                $$ go x2 xs
+              where
+                go y [] = text "," <> showAstData' y <> text "]"
+                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
+
+            -- Eliminate word-size dependence
+            lit :: HsLit GhcPs -> SDoc
+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
+            lit l                  = generic l
+
+            litr :: HsLit GhcRn -> SDoc
+            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
+            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
+            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
+            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
+            litr l                  = generic l
+
+            litt :: HsLit GhcTc -> SDoc
+            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
+            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
+            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
+            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
+            litt l                  = generic l
+
+            numericLit :: String -> Integer -> SourceText -> SDoc
+            numericLit tag x s = braces $ hsep [ text tag
+                                               , generic x
+                                               , generic s ]
+
+            name :: Name -> SDoc
+            name nm    = braces $ text "Name: " <> ppr nm
+
+            occName n  =  braces $
+                          text "OccName: "
+                       <> text (OccName.occNameString n)
+
+            moduleName :: ModuleName -> SDoc
+            moduleName m = braces $ text "ModuleName: " <> ppr m
+
+            srcSpan :: SrcSpan -> SDoc
+            srcSpan ss = case b of
+             BlankSrcSpan -> text "{ ss }"
+             NoBlankSrcSpan -> braces $ char ' ' <>
+                             (hang (ppr ss) 1
+                                   -- TODO: show annotations here
+                                   (text ""))
+
+            var  :: Var -> SDoc
+            var v      = braces $ text "Var: " <> ppr v
+
+            dataCon :: DataCon -> SDoc
+            dataCon c  = braces $ text "DataCon: " <> ppr c
+
+            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc
+            bagRdrName bg =  braces $
+                             text "Bag(Located (HsBind GhcPs)):"
+                          $$ (list . bagToList $ bg)
+
+            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc
+            bagName bg  =  braces $
+                           text "Bag(Located (HsBind Name)):"
+                        $$ (list . bagToList $ bg)
+
+            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc
+            bagVar bg  =  braces $
+                          text "Bag(Located (HsBind Var)):"
+                       $$ (list . bagToList $ bg)
+
+            nameSet ns =  braces $
+                          text "NameSet:"
+                       $$ (list . nameSetElemsStable $ ns)
+
+            fixity :: Fixity -> SDoc
+            fixity fx =  braces $
+                         text "Fixity: "
+                      <> ppr fx
+
+            located :: (Data b,Data loc) => GenLocated loc b -> SDoc
+            located (L ss a) = parens $
+                   case cast ss of
+                        Just (s :: SrcSpan) ->
+                          srcSpan s
+                        Nothing -> text "nnnnnnnn"
+                      $$ showAstData' a
+
+normalize_newlines :: String -> String
+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
+normalize_newlines (x:xs)                 = x:normalize_newlines xs
+normalize_newlines []                     = []
+
+{-
+************************************************************************
+*                                                                      *
+* Copied from syb
+*                                                                      *
+************************************************************************
+-}
+
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+-- | Type extension of queries for type constructors
+ext1Q :: (Data d, Typeable t)
+      => (d -> q)
+      -> (forall e. Data e => t e -> q)
+      -> d -> q
+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
+
+
+-- | Type extension of queries for type constructors
+ext2Q :: (Data d, Typeable t)
+      => (d -> q)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
+
+-- | Flexible type extension
+ext1 :: (Data a, Typeable t)
+     => c a
+     -> (forall d. Data d => c (t d))
+     -> c a
+ext1 def ext = maybe def id (dataCast1 ext)
+
+
+
+-- | Flexible type extension
+ext2 :: (Data a, Typeable t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2 def ext = maybe def id (dataCast2 ext)
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/BinIface.hs
@@ -0,0 +1,425 @@
+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
+
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+{-# OPTIONS_GHC -O2 #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
+
+-- | Binary interface file support.
+module BinIface (
+        writeBinIface,
+        readBinIface,
+        getSymtabName,
+        getDictFastString,
+        CheckHiWay(..),
+        TraceBinIFaceReading(..),
+        getWithUserData,
+        putWithUserData
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )
+import IfaceEnv
+import HscTypes
+import Module
+import Name
+import DynFlags
+import UniqFM
+import UniqSupply
+import Panic
+import Binary
+import SrcLoc
+import ErrUtils
+import FastMutInt
+import Unique
+import Outputable
+import NameCache
+import Platform
+import FastString
+import Constants
+import Util
+
+import Data.Array
+import Data.Array.ST
+import Data.Array.Unsafe
+import Data.Bits
+import Data.Char
+import Data.Word
+import Data.IORef
+import Data.Foldable
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State.Strict as State
+
+-- ---------------------------------------------------------------------------
+-- Reading and writing binary interface files
+--
+
+data CheckHiWay = CheckHiWay | IgnoreHiWay
+    deriving Eq
+
+data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
+    deriving Eq
+
+-- | Read an interface file
+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
+             -> TcRnIf a b ModIface
+readBinIface checkHiWay traceBinIFaceReading hi_path = do
+    ncu <- mkNameCacheUpdater
+    dflags <- getDynFlags
+    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
+
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
+              -> NameCacheUpdater
+              -> IO ModIface
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
+    let printer :: SDoc -> IO ()
+        printer = case traceBinIFaceReading of
+                      TraceBinIFaceReading -> \sd ->
+                          putLogMsg dflags
+                                    NoReason
+                                    SevOutput
+                                    noSrcSpan
+                                    (defaultDumpStyle dflags)
+                                    sd
+                      QuietBinIFaceReading -> \_ -> return ()
+
+        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
+        wantedGot what wanted got ppr' =
+            printer (text what <> text ": " <>
+                     vcat [text "Wanted " <> ppr' wanted <> text ",",
+                           text "got    " <> ppr' got])
+
+        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
+        errorOnMismatch what wanted got =
+            -- This will be caught by readIface which will emit an error
+            -- msg containing the iface module name.
+            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
+                         (what ++ " (wanted " ++ show wanted
+                               ++ ", got "    ++ show got ++ ")")
+    bh <- Binary.readBinMem hi_path
+
+    -- Read the magic number to check that this really is a GHC .hi file
+    -- (This magic number does not change when we change
+    --  GHC interface file format)
+    magic <- get bh
+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr
+    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
+        (binaryInterfaceMagic dflags) magic
+
+    -- Note [dummy iface field]
+    -- read a dummy 32/64 bit value.  This field used to hold the
+    -- dictionary pointer in old interface file formats, but now
+    -- the dictionary pointer is after the version (where it
+    -- should be).  Also, the serialisation of value of type "Bin
+    -- a" used to depend on the word size of the machine, now they
+    -- are always 32 bits.
+    if wORD_SIZE dflags == 4
+        then do _ <- Binary.get bh :: IO Word32; return ()
+        else do _ <- Binary.get bh :: IO Word64; return ()
+
+    -- Check the interface file version and ways.
+    check_ver  <- get bh
+    let our_ver = show hiVersion
+    wantedGot "Version" our_ver check_ver text
+    errorOnMismatch "mismatched interface file versions" our_ver check_ver
+
+    check_way <- get bh
+    let way_descr = getWayDescr dflags
+    wantedGot "Way" way_descr check_way ppr
+    when (checkHiWay == CheckHiWay) $
+        errorOnMismatch "mismatched interface file ways" way_descr check_way
+    getWithUserData ncu bh
+
+
+-- | This performs a get action after reading the dictionary and symbol
+-- table. It is necessary to run this before trying to deserialise any
+-- Names or FastStrings.
+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
+getWithUserData ncu bh = do
+    -- Read the dictionary
+    -- The next word in the file is a pointer to where the dictionary is
+    -- (probably at the end of the file)
+    dict_p <- Binary.get bh
+    data_p <- tellBin bh          -- Remember where we are now
+    seekBin bh dict_p
+    dict   <- getDictionary bh
+    seekBin bh data_p             -- Back to where we were before
+
+    -- Initialise the user-data field of bh
+    bh <- do
+        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
+                                                     (getDictFastString dict)
+        symtab_p <- Binary.get bh     -- Get the symtab ptr
+        data_p <- tellBin bh          -- Remember where we are now
+        seekBin bh symtab_p
+        symtab <- getSymbolTable bh ncu
+        seekBin bh data_p             -- Back to where we were before
+
+        -- It is only now that we know how to get a Name
+        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
+                                               (getDictFastString dict)
+
+    -- Read the interface file
+    get bh
+
+-- | Write an interface file
+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
+writeBinIface dflags hi_path mod_iface = do
+    bh <- openBinMem initBinMemSize
+    put_ bh (binaryInterfaceMagic dflags)
+
+   -- dummy 32/64-bit field before the version/way for
+   -- compatibility with older interface file formats.
+   -- See Note [dummy iface field] above.
+    if wORD_SIZE dflags == 4
+        then Binary.put_ bh (0 :: Word32)
+        else Binary.put_ bh (0 :: Word64)
+
+    -- The version and way descriptor go next
+    put_ bh (show hiVersion)
+    let way_descr = getWayDescr dflags
+    put_  bh way_descr
+
+
+    putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+    -- And send the result to the file
+    writeBinMem bh hi_path
+
+-- | Put a piece of data with an initialised `UserData` field. This
+-- is necessary if you want to serialise Names or FastStrings.
+-- It also writes a symbol table and the dictionary.
+-- This segment should be read using `getWithUserData`.
+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
+putWithUserData log_action bh payload = do
+    -- Remember where the dictionary pointer will go
+    dict_p_p <- tellBin bh
+    -- Placeholder for ptr to dictionary
+    put_ bh dict_p_p
+
+    -- Remember where the symbol table pointer will go
+    symtab_p_p <- tellBin bh
+    put_ bh symtab_p_p
+    -- Make some initial state
+    symtab_next <- newFastMutInt
+    writeFastMutInt symtab_next 0
+    symtab_map <- newIORef emptyUFM
+    let bin_symtab = BinSymbolTable {
+                         bin_symtab_next = symtab_next,
+                         bin_symtab_map  = symtab_map }
+    dict_next_ref <- newFastMutInt
+    writeFastMutInt dict_next_ref 0
+    dict_map_ref <- newIORef emptyUFM
+    let bin_dict = BinDictionary {
+                       bin_dict_next = dict_next_ref,
+                       bin_dict_map  = dict_map_ref }
+
+    -- Put the main thing,
+    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
+                                                  (putName bin_dict bin_symtab)
+                                                  (putFastString bin_dict)
+    put_ bh payload
+
+    -- Write the symtab pointer at the front of the file
+    symtab_p <- tellBin bh        -- This is where the symtab will start
+    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
+    seekBin bh symtab_p           -- Seek back to the end of the file
+
+    -- Write the symbol table itself
+    symtab_next <- readFastMutInt symtab_next
+    symtab_map  <- readIORef symtab_map
+    putSymbolTable bh symtab_next symtab_map
+    log_action (text "writeBinIface:" <+> int symtab_next
+                                <+> text "Names")
+
+    -- NB. write the dictionary after the symbol table, because
+    -- writing the symbol table may create more dictionary entries.
+
+    -- Write the dictionary pointer at the front of the file
+    dict_p <- tellBin bh          -- This is where the dictionary will start
+    putAt bh dict_p_p dict_p      -- Fill in the placeholder
+    seekBin bh dict_p             -- Seek back to the end of the file
+
+    -- Write the dictionary itself
+    dict_next <- readFastMutInt dict_next_ref
+    dict_map  <- readIORef dict_map_ref
+    putDictionary bh dict_next dict_map
+    log_action (text "writeBinIface:" <+> int dict_next
+                                <+> text "dict entries")
+
+
+
+-- | Initial ram buffer to allocate for writing interface files
+initBinMemSize :: Int
+initBinMemSize = 1024 * 1024
+
+binaryInterfaceMagic :: DynFlags -> Word32
+binaryInterfaceMagic dflags
+ | target32Bit (targetPlatform dflags) = 0x1face
+ | otherwise                           = 0x1face64
+
+
+-- -----------------------------------------------------------------------------
+-- The symbol table
+--
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable bh next_off symtab = do
+    put_ bh next_off
+    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
+      -- It's OK to use nonDetEltsUFM here because the elements have
+      -- indices that array uses to create order
+    mapM_ (\n -> serialiseName bh n symtab) names
+
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
+getSymbolTable bh ncu = do
+    sz <- get bh
+    od_names <- sequence (replicate sz (get bh))
+    updateNameCache ncu $ \namecache ->
+        runST $ flip State.evalStateT namecache $ do
+            mut_arr <- lift $ newSTArray_ (0, sz-1)
+            for_ (zip [0..] od_names) $ \(i, odn) -> do
+                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
+                lift $ writeArray mut_arr i n
+                State.put nc
+            arr <- lift $ unsafeFreeze mut_arr
+            namecache' <- State.get
+            return (namecache', arr)
+  where
+    -- This binding is required because the type of newArray_ cannot be inferred
+    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
+    newSTArray_ = newArray_
+
+type OnDiskName = (UnitId, ModuleName, OccName)
+
+fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
+fromOnDiskName nc (pid, mod_name, occ) =
+    let mod   = mkModule pid mod_name
+        cache = nsNames nc
+    in case lookupOrigNameCache cache  mod occ of
+           Just name -> (nc, name)
+           Nothing   ->
+               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+                   name       = mkExternalName uniq mod occ noSrcSpan
+                   new_cache  = extendNameCache cache mod occ name
+               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+
+serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName bh name _ = do
+    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)
+
+
+-- Note [Symbol table representation of names]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- An occurrence of a name in an interface file is serialized as a single 32-bit
+-- word. The format of this word is:
+--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
+--   A normal name. x is an index into the symbol table
+--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
+--   A known-key name. x is the Unique's Char, y is the int part. We assume that
+--   all known-key uniques fit in this space. This is asserted by
+--   PrelInfo.knownKeyNamesOkay.
+--
+-- During serialization we check for known-key things using isKnownKeyName.
+-- During deserialization we use lookupKnownKeyName to get from the unique back
+-- to its corresponding Name.
+
+
+-- See Note [Symbol table representation of names]
+putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
+putName _dict BinSymbolTable{
+               bin_symtab_map = symtab_map_ref,
+               bin_symtab_next = symtab_next }
+        bh name
+  | isKnownKeyName name
+  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
+  = -- ASSERT(u < 2^(22 :: Int))
+    put_ bh (0x80000000
+             .|. (fromIntegral (ord c) `shiftL` 22)
+             .|. (fromIntegral u :: Word32))
+
+  | otherwise
+  = do symtab_map <- readIORef symtab_map_ref
+       case lookupUFM symtab_map name of
+         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
+         Nothing -> do
+            off <- readFastMutInt symtab_next
+            -- MASSERT(off < 2^(30 :: Int))
+            writeFastMutInt symtab_next (off+1)
+            writeIORef symtab_map_ref
+                $! addToUFM symtab_map name (off,name)
+            put_ bh (fromIntegral off :: Word32)
+
+-- See Note [Symbol table representation of names]
+getSymtabName :: NameCacheUpdater
+              -> Dictionary -> SymbolTable
+              -> BinHandle -> IO Name
+getSymtabName _ncu _dict symtab bh = do
+    i :: Word32 <- get bh
+    case i .&. 0xC0000000 of
+      0x00000000 -> return $! symtab ! fromIntegral i
+
+      0x80000000 ->
+        let
+          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
+          ix  = fromIntegral i .&. 0x003FFFFF
+          u   = mkUnique tag ix
+        in
+          return $! case lookupKnownKeyName u of
+                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"
+                                          (ppr i $$ ppr (unpkUnique u))
+                      Just n  -> n
+
+      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+
+data BinSymbolTable = BinSymbolTable {
+        bin_symtab_next :: !FastMutInt, -- The next index to use
+        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
+                                -- indexed by Name
+  }
+
+putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
+
+allocateFastString :: BinDictionary -> FastString -> IO Word32
+allocateFastString BinDictionary { bin_dict_next = j_r,
+                                   bin_dict_map  = out_r} f = do
+    out <- readIORef out_r
+    let uniq = getUnique f
+    case lookupUFM out uniq of
+        Just (j, _)  -> return (fromIntegral j :: Word32)
+        Nothing -> do
+           j <- readFastMutInt j_r
+           writeFastMutInt j_r (j + 1)
+           writeIORef out_r $! addToUFM out uniq (j, f)
+           return (fromIntegral j :: Word32)
+
+getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString dict bh = do
+    j <- get bh
+    return $! (dict ! fromIntegral (j :: Word32))
+
+data BinDictionary = BinDictionary {
+        bin_dict_next :: !FastMutInt, -- The next index to use
+        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
+                                -- indexed by FastString
+  }
+
+getWayDescr :: DynFlags -> String
+getWayDescr dflags
+  | platformUnregisterised (targetPlatform dflags) = 'u':tag
+  | otherwise                                      =     tag
+  where tag = buildTag dflags
+        -- if this is an unregisterised build, make sure our interfaces
+        -- can't be used by a registerised build.
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/BuildTyCl.hs
@@ -0,0 +1,414 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP #-}
+
+module BuildTyCl (
+        buildDataCon,
+        buildPatSyn,
+        TcMethInfo, MethInfo, buildClass,
+        mkNewTyConRhs,
+        newImplicitBinder, newTyConRepName
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import IfaceEnv
+import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
+import TysWiredIn( isCTupleTyConName )
+import TysPrim ( voidPrimTy )
+import DataCon
+import PatSyn
+import Var
+import VarSet
+import BasicTypes
+import Name
+import NameEnv
+import MkId
+import Class
+import TyCon
+import Type
+import Id
+import TcType
+
+import SrcLoc( SrcSpan, noSrcSpan )
+import DynFlags
+import TcRnMonad
+import UniqSupply
+import Util
+import Outputable
+
+
+mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
+-- ^ Monadic because it makes a Name for the coercion TyCon
+--   We pass the Name of the parent TyCon, as well as the TyCon itself,
+--   because the latter is part of a knot, whereas the former is not.
+mkNewTyConRhs tycon_name tycon con
+  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
+        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
+        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
+        ; return (NewTyCon { data_con    = con,
+                             nt_rhs      = rhs_ty,
+                             nt_etad_rhs = (etad_tvs, etad_rhs),
+                             nt_co       = nt_ax } ) }
+                             -- Coreview looks through newtypes with a Nothing
+                             -- for nt_co, or uses explicit coercions otherwise
+  where
+    tvs    = tyConTyVars tycon
+    roles  = tyConRoles tycon
+    con_arg_ty = case dataConRepArgTys con of
+                   [arg_ty] -> arg_ty
+                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
+    rhs_ty = substTyWith (dataConUnivTyVars con)
+                         (mkTyVarTys tvs) con_arg_ty
+        -- Instantiate the newtype's RHS with the
+        -- type variables from the tycon
+        -- NB: a newtype DataCon has a type that must look like
+        --        forall tvs.  <arg-ty> -> T tvs
+        -- Note that we *can't* use dataConInstOrigArgTys here because
+        -- the newtype arising from   class Foo a => Bar a where {}
+        -- has a single argument (Foo a) that is a *type class*, so
+        -- dataConInstOrigArgTys returns [].
+
+    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can
+    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty
+    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface
+    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
+
+    eta_reduce :: [TyVar]       -- Reversed
+               -> [Role]        -- also reversed
+               -> Type          -- Rhs type
+               -> ([TyVar], [Role], Type)  -- Eta-reduced version
+                                           -- (tyvars in normal order)
+    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
+                                  Just tv <- getTyVar_maybe arg,
+                                  tv == a,
+                                  not (a `elemVarSet` tyCoVarsOfType fun)
+                                = eta_reduce as rs fun
+    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
+
+------------------------------------------------------
+buildDataCon :: FamInstEnvs
+            -> Name
+            -> Bool                     -- Declared infix
+            -> TyConRepName
+            -> [HsSrcBang]
+            -> Maybe [HsImplBang]
+                -- See Note [Bangs on imported data constructors] in MkId
+           -> [FieldLabel]             -- Field labels
+           -> [TyVar]                  -- Universals
+           -> [TyCoVar]                -- Existentials
+           -> [TyVarBinder]            -- User-written 'TyVarBinder's
+           -> [EqSpec]                 -- Equality spec
+           -> KnotTied ThetaType       -- Does not include the "stupid theta"
+                                       -- or the GADT equalities
+           -> [KnotTied Type]          -- Arguments
+           -> KnotTied Type            -- Result types
+           -> KnotTied TyCon           -- Rep tycon
+           -> NameEnv ConTag           -- Maps the Name of each DataCon to its
+                                       -- ConTag
+           -> TcRnIf m n DataCon
+-- A wrapper for DataCon.mkDataCon that
+--   a) makes the worker Id
+--   b) makes the wrapper Id if necessary, including
+--      allocating its unique (hence monadic)
+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
+             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
+             rep_tycon tag_map
+  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
+        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
+        -- This last one takes the name of the data constructor in the source
+        -- code, which (for Haskell source anyway) will be in the DataName name
+        -- space, and puts it into the VarName name space
+
+        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
+        ; us <- newUniqueSupply
+        ; dflags <- getDynFlags
+        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
+              tag = lookupNameEnv_NF tag_map src_name
+              -- See Note [Constructor tag allocation], fixes #14657
+              data_con = mkDataCon src_name declared_infix prom_info
+                                   src_bangs field_lbls
+                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt
+                                   arg_tys res_ty NoRRI rep_tycon tag
+                                   stupid_ctxt dc_wrk dc_rep
+              dc_wrk = mkDataConWorkId work_name data_con
+              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
+                                                impl_bangs data_con)
+
+        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
+        ; return data_con }
+
+
+-- The stupid context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+-- ToDo: Or functionally dependent on?
+--       This whole stupid theta thing is, well, stupid.
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
+mkDataConStupidTheta tycon arg_tys univ_tvs
+  | null stupid_theta = []      -- The common case
+  | otherwise         = filter in_arg_tys stupid_theta
+  where
+    tc_subst     = zipTvSubst (tyConTyVars tycon)
+                              (mkTyVarTys univ_tvs)
+    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
+        -- Start by instantiating the master copy of the
+        -- stupid theta, taken from the TyCon
+
+    arg_tyvars      = tyCoVarsOfTypes arg_tys
+    in_arg_tys pred = not $ isEmptyVarSet $
+                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars
+
+
+------------------------------------------------------
+buildPatSyn :: Name -> Bool
+            -> (Id,Bool) -> Maybe (Id, Bool)
+            -> ([TyVarBinder], ThetaType) -- ^ Univ and req
+            -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
+            -> [Type]               -- ^ Argument types
+            -> Type                 -- ^ Result type
+            -> [FieldLabel]         -- ^ Field labels for
+                                    --   a record pattern synonym
+            -> PatSyn
+buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
+            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
+            pat_ty field_labels
+  = -- The assertion checks that the matcher is
+    -- compatible with the pattern synonym
+    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
+                 , ex_tvs `equalLength` ex_tvs1
+                 , pat_ty `eqType` substTy subst pat_ty1
+                 , prov_theta `eqTypes` substTys subst prov_theta1
+                 , req_theta `eqTypes` substTys subst req_theta1
+                 , compareArgTys arg_tys (substTys subst arg_tys1)
+                 ])
+            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
+                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
+                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1
+                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1
+                    , ppr req_theta <+> twiddle <+> ppr req_theta1
+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
+    mkPatSyn src_name declared_infix
+             (univ_tvs, req_theta) (ex_tvs, prov_theta)
+             arg_tys pat_ty
+             matcher builder field_labels
+  where
+    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
+    ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau
+    (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy cont_sigma
+    (arg_tys1, _) = (tcSplitFunTys cont_tau)
+    twiddle = char '~'
+    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
+                       (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
+
+    -- For a nullary pattern synonym we add a single void argument to the
+    -- matcher to preserve laziness in the case of unlifted types.
+    -- See #12746
+    compareArgTys :: [Type] -> [Type] -> Bool
+    compareArgTys [] [x] = x `eqType` voidPrimTy
+    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
+
+
+------------------------------------------------------
+type TcMethInfo = MethInfo  -- this variant needs zonking
+type MethInfo       -- A temporary intermediate, to communicate
+                    -- between tcClassSigs and buildClass.
+  = ( Name   -- Name of the class op
+    , Type   -- Type of the class op
+    , Maybe (DefMethSpec (SrcSpan, Type)))
+         -- Nothing                    => no default method
+         --
+         -- Just VanillaDM             => There is an ordinary
+         --                               polymorphic default method
+         --
+         -- Just (GenericDM (loc, ty)) => There is a generic default metho
+         --                               Here is its type, and the location
+         --                               of the type signature
+         --    We need that location /only/ to attach it to the
+         --    generic default method's Name; and we need /that/
+         --    only to give the right location of an ambiguity error
+         --    for the generic default method, spat out by checkValidClass
+
+buildClass :: Name  -- Name of the class/tycon (they have the same Name)
+           -> [TyConBinder]                -- Of the tycon
+           -> [Role]
+           -> [FunDep TyVar]               -- Functional dependencies
+           -- Super classes, associated types, method info, minimal complete def.
+           -- This is Nothing if the class is abstract.
+           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
+           -> TcRnIf m n Class
+
+buildClass tycon_name binders roles fds Nothing
+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
+    do  { traceIf (text "buildClass")
+
+        ; tc_rep_name  <- newTyConRepName tycon_name
+        ; let univ_tvs = binderVars binders
+              tycon = mkClassTyCon tycon_name binders roles
+                                   AbstractTyCon rec_clas tc_rep_name
+              result = mkAbstractClass tycon_name univ_tvs fds tycon
+        ; traceIf (text "buildClass" <+> ppr tycon)
+        ; return result }
+
+buildClass tycon_name binders roles fds
+           (Just (sc_theta, at_items, sig_stuff, mindef))
+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
+    do  { traceIf (text "buildClass")
+
+        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
+        ; tc_rep_name  <- newTyConRepName tycon_name
+
+        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
+                        -- Build the selector id and default method id
+
+              -- Make selectors for the superclasses
+        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
+                                (takeList sc_theta [fIRST_TAG..])
+        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
+                           | sc_name <- sc_sel_names]
+              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
+              -- can construct names for the selectors. Thus
+              --      class (C a, C b) => D a b where ...
+              -- gives superclass selectors
+              --      D_sc1, D_sc2
+              -- (We used to call them D_C, but now we can have two different
+              --  superclasses both called C!)
+
+        ; let use_newtype = isSingleton arg_tys
+                -- Use a newtype if the data constructor
+                --   (a) has exactly one value field
+                --       i.e. exactly one operation or superclass taken together
+                --   (b) that value is of lifted type (which they always are, because
+                --       we box equality superclasses)
+                -- See note [Class newtypes and equality predicates]
+
+                -- We treat the dictionary superclasses as ordinary arguments.
+                -- That means that in the case of
+                --     class C a => D a
+                -- we don't get a newtype with no arguments!
+              args       = sc_sel_names ++ op_names
+              op_tys     = [ty | (_,ty,_) <- sig_stuff]
+              op_names   = [op | (op,_,_) <- sig_stuff]
+              arg_tys    = sc_theta ++ op_tys
+              rec_tycon  = classTyCon rec_clas
+              univ_bndrs = tyConTyVarBinders binders
+              univ_tvs   = binderVars univ_bndrs
+
+        ; rep_nm   <- newTyConRepName datacon_name
+        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
+                                   datacon_name
+                                   False        -- Not declared infix
+                                   rep_nm
+                                   (map (const no_bang) args)
+                                   (Just (map (const HsLazy) args))
+                                   [{- No fields -}]
+                                   univ_tvs
+                                   [{- no existentials -}]
+                                   univ_bndrs
+                                   [{- No GADT equalities -}]
+                                   [{- No theta -}]
+                                   arg_tys
+                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
+                                   rec_tycon
+                                   (mkTyConTagMap rec_tycon)
+
+        ; rhs <- case () of
+                  _ | use_newtype
+                    -> mkNewTyConRhs tycon_name rec_tycon dict_con
+                    | isCTupleTyConName tycon_name
+                    -> return (TupleTyCon { data_con = dict_con
+                                          , tup_sort = ConstraintTuple })
+                    | otherwise
+                    -> return (mkDataTyConRhs [dict_con])
+
+        ; let { tycon = mkClassTyCon tycon_name binders roles
+                                     rhs rec_clas tc_rep_name
+                -- A class can be recursive, and in the case of newtypes
+                -- this matters.  For example
+                --      class C a where { op :: C b => a -> b -> Int }
+                -- Because C has only one operation, it is represented by
+                -- a newtype, and it should be a *recursive* newtype.
+                -- [If we don't make it a recursive newtype, we'll expand the
+                -- newtype like a synonym, but that will lead to an infinite
+                -- type]
+
+              ; result = mkClass tycon_name univ_tvs fds
+                                 sc_theta sc_sel_ids at_items
+                                 op_items mindef tycon
+              }
+        ; traceIf (text "buildClass" <+> ppr tycon)
+        ; return result }
+  where
+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
+
+    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
+    mk_op_item rec_clas (op_name, _, dm_spec)
+      = do { dm_info <- mk_dm_info op_name dm_spec
+           ; return (mkDictSelId op_name rec_clas, dm_info) }
+
+    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
+               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
+    mk_dm_info _ Nothing
+      = return Nothing
+    mk_dm_info op_name (Just VanillaDM)
+      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+           ; return (Just (dm_name, VanillaDM)) }
+    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
+      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
+           ; return (Just (dm_name, GenericDM dm_ty)) }
+
+{-
+Note [Class newtypes and equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        class (a ~ F b) => C a b where
+          op :: a -> b
+
+We cannot represent this by a newtype, even though it's not
+existential, because there are two value fields (the equality
+predicate and op. See #2238
+
+Moreover,
+          class (a ~ F b) => C a b where {}
+Here we can't use a newtype either, even though there is only
+one field, because equality predicates are unboxed, and classes
+are boxed.
+-}
+
+newImplicitBinder :: Name                       -- Base name
+                  -> (OccName -> OccName)       -- Occurrence name modifier
+                  -> TcRnIf m n Name            -- Implicit name
+-- Called in BuildTyCl to allocate the implicit binders of type/class decls
+-- For source type/class decls, this is the first occurrence
+-- For iface ones, the LoadIface has already allocated a suitable name in the cache
+newImplicitBinder base_name mk_sys_occ
+  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
+
+newImplicitBinderLoc :: Name                       -- Base name
+                     -> (OccName -> OccName)       -- Occurrence name modifier
+                     -> SrcSpan
+                     -> TcRnIf m n Name            -- Implicit name
+-- Just the same, but lets you specify the SrcSpan
+newImplicitBinderLoc base_name mk_sys_occ loc
+  | Just mod <- nameModule_maybe base_name
+  = newGlobalBinder mod occ loc
+  | otherwise           -- When typechecking a [d| decl bracket |],
+                        -- TH generates types, classes etc with Internal names,
+                        -- so we follow suit for the implicit binders
+  = do  { uniq <- newUnique
+        ; return (mkInternalName uniq occ loc) }
+  where
+    occ = mk_sys_occ (nameOccName base_name)
+
+-- | Make the 'TyConRepName' for this 'TyCon'
+newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
+newTyConRepName tc_name
+  | Just mod <- nameModule_maybe tc_name
+  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
+  = newGlobalBinder mod occ noSrcSpan
+  | otherwise
+  = newImplicitBinder tc_name mkTyConRepOcc
diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/FlagChecker.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This module manages storing the various GHC option flags in a modules
+-- interface file as part of the recompilation checking infrastructure.
+module FlagChecker (
+        fingerprintDynFlags
+      , fingerprintOptFlags
+      , fingerprintHpcFlags
+    ) where
+
+import GhcPrelude
+
+import Binary
+import BinIface ()
+import DynFlags
+import HscTypes
+import Module
+import Name
+import Fingerprint
+import BinFingerprint
+-- import Outputable
+
+import qualified EnumSet
+import System.FilePath (normalise)
+
+-- | Produce a fingerprint of a @DynFlags@ value. We only base
+-- the finger print on important fields in @DynFlags@ so that
+-- the recompilation checker can use this fingerprint.
+--
+-- NB: The 'Module' parameter is the 'Module' recorded by the
+-- *interface* file, not the actual 'Module' according to our
+-- 'DynFlags'.
+fingerprintDynFlags :: DynFlags -> Module
+                    -> (BinHandle -> Name -> IO ())
+                    -> IO Fingerprint
+
+fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
+    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing
+                      -- see #5878
+        -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)
+        safeHs   = setSafeMode safeHaskell
+        -- oflags   = sort $ filter filterOFlags $ flags dflags
+
+        -- *all* the extension flags and the language
+        lang = (fmap fromEnum language,
+                map fromEnum $ EnumSet.toList extensionFlags)
+
+        -- -I, -D and -U flags affect CPP
+        cpp = ( map normalise $ flattenIncludes includePaths
+            -- normalise: eliminate spurious differences due to "./foo" vs "foo"
+              , picPOpts dflags
+              , opt_P_signature dflags)
+            -- See Note [Repeated -optP hashing]
+
+        -- Note [path flags and recompilation]
+        paths = [ hcSuf ]
+
+        -- -fprof-auto etc.
+        prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0
+
+        flags = (mainis, safeHs, lang, cpp, paths, prof)
+
+    in -- pprTrace "flags" (ppr flags) $
+       computeFingerprint nameio flags
+
+-- Fingerprint the optimisation info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to ignore changes in
+-- optimisation level or optimisation flags so as to use as many pre-existing
+-- object files as they can.
+-- See Note [Ignoring some flag changes]
+fingerprintOptFlags :: DynFlags
+                      -> (BinHandle -> Name -> IO ())
+                      -> IO Fingerprint
+fingerprintOptFlags DynFlags{..} nameio =
+      let
+        -- See https://gitlab.haskell.org/ghc/ghc/issues/10923
+        -- We used to fingerprint the optimisation level, but as Joachim
+        -- Breitner pointed out in comment 9 on that ticket, it's better
+        -- to ignore that and just look at the individual optimisation flags.
+        opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
+                                          (EnumSet.toList generalFlags)
+
+      in computeFingerprint nameio opt_flags
+
+-- Fingerprint the HPC info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to use an object
+-- file compiled for HPC when not actually using HPC.
+-- See Note [Ignoring some flag changes]
+fingerprintHpcFlags :: DynFlags
+                      -> (BinHandle -> Name -> IO ())
+                      -> IO Fingerprint
+fingerprintHpcFlags dflags@DynFlags{..} nameio =
+      let
+        -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798
+        -- hpcDir is output-only, so we should recompile if it changes
+        hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
+
+      in computeFingerprint nameio hpc
+
+
+{- Note [path flags and recompilation]
+
+There are several flags that we deliberately omit from the
+recompilation check; here we explain why.
+
+-osuf, -odir, -hisuf, -hidir
+  If GHC decides that it does not need to recompile, then
+  it must have found an up-to-date .hi file and .o file.
+  There is no point recording these flags - the user must
+  have passed the correct ones.  Indeed, the user may
+  have compiled the source file in one-shot mode using
+  -o to specify the .o file, and then loaded it in GHCi
+  using -odir.
+
+-stubdir
+  We omit this one because it is automatically set by -outputdir, and
+  we don't want changes in -outputdir to automatically trigger
+  recompilation.  This could be wrong, but only in very rare cases.
+
+-i (importPaths)
+  For the same reason as -osuf etc. above: if GHC decides not to
+  recompile, then it must have already checked all the .hi files on
+  which the current module depends, so it must have found them
+  successfully.  It is occasionally useful to be able to cd to a
+  different directory and use -i flags to enable GHC to find the .hi
+  files; we don't want this to force recompilation.
+
+The only path-related flag left is -hcsuf.
+-}
+
+{- Note [Ignoring some flag changes]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Normally, --make tries to reuse only compilation products that are
+the same as those that would have been produced compiling from
+scratch. Sometimes, however, users would like to be more aggressive
+about recompilation avoidance. This is particularly likely when
+developing using GHCi (see #13604). Currently, we allow users to
+ignore optimisation changes using -fignore-optim-changes, and to
+ignore HPC option changes using -fignore-hpc-changes. If there's a
+demand for it, we could also allow changes to -fprof-auto-* flags
+(although we can't allow -prof flags to differ). The key thing about
+these options is that we can still successfully link a library or
+executable when some of its components differ in these ways.
+
+The way we accomplish this is to leave the optimization and HPC
+options out of the flag hash, hashing them separately.
+-}
+
+{- Note [Repeated -optP hashing]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We invoke fingerprintDynFlags for each compiled module to include
+the hash of relevant DynFlags in the resulting interface file.
+-optP (preprocessor) flags are part of that hash.
+-optP flags can come from multiple places:
+
+  1. -optP flags directly passed on command line.
+  2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.
+  3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.
+
+When compiling many modules at once with many -optP command line arguments
+the work of hashing -optP flags would be repeated. This can get expensive
+and as noted on #14697 it can take 7% of time and 14% of allocations on
+a real codebase.
+
+The obvious solution is to cache the hash of -optP flags per GHC invocation.
+However, one has to be careful there, as the flags that were added in 3. way
+have to be accounted for.
+
+The current strategy is as follows:
+
+  1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p
+     is modified. This serves dual purpose. It ensures correctness for when
+     we add per file -optP flags and lets us save work for when we don't.
+  2. When computing the fingerprint in fingerprintDynFlags use the cached
+     value *and* fingerprint the additional implied (see 2. above) -optP flags.
+     This is relatively cheap and saves the headache of fingerprinting all
+     the -optP flags and tracking all the places that could invalidate the
+     cache.
+-}
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/IfaceEnv.hs
@@ -0,0 +1,298 @@
+-- (c) The University of Glasgow 2002-2006
+
+{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}
+
+module IfaceEnv (
+        newGlobalBinder, newInteractiveBinder,
+        externaliseName,
+        lookupIfaceTop,
+        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
+        newIfaceName, newIfaceNames,
+        extendIfaceIdEnv, extendIfaceTyVarEnv,
+        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
+        lookupIfaceTyVar, extendIfaceEnvs,
+        setNameModule,
+
+        ifaceExportNames,
+
+        -- Name-cache stuff
+        allocateGlobalBinder, updNameCacheTc,
+        mkNameCacheUpdater, NameCacheUpdater(..),
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import HscTypes
+import Type
+import Var
+import Name
+import Avail
+import Module
+import FastString
+import FastStringEnv
+import IfaceType
+import NameCache
+import UniqSupply
+import SrcLoc
+
+import Outputable
+import Data.List     ( partition )
+
+{-
+*********************************************************
+*                                                      *
+        Allocating new Names in the Name Cache
+*                                                      *
+*********************************************************
+
+See Also: Note [The Name Cache] in NameCache
+-}
+
+newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
+-- Used for source code and interface files, to make the
+-- Name for a thing, given its Module and OccName
+-- See Note [The Name Cache]
+--
+-- The cache may already already have a binding for this thing,
+-- because we may have seen an occurrence before, but now is the
+-- moment when we know its Module and SrcLoc in their full glory
+
+newGlobalBinder mod occ loc
+  = do { name <- updNameCacheTc mod occ $ \name_cache ->
+                 allocateGlobalBinder name_cache mod occ loc
+       ; traceIf (text "newGlobalBinder" <+>
+                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
+       ; return name }
+
+newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
+-- Works in the IO monad, and gets the Module
+-- from the interactive context
+newInteractiveBinder hsc_env occ loc
+ = do { let mod = icInteractiveModule (hsc_IC hsc_env)
+       ; updNameCacheIO hsc_env mod occ $ \name_cache ->
+         allocateGlobalBinder name_cache mod occ loc }
+
+allocateGlobalBinder
+  :: NameCache
+  -> Module -> OccName -> SrcSpan
+  -> (NameCache, Name)
+-- See Note [The Name Cache]
+allocateGlobalBinder name_supply mod occ loc
+  = case lookupOrigNameCache (nsNames name_supply) mod occ of
+        -- A hit in the cache!  We are at the binding site of the name.
+        -- This is the moment when we know the SrcLoc
+        -- of the Name, so we set this field in the Name we return.
+        --
+        -- Then (bogus) multiple bindings of the same Name
+        -- get different SrcLocs can can be reported as such.
+        --
+        -- Possible other reason: it might be in the cache because we
+        --      encountered an occurrence before the binding site for an
+        --      implicitly-imported Name.  Perhaps the current SrcLoc is
+        --      better... but not really: it'll still just say 'imported'
+        --
+        -- IMPORTANT: Don't mess with wired-in names.
+        --            Their wired-in-ness is in their NameSort
+        --            and their Module is correct.
+
+        Just name | isWiredInName name
+                  -> (name_supply, name)
+                  | otherwise
+                  -> (new_name_supply, name')
+                  where
+                    uniq            = nameUnique name
+                    name'           = mkExternalName uniq mod occ loc
+                                      -- name' is like name, but with the right SrcSpan
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'
+                    new_name_supply = name_supply {nsNames = new_cache}
+
+        -- Miss in the cache!
+        -- Build a completely new Name, and put it in the cache
+        _ -> (new_name_supply, name)
+                  where
+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
+                    name            = mkExternalName uniq mod occ loc
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name
+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+
+ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
+ifaceExportNames exports = return exports
+
+-- | A function that atomically updates the name cache given a modifier
+-- function.  The second result of the modifier function will be the result
+-- of the IO action.
+newtype NameCacheUpdater
+      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
+
+mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
+mkNameCacheUpdater = do { hsc_env <- getTopEnv
+                        ; let !ncRef = hsc_NC hsc_env
+                        ; return (NCU (updNameCache ncRef)) }
+
+updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
+               -> TcRnIf a b c
+updNameCacheTc mod occ upd_fn = do {
+    hsc_env <- getTopEnv
+  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
+
+
+updNameCacheIO ::  HscEnv -> Module -> OccName
+               -> (NameCache -> (NameCache, c))
+               -> IO c
+updNameCacheIO hsc_env mod occ upd_fn = do {
+
+    -- First ensure that mod and occ are evaluated
+    -- If not, chaos can ensue:
+    --      we read the name-cache
+    --      then pull on mod (say)
+    --      which does some stuff that modifies the name cache
+    -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+
+    mod `seq` occ `seq` return ()
+  ; updNameCache (hsc_NC hsc_env) upd_fn }
+
+
+{-
+************************************************************************
+*                                                                      *
+                Name cache access
+*                                                                      *
+************************************************************************
+-}
+
+-- | Look up the 'Name' for a given 'Module' and 'OccName'.
+-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad
+-- and 'Module' is simply that of the 'ModIface' you are typechecking.
+lookupOrig :: Module -> OccName -> TcRnIf a b Name
+lookupOrig mod occ
+  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
+
+        ; updNameCacheTc mod occ $ lookupNameCache mod occ }
+
+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
+lookupOrigIO hsc_env mod occ
+  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
+
+lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
+-- Lookup up the (Module,OccName) in the NameCache
+-- If you find it, return it; if not, allocate a fresh original name and extend
+-- the NameCache.
+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
+-- If we need to explore its value we will load Foo.hi; but meanwhile all we
+-- need is a Name for it.
+lookupNameCache mod occ name_cache =
+  case lookupOrigNameCache (nsNames name_cache) mod occ of {
+    Just name -> (name_cache, name);
+    Nothing   ->
+        case takeUniqFromSupply (nsUniqs name_cache) of {
+          (uniq, us) ->
+              let
+                name      = mkExternalName uniq mod occ noSrcSpan
+                new_cache = extendNameCache (nsNames name_cache) mod occ name
+              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
+
+externaliseName :: Module -> Name -> TcRnIf m n Name
+-- Take an Internal Name and make it an External one,
+-- with the same unique
+externaliseName mod name
+  = do { let occ = nameOccName name
+             loc = nameSrcSpan name
+             uniq = nameUnique name
+       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder
+       ; updNameCacheTc mod occ $ \ ns ->
+         let name' = mkExternalName uniq mod occ loc
+             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
+         in (ns', name') }
+
+-- | Set the 'Module' of a 'Name'.
+setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
+setNameModule Nothing n = return n
+setNameModule (Just m) n =
+    newGlobalBinder m (nameOccName n) (nameSrcSpan n)
+
+{-
+************************************************************************
+*                                                                      *
+                Type variables and local Ids
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceLclId :: FastString -> IfL Id
+tcIfaceLclId occ
+  = do  { lcl <- getLclEnv
+        ; case (lookupFsEnv (if_id_env lcl) occ) of
+            Just ty_var -> return ty_var
+            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
+        }
+
+extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
+extendIfaceIdEnv ids thing_inside
+  = do  { env <- getLclEnv
+        ; let { id_env' = extendFsEnvList (if_id_env env) pairs
+              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
+        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+
+
+tcIfaceTyVar :: FastString -> IfL TyVar
+tcIfaceTyVar occ
+  = do  { lcl <- getLclEnv
+        ; case (lookupFsEnv (if_tv_env lcl) occ) of
+            Just ty_var -> return ty_var
+            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
+        }
+
+lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
+lookupIfaceTyVar (occ, _)
+  = do  { lcl <- getLclEnv
+        ; return (lookupFsEnv (if_tv_env lcl) occ) }
+
+lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
+lookupIfaceVar (IfaceIdBndr (occ, _))
+  = do  { lcl <- getLclEnv
+        ; return (lookupFsEnv (if_id_env lcl) occ) }
+lookupIfaceVar (IfaceTvBndr (occ, _))
+  = do  { lcl <- getLclEnv
+        ; return (lookupFsEnv (if_tv_env lcl) occ) }
+
+extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
+extendIfaceTyVarEnv tyvars thing_inside
+  = do  { env <- getLclEnv
+        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
+              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
+        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
+
+extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
+extendIfaceEnvs tcvs thing_inside
+  = extendIfaceTyVarEnv tvs $
+    extendIfaceIdEnv    cvs $
+    thing_inside
+  where
+    (tvs, cvs) = partition isTyVar tcvs
+
+{-
+************************************************************************
+*                                                                      *
+                Getting from RdrNames to Names
+*                                                                      *
+************************************************************************
+-}
+
+-- | Look up a top-level name from the current Iface module
+lookupIfaceTop :: OccName -> IfL Name
+lookupIfaceTop occ
+  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
+
+newIfaceName :: OccName -> IfL Name
+newIfaceName occ
+  = do  { uniq <- newUnique
+        ; return $! mkInternalName uniq occ noSrcSpan }
+
+newIfaceNames :: [OccName] -> IfL [Name]
+newIfaceNames occs
+  = do  { uniqs <- newUniqueSupply
+        ; return [ mkInternalName uniq occ noSrcSpan
+                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
diff --git a/compiler/iface/IfaceEnv.hs-boot b/compiler/iface/IfaceEnv.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/iface/IfaceEnv.hs-boot
@@ -0,0 +1,9 @@
+module IfaceEnv where
+
+import Module
+import OccName
+import TcRnMonad
+import Name
+import SrcLoc
+
+newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/LoadIface.hs
@@ -0,0 +1,1286 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Loading interface files
+-}
+
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module LoadIface (
+        -- Importing one thing
+        tcLookupImported_maybe, importDecl,
+        checkWiredInTyCon, ifCheckWiredInThing,
+
+        -- RnM/TcM functions
+        loadModuleInterface, loadModuleInterfaces,
+        loadSrcInterface, loadSrcInterface_maybe,
+        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,
+
+        -- IfM functions
+        loadInterface,
+        loadSysInterface, loadUserInterface, loadPluginInterface,
+        findAndReadIface, readIface,    -- Used when reading the module's old interface
+        loadDecls,      -- Should move to TcIface and be renamed
+        initExternalPackageState,
+        moduleFreeHolesPrecise,
+        needWiredInHomeIface, loadWiredInHomeIface,
+
+        pprModIfaceSimple,
+        ifaceStats, pprModIface, showIface
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
+                                 tcIfaceFamInst,
+                                 tcIfaceAnnotations, tcIfaceCompleteSigs )
+
+import DynFlags
+import IfaceSyn
+import IfaceEnv
+import HscTypes
+
+import BasicTypes hiding (SuccessFlag(..))
+import TcRnMonad
+
+import Constants
+import PrelNames
+import PrelInfo
+import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )
+import MkId     ( seqId )
+import TysPrim  ( funTyConName )
+import Rules
+import TyCon
+import Annotations
+import InstEnv
+import FamInstEnv
+import Name
+import NameEnv
+import Avail
+import Module
+import Maybes
+import ErrUtils
+import Finder
+import UniqFM
+import SrcLoc
+import Outputable
+import BinIface
+import Panic
+import Util
+import FastString
+import Fingerprint
+import Hooks
+import FieldLabel
+import RnModIface
+import UniqDSet
+import Plugins
+
+import Control.Monad
+import Control.Exception
+import Data.IORef
+import System.FilePath
+
+{-
+************************************************************************
+*                                                                      *
+*      tcImportDecl is the key function for "faulting in"              *
+*      imported things
+*                                                                      *
+************************************************************************
+
+The main idea is this.  We are chugging along type-checking source code, and
+find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
+it in the EPS type envt.  So it
+        1 loads GHC.Base.hi
+        2 gets the decl for GHC.Base.map
+        3 typechecks it via tcIfaceDecl
+        4 and adds it to the type env in the EPS
+
+Note that DURING STEP 4, we may find that map's type mentions a type
+constructor that also
+
+Notice that for imported things we read the current version from the EPS
+mutable variable.  This is important in situations like
+        ...$(e1)...$(e2)...
+where the code that e1 expands to might import some defns that
+also turn out to be needed by the code that e2 expands to.
+-}
+
+tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+tcLookupImported_maybe name
+  = do  { hsc_env <- getTopEnv
+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+        ; case mb_thing of
+            Just thing -> return (Succeeded thing)
+            Nothing    -> tcImportDecl_maybe name }
+
+tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
+-- Entry point for *source-code* uses of importDecl
+tcImportDecl_maybe name
+  | Just thing <- wiredInNameTyThing_maybe name
+  = do  { when (needWiredInHomeIface thing)
+               (initIfaceTcRn (loadWiredInHomeIface name))
+                -- See Note [Loading instances for wired-in things]
+        ; return (Succeeded thing) }
+  | otherwise
+  = initIfaceTcRn (importDecl name)
+
+importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
+-- Get the TyThing for this Name from an interface file
+-- It's not a wired-in thing -- the caller caught that
+importDecl name
+  = ASSERT( not (isWiredInName name) )
+    do  { traceIf nd_doc
+
+        -- Load the interface, which should populate the PTE
+        ; mb_iface <- ASSERT2( isExternalName name, ppr name )
+                      loadInterface nd_doc (nameModule name) ImportBySystem
+        ; case mb_iface of {
+                Failed err_msg  -> return (Failed err_msg) ;
+                Succeeded _ -> do
+
+        -- Now look it up again; this time we should find it
+        { eps <- getEps
+        ; case lookupTypeEnv (eps_PTE eps) name of
+            Just thing -> return $ Succeeded thing
+            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)
+                                    $$ not_found_msg
+                          in return $ Failed doc
+    }}}
+  where
+    nd_doc = text "Need decl for" <+> ppr name
+    not_found_msg = hang (text "Can't find interface-file declaration for" <+>
+                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
+                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",
+                                text "Use -ddump-if-trace to get an idea of which file caused the error"])
+    found_things_msg eps =
+        hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)
+           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))
+      where
+        is_interesting thing = nameModule name == nameModule (getName thing)
+
+
+{-
+************************************************************************
+*                                                                      *
+           Checks for wired-in things
+*                                                                      *
+************************************************************************
+
+Note [Loading instances for wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to make sure that we have at least *read* the interface files
+for any module with an instance decl or RULE that we might want.
+
+* If the instance decl is an orphan, we have a whole separate mechanism
+  (loadOrphanModules)
+
+* If the instance decl is not an orphan, then the act of looking at the
+  TyCon or Class will force in the defining module for the
+  TyCon/Class, and hence the instance decl
+
+* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;
+  but we must make sure we read its interface in case it has instances or
+  rules.  That is what LoadIface.loadWiredInHomeIface does.  It's called
+  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}
+
+* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There
+  are some wired-in Ids, but we don't want to load their interfaces. For
+  example, Control.Exception.Base.recSelError is wired in, but that module
+  is compiled late in the base library, and we don't want to force it to
+  load before it's been compiled!
+
+All of this is done by the type checker. The renamer plays no role.
+(It used to, but no longer.)
+-}
+
+checkWiredInTyCon :: TyCon -> TcM ()
+-- Ensure that the home module of the TyCon (and hence its instances)
+-- are loaded. See Note [Loading instances for wired-in things]
+-- It might not be a wired-in tycon (see the calls in TcUnify),
+-- in which case this is a no-op.
+checkWiredInTyCon tc
+  | not (isWiredInName tc_name)
+  = return ()
+  | otherwise
+  = do  { mod <- getModule
+        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
+        ; ASSERT( isExternalName tc_name )
+          when (mod /= nameModule tc_name)
+               (initIfaceTcRn (loadWiredInHomeIface tc_name))
+                -- Don't look for (non-existent) Float.hi when
+                -- compiling Float.hs, which mentions Float of course
+                -- A bit yukky to call initIfaceTcRn here
+        }
+  where
+    tc_name = tyConName tc
+
+ifCheckWiredInThing :: TyThing -> IfL ()
+-- Even though we are in an interface file, we want to make
+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
+-- Ditto want to ensure that RULES are loaded too
+-- See Note [Loading instances for wired-in things]
+ifCheckWiredInThing thing
+  = do  { mod <- getIfModule
+                -- Check whether we are typechecking the interface for this
+                -- very module.  E.g when compiling the base library in --make mode
+                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
+                -- the HPT, so without the test we'll demand-load it into the PIT!
+                -- C.f. the same test in checkWiredInTyCon above
+        ; let name = getName thing
+        ; ASSERT2( isExternalName name, ppr name )
+          when (needWiredInHomeIface thing && mod /= nameModule name)
+               (loadWiredInHomeIface name) }
+
+needWiredInHomeIface :: TyThing -> Bool
+-- Only for TyCons; see Note [Loading instances for wired-in things]
+needWiredInHomeIface (ATyCon {}) = True
+needWiredInHomeIface _           = False
+
+
+{-
+************************************************************************
+*                                                                      *
+        loadSrcInterface, loadOrphanModules, loadInterfaceForName
+
+                These three are called from TcM-land
+*                                                                      *
+************************************************************************
+-}
+
+-- | Load the interface corresponding to an @import@ directive in
+-- source code.  On a failure, fail in the monad with an error message.
+loadSrcInterface :: SDoc
+                 -> ModuleName
+                 -> IsBootInterface     -- {-# SOURCE #-} ?
+                 -> Maybe FastString    -- "package", if any
+                 -> RnM ModIface
+
+loadSrcInterface doc mod want_boot maybe_pkg
+  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg
+       ; case res of
+           Failed err      -> failWithTc err
+           Succeeded iface -> return iface }
+
+-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.
+loadSrcInterface_maybe :: SDoc
+                       -> ModuleName
+                       -> IsBootInterface     -- {-# SOURCE #-} ?
+                       -> Maybe FastString    -- "package", if any
+                       -> RnM (MaybeErr MsgDoc ModIface)
+
+loadSrcInterface_maybe doc mod want_boot maybe_pkg
+  -- We must first find which Module this import refers to.  This involves
+  -- calling the Finder, which as a side effect will search the filesystem
+  -- and create a ModLocation.  If successful, loadIface will read the
+  -- interface; it will call the Finder again, but the ModLocation will be
+  -- cached from the first search.
+  = do { hsc_env <- getTopEnv
+       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
+       ; case res of
+           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
+           -- TODO: Make sure this error message is good
+           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }
+
+-- | Load interface directly for a fully qualified 'Module'.  (This is a fairly
+-- rare operation, but in particular it is used to load orphan modules
+-- in order to pull their instances into the global package table and to
+-- handle some operations in GHCi).
+loadModuleInterface :: SDoc -> Module -> TcM ModIface
+loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)
+
+-- | Load interfaces for a collection of modules.
+loadModuleInterfaces :: SDoc -> [Module] -> TcM ()
+loadModuleInterfaces doc mods
+  | null mods = return ()
+  | otherwise = initIfaceTcRn (mapM_ load mods)
+  where
+    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod
+
+-- | Loads the interface for a given Name.
+-- Should only be called for an imported name;
+-- otherwise loadSysInterface may not find the interface
+loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
+loadInterfaceForName doc name
+  = do { when debugIsOn $  -- Check pre-condition
+         do { this_mod <- getModule
+            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }
+      ; ASSERT2( isExternalName name, ppr name )
+        initIfaceTcRn $ loadSysInterface doc (nameModule name) }
+
+-- | Only loads the interface for external non-local names.
+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)
+loadInterfaceForNameMaybe doc name
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)
+         then return Nothing
+         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))
+       }
+
+-- | Loads the interface for a given Module.
+loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
+loadInterfaceForModule doc m
+  = do
+    -- Should not be called with this module
+    when debugIsOn $ do
+      this_mod <- getModule
+      MASSERT2( this_mod /= m, ppr m <+> parens doc )
+    initIfaceTcRn $ loadSysInterface doc m
+
+{-
+*********************************************************
+*                                                      *
+                loadInterface
+
+        The main function to load an interface
+        for an imported module, and put it in
+        the External Package State
+*                                                      *
+*********************************************************
+-}
+
+-- | An 'IfM' function to load the home interface for a wired-in thing,
+-- so that we're sure that we see its instance declarations and rules
+-- See Note [Loading instances for wired-in things]
+loadWiredInHomeIface :: Name -> IfM lcl ()
+loadWiredInHomeIface name
+  = ASSERT( isWiredInName name )
+    do _ <- loadSysInterface doc (nameModule name); return ()
+  where
+    doc = text "Need home interface for wired-in thing" <+> ppr name
+
+------------------
+-- | Loads a system interface and throws an exception if it fails
+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem
+
+------------------
+-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
+-- whether we should import the boot variant of the module
+loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface
+loadUserInterface is_boot doc mod_name
+  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)
+
+loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface
+loadPluginInterface doc mod_name
+  = loadInterfaceWithException doc mod_name ImportByPlugin
+
+------------------
+-- | A wrapper for 'loadInterface' that throws an exception if it fails
+loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
+loadInterfaceWithException doc mod_name where_from
+  = withException (loadInterface doc mod_name where_from)
+
+------------------
+loadInterface :: SDoc -> Module -> WhereFrom
+              -> IfM lcl (MaybeErr MsgDoc ModIface)
+
+-- loadInterface looks in both the HPT and PIT for the required interface
+-- If not found, it loads it, and puts it in the PIT (always).
+
+-- If it can't find a suitable interface file, we
+--      a) modify the PackageIfaceTable to have an empty entry
+--              (to avoid repeated complaints)
+--      b) return (Left message)
+--
+-- It's not necessarily an error for there not to be an interface
+-- file -- perhaps the module has changed, and that interface
+-- is no longer used
+
+loadInterface doc_str mod from
+  | isHoleModule mod
+  -- Hole modules get special treatment
+  = do dflags <- getDynFlags
+       -- Redo search for our local hole module
+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
+  | otherwise
+  = do  {       -- Read the state
+          (eps,hpt) <- getEpsAndHpt
+        ; gbl_env <- getGblEnv
+
+        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
+
+                -- Check whether we have the interface already
+        ; dflags <- getDynFlags
+        ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
+            Just iface
+                -> return (Succeeded iface) ;   -- Already loaded
+                        -- The (src_imp == mi_boot iface) test checks that the already-loaded
+                        -- interface isn't a boot iface.  This can conceivably happen,
+                        -- if an earlier import had a before we got to real imports.   I think.
+            _ -> do {
+
+        -- READ THE MODULE IN
+        ; read_result <- case (wantHiBootFile dflags eps mod from) of
+                           Failed err             -> return (Failed err)
+                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod
+        ; case read_result of {
+            Failed err -> do
+                { let fake_iface = emptyModIface mod
+
+                ; updateEps_ $ \eps ->
+                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
+                        -- Not found, so add an empty iface to
+                        -- the EPS map so that we don't look again
+
+                ; return (Failed err) } ;
+
+        -- Found and parsed!
+        -- We used to have a sanity check here that looked for:
+        --  * System importing ..
+        --  * a home package module ..
+        --  * that we know nothing about (mb_dep == Nothing)!
+        --
+        -- But this is no longer valid because thNameToGhcName allows users to
+        -- cause the system to load arbitrary interfaces (by supplying an appropriate
+        -- Template Haskell original-name).
+            Succeeded (iface, loc) ->
+        let
+            loc_doc = text loc
+        in
+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
+
+        dontLeakTheHPT $ do
+
+        --      Load the new ModIface into the External Package State
+        -- Even home-package interfaces loaded by loadInterface
+        --      (which only happens in OneShot mode; in Batch/Interactive
+        --      mode, home-package modules are loaded one by one into the HPT)
+        -- are put in the EPS.
+        --
+        -- The main thing is to add the ModIface to the PIT, but
+        -- we also take the
+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,
+        -- out of the ModIface and put them into the big EPS pools
+
+        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
+        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).
+        --     If we do loadExport first the wrong info gets into the cache (unless we
+        --      explicitly tag each export which seems a bit of a bore)
+
+        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas
+        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
+        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
+        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
+        ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+
+        ; let { final_iface = iface {
+                                mi_decls     = panic "No mi_decls in PIT",
+                                mi_insts     = panic "No mi_insts in PIT",
+                                mi_fam_insts = panic "No mi_fam_insts in PIT",
+                                mi_rules     = panic "No mi_rules in PIT",
+                                mi_anns      = panic "No mi_anns in PIT"
+                              }
+               }
+
+        ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod
+                            -- Warn warn against an EPS-updating import
+                            -- of one's own boot file! (one-shot only)
+                            -- See Note [Loading your own hi-boot file]
+                            -- in MkIface.
+
+        ; WARN( bad_boot, ppr mod )
+          updateEps_  $ \ eps ->
+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface
+                then eps
+           else if bad_boot
+                -- See Note [Loading your own hi-boot file]
+                then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }
+           else
+                eps {
+                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
+                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
+                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)
+                                                        new_eps_rules,
+                  eps_complete_matches
+                                   = extendCompleteMatchMap
+                                         (eps_complete_matches eps)
+                                         new_eps_complete_sigs,
+                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)
+                                                       new_eps_insts,
+                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
+                                                          new_eps_fam_insts,
+                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)
+                                                      new_eps_anns,
+                  eps_mod_fam_inst_env
+                                   = let
+                                       fam_inst_env =
+                                         extendFamInstEnvList emptyFamInstEnv
+                                                              new_eps_fam_insts
+                                     in
+                                     extendModuleEnv (eps_mod_fam_inst_env eps)
+                                                     mod
+                                                     fam_inst_env,
+                  eps_stats        = addEpsInStats (eps_stats eps)
+                                                   (length new_eps_decls)
+                                                   (length new_eps_insts)
+                                                   (length new_eps_rules) }
+
+        ; -- invoke plugins
+          res <- withPlugins dflags interfaceLoadAction final_iface
+        ; return (Succeeded res)
+    }}}}
+
+{- Note [Loading your own hi-boot file]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking, when compiling module M, we should not
+load M.hi boot into the EPS.  After all, we are very shortly
+going to have full information about M.  Moreover, see
+Note [Do not update EPS with your own hi-boot] in MkIface.
+
+But there is a HORRIBLE HACK here.
+
+* At the end of tcRnImports, we call checkFamInstConsistency to
+  check consistency of imported type-family instances
+  See Note [The type family instance consistency story] in FamInst
+
+* Alas, those instances may refer to data types defined in M,
+  if there is a M.hs-boot.
+
+* And that means we end up loading M.hi-boot, because those
+  data types are not yet in the type environment.
+
+But in this wierd case, /all/ we need is the types. We don't need
+instances, rules etc.  And if we put the instances in the EPS
+we get "duplicate instance" warnings when we compile the "real"
+instance in M itself.  Hence the strange business of just updateing
+the eps_PTE.
+
+This really happens in practice.  The module HsExpr.hs gets
+"duplicate instance" errors if this hack is not present.
+
+This is a mess.
+
+
+Note [HPT space leak] (#15111)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In IfL, we defer some work until it is demanded using forkM, such
+as building TyThings from IfaceDecls. These thunks are stored in
+the ExternalPackageState, and they might never be poked.  If we're
+not careful, these thunks will capture the state of the loaded
+program when we read an interface file, and retain all that data
+for ever.
+
+Therefore, when loading a package interface file , we use a "clean"
+version of the HscEnv with all the data about the currently loaded
+program stripped out. Most of the fields can be panics because
+we'll never read them, but hsc_HPT needs to be empty because this
+interface will cause other interfaces to be loaded recursively, and
+when looking up those interfaces we use the HPT in loadInterface.
+We know that none of the interfaces below here can refer to
+home-package modules however, so it's safe for the HPT to be empty.
+-}
+
+dontLeakTheHPT :: IfL a -> IfL a
+dontLeakTheHPT thing_inside = do
+  let
+    cleanTopEnv HscEnv{..} =
+       let
+         -- wrinkle: when we're typechecking in --backpack mode, the
+         -- instantiation of a signature might reside in the HPT, so
+         -- this case breaks the assumption that EPS interfaces only
+         -- refer to other EPS interfaces. We can detect when we're in
+         -- typechecking-only mode by using hscTarget==HscNothing, and
+         -- in that case we don't empty the HPT.  (admittedly this is
+         -- a bit of a hack, better suggestions welcome). A number of
+         -- tests in testsuite/tests/backpack break without this
+         -- tweak.
+         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT
+              | otherwise = emptyHomePackageTable
+       in
+       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"
+              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"
+              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"
+              ,  hsc_HPT          = hpt
+              , .. }
+
+  updTopEnv cleanTopEnv $ do
+  !_ <- getTopEnv        -- force the updTopEnv
+  thing_inside
+
+
+-- | Returns @True@ if a 'ModIface' comes from an external package.
+-- In this case, we should NOT load it into the EPS; the entities
+-- should instead come from the local merged signature interface.
+is_external_sig :: DynFlags -> ModIface -> Bool
+is_external_sig dflags iface =
+    -- It's a signature iface...
+    mi_semantic_module iface /= mi_module iface &&
+    -- and it's not from the local package
+    moduleUnitId (mi_module iface) /= thisPackage dflags
+
+-- | This is an improved version of 'findAndReadIface' which can also
+-- handle the case when a user requests @p[A=<B>]:M@ but we only
+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.
+-- If we are not trying to build code, we load the interface we have,
+-- *instantiating it* according to how the holes are specified.
+-- (Of course, if we're actually building code, this is a hard error.)
+--
+-- In the presence of holes, 'computeInterface' has an important invariant:
+-- to load module M, its set of transitively reachable requirements must
+-- have an up-to-date local hi file for that requirement.  Note that if
+-- we are loading the interface of a requirement, this does not
+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require
+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless
+-- we are actually typechecking p.)
+computeInterface ::
+       SDoc -> IsBootInterface -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+computeInterface doc_str hi_boot_file mod0 = do
+    MASSERT( not (isHoleModule mod0) )
+    dflags <- getDynFlags
+    case splitModuleInsts mod0 of
+        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+            r <- findAndReadIface doc_str imod mod0 hi_boot_file
+            case r of
+                Succeeded (iface0, path) -> do
+                    hsc_env <- getTopEnv
+                    r <- liftIO $
+                        rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))
+                                   Nothing iface0
+                    case r of
+                        Right x -> return (Succeeded (x, path))
+                        Left errs -> liftIO . throwIO . mkSrcErr $ errs
+                Failed err -> return (Failed err)
+        (mod, _) ->
+            findAndReadIface doc_str mod mod0 hi_boot_file
+
+-- | Compute the signatures which must be compiled in order to
+-- load the interface for a 'Module'.  The output of this function
+-- is always a subset of 'moduleFreeHoles'; it is more precise
+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes
+-- are A and B, B might not depend on A at all!
+--
+-- If this is invoked on a signature, this does NOT include the
+-- signature itself; e.g. precise free module holes of
+-- @p[A=<A>,B=<B>]:B@ never includes B.
+moduleFreeHolesPrecise
+    :: SDoc -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))
+moduleFreeHolesPrecise doc_str mod
+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
+ | otherwise =
+   case splitModuleInsts mod of
+    (imod, Just indef) -> do
+        let insts = indefUnitIdInsts (indefModuleUnitId indef)
+        traceIf (text "Considering whether to load" <+> ppr mod <+>
+                 text "to compute precise free module holes")
+        (eps, hpt) <- getEpsAndHpt
+        dflags <- getDynFlags
+        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of
+            Just r -> return (Succeeded r)
+            Nothing -> readAndCache imod insts
+    (_, Nothing) -> return (Succeeded emptyUniqDSet)
+  where
+    tryEpsAndHpt dflags eps hpt =
+        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
+    tryDepsCache eps imod insts =
+        case lookupInstalledModuleEnv (eps_free_holes eps) imod of
+            Just ifhs  -> Just (renameFreeHoles ifhs insts)
+            _otherwise -> Nothing
+    readAndCache imod insts = do
+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False
+        case mb_iface of
+            Succeeded (iface, _) -> do
+                let ifhs = mi_free_holes iface
+                -- Cache it
+                updateEps_ (\eps ->
+                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
+                return (Succeeded (renameFreeHoles ifhs insts))
+            Failed err -> return (Failed err)
+
+wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
+               -> MaybeErr MsgDoc IsBootInterface
+-- Figure out whether we want Foo.hi or Foo.hi-boot
+wantHiBootFile dflags eps mod from
+  = case from of
+       ImportByUser usr_boot
+          | usr_boot && not this_package
+          -> Failed (badSourceImport mod)
+          | otherwise -> Succeeded usr_boot
+
+       ImportByPlugin
+          -> Succeeded False
+
+       ImportBySystem
+          | not this_package   -- If the module to be imported is not from this package
+          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed
+                               -- on the ModuleName of *home-package* modules only.
+                               -- We never import boot modules from other packages!
+
+          | otherwise
+          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of
+                Just (_, is_boot) -> Succeeded is_boot
+                Nothing           -> Succeeded False
+                     -- The boot-ness of the requested interface,
+                     -- based on the dependencies in directly-imported modules
+  where
+    this_package = thisPackage dflags == moduleUnitId mod
+
+badSourceImport :: Module -> SDoc
+badSourceImport mod
+  = hang (text "You cannot {-# SOURCE #-} import a module from another package")
+       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")
+          <+> quotes (ppr (moduleUnitId mod)))
+
+-----------------------------------------------------
+--      Loading type/class/value decls
+-- We pass the full Module name here, replete with
+-- its package info, so that we can build a Name for
+-- each binder with the right package info in it
+-- All subsequent lookups, including crucially lookups during typechecking
+-- the declaration itself, will find the fully-glorious Name
+--
+-- We handle ATs specially.  They are not main declarations, but also not
+-- implicit things (in particular, adding them to `implicitTyThings' would mess
+-- things up in the renaming/type checking of source programs).
+-----------------------------------------------------
+
+addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
+addDeclsToPTE pte things = extendNameEnvList pte things
+
+loadDecls :: Bool
+          -> [(Fingerprint, IfaceDecl)]
+          -> IfL [(Name,TyThing)]
+loadDecls ignore_prags ver_decls
+   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls
+        ; return (concat thingss)
+        }
+
+loadDecl :: Bool                    -- Don't load pragmas into the decl pool
+          -> (Fingerprint, IfaceDecl)
+          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
+                                    -- TyThings are forkM'd thunks
+loadDecl ignore_prags (_version, decl)
+  = do  {       -- Populate the name cache with final versions of all
+                -- the names associated with the decl
+          let main_name = ifName decl
+
+        -- Typecheck the thing, lazily
+        -- NB. Firstly, the laziness is there in case we never need the
+        -- declaration (in one-shot mode), and secondly it is there so that
+        -- we don't look up the occurrence of a name before calling mk_new_bndr
+        -- on the binder.  This is important because we must get the right name
+        -- which includes its nameParent.
+
+        ; thing <- forkM doc $ do { bumpDeclStats main_name
+                                  ; tcIfaceDecl ignore_prags decl }
+
+        -- Populate the type environment with the implicitTyThings too.
+        --
+        -- Note [Tricky iface loop]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~
+        -- Summary: The delicate point here is that 'mini-env' must be
+        -- buildable from 'thing' without demanding any of the things
+        -- 'forkM'd by tcIfaceDecl.
+        --
+        -- In more detail: Consider the example
+        --      data T a = MkT { x :: T a }
+        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]
+        -- (plus their workers, wrappers, coercions etc etc)
+        --
+        -- We want to return an environment
+        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
+        -- (where the "MkT" is the *Name* associated with MkT, etc.)
+        --
+        -- We do this by mapping the implicit_names to the associated
+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and
+        -- implicitTyThings, we can use getOccName on the implicit
+        -- TyThings to make this association: each Name's OccName should
+        -- be the OccName of exactly one implicitTyThing.  So the key is
+        -- to define a "mini-env"
+        --
+        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]
+        -- where the 'MkT' here is the *OccName* associated with MkT.
+        --
+        -- However, there is a subtlety: due to how type checking needs
+        -- to be staged, we can't poke on the forkM'd thunks inside the
+        -- implicitTyThings while building this mini-env.
+        -- If we poke these thunks too early, two problems could happen:
+        --    (1) When processing mutually recursive modules across
+        --        hs-boot boundaries, poking too early will do the
+        --        type-checking before the recursive knot has been tied,
+        --        so things will be type-checked in the wrong
+        --        environment, and necessary variables won't be in
+        --        scope.
+        --
+        --    (2) Looking up one OccName in the mini_env will cause
+        --        others to be looked up, which might cause that
+        --        original one to be looked up again, and hence loop.
+        --
+        -- The code below works because of the following invariant:
+        -- getOccName on a TyThing does not force the suspended type
+        -- checks in order to extract the name. For example, we don't
+        -- poke on the "T a" type of <selector x> on the way to
+        -- extracting <selector x>'s OccName. Of course, there is no
+        -- reason in principle why getting the OccName should force the
+        -- thunks, but this means we need to be careful in
+        -- implicitTyThings and its helper functions.
+        --
+        -- All a bit too finely-balanced for my liking.
+
+        -- This mini-env and lookup function mediates between the
+        --'Name's n and the map from 'OccName's to the implicit TyThings
+        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
+              lookup n = case lookupOccEnv mini_env (getOccName n) of
+                           Just thing -> thing
+                           Nothing    ->
+                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
+
+        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)
+
+--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)
+        ; return $ (main_name, thing) :
+                      -- uses the invariant that implicit_names and
+                      -- implicitTyThings are bijective
+                      [(n, lookup n) | n <- implicit_names]
+        }
+  where
+    doc = text "Declaration for" <+> ppr (ifName decl)
+
+bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used
+bumpDeclStats name
+  = do  { traceIf (text "Loading decl for" <+> ppr name)
+        ; updateEps_ (\eps -> let stats = eps_stats eps
+                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+        }
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Reading an interface file}
+*                                                      *
+*********************************************************
+
+Note [Home module load error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the sought-for interface is in the current package (as determined
+by -package-name flag) then it jolly well should already be in the HPT
+because we process home-package modules in dependency order.  (Except
+in one-shot mode; see notes with hsc_HPT decl in HscTypes).
+
+It is possible (though hard) to get this error through user behaviour.
+  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,
+    Q2, with Q2 importing Q1)
+  * We compile both packages.
+  * Now we edit package Q so that it somehow depends on P
+  * Now recompile Q with --make (without recompiling P).
+  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2
+    is a home-package module which is not yet in the HPT!  Disaster.
+
+This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
+See #8320.
+-}
+
+findAndReadIface :: SDoc
+                 -- The unique identifier of the on-disk module we're
+                 -- looking for
+                 -> InstalledModule
+                 -- The *actual* module we're looking for.  We use
+                 -- this to check the consistency of the requirements
+                 -- of the module we read out.
+                 -> Module
+                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file
+                                        -- False <=> Look for .hi file
+                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+        -- Nothing <=> file not found, or unreadable, or illegible
+        -- Just x  <=> successfully found and parsed
+
+        -- It *doesn't* add an error to the monad, because
+        -- sometimes it's ok to fail... see notes with loadInterface
+findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
+  = do traceIf (sep [hsep [text "Reading",
+                           if hi_boot_file
+                             then text "[boot]"
+                             else Outputable.empty,
+                           text "interface for",
+                           ppr mod <> semi],
+                     nest 4 (text "reason:" <+> doc_str)])
+
+       -- Check for GHC.Prim, and return its static interface
+       -- TODO: make this check a function
+       if mod `installedModuleEq` gHC_PRIM
+           then do
+               iface <- getHooked ghcPrimIfaceHook ghcPrimIface
+               return (Succeeded (iface,
+                                   "<built in interface for GHC.Prim>"))
+           else do
+               dflags <- getDynFlags
+               -- Look for the file
+               hsc_env <- getTopEnv
+               mb_found <- liftIO (findExactModule hsc_env mod)
+               case mb_found of
+                   InstalledFound loc mod -> do
+                       -- Found file, so read it
+                       let file_path = addBootSuffix_maybe hi_boot_file
+                                                           (ml_hi_file loc)
+
+                       -- See Note [Home module load error]
+                       if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&
+                          not (isOneShot (ghcMode dflags))
+                           then return (Failed (homeModError mod loc))
+                           else do r <- read_file file_path
+                                   checkBuildDynamicToo r
+                                   return r
+                   err -> do
+                       traceIf (text "...not found")
+                       dflags <- getDynFlags
+                       return (Failed (cannotFindInterface dflags
+                                           (installedModuleName mod) err))
+    where read_file file_path = do
+              traceIf (text "readIFace" <+> text file_path)
+              -- Figure out what is recorded in mi_module.  If this is
+              -- a fully definite interface, it'll match exactly, but
+              -- if it's indefinite, the inside will be uninstantiated!
+              dflags <- getDynFlags
+              let wanted_mod =
+                    case splitModuleInsts wanted_mod_with_insts of
+                        (_, Nothing) -> wanted_mod_with_insts
+                        (_, Just indef_mod) ->
+                          indefModuleToModule dflags
+                            (generalizeIndefModule indef_mod)
+              read_result <- readIface wanted_mod file_path
+              case read_result of
+                Failed err -> return (Failed (badIfaceFile file_path err))
+                Succeeded iface -> return (Succeeded (iface, file_path))
+                            -- Don't forget to fill in the package name...
+          checkBuildDynamicToo (Succeeded (iface, filePath)) = do
+              dflags <- getDynFlags
+              -- Indefinite interfaces are ALWAYS non-dynamic, and
+              -- that's OK.
+              let is_definite_iface = moduleIsDefinite (mi_module iface)
+              when is_definite_iface $
+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
+                  let ref = canGenerateDynamicToo dflags
+                      dynFilePath = addBootSuffix_maybe hi_boot_file
+                                  $ replaceExtension filePath (dynHiSuf dflags)
+                  r <- read_file dynFilePath
+                  case r of
+                      Succeeded (dynIface, _)
+                       | mi_mod_hash iface == mi_mod_hash dynIface ->
+                          return ()
+                       | otherwise ->
+                          do traceIf (text "Dynamic hash doesn't match")
+                             liftIO $ writeIORef ref False
+                      Failed err ->
+                          do traceIf (text "Failed to load dynamic interface file:" $$ err)
+                             liftIO $ writeIORef ref False
+          checkBuildDynamicToo _ = return ()
+
+-- @readIface@ tries just the one file.
+
+readIface :: Module -> FilePath
+          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
+        -- Failed err    <=> file not found, or unreadable, or illegible
+        -- Succeeded iface <=> successfully found and parsed
+
+readIface wanted_mod file_path
+  = do  { res <- tryMostM $
+                 readBinIface CheckHiWay QuietBinIFaceReading file_path
+        ; dflags <- getDynFlags
+        ; case res of
+            Right iface
+                -- NB: This check is NOT just a sanity check, it is
+                -- critical for correctness of recompilation checking
+                -- (it lets us tell when -this-unit-id has changed.)
+                | wanted_mod == actual_mod
+                                -> return (Succeeded iface)
+                | otherwise     -> return (Failed err)
+                where
+                  actual_mod = mi_module iface
+                  err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod
+
+            Left exn    -> return (Failed (text (showException exn)))
+    }
+
+{-
+*********************************************************
+*                                                       *
+        Wired-in interface for GHC.Prim
+*                                                       *
+*********************************************************
+-}
+
+initExternalPackageState :: ExternalPackageState
+initExternalPackageState
+  = EPS {
+      eps_is_boot          = emptyUFM,
+      eps_PIT              = emptyPackageIfaceTable,
+      eps_free_holes       = emptyInstalledModuleEnv,
+      eps_PTE              = emptyTypeEnv,
+      eps_inst_env         = emptyInstEnv,
+      eps_fam_inst_env     = emptyFamInstEnv,
+      eps_rule_base        = mkRuleBase builtinRules,
+        -- Initialise the EPS rule pool with the built-in rules
+      eps_mod_fam_inst_env
+                           = emptyModuleEnv,
+      eps_complete_matches = emptyUFM,
+      eps_ann_env          = emptyAnnEnv,
+      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
+                           , n_insts_in = 0, n_insts_out = 0
+                           , n_rules_in = length builtinRules, n_rules_out = 0 }
+    }
+
+{-
+*********************************************************
+*                                                       *
+        Wired-in interface for GHC.Prim
+*                                                       *
+*********************************************************
+-}
+
+ghcPrimIface :: ModIface
+ghcPrimIface
+  = (emptyModIface gHC_PRIM) {
+        mi_exports  = ghcPrimExports,
+        mi_decls    = [],
+        mi_fixities = fixities,
+        mi_fix_fn  = mkIfaceFixCache fixities
+    }
+  where
+    -- The fixities listed here for @`seq`@ or @->@ should match
+    -- those in primops.txt.pp (from which Haddock docs are generated).
+    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
+             : (occName funTyConName, funTyFixity)  -- trac #10145
+             : mapMaybe mkFixity allThePrimOps
+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Statistics}
+*                                                      *
+*********************************************************
+-}
+
+ifaceStats :: ExternalPackageState -> SDoc
+ifaceStats eps
+  = hcat [text "Renamer stats: ", msg]
+  where
+    stats = eps_stats eps
+    msg = vcat
+        [int (n_ifaces_in stats) <+> text "interfaces read",
+         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+                int (n_decls_in stats), text "read"],
+         hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+                int (n_insts_in stats), text "read"],
+         hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+                int (n_rules_in stats), text "read"]
+        ]
+
+{-
+************************************************************************
+*                                                                      *
+                Printing interfaces
+*                                                                      *
+************************************************************************
+
+Note [Name qualification with --show-iface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In order to disambiguate between identifiers from different modules, we qualify
+all names that don't originate in the current module. In order to keep visual
+noise as low as possible, we keep local names unqualified.
+
+For some background on this choice see trac #15269.
+-}
+
+-- | Read binary interface, and print it out
+showIface :: HscEnv -> FilePath -> IO ()
+showIface hsc_env filename = do
+   -- skip the hi way check; we don't want to worry about profiled vs.
+   -- non-profiled interfaces, for example.
+   iface <- initTcRnIf 's' hsc_env () () $
+       readBinIface IgnoreHiWay TraceBinIFaceReading filename
+   let dflags = hsc_dflags hsc_env
+       -- See Note [Name qualification with --show-iface]
+       qualifyImportedNames mod _
+           | mod == mi_module iface = NameUnqual
+           | otherwise              = NameNotInScope1
+       print_unqual = QueryQualify qualifyImportedNames
+                                   neverQualifyModules
+                                   neverQualifyPackages
+   putLogMsg dflags NoReason SevDump noSrcSpan
+      (mkDumpStyle dflags print_unqual) (pprModIface iface)
+
+-- Show a ModIface but don't display details; suitable for ModIfaces stored in
+-- the EPT.
+pprModIfaceSimple :: ModIface -> SDoc
+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))
+
+pprModIface :: ModIface -> SDoc
+-- Show a ModIface
+pprModIface iface
+ = vcat [ text "interface"
+                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
+                <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)
+                <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)
+                <+> (if mi_hpc    iface then text "[hpc]" else Outputable.empty)
+                <+> integer hiVersion
+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
+        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))
+        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))
+        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))
+        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
+        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
+        , nest 2 (text "where")
+        , text "exports:"
+        , nest 2 (vcat (map pprExport (mi_exports iface)))
+        , pprDeps (mi_deps iface)
+        , vcat (map pprUsage (mi_usages iface))
+        , vcat (map pprIfaceAnnotation (mi_anns iface))
+        , pprFixities (mi_fixities iface)
+        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]
+        , vcat (map ppr (mi_insts iface))
+        , vcat (map ppr (mi_fam_insts iface))
+        , vcat (map ppr (mi_rules iface))
+        , ppr (mi_warns iface)
+        , pprTrustInfo (mi_trust iface)
+        , pprTrustPkg (mi_trust_pkg iface)
+        , vcat (map ppr (mi_complete_sigs iface))
+        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
+        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
+        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
+        ]
+  where
+    pp_hsc_src HsBootFile = text "[boot]"
+    pp_hsc_src HsigFile = text "[hsig]"
+    pp_hsc_src HsSrcFile = Outputable.empty
+
+{-
+When printing export lists, we print like this:
+        Avail   f               f
+        AvailTC C [C, x, y]     C(x,y)
+        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
+-}
+
+pprExport :: IfaceExport -> SDoc
+pprExport (Avail n)         = ppr n
+pprExport (AvailTC _ [] []) = Outputable.empty
+pprExport (AvailTC n ns0 fs)
+  = case ns0 of
+      (n':ns) | n==n' -> ppr n <> pp_export ns fs
+      _               -> ppr n <> vbar <> pp_export ns0 fs
+  where
+    pp_export []    [] = Outputable.empty
+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
+
+pprUsage :: Usage -> SDoc
+pprUsage usage@UsagePackageModule{}
+  = pprUsageImport usage usg_mod
+pprUsage usage@UsageHomeModule{}
+  = pprUsageImport usage usg_mod_name $$
+    nest 2 (
+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
+        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
+        )
+pprUsage usage@UsageFile{}
+  = hsep [text "addDependentFile",
+          doubleQuotes (text (usg_file_path usage)),
+          ppr (usg_file_hash usage)]
+pprUsage usage@UsageMergedRequirement{}
+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
+
+pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
+pprUsageImport usage usg_mod'
+  = hsep [text "import", safe, ppr (usg_mod' usage),
+                       ppr (usg_mod_hash usage)]
+    where
+        safe | usg_safe usage = text "safe"
+             | otherwise      = text " -/ "
+
+pprDeps :: Dependencies -> SDoc
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
+                dep_finsts = finsts })
+  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),
+          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),
+          text "orphans:" <+> fsep (map ppr orphs),
+          text "family instance modules:" <+> fsep (map ppr finsts)
+        ]
+  where
+    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
+    ppr_pkg (pkg,trust_req)  = ppr pkg <>
+                               (if trust_req then text "*" else Outputable.empty)
+    ppr_boot True  = text "[boot]"
+    ppr_boot False = Outputable.empty
+
+pprFixities :: [(OccName, Fixity)] -> SDoc
+pprFixities []    = Outputable.empty
+pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
+                  where
+                    pprFix (occ,fix) = ppr fix <+> ppr occ
+
+pprTrustInfo :: IfaceTrustInfo -> SDoc
+pprTrustInfo trust = text "trusted:" <+> ppr trust
+
+pprTrustPkg :: Bool -> SDoc
+pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
+
+instance Outputable Warnings where
+    ppr = pprWarns
+
+pprWarns :: Warnings -> SDoc
+pprWarns NoWarnings         = Outputable.empty
+pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt
+pprWarns (WarnSome prs) = text "Warnings"
+                        <+> vcat (map pprWarning prs)
+    where pprWarning (name, txt) = ppr name <+> ppr txt
+
+pprIfaceAnnotation :: IfaceAnnotation -> SDoc
+pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
+  = ppr target <+> text "annotated by" <+> ppr serialized
+
+{-
+*********************************************************
+*                                                       *
+\subsection{Errors}
+*                                                       *
+*********************************************************
+-}
+
+badIfaceFile :: String -> SDoc -> SDoc
+badIfaceFile file err
+  = vcat [text "Bad interface file:" <+> text file,
+          nest 4 err]
+
+hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc
+hiModuleNameMismatchWarn dflags requested_mod read_mod
+ | moduleUnitId requested_mod == moduleUnitId read_mod =
+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
+         text "but we were expecting module" <+> quotes (ppr requested_mod),
+         sep [text "Probable cause: the source code which generated interface file",
+             text "has an incompatible module name"
+            ]
+        ]
+ | otherwise =
+  -- ToDo: This will fail to have enough qualification when the package IDs
+  -- are the same
+  withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $
+    -- we want the Modules below to be qualified with package names,
+    -- so reset the PrintUnqualified setting.
+    hsep [ text "Something is amiss; requested module "
+         , ppr requested_mod
+         , text "differs from name found in the interface file"
+         , ppr read_mod
+         , parens (text "if these names look the same, try again with -dppr-debug")
+         ]
+
+homeModError :: InstalledModule -> ModLocation -> SDoc
+-- See Note [Home module load error]
+homeModError mod location
+  = text "attempting to use module " <> quotes (ppr mod)
+    <> (case ml_hs_file location of
+           Just file -> space <> parens (text file)
+           Nothing   -> Outputable.empty)
+    <+> text "which is not loaded"
diff --git a/compiler/iface/LoadIface.hs-boot b/compiler/iface/LoadIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/iface/LoadIface.hs-boot
@@ -0,0 +1,7 @@
+module LoadIface where
+import Module (Module)
+import TcRnMonad (IfM)
+import HscTypes (ModIface)
+import Outputable (SDoc)
+
+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/MkIface.hs
@@ -0,0 +1,2034 @@
+{-
+(c) The University of Glasgow 2006-2008
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+-}
+
+{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE MultiWayIf #-}
+
+-- | Module for constructing @ModIface@ values (interface files),
+-- writing them to disk and comparing two versions to see if
+-- recompilation is required.
+module MkIface (
+        mkIface,        -- Build a ModIface from a ModGuts,
+                        -- including computing version information
+
+        mkIfaceTc,
+
+        writeIfaceFile, -- Write the interface file
+
+        checkOldIface,  -- See if recompilation is required, by
+                        -- comparing version information
+        RecompileRequired(..), recompileRequired,
+        mkIfaceExports,
+
+        coAxiomToIfaceDecl,
+        tyThingToIfaceDecl -- Converting things to their Iface equivalents
+ ) where
+
+{-
+  -----------------------------------------------
+          Recompilation checking
+  -----------------------------------------------
+
+A complete description of how recompilation checking works can be
+found in the wiki commentary:
+
+ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
+
+Please read the above page for a top-down description of how this all
+works.  Notes below cover specific issues related to the implementation.
+
+Basic idea:
+
+  * In the mi_usages information in an interface, we record the
+    fingerprint of each free variable of the module
+
+  * In mkIface, we compute the fingerprint of each exported thing A.f.
+    For each external thing that A.f refers to, we include the fingerprint
+    of the external reference when computing the fingerprint of A.f.  So
+    if anything that A.f depends on changes, then A.f's fingerprint will
+    change.
+    Also record any dependent files added with
+      * addDependentFile
+      * #include
+      * -optP-include
+
+  * In checkOldIface we compare the mi_usages for the module with
+    the actual fingerprint for all each thing recorded in mi_usages
+-}
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import IfaceSyn
+import BinFingerprint
+import LoadIface
+import ToIface
+import FlagChecker
+
+import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
+import Id
+import Annotations
+import CoreSyn
+import Class
+import TyCon
+import CoAxiom
+import ConLike
+import DataCon
+import Type
+import TcType
+import InstEnv
+import FamInstEnv
+import TcRnMonad
+import HsSyn
+import HscTypes
+import Finder
+import DynFlags
+import VarEnv
+import Var
+import Name
+import Avail
+import RdrName
+import NameEnv
+import NameSet
+import Module
+import BinIface
+import ErrUtils
+import Digraph
+import SrcLoc
+import Outputable
+import BasicTypes       hiding ( SuccessFlag(..) )
+import Unique
+import Util             hiding ( eqListBy )
+import FastString
+import Maybes
+import Binary
+import Fingerprint
+import Exception
+import UniqSet
+import Packages
+import ExtractDocs
+
+import Control.Monad
+import Data.Function
+import Data.List
+import qualified Data.Map as Map
+import Data.Ord
+import Data.IORef
+import System.Directory
+import System.FilePath
+import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),
+                 pluginRecompile', plugins )
+
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Completing an interface}
+*                                                                      *
+************************************************************************
+-}
+
+mkIface :: HscEnv
+        -> Maybe Fingerprint    -- The old fingerprint, if we have it
+        -> ModDetails           -- The trimmed, tidied interface
+        -> ModGuts              -- Usages, deprecations, etc
+        -> IO (ModIface, -- The new one
+               Bool)     -- True <=> there was an old Iface, and the
+                         --          new one is identical, so no need
+                         --          to write it
+
+mkIface hsc_env maybe_old_fingerprint mod_details
+         ModGuts{     mg_module       = this_mod,
+                      mg_hsc_src      = hsc_src,
+                      mg_usages       = usages,
+                      mg_used_th      = used_th,
+                      mg_deps         = deps,
+                      mg_rdr_env      = rdr_env,
+                      mg_fix_env      = fix_env,
+                      mg_warns        = warns,
+                      mg_hpc_info     = hpc_info,
+                      mg_safe_haskell = safe_mode,
+                      mg_trust_pkg    = self_trust,
+                      mg_doc_hdr      = doc_hdr,
+                      mg_decl_docs    = decl_docs,
+                      mg_arg_docs     = arg_docs
+                    }
+        = mkIface_ hsc_env maybe_old_fingerprint
+                   this_mod hsc_src used_th deps rdr_env fix_env
+                   warns hpc_info self_trust
+                   safe_mode usages
+                   doc_hdr decl_docs arg_docs
+                   mod_details
+
+-- | make an interface from the results of typechecking only.  Useful
+-- for non-optimising compilation, or where we aren't generating any
+-- object code at all ('HscNothing').
+mkIfaceTc :: HscEnv
+          -> Maybe Fingerprint  -- The old fingerprint, if we have it
+          -> SafeHaskellMode    -- The safe haskell mode
+          -> ModDetails         -- gotten from mkBootModDetails, probably
+          -> TcGblEnv           -- Usages, deprecations, etc
+          -> IO (ModIface, Bool)
+mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
+  tc_result@TcGblEnv{ tcg_mod = this_mod,
+                      tcg_src = hsc_src,
+                      tcg_imports = imports,
+                      tcg_rdr_env = rdr_env,
+                      tcg_fix_env = fix_env,
+                      tcg_merged = merged,
+                      tcg_warns = warns,
+                      tcg_hpc = other_hpc_info,
+                      tcg_th_splice_used = tc_splice_used,
+                      tcg_dependent_files = dependent_files
+                    }
+  = do
+          let used_names = mkUsedNames tc_result
+          let pluginModules =
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
+          deps <- mkDependencies
+                    (thisInstalledUnitId (hsc_dflags hsc_env))
+                    (map mi_module pluginModules) tc_result
+          let hpc_info = emptyHpcInfo other_hpc_info
+          used_th <- readIORef tc_splice_used
+          dep_files <- (readIORef dependent_files)
+          -- Do NOT use semantic module here; this_mod in mkUsageInfo
+          -- is used solely to decide if we should record a dependency
+          -- or not.  When we instantiate a signature, the semantic
+          -- module is something we want to record dependencies for,
+          -- but if you pass that in here, we'll decide it's the local
+          -- module and does not need to be recorded as a dependency.
+          -- See Note [Identity versus semantic module]
+          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
+                      dep_files merged pluginModules
+
+          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+
+          mkIface_ hsc_env maybe_old_fingerprint
+                   this_mod hsc_src
+                   used_th deps rdr_env
+                   fix_env warns hpc_info
+                   (imp_trust_own_pkg imports) safe_mode usages
+                   doc_hdr' doc_map arg_map
+                   mod_details
+
+
+
+mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
+         -> Bool -> Dependencies -> GlobalRdrEnv
+         -> NameEnv FixItem -> Warnings -> HpcInfo
+         -> Bool
+         -> SafeHaskellMode
+         -> [Usage]
+         -> Maybe HsDocString
+         -> DeclDocMap
+         -> ArgDocMap
+         -> ModDetails
+         -> IO (ModIface, Bool)
+mkIface_ hsc_env maybe_old_fingerprint
+         this_mod hsc_src used_th deps rdr_env fix_env src_warns
+         hpc_info pkg_trust_req safe_mode usages
+         doc_hdr decl_docs arg_docs
+         ModDetails{  md_insts     = insts,
+                      md_fam_insts = fam_insts,
+                      md_rules     = rules,
+                      md_anns      = anns,
+                      md_types     = type_env,
+                      md_exports   = exports,
+                      md_complete_sigs = complete_sigs }
+-- NB:  notice that mkIface does not look at the bindings
+--      only at the TypeEnv.  The previous Tidy phase has
+--      put exactly the info into the TypeEnv that we want
+--      to expose in the interface
+
+  = do
+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
+        entities = typeEnvElts type_env
+        decls  = [ tyThingToIfaceDecl entity
+                 | entity <- entities,
+                   let name = getName entity,
+                   not (isImplicitTyThing entity),
+                      -- No implicit Ids and class tycons in the interface file
+                   not (isWiredInName name),
+                      -- Nor wired-in things; the compiler knows about them anyhow
+                   nameIsLocalOrFrom semantic_mod name  ]
+                      -- Sigh: see Note [Root-main Id] in TcRnDriver
+                      -- NB: ABSOLUTELY need to check against semantic_mod,
+                      -- because all of the names in an hsig p[H=<H>]:H
+                      -- are going to be for <H>, not the former id!
+                      -- See Note [Identity versus semantic module]
+
+        fixities    = sortBy (comparing fst)
+          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+          -- The order of fixities returned from nameEnvElts is not
+          -- deterministic, so we sort by OccName to canonicalize it.
+          -- See Note [Deterministic UniqFM] in UniqDFM for more details.
+        warns       = src_warns
+        iface_rules = map coreRuleToIfaceRule rules
+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
+        iface_fam_insts = map famInstToIfaceFamInst fam_insts
+        trust_info  = setSafeMode safe_mode
+        annotations = map mkIfaceAnnotation anns
+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs
+
+        intermediate_iface = ModIface {
+              mi_module      = this_mod,
+              -- Need to record this because it depends on the -instantiated-with flag
+              -- which could change
+              mi_sig_of      = if semantic_mod == this_mod
+                                then Nothing
+                                else Just semantic_mod,
+              mi_hsc_src     = hsc_src,
+              mi_deps        = deps,
+              mi_usages      = usages,
+              mi_exports     = mkIfaceExports exports,
+
+              -- Sort these lexicographically, so that
+              -- the result is stable across compilations
+              mi_insts       = sortBy cmp_inst     iface_insts,
+              mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,
+              mi_rules       = sortBy cmp_rule     iface_rules,
+
+              mi_fixities    = fixities,
+              mi_warns       = warns,
+              mi_anns        = annotations,
+              mi_globals     = maybeGlobalRdrEnv rdr_env,
+
+              -- Left out deliberately: filled in by addFingerprints
+              mi_iface_hash  = fingerprint0,
+              mi_mod_hash    = fingerprint0,
+              mi_flag_hash   = fingerprint0,
+              mi_opt_hash    = fingerprint0,
+              mi_hpc_hash    = fingerprint0,
+              mi_exp_hash    = fingerprint0,
+              mi_plugin_hash = fingerprint0,
+              mi_used_th     = used_th,
+              mi_orphan_hash = fingerprint0,
+              mi_orphan      = False, -- Always set by addFingerprints, but
+                                      -- it's a strict field, so we can't omit it.
+              mi_finsts      = False, -- Ditto
+              mi_decls       = deliberatelyOmitted "decls",
+              mi_hash_fn     = deliberatelyOmitted "hash_fn",
+              mi_hpc         = isHpcUsed hpc_info,
+              mi_trust       = trust_info,
+              mi_trust_pkg   = pkg_trust_req,
+
+              -- And build the cached values
+              mi_warn_fn     = mkIfaceWarnCache warns,
+              mi_fix_fn      = mkIfaceFixCache fixities,
+              mi_complete_sigs = icomplete_sigs,
+              mi_doc_hdr     = doc_hdr,
+              mi_decl_docs   = decl_docs,
+              mi_arg_docs    = arg_docs }
+
+    (new_iface, no_change_at_all)
+          <- {-# SCC "versioninfo" #-}
+                   addFingerprints hsc_env maybe_old_fingerprint
+                                   intermediate_iface decls
+
+    -- Debug printing
+    dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+                  (pprModIface new_iface)
+
+    -- bug #1617: on reload we weren't updating the PrintUnqualified
+    -- correctly.  This stems from the fact that the interface had
+    -- not changed, so addFingerprints returns the old ModIface
+    -- with the old GlobalRdrEnv (mi_globals).
+    let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
+
+    return (final_iface, no_change_at_all)
+  where
+     cmp_rule     = comparing ifRuleName
+     -- Compare these lexicographically by OccName, *not* by unique,
+     -- because the latter is not stable across compilations:
+     cmp_inst     = comparing (nameOccName . ifDFun)
+     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
+
+     dflags = hsc_dflags hsc_env
+
+     -- We only fill in mi_globals if the module was compiled to byte
+     -- code.  Otherwise, the compiler may not have retained all the
+     -- top-level bindings and they won't be in the TypeEnv (see
+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
+     -- by GHCi to decide whether the module has its full top-level
+     -- scope available. (#5534)
+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
+     maybeGlobalRdrEnv rdr_env
+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
+         | otherwise                                   = Nothing
+
+     deliberatelyOmitted :: String -> a
+     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
+     ifFamInstTcName = ifFamInstFam
+
+-----------------------------
+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
+writeIfaceFile dflags hi_file_path new_iface
+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)
+         writeBinIface dflags hi_file_path new_iface
+
+
+-- -----------------------------------------------------------------------------
+-- Look up parents and versions of Names
+
+-- This is like a global version of the mi_hash_fn field in each ModIface.
+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
+-- the parent and version info.
+
+mkHashFun
+        :: HscEnv                       -- needed to look up versions
+        -> ExternalPackageState         -- ditto
+        -> (Name -> IO Fingerprint)
+mkHashFun hsc_env eps name
+  | isHoleModule orig_mod
+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
+  | otherwise
+  = lookup orig_mod
+  where
+      dflags = hsc_dflags hsc_env
+      hpt = hsc_HPT hsc_env
+      pit = eps_PIT eps
+      occ = nameOccName name
+      orig_mod = nameModule name
+      lookup mod = do
+        MASSERT2( isExternalName name, ppr name )
+        iface <- case lookupIfaceByModule dflags hpt pit mod of
+                  Just iface -> return iface
+                  Nothing -> do
+                      -- This can occur when we're writing out ifaces for
+                      -- requirements; we didn't do any /real/ typechecking
+                      -- so there's no guarantee everything is loaded.
+                      -- Kind of a heinous hack.
+                      iface <- initIfaceLoad hsc_env . withException
+                            $ loadInterface (text "lookupVers2") mod ImportBySystem
+                      return iface
+        return $ snd (mi_hash_fn iface occ `orElse`
+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
+
+-- ---------------------------------------------------------------------------
+-- Compute fingerprints for the interface
+
+{-
+Note [Fingerprinting IfaceDecls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The general idea here is that we first examine the 'IfaceDecl's and determine
+the recursive groups of them. We then walk these groups in dependency order,
+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
+hash using MD5 to produce a fingerprint for the group.
+
+However, the serialization that we use is a bit funny: we override the @putName@
+operation with our own which serializes the hash of a 'Name' instead of the
+'Name' itself. This ensures that the fingerprint of a decl changes if anything
+in its transitive closure changes. This trick is why we must be careful about
+traversing in dependency order: we need to ensure that we have hashes for
+everything referenced by the decl which we are fingerprinting.
+
+Moreover, we need to be careful to distinguish between serialization of binding
+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
+field of a IfaceClsInst): only in the non-binding case should we include the
+fingerprint; in the binding case we shouldn't since it is merely the name of the
+thing that we are currently fingerprinting.
+-}
+
+-- | Add fingerprints for top-level declarations to a 'ModIface'.
+--
+-- See Note [Fingerprinting IfaceDecls]
+addFingerprints
+        :: HscEnv
+        -> Maybe Fingerprint -- the old fingerprint, if any
+        -> ModIface          -- The new interface (lacking decls)
+        -> [IfaceDecl]       -- The new decls
+        -> IO (ModIface,     -- Updated interface
+               Bool)         -- True <=> no changes at all;
+                             -- no need to write Iface
+
+addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
+ = do
+   eps <- hscEPS hsc_env
+   let
+        -- The ABI of a declaration represents everything that is made
+        -- visible about the declaration that a client can depend on.
+        -- see IfaceDeclABI below.
+       declABI :: IfaceDecl -> IfaceDeclABI
+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.
+       -- See also Note [Identity versus semantic module]
+       declABI decl = (this_mod, decl, extras)
+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
+                                  non_orph_fis top_lvl_name_env decl
+
+       -- This is used for looking up the Name of a default method
+       -- from its OccName. See Note [default method Name]
+       top_lvl_name_env =
+         mkOccEnv [ (nameOccName nm, nm)
+                  | IfaceId { ifName = nm } <- new_decls ]
+
+       -- Dependency edges between declarations in the current module.
+       -- This is computed by finding the free external names of each
+       -- declaration, including IfaceDeclExtras (things that a
+       -- declaration implicitly depends on).
+       edges :: [ Node Unique IfaceDeclABI ]
+       edges = [ DigraphNode abi (getUnique (getOccName decl)) out
+               | decl <- new_decls
+               , let abi = declABI decl
+               , let out = localOccs $ freeNamesDeclABI abi
+               ]
+
+       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
+       localOccs =
+         map (getUnique . getParent . getOccName)
+                        -- NB: names always use semantic module, so
+                        -- filtering must be on the semantic module!
+                        -- See Note [Identity versus semantic module]
+                        . filter ((== semantic_mod) . name_module)
+                        . nonDetEltsUniqSet
+                   -- It's OK to use nonDetEltsUFM as localOccs is only
+                   -- used to construct the edges and
+                   -- stronglyConnCompFromEdgedVertices is deterministic
+                   -- even with non-deterministic order of edges as
+                   -- explained in Note [Deterministic SCC] in Digraph.
+          where getParent :: OccName -> OccName
+                getParent occ = lookupOccEnv parent_map occ `orElse` occ
+
+        -- maps OccNames to their parents in the current module.
+        -- e.g. a reference to a constructor must be turned into a reference
+        -- to the TyCon for the purposes of calculating dependencies.
+       parent_map :: OccEnv OccName
+       parent_map = foldl' extend emptyOccEnv new_decls
+          where extend env d =
+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
+                  where n = getOccName d
+
+        -- Strongly-connected groups of declarations, in dependency order
+       groups :: [SCC IfaceDeclABI]
+       groups = stronglyConnCompFromEdgedVerticesUniq edges
+
+       global_hash_fn = mkHashFun hsc_env eps
+
+        -- How to output Names when generating the data to fingerprint.
+        -- Here we want to output the fingerprint for each top-level
+        -- Name, whether it comes from the current module or another
+        -- module.  In this way, the fingerprint for a declaration will
+        -- change if the fingerprint for anything it refers to (transitively)
+        -- changes.
+       mk_put_name :: OccEnv (OccName,Fingerprint)
+                   -> BinHandle -> Name -> IO  ()
+       mk_put_name local_env bh name
+          | isWiredInName name  =  putNameLiterally bh name
+           -- wired-in names don't have fingerprints
+          | otherwise
+          = ASSERT2( isExternalName name, ppr name )
+            let hash | nameModule name /= semantic_mod =  global_hash_fn name
+                     -- Get it from the REAL interface!!
+                     -- This will trigger when we compile an hsig file
+                     -- and we know a backing impl for it.
+                     -- See Note [Identity versus semantic module]
+                     | semantic_mod /= this_mod
+                     , not (isHoleModule semantic_mod) = global_hash_fn name
+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
+                           `orElse` pprPanic "urk! lookup local fingerprint"
+                                       (ppr name $$ ppr local_env)))
+                -- This panic indicates that we got the dependency
+                -- analysis wrong, because we needed a fingerprint for
+                -- an entity that wasn't in the environment.  To debug
+                -- it, turn the panic into a trace, uncomment the
+                -- pprTraces below, run the compile again, and inspect
+                -- the output and the generated .hi file with
+                -- --show-iface.
+            in hash >>= put_ bh
+
+        -- take a strongly-connected group of declarations and compute
+        -- its fingerprint.
+
+       fingerprint_group :: (OccEnv (OccName,Fingerprint),
+                             [(Fingerprint,IfaceDecl)])
+                         -> SCC IfaceDeclABI
+                         -> IO (OccEnv (OccName,Fingerprint),
+                                [(Fingerprint,IfaceDecl)])
+
+       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
+          = do let hash_fn = mk_put_name local_env
+                   decl = abiDecl abi
+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
+               hash <- computeFingerprint hash_fn abi
+               env' <- extend_hash_env local_env (hash,decl)
+               return (env', (hash,decl) : decls_w_hashes)
+
+       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
+          = do let decls = map abiDecl abis
+               local_env1 <- foldM extend_hash_env local_env
+                                   (zip (repeat fingerprint0) decls)
+               let hash_fn = mk_put_name local_env1
+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
+               let stable_abis = sortBy cmp_abiNames abis
+                -- put the cycle in a canonical order
+               hash <- computeFingerprint hash_fn stable_abis
+               let pairs = zip (repeat hash) decls
+               local_env2 <- foldM extend_hash_env local_env pairs
+               return (local_env2, pairs ++ decls_w_hashes)
+
+       -- we have fingerprinted the whole declaration, but we now need
+       -- to assign fingerprints to all the OccNames that it binds, to
+       -- use when referencing those OccNames in later declarations.
+       --
+       extend_hash_env :: OccEnv (OccName,Fingerprint)
+                       -> (Fingerprint,IfaceDecl)
+                       -> IO (OccEnv (OccName,Fingerprint))
+       extend_hash_env env0 (hash,d) = do
+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
+                 (ifaceDeclFingerprints hash d))
+
+   --
+   (local_env, decls_w_hashes) <-
+       foldM fingerprint_group (emptyOccEnv, []) groups
+
+   -- when calculating fingerprints, we always need to use canonical
+   -- ordering for lists of things.  In particular, the mi_deps has various
+   -- lists of modules and suchlike, so put these all in canonical order:
+   let sorted_deps = sortDependencies (mi_deps iface0)
+
+   -- The export hash of a module depends on the orphan hashes of the
+   -- orphan modules below us in the dependency tree.  This is the way
+   -- that changes in orphans get propagated all the way up the
+   -- dependency tree.
+   --
+   -- Note [A bad dep_orphs optimization]
+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   -- In a previous version of this code, we filtered out orphan modules which
+   -- were not from the home package, justifying it by saying that "we'd
+   -- pick up the ABI hashes of the external module instead".  This is wrong.
+   -- Suppose that we have:
+   --
+   --       module External where
+   --           instance Show (a -> b)
+   --
+   --       module Home1 where
+   --           import External
+   --
+   --       module Home2 where
+   --           import Home1
+   --
+   -- The export hash of Home1 needs to reflect the orphan instances of
+   -- External. It's true that Home1 will get rebuilt if the orphans
+   -- of External, but we also need to make sure Home2 gets rebuilt
+   -- as well.  See #12733 for more details.
+   let orph_mods
+        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
+        $ dep_orphs sorted_deps
+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
+
+   -- Note [Do not update EPS with your own hi-boot]
+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   -- (See also #10182).  When your hs-boot file includes an orphan
+   -- instance declaration, you may find that the dep_orphs of a module you
+   -- import contains reference to yourself.  DO NOT actually load this module
+   -- or add it to the orphan hashes: you're going to provide the orphan
+   -- instances yourself, no need to consult hs-boot; if you do load the
+   -- interface into EPS, you will see a duplicate orphan instance.
+
+   orphan_hash <- computeFingerprint (mk_put_name local_env)
+                                     (map ifDFun orph_insts, orph_rules, orph_fis)
+
+   -- the export list hash doesn't depend on the fingerprints of
+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
+   export_hash <- computeFingerprint putNameLiterally
+                      (mi_exports iface0,
+                       orphan_hash,
+                       dep_orphan_hashes,
+                       dep_pkgs (mi_deps iface0),
+                       -- See Note [Export hash depends on non-orphan family instances]
+                       dep_finsts (mi_deps iface0),
+                        -- dep_pkgs: see "Package Version Changes" on
+                        -- wiki/commentary/compiler/recompilation-avoidance
+                       mi_trust iface0)
+                        -- Make sure change of Safe Haskell mode causes recomp.
+
+   -- Note [Export hash depends on non-orphan family instances]
+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   --
+   -- Suppose we have:
+   --
+   --   module A where
+   --       type instance F Int = Bool
+   --
+   --   module B where
+   --       import A
+   --
+   --   module C where
+   --       import B
+   --
+   -- The family instance consistency check for C depends on the dep_finsts of
+   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need
+   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
+   -- the exports of B, because C always considers them when checking
+   -- consistency.
+   --
+   -- A full discussion is in #12723.
+   --
+   -- We do NOT need to hash dep_orphs, because this is implied by
+   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
+   -- because there is no eager consistency check as there is with type families
+   -- (also we didn't store it anywhere!)
+   --
+
+   -- put the declarations in a canonical order, sorted by OccName
+   let sorted_decls = Map.elems $ Map.fromList $
+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]
+
+   -- the flag hash depends on:
+   --   - (some of) dflags
+   -- it returns two hashes, one that shouldn't change
+   -- the abi hash and one that should
+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
+
+   opt_hash <- fingerprintOptFlags dflags putNameLiterally
+
+   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
+
+   plugin_hash <- fingerprintPlugins hsc_env
+
+   -- the ABI hash depends on:
+   --   - decls
+   --   - export list
+   --   - orphans
+   --   - deprecations
+   --   - flag abi hash
+   mod_hash <- computeFingerprint putNameLiterally
+                      (map fst sorted_decls,
+                       export_hash,  -- includes orphan_hash
+                       mi_warns iface0)
+
+   -- The interface hash depends on:
+   --   - the ABI hash, plus
+   --   - the module level annotations,
+   --   - usages
+   --   - deps (home and external packages, dependent files)
+   --   - hpc
+   iface_hash <- computeFingerprint putNameLiterally
+                      (mod_hash,
+                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache
+                       mi_usages iface0,
+                       sorted_deps,
+                       mi_hpc iface0)
+
+   let
+    no_change_at_all = Just iface_hash == mb_old_fingerprint
+
+    final_iface = iface0 {
+                mi_mod_hash    = mod_hash,
+                mi_iface_hash  = iface_hash,
+                mi_exp_hash    = export_hash,
+                mi_orphan_hash = orphan_hash,
+                mi_flag_hash   = flag_hash,
+                mi_opt_hash    = opt_hash,
+                mi_hpc_hash    = hpc_hash,
+                mi_plugin_hash = plugin_hash,
+                mi_orphan      = not (   all ifRuleAuto orph_rules
+                                           -- See Note [Orphans and auto-generated rules]
+                                      && null orph_insts
+                                      && null orph_fis),
+                mi_finsts      = not . null $ mi_fam_insts iface0,
+                mi_decls       = sorted_decls,
+                mi_hash_fn     = lookupOccEnv local_env }
+   --
+   return (final_iface, no_change_at_all)
+
+  where
+    this_mod = mi_module iface0
+    semantic_mod = mi_semantic_module iface0
+    dflags = hsc_dflags hsc_env
+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)
+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
+    fix_fn = mi_fix_fn iface0
+    ann_fn = mkIfaceAnnCache (mi_anns iface0)
+
+-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
+-- (in particular, the orphan modules which are transitively imported by the
+-- current module).
+--
+-- Q: Why do we need the hash at all, doesn't the list of transitively
+-- imported orphan modules suffice?
+--
+-- A: If one of our transitive imports adds a new orphan instance, our
+-- export hash must change so that modules which import us rebuild.  If we just
+-- hashed the [Module], the hash would not change even when a new instance was
+-- added to a module that already had an orphan instance.
+--
+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?
+-- Why the full transitive closure?
+--
+-- A: Suppose we have these modules:
+--
+--      module A where
+--          instance Show (a -> b) where
+--      module B where
+--          import A -- **
+--      module C where
+--          import A
+--          import B
+--
+-- Whether or not we add or remove the import to A in B affects the
+-- orphan hash of B.  But it shouldn't really affect the orphan hash
+-- of C.  If we hashed only direct dependencies, there would be no
+-- way to tell that the net effect was a wash, and we'd be forced
+-- to recompile C and everything else.
+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
+getOrphanHashes hsc_env mods = do
+  eps <- hscEPS hsc_env
+  let
+    hpt        = hsc_HPT hsc_env
+    pit        = eps_PIT eps
+    dflags     = hsc_dflags hsc_env
+    get_orph_hash mod =
+          case lookupIfaceByModule dflags hpt pit mod of
+            Just iface -> return (mi_orphan_hash iface)
+            Nothing    -> do -- similar to 'mkHashFun'
+                iface <- initIfaceLoad hsc_env . withException
+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem
+                return (mi_orphan_hash iface)
+
+  --
+  mapM get_orph_hash mods
+
+
+sortDependencies :: Dependencies -> Dependencies
+sortDependencies d
+ = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
+          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),
+          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
+          dep_finsts = sortBy stableModuleCmp (dep_finsts d),
+          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
+
+-- | Creates cached lookup for the 'mi_anns' field of ModIface
+-- Hackily, we use "module" as the OccName for any module-level annotations
+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
+mkIfaceAnnCache anns
+  = \n -> lookupOccEnv env n `orElse` []
+  where
+    pair (IfaceAnnotation target value) =
+      (case target of
+          NamedTarget occn -> occn
+          ModuleTarget _   -> mkVarOcc "module"
+      , [value])
+    -- flipping (++), so the first argument is always short
+    env = mkOccEnv_C (flip (++)) (map pair anns)
+
+{-
+************************************************************************
+*                                                                      *
+          The ABI of an IfaceDecl
+*                                                                      *
+************************************************************************
+
+Note [The ABI of an IfaceDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ABI of a declaration consists of:
+
+   (a) the full name of the identifier (inc. module and package,
+       because these are used to construct the symbol name by which
+       the identifier is known externally).
+
+   (b) the declaration itself, as exposed to clients.  That is, the
+       definition of an Id is included in the fingerprint only if
+       it is made available as an unfolding in the interface.
+
+   (c) the fixity of the identifier (if it exists)
+   (d) for Ids: rules
+   (e) for classes: instances, fixity & rules for methods
+   (f) for datatypes: instances, fixity & rules for constrs
+
+Items (c)-(f) are not stored in the IfaceDecl, but instead appear
+elsewhere in the interface file.  But they are *fingerprinted* with
+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
+and fingerprinting that as part of the declaration.
+-}
+
+type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
+
+data IfaceDeclExtras
+  = IfaceIdExtras IfaceIdExtras
+
+  | IfaceDataExtras
+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)
+       [IfaceInstABI]           -- Local class and family instances of this tycon
+                                -- See Note [Orphans] in InstEnv
+       [AnnPayload]             -- Annotations of the type itself
+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations
+
+  | IfaceClassExtras
+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)
+       [IfaceInstABI]           -- Local instances of this class *or*
+                                --   of its associated data types
+                                -- See Note [Orphans] in InstEnv
+       [AnnPayload]             -- Annotations of the type itself
+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
+       [IfExtName]              -- Default methods. If a module
+                                -- mentions a class, then it can
+                                -- instantiate the class and thereby
+                                -- use the default methods, so we must
+                                -- include these in the fingerprint of
+                                -- a class.
+
+  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
+
+  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]
+
+  | IfaceOtherDeclExtras
+
+data IfaceIdExtras
+  = IdExtras
+       (Maybe Fixity)           -- Fixity of the Id (if it exists)
+       [IfaceRule]              -- Rules for the Id
+       [AnnPayload]             -- Annotations for the Id
+
+-- When hashing a class or family instance, we hash only the
+-- DFunId or CoAxiom, because that depends on all the
+-- information about the instance.
+--
+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance
+
+abiDecl :: IfaceDeclABI -> IfaceDecl
+abiDecl (_, decl, _) = decl
+
+cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`
+                         getOccName (abiDecl abi2)
+
+freeNamesDeclABI :: IfaceDeclABI -> NameSet
+freeNamesDeclABI (_mod, decl, extras) =
+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
+
+freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
+freeNamesDeclExtras (IfaceIdExtras id_extras)
+  = freeNamesIdExtras id_extras
+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)
+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)
+  = unionNameSets $
+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs
+freeNamesDeclExtras (IfaceSynonymExtras _ _)
+  = emptyNameSet
+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
+  = mkNameSet insts
+freeNamesDeclExtras IfaceOtherDeclExtras
+  = emptyNameSet
+
+freeNamesIdExtras :: IfaceIdExtras -> NameSet
+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
+
+instance Outputable IfaceDeclExtras where
+  ppr IfaceOtherDeclExtras       = Outputable.empty
+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras
+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
+  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
+                                                ppr_id_extras_s stuff]
+  ppr (IfaceClassExtras fix insts anns stuff defms) =
+    vcat [ppr fix, ppr_insts insts, ppr anns,
+          ppr_id_extras_s stuff, ppr defms]
+
+ppr_insts :: [IfaceInstABI] -> SDoc
+ppr_insts _ = text "<insts>"
+
+ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
+
+ppr_id_extras :: IfaceIdExtras -> SDoc
+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
+
+-- This instance is used only to compute fingerprints
+instance Binary IfaceDeclExtras where
+  get _bh = panic "no get for IfaceDeclExtras"
+  put_ bh (IfaceIdExtras extras) = do
+   putByte bh 1; put_ bh extras
+  put_ bh (IfaceDataExtras fix insts anns cons) = do
+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do
+   putByte bh 3
+   put_ bh fix
+   put_ bh insts
+   put_ bh anns
+   put_ bh methods
+   put_ bh defms
+  put_ bh (IfaceSynonymExtras fix anns) = do
+   putByte bh 4; put_ bh fix; put_ bh anns
+  put_ bh (IfaceFamilyExtras fix finsts anns) = do
+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
+  put_ bh IfaceOtherDeclExtras = putByte bh 6
+
+instance Binary IfaceIdExtras where
+  get _bh = panic "no get for IfaceIdExtras"
+  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
+
+declExtras :: (OccName -> Maybe Fixity)
+           -> (OccName -> [AnnPayload])
+           -> OccEnv [IfaceRule]
+           -> OccEnv [IfaceClsInst]
+           -> OccEnv [IfaceFamInst]
+           -> OccEnv IfExtName          -- lookup default method names
+           -> IfaceDecl
+           -> IfaceDeclExtras
+
+declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl
+  = case decl of
+      IfaceId{} -> IfaceIdExtras (id_extras n)
+      IfaceData{ifCons=cons} ->
+                     IfaceDataExtras (fix_fn n)
+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
+                         map ifDFun         (lookupOccEnvL inst_env n))
+                        (ann_fn n)
+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
+                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms
+          where
+            insts = (map ifDFun $ (concatMap at_extras ats)
+                                    ++ lookupOccEnvL inst_env n)
+                           -- Include instances of the associated types
+                           -- as well as instances of the class (#5147)
+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
+            -- Names of all the default methods (see Note [default method Name])
+            defms = [ dmName
+                    | IfaceClassOp bndr _ (Just _) <- sigs
+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)
+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]
+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
+                                           (ann_fn n)
+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
+                        (ann_fn n)
+      _other -> IfaceOtherDeclExtras
+  where
+        n = getOccName decl
+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
+
+
+{- Note [default method Name] (see also #15970)
+
+The Names for the default methods aren't available in the IfaceSyn.
+
+* We originally start with a DefMethInfo from the class, contain a
+  Name for the default method
+
+* We turn that into IfaceSyn as a DefMethSpec which lacks a Name
+  entirely. Why? Because the Name can be derived from the method name
+  (in TcIface), so doesn't need to be serialised into the interface
+  file.
+
+But now we have to get the Name back, because the class declaration's
+fingerprint needs to depend on it (this was the bug in #15970).  This
+is done in a slightly convoluted way:
+
+* Then, in addFingerprints we build a map that maps OccNames to Names
+
+* We pass that map to declExtras which laboriously looks up in the map
+  (using the derived occurrence name) to recover the Name we have just
+  thrown away.
+-}
+
+lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
+lookupOccEnvL env k = lookupOccEnv env k `orElse` []
+
+{-
+-- for testing: use the md5sum command to generate fingerprints and
+-- compare the results against our built-in version.
+  fp' <- oldMD5 dflags bh
+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
+               else return fp
+
+oldMD5 dflags bh = do
+  tmp <- newTempName dflags CurrentModule "bin"
+  writeBinMem bh tmp
+  tmp2 <- newTempName dflags CurrentModule "md5"
+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
+  r <- system cmd
+  case r of
+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
+    ExitSuccess -> do
+        hash_str <- readFile tmp2
+        return $! readHexFingerprint hash_str
+-}
+
+----------------------
+-- mkOrphMap partitions instance decls or rules into
+--      (a) an OccEnv for ones that are not orphans,
+--          mapping the local OccName to a list of its decls
+--      (b) a list of orphan decls
+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
+          -> [decl]             -- Sorted into canonical order
+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;
+                                --      each sublist in canonical order
+              [decl])           -- Orphan decls; in canonical order
+mkOrphMap get_key decls
+  = foldl' go (emptyOccEnv, []) decls
+  where
+    go (non_orphs, orphs) d
+        | NotOrphan occ <- get_key d
+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
+        | otherwise = (non_orphs, d:orphs)
+
+{-
+************************************************************************
+*                                                                      *
+       COMPLETE Pragmas
+*                                                                      *
+************************************************************************
+-}
+
+mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
+
+
+{-
+************************************************************************
+*                                                                      *
+       Keeping track of what we've slurped, and fingerprints
+*                                                                      *
+************************************************************************
+-}
+
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
+  = IfaceAnnotation {
+        ifAnnotatedTarget = fmap nameOccName target,
+        ifAnnotatedValue = payload
+    }
+
+mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical
+mkIfaceExports exports
+  = sortBy stableAvailCmp (map sort_subs exports)
+  where
+    sort_subs :: AvailInfo -> AvailInfo
+    sort_subs (Avail n) = Avail n
+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+    sort_subs (AvailTC n (m:ms) fs)
+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
+       -- Maintain the AvailTC Invariant
+
+    sort_flds = sortBy (stableNameCmp `on` flSelector)
+
+{-
+Note [Original module]
+~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+        module X where { data family T }
+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }
+The exported Avail from Y will look like
+        X.T{X.T, Y.MkT}
+That is, in Y,
+  - only MkT is brought into scope by the data instance;
+  - but the parent (used for grouping and naming in T(..) exports) is X.T
+  - and in this case we export X.T too
+
+In the result of MkIfaceExports, the names are grouped by defining module,
+so we may need to split up a single Avail into multiple ones.
+
+Note [Internal used_names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the used_names are External Names, but we can have Internal
+Names too: see Note [Binders in Template Haskell] in Convert, and
+#5362 for an example.  Such Names are always
+  - Such Names are always for locally-defined things, for which we
+    don't gather usage info, so we can just ignore them in ent_map
+  - They are always System Names, hence the assert, just as a double check.
+
+
+************************************************************************
+*                                                                      *
+        Load the old interface file for this module (unless
+        we have it already), and check whether it is up to date
+*                                                                      *
+************************************************************************
+-}
+
+data RecompileRequired
+  = UpToDate
+       -- ^ everything is up to date, recompilation is not required
+  | MustCompile
+       -- ^ The .hs file has been touched, or the .o/.hi file does not exist
+  | RecompBecause String
+       -- ^ The .o/.hi files are up to date, but something else has changed
+       -- to force recompilation; the String says what (one-line summary)
+   deriving Eq
+
+instance Semigroup RecompileRequired where
+  UpToDate <> r = r
+  mc <> _       = mc
+
+instance Monoid RecompileRequired where
+  mempty = UpToDate
+
+recompileRequired :: RecompileRequired -> Bool
+recompileRequired UpToDate = False
+recompileRequired _ = True
+
+
+
+-- | Top level function to check if the version of an old interface file
+-- is equivalent to the current source file the user asked us to compile.
+-- If the same, we can avoid recompilation. We return a tuple where the
+-- first element is a bool saying if we should recompile the object file
+-- and the second is maybe the interface file, where Nothng means to
+-- rebuild the interface file not use the exisitng one.
+checkOldIface
+  :: HscEnv
+  -> ModSummary
+  -> SourceModified
+  -> Maybe ModIface         -- Old interface from compilation manager, if any
+  -> IO (RecompileRequired, Maybe ModIface)
+
+checkOldIface hsc_env mod_summary source_modified maybe_iface
+  = do  let dflags = hsc_dflags hsc_env
+        showPass dflags $
+            "Checking old interface for " ++
+              (showPpr dflags $ ms_mod mod_summary) ++
+              " (use -ddump-hi-diffs for more details)"
+        initIfaceCheck (text "checkOldIface") hsc_env $
+            check_old_iface hsc_env mod_summary source_modified maybe_iface
+
+check_old_iface
+  :: HscEnv
+  -> ModSummary
+  -> SourceModified
+  -> Maybe ModIface
+  -> IfG (RecompileRequired, Maybe ModIface)
+
+check_old_iface hsc_env mod_summary src_modified maybe_iface
+  = let dflags = hsc_dflags hsc_env
+        getIface =
+            case maybe_iface of
+                Just _  -> do
+                    traceIf (text "We already have the old interface for" <+>
+                      ppr (ms_mod mod_summary))
+                    return maybe_iface
+                Nothing -> loadIface
+
+        loadIface = do
+             let iface_path = msHiFilePath mod_summary
+             read_result <- readIface (ms_mod mod_summary) iface_path
+             case read_result of
+                 Failed err -> do
+                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
+                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
+                     return Nothing
+                 Succeeded iface -> do
+                     traceIf (text "Read the interface file" <+> text iface_path)
+                     return $ Just iface
+
+        src_changed
+            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+            | SourceModified <- src_modified = True
+            | otherwise = False
+    in do
+        when src_changed $
+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
+
+        case src_changed of
+            -- If the source has changed and we're in interactive mode,
+            -- avoid reading an interface; just return the one we might
+            -- have been supplied with.
+            True | not (isObjectTarget $ hscTarget dflags) ->
+                return (MustCompile, maybe_iface)
+
+            -- Try and read the old interface for the current module
+            -- from the .hi file left from the last time we compiled it
+            True -> do
+                maybe_iface' <- getIface
+                return (MustCompile, maybe_iface')
+
+            False -> do
+                maybe_iface' <- getIface
+                case maybe_iface' of
+                    -- We can't retrieve the iface
+                    Nothing    -> return (MustCompile, Nothing)
+
+                    -- We have got the old iface; check its versions
+                    -- even in the SourceUnmodifiedAndStable case we
+                    -- should check versions because some packages
+                    -- might have changed or gone away.
+                    Just iface -> checkVersions hsc_env mod_summary iface
+
+-- | Check if a module is still the same 'version'.
+--
+-- This function is called in the recompilation checker after we have
+-- determined that the module M being checked hasn't had any changes
+-- to its source file since we last compiled M. So at this point in general
+-- two things may have changed that mean we should recompile M:
+--   * The interface export by a dependency of M has changed.
+--   * The compiler flags specified this time for M have changed
+--     in a manner that is significant for recompilation.
+-- We return not just if we should recompile the object file but also
+-- if we should rebuild the interface file.
+checkVersions :: HscEnv
+              -> ModSummary
+              -> ModIface       -- Old interface
+              -> IfG (RecompileRequired, Maybe ModIface)
+checkVersions hsc_env mod_summary iface
+  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+                        ppr (mi_module iface) <> colon)
+
+       -- readIface will have verified that the InstalledUnitId matches,
+       -- but we ALSO must make sure the instantiation matches up.  See
+       -- test case bkpcabal04!
+       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)
+            then return (RecompBecause "-this-unit-id changed", Nothing) else do {
+       ; recomp <- checkFlagHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkOptimHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHpcHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkMergedSignatures mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHsig mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHie mod_summary
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkDependencies hsc_env mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Just iface) else do {
+       ; recomp <- checkPlugins hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+
+
+       -- Source code unchanged and no errors yet... carry on
+       --
+       -- First put the dependent-module info, read from the old
+       -- interface, into the envt, so that when we look for
+       -- interfaces we look for the right one (.hi or .hi-boot)
+       --
+       -- It's just temporary because either the usage check will succeed
+       -- (in which case we are done with this module) or it'll fail (in which
+       -- case we'll compile the module from scratch anyhow).
+       --
+       -- We do this regardless of compilation mode, although in --make mode
+       -- all the dependent modules should be in the HPT already, so it's
+       -- quite redundant
+       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
+       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
+       ; return (recomp, Just iface)
+    }}}}}}}}}}
+  where
+    this_pkg = thisPackage (hsc_dflags hsc_env)
+    -- This is a bit of a hack really
+    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
+    mod_deps = mkModDeps (dep_mods (mi_deps iface))
+
+-- | Check if any plugins are requesting recompilation
+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
+checkPlugins hsc iface = liftIO $ do
+  new_fingerprint <- fingerprintPlugins hsc
+  let old_fingerprint = mi_plugin_hash iface
+  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))
+  return $
+    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr
+
+fingerprintPlugins :: HscEnv -> IO Fingerprint
+fingerprintPlugins hsc_env = do
+  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)
+
+fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
+fingerprintPlugins' plugins = do
+  res <- mconcat <$> mapM pluginRecompile' plugins
+  return $ case res of
+      NoForceRecompile ->  fingerprintString "NoForceRecompile"
+      ForceRecompile   -> fingerprintString "ForceRecompile"
+      -- is the chance of collision worth worrying about?
+      -- An alternative is to fingerprintFingerprints [fingerprintString
+      -- "maybeRecompile", fp]
+      (MaybeRecompile fp) -> fp
+
+
+pluginRecompileToRecompileRequired
+    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
+pluginRecompileToRecompileRequired old_fp new_fp pr
+  | old_fp == new_fp =
+    case pr of
+      NoForceRecompile  -> UpToDate
+
+      -- we already checked the fingerprint above so a mismatch is not possible
+      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
+      MaybeRecompile _  -> UpToDate
+
+      -- when we have an impure plugin in the stack we have to unconditionally
+      -- recompile since it might integrate all sorts of crazy IO results into
+      -- its compilation output.
+      ForceRecompile    -> RecompBecause "Impure plugin forced recompilation"
+
+  | old_fp `elem` magic_fingerprints ||
+    new_fp `elem` magic_fingerprints
+    -- The fingerprints do not match either the old or new one is a magic
+    -- fingerprint. This happens when non-pure plugins are added for the first
+    -- time or when we go from one recompilation strategy to another: (force ->
+    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
+    --
+    -- For example when we go from from ForceRecomp to NoForceRecomp
+    -- recompilation is triggered since the old impure plugins could have
+    -- changed the build output which is now back to normal.
+    = RecompBecause "Plugins changed"
+
+  | otherwise =
+    let reason = "Plugin fingerprint changed" in
+    case pr of
+      -- even though a plugin is forcing recompilation the fingerprint changed
+      -- which would cause recompilation anyways so we report the fingerprint
+      -- change instead.
+      ForceRecompile   -> RecompBecause reason
+
+      _                -> RecompBecause reason
+
+ where
+   magic_fingerprints =
+       [ fingerprintString "NoForceRecompile"
+       , fingerprintString "ForceRecompile"
+       ]
+
+
+-- | Check if an hsig file needs recompilation because its
+-- implementing module has changed.
+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
+checkHsig mod_summary iface = do
+    dflags <- getDynFlags
+    let outer_mod = ms_mod mod_summary
+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    case inner_mod == mi_semantic_module iface of
+        True -> up_to_date (text "implementing module unchanged")
+        False -> return (RecompBecause "implementing module changed")
+
+-- | Check if @.hie@ file is out of date or missing.
+checkHie :: ModSummary -> IfG RecompileRequired
+checkHie mod_summary = do
+    dflags <- getDynFlags
+    let hie_date_opt = ms_hie_date mod_summary
+        hs_date = ms_hs_date mod_summary
+    pure $ case gopt Opt_WriteHie dflags of
+               False -> UpToDate
+               True -> case hie_date_opt of
+                           Nothing -> RecompBecause "HIE file is missing"
+                           Just hie_date
+                               | hie_date < hs_date
+                               -> RecompBecause "HIE file is out of date"
+                               | otherwise
+                               -> UpToDate
+
+-- | Check the flags haven't changed
+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkFlagHash hsc_env iface = do
+    let old_hash = mi_flag_hash iface
+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
+                                             (mi_module iface)
+                                             putNameLiterally
+    case old_hash == new_hash of
+        True  -> up_to_date (text "Module flags unchanged")
+        False -> out_of_date_hash "flags changed"
+                     (text "  Module flags have changed")
+                     old_hash new_hash
+
+-- | Check the optimisation flags haven't changed
+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkOptimHash hsc_env iface = do
+    let old_hash = mi_opt_hash iface
+    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
+                                               putNameLiterally
+    if | old_hash == new_hash
+         -> up_to_date (text "Optimisation flags unchanged")
+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
+         -> up_to_date (text "Optimisation flags changed; ignoring")
+       | otherwise
+         -> out_of_date_hash "Optimisation flags changed"
+                     (text "  Optimisation flags have changed")
+                     old_hash new_hash
+
+-- | Check the HPC flags haven't changed
+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkHpcHash hsc_env iface = do
+    let old_hash = mi_hpc_hash iface
+    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
+                                               putNameLiterally
+    if | old_hash == new_hash
+         -> up_to_date (text "HPC flags unchanged")
+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
+         -> up_to_date (text "HPC flags changed; ignoring")
+       | otherwise
+         -> out_of_date_hash "HPC flags changed"
+                     (text "  HPC flags have changed")
+                     old_hash new_hash
+
+-- Check that the set of signatures we are merging in match.
+-- If the -unit-id flags change, this can change too.
+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
+checkMergedSignatures mod_summary iface = do
+    dflags <- getDynFlags
+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
+        new_merged = case Map.lookup (ms_mod_name mod_summary)
+                                     (requirementContext (pkgState dflags)) of
+                        Nothing -> []
+                        Just r -> sort $ map (indefModuleToModule dflags) r
+    if old_merged == new_merged
+        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
+        else return (RecompBecause "signatures to merge in changed")
+
+-- If the direct imports of this module are resolved to targets that
+-- are not among the dependencies of the previous interface file,
+-- then we definitely need to recompile.  This catches cases like
+--   - an exposed package has been upgraded
+--   - we are compiling with different package flags
+--   - a home module that was shadowing a package module has been removed
+--   - a new home module has been added that shadows a package module
+-- See bug #1372.
+--
+-- Returns (RecompBecause <textual reason>) if recompilation is required.
+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
+checkDependencies hsc_env summary iface
+ = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
+  where
+   prev_dep_mods = dep_mods (mi_deps iface)
+   prev_dep_plgn = dep_plgins (mi_deps iface)
+   prev_dep_pkgs = dep_pkgs (mi_deps iface)
+
+   this_pkg = thisPackage (hsc_dflags hsc_env)
+
+   dep_missing (mb_pkg, L _ mod) = do
+     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
+     let reason = moduleNameString mod ++ " changed"
+     case find_res of
+        Found _ mod
+          | pkg == this_pkg
+           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
+                 then do traceHiDiffs $
+                           text "imported module " <> quotes (ppr mod) <>
+                           text " not among previous dependencies"
+                         return (RecompBecause reason)
+                 else
+                         return UpToDate
+          | otherwise
+           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
+                 then do traceHiDiffs $
+                           text "imported module " <> quotes (ppr mod) <>
+                           text " is from package " <> quotes (ppr pkg) <>
+                           text ", which is not among previous dependencies"
+                         return (RecompBecause reason)
+                 else
+                         return UpToDate
+           where pkg = moduleUnitId mod
+        _otherwise  -> return (RecompBecause reason)
+
+needInterface :: Module -> (ModIface -> IfG RecompileRequired)
+              -> IfG RecompileRequired
+needInterface mod continue
+  = do  -- Load the imported interface if possible
+    let doc_str = sep [text "need version info for", ppr mod]
+    traceHiDiffs (text "Checking usages for module" <+> ppr mod)
+
+    mb_iface <- loadInterface doc_str mod ImportBySystem
+        -- Load the interface, but don't complain on failure;
+        -- Instead, get an Either back which we can test
+
+    case mb_iface of
+      Failed _ -> do
+        traceHiDiffs (sep [text "Couldn't load interface for module",
+                           ppr mod])
+        return MustCompile
+                  -- Couldn't find or parse a module mentioned in the
+                  -- old interface file.  Don't complain: it might
+                  -- just be that the current module doesn't need that
+                  -- import and it's been deleted
+      Succeeded iface -> continue iface
+
+-- | Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
+checkModUsage _this_pkg UsagePackageModule{
+                                usg_mod = mod,
+                                usg_mod_hash = old_mod_hash }
+  = needInterface mod $ \iface -> do
+    let reason = moduleNameString (moduleName mod) ++ " changed"
+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+        -- We only track the ABI hash of package modules, rather than
+        -- individual entity usages, so if the ABI hash changes we must
+        -- recompile.  This is safe but may entail more recompilation when
+        -- a dependent package has changed.
+
+checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }
+  = needInterface mod $ \iface -> do
+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+
+checkModUsage this_pkg UsageHomeModule{
+                                usg_mod_name = mod_name,
+                                usg_mod_hash = old_mod_hash,
+                                usg_exports = maybe_old_export_hash,
+                                usg_entities = old_decl_hash }
+  = do
+    let mod = mkModule this_pkg mod_name
+    needInterface mod $ \iface -> do
+
+    let
+        new_mod_hash    = mi_mod_hash    iface
+        new_decl_hash   = mi_hash_fn     iface
+        new_export_hash = mi_exp_hash    iface
+
+        reason = moduleNameString mod_name ++ " changed"
+
+        -- CHECK MODULE
+    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
+    if not (recompileRequired recompile)
+      then return UpToDate
+      else do
+
+        -- CHECK EXPORT LIST
+        checkMaybeHash reason maybe_old_export_hash new_export_hash
+            (text "  Export list changed") $ do
+
+        -- CHECK ITEMS ONE BY ONE
+        recompile <- checkList [ checkEntityUsage reason new_decl_hash u
+                               | u <- old_decl_hash]
+        if recompileRequired recompile
+          then return recompile     -- This one failed, so just bail out now
+          else up_to_date (text "  Great!  The bits I use are up to date")
+
+
+checkModUsage _this_pkg UsageFile{ usg_file_path = file,
+                                   usg_file_hash = old_hash } =
+  liftIO $
+    handleIO handle $ do
+      new_hash <- getFileHash file
+      if (old_hash /= new_hash)
+         then return recomp
+         else return UpToDate
+ where
+   recomp = RecompBecause (file ++ " changed")
+   handle =
+#if defined(DEBUG)
+       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
+#else
+       \_ -> return recomp -- if we can't find the file, just recompile, don't fail
+#endif
+
+------------------------
+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
+                       -> IfG RecompileRequired
+checkModuleFingerprint reason old_mod_hash new_mod_hash
+  | new_mod_hash == old_mod_hash
+  = up_to_date (text "Module fingerprint unchanged")
+
+  | otherwise
+  = out_of_date_hash reason (text "  Module fingerprint has changed")
+                     old_mod_hash new_mod_hash
+
+------------------------
+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
+               -> IfG RecompileRequired -> IfG RecompileRequired
+checkMaybeHash reason maybe_old_hash new_hash doc continue
+  | Just hash <- maybe_old_hash, hash /= new_hash
+  = out_of_date_hash reason doc hash new_hash
+  | otherwise
+  = continue
+
+------------------------
+checkEntityUsage :: String
+                 -> (OccName -> Maybe (OccName, Fingerprint))
+                 -> (OccName, Fingerprint)
+                 -> IfG RecompileRequired
+checkEntityUsage reason new_hash (name,old_hash)
+  = case new_hash name of
+
+        Nothing       ->        -- We used it before, but it ain't there now
+                          out_of_date reason (sep [text "No longer exported:", ppr name])
+
+        Just (_, new_hash)      -- It's there, but is it up to date?
+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
+                                       return UpToDate
+          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)
+                                                     old_hash new_hash
+
+up_to_date :: SDoc -> IfG RecompileRequired
+up_to_date  msg = traceHiDiffs msg >> return UpToDate
+
+out_of_date :: String -> SDoc -> IfG RecompileRequired
+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
+
+out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
+out_of_date_hash reason msg old_hash new_hash
+  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+
+----------------------
+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
+-- This helper is used in two places
+checkList []             = return UpToDate
+checkList (check:checks) = do recompile <- check
+                              if recompileRequired recompile
+                                then return recompile
+                                else checkList checks
+
+{-
+************************************************************************
+*                                                                      *
+                Converting things to their Iface equivalents
+*                                                                      *
+************************************************************************
+-}
+
+tyThingToIfaceDecl :: TyThing -> IfaceDecl
+tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id
+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
+tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax
+tyThingToIfaceDecl (AConLike cl)  = case cl of
+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
+    PatSynCon ps   -> patSynToIfaceDecl ps
+
+--------------------------
+idToIfaceDecl :: Id -> IfaceDecl
+-- The Id is already tidied, so that locally-bound names
+-- (lambdas, for-alls) already have non-clashing OccNames
+-- We can't tidy it here, locally, because it may have
+-- free variables in its type or IdInfo
+idToIfaceDecl id
+  = IfaceId { ifName      = getName id,
+              ifType      = toIfaceType (idType id),
+              ifIdDetails = toIfaceIdDetails (idDetails id),
+              ifIdInfo    = toIfaceIdInfo (idInfo id) }
+
+--------------------------
+dataConToIfaceDecl :: DataCon -> IfaceDecl
+dataConToIfaceDecl dataCon
+  = IfaceId { ifName      = getName dataCon,
+              ifType      = toIfaceType (dataConUserType dataCon),
+              ifIdDetails = IfVanillaId,
+              ifIdInfo    = NoInfo }
+
+--------------------------
+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
+-- We *do* tidy Axioms, because they are not (and cannot
+-- conveniently be) built in tidy form
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
+                               , co_ax_role = role })
+ = IfaceAxiom { ifName       = getName ax
+              , ifTyCon      = toIfaceTyCon tycon
+              , ifRole       = role
+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon
+                                     (map coAxBranchLHS branch_list))
+                                   branch_list }
+ where
+   branch_list = fromBranches branches
+
+-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
+-- to incompatible indices
+-- 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 }
+  where
+    iface_incomps = map (expectJust "iface_incomps"
+                        . (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
+-- conveniently be) built in tidy form
+-- The returned TidyEnv is the one after tidying the tyConTyVars
+tyConToIfaceDecl env tycon
+  | Just clas <- tyConClass_maybe tycon
+  = classToIfaceDecl env clas
+
+  | Just syn_rhs <- synTyConRhs_maybe tycon
+  = ( tc_env1
+    , IfaceSynonym { ifName    = getName tycon,
+                     ifRoles   = tyConRoles tycon,
+                     ifSynRhs  = if_syn_type syn_rhs,
+                     ifBinders = if_binders,
+                     ifResKind = if_res_kind
+                   })
+
+  | Just fam_flav <- famTyConFlav_maybe tycon
+  = ( tc_env1
+    , IfaceFamily { ifName    = getName tycon,
+                    ifResVar  = if_res_var,
+                    ifFamFlav = to_if_fam_flav fam_flav,
+                    ifBinders = if_binders,
+                    ifResKind = if_res_kind,
+                    ifFamInj  = tyConInjectivityInfo tycon
+                  })
+
+  | isAlgTyCon tycon
+  = ( tc_env1
+    , IfaceData { ifName    = getName tycon,
+                  ifBinders = if_binders,
+                  ifResKind = if_res_kind,
+                  ifCType   = tyConCType tycon,
+                  ifRoles   = tyConRoles tycon,
+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
+                  ifCons    = ifaceConDecls (algTyConRhs tycon),
+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,
+                  ifParent  = parent })
+
+  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
+  -- We only convert these TyCons to IfaceTyCons when we are
+  -- just about to pretty-print them, not because we are going
+  -- to put them into interface files
+  = ( env
+    , IfaceData { ifName       = getName tycon,
+                  ifBinders    = if_binders,
+                  ifResKind    = if_res_kind,
+                  ifCType      = Nothing,
+                  ifRoles      = tyConRoles tycon,
+                  ifCtxt       = [],
+                  ifCons       = IfDataTyCon [],
+                  ifGadtSyntax = False,
+                  ifParent     = IfNoParent })
+  where
+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
+    -- an error.
+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+    tc_tyvars      = binderVars tc_binders
+    if_binders     = toIfaceTyCoVarBinders tc_binders
+                     -- No tidying of the binders; they are already tidy
+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)
+    if_syn_type ty = tidyToIfaceType tc_env1 ty
+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon
+
+    parent = case tyConFamInstSig_maybe tycon of
+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
+                                                   (toIfaceTyCon tc)
+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)
+               Nothing           -> IfNoParent
+
+    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon
+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon
+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon
+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon
+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
+      where defs = fromBranches $ coAxiomBranches ax
+            ibr  = map (coAxBranchToIfaceBranch' tycon) defs
+            axn  = coAxiomName ax
+
+    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
+    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]
+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon
+        -- The AbstractTyCon case happens when a TyCon has been trimmed
+        -- during tidying.
+        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
+        -- for GHCi, when browsing a module, in which case the
+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
+        -- (Tuple declarations are not serialised into interface files.)
+
+    ifaceConDecl data_con
+        = IfCon   { ifConName    = dataConName data_con,
+                    ifConInfix   = dataConIsInfix data_con,
+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),
+                    ifConExTCvs  = map toIfaceBndr ex_tvs',
+                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,
+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
+                    ifConFields  = dataConFieldLabels data_con,
+                    ifConStricts = map (toIfaceBang con_env2)
+                                       (dataConImplBangs data_con),
+                    ifConSrcStricts = map toIfaceSrcBang
+                                          (dataConSrcBangs data_con)}
+        where
+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+            = dataConFullSig data_con
+          user_bndrs = dataConUserTyVarBinders data_con
+
+          -- Tidy the univ_tvs of the data constructor to be identical
+          -- to the tyConTyVars of the type constructor.  This means
+          -- (a) we don't need to redundantly put them into the interface file
+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
+          --     we know that the type variables will line up
+          -- The latter (b) is important because we pretty-print type constructors
+          -- by converting to IfaceSyn and pretty-printing that
+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
+                     -- A bit grimy, perhaps, but it's simple!
+
+          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
+          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs
+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
+
+          -- By this point, we have tidied every universal and existential
+          -- tyvar. Because of the dcUserTyCoVarBinders invariant
+          -- (see Note [DataCon user type variable binders]), *every*
+          -- user-written tyvar must be contained in the substitution that
+          -- tidying produced. Therefore, tidying the user-written tyvars is a
+          -- simple matter of looking up each variable in the substitution,
+          -- which tidyTyCoVarOcc accomplishes.
+          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
+          tidyUserTyCoVarBinder env (Bndr tv vis) =
+            Bndr (tidyTyCoVarOcc env tv) vis
+
+classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
+classToIfaceDecl env clas
+  = ( env1
+    , IfaceClass { ifName   = getName tycon,
+                   ifRoles  = tyConRoles (classTyCon clas),
+                   ifBinders = toIfaceTyCoVarBinders tc_binders,
+                   ifBody   = body,
+                   ifFDs    = map toIfaceFD clas_fds })
+  where
+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
+      = classExtraBigSig clas
+    tycon = classTyCon clas
+
+    body | isAbstractTyCon tycon = IfAbstractClass
+         | otherwise
+         = IfConcreteClass {
+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,
+                ifATs    = map toIfaceAT clas_ats,
+                ifSigs   = map toIfaceClassOp op_stuff,
+                ifMinDef = fmap getOccFS (classMinimalDef clas)
+            }
+
+    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+
+    toIfaceAT :: ClassATItem -> IfaceAT
+    toIfaceAT (ATI tc def)
+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
+      where
+        (env2, if_decl) = tyConToIfaceDecl env1 tc
+
+    toIfaceClassOp (sel_id, def_meth)
+        = ASSERT( sel_tyvars == binderVars tc_binders )
+          IfaceClassOp (getName sel_id)
+                       (tidyToIfaceType env1 op_ty)
+                       (fmap toDmSpec def_meth)
+        where
+                -- Be careful when splitting the type, because of things
+                -- like         class Foo a where
+                --                op :: (?x :: String) => a -> a
+                -- and          class Baz a where
+                --                op :: (Ord a) => a -> a
+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+          op_ty                = funResultTy rho_ty
+
+    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
+    toDmSpec (_, VanillaDM)       = VanillaDM
+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
+
+    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
+                             ,map (tidyTyVar env1) tvs2)
+
+--------------------------
+
+tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
+-- If the type variable "binder" is in scope, don't re-bind it
+-- In a class decl, for example, the ATD binders mention
+-- (amd must mention) the class tyvars
+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
+ = case lookupVarEnv subst tv of
+     Just tv' -> (env,  Bndr tv' vis)
+     Nothing  -> tidyTyCoVarBinder env tvb
+
+tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
+tidyTyConBinders = mapAccumL tidyTyConBinder
+
+tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
+
+--------------------------
+instanceToIfaceInst :: ClsInst -> IfaceClsInst
+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
+                             , is_cls_nm = cls_name, is_cls = cls
+                             , is_tcs = mb_tcs
+                             , is_orphan = orph })
+  = ASSERT( cls_name == className cls )
+    IfaceClsInst { ifDFun    = dfun_name,
+                ifOFlag   = oflag,
+                ifInstCls = cls_name,
+                ifInstTys = map do_rough mb_tcs,
+                ifInstOrph = orph }
+  where
+    do_rough Nothing  = Nothing
+    do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+    dfun_name = idName dfun_id
+
+
+--------------------------
+famInstToIfaceFamInst :: FamInst -> IfaceFamInst
+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
+                                 fi_fam      = fam,
+                                 fi_tcs      = roughs })
+  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom
+                 , ifFamInstFam      = fam
+                 , ifFamInstTys      = map do_rough roughs
+                 , ifFamInstOrph     = orph }
+  where
+    do_rough Nothing  = Nothing
+    do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+    fam_decl = tyConName $ coAxiomTyCon axiom
+    mod = ASSERT( isExternalName (coAxiomName axiom) )
+          nameModule (coAxiomName axiom)
+    is_local name = nameIsLocalOrFrom mod name
+
+    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
+
+    orph | is_local fam_decl
+         = NotOrphan (nameOccName fam_decl)
+         | otherwise
+         = chooseOrphanAnchor lhs_names
+
+--------------------------
+coreRuleToIfaceRule :: CoreRule -> IfaceRule
+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
+  = pprTrace "toHsRule: builtin" (ppr fn) $
+    bogusIfaceRule fn
+
+coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
+                            ru_act = act, ru_bndrs = bndrs,
+                            ru_args = args, ru_rhs = rhs,
+                            ru_orphan = orph, ru_auto = auto })
+  = IfaceRule { ifRuleName  = name, ifActivation = act,
+                ifRuleBndrs = map toIfaceBndr bndrs,
+                ifRuleHead  = fn,
+                ifRuleArgs  = map do_arg args,
+                ifRuleRhs   = toIfaceExpr rhs,
+                ifRuleAuto  = auto,
+                ifRuleOrph  = orph }
+  where
+        -- For type args we must remove synonyms from the outermost
+        -- level.  Reason: so that when we read it back in we'll
+        -- construct the same ru_rough field as we have right now;
+        -- see tcIfaceRule
+    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))
+    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)
+    do_arg arg           = toIfaceExpr arg
+
+bogusIfaceRule :: Name -> IfaceRule
+bogusIfaceRule id_name
+  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
+        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
+        ifRuleAuto = True }
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/TcIface.hs
@@ -0,0 +1,1821 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Type checking of type signatures in interface files
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+
+module TcIface (
+        tcLookupImported_maybe,
+        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
+        typecheckIfacesForMerging,
+        typecheckIfaceForInstantiate,
+        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
+        tcIfaceAnnotations, tcIfaceCompleteSigs,
+        tcIfaceExpr,    -- Desired by HERMIT (#7683)
+        tcIfaceGlobal
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcTypeNats(typeNatCoAxiomRules)
+import IfaceSyn
+import LoadIface
+import IfaceEnv
+import BuildTyCl
+import TcRnMonad
+import TcType
+import Type
+import Coercion
+import CoAxiom
+import TyCoRep    -- needs to build types & coercions in a knot
+import HscTypes
+import Annotations
+import InstEnv
+import FamInstEnv
+import CoreSyn
+import CoreUtils
+import CoreUnfold
+import CoreLint
+import MkCore
+import Id
+import MkId
+import IdInfo
+import Class
+import TyCon
+import ConLike
+import DataCon
+import PrelNames
+import TysWiredIn
+import Literal
+import Var
+import VarSet
+import Name
+import NameEnv
+import NameSet
+import OccurAnal        ( occurAnalyseExpr )
+import Demand
+import Module
+import UniqFM
+import UniqSupply
+import Outputable
+import Maybes
+import SrcLoc
+import DynFlags
+import Util
+import FastString
+import BasicTypes hiding ( SuccessFlag(..) )
+import ListSetOps
+import GHC.Fingerprint
+import qualified BooleanFormula as BF
+
+import Control.Monad
+import qualified Data.Map as Map
+
+{-
+This module takes
+
+        IfaceDecl -> TyThing
+        IfaceType -> Type
+        etc
+
+An IfaceDecl is populated with RdrNames, and these are not renamed to
+Names before typechecking, because there should be no scope errors etc.
+
+        -- For (b) consider: f = \$(...h....)
+        -- where h is imported, and calls f via an hi-boot file.
+        -- This is bad!  But it is not seen as a staging error, because h
+        -- is indeed imported.  We don't want the type-checker to black-hole
+        -- when simplifying and compiling the splice!
+        --
+        -- Simple solution: discard any unfolding that mentions a variable
+        -- bound in this module (and hence not yet processed).
+        -- The discarding happens when forkM finds a type error.
+
+
+************************************************************************
+*                                                                      *
+                Type-checking a complete interface
+*                                                                      *
+************************************************************************
+
+Suppose we discover we don't need to recompile.  Then we must type
+check the old interface file.  This is a bit different to the
+incremental type checking we do as we suck in interface files.  Instead
+we do things similarly as when we are typechecking source decls: we
+bring into scope the type envt for the interface all at once, using a
+knot.  Remember, the decls aren't necessarily in dependency order --
+and even if they were, the type decls might be mutually recursive.
+
+Note [Knot-tying typecheckIface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are typechecking an interface A.hi, and we come across
+a Name for another entity defined in A.hi.  How do we get the
+'TyCon', in this case?  There are three cases:
+
+    1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in
+    preparation of checking if the hs file we're building
+    is compatible.  In this case, we want all of the internal
+    TyCons to MATCH the ones that we just constructed during
+    typechecking: the knot is thus tied through if_rec_types.
+
+    2) retypecheckLoop in GhcMake: We are retypechecking a
+    mutually recursive cluster of hi files, in order to ensure
+    that all of the references refer to each other correctly.
+    In this case, the knot is tied through the HPT passed in,
+    which contains all of the interfaces we are in the process
+    of typechecking.
+
+    3) genModDetails in HscMain: We are typechecking an
+    old interface to generate the ModDetails.  In this case,
+    we do the same thing as (2) and pass in an HPT with
+    the HomeModInfo being generated to tie knots.
+
+The upshot is that the CLIENT of this function is responsible
+for making sure that the knot is tied correctly.  If you don't,
+then you'll get a message saying that we couldn't load the
+declaration you wanted.
+
+BTW, in one-shot mode we never call typecheckIface; instead,
+loadInterface handles type-checking interface.  In that case,
+knots are tied through the EPS.  No problem!
+-}
+
+-- Clients of this function be careful, see Note [Knot-tying typecheckIface]
+typecheckIface :: ModIface      -- Get the decls from here
+               -> IfG ModDetails
+typecheckIface iface
+  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
+        {       -- Get the right set of decls and rules.  If we are compiling without -O
+                -- we discard pragmas before typechecking, so that we don't "see"
+                -- information that we shouldn't.  From a versioning point of view
+                -- It's not actually *wrong* to do so, but in fact GHCi is unable
+                -- to handle unboxed tuples, so it must not see unfoldings.
+          ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+
+                -- Typecheck the decls.  This is done lazily, so that the knot-tying
+                -- within this single module works out right.  It's the callers
+                -- job to make sure the knot is tied.
+        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
+        ; let type_env = mkNameEnv names_w_things
+
+                -- Now do those rules, instances and annotations
+        ; insts     <- mapM tcIfaceInst (mi_insts iface)
+        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        ; anns      <- tcIfaceAnnotations (mi_anns iface)
+
+                -- Exports
+        ; exports <- ifaceExportNames (mi_exports iface)
+
+                -- Complete Sigs
+        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+
+                -- Finished
+        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
+                         -- Careful! If we tug on the TyThing thunks too early
+                         -- we'll infinite loop with hs-boot.  See #10083 for
+                         -- an example where this would cause non-termination.
+                         text "Type envt:" <+> ppr (map fst names_w_things)])
+        ; return $ ModDetails { md_types     = type_env
+                              , md_insts     = insts
+                              , md_fam_insts = fam_insts
+                              , md_rules     = rules
+                              , md_anns      = anns
+                              , md_exports   = exports
+                              , md_complete_sigs = complete_sigs
+                              }
+    }
+
+{-
+************************************************************************
+*                                                                      *
+                Typechecking for merging
+*                                                                      *
+************************************************************************
+-}
+
+-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
+isAbstractIfaceDecl :: IfaceDecl -> Bool
+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
+isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
+isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
+isAbstractIfaceDecl _ = False
+
+ifMaybeRoles :: IfaceDecl -> Maybe [Role]
+ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs
+ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs
+ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs
+ifMaybeRoles _ = Nothing
+
+-- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If
+-- both are non-abstract we pick one arbitrarily (and check for consistency
+-- later.)
+mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
+mergeIfaceDecl d1 d2
+    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
+    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
+    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
+    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
+    = let ops = nameEnvElts $
+                  plusNameEnv_C mergeIfaceClassOp
+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
+      in d1 { ifBody = (ifBody d1) {
+                ifSigs  = ops,
+                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
+                }
+            } `withRolesFrom` d2
+    -- It doesn't matter; we'll check for consistency later when
+    -- we merge, see 'mergeSignatures'
+    | otherwise              = d1 `withRolesFrom` d2
+
+-- Note [Role merging]
+-- ~~~~~~~~~~~~~~~~~~~
+-- First, why might it be necessary to do a non-trivial role
+-- merge?  It may rescue a merge that might otherwise fail:
+--
+--      signature A where
+--          type role T nominal representational
+--          data T a b
+--
+--      signature A where
+--          type role T representational nominal
+--          data T a b
+--
+-- A module that defines T as representational in both arguments
+-- would successfully fill both signatures, so it would be better
+-- if we merged the roles of these types in some nontrivial
+-- way.
+--
+-- However, we have to be very careful about how we go about
+-- doing this, because role subtyping is *conditional* on
+-- the supertype being NOT representationally injective, e.g.,
+-- if we have instead:
+--
+--      signature A where
+--          type role T nominal representational
+--          data T a b = T a b
+--
+--      signature A where
+--          type role T representational nominal
+--          data T a b = T a b
+--
+-- Should we merge the definitions of T so that the roles are R/R (or N/N)?
+-- Absolutely not: neither resulting type is a subtype of the original
+-- types (see Note [Role subtyping]), because data is not representationally
+-- injective.
+--
+-- Thus, merging only occurs when BOTH TyCons in question are
+-- representationally injective.  If they're not, no merge.
+
+withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
+d1 `withRolesFrom` d2
+    | Just roles1 <- ifMaybeRoles d1
+    , Just roles2 <- ifMaybeRoles d2
+    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)
+    = d1 { ifRoles = mergeRoles roles1 roles2 }
+    | otherwise = d1
+  where
+    mergeRoles roles1 roles2 = zipWith max roles1 roles2
+
+isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
+isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True
+isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True
+isRepInjectiveIfaceDecl _ = False
+
+mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
+mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
+mergeIfaceClassOp _ op2 = op2
+
+-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
+mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
+mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
+
+-- | This is a very interesting function.  Like typecheckIface, we want
+-- to type check an interface file into a ModDetails.  However, the use-case
+-- for these ModDetails is different: we want to compare all of the
+-- ModDetails to ensure they define compatible declarations, and then
+-- merge them together.  So in particular, we have to take a different
+-- strategy for knot-tying: we first speculatively merge the declarations
+-- to get the "base" truth for what we believe the types will be
+-- (this is "type computation.")  Then we read everything in relative
+-- to this truth and check for compatibility.
+--
+-- During the merge process, we may need to nondeterministically
+-- pick a particular declaration to use, if multiple signatures define
+-- the declaration ('mergeIfaceDecl').  If, for all choices, there
+-- are no type synonym cycles in the resulting merged graph, then
+-- we can show that our choice cannot matter. Consider the
+-- set of entities which the declarations depend on: by assumption
+-- of acyclicity, we can assume that these have already been shown to be equal
+-- to each other (otherwise merging will fail).  Then it must
+-- be the case that all candidate declarations here are type-equal
+-- (the choice doesn't matter) or there is an inequality (in which
+-- case merging will fail.)
+--
+-- Unfortunately, the choice can matter if there is a cycle.  Consider the
+-- following merge:
+--
+--      signature H where { type A = C;  type B = A; data C      }
+--      signature H where { type A = (); data B;     type C = B  }
+--
+-- If we pick @type A = C@ as our representative, there will be
+-- a cycle and merging will fail. But if we pick @type A = ()@ as
+-- our representative, no cycle occurs, and we instead conclude
+-- that all of the types are unit.  So it seems that we either
+-- (a) need a stronger acyclicity check which considers *all*
+-- possible choices from a merge, or (b) we must find a selection
+-- of declarations which is acyclic, and show that this is always
+-- the "best" choice we could have made (ezyang conjectures this
+-- is the case but does not have a proof).  For now this is
+-- not implemented.
+--
+-- It's worth noting that at the moment, a data constructor and a
+-- type synonym are never compatible.  Consider:
+--
+--      signature H where { type Int=C;         type B = Int; data C = Int}
+--      signature H where { export Prelude.Int; data B;       type C = B; }
+--
+-- This will be rejected, because the reexported Int in the second
+-- signature (a proper data type) is never considered equal to a
+-- type synonym.  Perhaps this should be relaxed, where a type synonym
+-- in a signature is considered implemented by a data type declaration
+-- which matches the reference of the type synonym.
+typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
+typecheckIfacesForMerging mod ifaces tc_env_var =
+  -- cannot be boot (False)
+  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+    -- Build the initial environment
+    -- NB: Don't include dfuns here, because we don't want to
+    -- serialize them out.  See Note [rnIfaceNeverExported] in RnModIface
+    -- NB: But coercions are OK, because they will have the right OccName.
+    let mk_decl_env decls
+            = mkOccEnv [ (getOccName decl, decl)
+                       | decl <- decls
+                       , case decl of
+                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
+                            _ -> True ]
+        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
+                        :: [OccEnv IfaceDecl]
+        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
+                        ::  OccEnv IfaceDecl
+    -- TODO: change loadDecls to accept w/o Fingerprint
+    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
+                                                  (occEnvElts decl_env))
+    let global_type_env = mkNameEnv names_w_things
+    writeMutVar tc_env_var global_type_env
+
+    -- OK, now typecheck each ModIface using this environment
+    details <- forM ifaces $ \iface -> do
+        -- See Note [Resolving never-exported Names in TcIface]
+        type_env <- fixM $ \type_env -> do
+            setImplicitEnvM type_env $ do
+                decls <- loadDecls ignore_prags (mi_decls iface)
+                return (mkNameEnv decls)
+        -- But note that we use this type_env to typecheck references to DFun
+        -- in 'IfaceInst'
+        setImplicitEnvM type_env $ do
+        insts     <- mapM tcIfaceInst (mi_insts iface)
+        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        anns      <- tcIfaceAnnotations (mi_anns iface)
+        exports   <- ifaceExportNames (mi_exports iface)
+        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+        return $ ModDetails { md_types     = type_env
+                            , md_insts     = insts
+                            , md_fam_insts = fam_insts
+                            , md_rules     = rules
+                            , md_anns      = anns
+                            , md_exports   = exports
+                            , md_complete_sigs = complete_sigs
+                            }
+    return (global_type_env, details)
+
+-- | Typecheck a signature 'ModIface' under the assumption that we have
+-- instantiated it under some implementation (recorded in 'mi_semantic_module')
+-- and want to check if the implementation fills the signature.
+--
+-- This needs to operate slightly differently than 'typecheckIface'
+-- because (1) we have a 'NameShape', from the exports of the
+-- implementing module, which we will use to give our top-level
+-- declarations the correct 'Name's even when the implementor
+-- provided them with a reexport, and (2) we have to deal with
+-- DFun silliness (see Note [rnIfaceNeverExported])
+typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
+typecheckIfaceForInstantiate nsubst iface =
+  initIfaceLclWithSubst (mi_semantic_module iface)
+                        (text "typecheckIfaceForInstantiate")
+                        (mi_boot iface) nsubst $ do
+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+    -- See Note [Resolving never-exported Names in TcIface]
+    type_env <- fixM $ \type_env -> do
+        setImplicitEnvM type_env $ do
+            decls     <- loadDecls ignore_prags (mi_decls iface)
+            return (mkNameEnv decls)
+    -- See Note [rnIfaceNeverExported]
+    setImplicitEnvM type_env $ do
+    insts     <- mapM tcIfaceInst (mi_insts iface)
+    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+    rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+    anns      <- tcIfaceAnnotations (mi_anns iface)
+    exports   <- ifaceExportNames (mi_exports iface)
+    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+    return $ ModDetails { md_types     = type_env
+                        , md_insts     = insts
+                        , md_fam_insts = fam_insts
+                        , md_rules     = rules
+                        , md_anns      = anns
+                        , md_exports   = exports
+                        , md_complete_sigs = complete_sigs
+                        }
+
+-- Note [Resolving never-exported Names in TcIface]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For the high-level overview, see
+-- Note [Handling never-exported TyThings under Backpack]
+--
+-- As described in 'typecheckIfacesForMerging', the splendid innovation
+-- of signature merging is to rewrite all Names in each of the signatures
+-- we are merging together to a pre-merged structure; this is the key
+-- ingredient that lets us solve some problems when merging type
+-- synonyms.
+--
+-- However, when a 'Name' refers to a NON-exported entity, as is the
+-- case with the DFun of a ClsInst, or a CoAxiom of a type family,
+-- this strategy causes problems: if we pick one and rewrite all
+-- references to a shared 'Name', we will accidentally fail to check
+-- if the DFun or CoAxioms are compatible, as they will never be
+-- checked--only exported entities are checked for compatibility,
+-- and a non-exported TyThing is checked WHEN we are checking the
+-- ClsInst or type family for compatibility in checkBootDeclM.
+-- By virtue of the fact that everything's been pointed to the merged
+-- declaration, you'll never notice there's a difference even if there
+-- is one.
+--
+-- Fortunately, there are only a few places in the interface declarations
+-- where this can occur, so we replace those calls with 'tcIfaceImplicit',
+-- which will consult a local TypeEnv that records any never-exported
+-- TyThings which we should wire up with.
+--
+-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a
+-- type family can refer to a coercion axiom, all of which are done in one go
+-- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck
+-- coercions first before type families, but that seemed more fragile.
+--
+
+{-
+************************************************************************
+*                                                                      *
+                Type and class declarations
+*                                                                      *
+************************************************************************
+-}
+
+tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
+-- Load the hi-boot iface for the module being compiled,
+-- if it indeed exists in the transitive closure of imports
+-- Return the ModDetails; Nothing if no hi-boot iface
+tcHiBootIface hsc_src mod
+  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file
+  = return NoSelfBoot
+  | otherwise
+  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)
+
+        ; mode <- getGhcMode
+        ; if not (isOneShot mode)
+                -- In --make and interactive mode, if this module has an hs-boot file
+                -- we'll have compiled it already, and it'll be in the HPT
+                --
+                -- We check wheher the interface is a *boot* interface.
+                -- It can happen (when using GHC from Visual Studio) that we
+                -- compile a module in TypecheckOnly mode, with a stable,
+                -- fully-populated HPT.  In that case the boot interface isn't there
+                -- (it's been replaced by the mother module) so we can't check it.
+                -- And that's fine, because if M's ModInfo is in the HPT, then
+                -- it's been compiled once, and we don't need to check the boot iface
+          then do { hpt <- getHpt
+                 ; case lookupHpt hpt (moduleName mod) of
+                      Just info | mi_boot (hm_iface info)
+                                -> mkSelfBootInfo (hm_iface info) (hm_details info)
+                      _ -> return NoSelfBoot }
+          else do
+
+        -- OK, so we're in one-shot mode.
+        -- Re #9245, we always check if there is an hi-boot interface
+        -- to check consistency against, rather than just when we notice
+        -- that an hi-boot is necessary due to a circular import.
+        { read_result <- findAndReadIface
+                                need (fst (splitModuleInsts mod)) mod
+                                True    -- Hi-boot file
+
+        ; case read_result of {
+            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
+                                           ; mkSelfBootInfo iface tc_iface } ;
+            Failed err               ->
+
+        -- There was no hi-boot file. But if there is circularity in
+        -- the module graph, there really should have been one.
+        -- Since we've read all the direct imports by now,
+        -- eps_is_boot will record if any of our imports mention the
+        -- current module, which either means a module loop (not
+        -- a SOURCE import) or that our hi-boot file has mysteriously
+        -- disappeared.
+    do  { eps <- getEps
+        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
+            Nothing -> return NoSelfBoot -- The typical case
+
+            Just (_, False) -> failWithTc moduleLoop
+                -- Someone below us imported us!
+                -- This is a loop with no hi-boot in the way
+
+            Just (_mod, True) -> failWithTc (elaborate err)
+                -- The hi-boot file has mysteriously disappeared.
+    }}}}
+  where
+    need = text "Need the hi-boot interface for" <+> ppr mod
+                 <+> text "to compare against the Real Thing"
+
+    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
+                     <+> text "depends on itself"
+
+    elaborate err = hang (text "Could not find hi-boot interface for" <+>
+                          quotes (ppr mod) <> colon) 4 err
+
+
+mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
+mkSelfBootInfo iface mds
+  = do -- NB: This is computed DIRECTLY from the ModIface rather
+       -- than from the ModDetails, so that we can query 'sb_tcs'
+       -- WITHOUT forcing the contents of the interface.
+       let tcs = map ifName
+                 . filter isIfaceTyCon
+                 . map snd
+                 $ mi_decls iface
+       return $ SelfBoot { sb_mds = mds
+                         , sb_tcs = mkNameSet tcs }
+  where
+    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on
+    -- this 'IfaceDecl', an ATyCon would be returned.
+    -- NB: This code assumes that a TyCon cannot be implicit.
+    isIfaceTyCon IfaceId{}      = False
+    isIfaceTyCon IfaceData{}    = True
+    isIfaceTyCon IfaceSynonym{} = True
+    isIfaceTyCon IfaceFamily{}  = True
+    isIfaceTyCon IfaceClass{}   = True
+    isIfaceTyCon IfaceAxiom{}   = False
+    isIfaceTyCon IfacePatSyn{}  = False
+
+{-
+************************************************************************
+*                                                                      *
+                Type and class declarations
+*                                                                      *
+************************************************************************
+
+When typechecking a data type decl, we *lazily* (via forkM) typecheck
+the constructor argument types.  This is in the hope that we may never
+poke on those argument types, and hence may never need to load the
+interface files for types mentioned in the arg types.
+
+E.g.
+        data Foo.S = MkS Baz.T
+Maybe we can get away without even loading the interface for Baz!
+
+This is not just a performance thing.  Suppose we have
+        data Foo.S = MkS Baz.T
+        data Baz.T = MkT Foo.S
+(in different interface files, of course).
+Now, first we load and typecheck Foo.S, and add it to the type envt.
+If we do explore MkS's argument, we'll load and typecheck Baz.T.
+If we explore MkT's argument we'll find Foo.S already in the envt.
+
+If we typechecked constructor args eagerly, when loading Foo.S we'd try to
+typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
+which isn't done yet.
+
+All very cunning. However, there is a rather subtle gotcha which bit
+me when developing this stuff.  When we typecheck the decl for S, we
+extend the type envt with S, MkS, and all its implicit Ids.  Suppose
+(a bug, but it happened) that the list of implicit Ids depended in
+turn on the constructor arg types.  Then the following sequence of
+events takes place:
+        * we build a thunk <t> for the constructor arg tys
+        * we build a thunk for the extended type environment (depends on <t>)
+        * we write the extended type envt into the global EPS mutvar
+
+Now we look something up in the type envt
+        * that pulls on <t>
+        * which reads the global type envt out of the global EPS mutvar
+        * but that depends in turn on <t>
+
+It's subtle, because, it'd work fine if we typechecked the constructor args
+eagerly -- they don't need the extended type envt.  They just get the extended
+type envt by accident, because they look at it later.
+
+What this means is that the implicitTyThings MUST NOT DEPEND on any of
+the forkM stuff.
+-}
+
+tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings
+            -> IfaceDecl
+            -> IfL TyThing
+tcIfaceDecl = tc_iface_decl Nothing
+
+tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations
+              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings
+              -> IfaceDecl
+              -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
+                                       ifIdDetails = details, ifIdInfo = info})
+  = do  { ty <- tcIfaceType iface_type
+        ; details <- tcIdDetails ty details
+        ; info <- tcIdInfo ignore_prags TopLevel name ty info
+        ; return (AnId (mkGlobalId details name ty info)) }
+
+tc_iface_decl _ _ (IfaceData {ifName = tc_name,
+                          ifCType = cType,
+                          ifBinders = binders,
+                          ifResKind = res_kind,
+                          ifRoles = roles,
+                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+                          ifCons = rdr_cons,
+                          ifParent = mb_parent })
+  = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+    { res_kind' <- tcIfaceType res_kind
+
+    ; tycon <- fixM $ \ tycon -> do
+            { stupid_theta <- tcIfaceCtxt ctxt
+            ; parent' <- tc_parent tc_name mb_parent
+            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
+            ; return (mkAlgTyCon tc_name binders' res_kind'
+                                 roles cType stupid_theta
+                                 cons parent' gadt_syn) }
+    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+    ; return (ATyCon tycon) }
+  where
+    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
+    tc_parent tc_name IfNoParent
+      = do { tc_rep_name <- newTyConRepName tc_name
+           ; return (VanillaAlgTyCon tc_rep_name) }
+    tc_parent _ (IfDataInstance ax_name _ arg_tys)
+      = do { ax <- tcIfaceCoAxiom ax_name
+           ; let fam_tc  = coAxiomTyCon ax
+                 ax_unbr = toUnbranchedAxiom ax
+           ; lhs_tys <- tcIfaceAppArgs arg_tys
+           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
+
+tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
+                                      ifRoles = roles,
+                                      ifSynRhs = rhs_ty,
+                                      ifBinders = binders,
+                                      ifResKind = res_kind })
+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]
+     ; rhs      <- forkM (mk_doc tc_name) $
+                   tcIfaceType rhs_ty
+     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
+     ; return (ATyCon tycon) }
+   where
+     mk_doc n = text "Type synonym" <+> ppr n
+
+tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
+                                     ifFamFlav = fam_flav,
+                                     ifBinders = binders,
+                                     ifResKind = res_kind,
+                                     ifResVar = res, ifFamInj = inj })
+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]
+     ; rhs      <- forkM (mk_doc tc_name) $
+                   tc_fam_flav tc_name fam_flav
+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
+     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
+     ; return (ATyCon tycon) }
+   where
+     mk_doc n = text "Type synonym" <+> ppr n
+
+     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
+     tc_fam_flav tc_name IfaceDataFamilyTyCon
+       = do { tc_rep_name <- newTyConRepName tc_name
+            ; return (DataFamilyTyCon tc_rep_name) }
+     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
+     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
+       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
+            ; return (ClosedSynFamilyTyCon ax) }
+     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
+         = return AbstractClosedSynFamilyTyCon
+     tc_fam_flav _ IfaceBuiltInSynFamTyCon
+         = pprPanic "tc_iface_decl"
+                    (text "IfaceBuiltInSynFamTyCon in interface file")
+
+tc_iface_decl _parent _ignore_prags
+            (IfaceClass {ifName = tc_name,
+                         ifRoles = roles,
+                         ifBinders = binders,
+                         ifFDs = rdr_fds,
+                         ifBody = IfAbstractClass})
+  = bindIfaceTyConBinders binders $ \ binders' -> do
+    { fds  <- mapM tc_fd rdr_fds
+    ; cls  <- buildClass tc_name binders' roles fds Nothing
+    ; return (ATyCon (classTyCon cls)) }
+
+tc_iface_decl _parent ignore_prags
+            (IfaceClass {ifName = tc_name,
+                         ifRoles = roles,
+                         ifBinders = binders,
+                         ifFDs = rdr_fds,
+                         ifBody = IfConcreteClass {
+                             ifClassCtxt = rdr_ctxt,
+                             ifATs = rdr_ats, ifSigs = rdr_sigs,
+                             ifMinDef = mindef_occ
+                         }})
+  = bindIfaceTyConBinders binders $ \ binders' -> do
+    { traceIf (text "tc-iface-class1" <+> ppr tc_name)
+    ; ctxt <- mapM tc_sc rdr_ctxt
+    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
+    ; sigs <- mapM tc_sig rdr_sigs
+    ; fds  <- mapM tc_fd rdr_fds
+    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
+    ; cls  <- fixM $ \ cls -> do
+              { ats  <- mapM (tc_at cls) rdr_ats
+              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
+              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
+    ; return (ATyCon (classTyCon cls)) }
+  where
+   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
+        -- The *length* of the superclasses is used by buildClass, and hence must
+        -- not be inside the thunk.  But the *content* maybe recursive and hence
+        -- must be lazy (via forkM).  Example:
+        --     class C (T a) => D a where
+        --       data T a
+        -- Here the associated type T is knot-tied with the class, and
+        -- so we must not pull on T too eagerly.  See #5970
+
+   tc_sig :: IfaceClassOp -> IfL TcMethInfo
+   tc_sig (IfaceClassOp op_name rdr_ty dm)
+     = do { let doc = mk_op_doc op_name rdr_ty
+          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
+                -- Must be done lazily for just the same reason as the
+                -- type of a data con; to avoid sucking in types that
+                -- it mentions unless it's necessary to do so
+          ; dm'   <- tc_dm doc dm
+          ; return (op_name, op_ty, dm') }
+
+   tc_dm :: SDoc
+         -> Maybe (DefMethSpec IfaceType)
+         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
+   tc_dm _   Nothing               = return Nothing
+   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)
+   tc_dm doc (Just (GenericDM ty))
+        = do { -- Must be done lazily to avoid sucking in types
+             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
+             ; return (Just (GenericDM (noSrcSpan, ty'))) }
+
+   tc_at cls (IfaceAT tc_decl if_def)
+     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
+          mb_def <- case if_def of
+                      Nothing  -> return Nothing
+                      Just def -> forkM (mk_at_doc tc)                 $
+                                  extendIfaceTyVarEnv (tyConTyVars tc) $
+                                  do { tc_def <- tcIfaceType def
+                                     ; return (Just (tc_def, noSrcSpan)) }
+                  -- Must be done lazily in case the RHS of the defaults mention
+                  -- the type constructor being defined here
+                  -- e.g.   type AT a; type AT b = AT [b]   #8002
+          return (ATI tc mb_def)
+
+   mk_sc_doc pred = text "Superclass" <+> ppr pred
+   mk_at_doc tc = text "Associated type" <+> ppr tc
+   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
+
+tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
+                              , ifAxBranches = branches, ifRole = role })
+  = do { tc_tycon    <- tcIfaceTyCon tc
+       -- Must be done lazily, because axioms are forced when checking
+       -- for family instance consistency, and the RHS may mention
+       -- a hs-boot declared type constructor that is going to be
+       -- defined by this module.
+       -- e.g. type instance F Int = ToBeDefined
+       -- See #13803
+       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
+                      $ tc_ax_branches branches
+       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
+                             , co_ax_name     = tc_name
+                             , co_ax_tc       = tc_tycon
+                             , co_ax_role     = role
+                             , co_ax_branches = manyBranches tc_branches
+                             , co_ax_implicit = False }
+       ; return (ACoAxiom axiom) }
+
+tc_iface_decl _ _ (IfacePatSyn{ ifName = name
+                              , ifPatMatcher = if_matcher
+                              , ifPatBuilder = if_builder
+                              , ifPatIsInfix = is_infix
+                              , ifPatUnivBndrs = univ_bndrs
+                              , ifPatExBndrs = ex_bndrs
+                              , ifPatProvCtxt = prov_ctxt
+                              , ifPatReqCtxt = req_ctxt
+                              , ifPatArgs = args
+                              , ifPatTy = pat_ty
+                              , ifFieldLabels = field_labels })
+  = do { traceIf (text "tc_iface_decl" <+> ppr name)
+       ; matcher <- tc_pr if_matcher
+       ; builder <- fmapMaybeM tc_pr if_builder
+       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
+       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
+       { patsyn <- forkM (mk_doc name) $
+             do { prov_theta <- tcIfaceCtxt prov_ctxt
+                ; req_theta  <- tcIfaceCtxt req_ctxt
+                ; pat_ty     <- tcIfaceType pat_ty
+                ; arg_tys    <- mapM tcIfaceType args
+                ; return $ buildPatSyn name is_infix matcher builder
+                                       (univ_tvs, req_theta)
+                                       (ex_tvs, prov_theta)
+                                       arg_tys pat_ty field_labels }
+       ; return $ AConLike . PatSynCon $ patsyn }}}
+  where
+     mk_doc n = text "Pattern synonym" <+> ppr n
+     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
+     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
+                        ; return (id, b) }
+
+tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
+tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
+                        ; tvs2' <- mapM tcIfaceTyVar tvs2
+                        ; return (tvs1', tvs2') }
+
+tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
+
+tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
+tc_ax_branch prev_branches
+             (IfaceAxBranch { ifaxbTyVars = tv_bndrs
+                            , ifaxbEtaTyVars = eta_tv_bndrs
+                            , ifaxbCoVars = cv_bndrs
+                            , ifaxbLHS = lhs, ifaxbRHS = rhs
+                            , ifaxbRoles = roles, ifaxbIncomps = incomps })
+  = bindIfaceTyConBinders_AT
+      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
+         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
+    bindIfaceIds cv_bndrs $ \ cvs -> do
+    { tc_lhs   <- tcIfaceAppArgs lhs
+    ; tc_rhs   <- tcIfaceType rhs
+    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return
+    ; this_mod <- getIfModule
+    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`
+                                  moduleNameFS (moduleName this_mod))
+          br = CoAxBranch { cab_loc     = loc
+                          , cab_tvs     = binderVars tvs
+                          , cab_eta_tvs = eta_tvs
+                          , cab_cvs     = cvs
+                          , cab_lhs     = tc_lhs
+                          , cab_roles   = roles
+                          , cab_rhs     = tc_rhs
+                          , cab_incomps = map (prev_branches `getNth`) incomps }
+    ; return (prev_branches ++ [br]) }
+
+tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
+  = case if_cons of
+        IfAbstractTyCon  -> return AbstractTyCon
+        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons
+                                ; return (mkDataTyConRhs data_cons) }
+        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con
+                                ; mkNewTyConRhs tycon_name tycon data_con }
+  where
+    univ_tvs :: [TyVar]
+    univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
+
+    tag_map :: NameEnv ConTag
+    tag_map = mkTyConTagMap tycon
+
+    tc_con_decl (IfCon { ifConInfix = is_infix,
+                         ifConExTCvs = ex_bndrs,
+                         ifConUserTvBinders = user_bndrs,
+                         ifConName = dc_name,
+                         ifConCtxt = ctxt, ifConEqSpec = spec,
+                         ifConArgTys = args, ifConFields = lbl_names,
+                         ifConStricts = if_stricts,
+                         ifConSrcStricts = if_src_stricts})
+     = -- Universally-quantified tyvars are shared with
+       -- parent TyCon, and are already in scope
+       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do
+        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
+
+          -- By this point, we have bound every universal and existential
+          -- tyvar. Because of the dcUserTyVarBinders invariant
+          -- (see Note [DataCon user type variable binders]), *every* tyvar in
+          -- ifConUserTvBinders has a matching counterpart somewhere in the
+          -- bound universals/existentials. As a result, calling tcIfaceTyVar
+          -- below is always guaranteed to succeed.
+        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->
+                                   case bd of
+                                     IfaceIdBndr (name, _) ->
+                                       Bndr <$> tcIfaceLclId name <*> pure vis
+                                     IfaceTvBndr (name, _) ->
+                                       Bndr <$> tcIfaceTyVar name <*> pure vis)
+                                user_bndrs
+
+        -- Read the context and argument types, but lazily for two reasons
+        -- (a) to avoid looking tugging on a recursive use of
+        --     the type itself, which is knot-tied
+        -- (b) to avoid faulting in the component types unless
+        --     they are really needed
+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
+             do { eq_spec <- tcIfaceEqSpec spec
+                ; theta   <- tcIfaceCtxt ctxt
+                -- This fixes #13710.  The enclosing lazy thunk gets
+                -- forced when typechecking record wildcard pattern
+                -- matching (it's not completely clear why this
+                -- tuple is needed), which causes trouble if one of
+                -- the argument types was recursively defined.
+                -- See also Note [Tying the knot]
+                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
+                           $ mapM tcIfaceType args
+                ; stricts <- mapM tc_strict if_stricts
+                        -- The IfBang field can mention
+                        -- the type itself; hence inside forkM
+                ; return (eq_spec, theta, arg_tys, stricts) }
+
+        -- Remember, tycon is the representation tycon
+        ; let orig_res_ty = mkFamilyTyConApp tycon
+                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))
+                                             (binderVars tc_tybinders))
+
+        ; prom_rep_name <- newTyConRepName dc_name
+
+        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
+                       dc_name is_infix prom_rep_name
+                       (map src_strict if_src_stricts)
+                       (Just stricts)
+                       -- Pass the HsImplBangs (i.e. final
+                       -- decisions) to buildDataCon; it'll use
+                       -- these to guide the construction of a
+                       -- worker.
+                       -- See Note [Bangs on imported data constructors] in MkId
+                       lbl_names
+                       univ_tvs ex_tvs user_tv_bndrs
+                       eq_spec theta
+                       arg_tys orig_res_ty tycon tag_map
+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
+        ; return con }
+    mk_doc con_name = text "Constructor" <+> ppr con_name
+
+    tc_strict :: IfaceBang -> IfL HsImplBang
+    tc_strict IfNoBang = return (HsLazy)
+    tc_strict IfStrict = return (HsStrict)
+    tc_strict IfUnpack = return (HsUnpack Nothing)
+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
+                                      ; return (HsUnpack (Just co)) }
+
+    src_strict :: IfaceSrcBang -> HsSrcBang
+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
+
+tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
+tcIfaceEqSpec spec
+  = mapM do_item spec
+  where
+    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
+                              ; ty <- tcIfaceType if_ty
+                              ; return (mkEqSpec tv ty) }
+
+{-
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff).  To see why,
+consider this (#2412)
+
+M.hs:       module M where { import X; data T = MkT S }
+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot:  module M where { data T }
+
+When kind-checking M.hs we need S's kind.  But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
+
+************************************************************************
+*                                                                      *
+                Instances
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceInst :: IfaceClsInst -> IfL ClsInst
+tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
+                          , ifInstCls = cls, ifInstTys = mb_tcs
+                          , ifInstOrph = orph })
+  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
+                    fmap tyThingId (tcIfaceImplicit dfun_name)
+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
+
+tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
+                             , ifFamInstAxiom = axiom_name } )
+    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
+                     tcIfaceCoAxiom axiom_name
+             -- will panic if branched, but that's OK
+         ; let axiom'' = toUnbranchedAxiom axiom'
+               mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+         ; return (mkImportedFamInst fam mb_tcs' axiom'') }
+
+{-
+************************************************************************
+*                                                                      *
+                Rules
+*                                                                      *
+************************************************************************
+
+We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
+are in the type environment.  However, remember that typechecking a Rule may
+(as a side effect) augment the type envt, and so we may need to iterate the process.
+-}
+
+tcIfaceRules :: Bool            -- True <=> ignore rules
+             -> [IfaceRule]
+             -> IfL [CoreRule]
+tcIfaceRules ignore_prags if_rules
+  | ignore_prags = return []
+  | otherwise    = mapM tcIfaceRule if_rules
+
+tcIfaceRule :: IfaceRule -> IfL CoreRule
+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
+                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+                        ifRuleAuto = auto, ifRuleOrph = orph })
+  = do  { ~(bndrs', args', rhs') <-
+                -- Typecheck the payload lazily, in the hope it'll never be looked at
+                forkM (text "Rule" <+> pprRuleName name) $
+                bindIfaceBndrs bndrs                      $ \ bndrs' ->
+                do { args' <- mapM tcIfaceExpr args
+                   ; rhs'  <- tcIfaceExpr rhs
+                   ; return (bndrs', args', rhs') }
+        ; let mb_tcs = map ifTopFreeName args
+        ; this_mod <- getIfModule
+        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
+                          ru_bndrs = bndrs', ru_args = args',
+                          ru_rhs = occurAnalyseExpr rhs',
+                          ru_rough = mb_tcs,
+                          ru_origin = this_mod,
+                          ru_orphan = orph,
+                          ru_auto = auto,
+                          ru_local = False }) } -- An imported RULE is never for a local Id
+                                                -- or, even if it is (module loop, perhaps)
+                                                -- we'll just leave it in the non-local set
+  where
+        -- This function *must* mirror exactly what Rules.roughTopNames does
+        -- We could have stored the ru_rough field in the iface file
+        -- but that would be redundant, I think.
+        -- The only wrinkle is that we must not be deceived by
+        -- type synonyms at the top of a type arg.  Since
+        -- we can't tell at this point, we are careful not
+        -- to write them out in coreRuleToIfaceRule
+    ifTopFreeName :: IfaceExpr -> Maybe Name
+    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
+    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
+    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
+    ifTopFreeName (IfaceExt n)                      = Just n
+    ifTopFreeName _                                 = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+                Annotations
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceAnnotations = mapM tcIfaceAnnotation
+
+tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
+tcIfaceAnnotation (IfaceAnnotation target serialized) = do
+    target' <- tcIfaceAnnTarget target
+    return $ Annotation {
+        ann_target = target',
+        ann_value = serialized
+    }
+
+tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
+tcIfaceAnnTarget (NamedTarget occ) = do
+    name <- lookupIfaceTop occ
+    return $ NamedTarget name
+tcIfaceAnnTarget (ModuleTarget mod) = do
+    return $ ModuleTarget mod
+
+{-
+************************************************************************
+*                                                                      *
+                Complete Match Pragmas
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
+
+tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
+tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
+
+{-
+************************************************************************
+*                                                                      *
+                        Types
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceType :: IfaceType -> IfL Type
+tcIfaceType = go
+  where
+    go (IfaceTyVar n)          = TyVarTy <$> tcIfaceTyVar n
+    go (IfaceFreeTyVar n)      = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
+    go (IfaceLitTy l)          = LitTy <$> tcIfaceTyLit l
+    go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2
+    go (IfaceTupleTy s i tks)  = tcIfaceTupleTy s i tks
+    go (IfaceAppTy t ts)
+      = do { t'  <- go t
+           ; ts' <- traverse go (appArgsIfaceTypes ts)
+           ; pure (foldl' AppTy t' ts') }
+    go (IfaceTyConApp tc tks)
+      = do { tc' <- tcIfaceTyCon tc
+           ; tks' <- mapM go (appArgsIfaceTypes tks)
+           ; return (mkTyConApp tc' tks') }
+    go (IfaceForAllTy bndr t)
+      = bindIfaceForAllBndr bndr $ \ tv' vis ->
+        ForAllTy (Bndr tv' vis) <$> go t
+    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
+    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
+
+tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
+tcIfaceTupleTy sort is_promoted args
+ = do { args' <- tcIfaceAppArgs args
+      ; let arity = length args'
+      ; base_tc <- tcTupleTyCon True sort arity
+      ; case is_promoted of
+          NotPromoted
+            -> return (mkTyConApp base_tc args')
+
+          IsPromoted
+            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)
+                        kind_args = map typeKind args'
+                  ; return (mkTyConApp tc (kind_args ++ args')) } }
+
+-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)
+             -> TupleSort
+             -> Arity   -- the number of args. *not* the tuple arity.
+             -> IfL TyCon
+tcTupleTyCon in_type sort arity
+  = case sort of
+      ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
+                            ; return (tyThingTyCon thing) }
+      BoxedTuple   -> return (tupleTyCon Boxed   arity)
+      UnboxedTuple -> return (tupleTyCon Unboxed arity')
+        where arity' | in_type   = arity `div` 2
+                     | otherwise = arity
+                      -- in expressions, we only have term args
+
+tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
+tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
+
+-----------------------------------------
+tcIfaceCtxt :: IfaceContext -> IfL ThetaType
+tcIfaceCtxt sts = mapM tcIfaceType sts
+
+-----------------------------------------
+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
+tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+
+{-
+%************************************************************************
+%*                                                                      *
+                        Coercions
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceCo :: IfaceCoercion -> IfL Coercion
+tcIfaceCo = go
+  where
+    go_mco IfaceMRefl    = pure MRefl
+    go_mco (IfaceMCo co) = MCo <$> (go co)
+
+    go (IfaceReflCo t)           = Refl <$> tcIfaceType t
+    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco
+    go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2
+    go (IfaceTyConAppCo r tc cs)
+      = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
+    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2
+    go (IfaceForAllCo tv k c)  = do { k' <- go k
+                                      ; bindIfaceBndr tv $ \ tv' ->
+                                        ForAllCo tv' k' <$> go c }
+    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n
+    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
+    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
+                                          <*> tcIfaceType t1 <*> tcIfaceType t2
+    go (IfaceSymCo c)            = SymCo    <$> go c
+    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1
+                                            <*> go c2
+    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1
+                                            <*> go t2
+    go (IfaceNthCo d c)          = do { c' <- go c
+                                      ; return $ mkNthCo (nthCoRole d c') d c' }
+    go (IfaceLRCo lr c)          = LRCo lr  <$> go c
+    go (IfaceKindCo c)           = KindCo   <$> go c
+    go (IfaceSubCo c)            = SubCo    <$> go c
+    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
+                                               <*> mapM go cos
+    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
+    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)
+
+    go_var :: FastString -> IfL CoVar
+    go_var = tcIfaceLclId
+
+tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
+tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv
+tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str
+
+{-
+************************************************************************
+*                                                                      *
+                        Core
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
+tcIfaceExpr (IfaceType ty)
+  = Type <$> tcIfaceType ty
+
+tcIfaceExpr (IfaceCo co)
+  = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
+tcIfaceExpr (IfaceLcl name)
+  = Var <$> tcIfaceLclId name
+
+tcIfaceExpr (IfaceExt gbl)
+  = Var <$> tcIfaceExtId gbl
+
+tcIfaceExpr (IfaceLit lit)
+  = do lit' <- tcIfaceLit lit
+       return (Lit lit')
+
+tcIfaceExpr (IfaceFCall cc ty) = do
+    ty' <- tcIfaceType ty
+    u <- newUnique
+    dflags <- getDynFlags
+    return (Var (mkFCallId dflags u cc ty'))
+
+tcIfaceExpr (IfaceTuple sort args)
+  = do { args' <- mapM tcIfaceExpr args
+       ; tc <- tcTupleTyCon False sort arity
+       ; let con_tys = map exprType args'
+             some_con_args = map Type con_tys ++ args'
+             con_args = case sort of
+               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
+               _            -> some_con_args
+                        -- Put the missing type arguments back in
+             con_id   = dataConWorkId (tyConSingleDataCon tc)
+       ; return (mkApps (Var con_id) con_args) }
+  where
+    arity = length args
+
+tcIfaceExpr (IfaceLam (bndr, os) body)
+  = bindIfaceBndr bndr $ \bndr' ->
+    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
+  where
+    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
+    tcIfaceOneShot _            b = b
+
+tcIfaceExpr (IfaceApp fun arg)
+  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+
+tcIfaceExpr (IfaceECase scrut ty)
+  = do { scrut' <- tcIfaceExpr scrut
+       ; ty' <- tcIfaceType ty
+       ; return (castBottomExpr scrut' ty') }
+
+tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
+    scrut' <- tcIfaceExpr scrut
+    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
+    let
+        scrut_ty   = exprType scrut'
+        case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
+        tc_app     = splitTyConApp scrut_ty
+                -- NB: Won't always succeed (polymorphic case)
+                --     but won't be demanded in those cases
+                -- NB: not tcSplitTyConApp; we are looking at Core here
+                --     look through non-rec newtypes to find the tycon that
+                --     corresponds to the datacon in this case alternative
+
+    extendIfaceIdEnv [case_bndr'] $ do
+     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
+     return (Case scrut' case_bndr' (coreAltsType alts') alts')
+
+tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
+  = do  { name    <- newIfaceName (mkVarOccFS fs)
+        ; ty'     <- tcIfaceType ty
+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                              NotTopLevel name ty' info
+        ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
+                     `asJoinId_maybe` tcJoinInfo ji
+        ; rhs' <- tcIfaceExpr rhs
+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+        ; return (Let (NonRec id rhs') body') }
+
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
+  = do { ids <- mapM tc_rec_bndr (map fst pairs)
+       ; extendIfaceIdEnv ids $ do
+       { pairs' <- zipWithM tc_pair pairs ids
+       ; body' <- tcIfaceExpr body
+       ; return (Let (Rec pairs') body') } }
+ where
+   tc_rec_bndr (IfLetBndr fs ty _ ji)
+     = do { name <- newIfaceName (mkVarOccFS fs)
+          ; ty'  <- tcIfaceType ty
+          ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
+   tc_pair (IfLetBndr _ _ info _, rhs) id
+     = do { rhs' <- tcIfaceExpr rhs
+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                                NotTopLevel (idName id) (idType id) info
+          ; return (setIdInfo id id_info, rhs') }
+
+tcIfaceExpr (IfaceTick tickish expr) = do
+    expr' <- tcIfaceExpr expr
+    -- If debug flag is not set: Ignore source notes
+    dbgLvl <- fmap debugLevel getDynFlags
+    case tickish of
+      IfaceSource{} | dbgLvl > 0
+                    -> return expr'
+      _otherwise    -> do
+        tickish' <- tcIfaceTickish tickish
+        return (Tick tickish' expr')
+
+-------------------------
+tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
+tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
+tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
+tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)
+
+-------------------------
+tcIfaceLit :: Literal -> IfL Literal
+-- Integer literals deserialise to (LitInteger i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Integer literals] in Literal
+tcIfaceLit (LitNumber LitNumInteger i _)
+  = do t <- tcIfaceTyConByName integerTyConName
+       return (mkLitInteger i (mkTyConTy t))
+-- Natural literals deserialise to (LitNatural i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Natural literals] in Literal
+tcIfaceLit (LitNumber LitNumNatural i _)
+  = do t <- tcIfaceTyConByName naturalTyConName
+       return (mkLitNatural i (mkTyConTy t))
+tcIfaceLit lit = return lit
+
+-------------------------
+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
+           -> (IfaceConAlt, [FastString], IfaceExpr)
+           -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceAlt _ _ (IfaceDefault, names, rhs)
+  = ASSERT( null names ) do
+    rhs' <- tcIfaceExpr rhs
+    return (DEFAULT, [], rhs')
+
+tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
+  = ASSERT( null names ) do
+    lit' <- tcIfaceLit lit
+    rhs' <- tcIfaceExpr rhs
+    return (LitAlt lit', [], rhs')
+
+-- A case alternative is made quite a bit more complicated
+-- by the fact that we omit type annotations because we can
+-- work them out.  True enough, but its not that easy!
+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
+  = do  { con <- tcIfaceDataCon data_occ
+        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
+               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
+        ; tcIfaceDataAlt con inst_tys arg_strs rhs }
+
+tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
+               -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceDataAlt con inst_tys arg_strs rhs
+  = do  { us <- newUniqueSupply
+        ; let uniqs = uniqsFromSupply us
+        ; let (ex_tvs, arg_ids)
+                      = dataConRepFSInstPat arg_strs uniqs con inst_tys
+
+        ; rhs' <- extendIfaceEnvs  ex_tvs       $
+                  extendIfaceIdEnv arg_ids      $
+                  tcIfaceExpr rhs
+        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
+
+{-
+************************************************************************
+*                                                                      *
+                IdInfo
+*                                                                      *
+************************************************************************
+-}
+
+tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
+tcIdDetails _  IfVanillaId = return VanillaId
+tcIdDetails ty IfDFunId
+  = return (DFunId (isNewTyCon (classTyCon cls)))
+  where
+    (_, _, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
+  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
+                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
+                       tc
+       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
+  where
+    tyThingPatSyn (AConLike (PatSynCon ps)) = ps
+    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
+
+tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags toplvl name ty info = do
+    lcl_env <- getLclEnv
+    -- Set the CgInfo to something sensible but uninformative before
+    -- we start; default assumption is that it has CAFs
+    let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
+                  | otherwise       = vanillaIdInfo
+    if ignore_prags
+        then return init_info
+        else case info of
+                NoInfo -> return init_info
+                HasInfo info -> foldlM tcPrag init_info info
+  where
+    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
+    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
+    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
+    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
+    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
+    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)
+
+        -- The next two are lazy, so they don't transitively suck stuff in
+    tcPrag info (HsUnfold lb if_unf)
+      = do { unf <- tcUnfolding toplvl name ty info if_unf
+           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker
+                       | otherwise = info
+           ; return (info1 `setUnfoldingInfo` unf) }
+
+tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
+tcJoinInfo (IfaceJoinPoint ar) = Just ar
+tcJoinInfo IfaceNotJoinPoint   = Nothing
+
+tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
+  = do  { dflags <- getDynFlags
+        ; mb_expr <- tcPragExpr toplvl name if_expr
+        ; let unf_src | stable    = InlineStable
+                      | otherwise = InlineRhs
+        ; return $ case mb_expr of
+            Nothing -> NoUnfolding
+            Just expr -> mkUnfolding dflags unf_src
+                           True {- Top level -}
+                           (isBottomingSig strict_sig)
+                           expr
+        }
+  where
+     -- Strictness should occur before unfolding!
+    strict_sig = strictnessInfo info
+tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
+  = do  { mb_expr <- tcPragExpr toplvl name if_expr
+        ; return (case mb_expr of
+                    Nothing   -> NoUnfolding
+                    Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+  = do  { mb_expr <- tcPragExpr toplvl name if_expr
+        ; return (case mb_expr of
+                    Nothing   -> NoUnfolding
+                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
+  where
+    guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
+
+tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
+  = bindIfaceBndrs bs $ \ bs' ->
+    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+       ; return (case mb_ops1 of
+                    Nothing   -> noUnfolding
+                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
+  where
+    doc = text "Class ops for dfun" <+> ppr name
+    (_, _, cls, _) = tcSplitDFunTy dfun_ty
+
+{-
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+-}
+
+tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr toplvl name expr
+  = forkM_maybe doc $ do
+    core_expr' <- tcIfaceExpr expr
+
+    -- Check for type consistency in the unfolding
+    -- See Note [Linting Unfoldings from Interfaces]
+    when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
+        in_scope <- get_in_scope
+        dflags   <- getDynFlags
+        case lintUnfolding dflags noSrcLoc in_scope core_expr' of
+          Nothing       -> return ()
+          Just fail_msg -> do { mod <- getIfModule
+                              ; pprPanic "Iface Lint failure"
+                                  (vcat [ text "In interface for" <+> ppr mod
+                                        , hang doc 2 fail_msg
+                                        , ppr name <+> equals <+> ppr core_expr'
+                                        , text "Iface expr =" <+> ppr expr ]) }
+    return core_expr'
+  where
+    doc = text "Unfolding of" <+> ppr name
+
+    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
+    get_in_scope
+        = do { (gbl_env, lcl_env) <- getEnvs
+             ; rec_ids <- case if_rec_types gbl_env of
+                            Nothing -> return []
+                            Just (_, get_env) -> do
+                               { type_env <- setLclEnv () get_env
+                               ; return (typeEnvIds type_env) }
+             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
+                       bindingsVars (if_id_env lcl_env) `unionVarSet`
+                       mkVarSet rec_ids) }
+
+    bindingsVars :: FastStringEnv Var -> VarSet
+    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
+      -- It's OK to use nonDetEltsUFM here because we immediately forget
+      -- the ordering by creating a set
+
+{-
+************************************************************************
+*                                                                      *
+                Getting from Names to TyThings
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceGlobal :: Name -> IfL TyThing
+tcIfaceGlobal name
+  | Just thing <- wiredInNameTyThing_maybe name
+        -- Wired-in things include TyCons, DataCons, and Ids
+        -- Even though we are in an interface file, we want to make
+        -- sure the instances and RULES of this thing (particularly TyCon) are loaded
+        -- Imagine: f :: Double -> Double
+  = do { ifCheckWiredInThing thing; return thing }
+
+  | otherwise
+  = do  { env <- getGblEnv
+        ; case if_rec_types env of {    -- Note [Tying the knot]
+            Just (mod, get_type_env)
+                | nameIsLocalOrFrom mod name
+                -> do           -- It's defined in the module being compiled
+                { type_env <- setLclEnv () get_type_env         -- yuk
+                ; case lookupNameEnv type_env name of
+                    Just thing -> return thing
+                    -- See Note [Knot-tying fallback on boot]
+                    Nothing   -> via_external
+                }
+
+          ; _ -> via_external }}
+  where
+    via_external =  do
+        { hsc_env <- getTopEnv
+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+        ; case mb_thing of {
+            Just thing -> return thing ;
+            Nothing    -> do
+
+        { mb_thing <- importDecl name   -- It's imported; go get it
+        ; case mb_thing of
+            Failed err      -> failIfM err
+            Succeeded thing -> return thing
+        }}}
+
+-- Note [Tying the knot]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- The if_rec_types field is used when we are compiling M.hs, which indirectly
+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
+-- environment, which is splatted into if_rec_types after we've built M's type
+-- envt.
+--
+-- This is a dark and complicated part of GHC type checking, with a lot
+-- of moving parts.  Interested readers should also look at:
+--
+--      * Note [Knot-tying typecheckIface]
+--      * Note [DFun knot-tying]
+--      * Note [hsc_type_env_var hack]
+--      * Note [Knot-tying fallback on boot]
+--
+-- There is also a wiki page on the subject, see:
+--
+--      https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot
+
+-- Note [Knot-tying fallback on boot]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Suppose that you are typechecking A.hs, which transitively imports,
+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
+-- has a reference to a type T from A, what TyThing should we wire
+-- it up with? Clearly, if we have already typechecked T and
+-- added it into the type environment, we should go ahead and use that
+-- type. But what if we haven't typechecked it yet?
+--
+-- For the longest time, GHC adopted the policy that this was
+-- *an error condition*; that you MUST NEVER poke on B.hs's reference
+-- to a T defined in A.hs until A.hs has gotten around to kind-checking
+-- T and adding it to the env. However, actually ensuring this is the
+-- case has proven to be a bug farm, because it's really difficult to
+-- actually ensure this never happens. The problem was especially poignant
+-- with type family consistency checks, which eagerly happen before any
+-- typechecking takes place.
+--
+-- Today, we take a different strategy: if we ever try to access
+-- an entity from A which doesn't exist, we just fall back on the
+-- definition of A from the hs-boot file. This is complicated in
+-- its own way: it means that you may end up with a mix of A.hs and
+-- A.hs-boot TyThings during the course of typechecking.  We don't
+-- think (and have not observed) any cases where this would cause
+-- problems, but the hypothetical situation one might worry about
+-- is something along these lines in Core:
+--
+--    case x of
+--        A -> e1
+--        B -> e2
+--
+-- If, when typechecking this, we find x :: T, and the T we are hooked
+-- up with is the abstract one from the hs-boot file, rather than the
+-- one defined in this module with constructors A and B.  But it's hard
+-- to see how this could happen, especially because the reference to
+-- the constructor (A and B) means that GHC will always typecheck
+-- this expression *after* typechecking T.
+
+tcIfaceTyConByName :: IfExtName -> IfL TyCon
+tcIfaceTyConByName name
+  = do { thing <- tcIfaceGlobal name
+       ; return (tyThingTyCon thing) }
+
+tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
+tcIfaceTyCon (IfaceTyCon name info)
+  = do { thing <- tcIfaceGlobal name
+       ; return $ case ifaceTyConIsPromoted info of
+           NotPromoted -> tyThingTyCon thing
+           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }
+
+tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
+tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
+                         ; return (tyThingCoAxiom thing) }
+
+
+tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
+-- Unlike CoAxioms, which arise form user 'type instance' declarations,
+-- there are a fixed set of CoAxiomRules,
+-- currently enumerated in typeNatCoAxiomRules
+tcIfaceCoAxiomRule n
+  = case Map.lookup n typeNatCoAxiomRules of
+        Just ax -> return ax
+        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
+
+tcIfaceDataCon :: Name -> IfL DataCon
+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
+                         ; case thing of
+                                AConLike (RealDataCon dc) -> return dc
+                                _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+
+tcIfaceExtId :: Name -> IfL Id
+tcIfaceExtId name = do { thing <- tcIfaceGlobal name
+                       ; case thing of
+                          AnId id -> return id
+                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+
+-- See Note [Resolving never-exported Names in TcIface]
+tcIfaceImplicit :: Name -> IfL TyThing
+tcIfaceImplicit n = do
+    lcl_env <- getLclEnv
+    case if_implicits_env lcl_env of
+        Nothing -> tcIfaceGlobal n
+        Just tenv ->
+            case lookupTypeEnv tenv n of
+                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
+                Just tything -> return tything
+
+{-
+************************************************************************
+*                                                                      *
+                Bindings
+*                                                                      *
+************************************************************************
+-}
+
+bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
+bindIfaceId (fs, ty) thing_inside
+  = do  { name <- newIfaceName (mkVarOccFS fs)
+        ; ty' <- tcIfaceType ty
+        ; let id = mkLocalIdOrCoVar name ty'
+        ; extendIfaceIdEnv [id] (thing_inside id) }
+
+bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIds [] thing_inside = thing_inside []
+bindIfaceIds (b:bs) thing_inside
+  = bindIfaceId b   $ \b'  ->
+    bindIfaceIds bs $ \bs' ->
+    thing_inside (b':bs')
+
+bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
+bindIfaceBndr (IfaceIdBndr bndr) thing_inside
+  = bindIfaceId bndr thing_inside
+bindIfaceBndr (IfaceTvBndr bndr) thing_inside
+  = bindIfaceTyVar bndr thing_inside
+
+bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
+bindIfaceBndrs []     thing_inside = thing_inside []
+bindIfaceBndrs (b:bs) thing_inside
+  = bindIfaceBndr b     $ \ b' ->
+    bindIfaceBndrs bs   $ \ bs' ->
+    thing_inside (b':bs')
+
+-----------------------
+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a
+bindIfaceForAllBndrs [] thing_inside = thing_inside []
+bindIfaceForAllBndrs (bndr:bndrs) thing_inside
+  = bindIfaceForAllBndr bndr $ \tv vis ->
+    bindIfaceForAllBndrs bndrs $ \bndrs' ->
+    thing_inside (mkTyCoVarBinder vis tv : bndrs')
+
+bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a
+bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside
+  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
+bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
+  = bindIfaceId tv $ \tv' -> thing_inside tv' vis
+
+bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
+bindIfaceTyVar (occ,kind) thing_inside
+  = do  { name <- newIfaceName (mkTyVarOccFS occ)
+        ; tyvar <- mk_iface_tyvar name kind
+        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
+
+bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+bindIfaceTyVars [] thing_inside = thing_inside []
+bindIfaceTyVars (bndr:bndrs) thing_inside
+  = bindIfaceTyVar bndr   $ \tv  ->
+    bindIfaceTyVars bndrs $ \tvs ->
+    thing_inside (tv : tvs)
+
+mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
+mk_iface_tyvar name ifKind
+   = do { kind <- tcIfaceType ifKind
+        ; return (Var.mkTyVar name kind) }
+
+bindIfaceTyConBinders :: [IfaceTyConBinder]
+                      -> ([TyConBinder] -> IfL a) -> IfL a
+bindIfaceTyConBinders [] thing_inside = thing_inside []
+bindIfaceTyConBinders (b:bs) thing_inside
+  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->
+    bindIfaceTyConBinders bs              $ \ bs' ->
+    thing_inside (b':bs')
+
+bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
+                         -> ([TyConBinder] -> IfL a) -> IfL a
+-- Used for type variable in nested associated data/type declarations
+-- where some of the type variables are already in scope
+--    class C a where { data T a b }
+-- Here 'a' is in scope when we look at the 'data T'
+bindIfaceTyConBinders_AT [] thing_inside
+  = thing_inside []
+bindIfaceTyConBinders_AT (b : bs) thing_inside
+  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->
+    bindIfaceTyConBinders_AT      bs $ \bs' ->
+    thing_inside (b':bs')
+  where
+    bind_tv tv thing
+      = do { mb_tv <- lookupIfaceVar tv
+           ; case mb_tv of
+               Just b' -> thing b'
+               Nothing -> bindIfaceBndr tv thing }
+
+bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
+                      -> IfaceTyConBinder
+                      -> (TyConBinder -> IfL a) -> IfL a
+bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
+  = bind_tv tv $ \tv' ->
+    thing_inside (Bndr tv' vis)
diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/iface/TcIface.hs-boot
@@ -0,0 +1,19 @@
+module TcIface where
+
+import GhcPrelude
+import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,
+                     IfaceAnnotation, IfaceCompleteMatch )
+import TyCoRep     ( TyThing )
+import TcRnTypes   ( IfL )
+import InstEnv     ( ClsInst )
+import FamInstEnv  ( FamInst )
+import CoreSyn     ( CoreRule )
+import HscTypes    ( CompleteMatch )
+import Annotations ( Annotation )
+
+tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing
+tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]
+tcIfaceInst         :: IfaceClsInst -> IfL ClsInst
+tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst
+tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm.hs
@@ -0,0 +1,64 @@
+-- ----------------------------------------------------------------------------
+-- | This module supplies bindings to generate Llvm IR from Haskell
+-- (<http://www.llvm.org/docs/LangRef.html>).
+--
+-- Note: this module is developed in a demand driven way. It is no complete
+-- LLVM binding library in Haskell, but enough to generate code for GHC.
+--
+-- This code is derived from code taken from the Essential Haskell Compiler
+-- (EHC) project (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).
+--
+
+module Llvm (
+
+        -- * Modules, Functions and Blocks
+        LlvmModule(..),
+
+        LlvmFunction(..), LlvmFunctionDecl(..),
+        LlvmFunctions, LlvmFunctionDecls,
+        LlvmStatement(..), LlvmExpression(..),
+        LlvmBlocks, LlvmBlock(..), LlvmBlockId,
+        LlvmParamAttr(..), LlvmParameter,
+
+        -- * Atomic operations
+        LlvmAtomicOp(..),
+
+        -- * Fence synchronization
+        LlvmSyncOrdering(..),
+
+        -- * Call Handling
+        LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
+        LlvmLinkageType(..), LlvmFuncAttr(..),
+
+        -- * Operations and Comparisons
+        LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),
+
+        -- * Variables and Type System
+        LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
+        LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
+        LMConst(..),
+
+        -- ** Some basic types
+        i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
+
+        -- ** Metadata types
+        MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
+
+        -- ** Operations on the type system.
+        isGlobal, getLitType, getVarType,
+        getLink, getStatType, pVarLift, pVarLower,
+        pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
+
+        -- * Pretty Printing
+        ppLit, ppName, ppPlainName,
+        ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
+        ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
+        ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
+
+    ) where
+
+import Llvm.AbsSyn
+import Llvm.MetaData
+import Llvm.PpLlvm
+import Llvm.Types
+
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -0,0 +1,352 @@
+--------------------------------------------------------------------------------
+-- | The LLVM abstract syntax.
+--
+
+module Llvm.AbsSyn where
+
+import GhcPrelude
+
+import Llvm.MetaData
+import Llvm.Types
+
+import Unique
+
+-- | Block labels
+type LlvmBlockId = Unique
+
+-- | A block of LLVM code.
+data LlvmBlock = LlvmBlock {
+    -- | The code label for this block
+    blockLabel :: LlvmBlockId,
+
+    -- | A list of LlvmStatement's representing the code for this block.
+    -- This list must end with a control flow statement.
+    blockStmts :: [LlvmStatement]
+  }
+
+type LlvmBlocks = [LlvmBlock]
+
+-- | An LLVM Module. This is a top level container in LLVM.
+data LlvmModule = LlvmModule  {
+    -- | Comments to include at the start of the module.
+    modComments  :: [LMString],
+
+    -- | LLVM Alias type definitions.
+    modAliases   :: [LlvmAlias],
+
+    -- | LLVM meta data.
+    modMeta      :: [MetaDecl],
+
+    -- | Global variables to include in the module.
+    modGlobals   :: [LMGlobal],
+
+    -- | LLVM Functions used in this module but defined in other modules.
+    modFwdDecls  :: LlvmFunctionDecls,
+
+    -- | LLVM Functions defined in this module.
+    modFuncs     :: LlvmFunctions
+  }
+
+-- | An LLVM Function
+data LlvmFunction = LlvmFunction {
+    -- | The signature of this declared function.
+    funcDecl      :: LlvmFunctionDecl,
+
+    -- | The functions arguments
+    funcArgs      :: [LMString],
+
+    -- | The function attributes.
+    funcAttrs     :: [LlvmFuncAttr],
+
+    -- | The section to put the function into,
+    funcSect      :: LMSection,
+
+    -- | Prefix data
+    funcPrefix    :: Maybe LlvmStatic,
+
+    -- | The body of the functions.
+    funcBody      :: LlvmBlocks
+  }
+
+type LlvmFunctions = [LlvmFunction]
+
+type SingleThreaded = Bool
+
+-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM
+-- 3.0). Please see the LLVM documentation for a better description.
+data LlvmSyncOrdering
+  -- | Some partial order of operations exists.
+  = SyncUnord
+  -- | A single total order for operations at a single address exists.
+  | SyncMonotonic
+  -- | Acquire synchronization operation.
+  | SyncAcquire
+  -- | Release synchronization operation.
+  | SyncRelease
+  -- | Acquire + Release synchronization operation.
+  | SyncAcqRel
+  -- | Full sequential Consistency operation.
+  | SyncSeqCst
+  deriving (Show, Eq)
+
+-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in
+-- the LLVM documentation for a complete description.
+data LlvmAtomicOp
+  = LAO_Xchg
+  | LAO_Add
+  | LAO_Sub
+  | LAO_And
+  | LAO_Nand
+  | LAO_Or
+  | LAO_Xor
+  | LAO_Max
+  | LAO_Min
+  | LAO_Umax
+  | LAO_Umin
+  deriving (Show, Eq)
+
+-- | Llvm Statements
+data LlvmStatement
+  {- |
+    Assign an expression to a variable:
+      * dest:   Variable to assign to
+      * source: Source expression
+  -}
+  = Assignment LlvmVar LlvmExpression
+
+  {- |
+    Memory fence operation
+  -}
+  | Fence Bool LlvmSyncOrdering
+
+  {- |
+    Always branch to the target label
+  -}
+  | Branch LlvmVar
+
+  {- |
+    Branch to label targetTrue if cond is true otherwise to label targetFalse
+      * cond:        condition that will be tested, must be of type i1
+      * targetTrue:  label to branch to if cond is true
+      * targetFalse: label to branch to if cond is false
+  -}
+  | BranchIf LlvmVar LlvmVar LlvmVar
+
+  {- |
+    Comment
+    Plain comment.
+  -}
+  | Comment [LMString]
+
+  {- |
+    Set a label on this position.
+      * name: Identifier of this label, unique for this module
+  -}
+  | MkLabel LlvmBlockId
+
+  {- |
+    Store variable value in pointer ptr. If value is of type t then ptr must
+    be of type t*.
+      * value: Variable/Constant to store.
+      * ptr:   Location to store the value in
+  -}
+  | Store LlvmVar LlvmVar
+
+  {- |
+    Multiway branch
+      * scrutinee: Variable or constant which must be of integer type that is
+                   determines which arm is chosen.
+      * def:       The default label if there is no match in target.
+      * target:    A list of (value,label) where the value is an integer
+                   constant and label the corresponding label to jump to if the
+                   scrutinee matches the value.
+  -}
+  | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)]
+
+  {- |
+    Return a result.
+      * result: The variable or constant to return
+  -}
+  | Return (Maybe LlvmVar)
+
+  {- |
+    An instruction for the optimizer that the code following is not reachable
+  -}
+  | Unreachable
+
+  {- |
+    Raise an expression to a statement (if don't want result or want to use
+    Llvm unnamed values.
+  -}
+  | Expr LlvmExpression
+
+  {- |
+    A nop LLVM statement. Useful as its often more efficient to use this
+    then to wrap LLvmStatement in a Just or [].
+  -}
+  | Nop
+
+  {- |
+    A LLVM statement with metadata attached to it.
+  -}
+  | MetaStmt [MetaAnnot] LlvmStatement
+
+  deriving (Eq)
+
+
+-- | Llvm Expressions
+data LlvmExpression
+  {- |
+    Allocate amount * sizeof(tp) bytes on the stack
+      * tp:     LlvmType to reserve room for
+      * amount: The nr of tp's which must be allocated
+  -}
+  = Alloca LlvmType Int
+
+  {- |
+    Perform the machine operator op on the operands left and right
+      * op:    operator
+      * left:  left operand
+      * right: right operand
+  -}
+  | LlvmOp LlvmMachOp LlvmVar LlvmVar
+
+  {- |
+    Perform a compare operation on the operands left and right
+      * op:    operator
+      * left:  left operand
+      * right: right operand
+  -}
+  | Compare LlvmCmpOp LlvmVar LlvmVar
+
+  {- |
+    Extract a scalar element from a vector
+      * val: The vector
+      * idx: The index of the scalar within the vector
+  -}
+  | Extract LlvmVar LlvmVar
+
+  {- |
+    Extract a scalar element from a structure
+      * val: The structure
+      * idx: The index of the scalar within the structure
+    Corresponds to "extractvalue" instruction.
+  -}
+  | ExtractV LlvmVar Int
+
+  {- |
+    Insert a scalar element into a vector
+      * val:   The source vector
+      * elt:   The scalar to insert
+      * index: The index at which to insert the scalar
+  -}
+  | Insert LlvmVar LlvmVar LlvmVar
+
+  {- |
+    Allocate amount * sizeof(tp) bytes on the heap
+      * tp:     LlvmType to reserve room for
+      * amount: The nr of tp's which must be allocated
+  -}
+  | Malloc LlvmType Int
+
+  {- |
+    Load the value at location ptr
+  -}
+  | Load LlvmVar
+
+  {- |
+    Atomic load of the value at location ptr
+  -}
+  | ALoad LlvmSyncOrdering SingleThreaded LlvmVar
+
+  {- |
+    Navigate in a structure, selecting elements
+      * inbound: Is the pointer inbounds? (computed pointer doesn't overflow)
+      * ptr:     Location of the structure
+      * indexes: A list of indexes to select the correct value.
+  -}
+  | GetElemPtr Bool LlvmVar [LlvmVar]
+
+  {- |
+    Cast the variable from to the to type. This is an abstraction of three
+    cast operators in Llvm, inttoptr, ptrtoint and bitcast.
+       * cast: Cast type
+       * from: Variable to cast
+       * to:   type to cast to
+  -}
+  | Cast LlvmCastOp LlvmVar LlvmType
+
+  {- |
+    Atomic read-modify-write operation
+       * op:       Atomic operation
+       * addr:     Address to modify
+       * operand:  Operand to operation
+       * ordering: Ordering requirement
+  -}
+  | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering
+
+  {- |
+    Compare-and-exchange operation
+       * addr:     Address to modify
+       * old:      Expected value
+       * new:      New value
+       * suc_ord:  Ordering required in success case
+       * fail_ord: Ordering required in failure case, can be no stronger than
+                   suc_ord
+
+    Result is an @i1@, true if store was successful.
+  -}
+  | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering
+
+  {- |
+    Call a function. The result is the value of the expression.
+      * tailJumps: CallType to signal if the function should be tail called
+      * fnptrval:  An LLVM value containing a pointer to a function to be
+                   invoked. Can be indirect. Should be LMFunction type.
+      * args:      Concrete arguments for the parameters
+      * attrs:     A list of function attributes for the call. Only NoReturn,
+                   NoUnwind, ReadOnly and ReadNone are valid here.
+  -}
+  | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr]
+
+  {- |
+    Call a function as above but potentially taking metadata as arguments.
+      * tailJumps: CallType to signal if the function should be tail called
+      * fnptrval:  An LLVM value containing a pointer to a function to be
+                   invoked. Can be indirect. Should be LMFunction type.
+      * args:      Arguments that may include metadata.
+      * attrs:     A list of function attributes for the call. Only NoReturn,
+                   NoUnwind, ReadOnly and ReadNone are valid here.
+  -}
+  | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr]
+
+  {- |
+    Merge variables from different basic blocks which are predecessors of this
+    basic block in a new variable of type tp.
+      * tp:         type of the merged variable, must match the types of the
+                    predecessor variables.
+      * predecessors: A list of variables and the basic block that they originate
+                      from.
+  -}
+  | Phi LlvmType [(LlvmVar,LlvmVar)]
+
+  {- |
+    Inline assembly expression. Syntax is very similar to the style used by GCC.
+      * assembly:    Actual inline assembly code.
+      * constraints: Operand constraints.
+      * return ty:   Return type of function.
+      * vars:        Any variables involved in the assembly code.
+      * sideeffect:  Does the expression have side effects not visible from the
+                     constraints list.
+      * alignstack:  Should the stack be conservatively aligned before this
+                     expression is executed.
+  -}
+  | Asm LMString LMString LlvmType [LlvmVar] Bool Bool
+
+  {- |
+    A LLVM expression with metadata attached to it.
+  -}
+  | MExpr [MetaAnnot] LlvmExpression
+
+  deriving (Eq)
+
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Llvm.MetaData where
+
+import GhcPrelude
+
+import Llvm.Types
+import Outputable
+
+-- The LLVM Metadata System.
+--
+-- The LLVM metadata feature is poorly documented but roughly follows the
+-- following design:
+-- * Metadata can be constructed in a few different ways (See below).
+-- * After which it can either be attached to LLVM statements to pass along
+-- extra information to the optimizer and code generator OR specifically named
+-- metadata has an affect on the whole module (i.e., linking behaviour).
+--
+--
+-- # Constructing metadata
+-- Metadata comes largely in three forms:
+--
+-- * Metadata expressions -- these are the raw metadata values that encode
+--   information. They consist of metadata strings, metadata nodes, regular
+--   LLVM values (both literals and references to global variables) and
+--   metadata expressions (i.e., recursive data type). Some examples:
+--     !{ !"hello", !0, i32 0 }
+--     !{ !1, !{ i32 0 } }
+--
+-- * Metadata nodes -- global metadata variables that attach a metadata
+--   expression to a number. For example:
+--     !0 = !{ [<metadata expressions>] !}
+--
+-- * Named metadata -- global metadata variables that attach a metadata nodes
+--   to a name. Used ONLY to communicated module level information to LLVM
+--   through a meaningful name. For example:
+--     !llvm.module.linkage = !{ !0, !1 }
+--
+--
+-- # Using Metadata
+-- Using metadata depends on the form it is in:
+--
+-- * Attach to instructions -- metadata can be attached to LLVM instructions
+--   using a specific reference as follows:
+--     %l = load i32* @glob, !nontemporal !10
+--     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
+--   Only metadata nodes or expressions can be attached, named metadata cannot.
+--   Refer to LLVM documentation for which instructions take metadata and its
+--   meaning.
+--
+-- * As arguments -- llvm functions can take metadata as arguments, for
+--   example:
+--     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
+--   As with instructions, only metadata nodes or expressions can be attached.
+--
+-- * As a named metadata -- Here the metadata is simply declared in global
+--   scope using a specific name to communicate module level information to LLVM.
+--   For example:
+--     !llvm.module.linkage = !{ !0, !1 }
+--
+
+-- | A reference to an un-named metadata node.
+newtype MetaId = MetaId Int
+               deriving (Eq, Ord, Enum)
+
+instance Outputable MetaId where
+    ppr (MetaId n) = char '!' <> int n
+
+-- | LLVM metadata expressions
+data MetaExpr = MetaStr !LMString
+              | MetaNode !MetaId
+              | MetaVar !LlvmVar
+              | MetaStruct [MetaExpr]
+              deriving (Eq)
+
+instance Outputable MetaExpr where
+  ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
+  ppr (MetaStr    s ) = char '!' <> doubleQuotes (ftext s)
+  ppr (MetaNode   n ) = ppr n
+  ppr (MetaVar    v ) = ppr v
+  ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)
+
+-- | Associates some metadata with a specific label for attaching to an
+-- instruction.
+data MetaAnnot = MetaAnnot LMString MetaExpr
+               deriving (Eq)
+
+-- | Metadata declarations. Metadata can only be declared in global scope.
+data MetaDecl
+    -- | Named metadata. Only used for communicating module information to
+    -- LLVM. ('!name = !{ [!<n>] }' form).
+    = MetaNamed !LMString [MetaId]
+    -- | Metadata node declaration.
+    -- ('!0 = metadata !{ <metadata expression> }' form).
+    | MetaUnnamed !MetaId !MetaExpr
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -0,0 +1,499 @@
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- | Pretty print LLVM IR Code.
+--
+
+module Llvm.PpLlvm (
+
+    -- * Top level LLVM objects.
+    ppLlvmModule,
+    ppLlvmComments,
+    ppLlvmComment,
+    ppLlvmGlobals,
+    ppLlvmGlobal,
+    ppLlvmAliases,
+    ppLlvmAlias,
+    ppLlvmMetas,
+    ppLlvmMeta,
+    ppLlvmFunctionDecls,
+    ppLlvmFunctionDecl,
+    ppLlvmFunctions,
+    ppLlvmFunction,
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm.AbsSyn
+import Llvm.MetaData
+import Llvm.Types
+
+import Data.List ( intersperse )
+import Outputable
+import Unique
+import FastString ( sLit )
+
+--------------------------------------------------------------------------------
+-- * Top Level Print functions
+--------------------------------------------------------------------------------
+
+-- | Print out a whole LLVM module.
+ppLlvmModule :: LlvmModule -> SDoc
+ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
+  = ppLlvmComments comments $+$ newLine
+    $+$ ppLlvmAliases aliases $+$ newLine
+    $+$ ppLlvmMetas meta $+$ newLine
+    $+$ ppLlvmGlobals globals $+$ newLine
+    $+$ ppLlvmFunctionDecls decls $+$ newLine
+    $+$ ppLlvmFunctions funcs
+
+-- | Print out a multi-line comment, can be inside a function or on its own
+ppLlvmComments :: [LMString] -> SDoc
+ppLlvmComments comments = vcat $ map ppLlvmComment comments
+
+-- | Print out a comment, can be inside a function or on its own
+ppLlvmComment :: LMString -> SDoc
+ppLlvmComment com = semi <+> ftext com
+
+
+-- | Print out a list of global mutable variable definitions
+ppLlvmGlobals :: [LMGlobal] -> SDoc
+ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
+
+-- | Print out a global mutable variable definition
+ppLlvmGlobal :: LMGlobal -> SDoc
+ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
+    let sect = case x of
+            Just x' -> text ", section" <+> doubleQuotes (ftext x')
+            Nothing -> empty
+
+        align = case a of
+            Just a' -> text ", align" <+> int a'
+            Nothing -> empty
+
+        rhs = case dat of
+            Just stat -> pprSpecialStatic stat
+            Nothing   -> ppr (pLower $ getVarType var)
+
+        -- Position of linkage is different for aliases.
+        const = case c of
+          Global   -> "global"
+          Constant -> "constant"
+          Alias    -> "alias"
+
+    in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align
+       $+$ newLine
+
+ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
+  error $ "Non Global var ppr as global! "
+          ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
+
+
+-- | Print out a list of LLVM type aliases.
+ppLlvmAliases :: [LlvmAlias] -> SDoc
+ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
+
+-- | Print out an LLVM type alias.
+ppLlvmAlias :: LlvmAlias -> SDoc
+ppLlvmAlias (name, ty)
+  = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
+
+
+-- | Print out a list of LLVM metadata.
+ppLlvmMetas :: [MetaDecl] -> SDoc
+ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
+
+-- | Print out an LLVM metadata definition.
+ppLlvmMeta :: MetaDecl -> SDoc
+ppLlvmMeta (MetaUnnamed n m)
+  = ppr n <+> equals <+> ppr m
+
+ppLlvmMeta (MetaNamed n m)
+  = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
+  where
+    nodes = hcat $ intersperse comma $ map ppr m
+
+
+-- | Print out a list of function definitions.
+ppLlvmFunctions :: LlvmFunctions -> SDoc
+ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
+
+-- | Print out a function definition.
+ppLlvmFunction :: LlvmFunction -> SDoc
+ppLlvmFunction fun =
+    let attrDoc = ppSpaceJoin (funcAttrs fun)
+        secDoc = case funcSect fun of
+                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')
+                      Nothing -> empty
+        prefixDoc = case funcPrefix fun of
+                        Just v  -> text "prefix" <+> ppr v
+                        Nothing -> empty
+    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
+        <+> attrDoc <+> secDoc <+> prefixDoc
+        $+$ lbrace
+        $+$ ppLlvmBlocks (funcBody fun)
+        $+$ rbrace
+        $+$ newLine
+        $+$ newLine
+
+-- | Print out a function definition header.
+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
+ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
+  = let varg' = case varg of
+                      VarArgs | null p    -> sLit "..."
+                              | otherwise -> sLit ", ..."
+                      _otherwise          -> sLit ""
+        align = case a of
+                     Just a' -> text " align " <> ppr a'
+                     Nothing -> empty
+        args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
+                                    <> ftext n)
+                    (zip p args)
+    in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
+        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align
+
+-- | Print out a list of function declaration.
+ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
+ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
+
+-- | Print out a function declaration.
+-- Declarations define the function type but don't define the actual body of
+-- the function.
+ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
+ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
+  = let varg' = case varg of
+                      VarArgs | null p    -> sLit "..."
+                              | otherwise -> sLit ", ..."
+                      _otherwise          -> sLit ""
+        align = case a of
+                     Just a' -> text " align" <+> ppr a'
+                     Nothing -> empty
+        args = hcat $ intersperse (comma <> space) $
+                  map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
+    in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
+        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine
+
+
+-- | Print out a list of LLVM blocks.
+ppLlvmBlocks :: LlvmBlocks -> SDoc
+ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
+
+-- | Print out an LLVM block.
+-- It must be part of a function definition.
+ppLlvmBlock :: LlvmBlock -> SDoc
+ppLlvmBlock (LlvmBlock blockId stmts) =
+  let isLabel (MkLabel _) = True
+      isLabel _           = False
+      (block, rest)       = break isLabel stmts
+      ppRest = case rest of
+        MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)
+        _             -> empty
+  in ppLlvmBlockLabel blockId
+           $+$ (vcat $ map ppLlvmStatement block)
+           $+$ newLine
+           $+$ ppRest
+
+-- | Print out an LLVM block label.
+ppLlvmBlockLabel :: LlvmBlockId -> SDoc
+ppLlvmBlockLabel id = pprUniqueAlways id <> colon
+
+
+-- | Print out an LLVM statement.
+ppLlvmStatement :: LlvmStatement -> SDoc
+ppLlvmStatement stmt =
+  let ind = (text "  " <>)
+  in case stmt of
+        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression expr)
+        Fence       st ord        -> ind $ ppFence st ord
+        Branch      target        -> ind $ ppBranch target
+        BranchIf    cond ifT ifF  -> ind $ ppBranchIf cond ifT ifF
+        Comment     comments      -> ind $ ppLlvmComments comments
+        MkLabel     label         -> ppLlvmBlockLabel label
+        Store       value ptr     -> ind $ ppStore value ptr
+        Switch      scrut def tgs -> ind $ ppSwitch scrut def tgs
+        Return      result        -> ind $ ppReturn result
+        Expr        expr          -> ind $ ppLlvmExpression expr
+        Unreachable               -> ind $ text "unreachable"
+        Nop                       -> empty
+        MetaStmt    meta s        -> ppMetaStatement meta s
+
+
+-- | Print out an LLVM expression.
+ppLlvmExpression :: LlvmExpression -> SDoc
+ppLlvmExpression expr
+  = case expr of
+        Alloca     tp amount        -> ppAlloca tp amount
+        LlvmOp     op left right    -> ppMachOp op left right
+        Call       tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
+        CallM      tp fp args attrs -> ppCall tp fp args attrs
+        Cast       op from to       -> ppCast op from to
+        Compare    op left right    -> ppCmpOp op left right
+        Extract    vec idx          -> ppExtract vec idx
+        ExtractV   struct idx       -> ppExtractV struct idx
+        Insert     vec elt idx      -> ppInsert vec elt idx
+        GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
+        Load       ptr              -> ppLoad ptr
+        ALoad      ord st ptr       -> ppALoad ord st ptr
+        Malloc     tp amount        -> ppMalloc tp amount
+        AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
+        CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
+        Phi        tp predecessors  -> ppPhi tp predecessors
+        Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
+        MExpr      meta expr        -> ppMetaExpr meta expr
+
+
+--------------------------------------------------------------------------------
+-- * Individual print functions
+--------------------------------------------------------------------------------
+
+-- | Should always be a function pointer. So a global var of function type
+-- (since globals are always pointers) or a local var of pointer function type.
+ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
+ppCall ct fptr args attrs = case fptr of
+                           --
+    -- if local var function pointer, unwrap
+    LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
+
+    -- should be function type otherwise
+    LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d
+
+    -- not pointer or function, so error
+    _other -> error $ "ppCall called with non LMFunction type!\nMust be "
+                ++ " called with either global var of function type or "
+                ++ "local var of pointer function type."
+
+    where
+        ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
+            let tc = if ct == TailCall then text "tail " else empty
+                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
+                ppArgTy  = (ppCommaJoin $ map fst params) <>
+                           (case argTy of
+                               VarArgs   -> text ", ..."
+                               FixedArgs -> empty)
+                fnty = space <> lparen <> ppArgTy <> rparen
+                attrDoc = ppSpaceJoin attrs
+            in  tc <> text "call" <+> ppr cc <+> ppr ret
+                    <> fnty <+> ppName fptr <> lparen <+> ppValues
+                    <+> rparen <+> attrDoc
+
+        -- Metadata needs to be marked as having the `metadata` type when used
+        -- in a call argument
+        ppCallMetaExpr (MetaVar v) = ppr v
+        ppCallMetaExpr v           = text "metadata" <+> ppr v
+
+ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
+ppMachOp op left right =
+  (ppr op) <+> (ppr (getVarType left)) <+> ppName left
+        <> comma <+> ppName right
+
+
+ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
+ppCmpOp op left right =
+  let cmpOp
+        | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
+        | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
+        | otherwise = text "icmp" -- Just continue as its much easier to debug
+        {-
+        | otherwise = error ("can't compare different types, left = "
+                ++ (show $ getVarType left) ++ ", right = "
+                ++ (show $ getVarType right))
+        -}
+  in cmpOp <+> ppr op <+> ppr (getVarType left)
+        <+> ppName left <> comma <+> ppName right
+
+
+ppAssignment :: LlvmVar -> SDoc -> SDoc
+ppAssignment var expr = ppName var <+> equals <+> expr
+
+ppFence :: Bool -> LlvmSyncOrdering -> SDoc
+ppFence st ord =
+  let singleThread = case st of True  -> text "singlethread"
+                                False -> empty
+  in text "fence" <+> singleThread <+> ppSyncOrdering ord
+
+ppSyncOrdering :: LlvmSyncOrdering -> SDoc
+ppSyncOrdering SyncUnord     = text "unordered"
+ppSyncOrdering SyncMonotonic = text "monotonic"
+ppSyncOrdering SyncAcquire   = text "acquire"
+ppSyncOrdering SyncRelease   = text "release"
+ppSyncOrdering SyncAcqRel    = text "acq_rel"
+ppSyncOrdering SyncSeqCst    = text "seq_cst"
+
+ppAtomicOp :: LlvmAtomicOp -> SDoc
+ppAtomicOp LAO_Xchg = text "xchg"
+ppAtomicOp LAO_Add  = text "add"
+ppAtomicOp LAO_Sub  = text "sub"
+ppAtomicOp LAO_And  = text "and"
+ppAtomicOp LAO_Nand = text "nand"
+ppAtomicOp LAO_Or   = text "or"
+ppAtomicOp LAO_Xor  = text "xor"
+ppAtomicOp LAO_Max  = text "max"
+ppAtomicOp LAO_Min  = text "min"
+ppAtomicOp LAO_Umax = text "umax"
+ppAtomicOp LAO_Umin = text "umin"
+
+ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
+ppAtomicRMW aop tgt src ordering =
+  text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma
+  <+> ppr src <+> ppSyncOrdering ordering
+
+ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
+          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
+ppCmpXChg addr old new s_ord f_ord =
+  text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new
+  <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord
+
+-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
+-- we have no way of guaranteeing that this is true with GHC (we would need to
+-- modify the layout of the stack and closures, change the storage manager,
+-- etc.). So, we blindly tell LLVM that *any* vector store or load could be
+-- unaligned. In the future we may be able to guarantee that certain vector
+-- access patterns are aligned, in which case we will need a more granular way
+-- of specifying alignment.
+
+ppLoad :: LlvmVar -> SDoc
+ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
+  where
+    derefType = pLower $ getVarType var
+    align | isVector . pLower . getVarType $ var = text ", align 1"
+          | otherwise = empty
+
+ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
+ppALoad ord st var = sdocWithDynFlags $ \dflags ->
+  let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8
+      align     = text ", align" <+> ppr alignment
+      sThreaded | st        = text " singlethread"
+                | otherwise = empty
+      derefType = pLower $ getVarType var
+  in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded
+            <+> ppSyncOrdering ord <> align
+
+ppStore :: LlvmVar -> LlvmVar -> SDoc
+ppStore val dst
+    | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
+                        comma <+> text "align 1"
+    | otherwise       = text "store" <+> ppr val <> comma <+> ppr dst
+  where
+    isVecPtrVar :: LlvmVar -> Bool
+    isVecPtrVar = isVector . pLower . getVarType
+
+
+ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
+ppCast op from to
+    =   ppr op
+    <+> ppr (getVarType from) <+> ppName from
+    <+> text "to"
+    <+> ppr to
+
+
+ppMalloc :: LlvmType -> Int -> SDoc
+ppMalloc tp amount =
+  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
+  in text "malloc" <+> ppr tp <> comma <+> ppr amount'
+
+
+ppAlloca :: LlvmType -> Int -> SDoc
+ppAlloca tp amount =
+  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
+  in text "alloca" <+> ppr tp <> comma <+> ppr amount'
+
+
+ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
+ppGetElementPtr inb ptr idx =
+  let indexes = comma <+> ppCommaJoin idx
+      inbound = if inb then text "inbounds" else empty
+      derefType = pLower $ getVarType ptr
+  in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr
+                            <> indexes
+
+
+ppReturn :: Maybe LlvmVar -> SDoc
+ppReturn (Just var) = text "ret" <+> ppr var
+ppReturn Nothing    = text "ret" <+> ppr LMVoid
+
+
+ppBranch :: LlvmVar -> SDoc
+ppBranch var = text "br" <+> ppr var
+
+
+ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppBranchIf cond trueT falseT
+  = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT
+
+
+ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
+ppPhi tp preds =
+  let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
+  in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
+
+
+ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
+ppSwitch scrut dflt targets =
+  let ppTarget  (val, lab) = ppr val <> comma <+> ppr lab
+      ppTargets  xs        = brackets $ vcat (map ppTarget xs)
+  in text "switch" <+> ppr scrut <> comma <+> ppr dflt
+        <+> ppTargets targets
+
+
+ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
+ppAsm asm constraints rty vars sideeffect alignstack =
+  let asm'  = doubleQuotes $ ftext asm
+      cons  = doubleQuotes $ ftext constraints
+      rty'  = ppr rty
+      vars' = lparen <+> ppCommaJoin vars <+> rparen
+      side  = if sideeffect then text "sideeffect" else empty
+      align = if alignstack then text "alignstack" else empty
+  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
+        <+> cons <> vars'
+
+ppExtract :: LlvmVar -> LlvmVar -> SDoc
+ppExtract vec idx =
+    text "extractelement"
+    <+> ppr (getVarType vec) <+> ppName vec <> comma
+    <+> ppr idx
+
+ppExtractV :: LlvmVar -> Int -> SDoc
+ppExtractV struct idx =
+    text "extractvalue"
+    <+> ppr (getVarType struct) <+> ppName struct <> comma
+    <+> ppr idx
+
+ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppInsert vec elt idx =
+    text "insertelement"
+    <+> ppr (getVarType vec) <+> ppName vec <> comma
+    <+> ppr (getVarType elt) <+> ppName elt <> comma
+    <+> ppr idx
+
+
+ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
+ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta
+
+ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
+ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta
+
+ppMetaAnnots :: [MetaAnnot] -> SDoc
+ppMetaAnnots meta = hcat $ map ppMeta meta
+  where
+    ppMeta (MetaAnnot name e)
+        = comma <+> exclamation <> ftext name <+>
+          case e of
+            MetaNode n    -> ppr n
+            MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
+            other         -> exclamation <> braces (ppr other) -- possible?
+
+
+--------------------------------------------------------------------------------
+-- * Misc functions
+--------------------------------------------------------------------------------
+
+-- | Blank line.
+newLine :: SDoc
+newLine = empty
+
+-- | Exclamation point.
+exclamation :: SDoc
+exclamation = char '!'
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -0,0 +1,894 @@
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+
+--------------------------------------------------------------------------------
+-- | The LLVM Type System.
+--
+
+module Llvm.Types where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Data.Char
+import Data.Int
+import Numeric
+
+import DynFlags
+import FastString
+import Outputable
+import Unique
+
+-- from NCG
+import PprBase
+
+import GHC.Float
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Basic Types and Variables
+--
+
+-- | A global mutable variable. Maybe defined or external
+data LMGlobal = LMGlobal {
+  getGlobalVar :: LlvmVar,          -- ^ Returns the variable of the 'LMGlobal'
+  getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'
+  }
+
+-- | A String in LLVM
+type LMString = FastString
+
+-- | A type alias
+type LlvmAlias = (LMString, LlvmType)
+
+-- | Llvm Types
+data LlvmType
+  = LMInt Int             -- ^ An integer with a given width in bits.
+  | LMFloat               -- ^ 32 bit floating point
+  | LMDouble              -- ^ 64 bit floating point
+  | LMFloat80             -- ^ 80 bit (x86 only) floating point
+  | LMFloat128            -- ^ 128 bit floating point
+  | LMPointer LlvmType    -- ^ A pointer to a 'LlvmType'
+  | LMArray Int LlvmType  -- ^ An array of 'LlvmType'
+  | LMVector Int LlvmType -- ^ A vector of 'LlvmType'
+  | LMLabel               -- ^ A 'LlvmVar' can represent a label (address)
+  | LMVoid                -- ^ Void type
+  | LMStruct [LlvmType]   -- ^ Packed structure type
+  | LMStructU [LlvmType]  -- ^ Unpacked structure type
+  | LMAlias LlvmAlias     -- ^ A type alias
+  | LMMetadata            -- ^ LLVM Metadata
+
+  -- | Function type, used to create pointers to functions
+  | LMFunction LlvmFunctionDecl
+  deriving (Eq)
+
+instance Outputable LlvmType where
+  ppr (LMInt size     ) = char 'i' <> ppr size
+  ppr (LMFloat        ) = text "float"
+  ppr (LMDouble       ) = text "double"
+  ppr (LMFloat80      ) = text "x86_fp80"
+  ppr (LMFloat128     ) = text "fp128"
+  ppr (LMPointer x    ) = ppr x <> char '*'
+  ppr (LMArray nr tp  ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'
+  ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'
+  ppr (LMLabel        ) = text "label"
+  ppr (LMVoid         ) = text "void"
+  ppr (LMStruct tys   ) = text "<{" <> ppCommaJoin tys <> text "}>"
+  ppr (LMStructU tys  ) = text "{" <> ppCommaJoin tys <> text "}"
+  ppr (LMMetadata     ) = text "metadata"
+
+  ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
+    = ppr r <+> lparen <> ppParams varg p <> rparen
+
+  ppr (LMAlias (s,_)) = char '%' <> ftext s
+
+ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
+ppParams varg p
+  = let varg' = case varg of
+          VarArgs | null args -> sLit "..."
+                  | otherwise -> sLit ", ..."
+          _otherwise          -> sLit ""
+        -- by default we don't print param attributes
+        args = map fst p
+    in ppCommaJoin args <> ptext varg'
+
+-- | An LLVM section definition. If Nothing then let LLVM decide the section
+type LMSection = Maybe LMString
+type LMAlign = Maybe Int
+
+data LMConst = Global      -- ^ Mutable global variable
+             | Constant    -- ^ Constant global variable
+             | Alias       -- ^ Alias of another variable
+             deriving (Eq)
+
+-- | LLVM Variables
+data LlvmVar
+  -- | Variables with a global scope.
+  = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst
+  -- | Variables local to a function or parameters.
+  | LMLocalVar Unique LlvmType
+  -- | Named local variables. Sometimes we need to be able to explicitly name
+  -- variables (e.g for function arguments).
+  | LMNLocalVar LMString LlvmType
+  -- | A constant variable
+  | LMLitVar LlvmLit
+  deriving (Eq)
+
+instance Outputable LlvmVar where
+  ppr (LMLitVar x)  = ppr x
+  ppr (x         )  = ppr (getVarType x) <+> ppName x
+
+
+-- | Llvm Literal Data.
+--
+-- These can be used inline in expressions.
+data LlvmLit
+  -- | Refers to an integer constant (i64 42).
+  = LMIntLit Integer LlvmType
+  -- | Floating point literal
+  | LMFloatLit Double LlvmType
+  -- | Literal NULL, only applicable to pointer types
+  | LMNullLit LlvmType
+  -- | Vector literal
+  | LMVectorLit [LlvmLit]
+  -- | Undefined value, random bit pattern. Useful for optimisations.
+  | LMUndefLit LlvmType
+  deriving (Eq)
+
+instance Outputable LlvmLit where
+  ppr l@(LMVectorLit {}) = ppLit l
+  ppr l                  = ppr (getLitType l) <+> ppLit l
+
+
+-- | Llvm Static Data.
+--
+-- These represent the possible global level variables and constants.
+data LlvmStatic
+  = LMComment LMString                  -- ^ A comment in a static section
+  | LMStaticLit LlvmLit                 -- ^ A static variant of a literal value
+  | LMUninitType LlvmType               -- ^ For uninitialised data
+  | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'
+  | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array
+  | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type
+  | LMStaticPointer LlvmVar             -- ^ A pointer to other data
+
+  -- static expressions, could split out but leave
+  -- for moment for ease of use. Not many of them.
+
+  | LMTrunc LlvmStatic LlvmType        -- ^ Truncate
+  | LMBitc LlvmStatic LlvmType         -- ^ Pointer to Pointer conversion
+  | LMPtoI LlvmStatic LlvmType         -- ^ Pointer to Integer conversion
+  | LMAdd LlvmStatic LlvmStatic        -- ^ Constant addition operation
+  | LMSub LlvmStatic LlvmStatic        -- ^ Constant subtraction operation
+
+instance Outputable LlvmStatic where
+  ppr (LMComment       s) = text "; " <> ftext s
+  ppr (LMStaticLit   l  ) = ppr l
+  ppr (LMUninitType    t) = ppr t <> text " undef"
+  ppr (LMStaticStr   s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\""
+  ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'
+  ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"
+  ppr (LMStaticPointer v) = ppr v
+  ppr (LMTrunc v t)
+      = ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')'
+  ppr (LMBitc v t)
+      = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'
+  ppr (LMPtoI v t)
+      = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')'
+
+  ppr (LMAdd s1 s2)
+      = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd"
+  ppr (LMSub s1 s2)
+      = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub"
+
+
+pprSpecialStatic :: LlvmStatic -> SDoc
+pprSpecialStatic (LMBitc v t) =
+    ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t
+        <> char ')'
+pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v
+pprSpecialStatic stat = ppr stat
+
+
+pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString
+                  -> String -> SDoc
+pprStaticArith s1 s2 int_op float_op op_name =
+  let ty1 = getStatType s1
+      op  = if isFloat ty1 then float_op else int_op
+  in if ty1 == getStatType s2
+     then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen
+     else sdocWithDynFlags $ \dflags ->
+            error $ op_name ++ " with different types! s1: "
+                    ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2)
+
+-- -----------------------------------------------------------------------------
+-- ** Operations on LLVM Basic Types and Variables
+--
+
+-- | Return the variable name or value of the 'LlvmVar'
+-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
+ppName :: LlvmVar -> SDoc
+ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v
+ppName v@(LMLocalVar  {}) = char '%' <> ppPlainName v
+ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v
+ppName v@(LMLitVar    {}) =             ppPlainName v
+
+-- | Return the variable name or value of the 'LlvmVar'
+-- in a plain textual representation (e.g. @x@, @y@ or @42@).
+ppPlainName :: LlvmVar -> SDoc
+ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x
+ppPlainName (LMLocalVar  x LMLabel  ) = text (show x)
+ppPlainName (LMLocalVar  x _        ) = text ('l' : show x)
+ppPlainName (LMNLocalVar x _        ) = ftext x
+ppPlainName (LMLitVar    x          ) = ppLit x
+
+-- | Print a literal value. No type.
+ppLit :: LlvmLit -> SDoc
+ppLit (LMIntLit i (LMInt 32))  = ppr (fromInteger i :: Int32)
+ppLit (LMIntLit i (LMInt 64))  = ppr (fromInteger i :: Int64)
+ppLit (LMIntLit   i _       )  = ppr ((fromInteger i)::Int)
+ppLit (LMFloatLit r LMFloat )  = ppFloat $ narrowFp r
+ppLit (LMFloatLit r LMDouble)  = ppDouble r
+ppLit f@(LMFloatLit _ _)       = sdocWithDynFlags (\dflags ->
+                                   error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f))
+ppLit (LMVectorLit ls  )       = char '<' <+> ppCommaJoin ls <+> char '>'
+ppLit (LMNullLit _     )       = text "null"
+-- #11487 was an issue where we passed undef for some arguments
+-- that were actually live. By chance the registers holding those
+-- arguments usually happened to have the right values anyways, but
+-- that was not guaranteed. To find such bugs reliably, we set the
+-- flag below when validating, which replaces undef literals (at
+-- common types) with values that are likely to cause a crash or test
+-- failure.
+ppLit (LMUndefLit t    )       = sdocWithDynFlags f
+  where f dflags
+          | gopt Opt_LlvmFillUndefWithGarbage dflags,
+            Just lit <- garbageLit t   = ppLit lit
+          | otherwise                  = text "undef"
+
+garbageLit :: LlvmType -> Maybe LlvmLit
+garbageLit t@(LMInt w)     = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
+  -- Use a value that looks like an untagged pointer, so we are more
+  -- likely to try to enter it
+garbageLit t
+  | isFloat t              = Just (LMFloatLit 12345678.9 t)
+garbageLit t@(LMPointer _) = Just (LMNullLit t)
+  -- Using null isn't totally ideal, since some functions may check for null.
+  -- But producing another value is inconvenient since it needs a cast,
+  -- and the knowledge for how to format casts is in PpLlvm.
+garbageLit _               = Nothing
+  -- More cases could be added, but this should do for now.
+
+-- | Return the 'LlvmType' of the 'LlvmVar'
+getVarType :: LlvmVar -> LlvmType
+getVarType (LMGlobalVar _ y _ _ _ _) = y
+getVarType (LMLocalVar  _ y        ) = y
+getVarType (LMNLocalVar _ y        ) = y
+getVarType (LMLitVar    l          ) = getLitType l
+
+-- | Return the 'LlvmType' of a 'LlvmLit'
+getLitType :: LlvmLit -> LlvmType
+getLitType (LMIntLit   _ t) = t
+getLitType (LMFloatLit _ t) = t
+getLitType (LMVectorLit [])  = panic "getLitType"
+getLitType (LMVectorLit ls)  = LMVector (length ls) (getLitType (head ls))
+getLitType (LMNullLit    t) = t
+getLitType (LMUndefLit   t) = t
+
+-- | Return the 'LlvmType' of the 'LlvmStatic'
+getStatType :: LlvmStatic -> LlvmType
+getStatType (LMStaticLit   l  ) = getLitType l
+getStatType (LMUninitType    t) = t
+getStatType (LMStaticStr   _ t) = t
+getStatType (LMStaticArray _ t) = t
+getStatType (LMStaticStruc _ t) = t
+getStatType (LMStaticPointer v) = getVarType v
+getStatType (LMTrunc       _ t) = t
+getStatType (LMBitc        _ t) = t
+getStatType (LMPtoI        _ t) = t
+getStatType (LMAdd         t _) = getStatType t
+getStatType (LMSub         t _) = getStatType t
+getStatType (LMComment       _) = error "Can't call getStatType on LMComment!"
+
+-- | Return the 'LlvmLinkageType' for a 'LlvmVar'
+getLink :: LlvmVar -> LlvmLinkageType
+getLink (LMGlobalVar _ _ l _ _ _) = l
+getLink _                         = Internal
+
+-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
+-- cannot be lifted.
+pLift :: LlvmType -> LlvmType
+pLift LMLabel    = error "Labels are unliftable"
+pLift LMVoid     = error "Voids are unliftable"
+pLift LMMetadata = error "Metadatas are unliftable"
+pLift x          = LMPointer x
+
+-- | Lift a variable to 'LMPointer' type.
+pVarLift :: LlvmVar -> LlvmVar
+pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c
+pVarLift (LMLocalVar  s t        ) = LMLocalVar  s (pLift t)
+pVarLift (LMNLocalVar s t        ) = LMNLocalVar s (pLift t)
+pVarLift (LMLitVar    _          ) = error $ "Can't lower a literal type!"
+
+-- | Remove the pointer indirection of the supplied type. Only 'LMPointer'
+-- constructors can be lowered.
+pLower :: LlvmType -> LlvmType
+pLower (LMPointer x) = x
+pLower x  = pprPanic "llvmGen(pLower)"
+            $ ppr x <+> text " is a unlowerable type, need a pointer"
+
+-- | Lower a variable of 'LMPointer' type.
+pVarLower :: LlvmVar -> LlvmVar
+pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c
+pVarLower (LMLocalVar  s t        ) = LMLocalVar  s (pLower t)
+pVarLower (LMNLocalVar s t        ) = LMNLocalVar s (pLower t)
+pVarLower (LMLitVar    _          ) = error $ "Can't lower a literal type!"
+
+-- | Test if the given 'LlvmType' is an integer
+isInt :: LlvmType -> Bool
+isInt (LMInt _) = True
+isInt _         = False
+
+-- | Test if the given 'LlvmType' is a floating point type
+isFloat :: LlvmType -> Bool
+isFloat LMFloat    = True
+isFloat LMDouble   = True
+isFloat LMFloat80  = True
+isFloat LMFloat128 = True
+isFloat _          = False
+
+-- | Test if the given 'LlvmType' is an 'LMPointer' construct
+isPointer :: LlvmType -> Bool
+isPointer (LMPointer _) = True
+isPointer _             = False
+
+-- | Test if the given 'LlvmType' is an 'LMVector' construct
+isVector :: LlvmType -> Bool
+isVector (LMVector {}) = True
+isVector _             = False
+
+-- | Test if a 'LlvmVar' is global.
+isGlobal :: LlvmVar -> Bool
+isGlobal (LMGlobalVar _ _ _ _ _ _) = True
+isGlobal _                         = False
+
+-- | Width in bits of an 'LlvmType', returns 0 if not applicable
+llvmWidthInBits :: DynFlags -> LlvmType -> Int
+llvmWidthInBits _      (LMInt n)       = n
+llvmWidthInBits _      (LMFloat)       = 32
+llvmWidthInBits _      (LMDouble)      = 64
+llvmWidthInBits _      (LMFloat80)     = 80
+llvmWidthInBits _      (LMFloat128)    = 128
+-- Could return either a pointer width here or the width of what
+-- it points to. We will go with the former for now.
+-- PMW: At least judging by the way LLVM outputs constants, pointers
+--      should use the former, but arrays the latter.
+llvmWidthInBits dflags (LMPointer _)   = llvmWidthInBits dflags (llvmWord dflags)
+llvmWidthInBits dflags (LMArray n t)   = n * llvmWidthInBits dflags t
+llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty
+llvmWidthInBits _      LMLabel         = 0
+llvmWidthInBits _      LMVoid          = 0
+llvmWidthInBits dflags (LMStruct tys)  = sum $ map (llvmWidthInBits dflags) tys
+llvmWidthInBits _      (LMStructU _)   =
+    -- It's not trivial to calculate the bit width of the unpacked structs,
+    -- since they will be aligned depending on the specified datalayout (
+    -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support
+    -- this could be to make the LlvmCodeGen.Ppr.moduleLayout be a data type
+    -- that exposes the alignment information. However, currently the only place
+    -- we use unpacked structs is LLVM intrinsics that return them (e.g.,
+    -- llvm.sadd.with.overflow.*), so we don't actually need to compute their
+    -- bit width.
+    panic "llvmWidthInBits: not implemented for LMStructU"
+llvmWidthInBits _      (LMFunction  _) = 0
+llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t
+llvmWidthInBits _      LMMetadata      = panic "llvmWidthInBits: Meta-data has no runtime representation!"
+
+
+-- -----------------------------------------------------------------------------
+-- ** Shortcut for Common Types
+--
+
+i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType
+i128  = LMInt 128
+i64   = LMInt  64
+i32   = LMInt  32
+i16   = LMInt  16
+i8    = LMInt   8
+i1    = LMInt   1
+i8Ptr = pLift i8
+
+-- | The target architectures word size
+llvmWord, llvmWordPtr :: DynFlags -> LlvmType
+llvmWord    dflags = LMInt (wORD_SIZE dflags * 8)
+llvmWordPtr dflags = pLift (llvmWord dflags)
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Function Types
+--
+
+-- | An LLVM Function
+data LlvmFunctionDecl = LlvmFunctionDecl {
+        -- | Unique identifier of the function
+        decName       :: LMString,
+        -- | LinkageType of the function
+        funcLinkage   :: LlvmLinkageType,
+        -- | The calling convention of the function
+        funcCc        :: LlvmCallConvention,
+        -- | Type of the returned value
+        decReturnType :: LlvmType,
+        -- | Indicates if this function uses varargs
+        decVarargs    :: LlvmParameterListType,
+        -- | Parameter types and attributes
+        decParams     :: [LlvmParameter],
+        -- | Function align value, must be power of 2
+        funcAlign     :: LMAlign
+  }
+  deriving (Eq)
+
+instance Outputable LlvmFunctionDecl where
+  ppr (LlvmFunctionDecl n l c r varg p a)
+    = let align = case a of
+                       Just a' -> text " align " <> ppr a'
+                       Nothing -> empty
+      in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <>
+             lparen <> ppParams varg p <> rparen <> align
+
+type LlvmFunctionDecls = [LlvmFunctionDecl]
+
+type LlvmParameter = (LlvmType, [LlvmParamAttr])
+
+-- | LLVM Parameter Attributes.
+--
+-- Parameter attributes are used to communicate additional information about
+-- the result or parameters of a function
+data LlvmParamAttr
+  -- | This indicates to the code generator that the parameter or return value
+  -- should be zero-extended to a 32-bit value by the caller (for a parameter)
+  -- or the callee (for a return value).
+  = ZeroExt
+  -- | This indicates to the code generator that the parameter or return value
+  -- should be sign-extended to a 32-bit value by the caller (for a parameter)
+  -- or the callee (for a return value).
+  | SignExt
+  -- | This indicates that this parameter or return value should be treated in
+  -- a special target-dependent fashion during while emitting code for a
+  -- function call or return (usually, by putting it in a register as opposed
+  -- to memory).
+  | InReg
+  -- | This indicates that the pointer parameter should really be passed by
+  -- value to the function.
+  | ByVal
+  -- | This indicates that the pointer parameter specifies the address of a
+  -- structure that is the return value of the function in the source program.
+  | SRet
+  -- | This indicates that the pointer does not alias any global or any other
+  -- parameter.
+  | NoAlias
+  -- | This indicates that the callee does not make any copies of the pointer
+  -- that outlive the callee itself
+  | NoCapture
+  -- | This indicates that the pointer parameter can be excised using the
+  -- trampoline intrinsics.
+  | Nest
+  deriving (Eq)
+
+instance Outputable LlvmParamAttr where
+  ppr ZeroExt   = text "zeroext"
+  ppr SignExt   = text "signext"
+  ppr InReg     = text "inreg"
+  ppr ByVal     = text "byval"
+  ppr SRet      = text "sret"
+  ppr NoAlias   = text "noalias"
+  ppr NoCapture = text "nocapture"
+  ppr Nest      = text "nest"
+
+-- | Llvm Function Attributes.
+--
+-- Function attributes are set to communicate additional information about a
+-- function. Function attributes are considered to be part of the function,
+-- not of the function type, so functions with different parameter attributes
+-- can have the same function type. Functions can have multiple attributes.
+--
+-- Descriptions taken from <http://llvm.org/docs/LangRef.html#fnattrs>
+data LlvmFuncAttr
+  -- | This attribute indicates that the inliner should attempt to inline this
+  -- function into callers whenever possible, ignoring any active inlining
+  -- size threshold for this caller.
+  = AlwaysInline
+  -- | This attribute indicates that the source code contained a hint that
+  -- inlining this function is desirable (such as the \"inline\" keyword in
+  -- C/C++). It is just a hint; it imposes no requirements on the inliner.
+  | InlineHint
+  -- | This attribute indicates that the inliner should never inline this
+  -- function in any situation. This attribute may not be used together
+  -- with the alwaysinline attribute.
+  | NoInline
+  -- | This attribute suggests that optimization passes and code generator
+  -- passes make choices that keep the code size of this function low, and
+  -- otherwise do optimizations specifically to reduce code size.
+  | OptSize
+  -- | This function attribute indicates that the function never returns
+  -- normally. This produces undefined behavior at runtime if the function
+  -- ever does dynamically return.
+  | NoReturn
+  -- | This function attribute indicates that the function never returns with
+  -- an unwind or exceptional control flow. If the function does unwind, its
+  -- runtime behavior is undefined.
+  | NoUnwind
+  -- | This attribute indicates that the function computes its result (or
+  -- decides to unwind an exception) based strictly on its arguments, without
+  -- dereferencing any pointer arguments or otherwise accessing any mutable
+  -- state (e.g. memory, control registers, etc) visible to caller functions.
+  -- It does not write through any pointer arguments (including byval
+  -- arguments) and never changes any state visible to callers. This means
+  -- that it cannot unwind exceptions by calling the C++ exception throwing
+  -- methods, but could use the unwind instruction.
+  | ReadNone
+  -- | This attribute indicates that the function does not write through any
+  -- pointer arguments (including byval arguments) or otherwise modify any
+  -- state (e.g. memory, control registers, etc) visible to caller functions.
+  -- It may dereference pointer arguments and read state that may be set in
+  -- the caller. A readonly function always returns the same value (or unwinds
+  -- an exception identically) when called with the same set of arguments and
+  -- global state. It cannot unwind an exception by calling the C++ exception
+  -- throwing methods, but may use the unwind instruction.
+  | ReadOnly
+  -- | This attribute indicates that the function should emit a stack smashing
+  -- protector. It is in the form of a \"canary\"—a random value placed on the
+  -- stack before the local variables that's checked upon return from the
+  -- function to see if it has been overwritten. A heuristic is used to
+  -- determine if a function needs stack protectors or not.
+  --
+  -- If a function that has an ssp attribute is inlined into a function that
+  -- doesn't have an ssp attribute, then the resulting function will have an
+  -- ssp attribute.
+  | Ssp
+  -- | This attribute indicates that the function should always emit a stack
+  -- smashing protector. This overrides the ssp function attribute.
+  --
+  -- If a function that has an sspreq attribute is inlined into a function
+  -- that doesn't have an sspreq attribute or which has an ssp attribute,
+  -- then the resulting function will have an sspreq attribute.
+  | SspReq
+  -- | This attribute indicates that the code generator should not use a red
+  -- zone, even if the target-specific ABI normally permits it.
+  | NoRedZone
+  -- | This attributes disables implicit floating point instructions.
+  | NoImplicitFloat
+  -- | This attribute disables prologue / epilogue emission for the function.
+  -- This can have very system-specific consequences.
+  | Naked
+  deriving (Eq)
+
+instance Outputable LlvmFuncAttr where
+  ppr AlwaysInline       = text "alwaysinline"
+  ppr InlineHint         = text "inlinehint"
+  ppr NoInline           = text "noinline"
+  ppr OptSize            = text "optsize"
+  ppr NoReturn           = text "noreturn"
+  ppr NoUnwind           = text "nounwind"
+  ppr ReadNone           = text "readnon"
+  ppr ReadOnly           = text "readonly"
+  ppr Ssp                = text "ssp"
+  ppr SspReq             = text "ssqreq"
+  ppr NoRedZone          = text "noredzone"
+  ppr NoImplicitFloat    = text "noimplicitfloat"
+  ppr Naked              = text "naked"
+
+
+-- | Different types to call a function.
+data LlvmCallType
+  -- | Normal call, allocate a new stack frame.
+  = StdCall
+  -- | Tail call, perform the call in the current stack frame.
+  | TailCall
+  deriving (Eq,Show)
+
+-- | Different calling conventions a function can use.
+data LlvmCallConvention
+  -- | The C calling convention.
+  -- This calling convention (the default if no other calling convention is
+  -- specified) matches the target C calling conventions. This calling
+  -- convention supports varargs function calls and tolerates some mismatch in
+  -- the declared prototype and implemented declaration of the function (as
+  -- does normal C).
+  = CC_Ccc
+  -- | This calling convention attempts to make calls as fast as possible
+  -- (e.g. by passing things in registers). This calling convention allows
+  -- the target to use whatever tricks it wants to produce fast code for the
+  -- target, without having to conform to an externally specified ABI
+  -- (Application Binary Interface). Implementations of this convention should
+  -- allow arbitrary tail call optimization to be supported. This calling
+  -- convention does not support varargs and requires the prototype of al
+  -- callees to exactly match the prototype of the function definition.
+  | CC_Fastcc
+  -- | This calling convention attempts to make code in the caller as efficient
+  -- as possible under the assumption that the call is not commonly executed.
+  -- As such, these calls often preserve all registers so that the call does
+  -- not break any live ranges in the caller side. This calling convention
+  -- does not support varargs and requires the prototype of all callees to
+  -- exactly match the prototype of the function definition.
+  | CC_Coldcc
+  -- | The GHC-specific 'registerised' calling convention.
+  | CC_Ghc
+  -- | Any calling convention may be specified by number, allowing
+  -- target-specific calling conventions to be used. Target specific calling
+  -- conventions start at 64.
+  | CC_Ncc Int
+  -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it
+  -- rather than just using CC_Ncc.
+  | CC_X86_Stdcc
+  deriving (Eq)
+
+instance Outputable LlvmCallConvention where
+  ppr CC_Ccc       = text "ccc"
+  ppr CC_Fastcc    = text "fastcc"
+  ppr CC_Coldcc    = text "coldcc"
+  ppr CC_Ghc       = text "ghccc"
+  ppr (CC_Ncc i)   = text "cc " <> ppr i
+  ppr CC_X86_Stdcc = text "x86_stdcallcc"
+
+
+-- | Functions can have a fixed amount of parameters, or a variable amount.
+data LlvmParameterListType
+  -- Fixed amount of arguments.
+  = FixedArgs
+  -- Variable amount of arguments.
+  | VarArgs
+  deriving (Eq,Show)
+
+
+-- | Linkage type of a symbol.
+--
+-- The description of the constructors is copied from the Llvm Assembly Language
+-- Reference Manual <http://www.llvm.org/docs/LangRef.html#linkage>, because
+-- they correspond to the Llvm linkage types.
+data LlvmLinkageType
+  -- | Global values with internal linkage are only directly accessible by
+  -- objects in the current module. In particular, linking code into a module
+  -- with an internal global value may cause the internal to be renamed as
+  -- necessary to avoid collisions. Because the symbol is internal to the
+  -- module, all references can be updated. This corresponds to the notion
+  -- of the @static@ keyword in C.
+  = Internal
+  -- | Globals with @linkonce@ linkage are merged with other globals of the
+  -- same name when linkage occurs. This is typically used to implement
+  -- inline functions, templates, or other code which must be generated
+  -- in each translation unit that uses it. Unreferenced linkonce globals are
+  -- allowed to be discarded.
+  | LinkOnce
+  -- | @weak@ linkage is exactly the same as linkonce linkage, except that
+  -- unreferenced weak globals may not be discarded. This is used for globals
+  -- that may be emitted in multiple translation units, but that are not
+  -- guaranteed to be emitted into every translation unit that uses them. One
+  -- example of this are common globals in C, such as @int X;@ at global
+  -- scope.
+  | Weak
+  -- | @appending@ linkage may only be applied to global variables of pointer
+  -- to array type. When two global variables with appending linkage are
+  -- linked together, the two global arrays are appended together. This is
+  -- the Llvm, typesafe, equivalent of having the system linker append
+  -- together @sections@ with identical names when .o files are linked.
+  | Appending
+  -- | The semantics of this linkage follow the ELF model: the symbol is weak
+  -- until linked, if not linked, the symbol becomes null instead of being an
+  -- undefined reference.
+  | ExternWeak
+  -- | The symbol participates in linkage and can be used to resolve external
+  --  symbol references.
+  | ExternallyVisible
+  -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
+  --  assembly.
+  | External
+  -- | Symbol is private to the module and should not appear in the symbol table
+  | Private
+  deriving (Eq)
+
+instance Outputable LlvmLinkageType where
+  ppr Internal          = text "internal"
+  ppr LinkOnce          = text "linkonce"
+  ppr Weak              = text "weak"
+  ppr Appending         = text "appending"
+  ppr ExternWeak        = text "extern_weak"
+  -- ExternallyVisible does not have a textual representation, it is
+  -- the linkage type a function resolves to if no other is specified
+  -- in Llvm.
+  ppr ExternallyVisible = empty
+  ppr External          = text "external"
+  ppr Private           = text "private"
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Operations
+--
+
+-- | Llvm binary operators machine operations.
+data LlvmMachOp
+  = LM_MO_Add  -- ^ add two integer, floating point or vector values.
+  | LM_MO_Sub  -- ^ subtract two ...
+  | LM_MO_Mul  -- ^ multiply ..
+  | LM_MO_UDiv -- ^ unsigned integer or vector division.
+  | LM_MO_SDiv -- ^ signed integer ..
+  | LM_MO_URem -- ^ unsigned integer or vector remainder (mod)
+  | LM_MO_SRem -- ^ signed ...
+
+  | LM_MO_FAdd -- ^ add two floating point or vector values.
+  | LM_MO_FSub -- ^ subtract two ...
+  | LM_MO_FMul -- ^ multiply ...
+  | LM_MO_FDiv -- ^ divide ...
+  | LM_MO_FRem -- ^ remainder ...
+
+  -- | Left shift
+  | LM_MO_Shl
+  -- | Logical shift right
+  -- Shift right, filling with zero
+  | LM_MO_LShr
+  -- | Arithmetic shift right
+  -- The most significant bits of the result will be equal to the sign bit of
+  -- the left operand.
+  | LM_MO_AShr
+
+  | LM_MO_And -- ^ AND bitwise logical operation.
+  | LM_MO_Or  -- ^ OR bitwise logical operation.
+  | LM_MO_Xor -- ^ XOR bitwise logical operation.
+  deriving (Eq)
+
+instance Outputable LlvmMachOp where
+  ppr LM_MO_Add  = text "add"
+  ppr LM_MO_Sub  = text "sub"
+  ppr LM_MO_Mul  = text "mul"
+  ppr LM_MO_UDiv = text "udiv"
+  ppr LM_MO_SDiv = text "sdiv"
+  ppr LM_MO_URem = text "urem"
+  ppr LM_MO_SRem = text "srem"
+  ppr LM_MO_FAdd = text "fadd"
+  ppr LM_MO_FSub = text "fsub"
+  ppr LM_MO_FMul = text "fmul"
+  ppr LM_MO_FDiv = text "fdiv"
+  ppr LM_MO_FRem = text "frem"
+  ppr LM_MO_Shl  = text "shl"
+  ppr LM_MO_LShr = text "lshr"
+  ppr LM_MO_AShr = text "ashr"
+  ppr LM_MO_And  = text "and"
+  ppr LM_MO_Or   = text "or"
+  ppr LM_MO_Xor  = text "xor"
+
+
+-- | Llvm compare operations.
+data LlvmCmpOp
+  = LM_CMP_Eq  -- ^ Equal (Signed and Unsigned)
+  | LM_CMP_Ne  -- ^ Not equal (Signed and Unsigned)
+  | LM_CMP_Ugt -- ^ Unsigned greater than
+  | LM_CMP_Uge -- ^ Unsigned greater than or equal
+  | LM_CMP_Ult -- ^ Unsigned less than
+  | LM_CMP_Ule -- ^ Unsigned less than or equal
+  | LM_CMP_Sgt -- ^ Signed greater than
+  | LM_CMP_Sge -- ^ Signed greater than or equal
+  | LM_CMP_Slt -- ^ Signed less than
+  | LM_CMP_Sle -- ^ Signed less than or equal
+
+  -- Float comparisons. GHC uses a mix of ordered and unordered float
+  -- comparisons.
+  | LM_CMP_Feq -- ^ Float equal
+  | LM_CMP_Fne -- ^ Float not equal
+  | LM_CMP_Fgt -- ^ Float greater than
+  | LM_CMP_Fge -- ^ Float greater than or equal
+  | LM_CMP_Flt -- ^ Float less than
+  | LM_CMP_Fle -- ^ Float less than or equal
+  deriving (Eq)
+
+instance Outputable LlvmCmpOp where
+  ppr LM_CMP_Eq  = text "eq"
+  ppr LM_CMP_Ne  = text "ne"
+  ppr LM_CMP_Ugt = text "ugt"
+  ppr LM_CMP_Uge = text "uge"
+  ppr LM_CMP_Ult = text "ult"
+  ppr LM_CMP_Ule = text "ule"
+  ppr LM_CMP_Sgt = text "sgt"
+  ppr LM_CMP_Sge = text "sge"
+  ppr LM_CMP_Slt = text "slt"
+  ppr LM_CMP_Sle = text "sle"
+  ppr LM_CMP_Feq = text "oeq"
+  ppr LM_CMP_Fne = text "une"
+  ppr LM_CMP_Fgt = text "ogt"
+  ppr LM_CMP_Fge = text "oge"
+  ppr LM_CMP_Flt = text "olt"
+  ppr LM_CMP_Fle = text "ole"
+
+
+-- | Llvm cast operations.
+data LlvmCastOp
+  = LM_Trunc    -- ^ Integer truncate
+  | LM_Zext     -- ^ Integer extend (zero fill)
+  | LM_Sext     -- ^ Integer extend (sign fill)
+  | LM_Fptrunc  -- ^ Float truncate
+  | LM_Fpext    -- ^ Float extend
+  | LM_Fptoui   -- ^ Float to unsigned Integer
+  | LM_Fptosi   -- ^ Float to signed Integer
+  | LM_Uitofp   -- ^ Unsigned Integer to Float
+  | LM_Sitofp   -- ^ Signed Int to Float
+  | LM_Ptrtoint -- ^ Pointer to Integer
+  | LM_Inttoptr -- ^ Integer to Pointer
+  | LM_Bitcast  -- ^ Cast between types where no bit manipulation is needed
+  deriving (Eq)
+
+instance Outputable LlvmCastOp where
+  ppr LM_Trunc    = text "trunc"
+  ppr LM_Zext     = text "zext"
+  ppr LM_Sext     = text "sext"
+  ppr LM_Fptrunc  = text "fptrunc"
+  ppr LM_Fpext    = text "fpext"
+  ppr LM_Fptoui   = text "fptoui"
+  ppr LM_Fptosi   = text "fptosi"
+  ppr LM_Uitofp   = text "uitofp"
+  ppr LM_Sitofp   = text "sitofp"
+  ppr LM_Ptrtoint = text "ptrtoint"
+  ppr LM_Inttoptr = text "inttoptr"
+  ppr LM_Bitcast  = text "bitcast"
+
+
+-- -----------------------------------------------------------------------------
+-- * Floating point conversion
+--
+
+-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In
+-- Llvm float literals can be printed in a big-endian hexadecimal format,
+-- regardless of underlying architecture.
+--
+-- See Note [LLVM Float Types].
+ppDouble :: Double -> SDoc
+ppDouble d
+  = let bs     = doubleToBytes d
+        hex d' = case showHex d' "" of
+                     []    -> error "dToStr: too few hex digits for float"
+                     [x]   -> ['0',x]
+                     [x,y] -> [x,y]
+                     _     -> error "dToStr: too many hex digits for float"
+
+        str  = map toUpper $ concat $ fixEndian $ map hex bs
+    in  text "0x" <> text str
+
+-- Note [LLVM Float Types]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+-- We use 'ppDouble' for both printing Float and Double floating point types. This is
+-- as LLVM expects all floating point constants (single & double) to be in IEEE
+-- 754 Double precision format. However, for single precision numbers (Float)
+-- they should be *representable* in IEEE 754 Single precision format. So the
+-- easiest way to do this is to narrow and widen again.
+-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC
+-- doesn't optimize that away.
+
+-- Note [narrowFp & widenFp]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NOTE: we use float2Double & co directly as GHC likes to optimize away
+-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600).
+-- 'realToFrac' has inconsistent behaviour with optimisation as well that can
+-- also cause issues, these methods don't.
+
+narrowFp :: Double -> Float
+{-# NOINLINE narrowFp #-}
+narrowFp = double2Float
+
+widenFp :: Float -> Double
+{-# NOINLINE widenFp #-}
+widenFp = float2Double
+
+ppFloat :: Float -> SDoc
+ppFloat = ppDouble . widenFp
+
+-- | Reverse or leave byte data alone to fix endianness on this target.
+fixEndian :: [a] -> [a]
+#if defined(WORDS_BIGENDIAN)
+fixEndian = id
+#else
+fixEndian = reverse
+#endif
+
+
+--------------------------------------------------------------------------------
+-- * Misc functions
+--------------------------------------------------------------------------------
+
+ppCommaJoin :: (Outputable a) => [a] -> SDoc
+ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)
+
+ppSpaceJoin :: (Outputable a) => [a] -> SDoc
+ppSpaceJoin strs = hsep (map ppr strs)
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}
+
+-- -----------------------------------------------------------------------------
+-- | This is the top-level module in the LLVM code generator.
+--
+module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+import LlvmCodeGen.CodeGen
+import LlvmCodeGen.Data
+import LlvmCodeGen.Ppr
+import LlvmCodeGen.Regs
+import LlvmMangler
+
+import BlockId
+import CgUtils ( fixStgRegisters )
+import Cmm
+import CmmUtils
+import Hoopl.Block
+import Hoopl.Collections
+import PprCmm
+
+import BufWrite
+import DynFlags
+import ErrUtils
+import FastString
+import Outputable
+import UniqSupply
+import SysTools ( figureLlvmVersion )
+import qualified Stream
+
+import Control.Monad ( when )
+import Data.Maybe ( fromMaybe, catMaybes )
+import System.IO
+
+-- -----------------------------------------------------------------------------
+-- | Top-level of the LLVM Code generator
+--
+llvmCodeGen :: DynFlags -> Handle -> UniqSupply
+               -> Stream.Stream IO RawCmmGroup ()
+               -> IO ()
+llvmCodeGen dflags h us cmm_stream
+  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
+       bufh <- newBufHandle h
+
+       -- Pass header
+       showPass dflags "LLVM CodeGen"
+
+       -- get llvm version, cache for later use
+       ver <- (fromMaybe supportedLlvmVersion) `fmap` 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...")
+
+       -- run code generation
+       runLlvm dflags ver bufh us $
+         llvmCodeGen' (liftStream cmm_stream)
+
+       bFlush bufh
+
+llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
+llvmCodeGen' cmm_stream
+  = do  -- Preamble
+        renderLlvm header
+        ghcInternalFunctions
+        cmmMetaLlvmPrelude
+
+        -- Procedures
+        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
+        _ <- Stream.collect llvmStream
+
+        -- Declare aliases for forward references
+        renderLlvm . pprLlvmData =<< generateExternDecls
+
+        -- Postamble
+        cmmUsedLlvmGens
+  where
+    header :: SDoc
+    header = sdocWithDynFlags $ \dflags ->
+      let target = LLVM_TARGET
+          layout = case lookup target (llvmTargets dflags) of
+            Just (LlvmTarget dl _ _) -> dl
+            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
+      in     text ("target datalayout = \"" ++ layout ++ "\"")
+         $+$ text ("target triple = \"" ++ target ++ "\"")
+
+llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
+llvmGroupLlvmGens cmm = do
+
+        -- Insert functions into map, collect data
+        let split (CmmData s d' )     = return $ Just (s, d')
+            split (CmmProc h l live g) = do
+              -- Set function type
+              let l' = case mapLookup (g_entry g) h of
+                         Nothing                   -> l
+                         Just (Statics info_lbl _) -> info_lbl
+              lml <- strCLabel_llvm l'
+              funInsert lml =<< llvmFunTy live
+              return Nothing
+        cdata <- fmap catMaybes $ mapM split cmm
+
+        {-# SCC "llvm_datas_gen" #-}
+          cmmDataLlvmGens cdata
+        {-# SCC "llvm_procs_gen" #-}
+          mapM_ cmmLlvmGen cmm
+
+-- -----------------------------------------------------------------------------
+-- | Do LLVM code generation on all these Cmms data sections.
+--
+cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
+
+cmmDataLlvmGens statics
+  = do lmdatas <- mapM genLlvmData statics
+
+       let (concat -> gs, tss) = unzip lmdatas
+
+       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
+                        = funInsert l ty
+           regGlobal _  = pure ()
+       mapM_ regGlobal gs
+       gss' <- mapM aliasify $ gs
+
+       renderLlvm $ pprLlvmData (concat gss', concat tss)
+
+-- | LLVM can't handle entry blocks which loop back to themselves (could be
+-- seen as an LLVM bug) so we rearrange the code to keep the original entry
+-- label which branches to a newly generated second label that branches back
+-- to itself. See: #11649
+fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
+fixBottom cp@(CmmProc hdr entry_lbl live g) =
+    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
+  where
+    blk_map = toBlockMap g
+
+    fix_block :: CmmBlock -> LlvmM RawCmmDecl
+    fix_block blk
+        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
+        , isEmptyBlock middle
+        , e_lbl == b_lbl = do
+            new_lbl <- mkBlockId <$> getUniqueM
+
+            let fst_blk =
+                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
+                snd_blk =
+                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)
+
+            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
+                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]
+
+    fix_block _ = pure cp
+
+fixBottom rcd = pure rcd
+
+-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
+cmmLlvmGen ::RawCmmDecl -> LlvmM ()
+cmmLlvmGen cmm@CmmProc{} = do
+
+    -- rewrite assignments to global regs
+    dflags <- getDynFlag id
+    fixed_cmm <- fixBottom $
+                    {-# SCC "llvm_fix_regs" #-}
+                    fixStgRegisters dflags cmm
+
+    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
+
+    -- generate llvm code from cmm
+    llvmBC <- withClearVars $ genLlvmProc fixed_cmm
+
+    -- pretty print
+    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
+
+    -- Output, note down used variables
+    renderLlvm (vcat docs)
+    mapM_ markUsedVar $ concat ivars
+
+cmmLlvmGen _ = return ()
+
+-- -----------------------------------------------------------------------------
+-- | Generate meta data nodes
+--
+
+cmmMetaLlvmPrelude :: LlvmM ()
+cmmMetaLlvmPrelude = do
+  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
+    -- Generate / lookup meta data IDs
+    tbaaId <- getMetaUniqueId
+    setUniqMeta uniq tbaaId
+    parentId <- maybe (return Nothing) getUniqMeta parent
+    -- Build definition
+    return $ MetaUnnamed tbaaId $ MetaStruct $
+          case parentId of
+              Just p  -> [ MetaStr name, MetaNode p ]
+              -- As of LLVM 4.0, a node without parents should be rendered as
+              -- just a name on its own. Previously `null` was accepted as the
+              -- name.
+              Nothing -> [ MetaStr name ]
+  renderLlvm $ ppLlvmMetas metas
+
+-- -----------------------------------------------------------------------------
+-- | Marks variables as used where necessary
+--
+
+cmmUsedLlvmGens :: LlvmM ()
+cmmUsedLlvmGens = do
+
+  -- LLVM would discard variables that are internal and not obviously
+  -- used if we didn't provide these hints. This will generate a
+  -- definition of the form
+  --
+  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
+  --
+  -- Which is the LLVM way of protecting them against getting removed.
+  ivars <- getUsedVars
+  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+      ty     = (LMArray (length ivars) i8Ptr)
+      usedArray = LMStaticArray (map cast ivars) ty
+      sectName  = Just $ fsLit "llvm.metadata"
+      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
+      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
+  if null ivars
+     then return ()
+     else renderLlvm $ pprLlvmData ([lmUsed], [])
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -0,0 +1,571 @@
+{-# LANGUAGE CPP #-}
+
+-- ----------------------------------------------------------------------------
+-- | Base LLVM Code Generation module
+--
+-- Contains functions useful through out the code generator.
+--
+
+module LlvmCodeGen.Base (
+
+        LlvmCmmDecl, LlvmBasicBlock,
+        LiveGlobalRegs,
+        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
+
+        LlvmVersion, supportedLlvmVersion, llvmVersionStr,
+
+        LlvmM,
+        runLlvm, liftStream, withClearVars, varLookup, varInsert,
+        markStackReg, checkStackReg,
+        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
+        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
+        ghcInternalFunctions,
+
+        getMetaUniqueId,
+        setUniqMeta, getUniqMeta,
+
+        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+        llvmPtrBits, tysToParams, llvmFunSection,
+
+        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
+        getGlobalPtr, generateExternDecls,
+
+        aliasify, llvmDefLabel
+    ) where
+
+#include "HsVersions.h"
+#include "ghcautoconf.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Regs
+
+import CLabel
+import CodeGen.Platform ( activeStgRegs )
+import DynFlags
+import FastString
+import Cmm              hiding ( succ )
+import Outputable as Outp
+import Platform
+import UniqFM
+import Unique
+import BufWrite   ( BufHandle )
+import UniqSet
+import UniqSupply
+import ErrUtils
+import qualified Stream
+
+import Data.Maybe (fromJust)
+import Control.Monad (ap)
+
+-- ----------------------------------------------------------------------------
+-- * Some Data Types
+--
+
+type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
+type LlvmBasicBlock = GenBasicBlock LlvmStatement
+
+-- | Global registers live on proc entry
+type LiveGlobalRegs = [GlobalReg]
+
+-- | Unresolved code.
+-- Of the form: (data label, data type, unresolved data)
+type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
+
+-- | Top level LLVM Data (globals and type aliases)
+type LlvmData = ([LMGlobal], [LlvmType])
+
+-- | An unresolved Label.
+--
+-- Labels are unresolved when we haven't yet determined if they are defined in
+-- the module we are currently compiling, or an external one.
+type UnresLabel  = CmmLit
+type UnresStatic = Either UnresLabel LlvmStatic
+
+-- ----------------------------------------------------------------------------
+-- * Type translations
+--
+
+-- | Translate a basic CmmType to an LlvmType.
+cmmToLlvmType :: CmmType -> LlvmType
+cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
+                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
+                 | otherwise      = widthToLlvmInt   $ typeWidth ty
+
+-- | Translate a Cmm Float Width to a LlvmType.
+widthToLlvmFloat :: Width -> LlvmType
+widthToLlvmFloat W32  = LMFloat
+widthToLlvmFloat W64  = LMDouble
+widthToLlvmFloat W128 = LMFloat128
+widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
+
+-- | Translate a Cmm Bit Width to a LlvmType.
+widthToLlvmInt :: Width -> LlvmType
+widthToLlvmInt w = LMInt $ widthInBits w
+
+-- | GHC Call Convention for LLVM
+llvmGhcCC :: DynFlags -> LlvmCallConvention
+llvmGhcCC dflags
+ | platformUnregisterised (targetPlatform dflags) = CC_Ccc
+ | otherwise                                      = CC_Ghc
+
+-- | Llvm Function type for Cmm function
+llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
+llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
+
+-- | Llvm Function signature
+llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig live lbl link = do
+  lbl' <- strCLabel_llvm lbl
+  llvmFunSig' live lbl' link
+
+llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig' live lbl link
+  = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
+                      | otherwise   = (x, [])
+       dflags <- getDynFlags
+       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+                                 (map (toParams . getVarType) (llvmFunArgs dflags live))
+                                 (llvmFunAlign dflags)
+
+-- | Alignment to use for functions
+llvmFunAlign :: DynFlags -> LMAlign
+llvmFunAlign dflags = Just (wORD_SIZE dflags)
+
+-- | Alignment to use for into tables
+llvmInfAlign :: DynFlags -> LMAlign
+llvmInfAlign dflags = Just (wORD_SIZE dflags)
+
+-- | Section to use for a function
+llvmFunSection :: DynFlags -> LMString -> LMSection
+llvmFunSection dflags lbl
+    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
+    | otherwise                     = Nothing
+
+-- | A Function's arguments
+llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
+llvmFunArgs dflags live =
+    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
+    where platform = targetPlatform dflags
+          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
+          isPassed r = not (isSSE r) || isLive r
+          isSSE (FloatReg _)  = True
+          isSSE (DoubleReg _) = True
+          isSSE (XmmReg _)    = True
+          isSSE (YmmReg _)    = True
+          isSSE (ZmmReg _)    = True
+          isSSE _             = False
+
+-- | Llvm standard fun attributes
+llvmStdFunAttrs :: [LlvmFuncAttr]
+llvmStdFunAttrs = [NoUnwind]
+
+-- | Convert a list of types to a list of function parameters
+-- (each with no parameter attributes)
+tysToParams :: [LlvmType] -> [LlvmParameter]
+tysToParams = map (\ty -> (ty, []))
+
+-- | Pointer width
+llvmPtrBits :: DynFlags -> Int
+llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
+
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- | LLVM Version Number
+type LlvmVersion = (Int, Int)
+
+-- | The LLVM Version that is currently supported.
+supportedLlvmVersion :: LlvmVersion
+supportedLlvmVersion = sUPPORTED_LLVM_VERSION
+
+llvmVersionStr :: LlvmVersion -> String
+llvmVersionStr (major, minor) = show major ++ "." ++ show minor
+
+-- ----------------------------------------------------------------------------
+-- * Environment Handling
+--
+
+data LlvmEnv = LlvmEnv
+  { envVersion :: LlvmVersion      -- ^ LLVM version
+  , envDynFlags :: DynFlags        -- ^ Dynamic flags
+  , envOutput :: BufHandle         -- ^ Output buffer
+  , envUniq :: UniqSupply          -- ^ Supply of unique values
+  , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs
+  , envUniqMeta :: UniqFM MetaId   -- ^ Global metadata nodes
+  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
+  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
+  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
+
+    -- the following get cleared for every function (see @withClearVars@)
+  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type
+  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)
+  }
+
+type LlvmEnvMap = UniqFM LlvmType
+
+-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
+newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
+
+instance Functor LlvmM where
+    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+                                  return (f x, env')
+
+instance Applicative LlvmM where
+    pure x = LlvmM $ \env -> return (x, env)
+    (<*>) = ap
+
+instance Monad LlvmM where
+    m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+                                  runLlvmM (f x) env'
+
+instance HasDynFlags LlvmM where
+    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
+
+instance MonadUnique LlvmM where
+    getUniqueSupplyM = do
+        us <- getEnv envUniq
+        let (us1, us2) = splitUniqSupply us
+        modifyEnv (\s -> s { envUniq = us2 })
+        return us1
+
+    getUniqueM = do
+        us <- getEnv envUniq
+        let (u,us') = takeUniqFromSupply us
+        modifyEnv (\s -> s { envUniq = us' })
+        return u
+
+-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
+liftIO :: IO a -> LlvmM a
+liftIO m = LlvmM $ \env -> do x <- m
+                              return (x, env)
+
+-- | Get initial Llvm environment.
+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
+runLlvm dflags ver out us m = do
+    _ <- runLlvmM m env
+    return ()
+  where env = LlvmEnv { envFunMap = emptyUFM
+                      , envVarMap = emptyUFM
+                      , envStackRegs = []
+                      , envUsedVars = []
+                      , envAliases = emptyUniqSet
+                      , envVersion = ver
+                      , envDynFlags = dflags
+                      , envOutput = out
+                      , envUniq = us
+                      , envFreshMeta = MetaId 0
+                      , envUniqMeta = emptyUFM
+                      }
+
+-- | Get environment (internal)
+getEnv :: (LlvmEnv -> a) -> LlvmM a
+getEnv f = LlvmM (\env -> return (f env, env))
+
+-- | Modify environment (internal)
+modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
+modifyEnv f = LlvmM (\env -> return ((), f env))
+
+-- | Lift a stream into the LlvmM monad
+liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
+liftStream s = Stream.Stream $ do
+  r <- liftIO $ Stream.runStream s
+  case r of
+    Left b        -> return (Left b)
+    Right (a, r2) -> return (Right (a, liftStream r2))
+
+-- | Clear variables from the environment for a subcomputation
+withClearVars :: LlvmM a -> LlvmM a
+withClearVars m = LlvmM $ \env -> do
+    (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
+    return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
+
+-- | Insert variables or functions into the environment.
+varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
+
+-- | Lookup variables or functions in the environment.
+varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
+varLookup s = getEnv (flip lookupUFM s . envVarMap)
+funLookup s = getEnv (flip lookupUFM s . envFunMap)
+
+-- | Set a register as allocated on the stack
+markStackReg :: GlobalReg -> LlvmM ()
+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
+
+-- | Check whether a register is allocated on the stack
+checkStackReg :: GlobalReg -> LlvmM Bool
+checkStackReg r = getEnv ((elem r) . envStackRegs)
+
+-- | Allocate a new global unnamed metadata identifier
+getMetaUniqueId :: LlvmM MetaId
+getMetaUniqueId = LlvmM $ \env ->
+    return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
+
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmM LlvmVersion
+getLlvmVer = getEnv envVersion
+
+-- | Get the platform we are generating code for
+getDynFlag :: (DynFlags -> a) -> LlvmM a
+getDynFlag f = getEnv (f . envDynFlags)
+
+-- | Get the platform we are generating code for
+getLlvmPlatform :: LlvmM Platform
+getLlvmPlatform = getDynFlag targetPlatform
+
+-- | Dumps the document if the corresponding flag has been set by the user
+dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
+dumpIfSetLlvm flag hdr doc = do
+  dflags <- getDynFlags
+  liftIO $ dumpIfSet_dyn dflags flag hdr doc
+
+-- | Prints the given contents to the output handle
+renderLlvm :: Outp.SDoc -> LlvmM ()
+renderLlvm sdoc = do
+
+    -- Write to output
+    dflags <- getDynFlags
+    out <- getEnv envOutput
+    liftIO $ Outp.bufLeftRenderSDoc dflags out
+               (Outp.mkCodeStyle Outp.CStyle) sdoc
+
+    -- Dump, if requested
+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
+    return ()
+
+-- | Marks a variable as "used"
+markUsedVar :: LlvmVar -> LlvmM ()
+markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
+
+-- | Return all variables marked as "used" so far
+getUsedVars :: LlvmM [LlvmVar]
+getUsedVars = getEnv envUsedVars
+
+-- | Saves that at some point we didn't know the type of the label and
+-- generated a reference to a type variable instead
+saveAlias :: LMString -> LlvmM ()
+saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
+
+-- | Sets metadata node for a given unique
+setUniqMeta :: Unique -> MetaId -> LlvmM ()
+setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
+
+-- | Gets metadata node for given unique
+getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
+getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
+
+-- ----------------------------------------------------------------------------
+-- * Internal functions
+--
+
+-- | Here we pre-initialise some functions that are used internally by GHC
+-- so as to make sure they have the most general type in the case that
+-- user code also uses these functions but with a different type than GHC
+-- internally. (Main offender is treating return type as 'void' instead of
+-- 'void *'). Fixes trac #5486.
+ghcInternalFunctions :: LlvmM ()
+ghcInternalFunctions = do
+    dflags <- getDynFlags
+    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
+    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
+  where
+    mk n ret args = do
+      let n' = llvmDefLabel $ fsLit n
+          decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
+                                 FixedArgs (tysToParams args) Nothing
+      renderLlvm $ ppLlvmFunctionDecl decl
+      funInsert n' (LMFunction decl)
+
+-- ----------------------------------------------------------------------------
+-- * Label handling
+--
+
+-- | Pretty print a 'CLabel'.
+strCLabel_llvm :: CLabel -> LlvmM LMString
+strCLabel_llvm lbl = do
+    dflags <- getDynFlags
+    let sdoc = pprCLabel dflags lbl
+        str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
+    return (fsLit str)
+
+strDisplayName_llvm :: CLabel -> LlvmM LMString
+strDisplayName_llvm lbl = do
+    dflags <- getDynFlags
+    let sdoc = pprCLabel dflags lbl
+        depth = Outp.PartWay 1
+        style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
+        str = Outp.renderWithStyle dflags sdoc style
+    return (fsLit (dropInfoSuffix str))
+
+dropInfoSuffix :: String -> String
+dropInfoSuffix = go
+  where go "_info"        = []
+        go "_static_info" = []
+        go "_con_info"    = []
+        go (x:xs)         = x:go xs
+        go []             = []
+
+strProcedureName_llvm :: CLabel -> LlvmM LMString
+strProcedureName_llvm lbl = do
+    dflags <- getDynFlags
+    let sdoc = pprCLabel dflags lbl
+        depth = Outp.PartWay 1
+        style = Outp.mkUserStyle dflags Outp.neverQualify depth
+        str = Outp.renderWithStyle dflags sdoc style
+    return (fsLit str)
+
+-- ----------------------------------------------------------------------------
+-- * Global variables / forward references
+--
+
+-- | Create/get a pointer to a global value. Might return an alias if
+-- the value in question hasn't been defined yet. We especially make
+-- no guarantees on the type of the returned pointer.
+getGlobalPtr :: LMString -> LlvmM LlvmVar
+getGlobalPtr llvmLbl = do
+  m_ty <- funLookup llvmLbl
+  let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
+  case m_ty of
+    -- Directly reference if we have seen it already
+    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
+    -- Otherwise use a forward alias of it
+    Nothing -> do
+      saveAlias llvmLbl
+      return $ mkGlbVar llvmLbl i8 Alias
+
+-- | Derive the definition label. It has an identified
+-- structure type.
+llvmDefLabel :: LMString -> LMString
+llvmDefLabel = (`appendFS` fsLit "$def")
+
+-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
+--
+-- Must be called at a point where we are sure that no new global definitions
+-- will be generated anymore!
+generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
+generateExternDecls = do
+  delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
+  -- This is non-deterministic but we do not
+  -- currently support deterministic code-generation.
+  -- See Note [Unique Determinism and code generation]
+  defss <- flip mapM delayed $ \lbl -> do
+    m_ty <- funLookup lbl
+    case m_ty of
+      -- If we have a definition we've already emitted the proper aliases
+      -- when the symbol itself was emitted by @aliasify@
+      Just _ -> return []
+
+      -- If we don't have a definition this is an external symbol and we
+      -- need to emit a declaration
+      Nothing ->
+        let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
+        in return [LMGlobal var Nothing]
+
+  -- Reset forward list
+  modifyEnv $ \env -> env { envAliases = emptyUniqSet }
+  return (concat defss, [])
+
+-- | Here we take a global variable definition, rename it with a
+-- @$def@ suffix, and generate the appropriate alias.
+aliasify :: LMGlobal -> LlvmM [LMGlobal]
+-- See note [emit-time elimination of static indirections] in CLabel.
+-- Here we obtain the indirectee's precise type and introduce
+-- fresh aliases to both the precise typed label (lbl$def) and the i8*
+-- typed (regular) label of it with the matching new names.
+aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
+                   (Just orig)) = do
+    let defLbl = llvmDefLabel lbl
+        LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
+        defOrigLbl = llvmDefLabel origLbl
+        orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
+    origType <- funLookup origLbl
+    let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
+                                           (pLift $ fromJust origType) oLnk
+                                           Nothing Nothing Alias))
+                         (pLift ty)
+    pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
+         , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
+         ]
+aliasify (LMGlobal var val) = do
+    let LMGlobalVar lbl ty link sect align const = var
+
+        defLbl = llvmDefLabel lbl
+        defVar = LMGlobalVar defLbl ty Internal sect align const
+
+        defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
+        aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias
+        aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
+
+    -- we need to mark the $def symbols as used so LLVM doesn't forget which
+    -- section they need to go in. This will vanish once we switch away from
+    -- mangling sections for TNTC.
+    markUsedVar defVar
+
+    return [ LMGlobal defVar val
+           , LMGlobal aliasVar (Just aliasVal)
+           ]
+
+-- Note [Llvm Forward References]
+--
+-- The issue here is that LLVM insists on being strongly typed at
+-- every corner, so the first time we mention something, we have to
+-- settle what type we assign to it. That makes things awkward, as Cmm
+-- will often reference things before their definition, and we have no
+-- idea what (LLVM) type it is going to be before that point.
+--
+-- Our work-around is to define "aliases" of a standard type (i8 *) in
+-- these kind of situations, which we later tell LLVM to be either
+-- references to their actual local definitions (involving a cast) or
+-- an external reference. This obviously only works for pointers.
+--
+-- In particular when we encounter a reference to a symbol in a chunk of
+-- C-- there are three possible scenarios,
+--
+--   1. We have already seen a definition for the referenced symbol. This
+--      means we already know its type.
+--
+--   2. We have not yet seen a definition but we will find one later in this
+--      compilation unit. Since we want to be a good consumer of the
+--      C-- streamed to us from upstream, we don't know the type of the
+--      symbol at the time when we must emit the reference.
+--
+--   3. We have not yet seen a definition nor will we find one in this
+--      compilation unit. In this case the reference refers to an
+--      external symbol for which we do not know the type.
+--
+-- Let's consider case (2) for a moment: say we see a reference to
+-- the symbol @fooBar@ for which we have not seen a definition. As we
+-- do not know the symbol's type, we assume it is of type @i8*@ and emit
+-- the appropriate casts in @getSymbolPtr@. Later on, when we
+-- encounter the definition of @fooBar@ we emit it but with a modified
+-- name, @fooBar$def@ (which we'll call the definition symbol), to
+-- since we have already had to assume that the symbol @fooBar@
+-- is of type @i8*@. We then emit @fooBar@ itself as an alias
+-- of @fooBar$def@ with appropriate casts. This all happens in
+-- @aliasify@.
+--
+-- Case (3) is quite similar to (2): References are emitted assuming
+-- the referenced symbol is of type @i8*@. When we arrive at the end of
+-- the compilation unit and realize that the symbol is external, we emit
+-- an LLVM @external global@ declaration for the symbol @fooBar@
+-- (handled in @generateExternDecls@). This takes advantage of the
+-- fact that the aliases produced by @aliasify@ for exported symbols
+-- have external linkage and can therefore be used as normal symbols.
+--
+-- Historical note: As of release 3.5 LLVM does not allow aliases to
+-- refer to declarations. This the reason why aliases are produced at the
+-- point of definition instead of the point of usage, as was previously
+-- done. See #9142 for details.
+--
+-- Finally, case (1) is trival. As we already have a definition for
+-- and therefore know the type of the referenced symbol, we can do
+-- away with casting the alias to the desired type in @getSymbolPtr@
+-- and instead just emit a reference to the definition symbol directly.
+-- This is the @Just@ case in @getSymbolPtr@.
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -0,0 +1,2011 @@
+{-# LANGUAGE CPP, GADTs #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmProc to LLVM code.
+--
+module LlvmCodeGen.CodeGen ( genLlvmProc ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+import LlvmCodeGen.Regs
+
+import BlockId
+import CodeGen.Platform ( activeStgRegs, callerSaves )
+import CLabel
+import Cmm
+import PprCmm
+import CmmUtils
+import CmmSwitch
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+
+import DynFlags
+import FastString
+import ForeignCall
+import Outputable hiding (panic, pprPanic)
+import qualified Outputable
+import Platform
+import OrdList
+import UniqSupply
+import Unique
+import Util
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer
+
+import qualified Data.Semigroup as Semigroup
+import Data.List ( nub )
+import Data.Maybe ( catMaybes )
+
+type Atomic = Bool
+type LlvmStatements = OrdList LlvmStatement
+
+data Signage = Signed | Unsigned deriving (Eq, Show)
+
+-- -----------------------------------------------------------------------------
+-- | Top-level of the LLVM proc Code generator
+--
+genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
+genLlvmProc (CmmProc infos lbl live graph) = do
+    let blocks = toBlockListEntryFirstFalseFallthrough graph
+    (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
+    let info = mapLookup (g_entry graph) infos
+        proc = CmmProc info lbl live (ListGraph lmblocks)
+    return (proc:lmdata)
+
+genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
+
+-- -----------------------------------------------------------------------------
+-- * Block code generation
+--
+
+-- | Generate code for a list of blocks that make up a complete
+-- procedure. The first block in the list is expected to be the entry
+-- point and will get the prologue.
+basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
+                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
+basicBlocksCodeGen _    []                     = panic "no entry block!"
+basicBlocksCodeGen live (entryBlock:cmmBlocks)
+  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)
+
+       -- Generate code
+       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock
+       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
+
+       -- Compose
+       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)
+       return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)
+
+
+-- | Generate code for one block
+basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen block
+  = do let (_, nodes, tail)  = blockSplit block
+           id = entryLabel block
+       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
+       (tail_instrs, top')  <- stmtToInstrs tail
+       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
+       return (BasicBlock id instrs, top' ++ top)
+
+-- -----------------------------------------------------------------------------
+-- * CmmNode code generation
+--
+
+-- A statement conversion return data.
+--   * LlvmStatements: The compiled LLVM statements.
+--   * LlvmCmmDecl: Any global data needed.
+type StmtData = (LlvmStatements, [LlvmCmmDecl])
+
+
+-- | Convert a list of CmmNode's to LlvmStatement's
+stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
+stmtsToInstrs stmts
+   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
+        return (concatOL instrss, concat topss)
+
+
+-- | Convert a CmmStmt to a list of LlvmStatement's
+stmtToInstrs :: CmmNode e x -> LlvmM StmtData
+stmtToInstrs stmt = case stmt of
+
+    CmmComment _         -> return (nilOL, []) -- nuke comments
+    CmmTick    _         -> return (nilOL, [])
+    CmmUnwind  {}        -> return (nilOL, [])
+
+    CmmAssign reg src    -> genAssign reg src
+    CmmStore addr src    -> genStore addr src
+
+    CmmBranch id         -> genBranch id
+    CmmCondBranch arg true false likely
+                         -> genCondBranch arg true false likely
+    CmmSwitch arg ids    -> genSwitch arg ids
+
+    -- Foreign Call
+    CmmUnsafeForeignCall target res args
+        -> genCall target res args
+
+    -- Tail call
+    CmmCall { cml_target = arg,
+              cml_args_regs = live } -> genJump arg live
+
+    _ -> panic "Llvm.CodeGen.stmtToInstrs"
+
+-- | Wrapper function to declare an instrinct function by function type
+getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
+getInstrinct2 fname fty@(LMFunction funSig) = do
+
+    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant
+
+    fn <- funLookup fname
+    tops <- case fn of
+      Just _  ->
+        return []
+      Nothing -> do
+        funInsert fname fty
+        un <- getUniqueM
+        let lbl = mkAsmTempLabel un
+        return [CmmData (Section Data lbl) [([],[fty])]]
+
+    return (fv, nilOL, tops)
+
+getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"
+
+-- | Declares an instrinct function by return and parameter types
+getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
+getInstrinct fname retTy parTys =
+    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
+                    FixedArgs (tysToParams parTys) Nothing
+        fty = LMFunction funSig
+    in getInstrinct2 fname fty
+
+-- | Memory barrier instruction for LLVM >= 3.0
+barrier :: LlvmM StmtData
+barrier = do
+    let s = Fence False SyncSeqCst
+    return (unitOL s, [])
+
+-- | Foreign Calls
+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+
+-- Write barrier needs to be handled specially as it is implemented as an LLVM
+-- intrinsic function.
+genCall (PrimTarget MO_WriteBarrier) _ _ = do
+    platform <- getLlvmPlatform
+    if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
+       then return (nilOL, [])
+       else barrier
+
+genCall (PrimTarget MO_Touch) _ _
+ = return (nilOL, [])
+
+genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
+    dstV <- getCmmRegW (CmmLocal dst)
+    let ty = cmmToLlvmType $ localRegType dst
+        width = widthToLlvmFloat w
+    castV <- lift $ mkLocalVar ty
+    ve <- exprToVarW e
+    statement $ Assignment castV $ Cast LM_Uitofp ve width
+    statement $ Store castV dstV
+
+genCall (PrimTarget (MO_UF_Conv _)) [_] args =
+    panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
+    "Can only handle 1, given" ++ show (length args) ++ "."
+
+-- Handle prefetching data
+genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
+  | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do
+    let argTy = [i8Ptr, i32, i32, i32]
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints' = zip args arg_hints
+    argVars <- arg_varsW args_hints' ([], nilOL, [])
+    fptr    <- liftExprData $ getFunPtr funTy t
+    argVars' <- castVarsW Signed $ zip argVars argTy
+
+    doTrashStmts
+    let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
+    statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
+  | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
+
+-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
+-- and return types
+genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
+    genCallSimpleCast w t dsts args
+
+genCall t@(PrimTarget (MO_Pdep w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Pext w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Clz w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_Ctz w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_BSwap w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_BRev w)) dsts args =
+    genCallSimpleCast w t dsts args
+
+genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    nVar <- exprToVarW n
+    let targetTy = widthToLlvmInt width
+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+    ptrVar <- doExprW (pLift targetTy) ptrExpr
+    dstVar <- getCmmRegW (CmmLocal dst)
+    let op = case amop of
+               AMO_Add  -> LAO_Add
+               AMO_Sub  -> LAO_Sub
+               AMO_And  -> LAO_And
+               AMO_Nand -> LAO_Nand
+               AMO_Or   -> LAO_Or
+               AMO_Xor  -> LAO_Xor
+    retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
+    statement $ Store retVar dstVar
+
+genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
+    dstV <- getCmmRegW (CmmLocal dst)
+    v1 <- genLoadW True addr (localRegType dst)
+    statement $ Store v1 dstV
+
+genCall (PrimTarget (MO_Cmpxchg _width))
+        [dst] [addr, old, new] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    oldVar <- exprToVarW old
+    newVar <- exprToVarW new
+    let targetTy = getVarType oldVar
+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+    ptrVar <- doExprW (pLift targetTy) ptrExpr
+    dstVar <- getCmmRegW (CmmLocal dst)
+    retVar <- doExprW (LMStructU [targetTy,i1])
+              $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
+    retVar' <- doExprW targetTy $ ExtractV retVar 0
+    statement $ Store retVar' dstVar
+
+genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    valVar <- exprToVarW val
+    let ptrTy = pLift $ getVarType valVar
+        ptrExpr = Cast LM_Inttoptr addrVar ptrTy
+    ptrVar <- doExprW ptrTy ptrExpr
+    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst
+
+-- Handle memcpy function specifically since llvm's intrinsic version takes
+-- some extra parameters.
+genCall t@(PrimTarget op) [] args
+ | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do
+    dflags <- getDynFlags
+    let isVolTy = [i1]
+        isVolVal = [mkIntLit i1 0]
+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
+              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    argVars       <- arg_varsW args_hints ([], nilOL, [])
+    fptr          <- getFunPtrW funTy t
+    argVars' <- castVarsW Signed $ zip argVars argTy
+
+    doTrashStmts
+    let alignVal = mkIntLit i32 align
+        arguments = argVars' ++ (alignVal:isVolVal)
+    statement $ Expr $ Call StdCall fptr arguments []
+
+-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands
+-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will
+-- generate 'mul' on 128-bit operands. Then we only need some plumbing to
+-- extract the two 64-bit values out of 128-bit result.
+genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
+    let width = widthToLlvmInt w
+        bitWidth = widthInBits w
+        width2x = LMInt (bitWidth * 2)
+    -- First zero-extend the operands ('mul' instruction requires the operands
+    -- and the result to be of the same type). Note that we don't use 'castVars'
+    -- because it tries to do LM_Sext.
+    lhsVar <- exprToVarW lhs
+    rhsVar <- exprToVarW rhs
+    lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x
+    rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x
+    -- Do the actual multiplication (note that the result is also 2x width).
+    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
+    -- Extract the lower bits of the result into retL.
+    retL <- doExprW width $ Cast LM_Trunc retV width
+    -- Now we right-shift the higher bits by width.
+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
+    retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
+    -- And extract them into retH.
+    retH <- doExprW width $ Cast LM_Trunc retShifted width
+    dstRegL <- getCmmRegW (CmmLocal dstL)
+    dstRegH <- getCmmRegW (CmmLocal dstH)
+    statement $ Store retL dstRegL
+    statement $ Store retH dstRegH
+
+-- MO_U_QuotRem2 is another case we handle by widening the registers to double
+-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
+-- main difference here is that we need to combine two words into one register
+-- and then use both 'udiv' and 'urem' instructions to compute the result.
+genCall (PrimTarget (MO_U_QuotRem2 w))
+        [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do
+    let width = widthToLlvmInt w
+        bitWidth = widthInBits w
+        width2x = LMInt (bitWidth * 2)
+    -- First zero-extend all parameters to double width.
+    let zeroExtend expr = do
+            var <- exprToVarW expr
+            doExprW width2x $ Cast LM_Zext var width2x
+    lhsExtH <- zeroExtend lhsH
+    lhsExtL <- zeroExtend lhsL
+    rhsExt <- zeroExtend rhs
+    -- Now we combine the first two parameters (that represent the high and low
+    -- bits of the value). So first left-shift the high bits to their position
+    -- and then bit-or them with the low bits.
+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
+    lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit
+    lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL
+    -- Finally, we can call 'udiv' and 'urem' to compute the results.
+    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt
+    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt
+    -- And since everything is in 2x width, we need to truncate the results and
+    -- then return them.
+    let narrow var = doExprW width $ Cast LM_Trunc var width
+    retDiv <- narrow retExtDiv
+    retRem <- narrow retExtRem
+    dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)
+    dstRegR <- lift $ getCmmReg (CmmLocal dstR)
+    statement $ Store retDiv dstRegQ
+    statement $ Store retRem dstRegR
+
+-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
+-- which we need to extract the actual values.
+genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the
+-- return tuple to be the overflow bit and the second element to contain the
+-- actual result of the addition. So we still use genCallWithOverflow but swap
+-- the return registers.
+genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+-- Handle all other foreign calls and prim ops.
+genCall target res args = runStmtsDecls $ do
+    dflags <- getDynFlags
+
+    -- parameter types
+    let arg_type (_, AddrHint) = i8Ptr
+        -- cast pointers to i8*. Llvm equivalent of void*
+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
+
+    -- ret type
+    let ret_type [] = LMVoid
+        ret_type [(_, AddrHint)] = i8Ptr
+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
+        ret_type t = panic $ "genCall: Too many return values! Can only handle"
+                        ++ " 0 or 1, given " ++ show (length t) ++ "."
+
+    -- extract Cmm call convention, and translate to LLVM call convention
+    platform <- lift $ getLlvmPlatform
+    let lmconv = case target of
+            ForeignTarget _ (ForeignConvention conv _ _ _) ->
+              case conv of
+                 StdCallConv  -> case platformArch platform of
+                                 ArchX86    -> CC_X86_Stdcc
+                                 ArchX86_64 -> CC_X86_Stdcc
+                                 _          -> CC_Ccc
+                 CCallConv    -> CC_Ccc
+                 CApiConv     -> CC_Ccc
+                 PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"
+                 JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv"
+
+            PrimTarget   _ -> CC_Ccc
+
+    {-
+        CC_Ccc of the possibilities here are a worry with the use of a custom
+        calling convention for passing STG args. In practice the more
+        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
+
+        The native code generator only handles StdCall and CCallConv.
+    -}
+
+    -- call attributes
+    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
+                | otherwise     = llvmStdFunAttrs
+
+        never_returns = case target of
+             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
+             _ -> False
+
+    -- fun type
+    let (res_hints, arg_hints) = foreignTargetHints target
+    let args_hints = zip args arg_hints
+    let ress_hints = zip res  res_hints
+    let ccTy  = StdCall -- tail calls should be done through CmmJump
+    let retTy = ret_type ress_hints
+    let argTy = tysToParams $ map arg_type args_hints
+    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
+
+
+    argVars <- arg_varsW args_hints ([], nilOL, [])
+    fptr    <- getFunPtrW funTy target
+
+    let doReturn | ccTy == TailCall  = statement $ Return Nothing
+                 | never_returns     = statement $ Unreachable
+                 | otherwise         = return ()
+
+    doTrashStmts
+
+    -- make the actual call
+    case retTy of
+        LMVoid -> do
+            statement $ Expr $ Call ccTy fptr argVars fnAttrs
+
+        _ -> do
+            v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs
+            -- get the return register
+            let ret_reg [reg] = reg
+                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
+                                ++ " 1, given " ++ show (length t) ++ "."
+            let creg = ret_reg res
+            vreg <- getCmmRegW (CmmLocal creg)
+            if retTy == pLower (getVarType vreg)
+                then do
+                    statement $ Store v1 vreg
+                    doReturn
+                else do
+                    let ty = pLower $ getVarType vreg
+                    let op = case ty of
+                            vt | isPointer vt -> LM_Bitcast
+                               | isInt     vt -> LM_Ptrtoint
+                               | otherwise    ->
+                                   panic $ "genCall: CmmReg bad match for"
+                                        ++ " returned type!"
+
+                    v2 <- doExprW ty $ Cast op v1 ty
+                    statement $ Store v2 vreg
+                    doReturn
+
+-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
+-- with overflow bit (i.e., returns a struct containing the actual result of the
+-- operation and an overflow bit). This function will also extract the overflow
+-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the
+-- overflow "bit" as a usual Int# or Word#).
+genCallWithOverflow
+  :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
+genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
+    -- So far this was only tested for the following four CallishMachOps.
+    let valid = op `elem`   [ MO_Add2 w
+                            , MO_AddIntC w
+                            , MO_SubIntC w
+                            , MO_AddWordC w
+                            , MO_SubWordC w
+                            ]
+    MASSERT(valid)
+    let width = widthToLlvmInt w
+    -- This will do most of the work of generating the call to the intrinsic and
+    -- extracting the values from the struct.
+    (value, overflowBit, (stmts, top)) <-
+      genCallExtract t w (lhs, rhs) (width, i1)
+    -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects
+    -- both to be i<width>)
+    (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
+    dstRegV <- getCmmReg (CmmLocal dstV)
+    dstRegO <- getCmmReg (CmmLocal dstO)
+    let storeV = Store value dstRegV
+        storeO = Store overflow dstRegO
+    return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
+genCallWithOverflow _ _ _ _ =
+    panic "genCallExtract: wrong ForeignTarget or number of arguments"
+
+-- | A helper function for genCallWithOverflow that handles generating the call
+-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.
+genCallExtract
+    :: ForeignTarget           -- ^ PrimOp
+    -> Width                   -- ^ Width of the operands.
+    -> (CmmActual, CmmActual)  -- ^ Actual arguments.
+    -> (LlvmType, LlvmType)    -- ^ LLVM types of the returned struct.
+    -> LlvmM (LlvmVar, LlvmVar, StmtData)
+genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
+    let width = widthToLlvmInt w
+        argTy = [width, width]
+        retTy = LMStructU [llvmTypeA, llvmTypeB]
+
+    -- Process the arguments.
+    let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
+    (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
+    (argsV2, args2) <- castVars Signed $ zip argsV1 argTy
+
+    -- Get the function and make the call.
+    fname <- cmmPrimOpFunctions op
+    (fptr, _, top2) <- getInstrinct fname retTy argTy
+    -- We use StdCall for primops. See also the last case of genCall.
+    (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []
+
+    -- This will result in a two element struct, we need to use "extractvalue"
+    -- to get them out of it.
+    (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)
+    (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)
+
+    let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2
+        tops = top1 ++ top2
+    return (res1, res2, (stmts, tops))
+
+genCallExtract _ _ _ _ =
+    panic "genCallExtract: unsupported ForeignTarget"
+
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width [width]
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast _ _ dsts _ =
+    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
+
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast2 _ _ dsts _ =
+    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")
+
+-- | Create a function pointer from a target.
+getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
+           -> WriterT LlvmAccum LlvmM LlvmVar
+getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ
+
+-- | Create a function pointer from a target.
+getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
+          -> LlvmM ExprData
+getFunPtr funTy targ = case targ of
+    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+        name <- strCLabel_llvm lbl
+        getHsFunc' name (funTy name)
+
+    ForeignTarget expr _ -> do
+        (v1, stmts, top) <- exprToVar expr
+        dflags <- getDynFlags
+        let fty = funTy $ fsLit "dynamic"
+            cast = case getVarType v1 of
+                ty | isPointer ty -> LM_Bitcast
+                ty | isInt ty     -> LM_Inttoptr
+
+                ty -> panic $ "genCall: Expr is of bad type for function"
+                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
+
+        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
+        return (v2, stmts `snocOL` s1, top)
+
+    PrimTarget mop -> do
+        name <- cmmPrimOpFunctions mop
+        let fty = funTy name
+        getInstrinct2 name fty
+
+-- | Conversion of call arguments.
+arg_varsW :: [(CmmActual, ForeignHint)]
+          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+          -> WriterT LlvmAccum LlvmM [LlvmVar]
+arg_varsW xs ys = do
+    (vars, stmts, decls) <- lift $ arg_vars xs ys
+    tell $ LlvmAccum stmts decls
+    return vars
+
+-- | Conversion of call arguments.
+arg_vars :: [(CmmActual, ForeignHint)]
+         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+         -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+
+arg_vars [] (vars, stmts, tops)
+  = return (vars, stmts, tops)
+
+arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
+  = do (v1, stmts', top') <- exprToVar e
+       dflags <- getDynFlags
+       let op = case getVarType v1 of
+               ty | isPointer ty -> LM_Bitcast
+               ty | isInt ty     -> LM_Inttoptr
+
+               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("
+                           ++ showSDoc dflags (ppr a) ++ ")"
+
+       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
+       arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+                               tops ++ top')
+
+arg_vars ((e, _):rest) (vars, stmts, tops)
+  = do (v1, stmts', top') <- exprToVar e
+       arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+
+
+-- | Cast a collection of LLVM variables to specific types.
+castVarsW :: Signage
+          -> [(LlvmVar, LlvmType)]
+          -> WriterT LlvmAccum LlvmM [LlvmVar]
+castVarsW signage vars = do
+    (vars, stmts) <- lift $ castVars signage vars
+    tell $ LlvmAccum stmts mempty
+    return vars
+
+-- | Cast a collection of LLVM variables to specific types.
+castVars :: Signage -> [(LlvmVar, LlvmType)]
+         -> LlvmM ([LlvmVar], LlvmStatements)
+castVars signage vars = do
+                done <- mapM (uncurry (castVar signage)) vars
+                let (vars', stmts) = unzip done
+                return (vars', toOL stmts)
+
+-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
+castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar signage v t | getVarType v == t
+            = return (v, Nop)
+
+            | otherwise
+            = do dflags <- getDynFlags
+                 let op = case (getVarType v, t) of
+                      (LMInt n, LMInt m)
+                          -> if n < m then extend else LM_Trunc
+                      (vt, _) | isFloat vt && isFloat t
+                          -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
+                                then LM_Fpext else LM_Fptrunc
+                      (vt, _) | isInt vt && isFloat t       -> LM_Sitofp
+                      (vt, _) | isFloat vt && isInt t       -> LM_Fptosi
+                      (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
+                      (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
+                      (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast
+
+                      (vt, _) -> panic $ "castVars: Can't cast this type ("
+                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
+                 doExpr t $ Cast op v t
+    where extend = case signage of
+            Signed      -> LM_Sext
+            Unsigned    -> LM_Zext
+
+
+cmmPrimOpRetValSignage :: CallishMachOp -> Signage
+cmmPrimOpRetValSignage mop = case mop of
+    MO_Pdep _   -> Unsigned
+    MO_Pext _   -> Unsigned
+    _           -> Signed
+
+-- | Decide what C function to use to implement a CallishMachOp
+cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
+cmmPrimOpFunctions mop = do
+
+  dflags <- getDynFlags
+  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+      unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+                        ++ " not supported here")
+
+  return $ case mop of
+    MO_F32_Exp    -> fsLit "expf"
+    MO_F32_Log    -> fsLit "logf"
+    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
+    MO_F32_Fabs   -> fsLit "llvm.fabs.f32"
+    MO_F32_Pwr    -> fsLit "llvm.pow.f32"
+
+    MO_F32_Sin    -> fsLit "llvm.sin.f32"
+    MO_F32_Cos    -> fsLit "llvm.cos.f32"
+    MO_F32_Tan    -> fsLit "tanf"
+
+    MO_F32_Asin   -> fsLit "asinf"
+    MO_F32_Acos   -> fsLit "acosf"
+    MO_F32_Atan   -> fsLit "atanf"
+
+    MO_F32_Sinh   -> fsLit "sinhf"
+    MO_F32_Cosh   -> fsLit "coshf"
+    MO_F32_Tanh   -> fsLit "tanhf"
+
+    MO_F32_Asinh  -> fsLit "asinhf"
+    MO_F32_Acosh  -> fsLit "acoshf"
+    MO_F32_Atanh  -> fsLit "atanhf"
+
+    MO_F64_Exp    -> fsLit "exp"
+    MO_F64_Log    -> fsLit "log"
+    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
+    MO_F64_Fabs   -> fsLit "llvm.fabs.f64"
+    MO_F64_Pwr    -> fsLit "llvm.pow.f64"
+
+    MO_F64_Sin    -> fsLit "llvm.sin.f64"
+    MO_F64_Cos    -> fsLit "llvm.cos.f64"
+    MO_F64_Tan    -> fsLit "tan"
+
+    MO_F64_Asin   -> fsLit "asin"
+    MO_F64_Acos   -> fsLit "acos"
+    MO_F64_Atan   -> fsLit "atan"
+
+    MO_F64_Sinh   -> fsLit "sinh"
+    MO_F64_Cosh   -> fsLit "cosh"
+    MO_F64_Tanh   -> fsLit "tanh"
+
+    MO_F64_Asinh  -> fsLit "asinh"
+    MO_F64_Acosh  -> fsLit "acosh"
+    MO_F64_Atanh  -> fsLit "atanh"
+
+    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1
+    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1
+    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2
+    MO_Memcmp _   -> fsLit $ "memcmp"
+
+    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_BRev w)   -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Clz w)    -> fsLit $ "llvm.ctlz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Ctz w)    -> fsLit $ "llvm.cttz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+    (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'
+                            else fsLit $ "hs_pdep"              ++ w'
+    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'
+                            else fsLit $ "hs_pext"              ++ w'
+
+    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
+
+    MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+    MO_S_QuotRem {}  -> unsupported
+    MO_U_QuotRem {}  -> unsupported
+    MO_U_QuotRem2 {} -> unsupported
+    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
+    -- appropriate case of genCall.
+    MO_U_Mul2 {}     -> unsupported
+    MO_WriteBarrier  -> unsupported
+    MO_Touch         -> unsupported
+    MO_UF_Conv _     -> unsupported
+
+    MO_AtomicRead _  -> unsupported
+    MO_AtomicRMW _ _ -> unsupported
+    MO_AtomicWrite _ -> unsupported
+    MO_Cmpxchg _     -> unsupported
+
+-- | Tail function calls
+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
+
+-- Call to known function
+genJump (CmmLit (CmmLabel lbl)) live = do
+    (vf, stmts, top) <- getHsFunc live lbl
+    (stgRegs, stgStmts) <- funEpilogue live
+    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
+    let s2  = Return Nothing
+    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
+
+
+-- Call to unknown function / address
+genJump expr live = do
+    fty <- llvmFunTy live
+    (vf, stmts, top) <- exprToVar expr
+    dflags <- getDynFlags
+
+    let cast = case getVarType vf of
+         ty | isPointer ty -> LM_Bitcast
+         ty | isInt ty     -> LM_Inttoptr
+
+         ty -> panic $ "genJump: Expr is of bad type for function call! ("
+                     ++ showSDoc dflags (ppr ty) ++ ")"
+
+    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
+    (stgRegs, stgStmts) <- funEpilogue live
+    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
+    let s3 = Return Nothing
+    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
+            top)
+
+
+-- | CmmAssign operation
+--
+-- We use stack allocated variables for CmmReg. The optimiser will replace
+-- these with registers when possible.
+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
+genAssign reg val = do
+    vreg <- getCmmReg reg
+    (vval, stmts2, top2) <- exprToVar val
+    let stmts = stmts2
+
+    let ty = (pLower . getVarType) vreg
+    dflags <- getDynFlags
+    case ty of
+      -- Some registers are pointer types, so need to cast value to pointer
+      LMPointer _ | getVarType vval == llvmWord dflags -> do
+          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+          let s2 = Store v vreg
+          return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+      LMVector _ _ -> do
+          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
+          let s2 = Store v vreg
+          return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+      _ -> do
+          let s1 = Store vval vreg
+          return (stmts `snocOL` s1, top2)
+
+
+-- | CmmStore operation
+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genStore addr@(CmmReg (CmmGlobal r)) val
+    = genStore_fast addr r 0 val
+
+genStore addr@(CmmRegOff (CmmGlobal r) n) val
+    = genStore_fast addr r n val
+
+genStore addr@(CmmMachOp (MO_Add _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                val
+    = genStore_fast addr r (fromInteger n) val
+
+genStore addr@(CmmMachOp (MO_Sub _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                val
+    = genStore_fast addr r (negate $ fromInteger n) val
+
+-- generic case
+genStore addr val
+    = getTBAAMeta topN >>= genStore_slow addr val
+
+-- | CmmStore operation
+-- This is a special case for storing to a global register pointer
+-- offset such as I32[Sp+8].
+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
+              -> LlvmM StmtData
+genStore_fast addr r n val
+  = do dflags <- getDynFlags
+       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+       meta          <- getTBAARegMeta r
+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+       case isPointer grt && rem == 0 of
+            True -> do
+                (vval,  stmts, top) <- exprToVar val
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                -- We might need a different pointer type, so check
+                case pLower grt == getVarType vval of
+                     -- were fine
+                     True  -> do
+                         let s3 = MetaStmt meta $ Store vval ptr
+                         return (stmts `appOL` s1 `snocOL` s2
+                                 `snocOL` s3, top)
+
+                     -- cast to pointer type needed
+                     False -> do
+                         let ty = (pLift . getVarType) vval
+                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
+                         let s4 = MetaStmt meta $ Store vval ptr'
+                         return (stmts `appOL` s1 `snocOL` s2
+                                 `snocOL` s3 `snocOL` s4, top)
+
+            -- If its a bit type then we use the slow method since
+            -- we can't avoid casting anyway.
+            False -> genStore_slow addr val meta
+
+
+-- | CmmStore operation
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
+genStore_slow addr val meta = do
+    (vaddr, stmts1, top1) <- exprToVar addr
+    (vval,  stmts2, top2) <- exprToVar val
+
+    let stmts = stmts1 `appOL` stmts2
+    dflags <- getDynFlags
+    case getVarType vaddr of
+        -- sometimes we need to cast an int to a pointer before storing
+        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
+            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+            let s2 = MetaStmt meta $ Store v vaddr
+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+        LMPointer _ -> do
+            let s1 = MetaStmt meta $ Store vval vaddr
+            return (stmts `snocOL` s1, top1 ++ top2)
+
+        i@(LMInt _) | i == llvmWord dflags -> do
+            let vty = pLift $ getVarType vval
+            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
+            let s2 = MetaStmt meta $ Store vval vptr
+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+        other ->
+            pprPanic "genStore: ptr not right type!"
+                    (PprCmm.pprExpr addr <+> text (
+                        "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+                        ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+                        ", Var: " ++ showSDoc dflags (ppr vaddr)))
+
+
+-- | Unconditional branch
+genBranch :: BlockId -> LlvmM StmtData
+genBranch id =
+    let label = blockIdToLlvm id
+    in return (unitOL $ Branch label, [])
+
+
+-- | Conditional branch
+genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData
+genCondBranch cond idT idF likely = do
+    let labelT = blockIdToLlvm idT
+    let labelF = blockIdToLlvm idF
+    -- See Note [Literals and branch conditions].
+    (vc, stmts1, top1) <- exprToVarOpt i1Option cond
+    if getVarType vc == i1
+        then do
+            (vc', (stmts2, top2)) <- case likely of
+              Just b -> genExpectLit (if b then 1 else 0) i1  vc
+              _      -> pure (vc, (nilOL, []))
+            let s1 = BranchIf vc' labelT labelF
+            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
+        else do
+            dflags <- getDynFlags
+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
+
+
+-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
+genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
+genExpectLit expLit expTy var = do
+  dflags <- getDynFlags
+
+  let
+    lit = LMLitVar $ LMIntLit expLit expTy
+
+    llvmExpectName
+      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)
+      | otherwise   = panic $ "genExpectedLit: Type not an int!"
+
+  (llvmExpect, stmts, top) <-
+    getInstrinct llvmExpectName expTy [expTy, expTy]
+  (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []
+  return (var', (stmts `snocOL` call, top))
+
+{- Note [Literals and branch conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is important that whenever we generate branch conditions for
+literals like '1', they are properly narrowed to an LLVM expression of
+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
+must be certain to return a properly narrowed type. genLit is
+responsible for this, in the case of literal integers.
+
+Often, we won't see direct statements like:
+
+    if(1) {
+      ...
+    } else {
+      ...
+    }
+
+at this point in the pipeline, because the Glorious Code Generator
+will do trivial branch elimination in the sinking pass (among others,)
+which will eliminate the expression entirely.
+
+However, it's certainly possible and reasonable for this to occur in
+hand-written C-- code. Consider something like:
+
+    #if !defined(SOME_CONDITIONAL)
+    #define CHECK_THING(x) 1
+    #else
+    #define CHECK_THING(x) some_operation((x))
+    #endif
+
+    f() {
+
+      if (CHECK_THING(xyz)) {
+        ...
+      } else {
+        ...
+      }
+
+    }
+
+In such an instance, CHECK_THING might result in an *expression* in
+one case, and a *literal* in the other, depending on what in
+particular was #define'd. So we must be sure to properly narrow the
+literal in this case to i1 as it won't be eliminated beforehand.
+
+For a real example of this, see ./rts/StgStdThunks.cmm
+
+-}
+
+
+
+-- | Switch branch
+genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
+genSwitch cond ids = do
+    (vc, stmts, top) <- exprToVar cond
+    let ty = getVarType vc
+
+    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
+                 | (ix, b) <- switchTargetsCases ids ]
+    -- out of range is undefined, so let's just branch to first label
+    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
+               | otherwise                          = snd (head labels)
+
+    let s1 = Switch vc defLbl labels
+    return $ (stmts `snocOL` s1, top)
+
+
+-- -----------------------------------------------------------------------------
+-- * CmmExpr code generation
+--
+
+-- | An expression conversion return data:
+--   * LlvmVar: The var holding the result of the expression
+--   * LlvmStatements: Any statements needed to evaluate the expression
+--   * LlvmCmmDecl: Any global data needed for this expression
+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
+
+-- | Values which can be passed to 'exprToVar' to configure its
+-- behaviour in certain circumstances.
+--
+-- Currently just used for determining if a comparison should return
+-- a boolean (i1) or a word. See Note [Literals and branch conditions].
+newtype EOption = EOption { i1Expected :: Bool }
+-- XXX: EOption is an ugly and inefficient solution to this problem.
+
+-- | i1 type expected (condition scrutinee).
+i1Option :: EOption
+i1Option = EOption True
+
+-- | Word type expected (usual).
+wordOption :: EOption
+wordOption = EOption False
+
+-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
+-- expression being stored in the returned LlvmVar.
+exprToVar :: CmmExpr -> LlvmM ExprData
+exprToVar = exprToVarOpt wordOption
+
+exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
+exprToVarOpt opt e = case e of
+
+    CmmLit lit
+        -> genLit opt lit
+
+    CmmLoad e' ty
+        -> genLoad False e' ty
+
+    -- Cmmreg in expression is the value, so must load. If you want actual
+    -- reg pointer, call getCmmReg directly.
+    CmmReg r -> do
+        (v1, ty, s1) <- getCmmRegVal r
+        case isPointer ty of
+             True  -> do
+                 -- Cmm wants the value, so pointer types must be cast to ints
+                 dflags <- getDynFlags
+                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
+                 return (v2, s1 `snocOL` s2, [])
+
+             False -> return (v1, s1, [])
+
+    CmmMachOp op exprs
+        -> genMachOp opt op exprs
+
+    CmmRegOff r i
+        -> do dflags <- getDynFlags
+              exprToVar $ expandCmmReg dflags (r, i)
+
+    CmmStackSlot _ _
+        -> panic "exprToVar: CmmStackSlot not supported!"
+
+
+-- | Handle CmmMachOp expressions
+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Unary Machop
+genMachOp _ op [x] = case op of
+
+    MO_Not w ->
+        let all1 = mkIntLit (widthToLlvmInt w) (-1)
+        in negate (widthToLlvmInt w) all1 LM_MO_Xor
+
+    MO_S_Neg w ->
+        let all0 = mkIntLit (widthToLlvmInt w) 0
+        in negate (widthToLlvmInt w) all0 LM_MO_Sub
+
+    MO_F_Neg w ->
+        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
+        in negate (widthToLlvmFloat w) all0 LM_MO_FSub
+
+    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
+    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
+
+    MO_SS_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
+
+    MO_UU_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+    MO_XX_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+    MO_FF_Conv from to
+        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
+
+    MO_VS_Neg len w ->
+        let ty    = widthToLlvmInt w
+            vecty = LMVector len ty
+            all0  = LMIntLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_Sub
+
+    MO_VF_Neg len w ->
+        let ty    = widthToLlvmFloat w
+            vecty = LMVector len ty
+            all0  = LMFloatLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_FSub
+
+    MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
+
+    -- Handle unsupported cases explicitly so we get a warning
+    -- of missing case when new MachOps added
+    MO_Add _          -> panicOp
+    MO_Mul _          -> panicOp
+    MO_Sub _          -> panicOp
+    MO_S_MulMayOflo _ -> panicOp
+    MO_S_Quot _       -> panicOp
+    MO_S_Rem _        -> panicOp
+    MO_U_MulMayOflo _ -> panicOp
+    MO_U_Quot _       -> panicOp
+    MO_U_Rem _        -> panicOp
+
+    MO_Eq  _          -> panicOp
+    MO_Ne  _          -> panicOp
+    MO_S_Ge _         -> panicOp
+    MO_S_Gt _         -> panicOp
+    MO_S_Le _         -> panicOp
+    MO_S_Lt _         -> panicOp
+    MO_U_Ge _         -> panicOp
+    MO_U_Gt _         -> panicOp
+    MO_U_Le _         -> panicOp
+    MO_U_Lt _         -> panicOp
+
+    MO_F_Add        _ -> panicOp
+    MO_F_Sub        _ -> panicOp
+    MO_F_Mul        _ -> panicOp
+    MO_F_Quot       _ -> panicOp
+    MO_F_Eq         _ -> panicOp
+    MO_F_Ne         _ -> panicOp
+    MO_F_Ge         _ -> panicOp
+    MO_F_Gt         _ -> panicOp
+    MO_F_Le         _ -> panicOp
+    MO_F_Lt         _ -> panicOp
+
+    MO_And          _ -> panicOp
+    MO_Or           _ -> panicOp
+    MO_Xor          _ -> panicOp
+    MO_Shl          _ -> panicOp
+    MO_U_Shr        _ -> panicOp
+    MO_S_Shr        _ -> panicOp
+
+    MO_V_Insert   _ _ -> panicOp
+    MO_V_Extract  _ _ -> panicOp
+
+    MO_V_Add      _ _ -> panicOp
+    MO_V_Sub      _ _ -> panicOp
+    MO_V_Mul      _ _ -> panicOp
+
+    MO_VS_Quot    _ _ -> panicOp
+    MO_VS_Rem     _ _ -> panicOp
+
+    MO_VU_Quot    _ _ -> panicOp
+    MO_VU_Rem     _ _ -> panicOp
+
+    MO_VF_Insert  _ _ -> panicOp
+    MO_VF_Extract _ _ -> panicOp
+
+    MO_VF_Add     _ _ -> panicOp
+    MO_VF_Sub     _ _ -> panicOp
+    MO_VF_Mul     _ _ -> panicOp
+    MO_VF_Quot    _ _ -> panicOp
+
+    where
+        negate ty v2 negOp = do
+            (vx, stmts, top) <- exprToVar x
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
+            return (v1, stmts `snocOL` s1, top)
+
+        negateVec ty v2 negOp = do
+            (vx, stmts1, top) <- exprToVar x
+            (vxs', stmts2) <- castVars Signed [(vx, ty)]
+            let vx' = singletonPanic "genMachOp: negateVec" vxs'
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
+            return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
+
+        fiConv ty convOp = do
+            (vx, stmts, top) <- exprToVar x
+            (v1, s1) <- doExpr ty $ Cast convOp vx ty
+            return (v1, stmts `snocOL` s1, top)
+
+        sameConv from ty reduce expand = do
+            x'@(vx, stmts, top) <- exprToVar x
+            let sameConv' op = do
+                    (v1, s1) <- doExpr ty $ Cast op vx ty
+                    return (v1, stmts `snocOL` s1, top)
+            dflags <- getDynFlags
+            let toWidth = llvmWidthInBits dflags ty
+            -- LLVM doesn't like trying to convert to same width, so
+            -- need to check for that as we do get Cmm code doing it.
+            case widthInBits from  of
+                 w | w < toWidth -> sameConv' expand
+                 w | w > toWidth -> sameConv' reduce
+                 _w              -> return x'
+
+        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
+                       ++ "with one argument! (" ++ show op ++ ")"
+
+-- Handle GlobalRegs pointers
+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+    = genMachOp_fast opt o r (fromInteger n) e
+
+genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+    = genMachOp_fast opt o r (negate . fromInteger $ n) e
+
+-- Generic case
+genMachOp opt op e = genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This is a specialised method that handles Global register manipulations like
+-- 'Sp - 16', using the getelementptr instruction.
+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
+               -> LlvmM ExprData
+genMachOp_fast opt op r n e
+  = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+       dflags <- getDynFlags
+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+       case isPointer grt && rem == 0 of
+            True -> do
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
+                return (var, s1 `snocOL` s2 `snocOL` s3, [])
+
+            False -> genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This handles all the cases not handle by the specialised genMachOp_fast.
+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Element extraction
+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
+    vval <- exprToVarW val
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
+    doExprW ty $ Extract vval' vidx
+  where
+    ty = widthToLlvmInt w
+
+genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
+    vval <- exprToVarW val
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
+    doExprW ty $ Extract vval' vidx
+  where
+    ty = widthToLlvmFloat w
+
+-- Element insertion
+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
+    vval <- exprToVarW val
+    velt <- exprToVarW elt
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
+    doExprW ty $ Insert vval' velt vidx
+  where
+    ty = LMVector l (widthToLlvmInt w)
+
+genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
+    vval <- exprToVarW val
+    velt <- exprToVarW elt
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
+    doExprW ty $ Insert vval' velt vidx
+  where
+    ty = LMVector l (widthToLlvmFloat w)
+
+-- Binary MachOp
+genMachOp_slow opt op [x, y] = case op of
+
+    MO_Eq _   -> genBinComp opt LM_CMP_Eq
+    MO_Ne _   -> genBinComp opt LM_CMP_Ne
+
+    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
+    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
+    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
+    MO_S_Le _ -> genBinComp opt LM_CMP_Sle
+
+    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
+    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
+    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
+    MO_U_Le _ -> genBinComp opt LM_CMP_Ule
+
+    MO_Add _ -> genBinMach LM_MO_Add
+    MO_Sub _ -> genBinMach LM_MO_Sub
+    MO_Mul _ -> genBinMach LM_MO_Mul
+
+    MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
+
+    MO_S_MulMayOflo w -> isSMulOK w x y
+
+    MO_S_Quot _ -> genBinMach LM_MO_SDiv
+    MO_S_Rem  _ -> genBinMach LM_MO_SRem
+
+    MO_U_Quot _ -> genBinMach LM_MO_UDiv
+    MO_U_Rem  _ -> genBinMach LM_MO_URem
+
+    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
+    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
+    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
+    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
+    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
+    MO_F_Le _ -> genBinComp opt LM_CMP_Fle
+
+    MO_F_Add  _ -> genBinMach LM_MO_FAdd
+    MO_F_Sub  _ -> genBinMach LM_MO_FSub
+    MO_F_Mul  _ -> genBinMach LM_MO_FMul
+    MO_F_Quot _ -> genBinMach LM_MO_FDiv
+
+    MO_And _   -> genBinMach LM_MO_And
+    MO_Or  _   -> genBinMach LM_MO_Or
+    MO_Xor _   -> genBinMach LM_MO_Xor
+    MO_Shl _   -> genBinMach LM_MO_Shl
+    MO_U_Shr _ -> genBinMach LM_MO_LShr
+    MO_S_Shr _ -> genBinMach LM_MO_AShr
+
+    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
+    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
+    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
+
+    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
+    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
+
+    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
+    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
+
+    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
+    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
+    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
+    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
+
+    MO_Not _       -> panicOp
+    MO_S_Neg _     -> panicOp
+    MO_F_Neg _     -> panicOp
+
+    MO_SF_Conv _ _ -> panicOp
+    MO_FS_Conv _ _ -> panicOp
+    MO_SS_Conv _ _ -> panicOp
+    MO_UU_Conv _ _ -> panicOp
+    MO_XX_Conv _ _ -> panicOp
+    MO_FF_Conv _ _ -> panicOp
+
+    MO_V_Insert  {} -> panicOp
+    MO_V_Extract {} -> panicOp
+
+    MO_VS_Neg {} -> panicOp
+
+    MO_VF_Insert  {} -> panicOp
+    MO_VF_Extract {} -> panicOp
+
+    MO_VF_Neg {} -> panicOp
+
+    MO_AlignmentCheck {} -> panicOp
+
+    where
+        binLlvmOp ty binOp = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+            if getVarType vx == getVarType vy
+                then do
+                    doExprW (ty vx) $ binOp vx vy
+
+                else do
+                    -- Error. Continue anyway so we can debug the generated ll file.
+                    dflags <- getDynFlags
+                    let style = mkCodeStyle CStyle
+                        toString doc = renderWithStyle dflags doc style
+                        cmmToStr = (lines . toString . PprCmm.pprExpr)
+                    statement $ Comment $ map fsLit $ cmmToStr x
+                    statement $ Comment $ map fsLit $ cmmToStr y
+                    doExprW (ty vx) $ binOp vx vy
+
+        binCastLlvmOp ty binOp = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
+            case vxy' of
+              [vx',vy'] -> doExprW ty $ binOp vx' vy'
+              _         -> panic "genMachOp_slow: binCastLlvmOp"
+
+        -- | Need to use EOption here as Cmm expects word size results from
+        -- comparisons while LLVM return i1. Need to extend to llvmWord type
+        -- if expected. See Note [Literals and branch conditions].
+        genBinComp opt cmp = do
+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+            dflags <- getDynFlags
+            if getVarType v1 == i1
+                then case i1Expected opt of
+                    True  -> return ed
+                    False -> do
+                        let w_ = llvmWord dflags
+                        (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
+                        return (v2, stmts `snocOL` s1, top)
+                else
+                    panic $ "genBinComp: Compare returned type other then i1! "
+                        ++ (showSDoc dflags $ ppr $ getVarType v1)
+
+        genBinMach op = binLlvmOp getVarType (LlvmOp op)
+
+        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
+
+        -- | Detect if overflow will occur in signed multiply of the two
+        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
+        -- implementation. Its much longer due to type information/safety.
+        -- This should actually compile to only about 3 asm instructions.
+        isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
+        isSMulOK _ x y = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+
+            dflags <- getDynFlags
+            let word  = getVarType vx
+            let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
+            let shift = llvmWidthInBits dflags word
+            let shift1 = toIWord dflags (shift - 1)
+            let shift2 = toIWord dflags shift
+
+            if isInt word
+                then do
+                    x1     <- doExprW word2 $ Cast LM_Sext vx word2
+                    y1     <- doExprW word2 $ Cast LM_Sext vy word2
+                    r1     <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
+                    rlow1  <- doExprW word $ Cast LM_Trunc r1 word
+                    rlow2  <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
+                    rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
+                    rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
+                    doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
+
+                else
+                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
+
+        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
+                       ++ "with two arguments! (" ++ show op ++ ")"
+
+-- More than two expression, invalid!
+genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"
+
+
+-- | Handle CmmLoad expression.
+genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genLoad atomic e@(CmmReg (CmmGlobal r)) ty
+    = genLoad_fast atomic e r 0 ty
+
+genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty
+    = genLoad_fast atomic e r n ty
+
+genLoad atomic e@(CmmMachOp (MO_Add _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                ty
+    = genLoad_fast atomic e r (fromInteger n) ty
+
+genLoad atomic e@(CmmMachOp (MO_Sub _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                ty
+    = genLoad_fast atomic e r (negate $ fromInteger n) ty
+
+-- generic case
+genLoad atomic e ty
+    = getTBAAMeta topN >>= genLoad_slow atomic e ty
+
+-- | Handle CmmLoad expression.
+-- This is a special case for loading from a global register pointer
+-- offset such as I32[Sp+8].
+genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
+             -> LlvmM ExprData
+genLoad_fast atomic e r n ty = do
+    dflags <- getDynFlags
+    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+    meta          <- getTBAARegMeta r
+    let ty'      = cmmToLlvmType ty
+        (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+    case isPointer grt && rem == 0 of
+            True  -> do
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                -- We might need a different pointer type, so check
+                case grt == ty' of
+                     -- were fine
+                     True -> do
+                         (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)
+                         return (var, s1 `snocOL` s2 `snocOL` s3,
+                                     [])
+
+                     -- cast to pointer type needed
+                     False -> do
+                         let pty = pLift ty'
+                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
+                         (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')
+                         return (var, s1 `snocOL` s2 `snocOL` s3
+                                    `snocOL` s4, [])
+
+            -- If its a bit type then we use the slow method since
+            -- we can't avoid casting anyway.
+            False -> genLoad_slow atomic  e ty meta
+  where
+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
+                  | otherwise = Load ptr
+
+-- | Handle Cmm load expression.
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
+genLoad_slow atomic e ty meta = runExprData $ do
+    iptr <- exprToVarW e
+    dflags <- getDynFlags
+    case getVarType iptr of
+         LMPointer _ -> do
+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
+
+         i@(LMInt _) | i == llvmWord dflags -> do
+                    let pty = LMPointer $ cmmToLlvmType ty
+                    ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
+
+         other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
+                        (PprCmm.pprExpr e <+> text (
+                            "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+                            ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+                            ", Var: " ++ showSDoc dflags (ppr iptr)))
+  where
+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
+                  | otherwise = Load ptr
+
+
+-- | Handle CmmReg expression. This will return a pointer to the stack
+-- location of the register. Throws an error if it isn't allocated on
+-- the stack.
+getCmmReg :: CmmReg -> LlvmM LlvmVar
+getCmmReg (CmmLocal (LocalReg un _))
+  = do exists <- varLookup un
+       dflags <- getDynFlags
+       case exists of
+         Just ety -> return (LMLocalVar un $ pLift ety)
+         Nothing  -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
+           -- This should never happen, as every local variable should
+           -- have been assigned a value at some point, triggering
+           -- "funPrologue" to allocate it on the stack.
+
+getCmmReg (CmmGlobal g)
+  = do onStack <- checkStackReg g
+       dflags <- getDynFlags
+       if onStack
+         then return (lmGlobalRegVar dflags g)
+         else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
+
+-- | Return the value of a given register, as well as its type. Might
+-- need to be load from stack.
+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
+getCmmRegVal reg =
+  case reg of
+    CmmGlobal g -> do
+      onStack <- checkStackReg g
+      dflags <- getDynFlags
+      if onStack then loadFromStack else do
+        let r = lmGlobalRegArg dflags g
+        return (r, getVarType r, nilOL)
+    _ -> loadFromStack
+ where loadFromStack = do
+         ptr <- getCmmReg reg
+         let ty = pLower $ getVarType ptr
+         (v, s) <- doExpr ty (Load ptr)
+         return (v, ty, unitOL s)
+
+-- | Allocate a local CmmReg on the stack
+allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
+allocReg (CmmLocal (LocalReg un ty))
+  = let ty' = cmmToLlvmType ty
+        var = LMLocalVar un (LMPointer ty')
+        alc = Alloca ty' 1
+    in (var, unitOL $ Assignment var alc)
+
+allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
+                    ++ " have been handled elsewhere!"
+
+
+-- | Generate code for a literal
+genLit :: EOption -> CmmLit -> LlvmM ExprData
+genLit opt (CmmInt i w)
+  -- See Note [Literals and branch conditions].
+  = let width | i1Expected opt = i1
+              | otherwise      = LMInt (widthInBits w)
+        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt
+        --                 , fsLit $ "Width  : " ++ show w
+        --                 , fsLit $ "Width' : " ++ show (widthInBits w)
+        --                 ]
+    in return (mkIntLit width i, nilOL, [])
+
+genLit _ (CmmFloat r w)
+  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
+              nilOL, [])
+
+genLit opt (CmmVec ls)
+  = do llvmLits <- mapM toLlvmLit ls
+       return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
+  where
+    toLlvmLit :: CmmLit -> LlvmM LlvmLit
+    toLlvmLit lit = do
+        (llvmLitVar, _, _) <- genLit opt lit
+        case llvmLitVar of
+          LMLitVar llvmLit -> return llvmLit
+          _ -> panic "genLit"
+
+genLit _ cmm@(CmmLabel l)
+  = do var <- getGlobalPtr =<< strCLabel_llvm l
+       dflags <- getDynFlags
+       let lmty = cmmToLlvmType $ cmmLitType dflags cmm
+       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
+       return (v1, unitOL s1, [])
+
+genLit opt (CmmLabelOff label off) = do
+    dflags <- getDynFlags
+    (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
+    let voff = toIWord dflags off
+    (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
+    return (v1, stmts `snocOL` s1, stat)
+
+genLit opt (CmmLabelDiffOff l1 l2 off w) = do
+    dflags <- getDynFlags
+    (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
+    (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
+    let voff = toIWord dflags off
+    let ty1 = getVarType vl1
+    let ty2 = getVarType vl2
+    if (isInt ty1) && (isInt ty2)
+       && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
+       then do
+            (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
+            (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
+            let ty = widthToLlvmInt w
+            let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
+            if w /= wordWidth dflags
+              then do
+                (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
+                return (v3, stmts `snocOL` s3, stat1 ++ stat2)
+              else
+                return (v2, stmts, stat1 ++ stat2)
+        else
+            panic "genLit: CmmLabelDiffOff encountered with different label ty!"
+
+genLit opt (CmmBlock b)
+  = genLit opt (CmmLabel $ infoTblLbl b)
+
+genLit _ CmmHighStackMark
+  = panic "genStaticLit - CmmHighStackMark unsupported!"
+
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+--
+
+-- | Find CmmRegs that get assigned and allocate them on the stack
+--
+-- Any register that gets written needs to be allcoated on the
+-- stack. This avoids having to map a CmmReg to an equivalent SSA form
+-- and avoids having to deal with Phi node insertion.  This is also
+-- the approach recommended by LLVM developers.
+--
+-- On the other hand, this is unnecessarily verbose if the register in
+-- question is never written. Therefore we skip it where we can to
+-- save a few lines in the output and hopefully speed compilation up a
+-- bit.
+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
+funPrologue live cmmBlocks = do
+
+  trash <- getTrashRegs
+  let getAssignedRegs :: CmmNode O O -> [CmmReg]
+      getAssignedRegs (CmmAssign reg _)  = [reg]
+      -- Calls will trash all registers. Unfortunately, this needs them to
+      -- be stack-allocated in the first place.
+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
+      getAssignedRegs _                  = []
+      getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
+      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
+      isLive r     = r `elem` alwaysLive || r `elem` live
+
+  dflags <- getDynFlags
+  stmtss <- flip mapM assignedRegs $ \reg ->
+    case reg of
+      CmmLocal (LocalReg un _) -> do
+        let (newv, stmts) = allocReg reg
+        varInsert un (pLower $ getVarType newv)
+        return stmts
+      CmmGlobal r -> do
+        let reg   = lmGlobalRegVar dflags r
+            arg   = lmGlobalRegArg dflags r
+            ty    = (pLower . getVarType) reg
+            trash = LMLitVar $ LMUndefLit ty
+            rval  = if isLive r then arg else trash
+            alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
+        markStackReg r
+        return $ toOL [alloc, Store rval reg]
+
+  return (concatOL stmtss, [])
+
+-- | Function epilogue. Load STG variables to use as argument for call.
+-- STG Liveness optimisation done here.
+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
+funEpilogue live = do
+
+    -- Have information and liveness optimisation is enabled?
+    let liveRegs = alwaysLive ++ live
+        isSSE (FloatReg _)  = True
+        isSSE (DoubleReg _) = True
+        isSSE (XmmReg _)    = True
+        isSSE (YmmReg _)    = True
+        isSSE (ZmmReg _)    = True
+        isSSE _             = False
+
+    -- Set to value or "undef" depending on whether the register is
+    -- actually live
+    dflags <- getDynFlags
+    let loadExpr r = do
+          (v, _, s) <- getCmmRegVal (CmmGlobal r)
+          return (Just $ v, s)
+        loadUndef r = do
+          let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
+          return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
+    platform <- getDynFlag targetPlatform
+    loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
+      _ | r `elem` liveRegs  -> loadExpr r
+        | not (isSSE r)      -> loadUndef r
+        | otherwise          -> return (Nothing, nilOL)
+
+    let (vars, stmts) = unzip loads
+    return (catMaybes vars, concatOL stmts)
+
+
+-- | A series of statements to trash all the STG registers.
+--
+-- In LLVM we pass the STG registers around everywhere in function calls.
+-- So this means LLVM considers them live across the entire function, when
+-- in reality they usually aren't. For Caller save registers across C calls
+-- the saving and restoring of them is done by the Cmm code generator,
+-- using Cmm local vars. So to stop LLVM saving them as well (and saving
+-- all of them since it thinks they're always live, we trash them just
+-- before the call by assigning the 'undef' value to them. The ones we
+-- need are restored from the Cmm local var and the ones we don't need
+-- are fine to be trashed.
+getTrashStmts :: LlvmM LlvmStatements
+getTrashStmts = do
+  regs <- getTrashRegs
+  stmts <- flip mapM regs $ \ r -> do
+    reg <- getCmmReg (CmmGlobal r)
+    let ty = (pLower . getVarType) reg
+    return $ Store (LMLitVar $ LMUndefLit ty) reg
+  return $ toOL stmts
+
+getTrashRegs :: LlvmM [GlobalReg]
+getTrashRegs = do plat <- getLlvmPlatform
+                  return $ filter (callerSaves plat) (activeStgRegs plat)
+
+-- | Get a function pointer to the CLabel specified.
+--
+-- This is for Haskell functions, function type is assumed, so doesn't work
+-- with foreign functions.
+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
+getHsFunc live lbl
+  = do fty <- llvmFunTy live
+       name <- strCLabel_llvm lbl
+       getHsFunc' name fty
+
+getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
+getHsFunc' name fty
+  = do fun <- getGlobalPtr name
+       if getVarType fun == fty
+         then return (fun, nilOL, [])
+         else do (v1, s1) <- doExpr (pLift fty)
+                               $ Cast LM_Bitcast fun (pLift fty)
+                 return  (v1, unitOL s1, [])
+
+-- | Create a new local var
+mkLocalVar :: LlvmType -> LlvmM LlvmVar
+mkLocalVar ty = do
+    un <- getUniqueM
+    return $ LMLocalVar un ty
+
+
+-- | Execute an expression, assigning result to a var
+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
+doExpr ty expr = do
+    v <- mkLocalVar ty
+    return (v, Assignment v expr)
+
+
+-- | Expand CmmRegOff
+expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
+expandCmmReg dflags (reg, off)
+  = let width = typeWidth (cmmRegType dflags reg)
+        voff  = CmmLit $ CmmInt (fromIntegral off) width
+    in CmmMachOp (MO_Add width) [CmmReg reg, voff]
+
+
+-- | Convert a block id into a appropriate Llvm label
+blockIdToLlvm :: BlockId -> LlvmVar
+blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
+
+-- | Create Llvm int Literal
+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
+
+-- | Convert int type to a LLvmVar of word or i32 size
+toI32 :: Integral a => a -> LlvmVar
+toI32 = mkIntLit i32
+
+toIWord :: Integral a => DynFlags -> a -> LlvmVar
+toIWord dflags = mkIntLit (llvmWord dflags)
+
+
+-- | Error functions
+panic :: String -> a
+panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
+
+pprPanic :: String -> SDoc -> a
+pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
+
+
+-- | Returns TBAA meta data by unique
+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
+getTBAAMeta u = do
+    mi <- getUniqMeta u
+    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
+
+-- | Returns TBAA meta data for given register
+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
+getTBAARegMeta = getTBAAMeta . getTBAA
+
+
+-- | A more convenient way of accumulating LLVM statements and declarations.
+data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
+
+instance Semigroup LlvmAccum where
+  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
+        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
+
+instance Monoid LlvmAccum where
+    mempty = LlvmAccum nilOL []
+    mappend = (Semigroup.<>)
+
+liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
+liftExprData action = do
+    (var, stmts, decls) <- lift action
+    tell $ LlvmAccum stmts decls
+    return var
+
+statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
+statement stmt = tell $ LlvmAccum (unitOL stmt) []
+
+doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
+doExprW a b = do
+    (var, stmt) <- lift $ doExpr a b
+    statement stmt
+    return var
+
+exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
+exprToVarW = liftExprData . exprToVar
+
+runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
+runExprData action = do
+    (var, LlvmAccum stmts decls) <- runWriterT action
+    return (var, stmts, decls)
+
+runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
+runStmtsDecls action = do
+    LlvmAccum stmts decls <- execWriterT action
+    return (stmts, decls)
+
+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
+getCmmRegW = lift . getCmmReg
+
+genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+doTrashStmts :: WriterT LlvmAccum LlvmM ()
+doTrashStmts = do
+    stmts <- lift getTrashStmts
+    tell $ LlvmAccum stmts mempty
+
+-- | Return element of single-element list; 'panic' if list is not a single-element list
+singletonPanic :: String -> [a] -> a
+singletonPanic _ [x] = x
+singletonPanic s _ = panic s
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE CPP #-}
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmData to LLVM code.
+--
+
+module LlvmCodeGen.Data (
+        genLlvmData, genData
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+
+import BlockId
+import CLabel
+import Cmm
+import DynFlags
+import Platform
+
+import FastString
+import Outputable
+import qualified Data.ByteString as BS
+
+-- ----------------------------------------------------------------------------
+-- * Constants
+--
+
+-- | The string appended to a variable name to create its structure type alias
+structStr :: LMString
+structStr = fsLit "_struct"
+
+-- | The LLVM visibility of the label
+linkage :: CLabel -> LlvmLinkageType
+linkage lbl = if externallyVisibleCLabel lbl
+              then ExternallyVisible else Internal
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pass a CmmStatic section to an equivalent Llvm code.
+genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
+-- See note [emit-time elimination of static indirections] in CLabel.
+genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+  | lbl == mkIndStaticInfoLabel
+  , let labelInd (CmmLabelOff l _) = Just l
+        labelInd (CmmLabel l) = Just l
+        labelInd _ = Nothing
+  , Just ind' <- labelInd ind
+  , alias `mayRedirectTo` ind' = do
+    label <- strCLabel_llvm alias
+    label' <- strCLabel_llvm ind'
+    let link     = linkage alias
+        link'    = linkage ind'
+        -- the LLVM type we give the alias is an empty struct type
+        -- but it doesn't really matter, as the pointer is only
+        -- used for (bit/int)casting.
+        tyAlias  = LMAlias (label `appendFS` structStr, LMStructU [])
+
+        aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
+        -- we don't know the type of the indirectee here
+        indType  = panic "will be filled by 'aliasify', later"
+        orig     = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias
+
+    pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
+
+genLlvmData (sec, Statics lbl xs) = do
+    label <- strCLabel_llvm lbl
+    static <- mapM genData xs
+    lmsec <- llvmSection sec
+    let types   = map getStatType static
+
+        strucTy = LMStruct types
+        tyAlias = LMAlias (label `appendFS` structStr, strucTy)
+
+        struct         = Just $ LMStaticStruc static tyAlias
+        link           = linkage lbl
+        align          = case sec of
+                            Section CString _ -> Just 1
+                            _                 -> Nothing
+        const          = if isSecConstant sec then Constant else Global
+        varDef         = LMGlobalVar label tyAlias link lmsec align const
+        globDef        = LMGlobal varDef struct
+
+    return ([globDef], [tyAlias])
+
+-- | Format the section type part of a Cmm Section
+llvmSectionType :: Platform -> SectionType -> FastString
+llvmSectionType p t = case t of
+    Text                    -> fsLit ".text"
+    ReadOnlyData            -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata"
+                                 _         -> fsLit ".rodata"
+    RelocatableReadOnlyData -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$rel.ro"
+                                 _         -> fsLit ".data.rel.ro"
+    ReadOnlyData16          -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$cst16"
+                                 _         -> fsLit ".rodata.cst16"
+    Data                    -> fsLit ".data"
+    UninitialisedData       -> fsLit ".bss"
+    CString                 -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$str"
+                                 _         -> fsLit ".rodata.str"
+    (OtherSection _)        -> panic "llvmSectionType: unknown section type"
+
+-- | Format a Cmm Section into a LLVM section name
+llvmSection :: Section -> LlvmM LMSection
+llvmSection (Section t suffix) = do
+  dflags <- getDynFlags
+  let splitSect = gopt Opt_SplitSections dflags
+      platform  = targetPlatform dflags
+  if not splitSect
+  then return Nothing
+  else do
+    lmsuffix <- strCLabel_llvm suffix
+    let result sep = Just (concatFS [llvmSectionType platform t
+                                    , fsLit sep, lmsuffix])
+    case platformOS platform of
+      OSMinGW32 -> return (result "$")
+      _         -> return (result ".")
+
+-- ----------------------------------------------------------------------------
+-- * Generate static data
+--
+
+-- | Handle static data
+genData :: CmmStatic -> LlvmM LlvmStatic
+
+genData (CmmString str) = do
+    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
+                 (BS.unpack str)
+        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
+    return $ LMStaticArray ve (LMArray (length ve) i8)
+
+genData (CmmUninitialised bytes)
+    = return $ LMUninitType (LMArray bytes i8)
+
+genData (CmmStaticLit lit)
+    = genStaticLit lit
+
+-- | Generate Llvm code for a static literal.
+--
+-- Will either generate the code or leave it unresolved if it is a 'CLabel'
+-- which isn't yet known.
+genStaticLit :: CmmLit -> LlvmM LlvmStatic
+genStaticLit (CmmInt i w)
+    = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
+
+genStaticLit (CmmFloat r w)
+    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
+
+genStaticLit (CmmVec ls)
+    = do sls <- mapM toLlvmLit ls
+         return $ LMStaticLit (LMVectorLit sls)
+  where
+    toLlvmLit :: CmmLit -> LlvmM LlvmLit
+    toLlvmLit lit = do
+      slit <- genStaticLit lit
+      case slit of
+        LMStaticLit llvmLit -> return llvmLit
+        _ -> panic "genStaticLit"
+
+-- Leave unresolved, will fix later
+genStaticLit cmm@(CmmLabel l) = do
+    var <- getGlobalPtr =<< strCLabel_llvm l
+    dflags <- getDynFlags
+    let ptr = LMStaticPointer var
+        lmty = cmmToLlvmType $ cmmLitType dflags cmm
+    return $ LMPtoI ptr lmty
+
+genStaticLit (CmmLabelOff label off) = do
+    dflags <- getDynFlags
+    var <- genStaticLit (CmmLabel label)
+    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+    return $ LMAdd var offset
+
+genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
+    dflags <- getDynFlags
+    var1 <- genStaticLit (CmmLabel l1)
+    var2 <- genStaticLit (CmmLabel l2)
+    let var
+          | w == wordWidth dflags = LMSub var1 var2
+          | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
+        offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
+    return $ LMAdd var offset
+
+genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
+
+genStaticLit (CmmHighStackMark)
+    = panic "genStaticLit: CmmHighStackMark unsupported!"
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE CPP #-}
+
+-- ----------------------------------------------------------------------------
+-- | Pretty print helpers for the LLVM Code generator.
+--
+module LlvmCodeGen.Ppr (
+        pprLlvmCmmDecl, pprLlvmData, infoSection
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+import LlvmCodeGen.Data
+
+import CLabel
+import Cmm
+
+import FastString
+import Outputable
+import Unique
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pretty print LLVM data code
+pprLlvmData :: LlvmData -> SDoc
+pprLlvmData (globals, types) =
+    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a
+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
+        ppLlvmTys _other         = empty
+
+        types'   = vcat $ map ppLlvmTys types
+        globals' = ppLlvmGlobals globals
+    in types' $+$ globals'
+
+
+-- | Pretty print LLVM code
+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+pprLlvmCmmDecl (CmmData _ lmdata)
+  = return (vcat $ map pprLlvmData lmdata, [])
+
+pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
+  = do let lbl = case mb_info of
+                     Nothing                   -> entry_lbl
+                     Just (Statics info_lbl _) -> info_lbl
+           link = if externallyVisibleCLabel lbl
+                      then ExternallyVisible
+                      else Internal
+           lmblocks = map (\(BasicBlock id stmts) ->
+                                LlvmBlock (getUnique id) stmts) blks
+
+       funDec <- llvmFunSig live lbl link
+       dflags <- getDynFlags
+       let buildArg = fsLit . showSDoc dflags . ppPlainName
+           funArgs = map buildArg (llvmFunArgs dflags live)
+           funSect = llvmFunSection dflags (decName funDec)
+
+       -- generate the info table
+       prefix <- case mb_info of
+                     Nothing -> return Nothing
+                     Just (Statics _ statics) -> do
+                       infoStatics <- mapM genData statics
+                       let infoTy = LMStruct $ map getStatType infoStatics
+                       return $ Just $ LMStaticStruc infoStatics infoTy
+
+
+       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
+                              prefix lmblocks
+           name = decName $ funcDecl fun
+           defName = llvmDefLabel name
+           funcDecl' = (funcDecl fun) { decName = defName }
+           fun' = fun { funcDecl = funcDecl' }
+           funTy = LMFunction funcDecl'
+           funVar = LMGlobalVar name
+                                (LMPointer funTy)
+                                link
+                                Nothing
+                                Nothing
+                                Alias
+           defVar = LMGlobalVar defName
+                                (LMPointer funTy)
+                                (funcLinkage funcDecl')
+                                (funcSect fun)
+                                (funcAlign funcDecl')
+                                Alias
+           alias = LMGlobal funVar
+                            (Just $ LMBitc (LMStaticPointer defVar)
+                                           i8Ptr)
+
+       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
+
+
+-- | The section we are putting info tables and their entry code into, should
+-- be unique since we process the assembly pattern matching this.
+infoSection :: String
+infoSection = "X98A__STRIP,__me"
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- | Deal with Cmm registers
+--
+
+module LlvmCodeGen.Regs (
+        lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
+        stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+
+import CmmExpr
+import DynFlags
+import FastString
+import Outputable ( panic )
+import Unique
+
+-- | Get the LlvmVar function variable storing the real register
+lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar
+lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"
+
+-- | Get the LlvmVar function argument storing the real register
+lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar
+lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"
+
+{- Need to make sure the names here can't conflict with the unique generated
+   names. Uniques generated names containing only base62 chars. So using say
+   the '_' char guarantees this.
+-}
+lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar
+lmGlobalReg dflags suf reg
+  = case reg of
+        BaseReg        -> ptrGlobal $ "Base" ++ suf
+        Sp             -> ptrGlobal $ "Sp" ++ suf
+        Hp             -> ptrGlobal $ "Hp" ++ suf
+        VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf
+        VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf
+        VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf
+        VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf
+        VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf
+        VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf
+        VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf
+        VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf
+        SpLim          -> wordGlobal $ "SpLim" ++ suf
+        FloatReg 1     -> floatGlobal $"F1" ++ suf
+        FloatReg 2     -> floatGlobal $"F2" ++ suf
+        FloatReg 3     -> floatGlobal $"F3" ++ suf
+        FloatReg 4     -> floatGlobal $"F4" ++ suf
+        FloatReg 5     -> floatGlobal $"F5" ++ suf
+        FloatReg 6     -> floatGlobal $"F6" ++ suf
+        DoubleReg 1    -> doubleGlobal $ "D1" ++ suf
+        DoubleReg 2    -> doubleGlobal $ "D2" ++ suf
+        DoubleReg 3    -> doubleGlobal $ "D3" ++ suf
+        DoubleReg 4    -> doubleGlobal $ "D4" ++ suf
+        DoubleReg 5    -> doubleGlobal $ "D5" ++ suf
+        DoubleReg 6    -> doubleGlobal $ "D6" ++ suf
+        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf
+        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf
+        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf
+        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf
+        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf
+        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf
+        YmmReg 1       -> ymmGlobal $ "YMM1" ++ suf
+        YmmReg 2       -> ymmGlobal $ "YMM2" ++ suf
+        YmmReg 3       -> ymmGlobal $ "YMM3" ++ suf
+        YmmReg 4       -> ymmGlobal $ "YMM4" ++ suf
+        YmmReg 5       -> ymmGlobal $ "YMM5" ++ suf
+        YmmReg 6       -> ymmGlobal $ "YMM6" ++ suf
+        ZmmReg 1       -> zmmGlobal $ "ZMM1" ++ suf
+        ZmmReg 2       -> zmmGlobal $ "ZMM2" ++ suf
+        ZmmReg 3       -> zmmGlobal $ "ZMM3" ++ suf
+        ZmmReg 4       -> zmmGlobal $ "ZMM4" ++ suf
+        ZmmReg 5       -> zmmGlobal $ "ZMM5" ++ suf
+        ZmmReg 6       -> zmmGlobal $ "ZMM6" ++ suf
+        MachSp         -> wordGlobal $ "MachSp" ++ suf
+        _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
+                                ++ ") not supported!"
+        -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
+        -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg
+    where
+        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord dflags)
+        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)
+        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat
+        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble
+        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
+        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))
+        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))
+
+-- | A list of STG Registers that should always be considered alive
+alwaysLive :: [GlobalReg]
+alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
+
+-- | STG Type Based Alias Analysis hierarchy
+stgTBAA :: [(Unique, LMString, Maybe Unique)]
+stgTBAA
+  = [ (rootN,  fsLit "root",   Nothing)
+    , (topN,   fsLit "top",   Just rootN)
+    , (stackN, fsLit "stack", Just topN)
+    , (heapN,  fsLit "heap",  Just topN)
+    , (rxN,    fsLit "rx",    Just heapN)
+    , (baseN,  fsLit "base",  Just topN)
+    -- FIX: Not 100% sure if this hierarchy is complete.  I think the big thing
+    -- is Sp is never aliased, so might want to change the hierarchy to have Sp
+    -- on its own branch that is never aliased (e.g never use top as a TBAA
+    -- node).
+    ]
+
+-- | Id values
+-- The `rootN` node is the root (there can be more than one) of the TBAA
+-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It
+-- should never occur in any LLVM instruction statement.
+rootN, topN, stackN, heapN, rxN, baseN :: Unique
+rootN  = getUnique (fsLit "LlvmCodeGen.Regs.rootN")
+topN   = getUnique (fsLit "LlvmCodeGen.Regs.topN")
+stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN")
+heapN  = getUnique (fsLit "LlvmCodeGen.Regs.heapN")
+rxN    = getUnique (fsLit "LlvmCodeGen.Regs.rxN")
+baseN  = getUnique (fsLit "LlvmCodeGen.Regs.baseN")
+
+-- | The TBAA metadata identifier
+tbaa :: LMString
+tbaa = fsLit "tbaa"
+
+-- | Get the correct TBAA metadata information for this register type
+getTBAA :: GlobalReg -> Unique
+getTBAA BaseReg          = baseN
+getTBAA Sp               = stackN
+getTBAA Hp               = heapN
+getTBAA (VanillaReg _ _) = rxN
+getTBAA _                = topN
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -0,0 +1,129 @@
+-- -----------------------------------------------------------------------------
+-- | GHC LLVM Mangler
+--
+-- This script processes the assembly produced by LLVM, rewriting all symbols
+-- of type @function to @object. This keeps them from going through the PLT,
+-- which would be bad due to tables-next-to-code. On x86_64,
+-- it also rewrites AVX instructions that require alignment to their
+-- unaligned counterparts, since the stack is only 16-byte aligned but these
+-- instructions require 32-byte alignment.
+--
+
+module LlvmMangler ( llvmFixupAsm ) where
+
+import GhcPrelude
+
+import DynFlags ( DynFlags, targetPlatform )
+import Platform ( platformArch, Arch(..) )
+import ErrUtils ( withTiming )
+import Outputable ( text )
+
+import Control.Exception
+import qualified Data.ByteString.Char8 as B
+import System.IO
+
+-- | Read in assembly file and process
+llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
+llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
+    withTiming (pure dflags) (text "LLVM Mangler") id $
+    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
+        go r w
+        hClose r
+        hClose w
+        return ()
+  where
+    go :: Handle -> Handle -> IO ()
+    go r w = do
+      e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
+      let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w
+      case e_l of
+        Right l -> writeline l
+        Left _  -> return ()
+
+-- | These are the rewrites that the mangler will perform
+rewrites :: [Rewrite]
+rewrites = [rewriteSymType, rewriteAVX]
+
+type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
+
+-- | Rewrite a line of assembly source with the given rewrites,
+-- taking the first rewrite that applies.
+rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
+rewriteLine dflags rewrites l
+  -- We disable .subsections_via_symbols on darwin and ios, as the llvm code
+  -- gen uses prefix data for the info table.  This however does not prevent
+  -- llvm from generating .subsections_via_symbols, which in turn with
+  -- -dead_strip, strips the info tables, and therefore breaks ghc.
+  | isSubsectionsViaSymbols l =
+    (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")
+  | otherwise =
+    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of
+      Nothing        -> l
+      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
+  where
+    isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")
+
+    (symbol, rest) = splitLine l
+
+    firstJust :: [Maybe a] -> Maybe a
+    firstJust (Just x:_) = Just x
+    firstJust []         = Nothing
+    firstJust (_:rest)   = firstJust rest
+
+-- | This rewrites @.type@ annotations of function symbols to @%object@.
+-- This is done as the linker can relocate @%functions@ through the
+-- Procedure Linking Table (PLT). This is bad since we expect that the
+-- info table will appear directly before the symbol's location. In the
+-- case that the PLT is used, this will be not an info table but instead
+-- some random PLT garbage.
+rewriteSymType :: Rewrite
+rewriteSymType _ l
+  | isType l  = Just $ rewrite '@' $ rewrite '%' l
+  | otherwise = Nothing
+  where
+    isType = B.isPrefixOf (B.pack ".type")
+
+    rewrite :: Char -> B.ByteString -> B.ByteString
+    rewrite prefix = replaceOnce funcType objType
+      where
+        funcType = prefix `B.cons` B.pack "function"
+        objType  = prefix `B.cons` B.pack "object"
+
+-- | This rewrites aligned AVX instructions to their unaligned counterparts on
+-- x86-64. This is necessary because the stack is not adequately aligned for
+-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer
+-- and disable tail call optimization. Both would be catastrophic here so GHC
+-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then
+-- rewrites the instructions in the mangler.
+rewriteAVX :: Rewrite
+rewriteAVX dflags s
+  | not isX86_64 = Nothing
+  | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
+  | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
+  | otherwise    = Nothing
+  where
+    isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64
+    isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
+    isVmovap = B.isPrefixOf (B.pack "vmovap")
+
+-- | @replaceOnce match replace bs@ replaces the first occurrence of the
+-- substring @match@ in @bs@ with @replace@.
+replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
+replaceOnce matchBS replaceOnceBS = loop
+  where
+    loop :: B.ByteString -> B.ByteString
+    loop cts =
+        case B.breakSubstring matchBS cts of
+          (hd,tl) | B.null tl -> hd
+                  | otherwise -> hd `B.append` replaceOnceBS `B.append`
+                                 B.drop (B.length matchBS) tl
+
+-- | This function splits a line of assembly code into the label and the
+-- rest of the code.
+splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
+splitLine l = (symbol, B.dropWhile isSpace rest)
+  where
+    isSpace ' ' = True
+    isSpace '\t' = True
+    isSpace _ = False
+    (symbol, rest) = B.span (not . isSpace) l
diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/Ar.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
+{- Note: [The need for Ar.hs]
+Building `-staticlib` required the presence of libtool, and was a such
+restricted to mach-o only. As libtool on macOS and gnu libtool are very
+different, there was no simple portable way to support this.
+
+libtool for static archives does essentially: concatinate the input archives,
+add the input objects, and create a symbol index. Using `ar` for this task
+fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
+features across platforms (e.g. index prefixed retrieval of objects with
+the same name.)
+
+As Archives are rather simple structurally, we can just build the archives
+with Haskell directly and use ranlib on the final result to get the symbol
+index. This should allow us to work around with the differences/abailability
+of libtool across differet platforms.
+-}
+module Ar
+  (ArchiveEntry(..)
+  ,Archive(..)
+  ,afilter
+
+  ,parseAr
+
+  ,loadAr
+  ,loadObj
+  ,writeBSDAr
+  ,writeGNUAr
+
+  ,isBSDSymdef
+  ,isGNUSymdef
+  )
+   where
+
+import GhcPrelude
+
+import Data.List (mapAccumL, isPrefixOf)
+import Data.Monoid ((<>))
+import Data.Binary.Get
+import Data.Binary.Put
+import Control.Monad
+import Control.Applicative
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+#if !defined(mingw32_HOST_OS)
+import qualified System.Posix.Files as POSIX
+#endif
+import System.FilePath (takeFileName)
+
+data ArchiveEntry = ArchiveEntry
+    { filename :: String       -- ^ File name.
+    , filetime :: Int          -- ^ File modification time.
+    , fileown  :: Int          -- ^ File owner.
+    , filegrp  :: Int          -- ^ File group.
+    , filemode :: Int          -- ^ File mode.
+    , filesize :: Int          -- ^ File size.
+    , filedata :: B.ByteString -- ^ File bytes.
+    } deriving (Eq, Show)
+
+newtype Archive = Archive [ArchiveEntry]
+        deriving (Eq, Show, Semigroup, Monoid)
+
+afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
+afilter f (Archive xs) = Archive (filter f xs)
+
+isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
+isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
+isGNUSymdef a = "/" == (filename a)
+
+-- | Archives have numeric values padded with '\x20' to the right.
+getPaddedInt :: B.ByteString -> Int
+getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
+
+putPaddedInt :: Int -> Int -> Put
+putPaddedInt padding i = putPaddedString '\x20' padding (show i)
+
+putPaddedString :: Char -> Int -> String -> Put
+putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
+
+getBSDArchEntries :: Get [ArchiveEntry]
+getBSDArchEntries = do
+    empty <- isEmpty
+    if empty then
+        return []
+     else do
+        name    <- getByteString 16
+        when ('/' `C.elem` name && C.take 3 name /= "#1/") $
+          fail "Looks like GNU Archive"
+        time    <- getPaddedInt <$> getByteString 12
+        own     <- getPaddedInt <$> getByteString 6
+        grp     <- getPaddedInt <$> getByteString 6
+        mode    <- getPaddedInt <$> getByteString 8
+        st_size <- getPaddedInt <$> getByteString 10
+        end     <- getByteString 2
+        when (end /= "\x60\x0a") $
+          fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+                C.unpack name)
+        off1    <- liftM fromIntegral bytesRead :: Get Int
+        -- BSD stores extended filenames, by writing #1/<length> into the
+        -- name field, the first @length@ bytes then represent the file name
+        -- thus the payload size is filesize + file name length.
+        name    <- if C.unpack (C.take 3 name) == "#1/" then
+                        liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
+                    else
+                        return $ C.unpack $ C.takeWhile (/= ' ') name
+        off2    <- liftM fromIntegral bytesRead :: Get Int
+        file    <- getByteString (st_size - (off2 - off1))
+        -- data sections are two byte aligned (see #15396)
+        when (odd st_size) $
+          void (getByteString 1)
+
+        rest    <- getBSDArchEntries
+        return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
+
+-- | GNU Archives feature a special '//' entry that contains the
+-- extended names. Those are referred to as /<num>, where num is the
+-- offset into the '//' entry.
+-- In addition, filenames are terminated with '/' in the archive.
+getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
+getGNUArchEntries extInfo = do
+  empty <- isEmpty
+  if empty
+    then return []
+    else
+    do
+      name    <- getByteString 16
+      time    <- getPaddedInt <$> getByteString 12
+      own     <- getPaddedInt <$> getByteString 6
+      grp     <- getPaddedInt <$> getByteString 6
+      mode    <- getPaddedInt <$> getByteString 8
+      st_size <- getPaddedInt <$> getByteString 10
+      end     <- getByteString 2
+      when (end /= "\x60\x0a") $
+        fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+              C.unpack name)
+      file <- getByteString st_size
+      -- data sections are two byte aligned (see #15396)
+      when (odd st_size) $
+        void (getByteString 1)
+      name <- return . C.unpack $
+        if C.unpack (C.take 1 name) == "/"
+        then case C.takeWhile (/= ' ') name of
+               name@"/"  -> name               -- symbol table
+               name@"//" -> name               -- extendedn file names table
+               name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
+        else C.takeWhile (/= '/') name
+      case name of
+        "/"  -> getGNUArchEntries extInfo
+        "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
+        _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
+
+  where
+   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
+   getExtName Nothing _ = error "Invalid extended filename reference."
+   getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
+
+-- | put an Archive Entry. This assumes that the entries
+-- have been preprocessed to account for the extenden file name
+-- table section "//" e.g. for GNU Archives. Or that the names
+-- have been move into the payload for BSD Archives.
+putArchEntry :: ArchiveEntry -> PutM ()
+putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
+  putPaddedString ' '  16 name
+  putPaddedInt         12 time
+  putPaddedInt          6 own
+  putPaddedInt          6 grp
+  putPaddedInt          8 mode
+  putPaddedInt         10 (st_size + pad)
+  putByteString           "\x60\x0a"
+  putByteString           file
+  when (pad == 1) $
+    putWord8              0x0a
+  where
+    pad         = st_size `mod` 2
+
+getArchMagic :: Get ()
+getArchMagic = do
+  magic <- liftM C.unpack $ getByteString 8
+  if magic /= "!<arch>\n"
+    then fail $ "Invalid magic number " ++ show magic
+    else return ()
+
+putArchMagic :: Put
+putArchMagic = putByteString $ C.pack "!<arch>\n"
+
+getArch :: Get Archive
+getArch = Archive <$> do
+  getArchMagic
+  getBSDArchEntries <|> getGNUArchEntries Nothing
+
+putBSDArch :: Archive -> PutM ()
+putBSDArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    padStr pad size str = take size $ str <> repeat pad
+    nameSize name = case length name `divMod` 4 of
+      (n, 0) -> 4 * n
+      (n, _) -> 4 * (n + 1)
+    needExt name = length name > 16 || ' ' `elem` name
+    processEntry :: ArchiveEntry -> ArchiveEntry
+    processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
+      | needExt name = archive { filename = "#1/" <> show sz
+                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive
+                               , filesize = st_size + sz }
+      | otherwise    = archive
+
+      where sz = nameSize name
+
+    processEntries = map processEntry
+
+putGNUArch :: Archive -> PutM ()
+putGNUArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
+    processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
+      | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
+                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
+                           , archive { filename = "/" <> show (filesize extInfo) } )
+      | otherwise        = ( extInfo, archive { filename = name <> "/" } )
+
+    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
+    processEntries =
+      uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
+
+parseAr :: B.ByteString -> Archive
+parseAr = runGet getArch . L.fromChunks . pure
+
+writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
+writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
+writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
+
+loadAr :: FilePath -> IO Archive
+loadAr fp = parseAr <$> B.readFile fp
+
+loadObj :: FilePath -> IO ArchiveEntry
+loadObj fp = do
+  payload <- B.readFile fp
+  (modt, own, grp, mode) <- fileInfo fp
+  return $ ArchiveEntry
+    (takeFileName fp) modt own grp mode
+    (B.length payload) payload
+
+-- | Take a filePath and return (mod time, own, grp, mode in decimal)
+fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
+#if defined(mingw32_HOST_OS)
+-- on windows mod time, owner group and mode are zero.
+fileInfo _ = pure (0,0,0,0)
+#else
+fileInfo fp = go <$> POSIX.getFileStatus fp
+  where go status = ( fromEnum $ POSIX.modificationTime status
+                    , fromIntegral $ POSIX.fileOwner status
+                    , fromIntegral $ POSIX.fileGroup status
+                    , oct2dec . fromIntegral $ POSIX.fileMode status
+                    )
+
+oct2dec :: Int -> Int
+oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
+  where dec _ 0 = []
+        dec b i = let (rest, last) = i `quotRem` b
+                  in last:dec b rest
+
+#endif
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/CodeOutput.hs
@@ -0,0 +1,267 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section{Code output phase}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module CodeOutput( codeOutput, outputForeignStubs ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import AsmCodeGen ( nativeCodeGen )
+import LlvmCodeGen ( llvmCodeGen )
+
+import UniqSupply       ( mkSplitUniqSupply )
+
+import Finder           ( mkStubPaths )
+import PprC             ( writeCs )
+import CmmLint          ( cmmLint )
+import Packages
+import Cmm              ( RawCmmGroup )
+import HscTypes
+import DynFlags
+import Stream           (Stream)
+import qualified Stream
+import FileCleanup
+
+import ErrUtils
+import Outputable
+import Module
+import SrcLoc
+
+import Control.Exception
+import System.Directory
+import System.FilePath
+import System.IO
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Steering}
+*                                                                      *
+************************************************************************
+-}
+
+codeOutput :: DynFlags
+           -> Module
+           -> FilePath
+           -> ModLocation
+           -> ForeignStubs
+           -> [(ForeignSrcLang, FilePath)]
+           -- ^ additional files to be compiled with with the C compiler
+           -> [InstalledUnitId]
+           -> Stream IO RawCmmGroup ()                       -- Compiled C--
+           -> IO (FilePath,
+                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
+                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})
+
+codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
+  cmm_stream
+  =
+    do  {
+        -- Lint each CmmGroup as it goes past
+        ; let linted_cmm_stream =
+                 if gopt Opt_DoCmmLinting dflags
+                    then Stream.mapM do_lint cmm_stream
+                    else cmm_stream
+
+              do_lint cmm = withTiming (pure dflags)
+                                       (text "CmmLint"<+>brackets (ppr this_mod))
+                                       (const ()) $ do
+                { case cmmLint dflags cmm of
+                        Just err -> do { log_action dflags
+                                                   dflags
+                                                   NoReason
+                                                   SevDump
+                                                   noSrcSpan
+                                                   (defaultDumpStyle dflags)
+                                                   err
+                                       ; ghcExit dflags 1
+                                       }
+                        Nothing  -> return ()
+                ; return cmm
+                }
+
+        ; 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)
+        }
+
+doOutput :: String -> (Handle -> IO a) -> IO a
+doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{C}
+*                                                                      *
+************************************************************************
+-}
+
+outputC :: DynFlags
+        -> FilePath
+        -> Stream IO RawCmmGroup ()
+        -> [InstalledUnitId]
+        -> IO ()
+
+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
+
+       -- figure out which header files to #include in the generated .hc file:
+       --
+       --   * extra_includes from packages
+       --   * -#include options from the cmdline and OPTIONS pragmas
+       --   * the _stub.h file, if there is one.
+       --
+       let rts = getPackageDetails dflags rtsUnitId
+
+       let cc_injects = unlines (map mk_include (includes rts))
+           mk_include h_file =
+            case h_file of
+               '"':_{-"-} -> "#include "++h_file
+               '<':_      -> "#include "++h_file
+               _          -> "#include \""++h_file++"\""
+
+       let pkg_names = map installedUnitIdString packages
+
+       doOutput filenm $ \ h -> do
+          hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
+          hPutStr h cc_injects
+          writeCs dflags h rawcmms
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Assembler}
+*                                                                      *
+************************************************************************
+-}
+
+outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
+          -> Stream IO RawCmmGroup ()
+          -> IO ()
+outputAsm dflags this_mod location filenm cmm_stream
+ | sGhcWithNativeCodeGen $ settings dflags
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+
+       debugTraceMsg dflags 4 (text "Outputing asm to" <+> text 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"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{LLVM}
+*                                                                      *
+************************************************************************
+-}
+
+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputLlvm dflags filenm cmm_stream
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+
+       {-# SCC "llvm_output" #-} doOutput filenm $
+           \f -> {-# SCC "llvm_CodeGen" #-}
+                 llvmCodeGen dflags f ncg_uniqs cmm_stream
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign import/export}
+*                                                                      *
+************************************************************************
+-}
+
+outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
+                   -> IO (Bool,         -- Header file created
+                          Maybe FilePath) -- C file created
+outputForeignStubs dflags mod location stubs
+ = do
+   let stub_h = mkStubPaths dflags (moduleName mod) location
+   stub_c <- newTempName dflags TFL_CurrentModule "c"
+
+   case stubs of
+     NoStubs ->
+        return (False, Nothing)
+
+     ForeignStubs h_code c_code -> do
+        let
+            stub_c_output_d = pprCode CStyle c_code
+            stub_c_output_w = showSDoc dflags stub_c_output_d
+
+            -- Header file protos for "foreign export"ed functions.
+            stub_h_output_d = pprCode CStyle h_code
+            stub_h_output_w = showSDoc dflags stub_h_output_d
+
+        createDirectoryIfMissing True (takeDirectory stub_h)
+
+        dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export header file" stub_h_output_d
+
+        -- we need the #includes from the rts package for the stub files
+        let rts_includes =
+               let rts_pkg = getPackageDetails dflags rtsUnitId in
+               concatMap mk_include (includes rts_pkg)
+            mk_include i = "#include \"" ++ i ++ "\"\n"
+
+            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
+            ffi_includes
+              | sLibFFI $ settings dflags = "#include \"ffi.h\"\n"
+              | otherwise = ""
+
+        stub_h_file_exists
+           <- outputForeignStubs_help stub_h stub_h_output_w
+                ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
+
+        dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export stubs" stub_c_output_d
+
+        stub_c_file_exists
+           <- outputForeignStubs_help stub_c stub_c_output_w
+                ("#define IN_STG_CODE 0\n" ++
+                 "#include \"Rts.h\"\n" ++
+                 rts_includes ++
+                 ffi_includes ++
+                 cplusplus_hdr)
+                 cplusplus_ftr
+           -- We're adding the default hc_header to the stub file, but this
+           -- isn't really HC code, so we need to define IN_STG_CODE==0 to
+           -- avoid the register variables etc. being enabled.
+
+        return (stub_h_file_exists, if stub_c_file_exists
+                                       then Just stub_c
+                                       else Nothing )
+ where
+   cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
+   cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
+
+
+-- Don't use doOutput for dumping the f. export stubs
+-- since it is more than likely that the stubs file will
+-- turn out to be empty, in which case no file should be created.
+outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
+outputForeignStubs_help _fname ""      _header _footer = return False
+outputForeignStubs_help fname doc_str header footer
+   = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
+        return True
+
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/DriverMkDepend.hs
@@ -0,0 +1,423 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Makefile Dependency Generation
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module DriverMkDepend (
+        doMkDependHS
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import qualified GHC
+import GhcMonad
+import DynFlags
+import Util
+import HscTypes
+import qualified SysTools
+import Module
+import Digraph          ( SCC(..) )
+import Finder
+import Outputable
+import Panic
+import SrcLoc
+import Data.List
+import FastString
+import FileCleanup
+
+import Exception
+import ErrUtils
+
+import System.Directory
+import System.FilePath
+import System.IO
+import System.IO.Error  ( isEOFError )
+import Control.Monad    ( when )
+import Data.Maybe       ( isJust )
+import Data.IORef
+
+-----------------------------------------------------------------
+--
+--              The main function
+--
+-----------------------------------------------------------------
+
+doMkDependHS :: GhcMonad m => [FilePath] -> m ()
+doMkDependHS srcs = do
+    -- Initialisation
+    dflags0 <- GHC.getSessionDynFlags
+
+    -- We kludge things a bit for dependency generation. Rather than
+    -- generating dependencies for each way separately, we generate
+    -- them once and then duplicate them for each way's osuf/hisuf.
+    -- We therefore do the initial dependency generation with an empty
+    -- way and .o/.hi extensions, regardless of any flags that might
+    -- be specified.
+    let dflags = dflags0 {
+                     ways = [],
+                     buildTag = mkBuildTag [],
+                     hiSuf = "hi",
+                     objectSuf = "o"
+                 }
+    _ <- GHC.setSessionDynFlags dflags
+
+    when (null (depSuffixes dflags)) $ liftIO $
+        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
+
+    files <- liftIO $ beginMkDependHS dflags
+
+    -- Do the downsweep to find all the modules
+    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
+    GHC.setTargets targets
+    let excl_mods = depExcludeMods dflags
+    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
+
+    -- Sort into dependency order
+    -- There should be no cycles
+    let sorted = GHC.topSortModuleGraph False module_graph Nothing
+
+    -- Print out the dependencies if wanted
+    liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
+
+    -- Process them one by one, dumping results into makefile
+    -- and complaining about cycles
+    hsc_env <- getSession
+    root <- liftIO getCurrentDirectory
+    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
+
+    -- If -ddump-mod-cycles, show cycles in the module graph
+    liftIO $ dumpModCycles dflags module_graph
+
+    -- Tidy up
+    liftIO $ endMkDependHS dflags files
+
+    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
+    --exception; if that is not caught it's fine, but at least we have a
+    --chance to find out exactly what went wrong.  Uncomment the following
+    --line if you disagree.
+
+    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
+
+-----------------------------------------------------------------
+--
+--              beginMkDependHs
+--      Create a temporary file,
+--      find the Makefile,
+--      slurp through it, etc
+--
+-----------------------------------------------------------------
+
+data MkDepFiles
+  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
+            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
+            mkd_tmp_file  :: FilePath,          -- Name of the temporary file
+            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file
+
+beginMkDependHS :: DynFlags -> IO MkDepFiles
+beginMkDependHS dflags = do
+        -- open a new temp file in which to stuff the dependency info
+        -- as we go along.
+  tmp_file <- newTempName dflags TFL_CurrentModule "dep"
+  tmp_hdl <- openFile tmp_file WriteMode
+
+        -- open the makefile
+  let makefile = depMakefile dflags
+  exists <- doesFileExist makefile
+  mb_make_hdl <-
+        if not exists
+        then return Nothing
+        else do
+           makefile_hdl <- openFile makefile ReadMode
+
+                -- slurp through until we get the magic start string,
+                -- copying the contents into dep_makefile
+           let slurp = do
+                l <- hGetLine makefile_hdl
+                if (l == depStartMarker)
+                        then return ()
+                        else do hPutStrLn tmp_hdl l; slurp
+
+                -- slurp through until we get the magic end marker,
+                -- throwing away the contents
+           let chuck = do
+                l <- hGetLine makefile_hdl
+                if (l == depEndMarker)
+                        then return ()
+                        else chuck
+
+           catchIO slurp
+                (\e -> if isEOFError e then return () else ioError e)
+           catchIO chuck
+                (\e -> if isEOFError e then return () else ioError e)
+
+           return (Just makefile_hdl)
+
+
+        -- write the magic marker into the tmp file
+  hPutStrLn tmp_hdl depStartMarker
+
+  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
+                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})
+
+
+-----------------------------------------------------------------
+--
+--              processDeps
+--
+-----------------------------------------------------------------
+
+processDeps :: DynFlags
+            -> HscEnv
+            -> [ModuleName]
+            -> FilePath
+            -> Handle           -- Write dependencies to here
+            -> SCC ModSummary
+            -> IO ()
+-- Write suitable dependencies to handle
+-- Always:
+--                      this.o : this.hs
+--
+-- If the dependency is on something other than a .hi file:
+--                      this.o this.p_o ... : dep
+-- otherwise
+--                      this.o ...   : dep.hi
+--                      this.p_o ... : dep.p_hi
+--                      ...
+-- (where .o is $osuf, and the other suffixes come from
+-- the cmdline -s options).
+--
+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
+
+processDeps dflags _ _ _ _ (CyclicSCC nodes)
+  =     -- There shouldn't be any cycles; report them
+    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
+
+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
+  = do  { let extra_suffixes = depSuffixes dflags
+              include_pkg_deps = depIncludePkgDeps dflags
+              src_file  = msHsFilePath node
+              obj_file  = msObjFilePath node
+              obj_files = insertSuffixes obj_file extra_suffixes
+
+              do_imp loc is_boot pkg_qual imp_mod
+                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
+                                               is_boot include_pkg_deps
+                     ; case mb_hi of {
+                           Nothing      -> return () ;
+                           Just hi_file -> do
+                     { let hi_files = insertSuffixes hi_file extra_suffixes
+                           write_dep (obj,hi) = writeDependency root hdl [obj] hi
+
+                        -- Add one dependency for each suffix;
+                        -- e.g.         A.o   : B.hi
+                        --              A.x_o : B.x_hi
+                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}
+
+
+                -- Emit std dependency of the object(s) on the source file
+                -- Something like       A.o : A.hs
+        ; writeDependency root hdl obj_files src_file
+
+                -- Emit a dependency for each CPP import
+        ; when (depIncludeCppDeps dflags) $ do
+            -- CPP deps are descovered in the module parsing phase by parsing
+            -- comment lines left by the preprocessor.
+            -- Note that GHC.parseModule may throw an exception if the module
+            -- fails to parse, which may not be desirable (see #16616).
+          { session <- Session <$> newIORef hsc_env
+          ; parsedMod <- reflectGhc (GHC.parseModule node) session
+          ; mapM_ (writeDependency root hdl obj_files)
+                  (GHC.pm_extra_src_files parsedMod)
+          }
+
+                -- Emit a dependency for each import
+
+        ; let do_imps is_boot idecls = sequence_
+                    [ do_imp loc is_boot mb_pkg mod
+                    | (mb_pkg, L loc mod) <- idecls,
+                      mod `notElem` excl_mods ]
+
+        ; do_imps True  (ms_srcimps node)
+        ; do_imps False (ms_imps node)
+        }
+
+
+findDependency  :: HscEnv
+                -> SrcSpan
+                -> Maybe FastString     -- package qualifier, if any
+                -> ModuleName           -- Imported module
+                -> IsBootInterface      -- Source import
+                -> Bool                 -- Record dependency on package modules
+                -> IO (Maybe FilePath)  -- Interface file file
+findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
+  = do  {       -- Find the module; this will be fast because
+                -- we've done it once during downsweep
+          r <- findImportedModule hsc_env imp pkg
+        ; case r of
+            Found loc _
+                -- Home package: just depend on the .hi or hi-boot file
+                | isJust (ml_hs_file loc) || include_pkg_deps
+                -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+
+                -- Not in this package: we don't need a dependency
+                | otherwise
+                -> return Nothing
+
+            fail ->
+                let dflags = hsc_dflags hsc_env
+                in throwOneError $ mkPlainErrMsg dflags srcloc $
+                        cannotFindModule dflags imp fail
+        }
+
+-----------------------------
+writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
+-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
+--      t1 t2 : dep
+writeDependency root hdl targets dep
+  = do let -- We need to avoid making deps on
+           --     c:/foo/...
+           -- on cygwin as make gets confused by the :
+           -- Making relative deps avoids some instances of this.
+           dep' = makeRelative root dep
+           forOutput = escapeSpaces . reslash Forwards . normalise
+           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
+       hPutStrLn hdl output
+
+-----------------------------
+insertSuffixes
+        :: FilePath     -- Original filename;   e.g. "foo.o"
+        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]
+        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]
+        -- Note that that the extra bit gets inserted *before* the old suffix
+        -- We assume the old suffix contains no dots, so we know where to
+        -- split it
+insertSuffixes file_name extras
+  = [ basename <.> (extra ++ suffix) | extra <- extras ]
+  where
+    (basename, suffix) = case splitExtension file_name of
+                         -- Drop the "." from the extension
+                         (b, s) -> (b, drop 1 s)
+
+
+-----------------------------------------------------------------
+--
+--              endMkDependHs
+--      Complete the makefile, close the tmp file etc
+--
+-----------------------------------------------------------------
+
+endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
+
+endMkDependHS dflags
+   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
+            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
+  = do
+  -- write the magic marker into the tmp file
+  hPutStrLn tmp_hdl depEndMarker
+
+  case makefile_hdl of
+     Nothing  -> return ()
+     Just hdl -> do
+
+          -- slurp the rest of the original makefile and copy it into the output
+        let slurp = do
+                l <- hGetLine hdl
+                hPutStrLn tmp_hdl l
+                slurp
+
+        catchIO slurp
+                (\e -> if isEOFError e then return () else ioError e)
+
+        hClose hdl
+
+  hClose tmp_hdl  -- make sure it's flushed
+
+        -- Create a backup of the original makefile
+  when (isJust makefile_hdl)
+       (SysTools.copy dflags ("Backing up " ++ makefile)
+          makefile (makefile++".bak"))
+
+        -- Copy the new makefile in place
+  SysTools.copy dflags "Installing new makefile" tmp_file makefile
+
+
+-----------------------------------------------------------------
+--              Module cycles
+-----------------------------------------------------------------
+
+dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
+dumpModCycles dflags module_graph
+  | not (dopt Opt_D_dump_mod_cycles dflags)
+  = return ()
+
+  | null cycles
+  = putMsg dflags (text "No module cycles")
+
+  | otherwise
+  = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)
+  where
+
+    cycles :: [[ModSummary]]
+    cycles =
+      [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]
+
+    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))
+                        $$ pprCycle c $$ blankLine
+                     | (n,c) <- [1..] `zip` cycles ]
+
+pprCycle :: [ModSummary] -> SDoc
+-- Print a cycle, but show only the imports within the cycle
+pprCycle summaries = pp_group (CyclicSCC summaries)
+  where
+    cycle_mods :: [ModuleName]  -- The modules in this cycle
+    cycle_mods = map (moduleName . ms_mod) summaries
+
+    pp_group (AcyclicSCC ms) = pp_ms ms
+    pp_group (CyclicSCC mss)
+        = ASSERT( not (null boot_only) )
+                -- The boot-only list must be non-empty, else there would
+                -- be an infinite chain of non-boot imoprts, and we've
+                -- already checked for that in processModDeps
+          pp_ms loop_breaker $$ vcat (map pp_group groups)
+        where
+          (boot_only, others) = partition is_boot_only mss
+          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
+          in_group (L _ m) = m `elem` group_mods
+          group_mods = map (moduleName . ms_mod) mss
+
+          loop_breaker = head boot_only
+          all_others   = tail boot_only ++ others
+          groups =
+            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
+
+    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
+                       <+> (pp_imps empty (map snd (ms_imps summary)) $$
+                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
+        where
+          mod_str = moduleNameString (moduleName (ms_mod summary))
+
+    pp_imps :: SDoc -> [Located ModuleName] -> SDoc
+    pp_imps _    [] = empty
+    pp_imps what lms
+        = case [m | L _ m <- lms, m `elem` cycle_mods] of
+            [] -> empty
+            ms -> what <+> text "imports" <+>
+                                pprWithCommas ppr ms
+
+-----------------------------------------------------------------
+--
+--              Flags
+--
+-----------------------------------------------------------------
+
+depStartMarker, depEndMarker :: String
+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
+depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
+
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/DriverPipeline.hs
@@ -0,0 +1,2272 @@
+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
+{-# OPTIONS_GHC -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- GHC Driver
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module DriverPipeline (
+        -- Run a series of compilation steps in a pipeline, for a
+        -- collection of source files.
+   oneShot, compileFile,
+
+        -- Interfaces for the batch-mode driver
+   linkBinary,
+
+        -- Interfaces for the compilation manager (interpreted/batch-mode)
+   preprocess,
+   compileOne, compileOne',
+   link,
+
+        -- Exports for hooks to override runPhase and link
+   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
+   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
+   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
+   runPhase, exeFileName,
+   maybeCreateManifest,
+   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import PipelineMonad
+import Packages
+import HeaderInfo
+import DriverPhases
+import SysTools
+import SysTools.ExtraObj
+import HscMain
+import Finder
+import HscTypes hiding ( Hsc )
+import Outputable
+import Module
+import ErrUtils
+import DynFlags
+import Panic
+import Util
+import StringBuffer     ( hGetStringBuffer )
+import BasicTypes       ( SuccessFlag(..) )
+import Maybes           ( expectJust )
+import SrcLoc
+import LlvmCodeGen      ( llvmFixupAsm )
+import MonadUtils
+import Platform
+import TcRnTypes
+import Hooks
+import qualified GHC.LanguageExtensions as LangExt
+import FileCleanup
+import Ar
+
+import Exception
+import System.Directory
+import System.FilePath
+import System.IO
+import Control.Monad
+import Data.List        ( isInfixOf, intercalate )
+import Data.Maybe
+import Data.Version
+import Data.Either      ( partitionEithers )
+
+import Data.Time        ( UTCTime )
+
+-- ---------------------------------------------------------------------------
+-- Pre-process
+
+-- | Just preprocess a file, put the result in a temp. file (used by the
+-- compilation manager during the summary phase).
+--
+-- We return the augmented DynFlags, because they contain the result
+-- of slurping in the OPTIONS pragmas
+
+preprocess :: HscEnv
+           -> (FilePath, Maybe Phase) -- ^ filename and starting phase
+           -> IO (DynFlags, FilePath)
+preprocess hsc_env (filename, mb_phase) =
+  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
+  runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
+        Nothing
+        -- We keep the processed file for the whole session to save on
+        -- duplicated work in ghci.
+        (Temporary TFL_GhcSession)
+        Nothing{-no ModLocation-}
+        []{-no foreign objects-}
+
+-- ---------------------------------------------------------------------------
+
+-- | Compile
+--
+-- Compile a single module, under the control of the compilation manager.
+--
+-- This is the interface between the compilation manager and the
+-- compiler proper (hsc), where we deal with tedious details like
+-- reading the OPTIONS pragma from the source file, converting the
+-- C or assembly that GHC produces into an object file, and compiling
+-- FFI stub files.
+--
+-- NB.  No old interface can also mean that the source has changed.
+
+compileOne :: HscEnv
+           -> ModSummary      -- ^ summary for module being compiled
+           -> Int             -- ^ module N ...
+           -> Int             -- ^ ... of M
+           -> Maybe ModIface  -- ^ old interface, if we have one
+           -> Maybe Linkable  -- ^ old linkable, if we have one
+           -> SourceModified
+           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
+
+compileOne = compileOne' Nothing (Just batchMsg)
+
+compileOne' :: Maybe TcGblEnv
+            -> Maybe Messager
+            -> HscEnv
+            -> ModSummary      -- ^ summary for module being compiled
+            -> Int             -- ^ module N ...
+            -> Int             -- ^ ... of M
+            -> Maybe ModIface  -- ^ old interface, if we have one
+            -> Maybe Linkable  -- ^ old linkable, if we have one
+            -> SourceModified
+            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
+
+compileOne' m_tc_result mHscMessage
+            hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
+            source_modified0
+ = do
+
+   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
+
+   (status, hmi0) <- hscIncrementalCompile
+                        always_do_basic_recompilation_check
+                        m_tc_result mHscMessage
+                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)
+
+   let flags = hsc_dflags hsc_env0
+     in do unless (gopt Opt_KeepHiFiles flags) $
+               addFilesToClean flags TFL_CurrentModule $
+                   [ml_hi_file $ ms_location summary]
+           unless (gopt Opt_KeepOFiles flags) $
+               addFilesToClean flags TFL_GhcSession $
+                   [ml_obj_file $ ms_location summary]
+
+   case (status, hsc_lang) of
+        (HscUpToDate, _) ->
+            -- TODO recomp014 triggers this assert. What's going on?!
+            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
+            return hmi0 { hm_linkable = maybe_old_linkable }
+        (HscNotGeneratingCode, HscNothing) ->
+            let mb_linkable = if isHsBootOrSig src_flavour
+                                then Nothing
+                                -- TODO: Questionable.
+                                else Just (LM (ms_hs_date summary) this_mod [])
+            in return hmi0 { hm_linkable = mb_linkable }
+        (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
+        (_, HscNothing) -> panic "compileOne HscNothing"
+        (HscUpdateBoot, HscInterpreted) -> do
+            return hmi0
+        (HscUpdateBoot, _) -> do
+            touchObjectFile dflags object_filename
+            return hmi0
+        (HscUpdateSig, HscInterpreted) ->
+            let linkable = LM (ms_hs_date summary) this_mod []
+            in return hmi0 { hm_linkable = Just linkable }
+        (HscUpdateSig, _) -> do
+            output_fn <- getOutputFilename next_phase
+                            (Temporary TFL_CurrentModule) basename dflags
+                            next_phase (Just location)
+
+            -- #10660: Use the pipeline instead of calling
+            -- compileEmptyStub directly, so -dynamic-too gets
+            -- handled properly
+            _ <- runPipeline StopLn hsc_env
+                              (output_fn,
+                               Just (HscOut src_flavour
+                                            mod_name HscUpdateSig))
+                              (Just basename)
+                              Persistent
+                              (Just location)
+                              []
+            o_time <- getModificationUTCTime object_filename
+            let linkable = LM o_time this_mod [DotO object_filename]
+            return hmi0 { hm_linkable = Just linkable }
+        (HscRecomp cgguts summary, HscInterpreted) -> do
+            (hasStub, comp_bc, spt_entries) <-
+                hscInteractive hsc_env cgguts summary
+
+            stub_o <- case hasStub of
+                      Nothing -> return []
+                      Just stub_c -> do
+                          stub_o <- compileStub hsc_env stub_c
+                          return [DotO stub_o]
+
+            let hs_unlinked = [BCOs comp_bc spt_entries]
+                unlinked_time = ms_hs_date summary
+              -- Why do we use the timestamp of the source file here,
+              -- rather than the current time?  This works better in
+              -- the case where the local clock is out of sync
+              -- with the filesystem's clock.  It's just as accurate:
+              -- if the source is modified, then the linkable will
+              -- be out of date.
+            let linkable = LM unlinked_time (ms_mod summary)
+                           (hs_unlinked ++ stub_o)
+            return hmi0 { hm_linkable = Just linkable }
+        (HscRecomp cgguts summary, _) -> do
+            output_fn <- getOutputFilename next_phase
+                            (Temporary TFL_CurrentModule)
+                            basename dflags next_phase (Just location)
+            -- We're in --make mode: finish the compilation pipeline.
+            _ <- runPipeline StopLn hsc_env
+                              (output_fn,
+                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
+                              (Just basename)
+                              Persistent
+                              (Just location)
+                              []
+                  -- The object filename comes from the ModLocation
+            o_time <- getModificationUTCTime object_filename
+            let linkable = LM o_time this_mod [DotO object_filename]
+            return hmi0 { hm_linkable = Just linkable }
+
+ where dflags0     = ms_hspp_opts summary
+
+       this_mod    = ms_mod summary
+       location    = ms_location summary
+       input_fn    = expectJust "compile:hs" (ml_hs_file location)
+       input_fnpp  = ms_hspp_file summary
+       mod_graph   = hsc_mod_graph hsc_env0
+       needsLinker = needsTemplateHaskellOrQQ mod_graph
+       isDynWay    = any (== WayDyn) (ways dflags0)
+       isProfWay   = any (== WayProf) (ways dflags0)
+       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
+
+       src_flavour = ms_hsc_src summary
+       mod_name = ms_mod_name summary
+       next_phase = hscPostBackendPhase src_flavour hsc_lang
+       object_filename = ml_obj_file location
+
+       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
+       -- the linker can correctly load the object files.  This isn't necessary
+       -- when using -fexternal-interpreter.
+       dflags1 = if dynamicGhc && internalInterpreter &&
+                    not isDynWay && not isProfWay && needsLinker
+                  then gopt_set dflags0 Opt_BuildDynamicToo
+                  else dflags0
+
+       -- #16331 - when no "internal interpreter" is available but we
+       -- need to process some TemplateHaskell or QuasiQuotes, we automatically
+       -- turn on -fexternal-interpreter.
+       dflags2 = if not internalInterpreter && needsLinker
+                 then gopt_set dflags1 Opt_ExternalInterpreter
+                 else dflags1
+
+       basename = dropExtension input_fn
+
+       -- We add the directory in which the .hs files resides) to the import
+       -- path.  This is needed when we try to compile the .hc file later, if it
+       -- imports a _stub.h file that we created here.
+       current_dir = takeDirectory basename
+       old_paths   = includePaths dflags2
+       !prevailing_dflags = hsc_dflags hsc_env0
+       dflags =
+          dflags2 { includePaths = addQuoteInclude old_paths [current_dir]
+                  , log_action = log_action prevailing_dflags }
+                  -- use the prevailing log_action / log_finaliser,
+                  -- not the one cached in the summary.  This is so
+                  -- that we can change the log_action without having
+                  -- to re-summarize all the source files.
+       hsc_env     = hsc_env0 {hsc_dflags = dflags}
+
+       -- Figure out what lang we're generating
+       hsc_lang = hscTarget dflags
+
+       -- -fforce-recomp should also work with --make
+       force_recomp = gopt Opt_ForceRecomp dflags
+       source_modified
+         | force_recomp = SourceModified
+         | otherwise = source_modified0
+
+       always_do_basic_recompilation_check = case hsc_lang of
+                                             HscInterpreted -> True
+                                             _ -> False
+
+-----------------------------------------------------------------------------
+-- stub .h and .c files (for foreign export support), and cc files.
+
+-- The _stub.c file is derived from the haskell source file, possibly taking
+-- into account the -stubdir option.
+--
+-- The object file created by compiling the _stub.c file is put into a
+-- temporary file, which will be later combined with the main .o file
+-- (see the MergeForeigns phase).
+--
+-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
+-- from TH, that are then compiled and linked to the module. This is
+-- useful to implement facilities such as inline-c.
+
+compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
+compileForeign _ RawObject object_file = return object_file
+compileForeign hsc_env lang stub_c = do
+        let phase = case lang of
+              LangC      -> Cc
+              LangCxx    -> Ccxx
+              LangObjc   -> Cobjc
+              LangObjcxx -> Cobjcxx
+              LangAsm    -> As True -- allow CPP
+              RawObject  -> panic "compileForeign: should be unreachable"
+        (_, stub_o) <- runPipeline StopLn hsc_env
+                       (stub_c, Just (RealPhase phase))
+                       Nothing (Temporary TFL_GhcSession)
+                       Nothing{-no ModLocation-}
+                       []
+        return stub_o
+
+compileStub :: HscEnv -> FilePath -> IO FilePath
+compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
+
+compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
+compileEmptyStub dflags hsc_env basename location mod_name = do
+  -- To maintain the invariant that every Haskell file
+  -- compiles to object code, we make an empty (but
+  -- valid) stub object file for signatures.  However,
+  -- we make sure this object file has a unique symbol,
+  -- so that ranlib on OS X doesn't complain, see
+  -- https://gitlab.haskell.org/ghc/ghc/issues/12673
+  -- and https://github.com/haskell/cabal/issues/2257
+  empty_stub <- newTempName dflags TFL_CurrentModule "c"
+  let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
+  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
+  _ <- runPipeline StopLn hsc_env
+                  (empty_stub, Nothing)
+                  (Just basename)
+                  Persistent
+                  (Just location)
+                  []
+  return ()
+
+-- ---------------------------------------------------------------------------
+-- Link
+
+link :: GhcLink                 -- interactive or batch
+     -> DynFlags                -- dynamic flags
+     -> Bool                    -- attempt linking in batch mode?
+     -> HomePackageTable        -- what to link
+     -> IO SuccessFlag
+
+-- For the moment, in the batch linker, we don't bother to tell doLink
+-- which packages to link -- it just tries all that are available.
+-- batch_attempt_linking should only be *looked at* in batch mode.  It
+-- should only be True if the upsweep was successful and someone
+-- exports main, i.e., we have good reason to believe that linking
+-- will succeed.
+
+link ghcLink dflags
+  = lookupHook linkHook l dflags ghcLink dflags
+  where
+    l LinkInMemory _ _ _
+      = if sGhcWithInterpreter $ settings dflags
+        then -- Not Linking...(demand linker will do the job)
+             return Succeeded
+        else panicBadLink LinkInMemory
+
+    l NoLink _ _ _
+      = return Succeeded
+
+    l LinkBinary dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
+
+    l LinkStaticLib dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
+
+    l LinkDynLib dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
+
+panicBadLink :: GhcLink -> a
+panicBadLink other = panic ("link: GHC not built to link this way: " ++
+                            show other)
+
+link' :: DynFlags                -- dynamic flags
+      -> Bool                    -- attempt linking in batch mode?
+      -> HomePackageTable        -- what to link
+      -> IO SuccessFlag
+
+link' dflags batch_attempt_linking hpt
+   | batch_attempt_linking
+   = do
+        let
+            staticLink = case ghcLink dflags of
+                          LinkStaticLib -> True
+                          _ -> False
+
+            home_mod_infos = eltsHpt hpt
+
+            -- the packages we depend on
+            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
+
+            -- the linkables to link
+            linkables = map (expectJust "link".hm_linkable) home_mod_infos
+
+        debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
+
+        -- check for the -no-link flag
+        if isNoLink (ghcLink dflags)
+          then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
+                  return Succeeded
+          else do
+
+        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+            obj_files = concatMap getOfiles linkables
+
+            exe_file = exeFileName staticLink dflags
+
+        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
+
+        if not (gopt Opt_ForceRecomp dflags) && not linking_needed
+           then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
+                   return Succeeded
+           else do
+
+        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
+
+        -- Don't showPass in Batch mode; doLink will do that for us.
+        let link = case ghcLink dflags of
+                LinkBinary    -> linkBinary
+                LinkStaticLib -> linkStaticLib
+                LinkDynLib    -> linkDynLibCheck
+                other         -> panicBadLink other
+        link dflags obj_files pkg_deps
+
+        debugTraceMsg dflags 3 (text "link: done")
+
+        -- linkBinary only returns if it succeeds
+        return Succeeded
+
+   | otherwise
+   = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
+                                text "   Main.main not exported; not linking.")
+        return Succeeded
+
+
+linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
+linkingNeeded dflags staticLink linkables pkg_deps = do
+        -- if the modification time on the executable is later than the
+        -- modification times on all of the objects and libraries, then omit
+        -- linking (unless the -fforce-recomp flag was given).
+  let exe_file = exeFileName staticLink dflags
+  e_exe_time <- tryIO $ getModificationUTCTime exe_file
+  case e_exe_time of
+    Left _  -> return True
+    Right t -> do
+        -- first check object files and extra_ld_inputs
+        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
+        let (errs,extra_times) = partitionEithers e_extra_times
+        let obj_times =  map linkableTime linkables ++ extra_times
+        if not (null errs) || any (t <) obj_times
+            then return True
+            else do
+
+        -- next, check libraries. XXX this only checks Haskell libraries,
+        -- not extra_libraries or -l things from the command line.
+        let pkg_hslibs  = [ (collectLibraryPaths dflags [c], lib)
+                          | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
+                            lib <- packageHsLibs dflags c ]
+
+        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
+        if any isNothing pkg_libfiles then return True else do
+        e_lib_times <- mapM (tryIO . getModificationUTCTime)
+                          (catMaybes pkg_libfiles)
+        let (lib_errs,lib_times) = partitionEithers e_lib_times
+        if not (null lib_errs) || any (t <) lib_times
+           then return True
+           else checkLinkInfo dflags pkg_deps exe_file
+
+findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
+findHSLib dflags dirs lib = do
+  let batch_lib_file = if WayDyn `notElem` ways dflags
+                      then "lib" ++ lib <.> "a"
+                      else mkSOName (targetPlatform dflags) lib
+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
+  case found of
+    [] -> return Nothing
+    (x:_) -> return (Just x)
+
+-- -----------------------------------------------------------------------------
+-- Compile files in one-shot mode.
+
+oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
+oneShot hsc_env stop_phase srcs = do
+  o_files <- mapM (compileFile hsc_env stop_phase) srcs
+  doLink (hsc_dflags hsc_env) stop_phase o_files
+
+compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
+compileFile hsc_env stop_phase (src, mb_phase) = do
+   exists <- doesFileExist src
+   when (not exists) $
+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
+
+   let
+        dflags    = hsc_dflags hsc_env
+        mb_o_file = outputFile dflags
+        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
+
+        -- When linking, the -o argument refers to the linker's output.
+        -- otherwise, we use it as the name for the pipeline's output.
+        output
+         -- If we are doing -fno-code, then act as if the output is
+         -- 'Temporary'. This stops GHC trying to copy files to their
+         -- final location.
+         | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
+         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
+                -- -o foo applies to linker
+         | isJust mb_o_file = SpecificFile
+                -- -o foo applies to the file we are compiling now
+         | otherwise = Persistent
+
+   ( _, out_file) <- runPipeline stop_phase hsc_env
+                            (src, fmap RealPhase mb_phase) Nothing output
+                            Nothing{-no ModLocation-} []
+   return out_file
+
+
+doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
+doLink dflags stop_phase o_files
+  | not (isStopLn stop_phase)
+  = return ()           -- We stopped before the linking phase
+
+  | otherwise
+  = case ghcLink dflags of
+        NoLink        -> return ()
+        LinkBinary    -> linkBinary         dflags o_files []
+        LinkStaticLib -> linkStaticLib      dflags o_files []
+        LinkDynLib    -> linkDynLibCheck    dflags o_files []
+        other         -> panicBadLink other
+
+
+-- ---------------------------------------------------------------------------
+
+-- | Run a compilation pipeline, consisting of multiple phases.
+--
+-- This is the interface to the compilation pipeline, which runs
+-- a series of compilation steps on a single source file, specifying
+-- at which stage to stop.
+--
+-- The DynFlags can be modified by phases in the pipeline (eg. by
+-- OPTIONS_GHC pragmas), and the changes affect later phases in the
+-- pipeline.
+runPipeline
+  :: Phase                      -- ^ When to stop
+  -> HscEnv                     -- ^ Compilation environment
+  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
+  -> Maybe FilePath             -- ^ original basename (if different from ^^^)
+  -> PipelineOutput             -- ^ Output filename
+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
+  -> [FilePath]                 -- ^ foreign objects
+  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
+runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
+             mb_basename output maybe_loc foreign_os
+
+    = do let
+             dflags0 = hsc_dflags hsc_env0
+
+             -- Decide where dump files should go based on the pipeline output
+             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
+             hsc_env = hsc_env0 {hsc_dflags = dflags}
+
+             (input_basename, suffix) = splitExtension input_fn
+             suffix' = drop 1 suffix -- strip off the .
+             basename | Just b <- mb_basename = b
+                      | otherwise             = input_basename
+
+             -- If we were given a -x flag, then use that phase to start from
+             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
+
+             isHaskell (RealPhase (Unlit _)) = True
+             isHaskell (RealPhase (Cpp   _)) = True
+             isHaskell (RealPhase (HsPp  _)) = True
+             isHaskell (RealPhase (Hsc   _)) = True
+             isHaskell (HscOut {})           = True
+             isHaskell _                     = False
+
+             isHaskellishFile = isHaskell start_phase
+
+             env = PipeEnv{ stop_phase,
+                            src_filename = input_fn,
+                            src_basename = basename,
+                            src_suffix = suffix',
+                            output_spec = output }
+
+         when (isBackpackishSuffix suffix') $
+           throwGhcExceptionIO (UsageError
+                       ("use --backpack to process " ++ input_fn))
+
+         -- We want to catch cases of "you can't get there from here" before
+         -- we start the pipeline, because otherwise it will just run off the
+         -- end.
+         let happensBefore' = happensBefore dflags
+         case start_phase of
+             RealPhase start_phase' ->
+                 -- See Note [Partial ordering on phases]
+                 -- Not the same as: (stop_phase `happensBefore` start_phase')
+                 when (not (start_phase' `happensBefore'` stop_phase ||
+                            start_phase' `eqPhase` stop_phase)) $
+                       throwGhcExceptionIO (UsageError
+                                   ("cannot compile this file to desired target: "
+                                      ++ input_fn))
+             HscOut {} -> return ()
+
+         debugTraceMsg dflags 4 (text "Running the pipeline")
+         r <- runPipeline' start_phase hsc_env env input_fn
+                           maybe_loc foreign_os
+
+         -- If we are compiling a Haskell module, and doing
+         -- -dynamic-too, but couldn't do the -dynamic-too fast
+         -- path, then rerun the pipeline for the dyn way
+         let dflags = hsc_dflags hsc_env
+         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
+         when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
+           when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
+               debugTraceMsg dflags 4
+                   (text "Running the pipeline again for -dynamic-too")
+               let dflags' = dynamicTooMkDynamicDynFlags dflags
+               hsc_env' <- newHscEnv dflags'
+               _ <- runPipeline' start_phase hsc_env' env input_fn
+                                 maybe_loc foreign_os
+               return ()
+         return r
+
+runPipeline'
+  :: PhasePlus                  -- ^ When to start
+  -> HscEnv                     -- ^ Compilation environment
+  -> PipeEnv
+  -> FilePath                   -- ^ Input filename
+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
+  -> [FilePath]                 -- ^ foreign objects, if we have one
+  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
+runPipeline' start_phase hsc_env env input_fn
+             maybe_loc foreign_os
+  = do
+  -- Execute the pipeline...
+  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
+
+  evalP (pipeLoop start_phase input_fn) env state
+
+-- ---------------------------------------------------------------------------
+-- outer pipeline loop
+
+-- | pipeLoop runs phases until we reach the stop phase
+pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
+pipeLoop phase input_fn = do
+  env <- getPipeEnv
+  dflags <- getDynFlags
+  -- See Note [Partial ordering on phases]
+  let happensBefore' = happensBefore dflags
+      stopPhase = stop_phase env
+  case phase of
+   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done
+     -> -- Sometimes, a compilation phase doesn't actually generate any output
+        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
+        -- stage, but we wanted to keep the output, then we have to explicitly
+        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
+        -- further compilation stages can tell what the original filename was.
+        case output_spec env of
+        Temporary _ ->
+            return (dflags, input_fn)
+        output ->
+            do pst <- getPipeState
+               final_fn <- liftIO $ getOutputFilename
+                                        stopPhase output (src_basename env)
+                                        dflags stopPhase (maybe_loc pst)
+               when (final_fn /= input_fn) $ do
+                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
+                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
+                  liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
+               return (dflags, final_fn)
+
+
+     | not (realPhase `happensBefore'` stopPhase)
+        -- Something has gone wrong.  We'll try to cover all the cases when
+        -- this could happen, so if we reach here it is a panic.
+        -- eg. it might happen if the -C flag is used on a source file that
+        -- has {-# OPTIONS -fasm #-}.
+     -> panic ("pipeLoop: at phase " ++ show realPhase ++
+           " but I wanted to stop at phase " ++ show stopPhase)
+
+   _
+     -> do liftIO $ debugTraceMsg dflags 4
+                                  (text "Running phase" <+> ppr phase)
+           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
+           r <- pipeLoop next_phase output_fn
+           case phase of
+               HscOut {} ->
+                   whenGeneratingDynamicToo dflags $ do
+                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags
+                       -- TODO shouldn't ignore result:
+                       _ <- pipeLoop phase input_fn
+                       return ()
+               _ ->
+                   return ()
+           return r
+
+runHookedPhase :: PhasePlus -> FilePath -> DynFlags
+               -> CompPipeline (PhasePlus, FilePath)
+runHookedPhase pp input dflags =
+  lookupHook runPhaseHook runPhase dflags pp input dflags
+
+-- -----------------------------------------------------------------------------
+-- In each phase, we need to know into what filename to generate the
+-- output.  All the logic about which filenames we generate output
+-- into is embodied in the following function.
+
+-- | Computes the next output filename after we run @next_phase@.
+-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
+-- (which specifies all of the ambient information.)
+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
+phaseOutputFilename next_phase = do
+  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
+  PipeState{maybe_loc, hsc_env} <- getPipeState
+  let dflags = hsc_dflags hsc_env
+  liftIO $ getOutputFilename stop_phase output_spec
+                             src_basename dflags next_phase maybe_loc
+
+-- | Computes the next output filename for something in the compilation
+-- pipeline.  This is controlled by several variables:
+--
+--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This
+--         is used to tell if we're in the last phase or not, because
+--         in that case flags like @-o@ may be important.
+--      2. 'PipelineOutput': is this intended to be a 'Temporary' or
+--         'Persistent' build output?  Temporary files just go in
+--         a fresh temporary name.
+--      3. 'String': what was the basename of the original input file?
+--      4. 'DynFlags': the obvious thing
+--      5. 'Phase': the phase we want to determine the output filename of.
+--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're
+--         compiling; this can be used to override the default output
+--         of an object file.  (TODO: do we actually need this?)
+getOutputFilename
+  :: Phase -> PipelineOutput -> String
+  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
+getOutputFilename stop_phase output basename dflags next_phase maybe_location
+ | is_last_phase, Persistent   <- output = persistent_fn
+ | is_last_phase, SpecificFile <- output = case outputFile dflags of
+                                           Just f -> return f
+                                           Nothing ->
+                                               panic "SpecificFile: No filename"
+ | keep_this_output                      = persistent_fn
+ | Temporary lifetime <- output          = newTempName dflags lifetime suffix
+ | otherwise                             = newTempName dflags TFL_CurrentModule
+   suffix
+    where
+          hcsuf      = hcSuf dflags
+          odir       = objectDir dflags
+          osuf       = objectSuf dflags
+          keep_hc    = gopt Opt_KeepHcFiles dflags
+          keep_hscpp = gopt Opt_KeepHscppFiles dflags
+          keep_s     = gopt Opt_KeepSFiles dflags
+          keep_bc    = gopt Opt_KeepLlvmFiles dflags
+
+          myPhaseInputExt HCc       = hcsuf
+          myPhaseInputExt MergeForeign = osuf
+          myPhaseInputExt StopLn    = osuf
+          myPhaseInputExt other     = phaseInputExt other
+
+          is_last_phase = next_phase `eqPhase` stop_phase
+
+          -- sometimes, we keep output from intermediate stages
+          keep_this_output =
+               case next_phase of
+                       As _    | keep_s     -> True
+                       LlvmOpt | keep_bc    -> True
+                       HCc     | keep_hc    -> True
+                       HsPp _  | keep_hscpp -> True   -- See #10869
+                       _other               -> False
+
+          suffix = myPhaseInputExt next_phase
+
+          -- persistent object files get put in odir
+          persistent_fn
+             | StopLn <- next_phase = return odir_persistent
+             | otherwise            = return persistent
+
+          persistent = basename <.> suffix
+
+          odir_persistent
+             | Just loc <- maybe_location = ml_obj_file loc
+             | Just d <- odir = d </> persistent
+             | otherwise      = persistent
+
+
+-- | The fast LLVM Pipeline skips the mangler and assembler,
+-- emitting object code directly from llc.
+--
+-- slow: opt -> llc -> .s -> mangler -> as -> .o
+-- fast: opt -> llc -> .o
+--
+-- hidden flag: -ffast-llvm
+--
+-- if keep-s-files is specified, we need to go through
+-- the slow pipeline (Kavon Farvardin requested this).
+fastLlvmPipeline :: DynFlags -> Bool
+fastLlvmPipeline dflags
+  = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
+
+-- | LLVM Options. These are flags to be passed to opt and llc, to ensure
+-- consistency we list them in pairs, so that they form groups.
+llvmOptions :: DynFlags
+            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments
+llvmOptions dflags =
+       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
+    ++ [("-relocation-model=" ++ rmodel
+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
+    ++ [("-stack-alignment=" ++ (show align)
+        ,"-stack-alignment=" ++ (show align)) | align > 0 ]
+    ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
+
+    -- Additional llc flags
+    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)
+                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
+    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
+
+  where target = LLVM_TARGET
+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
+
+        -- Relocation models
+        rmodel | gopt Opt_PIC dflags        = "pic"
+               | positionIndependent dflags = "pic"
+               | WayDyn `elem` ways dflags  = "dynamic-no-pic"
+               | otherwise                  = "static"
+
+        align :: Int
+        align = case platformArch (targetPlatform dflags) of
+                  ArchX86_64 | isAvxEnabled dflags -> 32
+                  _                                -> 0
+
+        attrs :: String
+        attrs = intercalate "," $ mattr
+              ++ ["+sse42"   | isSse4_2Enabled dflags   ]
+              ++ ["+sse2"    | isSse2Enabled dflags     ]
+              ++ ["+sse"     | isSseEnabled dflags      ]
+              ++ ["+avx512f" | isAvx512fEnabled dflags  ]
+              ++ ["+avx2"    | isAvx2Enabled dflags     ]
+              ++ ["+avx"     | isAvxEnabled dflags      ]
+              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
+              ++ ["+avx512er"| isAvx512erEnabled dflags ]
+              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
+              ++ ["+bmi"     | isBmiEnabled dflags      ]
+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]
+
+-- -----------------------------------------------------------------------------
+-- | Each phase in the pipeline returns the next phase to execute, and the
+-- name of the file in which the output was placed.
+--
+-- We must do things dynamically this way, because we often don't know
+-- what the rest of the phases will be until part-way through the
+-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
+-- of a source file can change the latter stages of the pipeline from
+-- taking the LLVM route to using the native code generator.
+--
+runPhase :: PhasePlus   -- ^ Run this phase
+         -> FilePath    -- ^ name of the input file
+         -> DynFlags    -- ^ for convenience, we pass the current dflags in
+         -> CompPipeline (PhasePlus,           -- next phase to run
+                          FilePath)            -- output filename
+
+        -- Invariant: the output filename always contains the output
+        -- Interesting case: Hsc when there is no recompilation to do
+        --                   Then the output filename is still a .o file
+
+
+-------------------------------------------------------------------------------
+-- Unlit phase
+
+runPhase (RealPhase (Unlit sf)) input_fn dflags
+  = do
+       output_fn <- phaseOutputFilename (Cpp sf)
+
+       let flags = [ -- The -h option passes the file name for unlit to
+                     -- put in a #line directive
+                     SysTools.Option     "-h"
+                     -- See Note [Don't normalise input filenames].
+                   , SysTools.Option $ escape input_fn
+                   , SysTools.FileOption "" input_fn
+                   , SysTools.FileOption "" output_fn
+                   ]
+
+       liftIO $ SysTools.runUnlit dflags flags
+
+       return (RealPhase (Cpp sf), output_fn)
+  where
+       -- escape the characters \, ", and ', but don't try to escape
+       -- Unicode or anything else (so we don't use Util.charToC
+       -- here).  If we get this wrong, then in
+       -- Coverage.isGoodTickSrcSpan where we check that the filename in
+       -- a SrcLoc is the same as the source filenaame, the two will
+       -- look bogusly different. See test:
+       -- libraries/hpc/tests/function/subdir/tough2.hs
+       escape ('\\':cs) = '\\':'\\': escape cs
+       escape ('\"':cs) = '\\':'\"': escape cs
+       escape ('\'':cs) = '\\':'\'': escape cs
+       escape (c:cs)    = c : escape cs
+       escape []        = []
+
+-------------------------------------------------------------------------------
+-- Cpp phase : (a) gets OPTIONS out of file
+--             (b) runs cpp if necessary
+
+runPhase (RealPhase (Cpp sf)) input_fn dflags0
+  = do
+       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
+       (dflags1, unhandled_flags, warns)
+           <- liftIO $ parseDynamicFilePragma dflags0 src_opts
+       setDynFlags dflags1
+       liftIO $ checkProcessArgsResult dflags1 unhandled_flags
+
+       if not (xopt LangExt.Cpp dflags1) then do
+           -- we have to be careful to emit warnings only once.
+           unless (gopt Opt_Pp dflags1) $
+               liftIO $ handleFlagWarnings dflags1 warns
+
+           -- no need to preprocess CPP, just pass input file along
+           -- to the next phase of the pipeline.
+           return (RealPhase (HsPp sf), input_fn)
+        else do
+            output_fn <- phaseOutputFilename (HsPp sf)
+            liftIO $ doCpp dflags1 True{-raw-}
+                           input_fn output_fn
+            -- re-read the pragmas now that we've preprocessed the file
+            -- See #2464,#3457
+            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
+            (dflags2, unhandled_flags, warns)
+                <- liftIO $ parseDynamicFilePragma dflags0 src_opts
+            liftIO $ checkProcessArgsResult dflags2 unhandled_flags
+            unless (gopt Opt_Pp dflags2) $
+                liftIO $ handleFlagWarnings dflags2 warns
+            -- the HsPp pass below will emit warnings
+
+            setDynFlags dflags2
+
+            return (RealPhase (HsPp sf), output_fn)
+
+-------------------------------------------------------------------------------
+-- HsPp phase
+
+runPhase (RealPhase (HsPp sf)) input_fn dflags
+  = do
+       if not (gopt Opt_Pp dflags) then
+           -- no need to preprocess, just pass input file along
+           -- to the next phase of the pipeline.
+          return (RealPhase (Hsc sf), input_fn)
+        else do
+            PipeEnv{src_basename, src_suffix} <- getPipeEnv
+            let orig_fn = src_basename <.> src_suffix
+            output_fn <- phaseOutputFilename (Hsc sf)
+            liftIO $ SysTools.runPp dflags
+                           ( [ SysTools.Option     orig_fn
+                             , SysTools.Option     input_fn
+                             , SysTools.FileOption "" output_fn
+                             ]
+                           )
+
+            -- re-read pragmas now that we've parsed the file (see #3674)
+            src_opts <- liftIO $ getOptionsFromFile dflags output_fn
+            (dflags1, unhandled_flags, warns)
+                <- liftIO $ parseDynamicFilePragma dflags src_opts
+            setDynFlags dflags1
+            liftIO $ checkProcessArgsResult dflags1 unhandled_flags
+            liftIO $ handleFlagWarnings dflags1 warns
+
+            return (RealPhase (Hsc sf), output_fn)
+
+-----------------------------------------------------------------------------
+-- Hsc phase
+
+-- Compilation of a single module, in "legacy" mode (_not_ under
+-- the direction of the compilation manager).
+runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
+ = do   -- normal Hsc mode, not mkdependHS
+
+        PipeEnv{ stop_phase=stop,
+                 src_basename=basename,
+                 src_suffix=suff } <- getPipeEnv
+
+  -- we add the current directory (i.e. the directory in which
+  -- the .hs files resides) to the include path, since this is
+  -- what gcc does, and it's probably what you want.
+        let current_dir = takeDirectory basename
+            new_includes = addQuoteInclude paths [current_dir]
+            paths = includePaths dflags0
+            dflags = dflags0 { includePaths = new_includes }
+
+        setDynFlags dflags
+
+  -- gather the imports and module name
+        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
+          do
+            buf <- hGetStringBuffer input_fn
+            (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
+            return (Just buf, mod_name, imps, src_imps)
+
+  -- Take -o into account if present
+  -- Very like -ohi, but we must *only* do this if we aren't linking
+  -- (If we're linking then the -o applies to the linked thing, not to
+  -- the object file for one module.)
+  -- Note the nasty duplication with the same computation in compileFile above
+        location <- getLocation src_flavour mod_name
+
+        let o_file = ml_obj_file location -- The real object file
+            hi_file = ml_hi_file location
+            hie_file = ml_hie_file location
+            dest_file | writeInterfaceOnlyMode dflags
+                            = hi_file
+                      | otherwise
+                            = o_file
+
+  -- Figure out if the source has changed, for recompilation avoidance.
+  --
+  -- Setting source_unchanged to True means that M.o (or M.hie) seems
+  -- to be up to date wrt M.hs; so no need to recompile unless imports have
+  -- changed (which the compiler itself figures out).
+  -- Setting source_unchanged to False tells the compiler that M.o is out of
+  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
+        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
+
+        source_unchanged <- liftIO $
+          if not (isStopLn stop)
+                -- SourceModified unconditionally if
+                --      (a) recompilation checker is off, or
+                --      (b) we aren't going all the way to .o file (e.g. ghc -S)
+             then return SourceModified
+                -- Otherwise look at file modification dates
+             else do dest_file_mod <- sourceModified dest_file src_timestamp
+                     hie_file_mod <- if gopt Opt_WriteHie dflags
+                                        then sourceModified hie_file
+                                                            src_timestamp
+                                        else pure False
+                     if dest_file_mod || hie_file_mod
+                        then return SourceModified
+                        else return SourceUnmodified
+
+        PipeState{hsc_env=hsc_env'} <- getPipeState
+
+  -- Tell the finder cache about this module
+        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
+
+  -- Make the ModSummary to hand to hscMain
+        let
+            mod_summary = ModSummary {  ms_mod       = mod,
+                                        ms_hsc_src   = src_flavour,
+                                        ms_hspp_file = input_fn,
+                                        ms_hspp_opts = dflags,
+                                        ms_hspp_buf  = hspp_buf,
+                                        ms_location  = location,
+                                        ms_hs_date   = src_timestamp,
+                                        ms_obj_date  = Nothing,
+                                        ms_parsed_mod   = Nothing,
+                                        ms_iface_date   = Nothing,
+                                        ms_hie_date     = Nothing,
+                                        ms_textual_imps = imps,
+                                        ms_srcimps      = src_imps }
+
+  -- run the compiler!
+        let msg hsc_env _ what _ = oneShotMsg hsc_env what
+        (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
+                            mod_summary source_unchanged Nothing (1,1)
+
+        return (HscOut src_flavour mod_name result,
+                panic "HscOut doesn't have an input filename")
+
+runPhase (HscOut src_flavour mod_name result) _ dflags = do
+        location <- getLocation src_flavour mod_name
+        setModLocation location
+
+        let o_file = ml_obj_file location -- The real object file
+            hsc_lang = hscTarget dflags
+            next_phase = hscPostBackendPhase src_flavour hsc_lang
+
+        case result of
+            HscNotGeneratingCode ->
+                return (RealPhase StopLn,
+                        panic "No output filename from Hsc when no-code")
+            HscUpToDate ->
+                do liftIO $ touchObjectFile dflags o_file
+                   -- The .o file must have a later modification date
+                   -- than the source file (else we wouldn't get Nothing)
+                   -- but we touch it anyway, to keep 'make' happy (we think).
+                   return (RealPhase StopLn, o_file)
+            HscUpdateBoot ->
+                do -- In the case of hs-boot files, generate a dummy .o-boot
+                   -- stamp file for the benefit of Make
+                   liftIO $ touchObjectFile dflags o_file
+                   return (RealPhase StopLn, o_file)
+            HscUpdateSig ->
+                do -- We need to create a REAL but empty .o file
+                   -- because we are going to attempt to put it in a library
+                   PipeState{hsc_env=hsc_env'} <- getPipeState
+                   let input_fn = expectJust "runPhase" (ml_hs_file location)
+                       basename = dropExtension input_fn
+                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
+                   return (RealPhase StopLn, o_file)
+            HscRecomp cgguts mod_summary
+              -> do output_fn <- phaseOutputFilename next_phase
+
+                    PipeState{hsc_env=hsc_env'} <- getPipeState
+
+                    (outputFilename, mStub, foreign_files) <- liftIO $
+                      hscGenHardCode hsc_env' cgguts mod_summary output_fn
+                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
+                    foreign_os <- liftIO $
+                      mapM (uncurry (compileForeign hsc_env')) foreign_files
+                    setForeignOs (maybe [] return stub_o ++ foreign_os)
+
+                    return (RealPhase next_phase, outputFilename)
+
+-----------------------------------------------------------------------------
+-- Cmm phase
+
+runPhase (RealPhase CmmCpp) input_fn dflags
+  = do
+       output_fn <- phaseOutputFilename Cmm
+       liftIO $ doCpp dflags False{-not raw-}
+                      input_fn output_fn
+       return (RealPhase Cmm, output_fn)
+
+runPhase (RealPhase Cmm) input_fn dflags
+  = do
+        let hsc_lang = hscTarget dflags
+
+        let next_phase = hscPostBackendPhase HsSrcFile hsc_lang
+
+        output_fn <- phaseOutputFilename next_phase
+
+        PipeState{hsc_env} <- getPipeState
+
+        liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
+
+        return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- Cc phase
+
+-- we don't support preprocessing .c files (with -E) now.  Doing so introduces
+-- way too many hacks, and I can't say I've ever used it anyway.
+
+runPhase (RealPhase cc_phase) input_fn dflags
+   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
+   = do
+        let platform = targetPlatform dflags
+            hcc = cc_phase `eqPhase` HCc
+
+        let cmdline_include_paths = includePaths dflags
+
+        -- HC files have the dependent packages stamped into them
+        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
+
+        -- add package include paths even if we're just compiling .c
+        -- files; this is the Value Add(TM) that using ghc instead of
+        -- gcc gives you :)
+        pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
+        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+              (includePathsQuote cmdline_include_paths)
+        let include_paths = include_paths_quote ++ include_paths_global
+
+        let gcc_extra_viac_flags = extraGccViaCFlags dflags
+        let pic_c_flags = picCCOpts dflags
+
+        let verbFlags = getVerbFlags dflags
+
+        -- cc-options are not passed when compiling .hc files.  Our
+        -- hc code doesn't not #include any header files anyway, so these
+        -- options aren't necessary.
+        pkg_extra_cc_opts <- liftIO $
+          if cc_phase `eqPhase` HCc
+             then return []
+             else getPackageExtraCcOpts dflags pkgs
+
+        framework_paths <-
+            if platformUsesFrameworks platform
+            then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
+                    let cmdlineFrameworkPaths = frameworkPaths dflags
+                    return $ map ("-F"++)
+                                 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
+            else return []
+
+        let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
+                   | optLevel dflags >= 1 = [ "-O" ]
+                   | otherwise            = []
+
+        -- Decide next phase
+        let next_phase = As False
+        output_fn <- phaseOutputFilename next_phase
+
+        let
+          more_hcc_opts =
+                -- on x86 the floating point regs have greater precision
+                -- than a double, which leads to unpredictable results.
+                -- By default, we turn this off with -ffloat-store unless
+                -- the user specified -fexcess-precision.
+                (if platformArch platform == ArchX86 &&
+                    not (gopt Opt_ExcessPrecision dflags)
+                        then [ "-ffloat-store" ]
+                        else []) ++
+
+                -- gcc's -fstrict-aliasing allows two accesses to memory
+                -- to be considered non-aliasing if they have different types.
+                -- This interacts badly with the C code we generate, which is
+                -- very weakly typed, being derived from C--.
+                ["-fno-strict-aliasing"]
+
+        ghcVersionH <- liftIO $ getGhcVersionPathName dflags
+
+        liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags (
+                        [ SysTools.FileOption "" input_fn
+                        , SysTools.Option "-o"
+                        , SysTools.FileOption "" output_fn
+                        ]
+                       ++ map SysTools.Option (
+                          pic_c_flags
+
+                -- Stub files generated for foreign exports references the runIO_closure
+                -- and runNonIO_closure symbols, which are defined in the base package.
+                -- These symbols are imported into the stub.c file via RtsAPI.h, and the
+                -- way we do the import depends on whether we're currently compiling
+                -- the base package or not.
+                       ++ (if platformOS platform == OSMinGW32 &&
+                              thisPackage dflags == baseUnitId
+                                then [ "-DCOMPILING_BASE_PACKAGE" ]
+                                else [])
+
+        -- We only support SparcV9 and better because V8 lacks an atomic CAS
+        -- instruction. Note that the user can still override this
+        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
+        -- regardless of the ordering.
+        --
+        -- This is a temporary hack. See #2872, commit
+        -- 5bd3072ac30216a505151601884ac88bf404c9f2
+                       ++ (if platformArch platform == ArchSPARC
+                           then ["-mcpu=v9"]
+                           else [])
+
+                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
+                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
+                             then ["-Wimplicit"]
+                             else [])
+
+                       ++ (if hcc
+                             then gcc_extra_viac_flags ++ more_hcc_opts
+                             else [])
+                       ++ verbFlags
+                       ++ [ "-S" ]
+                       ++ cc_opt
+                       ++ [ "-include", ghcVersionH ]
+                       ++ framework_paths
+                       ++ include_paths
+                       ++ pkg_extra_cc_opts
+                       ))
+
+        return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- As, SpitAs phase : Assembler
+
+-- This is for calling the assembler on a regular assembly file
+runPhase (RealPhase (As with_cpp)) input_fn dflags
+  = do
+        -- LLVM from version 3.0 onwards doesn't support the OS X system
+        -- assembler, so we use clang as the assembler instead. (#5636)
+        let as_prog | hscTarget dflags == HscLlvm &&
+                      platformOS (targetPlatform dflags) == OSDarwin
+                    = SysTools.runClang
+                    | otherwise = SysTools.runAs
+
+        let cmdline_include_paths = includePaths dflags
+        let pic_c_flags = picCCOpts dflags
+
+        next_phase <- maybeMergeForeign
+        output_fn <- phaseOutputFilename next_phase
+
+        -- we create directories for the object file, because it
+        -- might be a hierarchical module.
+        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
+
+        ccInfo <- liftIO $ getCompilerInfo dflags
+        let global_includes = [ SysTools.Option ("-I" ++ p)
+                              | p <- includePathsGlobal cmdline_include_paths ]
+        let local_includes = [ SysTools.Option ("-iquote" ++ p)
+                             | p <- includePathsQuote cmdline_include_paths ]
+        let runAssembler inputFilename outputFilename
+              = liftIO $ do
+                  withAtomicRename outputFilename $ \temp_outputFilename -> do
+                    as_prog
+                       dflags
+                       (local_includes ++ global_includes
+                       -- See Note [-fPIC for assembler]
+                       ++ map SysTools.Option pic_c_flags
+                       -- See Note [Produce big objects on Windows]
+                       ++ [ SysTools.Option "-Wa,-mbig-obj"
+                          | platformOS (targetPlatform dflags) == OSMinGW32
+                          , not $ target32Bit (targetPlatform dflags)
+                          ]
+
+        -- We only support SparcV9 and better because V8 lacks an atomic CAS
+        -- instruction so we have to make sure that the assembler accepts the
+        -- instruction set. Note that the user can still override this
+        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
+        -- regardless of the ordering.
+        --
+        -- This is a temporary hack.
+                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+                           then [SysTools.Option "-mcpu=v9"]
+                           else [])
+                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+                            then [SysTools.Option "-Qunused-arguments"]
+                            else [])
+                       ++ [ SysTools.Option "-x"
+                          , if with_cpp
+                              then SysTools.Option "assembler-with-cpp"
+                              else SysTools.Option "assembler"
+                          , SysTools.Option "-c"
+                          , SysTools.FileOption "" inputFilename
+                          , SysTools.Option "-o"
+                          , SysTools.FileOption "" temp_outputFilename
+                          ])
+
+        liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
+        runAssembler input_fn output_fn
+
+        return (RealPhase next_phase, output_fn)
+
+
+-----------------------------------------------------------------------------
+-- LlvmOpt phase
+runPhase (RealPhase LlvmOpt) input_fn dflags
+  = do
+    output_fn <- phaseOutputFilename LlvmLlc
+
+    liftIO $ SysTools.runLlvmOpt dflags
+               (   optFlag
+                ++ defaultOptions ++
+                [ SysTools.FileOption "" input_fn
+                , SysTools.Option "-o"
+                , SysTools.FileOption "" output_fn]
+                )
+
+    return (RealPhase LlvmLlc, output_fn)
+  where
+        -- we always (unless -optlo specified) run Opt since we rely on it to
+        -- fix up some pretty big deficiencies in the code we generate
+        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]
+        llvmOpts = case lookup optIdx $ llvmPasses dflags of
+                    Just passes -> passes
+                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
+                                      ++ "is missing passes for level "
+                                      ++ show optIdx)
+
+        -- don't specify anything if user has specified commands. We do this
+        -- for opt but not llc since opt is very specifically for optimisation
+        -- passes only, so if the user is passing us extra options we assume
+        -- they know what they are doing and don't get in the way.
+        optFlag = if null (getOpts dflags opt_lo)
+                  then map SysTools.Option $ words llvmOpts
+                  else []
+
+        defaultOptions = map SysTools.Option . concat . fmap words . fst
+                       $ unzip (llvmOptions dflags)
+
+-----------------------------------------------------------------------------
+-- LlvmLlc phase
+
+runPhase (RealPhase LlvmLlc) input_fn dflags
+  = do
+    next_phase <- if | fastLlvmPipeline dflags -> maybeMergeForeign
+                     -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
+                     | gopt Opt_NoLlvmMangler dflags -> return (As False)
+                     | otherwise -> return LlvmMangle
+
+    output_fn <- phaseOutputFilename next_phase
+
+    liftIO $ SysTools.runLlvmLlc dflags
+                (  optFlag
+                ++ defaultOptions
+                ++ [ SysTools.FileOption "" input_fn
+                   , SysTools.Option "-o"
+                   , SysTools.FileOption "" output_fn
+                   ]
+                )
+
+    return (RealPhase next_phase, output_fn)
+  where
+    -- Note [Clamping of llc optimizations]
+    --
+    -- See #13724
+    --
+    -- we clamp the llc optimization between [1,2]. This is because passing -O0
+    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
+    --
+    --   Error while trying to spill R1 from class GPR: Cannot scavenge register
+    --   without an emergency spill slot!
+    --
+    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
+    --
+    --
+    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
+    --   rts/HeapStackCheck.cmm
+    --
+    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
+    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
+    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358
+    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
+    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876
+    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
+    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
+    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
+    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
+    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
+    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
+    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
+    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
+    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
+    -- 13 llc                      0x000000010195bf0b main + 491
+    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1
+    -- Stack dump:
+    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
+    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
+    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
+    --
+    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
+    --
+    llvmOpts = case optLevel dflags of
+      0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
+      1 -> "-O1"
+      _ -> "-O2"
+
+    optFlag = if null (getOpts dflags opt_lc)
+              then map SysTools.Option $ words llvmOpts
+              else []
+
+    defaultOptions = map SysTools.Option . concat . fmap words . snd
+                   $ unzip (llvmOptions dflags)
+
+
+-----------------------------------------------------------------------------
+-- LlvmMangle phase
+
+runPhase (RealPhase LlvmMangle) input_fn dflags
+  = do
+      let next_phase = As False
+      output_fn <- phaseOutputFilename next_phase
+      liftIO $ llvmFixupAsm dflags input_fn output_fn
+      return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- merge in stub objects
+
+runPhase (RealPhase MergeForeign) input_fn dflags
+ = do
+     PipeState{foreign_os} <- getPipeState
+     output_fn <- phaseOutputFilename StopLn
+     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
+     if null foreign_os
+       then panic "runPhase(MergeForeign): no foreign objects"
+       else do
+         liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
+         return (RealPhase StopLn, output_fn)
+
+-- warning suppression
+runPhase (RealPhase other) _input_fn _dflags =
+   panic ("runPhase: don't know how to run phase " ++ show other)
+
+maybeMergeForeign :: CompPipeline Phase
+maybeMergeForeign
+ = do
+     PipeState{foreign_os} <- getPipeState
+     if null foreign_os then return StopLn else return MergeForeign
+
+getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
+getLocation src_flavour mod_name = do
+    dflags <- getDynFlags
+
+    PipeEnv{ src_basename=basename,
+             src_suffix=suff } <- getPipeEnv
+    PipeState { maybe_loc=maybe_loc} <- getPipeState
+    case maybe_loc of
+        -- Build a ModLocation to pass to hscMain.
+        -- The source filename is rather irrelevant by now, but it's used
+        -- by hscMain for messages.  hscMain also needs
+        -- the .hi and .o filenames. If we already have a ModLocation
+        -- then simply update the extensions of the interface and object
+        -- files to match the DynFlags, otherwise use the logic in Finder.
+      Just l -> return $ l
+        { ml_hs_file = Just $ basename <.> suff
+        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags
+        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags
+        }
+      _ -> do
+        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
+
+        -- Boot-ify it if necessary
+        let location2
+              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
+              | otherwise                 = location1
+
+
+        -- Take -ohi into account if present
+        -- This can't be done in mkHomeModuleLocation because
+        -- it only applies to the module being compiles
+        let ohi = outputHi dflags
+            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+                      | otherwise      = location2
+
+        -- Take -o into account if present
+        -- Very like -ohi, but we must *only* do this if we aren't linking
+        -- (If we're linking then the -o applies to the linked thing, not to
+        -- the object file for one module.)
+        -- Note the nasty duplication with the same computation in compileFile
+        -- above
+        let expl_o_file = outputFile dflags
+            location4 | Just ofile <- expl_o_file
+                      , isNoLink (ghcLink dflags)
+                      = location3 { ml_obj_file = ofile }
+                      | otherwise = location3
+        return location4
+
+-----------------------------------------------------------------------------
+-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
+
+getHCFilePackages :: FilePath -> IO [InstalledUnitId]
+getHCFilePackages filename =
+  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
+    l <- hGetLine h
+    case l of
+      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
+          return (map stringToInstalledUnitId (words rest))
+      _other ->
+          return []
+
+-----------------------------------------------------------------------------
+-- Static linking, of .o files
+
+-- The list of packages passed to link is the list of packages on
+-- which this program depends, as discovered by the compilation
+-- manager.  It is combined with the list of packages that the user
+-- specifies on the command line with -package flags.
+--
+-- In one-shot linking mode, we can't discover the package
+-- dependencies (because we haven't actually done any compilation or
+-- read any interface files), so the user must explicitly specify all
+-- the packages.
+
+{-
+Note [-Xlinker -rpath vs -Wl,-rpath]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-Wl takes a comma-separated list of options which in the case of
+-Wl,-rpath -Wl,some,path,with,commas parses the path with commas
+as separate options.
+Buck, the build system, produces paths with commas in them.
+
+-Xlinker doesn't have this disadvantage and as far as I can tell
+it is supported by both gcc and clang. Anecdotally nvcc supports
+-Xlinker, but not -Wl.
+-}
+
+linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
+linkBinary = linkBinary' False
+
+linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
+linkBinary' staticLink dflags o_files dep_packages = do
+    let platform = targetPlatform dflags
+        mySettings = settings dflags
+        verbFlags = getVerbFlags dflags
+        output_fn = exeFileName staticLink dflags
+
+    -- get the full list of packages to link with, by combining the
+    -- explicit packages with the auto packages and all of their
+    -- dependencies, and eliminating duplicates.
+
+    full_output_fn <- if isAbsolute output_fn
+                      then return output_fn
+                      else do d <- getCurrentDirectory
+                              return $ normalise (d </> output_fn)
+    pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
+        get_pkg_lib_path_opts l
+         | osElfTarget (platformOS platform) &&
+           dynLibLoader dflags == SystemDependent &&
+           WayDyn `elem` ways dflags
+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags
+                            then "$ORIGIN" </>
+                                 (l `makeRelativeTo` full_output_fn)
+                            else l
+                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+                  rpath = if gopt Opt_RPath dflags
+                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]
+                          else []
+                  -- Solaris 11's linker does not support -rpath-link option. It silently
+                  -- ignores it and then complains about next option which is -l<some
+                  -- dir> as being a directory and not expected object file, E.g
+                  -- ld: elf error: file
+                  -- /tmp/ghc-src/libraries/base/dist-install/build:
+                  -- elf_begin: I/O error: region read: Is a directory
+                  rpathlink = if (platformOS platform) == OSSolaris2
+                              then []
+                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]
+              in ["-L" ++ l] ++ rpathlink ++ rpath
+         | osMachOTarget (platformOS platform) &&
+           dynLibLoader dflags == SystemDependent &&
+           WayDyn `elem` ways dflags &&
+           gopt Opt_RPath dflags
+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags
+                            then "@loader_path" </>
+                                 (l `makeRelativeTo` full_output_fn)
+                            else l
+              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
+         | otherwise = ["-L" ++ l]
+
+    pkg_lib_path_opts <-
+      if gopt Opt_SingleLibFolder dflags
+      then do
+        libs <- getLibs dflags dep_packages
+        tmpDir <- newTempDir dflags
+        sequence_ [ copyFile lib (tmpDir </> basename)
+                  | (lib, basename) <- libs]
+        return [ "-L" ++ tmpDir ]
+      else pure pkg_lib_path_opts
+
+    let
+      dead_strip
+        | gopt Opt_WholeArchiveHsLibs dflags = []
+        | otherwise = if osSubsectionsViaSymbols (platformOS platform)
+                        then ["-Wl,-dead_strip"]
+                        else []
+    let lib_paths = libraryPaths dflags
+    let lib_path_opts = map ("-L"++) lib_paths
+
+    extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
+    noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
+
+    let
+      (pre_hs_libs, post_hs_libs)
+        | gopt Opt_WholeArchiveHsLibs dflags
+        = if platformOS platform == OSDarwin
+            then (["-Wl,-all_load"], [])
+              -- OS X does not have a flag to turn off -all_load
+            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
+        | otherwise
+        = ([],[])
+
+    pkg_link_opts <- do
+        (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
+        return $ if staticLink
+            then package_hs_libs -- If building an executable really means making a static
+                                 -- library (e.g. iOS), then we only keep the -l options for
+                                 -- HS packages, because libtool doesn't accept other options.
+                                 -- In the case of iOS these need to be added by hand to the
+                                 -- final link in Xcode.
+            else other_flags ++ dead_strip
+                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
+                  ++ extra_libs
+                 -- -Wl,-u,<sym> contained in other_flags
+                 -- needs to be put before -l<package>,
+                 -- otherwise Solaris linker fails linking
+                 -- a binary with unresolved symbols in RTS
+                 -- which are defined in base package
+                 -- the reason for this is a note in ld(1) about
+                 -- '-u' option: "The placement of this option
+                 -- on the command line is significant.
+                 -- This option must be placed before the library
+                 -- that defines the symbol."
+
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
+    let framework_opts = getFrameworkOpts dflags platform
+
+        -- probably _stub.o files
+    let extra_ld_inputs = ldInputs dflags
+
+    -- Here are some libs that need to be linked at the *end* of
+    -- the command line, because they contain symbols that are referred to
+    -- by the RTS.  We can't therefore use the ordinary way opts for these.
+    let debug_opts | WayDebug `elem` ways dflags = [
+#if defined(HAVE_LIBBFD)
+                        "-lbfd", "-liberty"
+#endif
+                         ]
+                   | otherwise                   = []
+
+        thread_opts | WayThreaded `elem` ways dflags = [
+#if NEED_PTHREAD_LIB
+                        "-lpthread"
+#endif
+                        ]
+                    | otherwise                      = []
+
+    rc_objs <- maybeCreateManifest dflags output_fn
+
+    let link = if staticLink
+                   then SysTools.runLibtool
+                   else SysTools.runLink
+    link dflags (
+                       map SysTools.Option verbFlags
+                      ++ [ SysTools.Option "-o"
+                         , SysTools.FileOption "" output_fn
+                         ]
+                      ++ libmLinkOpts
+                      ++ map SysTools.Option (
+                         []
+
+                      -- See Note [No PIE when linking]
+                      ++ picCCOpts dflags
+
+                      -- Permit the linker to auto link _symbol to _imp_symbol.
+                      -- This lets us link against DLLs without needing an "import library".
+                      ++ (if platformOS platform == OSMinGW32
+                          then ["-Wl,--enable-auto-import"]
+                          else [])
+
+                      -- '-no_compact_unwind'
+                      -- C++/Objective-C exceptions cannot use optimised
+                      -- stack unwinding code. The optimised form is the
+                      -- default in Xcode 4 on at least x86_64, and
+                      -- without this flag we're also seeing warnings
+                      -- like
+                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
+                      -- on x86.
+                      ++ (if sLdSupportsCompactUnwind mySettings &&
+                             not staticLink &&
+                             (platformOS platform == OSDarwin) &&
+                             case platformArch platform of
+                               ArchX86 -> True
+                               ArchX86_64 -> True
+                               ArchARM {} -> True
+                               ArchARM64  -> True
+                               _ -> False
+                          then ["-Wl,-no_compact_unwind"]
+                          else [])
+
+                      -- '-Wl,-read_only_relocs,suppress'
+                      -- ld gives loads of warnings like:
+                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
+                      -- when linking any program. We're not sure
+                      -- whether this is something we ought to fix, but
+                      -- for now this flags silences them.
+                      ++ (if platformOS   platform == OSDarwin &&
+                             platformArch platform == ArchX86 &&
+                             not staticLink
+                          then ["-Wl,-read_only_relocs,suppress"]
+                          else [])
+
+                      ++ (if sLdIsGnuLd mySettings &&
+                             not (gopt Opt_WholeArchiveHsLibs dflags)
+                          then ["-Wl,--gc-sections"]
+                          else [])
+
+                      ++ o_files
+                      ++ lib_path_opts)
+                      ++ extra_ld_inputs
+                      ++ map SysTools.Option (
+                         rc_objs
+                      ++ framework_opts
+                      ++ pkg_lib_path_opts
+                      ++ extraLinkObj:noteLinkObjs
+                      ++ pkg_link_opts
+                      ++ pkg_framework_opts
+                      ++ debug_opts
+                      ++ thread_opts
+                      ++ (if platformOS platform == OSDarwin
+                          then [ "-Wl,-dead_strip_dylibs" ]
+                          else [])
+                    ))
+
+exeFileName :: Bool -> DynFlags -> FilePath
+exeFileName staticLink dflags
+  | Just s <- outputFile dflags =
+      case platformOS (targetPlatform dflags) of
+          OSMinGW32 -> s <?.> "exe"
+          _         -> if staticLink
+                         then s <?.> "a"
+                         else s
+  | otherwise =
+      if platformOS (targetPlatform dflags) == OSMinGW32
+      then "main.exe"
+      else if staticLink
+           then "liba.a"
+           else "a.out"
+ where s <?.> ext | null (takeExtension s) = s <.> ext
+                  | otherwise              = s
+
+maybeCreateManifest
+   :: DynFlags
+   -> FilePath                          -- filename of executable
+   -> IO [FilePath]                     -- extra objects to embed, maybe
+maybeCreateManifest dflags exe_filename
+ | platformOS (targetPlatform dflags) == OSMinGW32 &&
+   gopt Opt_GenManifest dflags
+    = do let manifest_filename = exe_filename <.> "manifest"
+
+         writeFile manifest_filename $
+             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
+             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
+             "  <assemblyIdentity version=\"1.0.0.0\"\n"++
+             "     processorArchitecture=\"X86\"\n"++
+             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
+             "     type=\"win32\"/>\n\n"++
+             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
+             "    <security>\n"++
+             "      <requestedPrivileges>\n"++
+             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
+             "        </requestedPrivileges>\n"++
+             "       </security>\n"++
+             "  </trustInfo>\n"++
+             "</assembly>\n"
+
+         -- Windows will find the manifest file if it is named
+         -- foo.exe.manifest. However, for extra robustness, and so that
+         -- we can move the binary around, we can embed the manifest in
+         -- the binary itself using windres:
+         if not (gopt Opt_EmbedManifest dflags) then return [] else do
+
+         rc_filename <- newTempName dflags TFL_CurrentModule "rc"
+         rc_obj_filename <-
+           newTempName dflags TFL_GhcSession (objectSuf dflags)
+
+         writeFile rc_filename $
+             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
+               -- magic numbers :-)
+               -- show is a bit hackish above, but we need to escape the
+               -- backslashes in the path.
+
+         runWindres dflags $ map SysTools.Option $
+               ["--input="++rc_filename,
+                "--output="++rc_obj_filename,
+                "--output-format=coff"]
+               -- no FileOptions here: windres doesn't like seeing
+               -- backslashes, apparently
+
+         removeFile manifest_filename
+
+         return [rc_obj_filename]
+ | otherwise = return []
+
+
+linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkDynLibCheck dflags o_files dep_packages
+ = do
+    when (haveRtsOptsFlags dflags) $ do
+      putLogMsg dflags NoReason SevInfo noSrcSpan
+          (defaultUserStyle dflags)
+          (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
+           text "    Call hs_init_ghc() from your main() function to set these options.")
+
+    linkDynLib dflags o_files dep_packages
+
+-- | Linking a static lib will not really link anything. It will merely produce
+-- a static archive of all dependent static libraries. The resulting library
+-- will still need to be linked with any remaining link flags.
+linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkStaticLib dflags o_files dep_packages = do
+  let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+      modules = o_files ++ extra_ld_inputs
+      output_fn = exeFileName True dflags
+
+  full_output_fn <- if isAbsolute output_fn
+                    then return output_fn
+                    else do d <- getCurrentDirectory
+                            return $ normalise (d </> output_fn)
+  output_exists <- doesFileExist full_output_fn
+  (when output_exists) $ removeFile full_output_fn
+
+  pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
+  archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
+
+  ar <- foldl mappend
+        <$> (Archive <$> mapM loadObj modules)
+        <*> mapM loadAr archives
+
+  if sLdIsGnuLd (settings dflags)
+    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
+    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
+
+  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
+  runRanlib dflags [SysTools.FileOption "" output_fn]
+
+-- -----------------------------------------------------------------------------
+-- Running CPP
+
+doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
+doCpp dflags raw input_fn output_fn = do
+    let hscpp_opts = picPOpts dflags
+    let cmdline_include_paths = includePaths dflags
+
+    pkg_include_dirs <- getPackageIncludePath dflags []
+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+          (includePathsQuote cmdline_include_paths)
+    let include_paths = include_paths_quote ++ include_paths_global
+
+    let verbFlags = getVerbFlags dflags
+
+    let cpp_prog args | raw       = SysTools.runCpp dflags args
+                      | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args)
+
+    let target_defs =
+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",
+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",
+            "-D" ++ TARGET_OS   ++ "_HOST_OS",
+            "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]
+        -- remember, in code we *compile*, the HOST is the same our TARGET,
+        -- and BUILD is the same as our HOST.
+
+    let sse_defs =
+          [ "-D__SSE__"      | isSseEnabled      dflags ] ++
+          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++
+          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]
+
+    let avx_defs =
+          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++
+          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++
+          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
+          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
+          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++
+          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
+
+    backend_defs <- getBackendDefs dflags
+
+    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
+    -- Default CPP defines in Haskell source
+    ghcVersionH <- getGhcVersionPathName dflags
+    let hsSourceCppOpts = [ "-include", ghcVersionH ]
+
+    -- MIN_VERSION macros
+    let uids = explicitPackages (pkgState dflags)
+        pkgs = catMaybes (map (lookupPackage dflags) uids)
+    mb_macro_include <-
+        if not (null pkgs) && gopt Opt_VersionMacros dflags
+            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
+                    writeFile macro_stub (generatePackageVersionMacros pkgs)
+                    -- Include version macros for every *exposed* package.
+                    -- Without -hide-all-packages and with a package database
+                    -- size of 1000 packages, it takes cpp an estimated 2
+                    -- milliseconds to process this file. See #10970
+                    -- comment 8.
+                    return [SysTools.FileOption "-include" macro_stub]
+            else return []
+
+    cpp_prog       (   map SysTools.Option verbFlags
+                    ++ map SysTools.Option include_paths
+                    ++ map SysTools.Option hsSourceCppOpts
+                    ++ map SysTools.Option target_defs
+                    ++ map SysTools.Option backend_defs
+                    ++ map SysTools.Option th_defs
+                    ++ map SysTools.Option hscpp_opts
+                    ++ map SysTools.Option sse_defs
+                    ++ map SysTools.Option avx_defs
+                    ++ mb_macro_include
+        -- Set the language mode to assembler-with-cpp when preprocessing. This
+        -- alleviates some of the C99 macro rules relating to whitespace and the hash
+        -- operator, which we tend to abuse. Clang in particular is not very happy
+        -- about this.
+                    ++ [ SysTools.Option     "-x"
+                       , SysTools.Option     "assembler-with-cpp"
+                       , SysTools.Option     input_fn
+        -- We hackily use Option instead of FileOption here, so that the file
+        -- name is not back-slashed on Windows.  cpp is capable of
+        -- dealing with / in filenames, so it works fine.  Furthermore
+        -- if we put in backslashes, cpp outputs #line directives
+        -- with *double* backslashes.   And that in turn means that
+        -- our error messages get double backslashes in them.
+        -- In due course we should arrange that the lexer deals
+        -- with these \\ escapes properly.
+                       , SysTools.Option     "-o"
+                       , SysTools.FileOption "" output_fn
+                       ])
+
+getBackendDefs :: DynFlags -> IO [String]
+getBackendDefs dflags | hscTarget dflags == HscLlvm = do
+    llvmVer <- figureLlvmVersion dflags
+    return $ case llvmVer of
+               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
+               _      -> []
+  where
+    format (major, minor)
+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"
+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
+
+getBackendDefs _ =
+    return []
+
+-- ---------------------------------------------------------------------------
+-- Macros (cribbed from Cabal)
+
+generatePackageVersionMacros :: [PackageConfig] -> String
+generatePackageVersionMacros pkgs = concat
+  -- Do not add any C-style comments. See #3389.
+  [ generateMacros "" pkgname version
+  | pkg <- pkgs
+  , let version = packageVersion pkg
+        pkgname = map fixchar (packageNameString pkg)
+  ]
+
+fixchar :: Char -> Char
+fixchar '-' = '_'
+fixchar c   = c
+
+generateMacros :: String -> String -> Version -> String
+generateMacros prefix name version =
+  concat
+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
+  ,"  (major1) <  ",major1," || \\\n"
+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
+  ,"\n\n"
+  ]
+  where
+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
+
+-- ---------------------------------------------------------------------------
+-- join object files into a single relocatable object file, using ld -r
+
+{-
+Note [Produce big objects on Windows]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The Windows Portable Executable object format has a limit of 32k sections, which
+we tend to blow through pretty easily. Thankfully, there is a "big object"
+extension, which raises this limit to 2^32. However, it must be explicitly
+enabled in the toolchain:
+
+ * the assembler accepts the -mbig-obj flag, which causes it to produce a
+   bigobj-enabled COFF object.
+
+ * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
+   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
+   PE executable.
+
+We must enable bigobj output in a few places:
+
+ * When merging object files (DriverPipeline.joinObjectFiles)
+
+ * When assembling (DriverPipeline.runPhase (RealPhase As ...))
+
+Unfortunately the big object format is not supported on 32-bit targets so
+none of this can be used in that case.
+-}
+
+joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
+joinObjectFiles dflags o_files output_fn = do
+  let mySettings = settings dflags
+      ldIsGnuLd = sLdIsGnuLd mySettings
+      osInfo = platformOS (targetPlatform dflags)
+      ld_r args cc = SysTools.runLink dflags ([
+                       SysTools.Option "-nostdlib",
+                       SysTools.Option "-Wl,-r"
+                     ]
+                        -- See Note [No PIE while linking] in DynFlags
+                     ++ (if sGccSupportsNoPie mySettings
+                          then [SysTools.Option "-no-pie"]
+                          else [])
+
+                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
+                          then []
+                          else [SysTools.Option "-nodefaultlibs"])
+                     ++ (if osInfo == OSFreeBSD
+                          then [SysTools.Option "-L/usr/lib"]
+                          else [])
+                        -- gcc on sparc sets -Wl,--relax implicitly, but
+                        -- -r and --relax are incompatible for ld, so
+                        -- disable --relax explicitly.
+                     ++ (if platformArch (targetPlatform dflags)
+                                `elem` [ArchSPARC, ArchSPARC64]
+                         && ldIsGnuLd
+                            then [SysTools.Option "-Wl,-no-relax"]
+                            else [])
+                        -- See Note [Produce big objects on Windows]
+                     ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
+                        | OSMinGW32 == osInfo
+                        , not $ target32Bit (targetPlatform dflags)
+                        ]
+                     ++ map SysTools.Option ld_build_id
+                     ++ [ SysTools.Option "-o",
+                          SysTools.FileOption "" output_fn ]
+                     ++ args)
+
+      -- suppress the generation of the .note.gnu.build-id section,
+      -- which we don't need and sometimes causes ld to emit a
+      -- warning:
+      ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
+                  | otherwise                     = []
+
+  ccInfo <- getCompilerInfo dflags
+  if ldIsGnuLd
+     then do
+          script <- newTempName dflags TFL_CurrentModule "ldscript"
+          cwd <- getCurrentDirectory
+          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
+          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
+          ld_r [SysTools.FileOption "" script] ccInfo
+     else if sLdSupportsFilelist mySettings
+     then do
+          filelist <- newTempName dflags TFL_CurrentModule "filelist"
+          writeFile filelist $ unlines o_files
+          ld_r [SysTools.Option "-Wl,-filelist",
+                SysTools.FileOption "-Wl," filelist] ccInfo
+     else do
+          ld_r (map (SysTools.FileOption "") o_files) ccInfo
+
+-- -----------------------------------------------------------------------------
+-- Misc.
+
+writeInterfaceOnlyMode :: DynFlags -> Bool
+writeInterfaceOnlyMode dflags =
+ gopt Opt_WriteInterface dflags &&
+ HscNothing == hscTarget dflags
+
+-- | Figure out if a source file was modified after an output file (or if we
+-- anyways need to consider the source file modified since the output is gone).
+sourceModified :: FilePath -- ^ destination file we are looking for
+               -> UTCTime  -- ^ last time of modification of source file
+               -> IO Bool  -- ^ do we need to regenerate the output?
+sourceModified dest_file src_timestamp = do
+  dest_file_exists <- doesFileExist dest_file
+  if not dest_file_exists
+    then return True       -- Need to recompile
+     else do t2 <- getModificationUTCTime dest_file
+             return (t2 <= src_timestamp)
+
+-- | What phase to run after one of the backend code generators has run
+hscPostBackendPhase :: HscSource -> HscTarget -> Phase
+hscPostBackendPhase HsBootFile _    =  StopLn
+hscPostBackendPhase HsigFile _      =  StopLn
+hscPostBackendPhase _ hsc_lang =
+  case hsc_lang of
+        HscC           -> HCc
+        HscAsm         -> As False
+        HscLlvm        -> LlvmOpt
+        HscNothing     -> StopLn
+        HscInterpreted -> StopLn
+
+touchObjectFile :: DynFlags -> FilePath -> IO ()
+touchObjectFile dflags path = do
+  createDirectoryIfMissing True $ takeDirectory path
+  SysTools.touch dflags "Touching object file" path
+
+-- | Find out path to @ghcversion.h@ file
+getGhcVersionPathName :: DynFlags -> IO FilePath
+getGhcVersionPathName dflags = do
+  candidates <- case ghcVersionFile dflags of
+    Just path -> return [path]
+    Nothing -> (map (</> "ghcversion.h")) <$>
+               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
+
+  found <- filterM doesFileExist candidates
+  case found of
+      []    -> throwGhcExceptionIO (InstallationError
+                                    ("ghcversion.h missing; tried: "
+                                      ++ intercalate ", " candidates))
+      (x:_) -> return x
+
+-- Note [-fPIC for assembler]
+-- When compiling .c source file GHC's driver pipeline basically
+-- does the following two things:
+--   1. ${CC}              -S 'PIC_CFLAGS' source.c
+--   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
+--
+-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
+-- Because on some architectures (at least sparc32) assembler also chooses
+-- the relocation type!
+-- Consider the following C module:
+--
+--     /* pic-sample.c */
+--     int v;
+--     void set_v (int n) { v = n; }
+--     int  get_v (void)  { return v; }
+--
+--     $ gcc -S -fPIC pic-sample.c
+--     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary
+--     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary
+--
+--     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od
+--     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
+--     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
+--
+-- Most of architectures won't show any difference in this test, but on sparc32
+-- the following assembly snippet:
+--
+--    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
+--
+-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
+--
+--       3c:  2f 00 00 00     sethi  %hi(0), %l7
+--    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8
+--    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8
+
+{- Note [Don't normalise input filenames]
+
+Summary
+  We used to normalise input filenames when starting the unlit phase. This
+  broke hpc in `--make` mode with imported literate modules (#2991).
+
+Introduction
+  1) --main
+  When compiling a module with --main, GHC scans its imports to find out which
+  other modules it needs to compile too. It turns out that there is a small
+  difference between saying `ghc --make A.hs`, when `A` imports `B`, and
+  specifying both modules on the command line with `ghc --make A.hs B.hs`. In
+  the former case, the filename for B is inferred to be './B.hs' instead of
+  'B.hs'.
+
+  2) unlit
+  When GHC compiles a literate haskell file, the source code first needs to go
+  through unlit, which turns it into normal Haskell source code. At the start
+  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
+  option `-h` and the name of the original file. We used to normalise this
+  filename using System.FilePath.normalise, which among other things removes
+  an initial './'. unlit then uses that filename in #line directives that it
+  inserts in the transformed source code.
+
+  3) SrcSpan
+  A SrcSpan represents a portion of a source code file. It has fields
+  linenumber, start column, end column, and also a reference to the file it
+  originated from. The SrcSpans for a literate haskell file refer to the
+  filename that was passed to unlit -h.
+
+  4) -fhpc
+  At some point during compilation with -fhpc, in the function
+  `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a
+  `SrcSpan` refers to with the name of the file we are currently compiling.
+  For some reason I don't yet understand, they can sometimes legitimally be
+  different, and then hpc ignores that SrcSpan.
+
+Problem
+  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
+  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
+  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
+  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
+  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
+  doesn't include ticks for B, and we have unhappy customers (#2991).
+
+Solution
+  Do not normalise `input_fn` when starting the unlit phase.
+
+Alternative solution
+  Another option would be to not compare the two filenames on equality, but to
+  use System.FilePath.equalFilePath. That function first normalises its
+  arguments. The problem is that by the time we need to do the comparison, the
+  filenames have been turned into FastStrings, probably for performance
+  reasons, so System.FilePath.equalFilePath can not be used directly.
+
+Archeology
+  The call to `normalise` was added in a commit called "Fix slash
+  direction on Windows with the new filePath code" (c9b6b5e8). The problem
+  that commit was addressing has since been solved in a different manner, in a
+  commit called "Fix the filename passed to unlit" (1eedbc6b). So the
+  `normalise` is no longer necessary.
+-}
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/DynamicLoading.hs
@@ -0,0 +1,316 @@
+{-# LANGUAGE CPP, MagicHash #-}
+
+-- | Dynamically lookup up values from modules and loading them.
+module DynamicLoading (
+        initializePlugins,
+#if defined(GHCI)
+        -- * Loading plugins
+        loadFrontendPlugin,
+
+        -- * Force loading information
+        forceLoadModuleInterfaces,
+        forceLoadNameModuleInterface,
+        forceLoadTyCon,
+
+        -- * Finding names
+        lookupRdrNameInModuleForPlugins,
+
+        -- * Loading values
+        getValueSafely,
+        getHValueSafely,
+        lessUnsafeCoerce
+#else
+        pluginError
+#endif
+    ) where
+
+import GhcPrelude
+import DynFlags
+
+#if defined(GHCI)
+import Linker           ( linkModule, getHValue )
+import GHCi             ( wormhole )
+import SrcLoc           ( noSrcSpan )
+import Finder           ( findPluginModule, cannotFindModule )
+import TcRnMonad        ( initTcInteractive, initIfaceTcRn )
+import LoadIface        ( loadPluginInterface )
+import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)
+                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
+                        , gre_name, mkRdrQual )
+import OccName          ( OccName, mkVarOcc )
+import RnNames          ( gresFromAvails )
+import Plugins
+import PrelNames        ( pluginTyConName, frontendPluginTyConName )
+
+import HscTypes
+import GHCi.RemoteTypes ( HValue )
+import Type             ( Type, eqType, mkTyConTy, pprTyThingCategory )
+import TyCon            ( TyCon )
+import Name             ( Name, nameModule_maybe )
+import Id               ( idType )
+import Module           ( Module, ModuleName )
+import Panic
+import FastString
+import ErrUtils
+import Outputable
+import Exception
+import Hooks
+
+import Control.Monad     ( when, unless )
+import Data.Maybe        ( mapMaybe )
+import GHC.Exts          ( unsafeCoerce# )
+
+#else
+
+import HscTypes         ( HscEnv )
+import Module           ( ModuleName, moduleNameString )
+import Panic
+
+import Data.List        ( intercalate )
+import Control.Monad    ( unless )
+
+#endif
+
+-- | Loads the plugins specified in the pluginModNames field of the dynamic
+-- flags. Should be called after command line arguments are parsed, but before
+-- actual compilation starts. Idempotent operation. Should be re-called if
+-- pluginModNames or pluginModNameOpts changes.
+initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
+#if !defined(GHCI)
+initializePlugins _ df
+  = do let pluginMods = pluginModNames df
+       unless (null pluginMods) (pluginError pluginMods)
+       return df
+#else
+initializePlugins hsc_env df
+  | map lpModuleName (cachedPlugins df)
+         == pluginModNames df -- plugins not changed
+     && all (\p -> paArguments (lpPlugin p)
+                       == argumentsForPlugin p (pluginModNameOpts df))
+            (cachedPlugins df) -- arguments not changed
+  = return df -- no need to reload plugins
+  | otherwise
+  = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })
+       return $ df { cachedPlugins = loadedPlugins }
+  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
+#endif
+
+
+#if defined(GHCI)
+
+loadPlugins :: HscEnv -> IO [LoadedPlugin]
+loadPlugins hsc_env
+  = do { unless (null to_load) $
+           checkExternalInterpreter hsc_env
+       ; plugins <- mapM loadPlugin to_load
+       ; return $ zipWith attachOptions to_load plugins }
+  where
+    dflags  = hsc_dflags hsc_env
+    to_load = pluginModNames dflags
+
+    attachOptions mod_nm (plug, mod) =
+        LoadedPlugin (PluginWithArgs plug (reverse options)) mod
+      where
+        options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
+                            , opt_mod_nm == mod_nm ]
+    loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env
+
+
+loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
+loadFrontendPlugin hsc_env mod_name = do
+    checkExternalInterpreter hsc_env
+    fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
+                hsc_env mod_name
+
+-- #14335
+checkExternalInterpreter :: HscEnv -> IO ()
+checkExternalInterpreter hsc_env =
+    when (gopt Opt_ExternalInterpreter dflags) $
+      throwCmdLineError $ showSDoc dflags $
+        text "Plugins require -fno-external-interpreter"
+  where
+    dflags = hsc_dflags hsc_env
+
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
+loadPlugin' occ_name plugin_name hsc_env mod_name
+  = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
+             dflags = hsc_dflags hsc_env
+       ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
+                        plugin_rdr_name
+       ; case mb_name of {
+            Nothing ->
+                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
+                          [ text "The module", ppr mod_name
+                          , text "did not export the plugin name"
+                          , ppr plugin_rdr_name ]) ;
+            Just (name, mod_iface) ->
+
+     do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
+        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
+        ; case mb_plugin of
+            Nothing ->
+                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
+                          [ text "The value", ppr name
+                          , text "did not have the type"
+                          , ppr pluginTyConName, text "as required"])
+            Just plugin -> return (plugin, mod_iface) } } }
+
+
+-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
+forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
+forceLoadModuleInterfaces hsc_env doc modules
+    = (initTcInteractive hsc_env $
+       initIfaceTcRn $
+       mapM_ (loadPluginInterface doc) modules)
+      >> return ()
+
+-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
+forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
+forceLoadNameModuleInterface hsc_env reason name = do
+    let name_modules = mapMaybe nameModule_maybe [name]
+    forceLoadModuleInterfaces hsc_env reason name_modules
+
+-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
+--
+-- * The interface could not be loaded
+-- * The name is not that of a 'TyCon'
+-- * The name did not exist in the loaded module
+forceLoadTyCon :: HscEnv -> Name -> IO TyCon
+forceLoadTyCon hsc_env con_name = do
+    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
+
+    mb_con_thing <- lookupTypeHscEnv hsc_env con_name
+    case mb_con_thing of
+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
+        Just (ATyCon tycon) -> return tycon
+        Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
+  where dflags = hsc_dflags hsc_env
+
+-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
+-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
+--
+-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
+--
+-- * If we could not load the names module
+-- * If the thing being loaded is not a value
+-- * If the Name does not exist in the module
+-- * If the link failed
+
+getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
+getValueSafely hsc_env val_name expected_type = do
+  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
+  case mb_hval of
+    Nothing   -> return Nothing
+    Just hval -> do
+      value <- lessUnsafeCoerce dflags "getValueSafely" hval
+      return (Just value)
+  where
+    dflags = hsc_dflags hsc_env
+
+getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
+getHValueSafely hsc_env val_name expected_type = do
+    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
+    -- Now look up the names for the value and type constructor in the type environment
+    mb_val_thing <- lookupTypeHscEnv hsc_env val_name
+    case mb_val_thing of
+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
+        Just (AnId id) -> do
+            -- Check the value type in the interface against the type recovered from the type constructor
+            -- before finally casting the value to the type we assume corresponds to that constructor
+            if expected_type `eqType` idType id
+             then do
+                -- Link in the module that contains the value, if it has such a module
+                case nameModule_maybe val_name of
+                    Just mod -> do linkModule hsc_env mod
+                                   return ()
+                    Nothing ->  return ()
+                -- Find the value that we just linked in and cast it given that we have proved it's type
+                hval <- getHValue hsc_env val_name >>= wormhole dflags
+                return (Just hval)
+             else return Nothing
+        Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
+   where dflags = hsc_dflags hsc_env
+
+-- | Coerce a value as usual, but:
+--
+-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
+--
+-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
+--    if it /does/ segfault
+lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
+lessUnsafeCoerce dflags context what = do
+    debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>
+                             (text "...")
+    output <- evaluate (unsafeCoerce# what)
+    debugTraceMsg dflags 3 (text "Successfully evaluated coercion")
+    return output
+
+
+-- | Finds the 'Name' corresponding to the given 'RdrName' in the
+-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
+-- could be found. Any other condition results in an exception:
+--
+-- * If the module could not be found
+-- * If we could not determine the imports of the module
+--
+-- Can only be used for looking up names while loading plugins (and is
+-- *not* suitable for use within plugins).  The interface file is
+-- loaded very partially: just enough that it can be used, without its
+-- rules and instances affecting (and being linked from!) the module
+-- being compiled.  This was introduced by 57d6798.
+--
+-- Need the module as well to record information in the interface file
+lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
+                                -> IO (Maybe (Name, ModIface))
+lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
+    -- First find the package the module resides in by searching exposed packages and home modules
+    found_module <- findPluginModule hsc_env mod_name
+    case found_module of
+        Found _ mod -> do
+            -- Find the exports of the module
+            (_, mb_iface) <- initTcInteractive hsc_env $
+                             initIfaceTcRn $
+                             loadPluginInterface doc mod
+            case mb_iface of
+                Just iface -> do
+                    -- Try and find the required name in the exports
+                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
+                                                , is_qual = False, is_dloc = noSrcSpan }
+                        imp_spec = ImpSpec decl_spec ImpAll
+                        env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
+                    case lookupGRE_RdrName rdr_name env of
+                        [gre] -> return (Just (gre_name gre, iface))
+                        []    -> return Nothing
+                        _     -> panic "lookupRdrNameInModule"
+
+                Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
+        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+  where
+    dflags = hsc_dflags hsc_env
+    doc = text "contains a name used in an invocation of lookupRdrNameInModule"
+
+wrongTyThingError :: Name -> TyThing -> SDoc
+wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
+
+missingTyThingError :: Name -> SDoc
+missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
+
+throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
+throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
+
+throwCmdLineError :: String -> IO a
+throwCmdLineError = throwGhcExceptionIO . CmdLineError
+
+#else
+
+pluginError :: [ModuleName] -> a
+pluginError modnames = throwGhcException (CmdLineError msg)
+  where
+    msg = "not built for interactive use - can't load plugins ("
+            -- module names are not z-encoded
+          ++ intercalate ", " (map moduleNameString modnames)
+          ++ ")"
+
+#endif
diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/Elf.hs
@@ -0,0 +1,467 @@
+{-
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2015
+--
+-- ELF format tools
+--
+-----------------------------------------------------------------------------
+-}
+
+module Elf (
+    readElfSectionByName,
+    readElfNoteAsString,
+    makeElfNote
+  ) where
+
+import GhcPrelude
+
+import AsmUtils
+import Exception
+import DynFlags
+import ErrUtils
+import Maybes     (MaybeT(..),runMaybeT)
+import Util       (charToC)
+import Outputable (text,hcat,SDoc)
+
+import Control.Monad (when)
+import Data.Binary.Get
+import Data.Word
+import Data.Char (ord)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as B8
+
+{- Note [ELF specification]
+   ~~~~~~~~~~~~~~~~~~~~~~~~
+
+   ELF (Executable and Linking Format) is described in the System V Application
+   Binary Interface (or ABI). The latter is composed of two parts: a generic
+   part and a processor specific part. The generic ABI describes the parts of
+   the interface that remain constant across all hardware implementations of
+   System V.
+
+   The latest release of the specification of the generic ABI is the version
+   4.1 from March 18, 1997:
+
+     - http://www.sco.com/developers/devspecs/gabi41.pdf
+
+   Since 1997, snapshots of the draft for the "next" version are published:
+
+     - http://www.sco.com/developers/gabi/
+
+   Quoting the notice on the website: "There is more than one instance of these
+   chapters to permit references to older instances to remain valid. All
+   modifications to these chapters are forward-compatible, so that correct use
+   of an older specification will not be invalidated by a newer instance.
+   Approximately on a yearly basis, a new instance will be saved, as it reaches
+   what appears to be a stable state."
+
+   Nevertheless we will see that since 1998 it is not true for Note sections.
+
+   Many ELF sections
+   -----------------
+
+   ELF-4.1: the normal section number fields in ELF are limited to 16 bits,
+   which runs out of bits when you try to cram in more sections than that. Two
+   fields are concerned: the one containing the number of the sections and the
+   one containing the index of the section that contains section's names. (The
+   same thing applies to the field containing the number of segments, but we
+   don't care about it here).
+
+   ELF-next: to solve this, theses fields in the ELF header have an escape
+   value (different for each case), and the actual section number is stashed
+   into unused fields in the first section header.
+
+   We support this extension as it is forward-compatible with ELF-4.1.
+   Moreover, GHC may generate objects with a lot of sections with the
+   "function-sections" feature (one section per function).
+
+   Note sections
+   -------------
+
+   Sections with type "note" (SHT_NOTE in the specification) are used to add
+   arbitrary data into an ELF file. An entry in a note section is composed of a
+   name, a type and a value.
+
+   ELF-4.1: "The note information in sections and program header elements holds
+   any number of entries, each of which is an array of 4-byte words in the
+   format of the target processor." Each entry has the following format:
+         | namesz |   Word32: size of the name string (including the ending \0)
+         | descsz |   Word32: size of the value
+         |  type  |   Word32: type of the note
+         |  name  |   Name string (with \0 padding to ensure 4-byte alignment)
+         |  ...   |
+         |  desc  |   Value (with \0 padding to ensure 4-byte alignment)
+         |  ...   |
+
+   ELF-next: "The note information in sections and program header elements
+   holds a variable amount of entries. In 64-bit objects (files with
+   e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte
+   words in the format of the target processor. In 32-bit objects (files with
+   e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte
+   words in the format of the target processor." (from 1998-2015 snapshots)
+
+   This is not forward-compatible with ELF-4.1. In practice, for almost all
+   platforms namesz, descz and type fields are 4-byte words for both 32-bit and
+   64-bit objects (see elf.h and readelf source code).
+
+   The only exception in readelf source code is for IA_64 machines with OpenVMS
+   OS: "This OS has so many departures from the ELF standard that we test it at
+   many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz,
+   descsz and type fields are 8-byte words and name and value fields are padded
+   to ensure 8-byte alignment.
+
+   We don't support this platform in the following code. Reading a note section
+   could be done easily (by testing Machine and OS fields in the ELF header).
+   Writing a note section, however, requires that we generate a different
+   assembly code for GAS depending on the target platform and this is a little
+   bit more involved.
+
+-}
+
+
+-- | ELF header
+--
+-- The ELF header indicates the native word size (32-bit or 64-bit) and the
+-- endianness of the target machine. We directly store getters for words of
+-- different sizes as it is more convenient to use. We also store the word size
+-- as it is useful to skip some uninteresting fields.
+--
+-- Other information such as the target machine and OS are left out as we don't
+-- use them yet. We could add them in the future if we ever need them.
+data ElfHeader = ElfHeader
+   { gw16     :: Get Word16   -- ^ Get a Word16 with the correct endianness
+   , gw32     :: Get Word32   -- ^ Get a Word32 with the correct endianness
+   , gwN      :: Get Word64   -- ^ Get a Word with the correct word size
+                              --   and endianness
+   , wordSize :: Int          -- ^ Word size in bytes
+   }
+
+
+-- | Read the ELF header
+readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader)
+readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF header")
+    return Nothing
+  where
+    getHeader = do
+      magic    <- getWord32be
+      ws       <- getWord8
+      endian   <- getWord8
+      version  <- getWord8
+      skip 9  -- skip OSABI, ABI version and padding
+      when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header"
+
+      case (ws, endian) of
+          -- ELF 32, little endian
+          (1,1) -> return . Just $ ElfHeader
+                           getWord16le
+                           getWord32le
+                           (fmap fromIntegral getWord32le) 4
+          -- ELF 32, big endian
+          (1,2) -> return . Just $ ElfHeader
+                           getWord16be
+                           getWord32be
+                           (fmap fromIntegral getWord32be) 4
+          -- ELF 64, little endian
+          (2,1) -> return . Just $ ElfHeader
+                           getWord16le
+                           getWord32le
+                           (fmap fromIntegral getWord64le) 8
+          -- ELF 64, big endian
+          (2,2) -> return . Just $ ElfHeader
+                           getWord16be
+                           getWord32be
+                           (fmap fromIntegral getWord64be) 8
+          _     -> fail "Invalid ELF header"
+
+
+------------------
+-- SECTIONS
+------------------
+
+
+-- | Description of the section table
+data SectionTable = SectionTable
+  { sectionTableOffset :: Word64  -- ^ offset of the table describing sections
+  , sectionEntrySize   :: Word16  -- ^ size of an entry in the section table
+  , sectionEntryCount  :: Word64  -- ^ number of sections
+  , sectionNameIndex   :: Word32  -- ^ index of a special section which
+                                  --   contains section's names
+  }
+
+-- | Read the ELF section table
+readElfSectionTable :: DynFlags
+                    -> ElfHeader
+                    -> ByteString
+                    -> IO (Maybe SectionTable)
+
+readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF section table")
+    return Nothing
+  where
+    getSectionTable :: Get SectionTable
+    getSectionTable = do
+      skip (24 + 2*wordSize hdr) -- skip header and some other fields
+      secTableOffset <- gwN hdr
+      skip 10
+      entrySize      <- gw16 hdr
+      entryCount     <- gw16 hdr
+      secNameIndex   <- gw16 hdr
+      return (SectionTable secTableOffset entrySize
+                           (fromIntegral entryCount)
+                           (fromIntegral secNameIndex))
+
+    action = do
+      secTable <- runGetOrThrow getSectionTable bs
+      -- In some cases, the number of entries and the index of the section
+      -- containing section's names must be found in unused fields of the first
+      -- section entry (see Note [ELF specification])
+      let
+        offSize0 = fromIntegral $ sectionTableOffset secTable + 8
+                                  + 3 * fromIntegral (wordSize hdr)
+        offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr)
+
+      entryCount'     <- if sectionEntryCount secTable /= 0
+                          then return (sectionEntryCount secTable)
+                          else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs)
+      entryNameIndex' <- if sectionNameIndex secTable /= 0xffff
+                          then return (sectionNameIndex secTable)
+                          else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs)
+      return (Just $ secTable
+        { sectionEntryCount = entryCount'
+        , sectionNameIndex  = entryNameIndex'
+        })
+
+
+-- | A section
+data Section = Section
+  { entryName :: ByteString   -- ^ Name of the section
+  , entryBS   :: ByteString   -- ^ Content of the section
+  }
+
+-- | Read a ELF section
+readElfSectionByIndex :: DynFlags
+                      -> ElfHeader
+                      -> SectionTable
+                      -> Word64
+                      -> ByteString
+                      -> IO (Maybe Section)
+
+readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF section")
+    return Nothing
+  where
+    -- read an entry from the section table
+    getEntry = do
+      nameIndex <- gw32 hdr
+      skip (4+2*wordSize hdr)
+      offset    <- fmap fromIntegral $ gwN hdr
+      size      <- fmap fromIntegral $ gwN hdr
+      let bs' = LBS.take size (LBS.drop offset bs)
+      return (nameIndex,bs')
+
+    -- read the entry with the given index in the section table
+    getEntryByIndex x = runGetOrThrow getEntry bs'
+      where
+        bs' = LBS.drop off bs
+        off = fromIntegral $ sectionTableOffset secTable +
+                             x * fromIntegral (sectionEntrySize secTable)
+
+    -- Get the name of a section
+    getEntryName nameIndex = do
+      let idx = fromIntegral (sectionNameIndex secTable)
+      (_,nameTable) <- getEntryByIndex idx
+      let bs' = LBS.drop nameIndex nameTable
+      runGetOrThrow getLazyByteStringNul bs'
+
+    action = do
+      (nameIndex,bs') <- getEntryByIndex (fromIntegral i)
+      name            <- getEntryName (fromIntegral nameIndex)
+      return (Just $ Section name bs')
+
+
+-- | Find a section from its name. Return the section contents.
+--
+-- We do not perform any check on the section type.
+findSectionFromName :: DynFlags
+                    -> ElfHeader
+                    -> SectionTable
+                    -> String
+                    -> ByteString
+                    -> IO (Maybe ByteString)
+findSectionFromName dflags hdr secTable name bs =
+    rec [0..sectionEntryCount secTable - 1]
+  where
+    -- convert the required section name into a ByteString to perform
+    -- ByteString comparison instead of String comparison
+    name' = B8.pack name
+
+    -- compare recursively each section name and return the contents of
+    -- the matching one, if any
+    rec []     = return Nothing
+    rec (x:xs) = do
+      me <- readElfSectionByIndex dflags hdr secTable x bs
+      case me of
+        Just e | entryName e == name' -> return (Just (entryBS e))
+        _                             -> rec xs
+
+
+-- | Given a section name, read its contents as a ByteString.
+--
+-- If the section isn't found or if there is any parsing error, we return
+-- Nothing
+readElfSectionByName :: DynFlags
+                     -> ByteString
+                     -> String
+                     -> IO (Maybe LBS.ByteString)
+
+readElfSectionByName dflags bs name = action `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF section \"" ++ name ++ "\"")
+    return Nothing
+  where
+    action = runMaybeT $ do
+      hdr      <- MaybeT $ readElfHeader dflags bs
+      secTable <- MaybeT $ readElfSectionTable dflags hdr bs
+      MaybeT $ findSectionFromName dflags hdr secTable name bs
+
+------------------
+-- NOTE SECTIONS
+------------------
+
+-- | read a Note as a ByteString
+--
+-- If you try to read a note from a section which does not support the Note
+-- format, the parsing is likely to fail and Nothing will be returned
+readElfNoteBS :: DynFlags
+              -> ByteString
+              -> String
+              -> String
+              -> IO (Maybe LBS.ByteString)
+
+readElfNoteBS dflags bs sectionName noteId = action `catchIO`  \_ -> do
+    debugTraceMsg dflags 3 $
+         text ("Unable to read ELF note \"" ++ noteId ++
+               "\" in section \"" ++ sectionName ++ "\"")
+    return Nothing
+  where
+    -- align the getter on n bytes
+    align n = do
+      m <- bytesRead
+      if m `mod` n == 0
+        then return ()
+        else skip 1 >> align n
+
+    -- noteId as a bytestring
+    noteId' = B8.pack noteId
+
+    -- read notes recursively until the one with a valid identifier is found
+    findNote hdr = do
+      align 4
+      namesz <- gw32 hdr
+      descsz <- gw32 hdr
+      _      <- gw32 hdr -- we don't use the note type
+      name   <- if namesz == 0
+                  then return LBS.empty
+                  else getLazyByteStringNul
+      align 4
+      desc  <- if descsz == 0
+                  then return LBS.empty
+                  else getLazyByteString (fromIntegral descsz)
+      if name == noteId'
+        then return $ Just desc
+        else findNote hdr
+
+
+    action = runMaybeT $ do
+      hdr  <- MaybeT $ readElfHeader dflags bs
+      sec  <- MaybeT $ readElfSectionByName dflags bs sectionName
+      MaybeT $ runGetOrThrow (findNote hdr) sec
+
+-- | read a Note as a String
+--
+-- If you try to read a note from a section which does not support the Note
+-- format, the parsing is likely to fail and Nothing will be returned
+readElfNoteAsString :: DynFlags
+                    -> FilePath
+                    -> String
+                    -> String
+                    -> IO (Maybe String)
+
+readElfNoteAsString dflags path sectionName noteId = action `catchIO`  \_ -> do
+    debugTraceMsg dflags 3 $
+         text ("Unable to read ELF note \"" ++ noteId ++
+               "\" in section \"" ++ sectionName ++ "\"")
+    return Nothing
+  where
+    action = do
+      bs   <- LBS.readFile path
+      note <- readElfNoteBS dflags bs sectionName noteId
+      return (fmap B8.unpack note)
+
+
+-- | Generate the GAS code to create a Note section
+--
+-- Header fields for notes are 32-bit long (see Note [ELF specification]).
+--
+-- It seems there is no easy way to force GNU AS to generate a 32-bit word in
+-- every case. Hence we use .int directive to create them: however "The byte
+-- order and bit size of the number depends on what kind of target the assembly
+-- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)
+--
+-- If we add new target platforms, we need to check that the generated words
+-- are 32-bit long, otherwise we need to use platform specific directives to
+-- force 32-bit .int in asWord32.
+makeElfNote :: String -> String -> Word32 -> String -> SDoc
+makeElfNote sectionName noteName typ contents = hcat [
+    text "\t.section ",
+    text sectionName,
+    text ",\"\",",
+    sectionType "note",
+    text "\n",
+
+    -- note name length (+ 1 for ending \0)
+    asWord32 (length noteName + 1),
+
+    -- note contents size
+    asWord32 (length contents),
+
+    -- note type
+    asWord32 typ,
+
+    -- note name (.asciz for \0 ending string) + padding
+    text "\t.asciz \"",
+    text noteName,
+    text "\"\n",
+    text "\t.align 4\n",
+
+    -- note contents (.ascii to avoid ending \0) + padding
+    text "\t.ascii \"",
+    text (escape contents),
+    text "\"\n",
+    text "\t.align 4\n"]
+  where
+    escape :: String -> String
+    escape = concatMap (charToC.fromIntegral.ord)
+
+    asWord32 :: Show a => a -> SDoc
+    asWord32 x = hcat [
+      text "\t.int ",
+      text (show x),
+      text "\n"]
+
+
+------------------
+-- Helpers
+------------------
+
+-- | runGet in IO monad that throws an IOException on failure
+runGetOrThrow :: Get a -> LBS.ByteString -> IO a
+runGetOrThrow g bs = case runGetOrFail g bs of
+  Left _        -> fail "Error while reading file"
+  Right (_,_,a) -> return a
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/Finder.hs
@@ -0,0 +1,844 @@
+{-
+(c) The University of Glasgow, 2000-2006
+
+\section[Finder]{Module Finder}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module Finder (
+    flushFinderCaches,
+    FindResult(..),
+    findImportedModule,
+    findPluginModule,
+    findExactModule,
+    findHomeModule,
+    findExposedPackageModule,
+    mkHomeModLocation,
+    mkHomeModLocation2,
+    mkHiOnlyModLocation,
+    mkHiPath,
+    mkObjPath,
+    addHomeModuleToFinder,
+    uncacheModule,
+    mkStubPaths,
+
+    findObjectLinkableMaybe,
+    findObjectLinkable,
+
+    cannotFindModule,
+    cannotFindInterface,
+
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Module
+import HscTypes
+import Packages
+import FastString
+import Util
+import PrelNames        ( gHC_PRIM )
+import DynFlags
+import Outputable
+import Maybes           ( expectJust )
+
+import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )
+import System.Directory
+import System.FilePath
+import Control.Monad
+import Data.Time
+
+
+type FileExt = String   -- Filename extension
+type BaseName = String  -- Basename of file
+
+-- -----------------------------------------------------------------------------
+-- The Finder
+
+-- The Finder provides a thin filesystem abstraction to the rest of
+-- the compiler.  For a given module, it can tell you where the
+-- source, interface, and object files for that module live.
+
+-- It does *not* know which particular package a module lives in.  Use
+-- Packages.lookupModuleInAllPackages for that.
+
+-- -----------------------------------------------------------------------------
+-- The finder's cache
+
+-- remove all the home modules from the cache; package modules are
+-- assumed to not move around during a session.
+flushFinderCaches :: HscEnv -> IO ()
+flushFinderCaches hsc_env =
+  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+ where
+        this_pkg = thisPackage (hsc_dflags hsc_env)
+        fc_ref = hsc_FC hsc_env
+        is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True
+                     | otherwise = False
+
+addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
+addToFinderCache ref key val =
+  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
+
+removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()
+removeFromFinderCache ref key =
+  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
+
+lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
+lookupFinderCache ref key = do
+   c <- readIORef ref
+   return $! lookupInstalledModuleEnv c key
+
+-- -----------------------------------------------------------------------------
+-- The three external entry points
+
+-- | Locate a module that was imported by the user.  We have the
+-- module's name, and possibly a package name.  Without a package
+-- name, this function will use the search path and the known exposed
+-- packages to find the module, if a package is specified then only
+-- that package is searched for the module.
+
+findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
+findImportedModule hsc_env mod_name mb_pkg =
+  case mb_pkg of
+        Nothing                        -> unqual_import
+        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
+                 | otherwise           -> pkg_import
+  where
+    home_import   = findHomeModule hsc_env mod_name
+
+    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg
+
+    unqual_import = home_import
+                    `orIfNotFound`
+                    findExposedPackageModule hsc_env mod_name Nothing
+
+-- | Locate a plugin module requested by the user, for a compiler
+-- plugin.  This consults the same set of exposed packages as
+-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
+-- @-plugin-package@ are specified.
+findPluginModule :: HscEnv -> ModuleName -> IO FindResult
+findPluginModule hsc_env mod_name =
+  findHomeModule hsc_env mod_name
+  `orIfNotFound`
+  findExposedPluginPackageModule hsc_env mod_name
+
+-- | Locate a specific 'Module'.  The purpose of this function is to
+-- create a 'ModLocation' for a given 'Module', that is to find out
+-- where the files associated with this module live.  It is used when
+-- reading the interface for a module mentioned by another interface,
+-- for example (a "system import").
+
+findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
+findExactModule hsc_env mod =
+    let dflags = hsc_dflags hsc_env
+    in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags
+       then findInstalledHomeModule hsc_env (installedModuleName mod)
+       else findPackageModule hsc_env mod
+
+-- -----------------------------------------------------------------------------
+-- Helpers
+
+-- | Given a monadic actions @this@ and @or_this@, first execute
+-- @this@.  If the returned 'FindResult' is successful, return
+-- it; otherwise, execute @or_this@.  If both failed, this function
+-- also combines their failure messages in a reasonable way.
+orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult
+orIfNotFound this or_this = do
+  res <- this
+  case res of
+    NotFound { fr_paths = paths1, fr_mods_hidden = mh1
+             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }
+     -> do res2 <- or_this
+           case res2 of
+             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2
+                      , fr_pkgs_hidden = ph2, fr_unusables = u2
+                      , fr_suggestions = s2 }
+              -> return (NotFound { fr_paths = paths1 ++ paths2
+                                  , fr_pkg = mb_pkg2 -- snd arg is the package search
+                                  , fr_mods_hidden = mh1 ++ mh2
+                                  , fr_pkgs_hidden = ph1 ++ ph2
+                                  , fr_unusables = u1 ++ u2
+                                  , fr_suggestions = s1  ++ s2 })
+             _other -> return res2
+    _other -> return res
+
+-- | Helper function for 'findHomeModule': this function wraps an IO action
+-- which would look up @mod_name@ in the file system (the home package),
+-- and first consults the 'hsc_FC' cache to see if the lookup has already
+-- been done.  Otherwise, do the lookup (with the IO action) and save
+-- the result in the finder cache and the module location cache (if it
+-- was successful.)
+homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
+homeSearchCache hsc_env mod_name do_this = do
+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+  modLocationCache hsc_env mod do_this
+
+findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
+                         -> IO FindResult
+findExposedPackageModule hsc_env mod_name mb_pkg
+  = findLookupResult hsc_env
+  $ lookupModuleWithSuggestions
+        (hsc_dflags hsc_env) mod_name mb_pkg
+
+findExposedPluginPackageModule :: HscEnv -> ModuleName
+                               -> IO FindResult
+findExposedPluginPackageModule hsc_env mod_name
+  = findLookupResult hsc_env
+  $ lookupPluginModuleWithSuggestions
+        (hsc_dflags hsc_env) mod_name Nothing
+
+findLookupResult :: HscEnv -> LookupResult -> IO FindResult
+findLookupResult hsc_env r = case r of
+     LookupFound m pkg_conf -> do
+       let im = fst (splitModuleInsts m)
+       r' <- findPackageModule_ hsc_env im pkg_conf
+       case r' of
+        -- TODO: ghc -M is unlikely to do the right thing
+        -- with just the location of the thing that was
+        -- instantiated; you probably also need all of the
+        -- implicit locations from the instances
+        InstalledFound loc   _ -> return (Found loc m)
+        InstalledNoPackage   _ -> return (NoPackage (moduleUnitId m))
+        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)
+                                         , fr_pkgs_hidden = []
+                                         , fr_mods_hidden = []
+                                         , fr_unusables = []
+                                         , fr_suggestions = []})
+     LookupMultiple rs ->
+       return (FoundMultiple rs)
+     LookupHidden pkg_hiddens mod_hiddens ->
+       return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                       , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens
+                       , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens
+                       , fr_unusables = []
+                       , fr_suggestions = [] })
+     LookupUnusable unusable ->
+       let unusables' = map get_unusable unusable
+           get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
+           get_unusable (_, r)             =
+             pprPanic "findLookupResult: unexpected origin" (ppr r)
+       in return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                          , fr_pkgs_hidden = []
+                          , fr_mods_hidden = []
+                          , fr_unusables = unusables'
+                          , fr_suggestions = [] })
+     LookupNotFound suggest ->
+       return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                       , fr_pkgs_hidden = []
+                       , fr_mods_hidden = []
+                       , fr_unusables = []
+                       , fr_suggestions = suggest })
+
+modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache hsc_env mod do_this = do
+  m <- lookupFinderCache (hsc_FC hsc_env) mod
+  case m of
+    Just result -> return result
+    Nothing     -> do
+        result <- do_this
+        addToFinderCache (hsc_FC hsc_env) mod result
+        return result
+
+mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
+mkHomeInstalledModule dflags mod_name =
+  let iuid = fst (splitUnitIdInsts (thisPackage dflags))
+  in InstalledModule iuid mod_name
+
+-- This returns a module because it's more convenient for users
+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
+addHomeModuleToFinder hsc_env mod_name loc = do
+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
+  return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)
+
+uncacheModule :: HscEnv -> ModuleName -> IO ()
+uncacheModule hsc_env mod_name = do
+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+  removeFromFinderCache (hsc_FC hsc_env) mod
+
+-- -----------------------------------------------------------------------------
+--      The internal workers
+
+findHomeModule :: HscEnv -> ModuleName -> IO FindResult
+findHomeModule hsc_env mod_name = do
+  r <- findInstalledHomeModule hsc_env mod_name
+  return $ case r of
+    InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+    InstalledNoPackage _ -> NoPackage uid -- impossible
+    InstalledNotFound fps _ -> NotFound {
+        fr_paths = fps,
+        fr_pkg = Just uid,
+        fr_mods_hidden = [],
+        fr_pkgs_hidden = [],
+        fr_unusables = [],
+        fr_suggestions = []
+      }
+ where
+  dflags = hsc_dflags hsc_env
+  uid = thisPackage dflags
+
+-- | Implements the search for a module name in the home package only.  Calling
+-- this function directly is usually *not* what you want; currently, it's used
+-- as a building block for the following operations:
+--
+--  1. When you do a normal package lookup, we first check if the module
+--  is available in the home module, before looking it up in the package
+--  database.
+--
+--  2. When you have a package qualified import with package name "this",
+--  we shortcut to the home module.
+--
+--  3. When we look up an exact 'Module', if the unit id associated with
+--  the module is the current home module do a look up in the home module.
+--
+--  4. Some special-case code in GHCi (ToDo: Figure out why that needs to
+--  call this.)
+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult
+findInstalledHomeModule hsc_env mod_name =
+   homeSearchCache hsc_env mod_name $
+   let
+     dflags = hsc_dflags hsc_env
+     home_path = importPaths dflags
+     hisuf = hiSuf dflags
+     mod = mkHomeInstalledModule dflags mod_name
+
+     source_exts =
+      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")
+      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")
+      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")
+      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")
+      ]
+
+     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
+     -- when hiDir field is set in dflags, we know to look there (see #16500)
+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)
+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)
+               ]
+
+        -- In compilation manager modes, we look for source files in the home
+        -- package because we can compile these automatically.  In one-shot
+        -- compilation mode we look for .hi and .hi-boot files only.
+     exts | isOneShot (ghcMode dflags) = hi_exts
+          | otherwise                  = source_exts
+   in
+
+  -- special case for GHC.Prim; we won't find it in the filesystem.
+  -- This is important only when compiling the base package (where GHC.Prim
+  -- is a home module).
+  if mod `installedModuleEq` gHC_PRIM
+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+        else searchPathExts home_path mod exts
+
+
+-- | Search for a module in external packages only.
+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
+findPackageModule hsc_env mod = do
+  let
+        dflags = hsc_dflags hsc_env
+        pkg_id = installedModuleUnitId mod
+  --
+  case lookupInstalledPackage dflags pkg_id of
+     Nothing -> return (InstalledNoPackage pkg_id)
+     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
+
+-- | Look up the interface file associated with module @mod@.  This function
+-- requires a few invariants to be upheld: (1) the 'Module' in question must
+-- be the module identifier of the *original* implementation of a module,
+-- not a reexport (this invariant is upheld by @Packages.hs@) and (2)
+-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.
+-- The redundancy is to avoid an extra lookup in the package state
+-- for the appropriate config.
+findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
+findPackageModule_ hsc_env mod pkg_conf =
+  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
+  modLocationCache hsc_env mod $
+
+  -- special case for GHC.Prim; we won't find it in the filesystem.
+  if mod `installedModuleEq` gHC_PRIM
+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+        else
+
+  let
+     dflags = hsc_dflags hsc_env
+     tag = buildTag dflags
+
+           -- hi-suffix for packages depends on the build tag.
+     package_hisuf | null tag  = "hi"
+                   | otherwise = tag ++ "_hi"
+
+     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf
+
+     import_dirs = importDirs pkg_conf
+      -- we never look for a .hi-boot file in an external package;
+      -- .hi-boot files only make sense for the home package.
+  in
+  case import_dirs of
+    [one] | MkDepend <- ghcMode dflags -> do
+          -- there's only one place that this .hi file can be, so
+          -- don't bother looking for it.
+          let basename = moduleNameSlashes (installedModuleName mod)
+          loc <- mk_hi_loc one basename
+          return (InstalledFound loc mod)
+    _otherwise ->
+          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
+
+-- -----------------------------------------------------------------------------
+-- General path searching
+
+searchPathExts
+  :: [FilePath]         -- paths to search
+  -> InstalledModule             -- module name
+  -> [ (
+        FileExt,                                -- suffix
+        FilePath -> BaseName -> IO ModLocation  -- action
+       )
+     ]
+  -> IO InstalledFindResult
+
+searchPathExts paths mod exts
+   = do result <- search to_search
+{-
+        hPutStrLn stderr (showSDoc $
+                vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)
+                    , nest 2 (vcat (map text paths))
+                    , case result of
+                        Succeeded (loc, p) -> text "Found" <+> ppr loc
+                        Failed fs          -> text "not found"])
+-}
+        return result
+
+  where
+    basename = moduleNameSlashes (installedModuleName mod)
+
+    to_search :: [(FilePath, IO ModLocation)]
+    to_search = [ (file, fn path basename)
+                | path <- paths,
+                  (ext,fn) <- exts,
+                  let base | path == "." = basename
+                           | otherwise   = path </> basename
+                      file = base <.> ext
+                ]
+
+    search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))
+
+    search ((file, mk_result) : rest) = do
+      b <- doesFileExist file
+      if b
+        then do { loc <- mk_result; return (InstalledFound loc mod) }
+        else search rest
+
+mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
+                          -> FilePath -> BaseName -> IO ModLocation
+mkHomeModLocationSearched dflags mod suff path basename = do
+   mkHomeModLocation2 dflags mod (path </> basename) suff
+
+-- -----------------------------------------------------------------------------
+-- Constructing a home module location
+
+-- This is where we construct the ModLocation for a module in the home
+-- package, for which we have a source file.  It is called from three
+-- places:
+--
+--  (a) Here in the finder, when we are searching for a module to import,
+--      using the search path (-i option).
+--
+--  (b) The compilation manager, when constructing the ModLocation for
+--      a "root" module (a source file named explicitly on the command line
+--      or in a :load command in GHCi).
+--
+--  (c) The driver in one-shot mode, when we need to construct a
+--      ModLocation for a source file named on the command-line.
+--
+-- Parameters are:
+--
+-- mod
+--      The name of the module
+--
+-- path
+--      (a): The search path component where the source file was found.
+--      (b) and (c): "."
+--
+-- src_basename
+--      (a): (moduleNameSlashes mod)
+--      (b) and (c): The filename of the source file, minus its extension
+--
+-- ext
+--      The filename extension of the source file (usually "hs" or "lhs").
+
+mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
+mkHomeModLocation dflags mod src_filename = do
+   let (basename,extension) = splitExtension src_filename
+   mkHomeModLocation2 dflags mod basename extension
+
+mkHomeModLocation2 :: DynFlags
+                   -> ModuleName
+                   -> FilePath  -- Of source module, without suffix
+                   -> String    -- Suffix
+                   -> IO ModLocation
+mkHomeModLocation2 dflags mod src_basename ext = do
+   let mod_basename = moduleNameSlashes mod
+
+       obj_fn = mkObjPath  dflags src_basename mod_basename
+       hi_fn  = mkHiPath   dflags src_basename mod_basename
+       hie_fn = mkHiePath  dflags src_basename mod_basename
+
+   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),
+                        ml_hi_file   = hi_fn,
+                        ml_obj_file  = obj_fn,
+                        ml_hie_file  = hie_fn })
+
+mkHomeModHiOnlyLocation :: DynFlags
+                        -> ModuleName
+                        -> FilePath
+                        -> BaseName
+                        -> IO ModLocation
+mkHomeModHiOnlyLocation dflags mod path basename = do
+   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""
+   return loc { ml_hs_file = Nothing }
+
+mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
+                    -> IO ModLocation
+mkHiOnlyModLocation dflags hisuf path basename
+ = do let full_basename = path </> basename
+          obj_fn = mkObjPath  dflags full_basename basename
+          hie_fn = mkHiePath  dflags full_basename basename
+      return ModLocation{    ml_hs_file   = Nothing,
+                             ml_hi_file   = full_basename <.> hisuf,
+                                -- Remove the .hi-boot suffix from
+                                -- hi_file, if it had one.  We always
+                                -- want the name of the real .hi file
+                                -- in the ml_hi_file field.
+                             ml_obj_file  = obj_fn,
+                             ml_hie_file  = hie_fn
+                  }
+
+-- | Constructs the filename of a .o file for a given source file.
+-- Does /not/ check whether the .o file exists
+mkObjPath
+  :: DynFlags
+  -> FilePath           -- the filename of the source file, minus the extension
+  -> String             -- the module name with dots replaced by slashes
+  -> FilePath
+mkObjPath dflags basename mod_basename = obj_basename <.> osuf
+  where
+                odir = objectDir dflags
+                osuf = objectSuf dflags
+
+                obj_basename | Just dir <- odir = dir </> mod_basename
+                             | otherwise        = basename
+
+
+-- | Constructs the filename of a .hi file for a given source file.
+-- Does /not/ check whether the .hi file exists
+mkHiPath
+  :: DynFlags
+  -> FilePath           -- the filename of the source file, minus the extension
+  -> String             -- the module name with dots replaced by slashes
+  -> FilePath
+mkHiPath dflags basename mod_basename = hi_basename <.> hisuf
+ where
+                hidir = hiDir dflags
+                hisuf = hiSuf dflags
+
+                hi_basename | Just dir <- hidir = dir </> mod_basename
+                            | otherwise         = basename
+
+-- | Constructs the filename of a .hie file for a given source file.
+-- Does /not/ check whether the .hie file exists
+mkHiePath
+  :: DynFlags
+  -> FilePath           -- the filename of the source file, minus the extension
+  -> String             -- the module name with dots replaced by slashes
+  -> FilePath
+mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf
+ where
+                hiedir = hieDir dflags
+                hiesuf = hieSuf dflags
+
+                hie_basename | Just dir <- hiedir = dir </> mod_basename
+                             | otherwise          = basename
+
+
+
+-- -----------------------------------------------------------------------------
+-- Filenames of the stub files
+
+-- We don't have to store these in ModLocations, because they can be derived
+-- from other available information, and they're only rarely needed.
+
+mkStubPaths
+  :: DynFlags
+  -> ModuleName
+  -> ModLocation
+  -> FilePath
+
+mkStubPaths dflags mod location
+  = let
+        stubdir = stubDir dflags
+
+        mod_basename = moduleNameSlashes mod
+        src_basename = dropExtension $ expectJust "mkStubPaths"
+                                                  (ml_hs_file location)
+
+        stub_basename0
+            | Just dir <- stubdir = dir </> mod_basename
+            | otherwise           = src_basename
+
+        stub_basename = stub_basename0 ++ "_stub"
+     in
+        stub_basename <.> "h"
+
+-- -----------------------------------------------------------------------------
+-- findLinkable isn't related to the other stuff in here,
+-- but there's no other obvious place for it
+
+findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
+findObjectLinkableMaybe mod locn
+   = do let obj_fn = ml_obj_file locn
+        maybe_obj_time <- modificationTimeIfExists obj_fn
+        case maybe_obj_time of
+          Nothing -> return Nothing
+          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)
+
+-- Make an object linkable when we know the object file exists, and we know
+-- its modification time.
+findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
+  -- We used to look for _stub.o files here, but that was a bug (#706)
+  -- Now GHC merges the stub.o into the main .o (#3687)
+
+-- -----------------------------------------------------------------------------
+-- Error messages
+
+cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
+cannotFindModule flags mod res =
+  cantFindErr (sLit cannotFindMsg)
+              (sLit "Ambiguous module name")
+              flags mod res
+  where
+    cannotFindMsg =
+      case res of
+        NotFound { fr_mods_hidden = hidden_mods
+                 , fr_pkgs_hidden = hidden_pkgs
+                 , fr_unusables = unusables }
+          | not (null hidden_mods && null hidden_pkgs && null unusables)
+          -> "Could not load module"
+        _ -> "Could not find module"
+
+cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc
+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")
+                                           (sLit "Ambiguous interface for")
+
+cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult
+            -> SDoc
+cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
+  | Just pkgs <- unambiguousPackages
+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
+       sep [text "it was found in multiple packages:",
+                hsep (map ppr pkgs) ]
+    )
+  | otherwise
+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
+       vcat (map pprMod mods)
+    )
+  where
+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods
+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
+        = Just (moduleUnitId m : xs)
+    unambiguousPackage _ _ = Nothing
+
+    pprMod (m, o) = text "it is bound as" <+> ppr m <+>
+                                text "by" <+> pprOrigin m o
+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
+      if e == Just True
+          then [text "package" <+> ppr (moduleUnitId m)]
+          else [] ++
+      map ((text "a reexport in package" <+>)
+                .ppr.packageConfigId) res ++
+      if f then [text "a package flag"] else []
+      )
+
+cantFindErr cannot_find _ dflags mod_name find_result
+  = ptext cannot_find <+> quotes (ppr mod_name)
+    $$ more_info
+  where
+    more_info
+      = case find_result of
+            NoPackage pkg
+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
+                   text "was found"
+
+            NotFound { fr_paths = files, fr_pkg = mb_pkg
+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
+                     , fr_unusables = unusables, fr_suggestions = suggest }
+                | Just pkg <- mb_pkg, pkg /= thisPackage dflags
+                -> not_found_in_package pkg files
+
+                | not (null suggest)
+                -> pp_suggestions suggest $$ tried_these files dflags
+
+                | null files && null mod_hiddens &&
+                  null pkg_hiddens && null unusables
+                -> text "It is not a module in the current program, or in any known package."
+
+                | otherwise
+                -> vcat (map pkg_hidden pkg_hiddens) $$
+                   vcat (map mod_hidden mod_hiddens) $$
+                   vcat (map unusable unusables) $$
+                   tried_these files dflags
+
+            _ -> panic "cantFindErr"
+
+    build_tag = buildTag dflags
+
+    not_found_in_package pkg files
+       | build_tag /= ""
+       = let
+            build = if build_tag == "p" then "profiling"
+                                        else "\"" ++ build_tag ++ "\""
+         in
+         text "Perhaps you haven't installed the " <> text build <>
+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
+         tried_these files dflags
+
+       | otherwise
+       = text "There are files missing in the " <> quotes (ppr pkg) <>
+         text " package," $$
+         text "try running 'ghc-pkg check'." $$
+         tried_these files dflags
+
+    pkg_hidden :: UnitId -> SDoc
+    pkg_hidden pkgid =
+        text "It is a member of the hidden package"
+        <+> quotes (ppr pkgid)
+        --FIXME: we don't really want to show the unit id here we should
+        -- show the source package id or installed package id if it's ambiguous
+        <> dot $$ pkg_hidden_hint pkgid
+    pkg_hidden_hint pkgid
+     | gopt Opt_BuildingCabalPackage dflags
+        = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)
+           in text "Perhaps you need to add" <+>
+              quotes (ppr (packageName pkg)) <+>
+              text "to the build-depends in your .cabal file."
+     | Just pkg <- lookupPackage dflags pkgid
+         = text "You can run" <+>
+           quotes (text ":set -package " <> ppr (packageName pkg)) <+>
+           text "to expose it." $$
+           text "(Note: this unloads all the modules in the current scope.)"
+     | otherwise = Outputable.empty
+
+    mod_hidden pkg =
+        text "it is a hidden module in the package" <+> quotes (ppr pkg)
+
+    unusable (pkg, reason)
+      = text "It is a member of the package"
+      <+> quotes (ppr pkg)
+      $$ pprReason (text "which is") reason
+
+    pp_suggestions :: [ModuleSuggestion] -> SDoc
+    pp_suggestions sugs
+      | null sugs = Outputable.empty
+      | otherwise = hang (text "Perhaps you meant")
+                       2 (vcat (map pp_sugg sugs))
+
+    -- NB: Prefer the *original* location, and then reexports, and then
+    -- package flags when making suggestions.  ToDo: if the original package
+    -- also has a reexport, prefer that one
+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
+      where provenance ModHidden = Outputable.empty
+            provenance (ModUnusable _) = Outputable.empty
+            provenance (ModOrigin{ fromOrigPackage = e,
+                                   fromExposedReexport = res,
+                                   fromPackageFlag = f })
+              | Just True <- e
+                 = parens (text "from" <+> ppr (moduleUnitId mod))
+              | f && moduleName mod == m
+                 = parens (text "from" <+> ppr (moduleUnitId mod))
+              | (pkg:_) <- res
+                 = parens (text "from" <+> ppr (packageConfigId pkg)
+                    <> comma <+> text "reexporting" <+> ppr mod)
+              | f
+                 = parens (text "defined via package flags to be"
+                    <+> ppr mod)
+              | otherwise = Outputable.empty
+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
+      where provenance ModHidden =  Outputable.empty
+            provenance (ModUnusable _) = Outputable.empty
+            provenance (ModOrigin{ fromOrigPackage = e,
+                                   fromHiddenReexport = rhs })
+              | Just False <- e
+                 = parens (text "needs flag -package-key"
+                    <+> ppr (moduleUnitId mod))
+              | (pkg:_) <- rhs
+                 = parens (text "needs flag -package-id"
+                    <+> ppr (packageConfigId pkg))
+              | otherwise = Outputable.empty
+
+cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName
+                     -> InstalledFindResult -> SDoc
+cantFindInstalledErr cannot_find _ dflags mod_name find_result
+  = ptext cannot_find <+> quotes (ppr mod_name)
+    $$ more_info
+  where
+    more_info
+      = case find_result of
+            InstalledNoPackage pkg
+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
+                   text "was found" $$ looks_like_srcpkgid pkg
+
+            InstalledNotFound files mb_pkg
+                | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)
+                -> not_found_in_package pkg files
+
+                | null files
+                -> text "It is not a module in the current program, or in any known package."
+
+                | otherwise
+                -> tried_these files dflags
+
+            _ -> panic "cantFindInstalledErr"
+
+    build_tag = buildTag dflags
+
+    looks_like_srcpkgid :: InstalledUnitId -> SDoc
+    looks_like_srcpkgid pk
+     -- Unsafely coerce a unit id FastString into a source package ID
+     -- FastString and see if it means anything.
+     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))
+     = parens (text "This unit ID looks like the source package ID;" $$
+       text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$
+       (if null pkgs then Outputable.empty
+        else text "and" <+> int (length pkgs) <+> text "other candidates"))
+     -- Todo: also check if it looks like a package name!
+     | otherwise = Outputable.empty
+
+    not_found_in_package pkg files
+       | build_tag /= ""
+       = let
+            build = if build_tag == "p" then "profiling"
+                                        else "\"" ++ build_tag ++ "\""
+         in
+         text "Perhaps you haven't installed the " <> text build <>
+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
+         tried_these files dflags
+
+       | otherwise
+       = text "There are files missing in the " <> quotes (ppr pkg) <>
+         text " package," $$
+         text "try running 'ghc-pkg check'." $$
+         tried_these files dflags
+
+tried_these :: [FilePath] -> DynFlags -> SDoc
+tried_these files dflags
+    | null files = Outputable.empty
+    | verbosity dflags < 3 =
+          text "Use -v (or `:set -v` in ghci) " <>
+              text "to see a list of the files searched for."
+    | otherwise =
+          hang (text "Locations searched:") 2 $ vcat (map text files)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/GHC.hs
@@ -0,0 +1,1560 @@
+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections, NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2005-2012
+--
+-- The GHC API
+--
+-- -----------------------------------------------------------------------------
+
+module GHC (
+        -- * Initialisation
+        defaultErrorHandler,
+        defaultCleanupHandler,
+        prettyPrintGhcErrors,
+        withSignalHandlers,
+        withCleanupSession,
+
+        -- * GHC Monad
+        Ghc, GhcT, GhcMonad(..), HscEnv,
+        runGhc, runGhcT, initGhcMonad,
+        gcatch, gbracket, gfinally,
+        printException,
+        handleSourceError,
+        needsTemplateHaskellOrQQ,
+
+        -- * Flags and settings
+        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
+        GhcMode(..), GhcLink(..), defaultObjectTarget,
+        parseDynamicFlags,
+        getSessionDynFlags, setSessionDynFlags,
+        getProgramDynFlags, setProgramDynFlags, setLogAction,
+        getInteractiveDynFlags, setInteractiveDynFlags,
+
+        -- * Targets
+        Target(..), TargetId(..), Phase,
+        setTargets,
+        getTargets,
+        addTarget,
+        removeTarget,
+        guessTarget,
+
+        -- * Loading\/compiling the program
+        depanal,
+        load, LoadHowMuch(..), InteractiveImport(..),
+        SuccessFlag(..), succeeded, failed,
+        defaultWarnErrLogger, WarnErrLogger,
+        workingDirectoryChanged,
+        parseModule, typecheckModule, desugarModule, loadModule,
+        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
+        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
+        TypecheckedMod, ParsedMod,
+        moduleInfo, renamedSource, typecheckedSource,
+        parsedSource, coreModule,
+
+        -- ** Compiling to Core
+        CoreModule(..),
+        compileToCoreModule, compileToCoreSimplified,
+
+        -- * Inspecting the module structure of the program
+        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
+        mgLookupModule,
+        ModSummary(..), ms_mod_name, ModLocation(..),
+        getModSummary,
+        getModuleGraph,
+        isLoaded,
+        topSortModuleGraph,
+
+        -- * Inspecting modules
+        ModuleInfo,
+        getModuleInfo,
+        modInfoTyThings,
+        modInfoTopLevelScope,
+        modInfoExports,
+        modInfoExportsWithSelectors,
+        modInfoInstances,
+        modInfoIsExportedName,
+        modInfoLookupName,
+        modInfoIface,
+        modInfoSafe,
+        lookupGlobalName,
+        findGlobalAnns,
+        mkPrintUnqualifiedForModule,
+        ModIface(..),
+        SafeHaskellMode(..),
+
+        -- * Querying the environment
+        -- packageDbModules,
+
+        -- * Printing
+        PrintUnqualified, alwaysQualify,
+
+        -- * Interactive evaluation
+
+        -- ** Executing statements
+        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
+        resumeExec,
+
+        -- ** Adding new declarations
+        runDecls, runDeclsWithLocation, runParsedDecls,
+
+        -- ** Get/set the current context
+        parseImportDecl,
+        setContext, getContext,
+        setGHCiMonad, getGHCiMonad,
+
+        -- ** Inspecting the current context
+        getBindings, getInsts, getPrintUnqual,
+        findModule, lookupModule,
+        isModuleTrusted, moduleTrustReqs,
+        getNamesInScope,
+        getRdrNamesInScope,
+        getGRE,
+        moduleIsInterpreted,
+        getInfo,
+        showModule,
+        moduleIsBootOrNotObjectLinkable,
+        getNameToInstancesIndex,
+
+        -- ** Inspecting types and kinds
+        exprType, TcRnExprMode(..),
+        typeKind,
+
+        -- ** Looking up a Name
+        parseName,
+        lookupName,
+
+        -- ** Compiling expressions
+        HValue, parseExpr, compileParsedExpr,
+        InteractiveEval.compileExpr, dynCompileExpr,
+        ForeignHValue,
+        compileExprRemote, compileParsedExprRemote,
+
+        -- ** Docs
+        getDocs, GetDocsFailure(..),
+
+        -- ** Other
+        runTcInteractive,   -- Desired by some clients (#8878)
+        isStmt, hasImport, isImport, isDecl,
+
+        -- ** The debugger
+        SingleStep(..),
+        Resume(..),
+        History(historyBreakInfo, historyEnclosingDecls),
+        GHC.getHistorySpan, getHistoryModule,
+        abandon, abandonAll,
+        getResumeContext,
+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
+        modInfoModBreaks,
+        ModBreaks(..), BreakIndex,
+        BreakInfo(breakInfo_number, breakInfo_module),
+        InteractiveEval.back,
+        InteractiveEval.forward,
+
+        -- * Abstract syntax elements
+
+        -- ** Packages
+        UnitId,
+
+        -- ** Modules
+        Module, mkModule, pprModule, moduleName, moduleUnitId,
+        ModuleName, mkModuleName, moduleNameString,
+
+        -- ** Names
+        Name,
+        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
+        NamedThing(..),
+        RdrName(Qual,Unqual),
+
+        -- ** Identifiers
+        Id, idType,
+        isImplicitId, isDeadBinder,
+        isExportedId, isLocalId, isGlobalId,
+        isRecordSelector,
+        isPrimOpId, isFCallId, isClassOpId_maybe,
+        isDataConWorkId, idDataCon,
+        isBottomingId, isDictonaryId,
+        recordSelectorTyCon,
+
+        -- ** Type constructors
+        TyCon,
+        tyConTyVars, tyConDataCons, tyConArity,
+        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
+        isPrimTyCon, isFunTyCon,
+        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
+        tyConClass_maybe,
+        synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
+
+        -- ** Type variables
+        TyVar,
+        alphaTyVars,
+
+        -- ** Data constructors
+        DataCon,
+        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+        dataConIsInfix, isVanillaDataCon, dataConUserType,
+        dataConSrcBangs,
+        StrictnessMark(..), isMarkedStrict,
+
+        -- ** Classes
+        Class,
+        classMethods, classSCTheta, classTvsFds, classATs,
+        pprFundeps,
+
+        -- ** Instances
+        ClsInst,
+        instanceDFunId,
+        pprInstance, pprInstanceHdr,
+        pprFamInst,
+
+        FamInst,
+
+        -- ** Types and Kinds
+        Type, splitForAllTys, funResultTy,
+        pprParendType, pprTypeApp,
+        Kind,
+        PredType,
+        ThetaType, pprForAll, pprThetaArrowTy,
+
+        -- ** Entities
+        TyThing(..),
+
+        -- ** Syntax
+        module HsSyn, -- ToDo: remove extraneous bits
+
+        -- ** Fixities
+        FixityDirection(..),
+        defaultFixity, maxPrecedence,
+        negateFixity,
+        compareFixity,
+        LexicalFixity(..),
+
+        -- ** Source locations
+        SrcLoc(..), RealSrcLoc,
+        mkSrcLoc, noSrcLoc,
+        srcLocFile, srcLocLine, srcLocCol,
+        SrcSpan(..), RealSrcSpan,
+        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
+        srcSpanStart, srcSpanEnd,
+        srcSpanFile,
+        srcSpanStartLine, srcSpanEndLine,
+        srcSpanStartCol, srcSpanEndCol,
+
+        -- ** Located
+        GenLocated(..), Located,
+
+        -- *** Constructing Located
+        noLoc, mkGeneralLocated,
+
+        -- *** Deconstructing Located
+        getLoc, unLoc,
+        getRealSrcSpan, unRealSrcSpan,
+
+        -- ** HasSrcSpan
+        HasSrcSpan(..), SrcSpanLess, dL, cL,
+
+        -- *** Combining and comparing Located values
+        eqLocated, cmpLocated, combineLocs, addCLoc,
+        leftmost_smallest, leftmost_largest, rightmost,
+        spans, isSubspanOf,
+
+        -- * Exceptions
+        GhcException(..), showGhcException,
+
+        -- * Token stream manipulations
+        Token,
+        getTokenStream, getRichTokenStream,
+        showRichTokenStream, addSourceToTokens,
+
+        -- * Pure interface to the parser
+        parser,
+
+        -- * API Annotations
+        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
+        getAnnotation, getAndRemoveAnnotation,
+        getAnnotationComments, getAndRemoveAnnotationComments,
+        unicodeAnn,
+
+        -- * Miscellaneous
+        --sessionHscEnv,
+        cyclicModuleErr,
+  ) where
+
+{-
+ ToDo:
+
+  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
+-}
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding (init)
+
+import ByteCodeTypes
+import InteractiveEval
+import InteractiveEvalTypes
+import GHCi
+import GHCi.RemoteTypes
+
+import PprTyThing       ( pprFamInst )
+import HscMain
+import GhcMake
+import DriverPipeline   ( compileOne' )
+import GhcMonad
+import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
+import LoadIface        ( loadSysInterface )
+import TcRnTypes
+import Packages
+import NameSet
+import RdrName
+import HsSyn
+import Type     hiding( typeKind )
+import TcType
+import Id
+import TysPrim          ( alphaTyVars )
+import TyCon
+import Class
+import DataCon
+import Name             hiding ( varName )
+import Avail
+import InstEnv
+import FamInstEnv ( FamInst )
+import SrcLoc
+import CoreSyn
+import TidyPgm
+import DriverPhases     ( Phase(..), isHaskellSrcFilename )
+import Finder
+import HscTypes
+import CmdLineParser
+import DynFlags hiding (WarnReason(..))
+import SysTools
+import SysTools.BaseDir
+import Annotations
+import Module
+import Panic
+import Platform
+import Bag              ( listToBag )
+import ErrUtils
+import MonadUtils
+import Util
+import StringBuffer
+import Outputable
+import BasicTypes
+import Maybes           ( expectJust )
+import FastString
+import qualified Parser
+import Lexer
+import ApiAnnotation
+import qualified GHC.LanguageExtensions as LangExt
+import NameEnv
+import CoreFVs          ( orphNamesOfFamInst )
+import FamInstEnv       ( famInstEnvElts )
+import TcRnDriver
+import Inst
+import FamInst
+import FileCleanup
+
+import Data.Foldable
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Sequence as Seq
+import System.Directory ( doesFileExist )
+import Data.Maybe
+import Data.Time
+import Data.Typeable    ( Typeable )
+import Data.Word        ( Word8 )
+import Control.Monad
+import System.Exit      ( exitWith, ExitCode(..) )
+import Exception
+import Data.IORef
+import System.FilePath
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Initialisation: exception handlers
+-- %*                                                                      *
+-- %************************************************************************
+
+
+-- | Install some default exception handlers and run the inner computation.
+-- Unless you want to handle exceptions yourself, you should wrap this around
+-- the top level of your program.  The default handlers output the error
+-- message(s) to stderr and exit cleanly.
+defaultErrorHandler :: (ExceptionMonad m)
+                    => FatalMessager -> FlushOut -> m a -> m a
+defaultErrorHandler fm (FlushOut flushOut) inner =
+  -- top-level exception handler: any unrecognised exception is a compiler bug.
+  ghandle (\exception -> liftIO $ do
+           flushOut
+           case fromException exception of
+                -- an IO exception probably isn't our fault, so don't panic
+                Just (ioe :: IOException) ->
+                  fatalErrorMsg'' fm (show ioe)
+                _ -> case fromException exception of
+                     Just UserInterrupt ->
+                         -- Important to let this one propagate out so our
+                         -- calling process knows we were interrupted by ^C
+                         liftIO $ throwIO UserInterrupt
+                     Just StackOverflow ->
+                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
+                     _ -> case fromException exception of
+                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
+                          _ ->
+                              fatalErrorMsg'' fm
+                                  (show (Panic (show exception)))
+           exitWith (ExitFailure 1)
+         ) $
+
+  -- error messages propagated as exceptions
+  handleGhcException
+            (\ge -> liftIO $ do
+                flushOut
+                case ge of
+                     Signal _ -> exitWith (ExitFailure 1)
+                     _ -> do fatalErrorMsg'' fm (show ge)
+                             exitWith (ExitFailure 1)
+            ) $
+  inner
+
+-- | This function is no longer necessary, cleanup is now done by
+-- runGhc/runGhcT.
+{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
+defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
+defaultCleanupHandler _ m = m
+ where _warning_suppression = m `gonException` undefined
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             The Ghc Monad
+-- %*                                                                      *
+-- %************************************************************************
+
+-- | Run function for the 'Ghc' monad.
+--
+-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
+-- to this function will create a new session which should not be shared among
+-- several threads.
+--
+-- Any errors not handled inside the 'Ghc' action are propagated as IO
+-- exceptions.
+
+runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
+       -> Ghc a           -- ^ The action to perform.
+       -> IO a
+runGhc mb_top_dir ghc = do
+  ref <- newIORef (panic "empty session")
+  let session = Session ref
+  flip unGhc session $ withSignalHandlers $ do -- catch ^C
+    initGhcMonad mb_top_dir
+    withCleanupSession ghc
+
+-- | Run function for 'GhcT' monad transformer.
+--
+-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
+-- to this function will create a new session which should not be shared among
+-- several threads.
+
+runGhcT :: ExceptionMonad m =>
+           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
+        -> GhcT m a        -- ^ The action to perform.
+        -> m a
+runGhcT mb_top_dir ghct = do
+  ref <- liftIO $ newIORef (panic "empty session")
+  let session = Session ref
+  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
+    initGhcMonad mb_top_dir
+    withCleanupSession ghct
+
+withCleanupSession :: GhcMonad m => m a -> m a
+withCleanupSession ghc = ghc `gfinally` cleanup
+  where
+   cleanup = do
+      hsc_env <- getSession
+      let dflags = hsc_dflags hsc_env
+      liftIO $ do
+          cleanTempFiles dflags
+          cleanTempDirs dflags
+          stopIServ hsc_env -- shut down the IServ
+          --  exceptions will be blocked while we clean the temporary files,
+          -- so there shouldn't be any difficulty if we receive further
+          -- signals.
+
+-- | Initialise a GHC session.
+--
+-- If you implement a custom 'GhcMonad' you must call this function in the
+-- monad run function.  It will initialise the session variable and clear all
+-- warnings.
+--
+-- The first argument should point to the directory where GHC's library files
+-- reside.  More precisely, this should be the output of @ghc --print-libdir@
+-- of the version of GHC the module using this API is compiled with.  For
+-- portability, you should use the @ghc-paths@ package, available at
+-- <http://hackage.haskell.org/package/ghc-paths>.
+
+initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
+initGhcMonad mb_top_dir
+  = do { env <- liftIO $
+                do { top_dir <- findTopDir mb_top_dir
+                   ; mySettings <- initSysTools top_dir
+                   ; myLlvmConfig <- initLlvmConfig top_dir
+                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
+                   ; checkBrokenTablesNextToCode dflags
+                   ; setUnsafeGlobalDynFlags dflags
+                      -- c.f. DynFlags.parseDynamicFlagsFull, which
+                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
+                   ; newHscEnv dflags }
+       ; setSession env }
+
+-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
+-- breaks tables-next-to-code in dynamically linked modules. This
+-- check should be more selective but there is currently no released
+-- version where this bug is fixed.
+-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
+-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
+checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
+checkBrokenTablesNextToCode dflags
+  = do { broken <- checkBrokenTablesNextToCode' dflags
+       ; when broken
+         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
+              ; liftIO $ fail "unsupported linker"
+              }
+       }
+  where
+    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>
+                   text "when using binutils ld (please see:" <+>
+                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
+
+checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
+checkBrokenTablesNextToCode' dflags
+  | not (isARM arch)              = return False
+  | WayDyn `notElem` ways dflags  = return False
+  | not (tablesNextToCode dflags) = return False
+  | otherwise                     = do
+    linkerInfo <- liftIO $ getLinkerInfo dflags
+    case linkerInfo of
+      GnuLD _  -> return True
+      _        -> return False
+  where platform = targetPlatform dflags
+        arch = platformArch platform
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Flags & settings
+-- %*                                                                      *
+-- %************************************************************************
+
+-- $DynFlags
+--
+-- The GHC session maintains two sets of 'DynFlags':
+--
+--   * The "interactive" @DynFlags@, which are used for everything
+--     related to interactive evaluation, including 'runStmt',
+--     'runDecls', 'exprType', 'lookupName' and so on (everything
+--     under \"Interactive evaluation\" in this module).
+--
+--   * The "program" @DynFlags@, which are used when loading
+--     whole modules with 'load'
+--
+-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
+-- interactive @DynFlags@.
+--
+-- 'setProgramDynFlags', 'getProgramDynFlags' work with the
+-- program @DynFlags@.
+--
+-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
+-- retrieves the program @DynFlags@ (for backwards compatibility).
+
+
+-- | Updates both the interactive and program DynFlags in a Session.
+-- This also reads the package database (unless it has already been
+-- read), and prepares the compilers knowledge about packages.  It can
+-- be called again to load new packages: just add new package flags to
+-- (packageFlags dflags).
+--
+-- Returns a list of new packages that may need to be linked in using
+-- the dynamic linker (see 'linkPackages') as a result of new package
+-- flags.  If you are not doing linking or doing static linking, you
+-- can ignore the list of packages returned.
+--
+setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
+setSessionDynFlags dflags = do
+  dflags' <- checkNewDynFlags dflags
+  (dflags'', preload) <- liftIO $ initPackages dflags'
+  modifySession $ \h -> h{ hsc_dflags = dflags''
+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
+  invalidateModSummaryCache
+  return preload
+
+-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
+-- cached module graph, causing more work to be done the next time
+-- 'load' is called.
+setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
+setProgramDynFlags dflags = setProgramDynFlags_ True dflags
+
+-- | Set the action taken when the compiler produces a message.  This
+-- can also be accomplished using 'setProgramDynFlags', but using
+-- 'setLogAction' avoids invalidating the cached module graph.
+setLogAction :: GhcMonad m => LogAction -> m ()
+setLogAction action = do
+  dflags' <- getProgramDynFlags
+  void $ setProgramDynFlags_ False $
+    dflags' { log_action = action }
+
+setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
+setProgramDynFlags_ invalidate_needed dflags = do
+  dflags' <- checkNewDynFlags dflags
+  dflags_prev <- getProgramDynFlags
+  (dflags'', preload) <-
+    if (packageFlagsChanged dflags_prev dflags')
+       then liftIO $ initPackages dflags'
+       else return (dflags', [])
+  modifySession $ \h -> h{ hsc_dflags = dflags'' }
+  when invalidate_needed $ invalidateModSummaryCache
+  return preload
+
+
+-- When changing the DynFlags, we want the changes to apply to future
+-- loads, but without completely discarding the program.  But the
+-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
+-- after a change to DynFlags, the changes would apply to new modules
+-- but not existing modules; this seems undesirable.
+--
+-- Furthermore, the GHC API client might expect that changing
+-- log_action would affect future compilation messages, but for those
+-- modules we have cached ModSummaries for, we'll continue to use the
+-- old log_action.  This is definitely wrong (#7478).
+--
+-- Hence, we invalidate the ModSummary cache after changing the
+-- DynFlags.  We do this by tweaking the date on each ModSummary, so
+-- that the next downsweep will think that all the files have changed
+-- and preprocess them again.  This won't necessarily cause everything
+-- to be recompiled, because by the time we check whether we need to
+-- recopmile a module, we'll have re-summarised the module and have a
+-- correct ModSummary.
+--
+invalidateModSummaryCache :: GhcMonad m => m ()
+invalidateModSummaryCache =
+  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
+ where
+  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }
+
+-- | Returns the program 'DynFlags'.
+getProgramDynFlags :: GhcMonad m => m DynFlags
+getProgramDynFlags = getSessionDynFlags
+
+-- | Set the 'DynFlags' used to evaluate interactive expressions.
+-- Note: this cannot be used for changes to packages.  Use
+-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
+-- 'pkgState' into the interactive @DynFlags@.
+setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
+setInteractiveDynFlags dflags = do
+  dflags' <- checkNewDynFlags dflags
+  dflags'' <- checkNewInteractiveDynFlags dflags'
+  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
+
+-- | Get the 'DynFlags' used to evaluate interactive expressions.
+getInteractiveDynFlags :: GhcMonad m => m DynFlags
+getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
+
+
+parseDynamicFlags :: MonadIO m =>
+                     DynFlags -> [Located String]
+                  -> m (DynFlags, [Located String], [Warn])
+parseDynamicFlags = parseDynamicFlagsCmdLine
+
+-- | Checks the set of new DynFlags for possibly erroneous option
+-- combinations when invoking 'setSessionDynFlags' and friends, and if
+-- found, returns a fixed copy (if possible).
+checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
+checkNewDynFlags dflags = do
+  -- See Note [DynFlags consistency]
+  let (dflags', warnings) = makeDynFlagsConsistent dflags
+  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
+  return dflags'
+
+checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
+checkNewInteractiveDynFlags dflags0 = do
+  -- We currently don't support use of StaticPointers in expressions entered on
+  -- the REPL. See #12356.
+  if xopt LangExt.StaticPointers dflags0
+  then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
+            [mkPlainWarnMsg dflags0 interactiveSrcSpan
+             $ text "StaticPointers is not supported in GHCi interactive expressions."]
+          return $ xopt_unset dflags0 LangExt.StaticPointers
+  else return dflags0
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Setting, getting, and modifying the targets
+-- %*                                                                      *
+-- %************************************************************************
+
+-- ToDo: think about relative vs. absolute file paths. And what
+-- happens when the current directory changes.
+
+-- | Sets the targets for this session.  Each target may be a module name
+-- or a filename.  The targets correspond to the set of root modules for
+-- the program\/library.  Unloading the current program is achieved by
+-- setting the current set of targets to be empty, followed by 'load'.
+setTargets :: GhcMonad m => [Target] -> m ()
+setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
+
+-- | Returns the current set of targets
+getTargets :: GhcMonad m => m [Target]
+getTargets = withSession (return . hsc_targets)
+
+-- | Add another target.
+addTarget :: GhcMonad m => Target -> m ()
+addTarget target
+  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
+
+-- | Remove a target
+removeTarget :: GhcMonad m => TargetId -> m ()
+removeTarget target_id
+  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
+  where
+   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
+
+-- | Attempts to guess what Target a string refers to.  This function
+-- implements the @--make@/GHCi command-line syntax for filenames:
+--
+--   - if the string looks like a Haskell source filename, then interpret it
+--     as such
+--
+--   - if adding a .hs or .lhs suffix yields the name of an existing file,
+--     then use that
+--
+--   - otherwise interpret the string as a module name
+--
+guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
+guessTarget str (Just phase)
+   = return (Target (TargetFile str (Just phase)) True Nothing)
+guessTarget str Nothing
+   | isHaskellSrcFilename file
+   = return (target (TargetFile file Nothing))
+   | otherwise
+   = do exists <- liftIO $ doesFileExist hs_file
+        if exists
+           then return (target (TargetFile hs_file Nothing))
+           else do
+        exists <- liftIO $ doesFileExist lhs_file
+        if exists
+           then return (target (TargetFile lhs_file Nothing))
+           else do
+        if looksLikeModuleName file
+           then return (target (TargetModule (mkModuleName file)))
+           else do
+        dflags <- getDynFlags
+        liftIO $ throwGhcExceptionIO
+                 (ProgramError (showSDoc dflags $
+                 text "target" <+> quotes (text file) <+>
+                 text "is not a module name or a source file"))
+     where
+         (file,obj_allowed)
+                | '*':rest <- str = (rest, False)
+                | otherwise       = (str,  True)
+
+         hs_file  = file <.> "hs"
+         lhs_file = file <.> "lhs"
+
+         target tid = Target tid obj_allowed Nothing
+
+
+-- | Inform GHC that the working directory has changed.  GHC will flush
+-- its cache of module locations, since it may no longer be valid.
+--
+-- Note: Before changing the working directory make sure all threads running
+-- in the same session have stopped.  If you change the working directory,
+-- you should also unload the current program (set targets to empty,
+-- followed by load).
+workingDirectoryChanged :: GhcMonad m => m ()
+workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Running phases one at a time
+-- %*                                                                      *
+-- %************************************************************************
+
+class ParsedMod m where
+  modSummary   :: m -> ModSummary
+  parsedSource :: m -> ParsedSource
+
+class ParsedMod m => TypecheckedMod m where
+  renamedSource     :: m -> Maybe RenamedSource
+  typecheckedSource :: m -> TypecheckedSource
+  moduleInfo        :: m -> ModuleInfo
+  tm_internals      :: m -> (TcGblEnv, ModDetails)
+        -- ToDo: improvements that could be made here:
+        --  if the module succeeded renaming but not typechecking,
+        --  we can still get back the GlobalRdrEnv and exports, so
+        --  perhaps the ModuleInfo should be split up into separate
+        --  fields.
+
+class TypecheckedMod m => DesugaredMod m where
+  coreModule :: m -> ModGuts
+
+-- | The result of successful parsing.
+data ParsedModule =
+  ParsedModule { pm_mod_summary   :: ModSummary
+               , pm_parsed_source :: ParsedSource
+               , pm_extra_src_files :: [FilePath]
+               , pm_annotations :: ApiAnns }
+               -- See Note [Api annotations] in ApiAnnotation.hs
+
+instance ParsedMod ParsedModule where
+  modSummary m    = pm_mod_summary m
+  parsedSource m = pm_parsed_source m
+
+-- | The result of successful typechecking.  It also contains the parser
+--   result.
+data TypecheckedModule =
+  TypecheckedModule { tm_parsed_module       :: ParsedModule
+                    , tm_renamed_source      :: Maybe RenamedSource
+                    , tm_typechecked_source  :: TypecheckedSource
+                    , tm_checked_module_info :: ModuleInfo
+                    , tm_internals_          :: (TcGblEnv, ModDetails)
+                    }
+
+instance ParsedMod TypecheckedModule where
+  modSummary m   = modSummary (tm_parsed_module m)
+  parsedSource m = parsedSource (tm_parsed_module m)
+
+instance TypecheckedMod TypecheckedModule where
+  renamedSource m     = tm_renamed_source m
+  typecheckedSource m = tm_typechecked_source m
+  moduleInfo m        = tm_checked_module_info m
+  tm_internals m      = tm_internals_ m
+
+-- | The result of successful desugaring (i.e., translation to core).  Also
+--  contains all the information of a typechecked module.
+data DesugaredModule =
+  DesugaredModule { dm_typechecked_module :: TypecheckedModule
+                  , dm_core_module        :: ModGuts
+             }
+
+instance ParsedMod DesugaredModule where
+  modSummary m   = modSummary (dm_typechecked_module m)
+  parsedSource m = parsedSource (dm_typechecked_module m)
+
+instance TypecheckedMod DesugaredModule where
+  renamedSource m     = renamedSource (dm_typechecked_module m)
+  typecheckedSource m = typecheckedSource (dm_typechecked_module m)
+  moduleInfo m        = moduleInfo (dm_typechecked_module m)
+  tm_internals m      = tm_internals_ (dm_typechecked_module m)
+
+instance DesugaredMod DesugaredModule where
+  coreModule m = dm_core_module m
+
+type ParsedSource      = Located (HsModule GhcPs)
+type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
+                          Maybe LHsDocString)
+type TypecheckedSource = LHsBinds GhcTc
+
+-- NOTE:
+--   - things that aren't in the output of the typechecker right now:
+--     - the export list
+--     - the imports
+--     - type signatures
+--     - type/data/newtype declarations
+--     - class declarations
+--     - instances
+--   - extra things in the typechecker's output:
+--     - default methods are turned into top-level decls.
+--     - dictionary bindings
+
+-- | Return the 'ModSummary' of a module with the given name.
+--
+-- The module must be part of the module graph (see 'hsc_mod_graph' and
+-- 'ModuleGraph').  If this is not the case, this function will throw a
+-- 'GhcApiError'.
+--
+-- This function ignores boot modules and requires that there is only one
+-- non-boot module with the given name.
+getModSummary :: GhcMonad m => ModuleName -> m ModSummary
+getModSummary mod = do
+   mg <- liftM hsc_mod_graph getSession
+   let mods_by_name = [ ms | ms <- mgModSummaries mg
+                      , ms_mod_name ms == mod
+                      , not (isBootSummary ms) ]
+   case mods_by_name of
+     [] -> do dflags <- getDynFlags
+              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
+     [ms] -> return ms
+     multiple -> do dflags <- getDynFlags
+                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
+
+-- | Parse a module.
+--
+-- Throws a 'SourceError' on parse error.
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
+   hsc_env <- getSession
+   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+   hpm <- liftIO $ hscParse hsc_env_tmp ms
+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
+                           (hpm_annotations hpm))
+               -- See Note [Api annotations] in ApiAnnotation.hs
+
+-- | Typecheck and rename a parsed module.
+--
+-- Throws a 'SourceError' if either fails.
+typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
+typecheckModule pmod = do
+ let ms = modSummary pmod
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ (tc_gbl_env, rn_info)
+       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
+                      HsParsedModule { hpm_module = parsedSource pmod,
+                                       hpm_src_files = pm_extra_src_files pmod,
+                                       hpm_annotations = pm_annotations pmod }
+ details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
+ safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
+
+ return $
+     TypecheckedModule {
+       tm_internals_          = (tc_gbl_env, details),
+       tm_parsed_module       = pmod,
+       tm_renamed_source      = rn_info,
+       tm_typechecked_source  = tcg_binds tc_gbl_env,
+       tm_checked_module_info =
+         ModuleInfo {
+           minf_type_env  = md_types details,
+           minf_exports   = md_exports details,
+           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
+           minf_instances = fixSafeInstances safe $ md_insts details,
+           minf_iface     = Nothing,
+           minf_safe      = safe,
+           minf_modBreaks = emptyModBreaks
+         }}
+
+-- | Desugar a typechecked module.
+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
+desugarModule tcm = do
+ let ms = modSummary tcm
+ let (tcg, _) = tm_internals tcm
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
+ return $
+     DesugaredModule {
+       dm_typechecked_module = tcm,
+       dm_core_module        = guts
+     }
+
+-- | Load a module.  Input doesn't need to be desugared.
+--
+-- A module must be loaded before dependent modules can be typechecked.  This
+-- always includes generating a 'ModIface' and, depending on the
+-- 'DynFlags.hscTarget', may also include code generation.
+--
+-- This function will always cause recompilation and will always overwrite
+-- previous compilation results (potentially files on disk).
+--
+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
+loadModule tcm = do
+   let ms = modSummary tcm
+   let mod = ms_mod_name ms
+   let loc = ms_location ms
+   let (tcg, _details) = tm_internals tcm
+
+   mb_linkable <- case ms_obj_date ms of
+                     Just t | t > ms_hs_date ms  -> do
+                         l <- liftIO $ findObjectLinkable (ms_mod ms)
+                                                  (ml_obj_file loc) t
+                         return (Just l)
+                     _otherwise -> return Nothing
+
+   let source_modified | isNothing mb_linkable = SourceModified
+                       | otherwise             = SourceUnmodified
+                       -- we can't determine stability here
+
+   -- compile doesn't change the session
+   hsc_env <- getSession
+   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
+                                    hsc_env ms 1 1 Nothing mb_linkable
+                                    source_modified
+
+   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
+   return tcm
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Dealing with Core
+-- %*                                                                      *
+-- %************************************************************************
+
+-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
+-- the 'GHC.compileToCoreModule' interface.
+data CoreModule
+  = CoreModule {
+      -- | Module name
+      cm_module   :: !Module,
+      -- | Type environment for types declared in this module
+      cm_types    :: !TypeEnv,
+      -- | Declarations
+      cm_binds    :: CoreProgram,
+      -- | Safe Haskell mode
+      cm_safe     :: SafeHaskellMode
+    }
+
+instance Outputable CoreModule where
+   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
+                    cm_safe = sf})
+    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
+      $$ vcat (map ppr cb)
+
+-- | This is the way to get access to the Core bindings corresponding
+-- to a module. 'compileToCore' parses, typechecks, and
+-- desugars the module, then returns the resulting Core module (consisting of
+-- the module name, type declarations, and function declarations) if
+-- successful.
+compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreSimplified = compileCore True
+
+compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
+compileCore simplify fn = do
+   -- First, set the target to the desired filename
+   target <- guessTarget fn Nothing
+   addTarget target
+   _ <- load LoadAllTargets
+   -- Then find dependencies
+   modGraph <- depanal [] True
+   case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of
+     Just modSummary -> do
+       -- Now we have the module name;
+       -- parse, typecheck and desugar the module
+       (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
+         do tm <- typecheckModule =<< parseModule modSummary
+            let tcg = fst (tm_internals tm)
+            (,) tcg . coreModule <$> desugarModule tm
+       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
+         if simplify
+          then do
+             -- If simplify is true: simplify (hscSimplify), then tidy
+             -- (tidyProgram).
+             hsc_env <- getSession
+             simpl_guts <- liftIO $ do
+               plugins <- readIORef (tcg_th_coreplugins tcg)
+               hscSimplify hsc_env plugins mod_guts
+             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
+             return $ Left tidy_guts
+          else
+             return $ Right mod_guts
+
+     Nothing -> panic "compileToCoreModule: target FilePath not found in\
+                           module dependency graph"
+  where -- two versions, based on whether we simplify (thus run tidyProgram,
+        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
+        -- we just have a ModGuts.
+        gutsToCoreModule :: SafeHaskellMode
+                         -> Either (CgGuts, ModDetails) ModGuts
+                         -> CoreModule
+        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
+          cm_module = cg_module cg,
+          cm_types  = md_types md,
+          cm_binds  = cg_binds cg,
+          cm_safe   = safe_mode
+        }
+        gutsToCoreModule safe_mode (Right mg) = CoreModule {
+          cm_module  = mg_module mg,
+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
+                                           (mg_tcs mg)
+                                           (mg_fam_insts mg),
+          cm_binds   = mg_binds mg,
+          cm_safe    = safe_mode
+         }
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Inspecting the session
+-- %*                                                                      *
+-- %************************************************************************
+
+-- | Get the module dependency graph.
+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
+getModuleGraph = liftM hsc_mod_graph getSession
+
+-- | Return @True@ <==> module is loaded.
+isLoaded :: GhcMonad m => ModuleName -> m Bool
+isLoaded m = withSession $ \hsc_env ->
+  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
+
+-- | Return the bindings for the current interactive session.
+getBindings :: GhcMonad m => m [TyThing]
+getBindings = withSession $ \hsc_env ->
+    return $ icInScopeTTs $ hsc_IC hsc_env
+
+-- | Return the instances for the current interactive session.
+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
+getInsts = withSession $ \hsc_env ->
+    return $ ic_instances (hsc_IC hsc_env)
+
+getPrintUnqual :: GhcMonad m => m PrintUnqualified
+getPrintUnqual = withSession $ \hsc_env ->
+  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
+
+-- | Container for information about a 'Module'.
+data ModuleInfo = ModuleInfo {
+        minf_type_env  :: TypeEnv,
+        minf_exports   :: [AvailInfo],
+        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
+        minf_instances :: [ClsInst],
+        minf_iface     :: Maybe ModIface,
+        minf_safe      :: SafeHaskellMode,
+        minf_modBreaks :: ModBreaks
+  }
+        -- We don't want HomeModInfo here, because a ModuleInfo applies
+        -- to package modules too.
+
+-- | Request information about a loaded 'Module'
+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
+getModuleInfo mdl = withSession $ \hsc_env -> do
+  let mg = hsc_mod_graph hsc_env
+  if mgElemModule mg mdl
+        then liftIO $ getHomeModuleInfo hsc_env mdl
+        else do
+  {- if isHomeModule (hsc_dflags hsc_env) mdl
+        then return Nothing
+        else -} liftIO $ getPackageModuleInfo hsc_env mdl
+   -- ToDo: we don't understand what the following comment means.
+   --    (SDM, 19/7/2011)
+   -- getPackageModuleInfo will attempt to find the interface, so
+   -- we don't want to call it for a home module, just in case there
+   -- was a problem loading the module and the interface doesn't
+   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
+
+getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
+getPackageModuleInfo hsc_env mdl
+  = do  eps <- hscEPS hsc_env
+        iface <- hscGetModuleInterface hsc_env mdl
+        let
+            avails = mi_exports iface
+            pte    = eps_PTE eps
+            tys    = [ ty | name <- concatMap availNames avails,
+                            Just ty <- [lookupTypeEnv pte name] ]
+        --
+        return (Just (ModuleInfo {
+                        minf_type_env  = mkTypeEnv tys,
+                        minf_exports   = avails,
+                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
+                        minf_iface     = Just iface,
+                        minf_safe      = getSafeMode $ mi_trust iface,
+                        minf_modBreaks = emptyModBreaks
+                }))
+
+getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
+getHomeModuleInfo hsc_env mdl =
+  case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of
+    Nothing  -> return Nothing
+    Just hmi -> do
+      let details = hm_details hmi
+          iface   = hm_iface hmi
+      return (Just (ModuleInfo {
+                        minf_type_env  = md_types details,
+                        minf_exports   = md_exports details,
+                        minf_rdr_env   = mi_globals $! hm_iface hmi,
+                        minf_instances = md_insts details,
+                        minf_iface     = Just iface,
+                        minf_safe      = getSafeMode $ mi_trust iface
+                       ,minf_modBreaks = getModBreaks hmi
+                        }))
+
+-- | The list of top-level entities defined in a module
+modInfoTyThings :: ModuleInfo -> [TyThing]
+modInfoTyThings minf = typeEnvElts (minf_type_env minf)
+
+modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
+modInfoTopLevelScope minf
+  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
+
+modInfoExports :: ModuleInfo -> [Name]
+modInfoExports minf = concatMap availNames $! minf_exports minf
+
+modInfoExportsWithSelectors :: ModuleInfo -> [Name]
+modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
+
+-- | Returns the instances defined by the specified module.
+-- Warning: currently unimplemented for package modules.
+modInfoInstances :: ModuleInfo -> [ClsInst]
+modInfoInstances = minf_instances
+
+modInfoIsExportedName :: ModuleInfo -> Name -> Bool
+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
+
+mkPrintUnqualifiedForModule :: GhcMonad m =>
+                               ModuleInfo
+                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
+mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
+  return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
+
+modInfoLookupName :: GhcMonad m =>
+                     ModuleInfo -> Name
+                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
+modInfoLookupName minf name = withSession $ \hsc_env -> do
+   case lookupTypeEnv (minf_type_env minf) name of
+     Just tyThing -> return (Just tyThing)
+     Nothing      -> do
+       eps <- liftIO $ readIORef (hsc_EPS hsc_env)
+       return $! lookupType (hsc_dflags hsc_env)
+                            (hsc_HPT hsc_env) (eps_PTE eps) name
+
+modInfoIface :: ModuleInfo -> Maybe ModIface
+modInfoIface = minf_iface
+
+-- | Retrieve module safe haskell mode
+modInfoSafe :: ModuleInfo -> SafeHaskellMode
+modInfoSafe = minf_safe
+
+modInfoModBreaks :: ModuleInfo -> ModBreaks
+modInfoModBreaks = minf_modBreaks
+
+isDictonaryId :: Id -> Bool
+isDictonaryId id
+  = case tcSplitSigmaTy (idType id) of {
+      (_tvs, _theta, tau) -> isDictTy tau }
+
+-- | Looks up a global name: that is, any top-level name in any
+-- visible module.  Unlike 'lookupName', lookupGlobalName does not use
+-- the interactive context, and therefore does not require a preceding
+-- 'setContext'.
+lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupGlobalName name = withSession $ \hsc_env -> do
+   liftIO $ lookupTypeHscEnv hsc_env name
+
+findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
+findGlobalAnns deserialize target = withSession $ \hsc_env -> do
+    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
+    return (findAnns deserialize ann_env target)
+
+-- | get the GlobalRdrEnv for a session
+getGRE :: GhcMonad m => m GlobalRdrEnv
+getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
+
+-- | Retrieve all type and family instances in the environment, indexed
+-- by 'Name'. Each name's lists will contain every instance in which that name
+-- is mentioned in the instance head.
+getNameToInstancesIndex :: GhcMonad m
+  => [Module]        -- ^ visible modules. An orphan instance will be returned
+                     -- if it is visible from at least one module in the list.
+  -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
+                     -- modules for everything that is in scope unqualified.
+  -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
+getNameToInstancesIndex visible_mods mods_to_load = do
+  hsc_env <- getSession
+  liftIO $ runTcInteractive hsc_env $
+    do { case mods_to_load of
+           Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+           Just mods ->
+             let doc = text "Need interface for reporting instances in scope"
+             in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
+
+       ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
+       ; let visible_mods' = mkModuleSet visible_mods
+       ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
+       -- We use Data.Sequence.Seq because we are creating left associated
+       -- mappends.
+       -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts
+       ; let cls_index = Map.fromListWith mappend
+                 [ (n, Seq.singleton ispec)
+                 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
+                 , instIsVisible visible_mods' ispec
+                 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
+                 ]
+       ; let fam_index = Map.fromListWith mappend
+                 [ (n, Seq.singleton fispec)
+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
+                 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec
+                 ]
+       ; return $ mkNameEnv $
+           [ (nm, (toList clss, toList fams))
+           | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
+               (fmap (,Seq.empty) cls_index)
+               (fmap (Seq.empty,) fam_index)
+           ] }
+
+-- -----------------------------------------------------------------------------
+
+{- ToDo: Move the primary logic here to compiler/main/Packages.hs
+-- | Return all /external/ modules available in the package database.
+-- Modules from the current session (i.e., from the 'HomePackageTable') are
+-- not included.  This includes module names which are reexported by packages.
+packageDbModules :: GhcMonad m =>
+                    Bool  -- ^ Only consider exposed packages.
+                 -> m [Module]
+packageDbModules only_exposed = do
+   dflags <- getSessionDynFlags
+   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
+   return $
+     [ mkModule pid modname
+     | p <- pkgs
+     , not only_exposed || exposed p
+     , let pid = packageConfigId p
+     , modname <- exposedModules p
+               ++ map exportName (reexportedModules p) ]
+               -}
+
+-- -----------------------------------------------------------------------------
+-- Misc exported utils
+
+dataConType :: DataCon -> Type
+dataConType dc = idType (dataConWrapId dc)
+
+-- | print a 'NamedThing', adding parentheses if the name is an operator.
+pprParenSymName :: NamedThing a => a -> SDoc
+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
+
+-- ----------------------------------------------------------------------------
+
+
+-- ToDo:
+--   - Data and Typeable instances for HsSyn.
+
+-- ToDo: check for small transformations that happen to the syntax in
+-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
+
+-- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
+-- to get from TyCons, Ids etc. to TH syntax (reify).
+
+-- :browse will use either lm_toplev or inspect lm_interface, depending
+-- on whether the module is interpreted or not.
+
+
+-- Extract the filename, stringbuffer content and dynflags associed to a module
+--
+-- XXX: Explain pre-conditions
+getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags mod = do
+  m <- getModSummary (moduleName mod)
+  case ml_hs_file $ ms_location m of
+    Nothing -> do dflags <- getDynFlags
+                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
+    Just sourceFile -> do
+        source <- liftIO $ hGetStringBuffer sourceFile
+        return (sourceFile, source, ms_hspp_opts m)
+
+
+-- | Return module source as token stream, including comments.
+--
+-- The module must be in the module graph and its source must be available.
+-- Throws a 'HscTypes.SourceError' on parse error.
+getTokenStream :: GhcMonad m => Module -> m [Located Token]
+getTokenStream mod = do
+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+  case lexTokenStream source startLoc flags of
+    POk _ ts  -> return ts
+    PFailed pst ->
+        do dflags <- getDynFlags
+           throwErrors (getErrorMessages pst dflags)
+
+-- | Give even more information on the source than 'getTokenStream'
+-- This function allows reconstructing the source completely with
+-- 'showRichTokenStream'.
+getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
+getRichTokenStream mod = do
+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+  case lexTokenStream source startLoc flags of
+    POk _ ts -> return $ addSourceToTokens startLoc source ts
+    PFailed pst ->
+        do dflags <- getDynFlags
+           throwErrors (getErrorMessages pst dflags)
+
+-- | Given a source location and a StringBuffer corresponding to this
+-- location, return a rich token stream with the source associated to the
+-- tokens.
+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
+                  -> [(Located Token, String)]
+addSourceToTokens _ _ [] = []
+addSourceToTokens loc buf (t@(dL->L span _) : ts)
+    = case span of
+      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
+      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts
+        where
+          (newLoc, newBuf, str) = go "" loc buf
+          start = realSrcSpanStart s
+          end = realSrcSpanEnd s
+          go acc loc buf | loc < start = go acc nLoc nBuf
+                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf
+                         | otherwise = (loc, buf, reverse acc)
+              where (ch, nBuf) = nextChar buf
+                    nLoc = advanceSrcLoc loc ch
+
+
+-- | Take a rich token stream such as produced from 'getRichTokenStream' and
+-- return source code almost identical to the original code (except for
+-- insignificant whitespace.)
+showRichTokenStream :: [(Located Token, String)] -> String
+showRichTokenStream ts = go startLoc ts ""
+    where sourceFile = getFile $ map (getLoc . fst) ts
+          getFile [] = panic "showRichTokenStream: No source file found"
+          getFile (UnhelpfulSpan _ : xs) = getFile xs
+          getFile (RealSrcSpan s : _) = srcSpanFile s
+          startLoc = mkRealSrcLoc sourceFile 1 1
+          go _ [] = id
+          go loc ((dL->L span _, str):ts)
+              = case span of
+                UnhelpfulSpan _ -> go loc ts
+                RealSrcSpan s
+                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
+                                       . (str ++)
+                                       . go tokEnd ts
+                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
+                               . ((replicate (tokCol - 1) ' ') ++)
+                              . (str ++)
+                              . go tokEnd ts
+                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
+                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
+                        tokEnd = realSrcSpanEnd s
+
+-- -----------------------------------------------------------------------------
+-- Interactive evaluation
+
+-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
+-- filesystem and package database to find the corresponding 'Module',
+-- using the algorithm that is used for an @import@ declaration.
+findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
+  let
+    dflags   = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+  --
+  case maybe_pkg of
+    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+      res <- findImportedModule hsc_env mod_name maybe_pkg
+      case res of
+        Found _ m -> return m
+        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err
+    _otherwise -> do
+      home <- lookupLoadedHomeModule mod_name
+      case home of
+        Just m  -> return m
+        Nothing -> liftIO $ do
+           res <- findImportedModule hsc_env mod_name maybe_pkg
+           case res of
+             Found loc m | moduleUnitId m /= this_pkg -> return m
+                         | otherwise -> modNotLoadedError dflags m loc
+             err -> throwOneError $ noModError dflags noSrcSpan mod_name err
+
+modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
+modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
+   text "module is not loaded:" <+>
+   quotes (ppr (moduleName m)) <+>
+   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
+
+-- | Like 'findModule', but differs slightly when the module refers to
+-- a source file, and the file has not been loaded via 'load'.  In
+-- this case, 'findModule' will throw an error (module not loaded),
+-- but 'lookupModule' will check to see whether the module can also be
+-- found in a package, and if so, that package 'Module' will be
+-- returned.  If not, the usual module-not-found error will be thrown.
+--
+lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
+lookupModule mod_name Nothing = withSession $ \hsc_env -> do
+  home <- lookupLoadedHomeModule mod_name
+  case home of
+    Just m  -> return m
+    Nothing -> liftIO $ do
+      res <- findExposedPackageModule hsc_env mod_name Nothing
+      case res of
+        Found _ m -> return m
+        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
+
+lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
+lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
+  case lookupHpt (hsc_HPT hsc_env) mod_name of
+    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))
+    _not_a_home_module -> return Nothing
+
+-- | Check that a module is safe to import (according to Safe Haskell).
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an error may be thrown first.
+isModuleTrusted :: GhcMonad m => Module -> m Bool
+isModuleTrusted m = withSession $ \hsc_env ->
+    liftIO $ hscCheckSafe hsc_env m noSrcSpan
+
+-- | Return if a module is trusted and the pkgs it depends on to be trusted.
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)
+moduleTrustReqs m = withSession $ \hsc_env ->
+    liftIO $ hscGetSafe hsc_env m noSrcSpan
+
+-- | Set the monad GHCi lifts user statements into.
+--
+-- Checks that a type (in string form) is an instance of the
+-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
+-- throws an error otherwise.
+setGHCiMonad :: GhcMonad m => String -> m ()
+setGHCiMonad name = withSession $ \hsc_env -> do
+    ty <- liftIO $ hscIsGHCiMonad hsc_env name
+    modifySession $ \s ->
+        let ic = (hsc_IC s) { ic_monad = ty }
+        in s { hsc_IC = ic }
+
+-- | Get the monad GHCi lifts user statements into.
+getGHCiMonad :: GhcMonad m => m Name
+getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
+
+getHistorySpan :: GhcMonad m => History -> m SrcSpan
+getHistorySpan h = withSession $ \hsc_env ->
+    return $ InteractiveEval.getHistorySpan hsc_env h
+
+obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
+    liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
+
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id = withSession $ \hsc_env ->
+    liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
+
+
+-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
+-- entity known to GHC, including 'Name's defined using 'runStmt'.
+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupName name =
+     withSession $ \hsc_env ->
+       liftIO $ hscTcRcLookupName hsc_env name
+
+-- -----------------------------------------------------------------------------
+-- Pure API
+
+-- | A pure interface to the module parser.
+--
+parser :: String         -- ^ Haskell module source text (full Unicode is supported)
+       -> DynFlags       -- ^ the flags
+       -> FilePath       -- ^ the filename (for source locations)
+       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))
+
+parser str dflags filename =
+   let
+       loc  = mkRealSrcLoc (mkFastString filename) 1 1
+       buf  = stringToStringBuffer str
+   in
+   case unP Parser.parseModule (mkPState dflags buf loc) of
+
+     PFailed pst ->
+         let (warns,errs) = getMessages pst dflags in
+         (warns, Left errs)
+
+     POk pst rdr_module ->
+         let (warns,_) = getMessages pst dflags in
+         (warns, Right rdr_module)
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/GhcMake.hs
@@ -0,0 +1,2598 @@
+{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- This module implements multi-module compilation, and is used
+-- by --make and GHCi.
+--
+-- -----------------------------------------------------------------------------
+module GhcMake(
+        depanal,
+        load, load', LoadHowMuch(..),
+
+        topSortModuleGraph,
+
+        ms_home_srcimps, ms_home_imps,
+
+        IsBoot(..),
+        summariseModule,
+        hscSourceToIsBoot,
+        findExtraSigImports,
+        implicitRequirements,
+
+        noModError, cyclicModuleErr,
+        moduleGraphNodes, SummaryNode
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import qualified Linker         ( unload )
+
+import DriverPhases
+import DriverPipeline
+import DynFlags
+import ErrUtils
+import Finder
+import GhcMonad
+import HeaderInfo
+import HscTypes
+import Module
+import TcIface          ( typecheckIface )
+import TcRnMonad        ( initIfaceCheck )
+import HscMain
+
+import Bag              ( listToBag )
+import BasicTypes
+import Digraph
+import Exception        ( tryIO, gbracket, gfinally )
+import FastString
+import Maybes           ( expectJust )
+import Name
+import MonadUtils       ( allM, MonadIO )
+import Outputable
+import Panic
+import SrcLoc
+import StringBuffer
+import UniqFM
+import UniqDSet
+import TcBackpack
+import Packages
+import UniqSet
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import NameEnv
+import FileCleanup
+
+import Data.Either ( rights, partitionEithers )
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import qualified FiniteMap as Map ( insertListWith )
+
+import Control.Concurrent ( forkIOWithUnmask, killThread )
+import qualified GHC.Conc as CC
+import Control.Concurrent.MVar
+import Control.Concurrent.QSem
+import Control.Exception
+import Control.Monad
+import Data.IORef
+import Data.List
+import qualified Data.List as List
+import Data.Foldable (toList)
+import Data.Maybe
+import Data.Ord ( comparing )
+import Data.Time
+import System.Directory
+import System.FilePath
+import System.IO        ( fixIO )
+import System.IO.Error  ( isDoesNotExistError )
+
+import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
+
+label_self :: String -> IO ()
+label_self thread_name = do
+    self_tid <- CC.myThreadId
+    CC.labelThread self_tid thread_name
+
+-- -----------------------------------------------------------------------------
+-- Loading the program
+
+-- | Perform a dependency analysis starting from the current targets
+-- and update the session with the new module graph.
+--
+-- Dependency analysis entails parsing the @import@ directives and may
+-- therefore require running certain preprocessors.
+--
+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
+-- changes to the 'DynFlags' to take effect you need to call this function
+-- again.
+--
+depanal :: GhcMonad m =>
+           [ModuleName]  -- ^ excluded modules
+        -> Bool          -- ^ allow duplicate roots
+        -> m ModuleGraph
+depanal excluded_mods allow_dup_roots = do
+  hsc_env <- getSession
+  let
+         dflags  = hsc_dflags hsc_env
+         targets = hsc_targets hsc_env
+         old_graph = hsc_mod_graph hsc_env
+
+  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
+    liftIO $ debugTraceMsg dflags 2 (hcat [
+              text "Chasing modules from: ",
+              hcat (punctuate comma (map pprTarget targets))])
+
+    -- Home package modules may have been moved or deleted, and new
+    -- source files may have appeared in the home package that shadow
+    -- external package modules, so we have to discard the existing
+    -- cached finder data.
+    liftIO $ flushFinderCaches hsc_env
+
+    mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)
+                                     excluded_mods allow_dup_roots
+    mod_summaries <- reportImportErrors mod_summariesE
+
+    let mod_graph = mkModuleGraph mod_summaries
+
+    warnMissingHomeModules hsc_env mod_graph
+
+    setSession hsc_env { hsc_mod_graph = mod_graph }
+    return mod_graph
+
+-- Note [Missing home modules]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
+-- in a command line. For example, cabal may want to enable this warning
+-- when building a library, so that GHC warns user about modules, not listed
+-- neither in `exposed-modules`, nor in `other-modules`.
+--
+-- Here "home module" means a module, that doesn't come from an other package.
+--
+-- For example, if GHC is invoked with modules "A" and "B" as targets,
+-- but "A" imports some other module "C", then GHC will issue a warning
+-- about module "C" not being listed in a command line.
+--
+-- The warning in enabled by `-Wmissing-home-modules`. See #13129
+warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
+warnMissingHomeModules hsc_env mod_graph =
+    when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $
+        logWarnings (listToBag [warn])
+  where
+    dflags = hsc_dflags hsc_env
+    targets = map targetId (hsc_targets hsc_env)
+
+    is_known_module mod = any (is_my_target mod) targets
+
+    -- We need to be careful to handle the case where (possibly
+    -- path-qualified) filenames (aka 'TargetFile') rather than module
+    -- names are being passed on the GHC command-line.
+    --
+    -- For instance, `ghc --make src-exe/Main.hs` and
+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
+    -- Note also that we can't always infer the associated module name
+    -- directly from the filename argument.  See #13727.
+    is_my_target mod (TargetModule name)
+      = moduleName (ms_mod mod) == name
+    is_my_target mod (TargetFile target_file _)
+      | Just mod_file <- ml_hs_file (ms_location mod)
+      = target_file == mod_file ||
+           --  We can get a file target even if a module name was
+           --  originally specified in a command line because it can
+           --  be converted in guessTarget (by appending .hs/.lhs).
+           --  So let's convert it back and compare with module name
+           mkModuleName (fst $ splitExtension target_file)
+            == moduleName (ms_mod mod)
+    is_my_target _ _ = False
+
+    missing = map (moduleName . ms_mod) $
+      filter (not . is_known_module) (mgModSummaries mod_graph)
+
+    msg
+      | gopt Opt_BuildingCabalPackage dflags
+      = hang
+          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
+          4
+          (sep (map ppr missing))
+      | otherwise
+      =
+        hang
+          (text "Modules are not listed in command line but needed for compilation: ")
+          4
+          (sep (map ppr missing))
+    warn = makeIntoWarning
+      (Reason Opt_WarnMissingHomeModules)
+      (mkPlainErrMsg dflags noSrcSpan msg)
+
+-- | Describes which modules of the module graph need to be loaded.
+data LoadHowMuch
+   = LoadAllTargets
+     -- ^ Load all targets and its dependencies.
+   | LoadUpTo ModuleName
+     -- ^ Load only the given module and its dependencies.
+   | LoadDependenciesOf ModuleName
+     -- ^ Load only the dependencies of the given module, but not the module
+     -- itself.
+
+-- | Try to load the program.  See 'LoadHowMuch' for the different modes.
+--
+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,
+-- compiles and loads the specified modules, avoiding re-compilation wherever
+-- possible.  Depending on the target (see 'DynFlags.hscTarget') compiling
+-- and loading may result in files being created on disk.
+--
+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
+-- successful or not.
+--
+-- Throw a 'SourceError' if errors are encountered before the actual
+-- compilation starts (e.g., during dependency analysis).  All other errors
+-- are reported using the 'defaultWarnErrLogger'.
+--
+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
+load how_much = do
+    mod_graph <- depanal [] False
+    load' how_much (Just batchMsg) mod_graph
+
+-- | Generalized version of 'load' which also supports a custom
+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
+-- produced by calling 'depanal'.
+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
+load' how_much mHscMessage mod_graph = do
+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
+    guessOutputFile
+    hsc_env <- getSession
+
+    let hpt1   = hsc_HPT hsc_env
+    let dflags = hsc_dflags hsc_env
+
+    -- The "bad" boot modules are the ones for which we have
+    -- B.hs-boot in the module graph, but no B.hs
+    -- The downsweep should have ensured this does not happen
+    -- (see msDeps)
+    let all_home_mods =
+          mkUniqSet [ ms_mod_name s
+                    | s <- mgModSummaries mod_graph, not (isBootSummary s)]
+    -- TODO: Figure out what the correct form of this assert is. It's violated
+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
+    -- files without corresponding hs files.
+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
+    --                              not (ms_mod_name s `elem` all_home_mods)]
+    -- ASSERT( null bad_boot_mods ) return ()
+
+    -- check that the module given in HowMuch actually exists, otherwise
+    -- topSortModuleGraph will bomb later.
+    let checkHowMuch (LoadUpTo m)           = checkMod m
+        checkHowMuch (LoadDependenciesOf m) = checkMod m
+        checkHowMuch _ = id
+
+        checkMod m and_then
+            | m `elementOfUniqSet` all_home_mods = and_then
+            | otherwise = do
+                    liftIO $ errorMsg dflags (text "no such module:" <+>
+                                     quotes (ppr m))
+                    return Failed
+
+    checkHowMuch how_much $ do
+
+    -- mg2_with_srcimps drops the hi-boot nodes, returning a
+    -- graph with cycles.  Among other things, it is used for
+    -- backing out partially complete cycles following a failed
+    -- upsweep, and for removing from hpt all the modules
+    -- not in strict downwards closure, during calls to compile.
+    let mg2_with_srcimps :: [SCC ModSummary]
+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
+
+    -- If we can determine that any of the {-# SOURCE #-} imports
+    -- are definitely unnecessary, then emit a warning.
+    warnUnnecessarySourceImports mg2_with_srcimps
+
+    let
+        -- check the stability property for each module.
+        stable_mods@(stable_obj,stable_bco)
+            = checkStability hpt1 mg2_with_srcimps all_home_mods
+
+        -- prune bits of the HPT which are definitely redundant now,
+        -- to save space.
+        pruned_hpt = pruneHomePackageTable hpt1
+                            (flattenSCCs mg2_with_srcimps)
+                            stable_mods
+
+    _ <- liftIO $ evaluate pruned_hpt
+
+    -- before we unload anything, make sure we don't leave an old
+    -- interactive context around pointing to dead bindings.  Also,
+    -- write the pruned HPT to allow the old HPT to be GC'd.
+    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
+
+    liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+                            text "Stable BCO:" <+> ppr stable_bco)
+
+    -- Unload any modules which are going to be re-linked this time around.
+    let stable_linkables = [ linkable
+                           | m <- nonDetEltsUniqSet stable_obj ++
+                                  nonDetEltsUniqSet stable_bco,
+                             -- It's OK to use nonDetEltsUniqSet here
+                             -- because it only affects linking. Besides
+                             -- this list only serves as a poor man's set.
+                             Just hmi <- [lookupHpt pruned_hpt m],
+                             Just linkable <- [hm_linkable hmi] ]
+    liftIO $ unload hsc_env stable_linkables
+
+    -- We could at this point detect cycles which aren't broken by
+    -- a source-import, and complain immediately, but it seems better
+    -- to let upsweep_mods do this, so at least some useful work gets
+    -- done before the upsweep is abandoned.
+    --hPutStrLn stderr "after tsort:\n"
+    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
+
+    -- Now do the upsweep, calling compile for each module in
+    -- turn.  Final result is version 3 of everything.
+
+    -- Topologically sort the module graph, this time including hi-boot
+    -- nodes, and possibly just including the portion of the graph
+    -- reachable from the module specified in the 2nd argument to load.
+    -- This graph should be cycle-free.
+    -- If we're restricting the upsweep to a portion of the graph, we
+    -- also want to retain everything that is still stable.
+    let full_mg :: [SCC ModSummary]
+        full_mg    = topSortModuleGraph False mod_graph Nothing
+
+        maybe_top_mod = case how_much of
+                            LoadUpTo m           -> Just m
+                            LoadDependenciesOf m -> Just m
+                            _                    -> Nothing
+
+        partial_mg0 :: [SCC ModSummary]
+        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
+
+        -- LoadDependenciesOf m: we want the upsweep to stop just
+        -- short of the specified module (unless the specified module
+        -- is stable).
+        partial_mg
+            | LoadDependenciesOf _mod <- how_much
+            = ASSERT( case last partial_mg0 of
+                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
+              List.init partial_mg0
+            | otherwise
+            = partial_mg0
+
+        stable_mg =
+            [ AcyclicSCC ms
+            | AcyclicSCC ms <- full_mg,
+              stable_mod_summary ms ]
+
+        stable_mod_summary ms =
+          ms_mod_name ms `elementOfUniqSet` stable_obj ||
+          ms_mod_name ms `elementOfUniqSet` stable_bco
+
+        -- the modules from partial_mg that are not also stable
+        -- NB. also keep cycles, we need to emit an error message later
+        unstable_mg = filter not_stable partial_mg
+          where not_stable (CyclicSCC _) = True
+                not_stable (AcyclicSCC ms)
+                   = not $ stable_mod_summary ms
+
+        -- Load all the stable modules first, before attempting to load
+        -- an unstable module (#7231).
+        mg = stable_mg ++ unstable_mg
+
+    -- clean up between compilations
+    let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
+    liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+                               2 (ppr mg))
+
+    n_jobs <- case parMakeCount dflags of
+                    Nothing -> liftIO getNumProcessors
+                    Just n  -> return n
+    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
+                   | otherwise  = upsweep
+
+    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
+    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $
+      upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
+
+    -- Make modsDone be the summaries for each home module now
+    -- available; this should equal the domain of hpt3.
+    -- Get in in a roughly top .. bottom order (hence reverse).
+
+    let modsDone = reverse modsUpswept
+
+    -- Try and do linking in some form, depending on whether the
+    -- upsweep was completely or only partially successful.
+
+    if succeeded upsweep_ok
+
+     then
+       -- Easy; just relink it all.
+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
+
+          -- Clean up after ourselves
+          hsc_env1 <- getSession
+          liftIO $ cleanCurrentModuleTempFiles dflags
+
+          -- Issue a warning for the confusing case where the user
+          -- said '-o foo' but we're not going to do any linking.
+          -- We attempt linking if either (a) one of the modules is
+          -- called Main, or (b) the user said -no-hs-main, indicating
+          -- that main() is going to come from somewhere else.
+          --
+          let ofile = outputFile dflags
+          let no_hs_main = gopt Opt_NoHsMain dflags
+          let
+            main_mod = mainModIs dflags
+            a_root_is_Main = mgElemModule mod_graph main_mod
+            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
+
+          -- link everything together
+          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
+
+          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
+             then do
+                liftIO $ errorMsg dflags $ text
+                   ("output was redirected with -o, " ++
+                    "but no output will be generated\n" ++
+                    "because there is no " ++
+                    moduleNameString (moduleName main_mod) ++ " module.")
+                -- This should be an error, not a warning (#10895).
+                loadFinish Failed linkresult
+             else
+                loadFinish Succeeded linkresult
+
+     else
+       -- Tricky.  We need to back out the effects of compiling any
+       -- half-done cycles, both so as to clean up the top level envs
+       -- and to avoid telling the interactive linker to link them.
+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
+
+          let modsDone_names
+                 = map ms_mod modsDone
+          let mods_to_zap_names
+                 = findPartiallyCompletedCycles modsDone_names
+                      mg2_with_srcimps
+          let (mods_to_clean, mods_to_keep) =
+                partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone
+          hsc_env1 <- getSession
+          let hpt4 = hsc_HPT hsc_env1
+              -- We must change the lifetime to TFL_CurrentModule for any temp
+              -- file created for an element of mod_to_clean during the upsweep.
+              -- These include preprocessed files and object files for loaded
+              -- modules.
+              unneeded_temps = concat
+                [ms_hspp_file : object_files
+                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
+                , let object_files = maybe [] linkableObjs $
+                        lookupHpt hpt4 (moduleName ms_mod)
+                        >>= hm_linkable
+                ]
+          liftIO $
+            changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
+          liftIO $ cleanCurrentModuleTempFiles dflags
+
+          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
+                                          hpt4
+
+          -- Clean up after ourselves
+
+          -- there should be no Nothings where linkables should be, now
+          let just_linkables =
+                    isNoLink (ghcLink dflags)
+                 || allHpt (isJust.hm_linkable)
+                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
+                                hpt5)
+          ASSERT( just_linkables ) do
+
+          -- Link everything together
+          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
+
+          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
+          loadFinish Failed linkresult
+
+
+-- | Finish up after a load.
+loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
+
+-- If the link failed, unload everything and return.
+loadFinish _all_ok Failed
+  = do hsc_env <- getSession
+       liftIO $ unload hsc_env []
+       modifySession discardProg
+       return Failed
+
+-- Empty the interactive context and set the module context to the topmost
+-- newly loaded module, or the Prelude if none were loaded.
+loadFinish all_ok Succeeded
+  = do modifySession discardIC
+       return all_ok
+
+
+-- | Forget the current program, but retain the persistent info in HscEnv
+discardProg :: HscEnv -> HscEnv
+discardProg hsc_env
+  = discardIC $ hsc_env { hsc_mod_graph = emptyMG
+                        , hsc_HPT = emptyHomePackageTable }
+
+-- | Discard the contents of the InteractiveContext, but keep the DynFlags.
+-- It will also keep ic_int_print and ic_monad if their names are from
+-- external packages.
+discardIC :: HscEnv -> HscEnv
+discardIC hsc_env
+  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
+                                , ic_monad = new_ic_monad } }
+  where
+  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
+  !new_ic_int_print = keep_external_name ic_int_print
+  !new_ic_monad = keep_external_name ic_monad
+  dflags = ic_dflags old_ic
+  old_ic = hsc_IC hsc_env
+  empty_ic = emptyInteractiveContext dflags
+  keep_external_name ic_name
+    | nameIsFromExternalPackage this_pkg old_name = old_name
+    | otherwise = ic_name empty_ic
+    where
+    this_pkg = thisPackage dflags
+    old_name = ic_name old_ic
+
+-- | If there is no -o option, guess the name of target executable
+-- by using top-level source file name as a base.
+guessOutputFile :: GhcMonad m => m ()
+guessOutputFile = modifySession $ \env ->
+    let dflags = hsc_dflags env
+        -- Force mod_graph to avoid leaking env
+        !mod_graph = hsc_mod_graph env
+        mainModuleSrcPath :: Maybe String
+        mainModuleSrcPath = do
+            ms <- mgLookupModule mod_graph (mainModIs dflags)
+            ml_hs_file (ms_location ms)
+        name = fmap dropExtension mainModuleSrcPath
+
+        name_exe = do
+#if defined(mingw32_HOST_OS)
+          -- we must add the .exe extension unconditionally here, otherwise
+          -- when name has an extension of its own, the .exe extension will
+          -- not be added by DriverPipeline.exeFileName.  See #2248
+          name' <- fmap (<.> "exe") name
+#else
+          name' <- name
+#endif
+          mainModuleSrcPath' <- mainModuleSrcPath
+          -- #9930: don't clobber input files (unless they ask for it)
+          if name' == mainModuleSrcPath'
+            then throwGhcException . UsageError $
+                 "default output name would overwrite the input file; " ++
+                 "must specify -o explicitly"
+            else Just name'
+    in
+    case outputFile dflags of
+        Just _ -> env
+        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
+
+-- -----------------------------------------------------------------------------
+--
+-- | Prune the HomePackageTable
+--
+-- Before doing an upsweep, we can throw away:
+--
+--   - For non-stable modules:
+--      - all ModDetails, all linked code
+--   - all unlinked code that is out of date with respect to
+--     the source file
+--
+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
+-- space at the end of the upsweep, because the topmost ModDetails of the
+-- old HPT holds on to the entire type environment from the previous
+-- compilation.
+pruneHomePackageTable :: HomePackageTable
+                      -> [ModSummary]
+                      -> StableModules
+                      -> HomePackageTable
+pruneHomePackageTable hpt summ (stable_obj, stable_bco)
+  = mapHpt prune hpt
+  where prune hmi
+          | is_stable modl = hmi'
+          | otherwise      = hmi'{ hm_details = emptyModDetails }
+          where
+           modl = moduleName (mi_module (hm_iface hmi))
+           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
+                = hmi{ hm_linkable = Nothing }
+                | otherwise
+                = hmi
+                where ms = expectJust "prune" (lookupUFM ms_map modl)
+
+        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
+
+        is_stable m =
+          m `elementOfUniqSet` stable_obj ||
+          m `elementOfUniqSet` stable_bco
+
+-- -----------------------------------------------------------------------------
+--
+-- | Return (names of) all those in modsDone who are part of a cycle as defined
+-- by theGraph.
+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
+findPartiallyCompletedCycles modsDone theGraph
+   = Set.unions
+       [mods_in_this_cycle
+       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.
+       , let names_in_this_cycle = Set.fromList (map ms_mod vs)
+             mods_in_this_cycle =
+                    Set.intersection (Set.fromList modsDone) names_in_this_cycle
+         -- If size mods_in_this_cycle == size names_in_this_cycle,
+         -- then this cycle has already been completed and we're not
+         -- interested.
+       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]
+
+
+-- ---------------------------------------------------------------------------
+--
+-- | Unloading
+unload :: HscEnv -> [Linkable] -> IO ()
+unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
+  = case ghcLink (hsc_dflags hsc_env) of
+        LinkInMemory -> Linker.unload hsc_env stable_linkables
+        _other -> return ()
+
+-- -----------------------------------------------------------------------------
+{- |
+
+  Stability tells us which modules definitely do not need to be recompiled.
+  There are two main reasons for having stability:
+
+   - avoid doing a complete upsweep of the module graph in GHCi when
+     modules near the bottom of the tree have not changed.
+
+   - to tell GHCi when it can load object code: we can only load object code
+     for a module when we also load object code fo  all of the imports of the
+     module.  So we need to know that we will definitely not be recompiling
+     any of these modules, and we can use the object code.
+
+  The stability check is as follows.  Both stableObject and
+  stableBCO are used during the upsweep phase later.
+
+@
+  stable m = stableObject m || stableBCO m
+
+  stableObject m =
+        all stableObject (imports m)
+        && old linkable does not exist, or is == on-disk .o
+        && date(on-disk .o) > date(.hs)
+
+  stableBCO m =
+        all stable (imports m)
+        && date(BCO) > date(.hs)
+@
+
+  These properties embody the following ideas:
+
+    - if a module is stable, then:
+
+        - if it has been compiled in a previous pass (present in HPT)
+          then it does not need to be compiled or re-linked.
+
+        - if it has not been compiled in a previous pass,
+          then we only need to read its .hi file from disk and
+          link it to produce a 'ModDetails'.
+
+    - if a modules is not stable, we will definitely be at least
+      re-linking, and possibly re-compiling it during the 'upsweep'.
+      All non-stable modules can (and should) therefore be unlinked
+      before the 'upsweep'.
+
+    - Note that objects are only considered stable if they only depend
+      on other objects.  We can't link object code against byte code.
+
+    - Note that even if an object is stable, we may end up recompiling
+      if the interface is out of date because an *external* interface
+      has changed.  The current code in GhcMake handles this case
+      fairly poorly, so be careful.
+-}
+
+type StableModules =
+  ( UniqSet ModuleName  -- stableObject
+  , UniqSet ModuleName  -- stableBCO
+  )
+
+
+checkStability
+        :: HomePackageTable   -- HPT from last compilation
+        -> [SCC ModSummary]   -- current module graph (cyclic)
+        -> UniqSet ModuleName -- all home modules
+        -> StableModules
+
+checkStability hpt sccs all_home_mods =
+  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs
+  where
+   checkSCC :: StableModules -> SCC ModSummary -> StableModules
+   checkSCC (stable_obj, stable_bco) scc0
+     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)
+     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)
+     | otherwise     = (stable_obj, stable_bco)
+     where
+        scc = flattenSCC scc0
+        scc_mods = map ms_mod_name scc
+        home_module m =
+          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods
+
+        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
+            -- all imports outside the current SCC, but in the home pkg
+
+        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps
+        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps
+
+        stableObjects =
+           and stable_obj_imps
+           && all object_ok scc
+
+        stableBCOs =
+           and (zipWith (||) stable_obj_imps stable_bco_imps)
+           && all bco_ok scc
+
+        object_ok ms
+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
+          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
+                                         && same_as_prev t
+          | otherwise = False
+          where
+             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
+                                Just hmi  | Just l <- hm_linkable hmi
+                                 -> isObjectLinkable l && t == linkableTime l
+                                _other  -> True
+                -- why '>=' rather than '>' above?  If the filesystem stores
+                -- times to the nearset second, we may occasionally find that
+                -- the object & source have the same modification time,
+                -- especially if the source was automatically generated
+                -- and compiled.  Using >= is slightly unsafe, but it matches
+                -- make's behaviour.
+                --
+                -- But see #5527, where someone ran into this and it caused
+                -- a problem.
+
+        bco_ok ms
+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
+          | otherwise = case lookupHpt hpt (ms_mod_name ms) of
+                Just hmi  | Just l <- hm_linkable hmi ->
+                        not (isObjectLinkable l) &&
+                        linkableTime l >= ms_hs_date ms
+                _other  -> False
+
+{- Parallel Upsweep
+ -
+ - The parallel upsweep attempts to concurrently compile the modules in the
+ - compilation graph using multiple Haskell threads.
+ -
+ - The Algorithm
+ -
+ - A Haskell thread is spawned for each module in the module graph, waiting for
+ - its direct dependencies to finish building before it itself begins to build.
+ -
+ - Each module is associated with an initially empty MVar that stores the
+ - result of that particular module's compile. If the compile succeeded, then
+ - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
+ - module, and the module's HMI is deleted from the old HPT (synchronized by an
+ - IORef) to save space.
+ -
+ - Instead of immediately outputting messages to the standard handles, all
+ - compilation output is deferred to a per-module TQueue. A QSem is used to
+ - limit the number of workers that are compiling simultaneously.
+ -
+ - Meanwhile, the main thread sequentially loops over all the modules in the
+ - module graph, outputting the messages stored in each module's TQueue.
+-}
+
+-- | Each module is given a unique 'LogQueue' to redirect compilation messages
+-- to. A 'Nothing' value contains the result of compilation, and denotes the
+-- end of the message queue.
+data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
+                         !(MVar ())
+
+-- | The graph of modules to compile and their corresponding result 'MVar' and
+-- 'LogQueue'.
+type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]
+
+-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
+-- also returning the first, if any, encountered module cycle.
+buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
+buildCompGraph [] = return ([], Nothing)
+buildCompGraph (scc:sccs) = case scc of
+    AcyclicSCC ms -> do
+        mvar <- newEmptyMVar
+        log_queue <- do
+            ref <- newIORef []
+            sem <- newEmptyMVar
+            return (LogQueue ref sem)
+        (rest,cycle) <- buildCompGraph sccs
+        return ((ms,mvar,log_queue):rest, cycle)
+    CyclicSCC mss -> return ([], Just mss)
+
+-- A Module and whether it is a boot module.
+type BuildModule = (Module, IsBoot)
+
+-- | 'Bool' indicating if a module is a boot module or not.  We need to treat
+-- boot modules specially when building compilation graphs, since they break
+-- cycles.  Regular source files and signature files are treated equivalently.
+data IsBoot = IsBoot | NotBoot
+    deriving (Ord, Eq, Show, Read)
+
+-- | Tests if an 'HscSource' is a boot file, primarily for constructing
+-- elements of 'BuildModule'.
+hscSourceToIsBoot :: HscSource -> IsBoot
+hscSourceToIsBoot HsBootFile = IsBoot
+hscSourceToIsBoot _ = NotBoot
+
+mkBuildModule :: ModSummary -> BuildModule
+mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
+
+-- | The entry point to the parallel upsweep.
+--
+-- See also the simpler, sequential 'upsweep'.
+parUpsweep
+    :: GhcMonad m
+    => Int
+    -- ^ The number of workers we wish to run in parallel
+    -> Maybe Messager
+    -> HomePackageTable
+    -> StableModules
+    -> (HscEnv -> IO ())
+    -> [SCC ModSummary]
+    -> m (SuccessFlag,
+          [ModSummary])
+parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+
+    when (not (null (unitIdsToCheck dflags))) $
+      throwGhcException (ProgramError "Backpack typechecking not supported with -j")
+
+    -- The bits of shared state we'll be using:
+
+    -- The global HscEnv is updated with the module's HMI when a module
+    -- successfully compiles.
+    hsc_env_var <- liftIO $ newMVar hsc_env
+
+    -- The old HPT is used for recompilation checking in upsweep_mod. When a
+    -- module successfully gets compiled, its HMI is pruned from the old HPT.
+    old_hpt_var <- liftIO $ newIORef old_hpt
+
+    -- What we use to limit parallelism with.
+    par_sem <- liftIO $ newQSem n_jobs
+
+
+    let updNumCapabilities = liftIO $ do
+            n_capabilities <- getNumCapabilities
+            n_cpus <- getNumProcessors
+            -- Setting number of capabilities more than
+            -- CPU count usually leads to high userspace
+            -- lock contention. #9221
+            let n_caps = min n_jobs n_cpus
+            unless (n_capabilities /= 1) $ setNumCapabilities n_caps
+            return n_capabilities
+    -- Reset the number of capabilities once the upsweep ends.
+    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
+
+    gbracket updNumCapabilities resetNumCapabilities $ \_ -> do
+
+    -- Sync the global session with the latest HscEnv once the upsweep ends.
+    let finallySyncSession io = io `gfinally` do
+            hsc_env <- liftIO $ readMVar hsc_env_var
+            setSession hsc_env
+
+    finallySyncSession $ do
+
+    -- Build the compilation graph out of the list of SCCs. Module cycles are
+    -- handled at the very end, after some useful work gets done. Note that
+    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
+    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs
+    let comp_graph_w_idx = zip comp_graph [1..]
+
+    -- The list of all loops in the compilation graph.
+    -- NB: For convenience, the last module of each loop (aka the module that
+    -- finishes the loop) is prepended to the beginning of the loop.
+    let graph = map fstOf3 (reverse comp_graph)
+        boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms]
+        comp_graph_loops = go graph boot_modules
+          where
+            remove ms bm
+              | isBootSummary ms = delModuleSet bm (ms_mod ms)
+              | otherwise = bm
+            go [] _ = []
+            go mg@(ms:mss) boot_modules
+              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)
+              = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules)
+              | otherwise
+              = go mss (remove ms boot_modules)
+
+    -- Build a Map out of the compilation graph with which we can efficiently
+    -- look up the result MVar associated with a particular home module.
+    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
+        home_mod_map =
+            Map.fromList [ (mkBuildModule ms, (mvar, idx))
+                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]
+
+
+    liftIO $ label_self "main --make thread"
+    -- For each module in the module graph, spawn a worker thread that will
+    -- compile this module.
+    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
+            forkIOWithUnmask $ \unmask -> do
+                liftIO $ label_self $ unwords
+                    [ "worker --make thread"
+                    , "for module"
+                    , show (moduleNameString (ms_mod_name mod))
+                    , "number"
+                    , show mod_idx
+                    ]
+                -- Replace the default log_action with one that writes each
+                -- message to the module's log_queue. The main thread will
+                -- deal with synchronously printing these messages.
+                --
+                -- Use a local filesToClean var so that we can clean up
+                -- intermediate files in a timely fashion (as soon as
+                -- compilation for that module is finished) without having to
+                -- worry about accidentally deleting a simultaneous compile's
+                -- important files.
+                lcl_files_to_clean <- newIORef emptyFilesToClean
+                let lcl_dflags = dflags { log_action = parLogAction log_queue
+                                        , filesToClean = lcl_files_to_clean }
+
+                -- Unmask asynchronous exceptions and perform the thread-local
+                -- work to compile the module (see parUpsweep_one).
+                m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
+                        parUpsweep_one mod home_mod_map comp_graph_loops
+                                       lcl_dflags mHscMessage cleanup
+                                       par_sem hsc_env_var old_hpt_var
+                                       stable_mods mod_idx (length sccs)
+
+                res <- case m_res of
+                    Right flag -> return flag
+                    Left exc -> do
+                        -- Don't print ThreadKilled exceptions: they are used
+                        -- to kill the worker thread in the event of a user
+                        -- interrupt, and the user doesn't have to be informed
+                        -- about that.
+                        when (fromException exc /= Just ThreadKilled)
+                             (errorMsg lcl_dflags (text (show exc)))
+                        return Failed
+
+                -- Populate the result MVar.
+                putMVar mvar res
+
+                -- Write the end marker to the message queue, telling the main
+                -- thread that it can stop waiting for messages from this
+                -- particular compile.
+                writeLogQueue log_queue Nothing
+
+                -- Add the remaining files that weren't cleaned up to the
+                -- global filesToClean ref, for cleanup later.
+                FilesToClean
+                  { ftcCurrentModule = cm_files
+                  , ftcGhcSession = gs_files
+                  } <- readIORef (filesToClean lcl_dflags)
+                addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files
+                addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files
+
+        -- Kill all the workers, masking interrupts (since killThread is
+        -- interruptible). XXX: This is not ideal.
+        ; killWorkers = uninterruptibleMask_ . mapM_ killThread }
+
+
+    -- Spawn the workers, making sure to kill them later. Collect the results
+    -- of each compile.
+    results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
+        -- Loop over each module in the compilation graph in order, printing
+        -- each message from its log_queue.
+        forM comp_graph $ \(mod,mvar,log_queue) -> do
+            printLogs dflags log_queue
+            result <- readMVar mvar
+            if succeeded result then return (Just mod) else return Nothing
+
+
+    -- Collect and return the ModSummaries of all the successful compiles.
+    -- NB: Reverse this list to maintain output parity with the sequential upsweep.
+    let ok_results = reverse (catMaybes results)
+
+    -- Handle any cycle in the original compilation graph and return the result
+    -- of the upsweep.
+    case cycle of
+        Just mss -> do
+            liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
+            return (Failed,ok_results)
+        Nothing  -> do
+            let success_flag = successIf (all isJust results)
+            return (success_flag,ok_results)
+
+  where
+    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
+    writeLogQueue (LogQueue ref sem) msg = do
+        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
+        _ <- tryPutMVar sem ()
+        return ()
+
+    -- The log_action callback that is used to synchronize messages from a
+    -- worker thread.
+    parLogAction :: LogQueue -> LogAction
+    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
+        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
+
+    -- Print each message from the log_queue using the log_action from the
+    -- session's DynFlags.
+    printLogs :: DynFlags -> LogQueue -> IO ()
+    printLogs !dflags (LogQueue ref sem) = read_msgs
+      where read_msgs = do
+                takeMVar sem
+                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
+                print_loop msgs
+
+            print_loop [] = read_msgs
+            print_loop (x:xs) = case x of
+                Just (reason,severity,srcSpan,style,msg) -> do
+                    putLogMsg dflags reason severity srcSpan style msg
+                    print_loop xs
+                -- Exit the loop once we encounter the end marker.
+                Nothing -> return ()
+
+-- The interruptible subset of the worker threads' work.
+parUpsweep_one
+    :: ModSummary
+    -- ^ The module we wish to compile
+    -> Map BuildModule (MVar SuccessFlag, Int)
+    -- ^ The map of home modules and their result MVar
+    -> [[BuildModule]]
+    -- ^ The list of all module loops within the compilation graph.
+    -> DynFlags
+    -- ^ The thread-local DynFlags
+    -> Maybe Messager
+    -- ^ The messager
+    -> (HscEnv -> IO ())
+    -- ^ The callback for cleaning up intermediate files
+    -> QSem
+    -- ^ The semaphore for limiting the number of simultaneous compiles
+    -> MVar HscEnv
+    -- ^ The MVar that synchronizes updates to the global HscEnv
+    -> IORef HomePackageTable
+    -- ^ The old HPT
+    -> StableModules
+    -- ^ Sets of stable objects and BCOs
+    -> Int
+    -- ^ The index of this module
+    -> Int
+    -- ^ The total number of modules
+    -> IO SuccessFlag
+    -- ^ The result of this compile
+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
+               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
+
+    let this_build_mod = mkBuildModule mod
+
+    let home_imps     = map unLoc $ ms_home_imps mod
+    let home_src_imps = map unLoc $ ms_home_srcimps mod
+
+    -- All the textual imports of this module.
+    let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
+                            zip home_imps     (repeat NotBoot) ++
+                            zip home_src_imps (repeat IsBoot)
+
+    -- Dealing with module loops
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
+    --
+    -- Not only do we have to deal with explicit textual dependencies, we also
+    -- have to deal with implicit dependencies introduced by import cycles that
+    -- are broken by an hs-boot file. We have to ensure that:
+    --
+    -- 1. A module that breaks a loop must depend on all the modules in the
+    --    loop (transitively or otherwise). This is normally always fulfilled
+    --    by the module's textual dependencies except in degenerate loops,
+    --    e.g.:
+    --
+    --    A.hs imports B.hs-boot
+    --    B.hs doesn't import A.hs
+    --    C.hs imports A.hs, B.hs
+    --
+    --    In this scenario, getModLoop will detect the module loop [A,B] but
+    --    the loop finisher B doesn't depend on A. So we have to explicitly add
+    --    A in as a dependency of B when we are compiling B.
+    --
+    -- 2. A module that depends on a module in an external loop can't proceed
+    --    until the entire loop is re-typechecked.
+    --
+    -- These two invariants have to be maintained to correctly build a
+    -- compilation graph with one or more loops.
+
+
+    -- The loop that this module will finish. After this module successfully
+    -- compiles, this loop is going to get re-typechecked.
+    let finish_loop = listToMaybe
+            [ tail loop | loop <- comp_graph_loops
+                        , head loop == this_build_mod ]
+
+    -- If this module finishes a loop then it must depend on all the other
+    -- modules in that loop because the entire module loop is going to be
+    -- re-typechecked once this module gets compiled. These extra dependencies
+    -- are this module's "internal" loop dependencies, because this module is
+    -- inside the loop in question.
+    let int_loop_deps = Set.fromList $
+            case finish_loop of
+                Nothing   -> []
+                Just loop -> filter (/= this_build_mod) loop
+
+    -- If this module depends on a module within a loop then it must wait for
+    -- that loop to get re-typechecked, i.e. it must wait on the module that
+    -- finishes that loop. These extra dependencies are this module's
+    -- "external" loop dependencies, because this module is outside of the
+    -- loop(s) in question.
+    let ext_loop_deps = Set.fromList
+            [ head loop | loop <- comp_graph_loops
+                        , any (`Set.member` textual_deps) loop
+                        , this_build_mod `notElem` loop ]
+
+
+    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]
+
+    -- All of the module's home-module dependencies.
+    let home_deps_with_idx =
+            [ home_dep | dep <- Set.toList all_deps
+                       , Just home_dep <- [Map.lookup dep home_mod_map] ]
+
+    -- Sort the list of dependencies in reverse-topological order. This way, by
+    -- the time we get woken up by the result of an earlier dependency,
+    -- subsequent dependencies are more likely to have finished. This step
+    -- effectively reduces the number of MVars that each thread blocks on.
+    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
+
+    -- Wait for the all the module's dependencies to finish building.
+    deps_ok <- allM (fmap succeeded . readMVar) home_deps
+
+    -- We can't build this module if any of its dependencies failed to build.
+    if not deps_ok
+      then return Failed
+      else do
+        -- Any hsc_env at this point is OK to use since we only really require
+        -- that the HPT contains the HMIs of our dependencies.
+        hsc_env <- readMVar hsc_env_var
+        old_hpt <- readIORef old_hpt_var
+
+        let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
+
+        -- Limit the number of parallel compiles.
+        let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
+        mb_mod_info <- withSem par_sem $
+            handleSourceError (\err -> do logger err; return Nothing) $ do
+                -- Have the ModSummary and HscEnv point to our local log_action
+                -- and filesToClean var.
+                let lcl_mod = localize_mod mod
+                let lcl_hsc_env = localize_hsc_env hsc_env
+
+                -- Re-typecheck the loop
+                -- This is necessary to make sure the knot is tied when
+                -- we close a recursive module loop, see bug #12035.
+                type_env_var <- liftIO $ newIORef emptyNameEnv
+                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
+                                    Just (ms_mod lcl_mod, type_env_var) }
+                lcl_hsc_env'' <- case finish_loop of
+                    Nothing   -> return lcl_hsc_env'
+                    -- In the non-parallel case, the retypecheck prior to
+                    -- typechecking the loop closer includes all modules
+                    -- EXCEPT the loop closer.  However, our precomputed
+                    -- SCCs include the loop closer, so we have to filter
+                    -- it out.
+                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
+                                 filter (/= moduleName (fst this_build_mod)) $
+                                 map (moduleName . fst) loop
+
+                -- Compile the module.
+                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
+                                        lcl_mod mod_index num_mods
+                return (Just mod_info)
+
+        case mb_mod_info of
+            Nothing -> return Failed
+            Just mod_info -> do
+                let this_mod = ms_mod_name mod
+
+                -- Prune the old HPT unless this is an hs-boot module.
+                unless (isBootSummary mod) $
+                    atomicModifyIORef' old_hpt_var $ \old_hpt ->
+                        (delFromHpt old_hpt this_mod, ())
+
+                -- Update and fetch the global HscEnv.
+                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
+                    let hsc_env' = hsc_env
+                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)
+                                                           this_mod mod_info }
+                    -- We've finished typechecking the module, now we must
+                    -- retypecheck the loop AGAIN to ensure unfoldings are
+                    -- updated.  This time, however, we include the loop
+                    -- closer!
+                    hsc_env'' <- case finish_loop of
+                        Nothing   -> return hsc_env'
+                        Just loop -> typecheckLoop lcl_dflags hsc_env' $
+                                     map (moduleName . fst) loop
+                    return (hsc_env'', localize_hsc_env hsc_env'')
+
+                -- Clean up any intermediate files.
+                cleanup lcl_hsc_env'
+                return Succeeded
+
+  where
+    localize_mod mod
+        = mod { ms_hspp_opts = (ms_hspp_opts mod)
+                 { log_action = log_action lcl_dflags
+                 , filesToClean = filesToClean lcl_dflags } }
+
+    localize_hsc_env hsc_env
+        = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
+                     { log_action = log_action lcl_dflags
+                     , filesToClean = filesToClean lcl_dflags } }
+
+-- -----------------------------------------------------------------------------
+--
+-- | The upsweep
+--
+-- This is where we compile each module in the module graph, in a pass
+-- from the bottom to the top of the graph.
+--
+-- There better had not be any cyclic groups here -- we check for them.
+upsweep
+    :: GhcMonad m
+    => Maybe Messager
+    -> HomePackageTable            -- ^ HPT from last time round (pruned)
+    -> StableModules               -- ^ stable modules (see checkStability)
+    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
+    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
+    -> m (SuccessFlag,
+          [ModSummary])
+       -- ^ Returns:
+       --
+       --  1. A flag whether the complete upsweep was successful.
+       --  2. The 'HscEnv' in the monad has an updated HPT
+       --  3. A list of modules which succeeded loading.
+
+upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
+   dflags <- getSessionDynFlags
+   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)
+                           (unitIdsToCheck dflags) done_holes
+   return (res, reverse $ mgModSummaries done)
+ where
+  done_holes = emptyUniqSet
+
+  upsweep'
+    :: GhcMonad m
+    => HomePackageTable
+    -> ModuleGraph
+    -> [SCC ModSummary]
+    -> Int
+    -> Int
+    -> [UnitId]
+    -> UniqSet ModuleName
+    -> m (SuccessFlag, ModuleGraph)
+  upsweep' _old_hpt done
+     [] _ _ uids_to_check _
+   = do hsc_env <- getSession
+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
+        return (Succeeded, done)
+
+  upsweep' _old_hpt done
+     (CyclicSCC ms:_) _ _ _ _
+   = do dflags <- getSessionDynFlags
+        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+        return (Failed, done)
+
+  upsweep' old_hpt done
+     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
+   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
+        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
+        --                     (moduleEnvElts (hsc_HPT hsc_env)))
+        let logger _mod = defaultWarnErrLogger
+
+        hsc_env <- getSession
+
+        -- TODO: Cache this, so that we don't repeatedly re-check
+        -- our imports when you run --make.
+        let (ready_uids, uids_to_check')
+                = partition (\uid -> isEmptyUniqDSet
+                    (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
+                     uids_to_check
+            done_holes'
+                | ms_hsc_src mod == HsigFile
+                = addOneToUniqSet done_holes (ms_mod_name mod)
+                | otherwise = done_holes
+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
+
+        -- Remove unwanted tmp files between compilations
+        liftIO (cleanup hsc_env)
+
+        -- Get ready to tie the knot
+        type_env_var <- liftIO $ newIORef emptyNameEnv
+        let hsc_env1 = hsc_env { hsc_type_env_var =
+                                    Just (ms_mod mod, type_env_var) }
+        setSession hsc_env1
+
+        -- Lazily reload the HPT modules participating in the loop.
+        -- See Note [Tying the knot]--if we don't throw out the old HPT
+        -- and reinitalize the knot-tying process, anything that was forced
+        -- while we were previously typechecking won't get updated, this
+        -- was bug #12035.
+        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
+        setSession hsc_env2
+
+        mb_mod_info
+            <- handleSourceError
+                   (\err -> do logger mod (Just err); return Nothing) $ do
+                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
+                                                  mod mod_index nmods
+                 logger mod Nothing -- log warnings
+                 return (Just mod_info)
+
+        case mb_mod_info of
+          Nothing -> return (Failed, done)
+          Just mod_info -> do
+                let this_mod = ms_mod_name mod
+
+                        -- Add new info to hsc_env
+                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info
+                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }
+
+                        -- Space-saving: delete the old HPT entry
+                        -- for mod BUT if mod is a hs-boot
+                        -- node, don't delete it.  For the
+                        -- interface, the HPT entry is probaby for the
+                        -- main Haskell source file.  Deleting it
+                        -- would force the real module to be recompiled
+                        -- every time.
+                    old_hpt1 | isBootSummary mod = old_hpt
+                             | otherwise = delFromHpt old_hpt this_mod
+
+                    done' = extendMG done mod
+
+                        -- fixup our HomePackageTable after we've finished compiling
+                        -- a mutually-recursive loop.  We have to do this again
+                        -- to make sure we have the final unfoldings, which may
+                        -- not have been computed accurately in the previous
+                        -- retypecheck.
+                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
+                setSession hsc_env4
+
+                        -- Add any necessary entries to the static pointer
+                        -- table. See Note [Grand plan for static forms] in
+                        -- StaticPtrTable.
+                when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $
+                    liftIO $ hscAddSptEntries hsc_env4
+                                 [ spt
+                                 | Just linkable <- pure $ hm_linkable mod_info
+                                 , unlinked <- linkableUnlinked linkable
+                                 , BCOs _ spts <- pure unlinked
+                                 , spt <- spts
+                                 ]
+
+                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
+
+unitIdsToCheck :: DynFlags -> [UnitId]
+unitIdsToCheck dflags =
+  nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
+ where
+  goUnitId uid =
+    case splitUnitIdInsts uid of
+      (_, Just indef) ->
+        let insts = indefUnitIdInsts indef
+        in uid : concatMap (goUnitId . moduleUnitId . snd) insts
+      _ -> []
+
+maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
+maybeGetIfaceDate dflags location
+ | writeInterfaceOnlyMode dflags
+    -- Minor optimization: it should be harmless to check the hi file location
+    -- always, but it's better to avoid hitting the filesystem if possible.
+    = modificationTimeIfExists (ml_hi_file location)
+ | otherwise
+    = return Nothing
+
+-- | Compile a single module.  Always produce a Linkable for it if
+-- successful.  If no compilation happened, return the old Linkable.
+upsweep_mod :: HscEnv
+            -> Maybe Messager
+            -> HomePackageTable
+            -> StableModules
+            -> ModSummary
+            -> Int  -- index of module
+            -> Int  -- total number of modules
+            -> IO HomeModInfo
+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods
+   =    let
+            this_mod_name = ms_mod_name summary
+            this_mod    = ms_mod summary
+            mb_obj_date = ms_obj_date summary
+            mb_if_date  = ms_iface_date summary
+            obj_fn      = ml_obj_file (ms_location summary)
+            hs_date     = ms_hs_date summary
+
+            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj
+            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco
+
+            old_hmi = lookupHpt old_hpt this_mod_name
+
+            -- We're using the dflags for this module now, obtained by
+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+            dflags = ms_hspp_opts summary
+            prevailing_target = hscTarget (hsc_dflags hsc_env)
+            local_target      = hscTarget dflags
+
+            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
+            -- we don't do anything dodgy: these should only work to change
+            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,
+            -- otherwise we could end up trying to link object code to byte
+            -- code.
+            target = if prevailing_target /= local_target
+                        && (not (isObjectTarget prevailing_target)
+                            || not (isObjectTarget local_target))
+                        && not (prevailing_target == HscNothing)
+                        && not (prevailing_target == HscInterpreted)
+                        then prevailing_target
+                        else local_target
+
+            -- store the corrected hscTarget into the summary
+            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+            -- The old interface is ok if
+            --  a) we're compiling a source file, and the old HPT
+            --     entry is for a source file
+            --  b) we're compiling a hs-boot file
+            -- Case (b) allows an hs-boot file to get the interface of its
+            -- real source file on the second iteration of the compilation
+            -- manager, but that does no harm.  Otherwise the hs-boot file
+            -- will always be recompiled
+
+            mb_old_iface
+                = case old_hmi of
+                     Nothing                              -> Nothing
+                     Just hm_info | isBootSummary summary -> Just iface
+                                  | not (mi_boot iface)   -> Just iface
+                                  | otherwise             -> Nothing
+                                   where
+                                     iface = hm_iface hm_info
+
+            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
+            compile_it  mb_linkable src_modified =
+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
+                             mb_old_iface mb_linkable src_modified
+
+            compile_it_discard_iface :: Maybe Linkable -> SourceModified
+                                     -> IO HomeModInfo
+            compile_it_discard_iface mb_linkable  src_modified =
+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
+                             Nothing mb_linkable src_modified
+
+            -- With the HscNothing target we create empty linkables to avoid
+            -- recompilation.  We have to detect these to recompile anyway if
+            -- the target changed since the last compile.
+            is_fake_linkable
+               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
+                  null (linkableUnlinked l)
+               | otherwise =
+                   -- we have no linkable, so it cannot be fake
+                   False
+
+            implies False _ = True
+            implies True x  = x
+
+        in
+        case () of
+         _
+                -- Regardless of whether we're generating object code or
+                -- byte code, we can always use an existing object file
+                -- if it is *stable* (see checkStability).
+          | is_stable_obj, Just hmi <- old_hmi -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping stable obj mod:" <+> ppr this_mod_name)
+                return hmi
+                -- object is stable, and we have an entry in the
+                -- old HPT: nothing to do
+
+          | is_stable_obj, isNothing old_hmi -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+                linkable <- liftIO $ findObjectLinkable this_mod obj_fn
+                              (expectJust "upsweep1" mb_obj_date)
+                compile_it (Just linkable) SourceUnmodifiedAndStable
+                -- object is stable, but we need to load the interface
+                -- off disk to make a HMI.
+
+          | not (isObjectTarget target), is_stable_bco,
+            (target /= HscNothing) `implies` not is_fake_linkable ->
+                ASSERT(isJust old_hmi) -- must be in the old_hpt
+                let Just hmi = old_hmi in do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+                return hmi
+                -- BCO is stable: nothing to do
+
+          | not (isObjectTarget target),
+            Just hmi <- old_hmi,
+            Just l <- hm_linkable hmi,
+            not (isObjectLinkable l),
+            (target /= HscNothing) `implies` not is_fake_linkable,
+            linkableTime l >= ms_hs_date summary -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+                compile_it (Just l) SourceUnmodified
+                -- we have an old BCO that is up to date with respect
+                -- to the source: do a recompilation check as normal.
+
+          -- When generating object code, if there's an up-to-date
+          -- object file on the disk, then we can use it.
+          -- However, if the object file is new (compared to any
+          -- linkable we had from a previous compilation), then we
+          -- must discard any in-memory interface, because this
+          -- means the user has compiled the source file
+          -- separately and generated a new interface, that we must
+          -- read from the disk.
+          --
+          | isObjectTarget target,
+            Just obj_date <- mb_obj_date,
+            obj_date >= hs_date -> do
+                case old_hmi of
+                  Just hmi
+                    | Just l <- hm_linkable hmi,
+                      isObjectLinkable l && linkableTime l == obj_date -> do
+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                                     (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+                          compile_it (Just l) SourceUnmodified
+                  _otherwise -> do
+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                                     (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+                          compile_it_discard_iface (Just linkable) SourceUnmodified
+
+          -- See Note [Recompilation checking in -fno-code mode]
+          | writeInterfaceOnlyMode dflags,
+            Just if_date <- mb_if_date,
+            if_date >= hs_date -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping tc'd mod:" <+> ppr this_mod_name)
+                compile_it Nothing SourceUnmodified
+
+         _otherwise -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling mod:" <+> ppr this_mod_name)
+                compile_it Nothing SourceModified
+
+
+{- Note [-fno-code mode]
+~~~~~~~~~~~~~~~~~~~~~~~~
+GHC offers the flag -fno-code for the purpose of parsing and typechecking a
+program without generating object files. This is intended to be used by tooling
+and IDEs to provide quick feedback on any parser or type errors as cheaply as
+possible.
+
+When GHC is invoked with -fno-code no object files or linked output will be
+generated. As many errors and warnings as possible will be generated, as if
+-fno-code had not been passed. The session DynFlags will have
+hscTarget == HscNothing.
+
+-fwrite-interface
+~~~~~~~~~~~~~~~~
+Whether interface files are generated in -fno-code mode is controlled by the
+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
+not also passed. Recompilation avoidance requires interface files, so passing
+-fno-code without -fwrite-interface should be avoided. If -fno-code were
+re-implemented today, -fwrite-interface would be discarded and it would be
+considered always on; this behaviour is as it is for backwards compatibility.
+
+================================================================
+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
+================================================================
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+A module using template haskell may invoke an imported function from inside a
+splice. This will cause the type-checker to attempt to execute that code, which
+would fail if no object files had been generated. See #8025. To rectify this,
+during the downsweep we patch the DynFlags in the ModSummary of any home module
+that is imported by a module that uses template haskell, to generate object
+code.
+
+The flavour of generated object code is chosen by defaultObjectTarget for the
+target platform. It would likely be faster to generate bytecode, but this is not
+supported on all platforms(?Please Confirm?), and does not support the entirety
+of GHC haskell. See #1257.
+
+The object files (and interface files if -fwrite-interface is disabled) produced
+for template haskell are written to temporary files.
+
+Note that since template haskell can run arbitrary IO actions, -fno-code mode
+is no more secure than running without it.
+
+Potential TODOS:
+~~~~~
+* Remove -fwrite-interface and have interface files always written in -fno-code
+  mode
+* Both .o and .dyn_o files are generated for template haskell, but we only need
+  .dyn_o. Fix it.
+* In make mode, a message like
+  Compiling A (A.hs, /tmp/ghc_123.o)
+  is shown if downsweep enabled object code generation for A. Perhaps we should
+  show "nothing" or "temporary object file" instead. Note that one
+  can currently use -keep-tmp-files and inspect the generated file with the
+  current behaviour.
+* Offer a -no-codedir command line option, and write what were temporary
+  object files there. This would speed up recompilation.
+* Use existing object files (if they are up to date) instead of always
+  generating temporary ones.
+-}
+
+-- Note [Recompilation checking in -fno-code mode]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- If we are compiling with -fno-code -fwrite-interface, there won't
+-- be any object code that we can compare against, nor should there
+-- be: we're *just* generating interface files.  In this case, we
+-- want to check if the interface file is new, in lieu of the object
+-- file.  See also #9243.
+
+-- Filter modules in the HPT
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs keep_these hpt
+   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)
+                 | mod <- keep_these
+                 , let mb_mod_info = lookupHpt hpt mod
+                 , isJust mb_mod_info ]
+
+-- ---------------------------------------------------------------------------
+-- Typecheck module loops
+{-
+See bug #930.  This code fixes a long-standing bug in --make.  The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky.  Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node.  This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+  | Just loop <- getModLoop ms mss appearsAsBoot
+  -- SOME hs-boot files should still
+  -- get used, just not the loop-closer.
+  , let non_boot = filter (\l -> not (isBootSummary l &&
+                                 ms_mod l == ms_mod ms)) loop
+  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)
+  | otherwise
+  = return hsc_env
+  where
+  mss = mgModSummaries graph
+  appearsAsBoot = (`elemModuleSet` mgBootModules graph)
+
+-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a
+-- corresponding boot file in @graph@, return the set of modules which
+-- transitively depend on this boot file.  This function is slightly misnamed,
+-- but its name "getModLoop" alludes to the fact that, when getModLoop is called
+-- with a graph that does not contain @ms@ (non-parallel case) or is an
+-- SCC with hs-boot nodes dropped (parallel-case), the modules which
+-- depend on the hs-boot file are typically (but not always) the
+-- modules participating in the recursive module loop.  The returned
+-- list includes the hs-boot file.
+--
+-- Example:
+--      let g represent the module graph:
+--          C.hs
+--          A.hs-boot imports C.hs
+--          B.hs imports A.hs-boot
+--          A.hs imports B.hs
+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]
+--
+--      It would also be permissible to omit A.hs from the graph,
+--      in which case the result is [A.hs-boot, B.hs]
+--
+-- Example:
+--      A counter-example to the claim that modules returned
+--      by this function participate in the loop occurs here:
+--
+--      let g represent the module graph:
+--          C.hs
+--          A.hs-boot imports C.hs
+--          B.hs imports A.hs-boot
+--          A.hs imports B.hs
+--          D.hs imports A.hs-boot
+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]
+--
+--      Arguably, D.hs should import A.hs, not A.hs-boot, but
+--      a dependency on the boot file is not illegal.
+--
+getModLoop
+  :: ModSummary
+  -> [ModSummary]
+  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
+  -> Maybe [ModSummary]
+getModLoop ms graph appearsAsBoot
+  | not (isBootSummary ms)
+  , appearsAsBoot this_mod
+  , let mss = reachableBackwards (ms_mod_name ms) graph
+  = Just mss
+  | otherwise
+  = Nothing
+ where
+  this_mod = ms_mod ms
+
+-- NB: sometimes mods has duplicates; this is harmless because
+-- any duplicates get clobbered in addListToHpt and never get forced.
+typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop dflags hsc_env mods = do
+  debugTraceMsg dflags 2 $
+     text "Re-typechecking loop: " <> ppr mods
+  new_hpt <-
+    fixIO $ \new_hpt -> do
+      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $
+                mapM (typecheckIface . hm_iface) hmis
+      let new_hpt = addListToHpt old_hpt
+                        (zip mods [ hmi{ hm_details = details }
+                                  | (hmi,details) <- zip hmis mds ])
+      return new_hpt
+  return hsc_env{ hsc_HPT = new_hpt }
+  where
+    old_hpt = hsc_HPT hsc_env
+    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+  = [ node_payload node | node <- reachableG (transposeG graph) root ]
+  where -- the rest just sets up the graph:
+        (graph, lookup_node) = moduleGraphNodes False summaries
+        root  = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+
+-- ---------------------------------------------------------------------------
+--
+-- | Topological sort of the module graph
+topSortModuleGraph
+          :: Bool
+          -- ^ Drop hi-boot nodes? (see below)
+          -> ModuleGraph
+          -> Maybe ModuleName
+             -- ^ Root module name.  If @Nothing@, use the full graph.
+          -> [SCC ModSummary]
+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- The resulting list of strongly-connected-components is in topologically
+-- sorted order, starting with the module(s) at the bottom of the
+-- dependency graph (ie compile them first) and ending with the ones at
+-- the top.
+--
+-- Drop hi-boot nodes (first boolean arg)?
+--
+-- - @False@:   treat the hi-boot summaries as nodes of the graph,
+--              so the graph must be acyclic
+--
+-- - @True@:    eliminate the hi-boot nodes, and instead pretend
+--              the a source-import of Foo is an import of Foo
+--              The resulting graph has no hi-boot nodes, but can be cyclic
+
+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+  where
+    summaries = mgModSummaries module_graph
+    -- stronglyConnCompG flips the original order, so if we reverse
+    -- the summaries we get a stable topological sort.
+    (graph, lookup_node) =
+      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
+
+    initial_graph = case mb_root_mod of
+        Nothing -> graph
+        Just root_mod ->
+            -- restrict the graph to just those modules reachable from
+            -- the specified module.  We do this by building a graph with
+            -- the full set of nodes, and determining the reachable set from
+            -- the specified node.
+            let root | Just node <- lookup_node HsSrcFile root_mod
+                     , graph `hasVertexG` node
+                     = node
+                     | otherwise
+                     = throwGhcException (ProgramError "module does not exist")
+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
+
+type SummaryNode = Node Int ModSummary
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey = node_key
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary = node_payload
+
+moduleGraphNodes :: Bool -> [ModSummary]
+  -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries =
+  (graphFromEdgedVerticesUniq nodes, lookup_node)
+  where
+    numbered_summaries = zip summaries [1..]
+
+    lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+    lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map
+
+    lookup_key :: HscSource -> ModuleName -> Maybe Int
+    lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+    node_map :: NodeMap SummaryNode
+    node_map = Map.fromList [ ((moduleName (ms_mod s),
+                                hscSourceToIsBoot (ms_hsc_src s)), node)
+                            | node <- nodes
+                            , let s = summaryNodeSummary node ]
+
+    -- We use integers as the keys for the SCC algorithm
+    nodes :: [SummaryNode]
+    nodes = [ DigraphNode s key out_keys
+            | (s, key) <- numbered_summaries
+             -- Drop the hi-boot ones if told to do so
+            , not (isBootSummary s && drop_hs_boot_nodes)
+            , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
+                             out_edge_keys HsSrcFile   (map unLoc (ms_home_imps s)) ++
+                             (-- see [boot-edges] below
+                              if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
+                              then []
+                              else case lookup_key HsBootFile (ms_mod_name s) of
+                                    Nothing -> []
+                                    Just k  -> [k]) ]
+
+    -- [boot-edges] if this is a .hs and there is an equivalent
+    -- .hs-boot, add a link from the former to the latter.  This
+    -- has the effect of detecting bogus cases where the .hs-boot
+    -- depends on the .hs, by introducing a cycle.  Additionally,
+    -- it ensures that we will always process the .hs-boot before
+    -- the .hs, and so the HomePackageTable will always have the
+    -- most up to date information.
+
+    -- Drop hs-boot nodes by using HsSrcFile as the key
+    hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+                | otherwise          = HsBootFile
+
+    out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+    out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
+        -- If we want keep_hi_boot_nodes, then we do lookup_key with
+        -- IsBoot; else NotBoot
+
+-- The nodes of the graph are keyed by (mod, is boot?) pairs
+-- NB: hsig files show up as *normal* nodes (not boot!), since they don't
+-- participate in cycles (for now)
+type NodeKey   = (ModuleName, IsBoot)
+type NodeMap a = Map.Map NodeKey a
+
+msKey :: ModSummary -> NodeKey
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
+    = (moduleName mod, hscSourceToIsBoot boot)
+
+mkNodeMap :: [ModSummary] -> NodeMap ModSummary
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
+
+nodeMapElts :: NodeMap a -> [a]
+nodeMapElts = Map.elems
+
+-- | If there are {-# SOURCE #-} imports between strongly connected
+-- components in the topological sort, then those imports can
+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
+-- were necessary, then the edge would be part of a cycle.
+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs = do
+  dflags <- getDynFlags
+  when (wopt Opt_WarnUnusedImports dflags)
+    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
+  where check dflags ms =
+           let mods_in_this_cycle = map ms_mod_name ms in
+           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
+                             unLoc i `notElem`  mods_in_this_cycle ]
+
+        warn :: DynFlags -> Located ModuleName -> WarnMsg
+        warn dflags (L loc mod) =
+           mkPlainErrMsg dflags loc
+                (text "Warning: {-# SOURCE #-} unnecessary in import of "
+                 <+> quotes (ppr mod))
+
+
+reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]
+reportImportErrors xs | null errs = return oks
+                      | otherwise = throwManyErrors errs
+  where (errs, oks) = partitionEithers xs
+
+throwManyErrors :: MonadIO m => [ErrMsg] -> m ab
+throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs
+
+
+-----------------------------------------------------------------------------
+--
+-- | Downsweep (dependency analysis)
+--
+-- Chase downwards from the specified root set, returning summaries
+-- for all home modules encountered.  Only follow source-import
+-- links.
+--
+-- We pass in the previous collection of summaries, which is used as a
+-- cache to avoid recalculating a module summary if the source is
+-- unchanged.
+--
+-- The returned list of [ModSummary] nodes has one node for each home-package
+-- module, plus one for any hs-boot files.  The imports of these nodes
+-- are all there, including the imports of non-home-package modules.
+downsweep :: HscEnv
+          -> [ModSummary]       -- Old summaries
+          -> [ModuleName]       -- Ignore dependencies on these; treat
+                                -- them as if they were package modules
+          -> Bool               -- True <=> allow multiple targets to have
+                                --          the same module name; this is
+                                --          very useful for ghc -M
+          -> IO [Either ErrMsg ModSummary]
+                -- The elts of [ModSummary] all have distinct
+                -- (Modules, IsBoot) identifiers, unless the Bool is true
+                -- in which case there can be repeats
+downsweep hsc_env old_summaries excl_mods allow_dup_roots
+   = do
+       rootSummaries <- mapM getRootSummary roots
+       rootSummariesOk <- reportImportErrors rootSummaries
+       let root_map = mkRootMap rootSummariesOk
+       checkDuplicates root_map
+       map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
+       -- if we have been passed -fno-code, we enable code generation
+       -- for dependencies of modules that have -XTemplateHaskell,
+       -- otherwise those modules will fail to compile.
+       -- See Note [-fno-code mode] #8025
+       map1 <- if hscTarget dflags == HscNothing
+         then enableCodeGenForTH
+           (defaultObjectTarget (settings dflags))
+           map0
+         else if hscTarget dflags == HscInterpreted
+           then enableCodeGenForUnboxedTuples
+             (defaultObjectTarget (settings dflags))
+             map0
+           else return map0
+       return $ concat $ nodeMapElts map1
+     where
+        calcDeps = msDeps
+
+        dflags = hsc_dflags hsc_env
+        roots = hsc_targets hsc_env
+
+        old_summary_map :: NodeMap ModSummary
+        old_summary_map = mkNodeMap old_summaries
+
+        getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
+        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
+           = do exists <- liftIO $ doesFileExist file
+                if exists
+                    then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
+                                       obj_allowed maybe_buf
+                    else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
+                           text "can't find file:" <+> text file
+        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
+           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
+                                           (L rootLoc modl) obj_allowed
+                                           maybe_buf excl_mods
+                case maybe_summary of
+                   Nothing -> return $ Left $ moduleNotFoundErr dflags modl
+                   Just s  -> return s
+
+        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+
+        -- In a root module, the filename is allowed to diverge from the module
+        -- name, so we have to check that there aren't multiple root files
+        -- defining the same module (otherwise the duplicates will be silently
+        -- ignored, leading to confusing behaviour).
+        checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO ()
+        checkDuplicates root_map
+           | allow_dup_roots = return ()
+           | null dup_roots  = return ()
+           | otherwise       = liftIO $ multiRootsErr dflags (head dup_roots)
+           where
+             dup_roots :: [[ModSummary]]        -- Each at least of length 2
+             dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
+
+        loop :: [(Located ModuleName,IsBoot)]
+                        -- Work list: process these modules
+             -> NodeMap [Either ErrMsg ModSummary]
+                        -- Visited set; the range is a list because
+                        -- the roots can have the same module names
+                        -- if allow_dup_roots is True
+             -> IO (NodeMap [Either ErrMsg ModSummary])
+                        -- The result is the completed NodeMap
+        loop [] done = return done
+        loop ((wanted_mod, is_boot) : ss) done
+          | Just summs <- Map.lookup key done
+          = if isSingleton summs then
+                loop ss done
+            else
+                do { multiRootsErr dflags (rights summs); return Map.empty }
+          | otherwise
+          = do mb_s <- summariseModule hsc_env old_summary_map
+                                       is_boot wanted_mod True
+                                       Nothing excl_mods
+               case mb_s of
+                   Nothing -> loop ss done
+                   Just (Left e) -> loop ss (Map.insert key [Left e] done)
+                   Just (Right s)-> do
+                     new_map <-
+                       loop (calcDeps s) (Map.insert key [Right s] done)
+                     loop ss new_map
+          where
+            key = (unLoc wanted_mod, is_boot)
+
+-- | Update the every ModSummary that is depended on
+-- by a module that needs template haskell. We enable codegen to
+-- the specified target, disable optimization and change the .hi
+-- and .o file locations to be temporary files.
+-- See Note [-fno-code mode]
+enableCodeGenForTH :: HscTarget
+  -> NodeMap [Either ErrMsg ModSummary]
+  -> IO (NodeMap [Either ErrMsg ModSummary])
+enableCodeGenForTH =
+  enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
+  where
+    condition = isTemplateHaskellOrQQNonBoot
+    should_modify (ModSummary { ms_hspp_opts = dflags }) =
+      hscTarget dflags == HscNothing &&
+      -- Don't enable codegen for TH on indefinite packages; we
+      -- can't compile anything anyway! See #16219.
+      not (isIndefinite dflags)
+
+-- | Update the every ModSummary that is depended on
+-- by a module that needs unboxed tuples. We enable codegen to
+-- the specified target, disable optimization and change the .hi
+-- and .o file locations to be temporary files.
+--
+-- This is used used in order to load code that uses unboxed tuples
+-- into GHCi while still allowing some code to be interpreted.
+enableCodeGenForUnboxedTuples :: HscTarget
+  -> NodeMap [Either ErrMsg ModSummary]
+  -> IO (NodeMap [Either ErrMsg ModSummary])
+enableCodeGenForUnboxedTuples =
+  enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
+  where
+    condition ms =
+      xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&
+      not (isBootSummary ms)
+    should_modify (ModSummary { ms_hspp_opts = dflags }) =
+      hscTarget dflags == HscInterpreted
+
+-- | Helper used to implement 'enableCodeGenForTH' and
+-- 'enableCodeGenForUnboxedTuples'. In particular, this enables
+-- unoptimized code generation for all modules that meet some
+-- condition (first parameter), or are dependencies of those
+-- modules. The second parameter is a condition to check before
+-- marking modules for code generation.
+enableCodeGenWhen
+  :: (ModSummary -> Bool)
+  -> (ModSummary -> Bool)
+  -> TempFileLifetime
+  -> TempFileLifetime
+  -> HscTarget
+  -> NodeMap [Either ErrMsg ModSummary]
+  -> IO (NodeMap [Either ErrMsg ModSummary])
+enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
+  traverse (traverse (traverse enable_code_gen)) nodemap
+  where
+    enable_code_gen ms
+      | ModSummary
+        { ms_mod = ms_mod
+        , ms_location = ms_location
+        , ms_hsc_src = HsSrcFile
+        , ms_hspp_opts = dflags
+        } <- ms
+      , should_modify ms
+      , ms_mod `Set.member` needs_codegen_set
+      = do
+        let new_temp_file suf dynsuf = do
+              tn <- newTempName dflags staticLife suf
+              let dyn_tn = tn -<.> dynsuf
+              addFilesToClean dflags dynLife [dyn_tn]
+              return tn
+          -- We don't want to create .o or .hi files unless we have been asked
+          -- to by the user. But we need them, so we patch their locations in
+          -- the ModSummary with temporary files.
+          --
+        hi_file <-
+          if gopt Opt_WriteInterface dflags
+            then return $ ml_hi_file ms_location
+            else new_temp_file (hiSuf dflags) (dynHiSuf dflags)
+        o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)
+        return $
+          ms
+          { ms_location =
+              ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}
+          , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}
+          }
+      | otherwise = return ms
+
+    needs_codegen_set = transitive_deps_set
+      [ ms
+      | mss <- Map.elems nodemap
+      , Right ms <- mss
+      , condition ms
+      ]
+
+    -- find the set of all transitive dependencies of a list of modules.
+    transitive_deps_set modSums = foldl' go Set.empty modSums
+      where
+        go marked_mods ms@ModSummary{ms_mod}
+          | ms_mod `Set.member` marked_mods = marked_mods
+          | otherwise =
+            let deps =
+                  [ dep_ms
+                  -- If a module imports a boot module, msDeps helpfully adds a
+                  -- dependency to that non-boot module in it's result. This
+                  -- means we don't have to think about boot modules here.
+                  | (L _ mn, NotBoot) <- msDeps ms
+                  , dep_ms <-
+                      toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
+                      toList
+                  ]
+                new_marked_mods = Set.insert ms_mod marked_mods
+            in foldl' go new_marked_mods deps
+
+mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
+mkRootMap summaries = Map.insertListWith (flip (++))
+                                         [ (msKey s, [Right s]) | s <- summaries ]
+                                         Map.empty
+
+-- | Returns the dependencies of the ModSummary s.
+-- A wrinkle is that for a {-# SOURCE #-} import we return
+--      *both* the hs-boot file
+--      *and* the source file
+-- as "dependencies".  That ensures that the list of all relevant
+-- modules always contains B.hs if it contains B.hs-boot.
+-- Remember, this pass isn't doing the topological sort.  It's
+-- just gathering the list of all relevant ModSummaries
+msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
+msDeps s =
+    concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
+        ++ [ (m,NotBoot) | m <- ms_home_imps s ]
+
+home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
+home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,
+                                  isLocal mb_pkg ]
+  where isLocal Nothing = True
+        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+        isLocal _ = False
+
+ms_home_allimps :: ModSummary -> [ModuleName]
+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
+
+-- | Like 'ms_home_imps', but for SOURCE imports.
+ms_home_srcimps :: ModSummary -> [Located ModuleName]
+ms_home_srcimps = home_imps . ms_srcimps
+
+-- | All of the (possibly) home module imports from a
+-- 'ModSummary'; that is to say, each of these module names
+-- could be a home import if an appropriately named file
+-- existed.  (This is in contrast to package qualified
+-- imports, which are guaranteed not to be home imports.)
+ms_home_imps :: ModSummary -> [Located ModuleName]
+ms_home_imps = home_imps . ms_imps
+
+-----------------------------------------------------------------------------
+-- Summarising modules
+
+-- We have two types of summarisation:
+--
+--    * Summarise a file.  This is used for the root module(s) passed to
+--      cmLoadModules.  The file is read, and used to determine the root
+--      module name.  The module name may differ from the filename.
+--
+--    * Summarise a module.  We are given a module name, and must provide
+--      a summary.  The finder is used to locate the file in which the module
+--      resides.
+
+summariseFile
+        :: HscEnv
+        -> [ModSummary]                 -- old summaries
+        -> FilePath                     -- source file name
+        -> Maybe Phase                  -- start phase
+        -> Bool                         -- object code allowed?
+        -> Maybe (StringBuffer,UTCTime)
+        -> IO ModSummary
+
+summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
+        -- we can use a cached summary if one is available and the
+        -- source file hasn't changed,  But we have to look up the summary
+        -- by source file, rather than module name as we do in summarise.
+   | Just old_summary <- findSummaryBySourceFile old_summaries file
+   = do
+        let location = ms_location old_summary
+            dflags = hsc_dflags hsc_env
+
+        src_timestamp <- get_src_timestamp
+                -- The file exists; we checked in getRootSummary above.
+                -- If it gets removed subsequently, then this
+                -- getModificationUTCTime may fail, but that's the right
+                -- behaviour.
+
+                -- return the cached summary if the source didn't change
+        if ms_hs_date old_summary == src_timestamp &&
+           not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
+           then do -- update the object-file timestamp
+                  obj_timestamp <-
+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+                        || obj_allowed -- bug #1205
+                        then liftIO $ getObjTimestamp location NotBoot
+                        else return Nothing
+                  hi_timestamp <- maybeGetIfaceDate dflags location
+                  let hie_location = ml_hie_file location
+                  hie_timestamp <- modificationTimeIfExists hie_location
+
+                  -- We have to repopulate the Finder's cache because it
+                  -- was flushed before the downsweep.
+                  _ <- liftIO $ addHomeModuleToFinder hsc_env
+                    (moduleName (ms_mod old_summary)) (ms_location old_summary)
+
+                  return old_summary{ ms_obj_date = obj_timestamp
+                                    , ms_iface_date = hi_timestamp
+                                    , ms_hie_date = hie_timestamp }
+           else
+                new_summary src_timestamp
+
+   | otherwise
+   = do src_timestamp <- get_src_timestamp
+        new_summary src_timestamp
+  where
+    get_src_timestamp = case maybe_buf of
+                           Just (_,t) -> return t
+                           Nothing    -> liftIO $ getModificationUTCTime file
+                        -- getModificationUTCTime may fail
+
+    new_summary src_timestamp = do
+        let dflags = hsc_dflags hsc_env
+
+        let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
+
+        (dflags', hspp_fn, buf)
+            <- preprocessFile hsc_env file mb_phase maybe_buf
+
+        (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
+
+        -- Make a ModLocation for this file
+        location <- liftIO $ mkHomeModLocation dflags mod_name file
+
+        -- Tell the Finder cache where it is, so that subsequent calls
+        -- to findModule will find it, even if it's not on any search path
+        mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+        -- when the user asks to load a source file by name, we only
+        -- use an object file if -fobject-code is on.  See #1205.
+        obj_timestamp <-
+            if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+               || obj_allowed -- bug #1205
+                then liftIO $ modificationTimeIfExists (ml_obj_file location)
+                else return Nothing
+
+        hi_timestamp <- maybeGetIfaceDate dflags location
+        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+
+        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+        required_by_imports <- implicitRequirements hsc_env the_imps
+
+        return (ModSummary { ms_mod = mod,
+                             ms_hsc_src = hsc_src,
+                             ms_location = location,
+                             ms_hspp_file = hspp_fn,
+                             ms_hspp_opts = dflags',
+                             ms_hspp_buf  = Just buf,
+                             ms_parsed_mod = Nothing,
+                             ms_srcimps = srcimps,
+                             ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
+                             ms_hs_date = src_timestamp,
+                             ms_iface_date = hi_timestamp,
+                             ms_hie_date = hie_timestamp,
+                             ms_obj_date = obj_timestamp })
+
+findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
+findSummaryBySourceFile summaries file
+  = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
+                                 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
+        [] -> Nothing
+        (x:_) -> Just x
+
+-- Summarise a module, and pick up source and timestamp.
+summariseModule
+          :: HscEnv
+          -> NodeMap ModSummary -- Map of old summaries
+          -> IsBoot             -- IsBoot <=> a {-# SOURCE #-} import
+          -> Located ModuleName -- Imported module to be summarised
+          -> Bool               -- object code allowed?
+          -> Maybe (StringBuffer, UTCTime)
+          -> [ModuleName]               -- Modules to exclude
+          -> IO (Maybe (Either ErrMsg ModSummary))      -- Its new summary
+
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+                obj_allowed maybe_buf excl_mods
+  | wanted_mod `elem` excl_mods
+  = return Nothing
+
+  | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
+  = do          -- Find its new timestamp; all the
+                -- ModSummaries in the old map have valid ml_hs_files
+        let location = ms_location old_summary
+            src_fn = expectJust "summariseModule" (ml_hs_file location)
+
+                -- check the modification time on the source file, and
+                -- return the cached summary if it hasn't changed.  If the
+                -- file has disappeared, we need to call the Finder again.
+        case maybe_buf of
+           Just (_,t) -> check_timestamp old_summary location src_fn t
+           Nothing    -> do
+                m <- tryIO (getModificationUTCTime src_fn)
+                case m of
+                   Right t -> check_timestamp old_summary location src_fn t
+                   Left e | isDoesNotExistError e -> find_it
+                          | otherwise             -> ioError e
+
+  | otherwise  = find_it
+  where
+    dflags = hsc_dflags hsc_env
+
+    check_timestamp old_summary location src_fn src_timestamp
+        | ms_hs_date old_summary == src_timestamp &&
+          not (gopt Opt_ForceRecomp dflags) = do
+                -- update the object-file timestamp
+                obj_timestamp <-
+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+                       || obj_allowed -- bug #1205
+                       then getObjTimestamp location is_boot
+                       else return Nothing
+                hi_timestamp <- maybeGetIfaceDate dflags location
+                hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+                return (Just (Right old_summary{ ms_obj_date = obj_timestamp
+                                               , ms_iface_date = hi_timestamp
+                                               , ms_hie_date = hie_timestamp }))
+        | otherwise =
+                -- source changed: re-summarise.
+                new_summary location (ms_mod old_summary) src_fn src_timestamp
+
+    find_it = do
+        found <- findImportedModule hsc_env wanted_mod Nothing
+        case found of
+             Found location mod
+                | isJust (ml_hs_file location) ->
+                        -- Home package
+                         just_found location mod
+
+             _ -> return Nothing
+                        -- Not found
+                        -- (If it is TRULY not found at all, we'll
+                        -- error when we actually try to compile)
+
+    just_found location mod = do
+                -- Adjust location to point to the hs-boot source file,
+                -- hi file, object file, when is_boot says so
+        let location' | IsBoot <- is_boot = addBootSuffixLocn location
+                      | otherwise         = location
+            src_fn = expectJust "summarise2" (ml_hs_file location')
+
+                -- Check that it exists
+                -- It might have been deleted since the Finder last found it
+        maybe_t <- modificationTimeIfExists src_fn
+        case maybe_t of
+          Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
+          Just t  -> new_summary location' mod src_fn t
+
+
+    new_summary location mod src_fn src_timestamp
+      = do
+        -- Preprocess the source file and get its imports
+        -- The dflags' contains the OPTIONS pragmas
+        (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
+        (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
+
+        -- NB: Despite the fact that is_boot is a top-level parameter, we
+        -- don't actually know coming into this function what the HscSource
+        -- of the module in question is.  This is because we may be processing
+        -- this module because another module in the graph imported it: in this
+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}
+        -- annotation, but we don't know if it's a signature or a regular
+        -- module until we actually look it up on the filesystem.
+        let hsc_src = case is_boot of
+                IsBoot -> HsBootFile
+                _ | isHaskellSigFilename src_fn -> HsigFile
+                  | otherwise -> HsSrcFile
+
+        when (mod_name /= wanted_mod) $
+                throwOneError $ mkPlainErrMsg dflags' mod_loc $
+                              text "File name does not match module name:"
+                              $$ text "Saw:" <+> quotes (ppr mod_name)
+                              $$ text "Expected:" <+> quotes (ppr wanted_mod)
+
+        when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $
+            let suggested_instantiated_with =
+                    hcat (punctuate comma $
+                        [ ppr k <> text "=" <> ppr v
+                        | (k,v) <- ((mod_name, mkHoleModule mod_name)
+                                : thisUnitIdInsts dflags)
+                        ])
+            in throwOneError $ mkPlainErrMsg dflags' mod_loc $
+                text "Unexpected signature:" <+> quotes (ppr mod_name)
+                $$ if gopt Opt_BuildingCabalPackage dflags
+                    then parens (text "Try adding" <+> quotes (ppr mod_name)
+                            <+> text "to the"
+                            <+> quotes (text "signatures")
+                            <+> text "field in your Cabal file.")
+                    else parens (text "Try passing -instantiated-with=\"" <>
+                                 suggested_instantiated_with <> text "\"" $$
+                                text "replacing <" <> ppr mod_name <> text "> as necessary.")
+
+                -- Find the object timestamp, and return the summary
+        obj_timestamp <-
+           if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+              || obj_allowed -- bug #1205
+              then getObjTimestamp location is_boot
+              else return Nothing
+
+        hi_timestamp <- maybeGetIfaceDate dflags location
+        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+
+        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+        required_by_imports <- implicitRequirements hsc_env the_imps
+
+        return (Just (Right (ModSummary { ms_mod       = mod,
+                              ms_hsc_src   = hsc_src,
+                              ms_location  = location,
+                              ms_hspp_file = hspp_fn,
+                              ms_hspp_opts = dflags',
+                              ms_hspp_buf  = Just buf,
+                              ms_parsed_mod = Nothing,
+                              ms_srcimps      = srcimps,
+                              ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
+                              ms_hs_date   = src_timestamp,
+                              ms_iface_date = hi_timestamp,
+                              ms_hie_date = hie_timestamp,
+                              ms_obj_date  = obj_timestamp })))
+
+
+getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
+getObjTimestamp location is_boot
+  = if is_boot == IsBoot then return Nothing
+                         else modificationTimeIfExists (ml_obj_file location)
+
+
+preprocessFile :: HscEnv
+               -> FilePath
+               -> Maybe Phase -- ^ Starting phase
+               -> Maybe (StringBuffer,UTCTime)
+               -> IO (DynFlags, FilePath, StringBuffer)
+preprocessFile hsc_env src_fn mb_phase Nothing
+  = do
+        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+        buf <- hGetStringBuffer hspp_fn
+        return (dflags', hspp_fn, buf)
+
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
+  = do
+        let dflags = hsc_dflags hsc_env
+        let local_opts = getOptions dflags buf src_fn
+
+        (dflags', leftovers, warns)
+            <- parseDynamicFilePragma dflags local_opts
+        checkProcessArgsResult dflags leftovers
+        handleFlagWarnings dflags' warns
+
+        let needs_preprocessing
+                | Just (Unlit _) <- mb_phase    = True
+                | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
+                  -- note: local_opts is only required if there's no Unlit phase
+                | xopt LangExt.Cpp dflags'      = True
+                | gopt Opt_Pp  dflags'          = True
+                | otherwise                     = False
+
+        when needs_preprocessing $
+           throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
+
+        return (dflags', src_fn, buf)
+
+
+-----------------------------------------------------------------------------
+--                      Error messages
+-----------------------------------------------------------------------------
+
+-- Defer and group warning, error and fatal messages so they will not get lost
+-- in the regular output.
+withDeferredDiagnostics :: GhcMonad m => m a -> m a
+withDeferredDiagnostics f = do
+  dflags <- getDynFlags
+  if not $ gopt Opt_DeferDiagnostics dflags
+  then f
+  else do
+    warnings <- liftIO $ newIORef []
+    errors <- liftIO $ newIORef []
+    fatals <- liftIO $ newIORef []
+
+    let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do
+          let action = putLogMsg dflags reason severity srcSpan style msg
+          case severity of
+            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())
+            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())
+            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())
+            _ -> action
+
+        printDeferredDiagnostics = liftIO $
+          forM_ [warnings, errors, fatals] $ \ref -> do
+            -- This IORef can leak when the dflags leaks, so let us always
+            -- reset the content.
+            actions <- atomicModifyIORef' ref $ \i -> ([], i)
+            sequence_ $ reverse actions
+
+        setLogAction action = modifySession $ \hsc_env ->
+          hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } }
+
+    gbracket
+      (setLogAction deferDiagnostics)
+      (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)
+      (\_ -> f)
+
+noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
+-- ToDo: we don't have a proper line number for this error
+noModError dflags loc wanted_mod err
+  = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
+
+noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
+noHsFileErr dflags loc path
+  = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
+
+moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
+moduleNotFoundErr dflags mod
+  = mkPlainErrMsg dflags noSrcSpan $
+        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
+
+multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
+multiRootsErr _      [] = panic "multiRootsErr"
+multiRootsErr dflags summs@(summ1:_)
+  = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
+        text "module" <+> quotes (ppr mod) <+>
+        text "is defined in multiple files:" <+>
+        sep (map text files)
+  where
+    mod = ms_mod summ1
+    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
+
+cyclicModuleErr :: [ModSummary] -> SDoc
+-- From a strongly connected component we find
+-- a single cycle to report
+cyclicModuleErr mss
+  = ASSERT( not (null mss) )
+    case findCycle graph of
+       Nothing   -> text "Unexpected non-cycle" <+> ppr mss
+       Just path -> vcat [ text "Module imports form a cycle:"
+                         , nest 2 (show_path path) ]
+  where
+    graph :: [Node NodeKey ModSummary]
+    graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
+
+    get_deps :: ModSummary -> [NodeKey]
+    get_deps ms = ([ (unLoc m, IsBoot)  | m <- ms_home_srcimps ms ] ++
+                   [ (unLoc m, NotBoot) | m <- ms_home_imps    ms ])
+
+    show_path []         = panic "show_path"
+    show_path [m]        = text "module" <+> ppr_ms m
+                           <+> text "imports itself"
+    show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)
+                                : nest 6 (text "imports" <+> ppr_ms m2)
+                                : go ms )
+       where
+         go []     = [text "which imports" <+> ppr_ms m1]
+         go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms
+
+
+    ppr_ms :: ModSummary -> SDoc
+    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
+                (parens (text (msHsFilePath ms)))
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/GhcPlugins.hs
@@ -0,0 +1,132 @@
+{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}
+
+-- | This module is not used by GHC itself.  Rather, it exports all of
+-- the functions and types you are likely to need when writing a
+-- plugin for GHC. So authors of plugins can probably get away simply
+-- with saying "import GhcPlugins".
+--
+-- Particularly interesting modules for plugin writers include
+-- "CoreSyn" and "CoreMonad".
+module GhcPlugins(
+        module Plugins,
+        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,
+        module CoreMonad, module CoreSyn, module Literal, module DataCon,
+        module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,
+        module Rules, module Annotations,
+        module DynFlags, module Packages,
+        module Module, module Type, module TyCon, module Coercion,
+        module TysWiredIn, module HscTypes, module BasicTypes,
+        module VarSet, module VarEnv, module NameSet, module NameEnv,
+        module UniqSet, module UniqFM, module FiniteMap,
+        module Util, module GHC.Serialized, module SrcLoc, module Outputable,
+        module UniqSupply, module Unique, module FastString,
+
+        -- * Getting 'Name's
+        thNameToGhcName
+    ) where
+
+-- Plugin stuff itself
+import Plugins
+
+-- Variable naming
+import RdrName
+import OccName  hiding  ( varName {- conflicts with Var.varName -} )
+import Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )
+import Var
+import Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )
+import IdInfo
+
+-- Core
+import CoreMonad
+import CoreSyn
+import Literal
+import DataCon
+import CoreUtils
+import MkCore
+import CoreFVs
+import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
+       -- These names are also exported by Type
+
+-- Core "extras"
+import Rules
+import Annotations
+
+-- Pipeline-related stuff
+import DynFlags
+import Packages
+
+-- Important GHC types
+import Module
+import Type     hiding {- conflict with CoreSubst -}
+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )
+import Coercion hiding {- conflict with CoreSubst -}
+                ( substCo )
+import TyCon
+import TysWiredIn
+import HscTypes
+import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )
+
+-- Collections and maps
+import VarSet
+import VarEnv
+import NameSet
+import NameEnv
+import UniqSet
+import UniqFM
+-- Conflicts with UniqFM:
+--import LazyUniqFM
+import FiniteMap
+
+-- Common utilities
+import Util
+import GHC.Serialized
+import SrcLoc
+import Outputable
+import UniqSupply
+import Unique           ( Unique, Uniquable(..) )
+import FastString
+import Data.Maybe
+
+import IfaceEnv         ( lookupOrigIO )
+import GhcPrelude
+import MonadUtils       ( mapMaybeM )
+import Convert          ( thRdrNameGuesses )
+import TcEnv            ( lookupGlobal )
+
+import qualified Language.Haskell.TH as TH
+
+{- This instance is defined outside CoreMonad.hs so that
+   CoreMonad does not depend on TcEnv -}
+instance MonadThings CoreM where
+    lookupThing name = do { hsc_env <- getHscEnv
+                          ; liftIO $ lookupGlobal hsc_env name }
+
+{-
+************************************************************************
+*                                                                      *
+               Template Haskell interoperability
+*                                                                      *
+************************************************************************
+-}
+
+-- | Attempt to convert a Template Haskell name to one that GHC can
+-- understand. Original TH names such as those you get when you use
+-- the @'foo@ syntax will be translated to their equivalent GHC name
+-- exactly. Qualified or unqualified TH names will be dynamically bound
+-- to names in the module being compiled, if possible. Exact TH names
+-- will be bound to the name they represent, exactly.
+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
+thNameToGhcName th_name
+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+          -- Pick the first that works
+          -- E.g. reify (mkName "A") will pick the class A in preference
+          -- to the data constructor A
+        ; return (listToMaybe names) }
+  where
+    lookup rdr_name
+      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+      = return $ if isExternalName n then Just n else Nothing
+      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+      = do { hsc_env <- getHscEnv
+           ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) }
+      | otherwise = return Nothing
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/HeaderInfo.hs
@@ -0,0 +1,352 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+--
+-- | Parsing the top of a Haskell source file to get its module name,
+-- imports and options.
+--
+-- (c) Simon Marlow 2005
+-- (c) Lemmih 2006
+--
+-----------------------------------------------------------------------------
+
+module HeaderInfo ( getImports
+                  , mkPrelImports -- used by the renamer too
+                  , getOptionsFromFile, getOptions
+                  , optionsErrorMsgs,
+                    checkProcessArgsResult ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HscTypes
+import Parser           ( parseHeader )
+import Lexer
+import FastString
+import HsSyn
+import Module
+import PrelNames
+import StringBuffer
+import SrcLoc
+import DynFlags
+import ErrUtils
+import Util
+import Outputable
+import Pretty           ()
+import Maybes
+import Bag              ( emptyBag, listToBag, unitBag )
+import MonadUtils
+import Exception
+import BasicTypes
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import System.IO
+import System.IO.Unsafe
+import Data.List
+
+------------------------------------------------------------------------------
+
+-- | Parse the imports of a source file.
+--
+-- Throws a 'SourceError' if parsing fails.
+getImports :: DynFlags
+           -> StringBuffer -- ^ Parse this.
+           -> FilePath     -- ^ Filename the buffer came from.  Used for
+                           --   reporting parse error locations.
+           -> FilePath     -- ^ The original source filename (used for locations
+                           --   in the function result)
+           -> IO ([(Maybe FastString, Located ModuleName)],
+                  [(Maybe FastString, Located ModuleName)],
+                  Located ModuleName)
+              -- ^ The source imports, normal imports, and the module name.
+getImports dflags buf filename source_filename = do
+  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
+  case unP parseHeader (mkPState dflags buf loc) of
+    PFailed pst -> do
+        -- assuming we're not logging warnings here as per below
+      throwErrors (getErrorMessages pst dflags)
+    POk pst rdr_module -> do
+      let _ms@(_warns, errs) = getMessages pst dflags
+      -- don't log warnings: they'll be reported when we parse the file
+      -- for real.  See #2500.
+          ms = (emptyBag, errs)
+      -- logWarnings warns
+      if errorsFound dflags ms
+        then throwIO $ mkSrcErr errs
+        else
+          let   hsmod = unLoc rdr_module
+                mb_mod = hsmodName hsmod
+                imps = hsmodImports hsmod
+                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
+                                       1 1)
+                mod = mb_mod `orElse` cL main_loc mAIN_NAME
+                (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+
+               -- GHC.Prim doesn't exist physically, so don't go looking for it.
+                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
+                                        . ideclName . unLoc)
+                                       ord_idecls
+
+                implicit_prelude = xopt LangExt.ImplicitPrelude dflags
+                implicit_imports = mkPrelImports (unLoc mod) main_loc
+                                                 implicit_prelude imps
+                convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
+                                         , ideclName i)
+              in
+              return (map convImport src_idecls,
+                      map convImport (implicit_imports ++ ordinary_imps),
+                      mod)
+
+mkPrelImports :: ModuleName
+              -> SrcSpan    -- Attribute the "import Prelude" to this location
+              -> Bool -> [LImportDecl GhcPs]
+              -> [LImportDecl GhcPs]
+-- Construct the implicit declaration "import Prelude" (or not)
+--
+-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
+-- because the former doesn't even look at Prelude.hi for instance
+-- declarations, whereas the latter does.
+mkPrelImports this_mod loc implicit_prelude import_decls
+  | this_mod == pRELUDE_NAME
+   || explicit_prelude_import
+   || not implicit_prelude
+  = []
+  | otherwise = [preludeImportDecl]
+  where
+      explicit_prelude_import
+       = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
+                                        , ideclPkgQual = Nothing }))
+                          <- import_decls
+                      , unLoc mod == pRELUDE_NAME ]
+
+      preludeImportDecl :: LImportDecl GhcPs
+      preludeImportDecl
+        = cL loc $ ImportDecl { ideclExt       = noExt,
+                                ideclSourceSrc = NoSourceText,
+                                ideclName      = cL loc pRELUDE_NAME,
+                                ideclPkgQual   = Nothing,
+                                ideclSource    = False,
+                                ideclSafe      = False,  -- Not a safe import
+                                ideclQualified = NotQualified,
+                                ideclImplicit  = True,   -- Implicit!
+                                ideclAs        = Nothing,
+                                ideclHiding    = Nothing  }
+
+--------------------------------------------------------------
+-- Get options
+--------------------------------------------------------------
+
+-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
+--
+-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
+getOptionsFromFile :: DynFlags
+                   -> FilePath            -- ^ Input file
+                   -> IO [Located String] -- ^ Parsed options, if any.
+getOptionsFromFile dflags filename
+    = Exception.bracket
+              (openBinaryFile filename ReadMode)
+              (hClose)
+              (\handle -> do
+                  opts <- fmap (getOptions' dflags)
+                               (lazyGetToks dflags' filename handle)
+                  seqList opts $ return opts)
+    where -- We don't need to get haddock doc tokens when we're just
+          -- getting the options from pragmas, and lazily lexing them
+          -- correctly is a little tricky: If there is "\n" or "\n-"
+          -- left at the end of a buffer then the haddock doc may
+          -- continue past the end of the buffer, despite the fact that
+          -- we already have an apparently-complete token.
+          -- We therefore just turn Opt_Haddock off when doing the lazy
+          -- lex.
+          dflags' = gopt_unset dflags Opt_Haddock
+
+blockSize :: Int
+-- blockSize = 17 -- for testing :-)
+blockSize = 1024
+
+lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
+lazyGetToks dflags filename handle = do
+  buf <- hGetStringBufferBlock handle blockSize
+  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
+ where
+  loc  = mkRealSrcLoc (mkFastString filename) 1 1
+
+  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
+  lazyLexBuf handle state eof size = do
+    case unP (lexer False return) state of
+      POk state' t -> do
+        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
+        if atEnd (buffer state') && not eof
+           -- if this token reached the end of the buffer, and we haven't
+           -- necessarily read up to the end of the file, then the token might
+           -- be truncated, so read some more of the file and lex it again.
+           then getMore handle state size
+           else case unLoc t of
+                  ITeof  -> return [t]
+                  _other -> do rest <- lazyLexBuf handle state' eof size
+                               return (t : rest)
+      _ | not eof   -> getMore handle state size
+        | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
+                         -- parser assumes an ITeof sentinel at the end
+
+  getMore :: Handle -> PState -> Int -> IO [Located Token]
+  getMore handle state size = do
+     -- pprTrace "getMore" (text (show (buffer state))) (return ())
+     let new_size = size * 2
+       -- double the buffer size each time we read a new block.  This
+       -- counteracts the quadratic slowdown we otherwise get for very
+       -- large module names (#5981)
+     nextbuf <- hGetStringBufferBlock handle new_size
+     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
+       newbuf <- appendStringBuffers (buffer state) nextbuf
+       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
+
+
+getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
+getToks dflags filename buf = lexAll (pragState dflags buf loc)
+ where
+  loc  = mkRealSrcLoc (mkFastString filename) 1 1
+
+  lexAll state = case unP (lexer False return) state of
+                   POk _      t@(dL->L _ ITeof) -> [t]
+                   POk state' t -> t : lexAll state'
+                   _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
+
+
+-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
+--
+-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
+getOptions :: DynFlags
+           -> StringBuffer -- ^ Input Buffer
+           -> FilePath     -- ^ Source filename.  Used for location info.
+           -> [Located String] -- ^ Parsed options.
+getOptions dflags buf filename
+    = getOptions' dflags (getToks dflags filename buf)
+
+-- The token parser is written manually because Happy can't
+-- return a partial result when it encounters a lexer error.
+-- We want to extract options before the buffer is passed through
+-- CPP, so we can't use the same trick as 'getImports'.
+getOptions' :: DynFlags
+            -> [Located Token]      -- Input buffer
+            -> [Located String]     -- Options.
+getOptions' dflags toks
+    = parseToks toks
+    where
+          parseToks (open:close:xs)
+              | IToptions_prag str <- unLoc open
+              , ITclose_prag       <- unLoc close
+              = case toArgs str of
+                  Left _err -> optionsParseError str dflags $   -- #15053
+                                 combineSrcSpans (getLoc open) (getLoc close)
+                  Right args -> map (cL (getLoc open)) args ++ parseToks xs
+          parseToks (open:close:xs)
+              | ITinclude_prag str <- unLoc open
+              , ITclose_prag       <- unLoc close
+              = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
+                parseToks xs
+          parseToks (open:close:xs)
+              | ITdocOptions str <- unLoc open
+              , ITclose_prag     <- unLoc close
+              = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
+                ++ parseToks xs
+          parseToks (open:xs)
+              | ITlanguage_prag <- unLoc open
+              = parseLanguage xs
+          parseToks (comment:xs) -- Skip over comments
+              | isComment (unLoc comment)
+              = parseToks xs
+          parseToks _ = []
+          parseLanguage ((dL->L loc (ITconid fs)):rest)
+              = checkExtension dflags (cL loc fs) :
+                case rest of
+                  (dL->L _loc ITcomma):more -> parseLanguage more
+                  (dL->L _loc ITclose_prag):more -> parseToks more
+                  (dL->L loc _):_ -> languagePragParseError dflags loc
+                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
+          parseLanguage (tok:_)
+              = languagePragParseError dflags (getLoc tok)
+          parseLanguage []
+              = panic "getOptions'.parseLanguage(2) went past eof token"
+
+          isComment :: Token -> Bool
+          isComment c =
+            case c of
+              (ITlineComment {})     -> True
+              (ITblockComment {})    -> True
+              (ITdocCommentNext {})  -> True
+              (ITdocCommentPrev {})  -> True
+              (ITdocCommentNamed {}) -> True
+              (ITdocSection {})      -> True
+              _                      -> False
+
+-----------------------------------------------------------------------------
+
+-- | Complain about non-dynamic flags in OPTIONS pragmas.
+--
+-- Throws a 'SourceError' if the input list is non-empty claiming that the
+-- input flags are unknown.
+checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
+checkProcessArgsResult dflags flags
+  = when (notNull flags) $
+      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
+    where mkMsg (dL->L loc flag)
+              = mkPlainErrMsg dflags loc $
+                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
+                   text flag)
+
+-----------------------------------------------------------------------------
+
+checkExtension :: DynFlags -> Located FastString -> Located String
+checkExtension dflags (dL->L l ext)
+-- Checks if a given extension is valid, and if so returns
+-- its corresponding flag. Otherwise it throws an exception.
+ =  let ext' = unpackFS ext in
+    if ext' `elem` supportedLanguagesAndExtensions
+    then cL l ("-X"++ext')
+    else unsupportedExtnError dflags l ext'
+
+languagePragParseError :: DynFlags -> SrcSpan -> a
+languagePragParseError dflags loc =
+    throwErr dflags loc $
+       vcat [ text "Cannot parse LANGUAGE pragma"
+            , text "Expecting comma-separated list of language options,"
+            , text "each starting with a capital letter"
+            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
+
+unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
+unsupportedExtnError dflags loc unsup =
+    throwErr dflags loc $
+        text "Unsupported extension: " <> text unsup $$
+        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
+  where
+     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
+
+
+optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
+optionsErrorMsgs dflags unhandled_flags flags_lines _filename
+  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
+  where unhandled_flags_lines :: [Located String]
+        unhandled_flags_lines = [ cL l f
+                                | f <- unhandled_flags
+                                , (dL->L l f') <- flags_lines
+                                , f == f' ]
+        mkMsg (dL->L flagSpan flag) =
+            ErrUtils.mkPlainErrMsg dflags flagSpan $
+                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
+
+optionsParseError :: String -> DynFlags -> SrcSpan -> a     -- #15053
+optionsParseError str dflags loc =
+  throwErr dflags loc $
+      vcat [ text "Error while parsing OPTIONS_GHC pragma."
+           , text "Expecting whitespace-separated list of GHC options."
+           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
+           , text ("Input was: " ++ show str) ]
+
+throwErr :: DynFlags -> SrcSpan -> SDoc -> a                -- #15053
+throwErr dflags loc doc =
+  throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/HscMain.hs
@@ -0,0 +1,1882 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -fprof-auto-top #-}
+
+-------------------------------------------------------------------------------
+--
+-- | Main API for compiling plain Haskell source code.
+--
+-- This module implements compilation of a Haskell source. It is
+-- /not/ concerned with preprocessing of source files; this is handled
+-- in "DriverPipeline".
+--
+-- There are various entry points depending on what mode we're in:
+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
+-- "interactive" mode (GHCi). There are also entry points for
+-- individual passes: parsing, typechecking/renaming, desugaring, and
+-- simplification.
+--
+-- All the functions here take an 'HscEnv' as a parameter, but none of
+-- them return a new one: 'HscEnv' is treated as an immutable value
+-- from here on in (although it has mutable components, for the
+-- caches).
+--
+-- We use the Hsc monad to deal with warning messages consistently:
+-- specifically, while executing within an Hsc monad, warnings are
+-- collected. When a Hsc monad returns to an IO monad, the
+-- warnings are printed, or compilation aborts if the @-Werror@
+-- flag is enabled.
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
+--
+-------------------------------------------------------------------------------
+
+module HscMain
+    (
+    -- * Making an HscEnv
+      newHscEnv
+
+    -- * Compiling complete source files
+    , Messager, batchMsg
+    , HscStatus (..)
+    , hscIncrementalCompile
+    , hscCompileCmmFile
+
+    , hscGenHardCode
+    , hscInteractive
+
+    -- * Running passes separately
+    , hscParse
+    , hscTypecheckRename
+    , hscDesugar
+    , makeSimpleDetails
+    , hscSimplify -- ToDo, shouldn't really export this
+
+    -- * Safe Haskell
+    , hscCheckSafe
+    , hscGetSafe
+
+    -- * Support for interactive evaluation
+    , hscParseIdentifier
+    , hscTcRcLookupName
+    , hscTcRnGetInfo
+    , hscIsGHCiMonad
+    , hscGetModuleInterface
+    , hscRnImportDecls
+    , hscTcRnLookupRdrName
+    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
+    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
+    , hscParseExpr
+    , hscCompileCoreExpr
+    -- * Low-level exports for hooks
+    , hscCompileCoreExpr'
+      -- We want to make sure that we export enough to be able to redefine
+      -- hscFileFrontEnd in client code
+    , hscParse', hscSimplify', hscDesugar', tcRnModule'
+    , getHscEnv
+    , hscSimpleIface', hscNormalIface'
+    , oneShotMsg
+    , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
+    , ioMsgMaybe
+    , showModuleIndex
+    , hscAddSptEntries
+    ) where
+
+import GhcPrelude
+
+import Data.Data hiding (Fixity, TyCon)
+import Data.Maybe       ( fromJust )
+import Id
+import GHCi             ( addSptEntry )
+import GHCi.RemoteTypes ( ForeignHValue )
+import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
+import Linker
+import CoreTidy         ( tidyExpr )
+import Type             ( Type )
+import {- Kind parts of -} Type         ( Kind )
+import CoreLint         ( lintInteractiveExpr )
+import VarEnv           ( emptyTidyEnv )
+import Panic
+import ConLike
+import Control.Concurrent
+
+import Module
+import Packages
+import RdrName
+import HsSyn
+import HsDumpAst
+import CoreSyn
+import StringBuffer
+import Parser
+import Lexer
+import SrcLoc
+import TcRnDriver
+import TcIface          ( typecheckIface )
+import TcRnMonad
+import NameCache        ( initNameCache )
+import LoadIface        ( ifaceStats, initExternalPackageState )
+import PrelInfo
+import MkIface
+import Desugar
+import SimplCore
+import TidyPgm
+import CorePrep
+import CoreToStg        ( coreToStg )
+import qualified StgCmm ( codeGen )
+import StgSyn
+import StgFVs           ( annTopBindingsFreeVars )
+import CostCentre
+import ProfInit
+import TyCon
+import Name
+import SimplStg         ( stg2stg )
+import Cmm
+import CmmParse         ( parseCmmFile )
+import CmmBuildInfoTables
+import CmmPipeline
+import CmmInfo
+import CodeOutput
+import InstEnv
+import FamInstEnv
+import Fingerprint      ( Fingerprint )
+import Hooks
+import TcEnv
+import PrelNames
+import Plugins
+import DynamicLoading   ( initializePlugins )
+
+import DynFlags
+import ErrUtils
+import Platform ( platformOS, osSubsectionsViaSymbols )
+
+import Outputable
+import NameEnv
+import HscStats         ( ppSourceStats )
+import HscTypes
+import FastString
+import UniqSupply
+import Bag
+import Exception
+import qualified Stream
+import Stream (Stream)
+
+import Util
+
+import Data.List
+import Control.Monad
+import Data.IORef
+import System.FilePath as FilePath
+import System.Directory
+import System.IO (fixIO)
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Set (Set)
+
+import HieAst           ( mkHieFile )
+import HieTypes         ( getAsts, hie_asts )
+import HieBin           ( readHieFile, writeHieFile )
+import HieDebug         ( diffFile, validateScopes )
+
+#include "HsVersions.h"
+
+
+{- **********************************************************************
+%*                                                                      *
+                Initialisation
+%*                                                                      *
+%********************************************************************* -}
+
+newHscEnv :: DynFlags -> IO HscEnv
+newHscEnv dflags = do
+    eps_var <- newIORef initExternalPackageState
+    us      <- mkSplitUniqSupply 'r'
+    nc_var  <- newIORef (initNameCache us knownKeyNames)
+    fc_var  <- newIORef emptyInstalledModuleEnv
+    iserv_mvar <- newMVar Nothing
+    emptyDynLinker <- uninitializedLinker
+    return HscEnv {  hsc_dflags       = dflags
+                  ,  hsc_targets      = []
+                  ,  hsc_mod_graph    = emptyMG
+                  ,  hsc_IC           = emptyInteractiveContext dflags
+                  ,  hsc_HPT          = emptyHomePackageTable
+                  ,  hsc_EPS          = eps_var
+                  ,  hsc_NC           = nc_var
+                  ,  hsc_FC           = fc_var
+                  ,  hsc_type_env_var = Nothing
+                  ,  hsc_iserv        = iserv_mvar
+                  ,  hsc_dynLinker    = emptyDynLinker
+                  }
+
+-- -----------------------------------------------------------------------------
+
+getWarnings :: Hsc WarningMessages
+getWarnings = Hsc $ \_ w -> return (w, w)
+
+clearWarnings :: Hsc ()
+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
+
+logWarnings :: WarningMessages -> Hsc ()
+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+
+getHscEnv :: Hsc HscEnv
+getHscEnv = Hsc $ \e w -> return (e, w)
+
+handleWarnings :: Hsc ()
+handleWarnings = do
+    dflags <- getDynFlags
+    w <- getWarnings
+    liftIO $ printOrThrowWarnings dflags w
+    clearWarnings
+
+-- | log warning in the monad, and if there are errors then
+-- throw a SourceError exception.
+logWarningsReportErrors :: Messages -> Hsc ()
+logWarningsReportErrors (warns,errs) = do
+    logWarnings warns
+    when (not $ isEmptyBag errs) $ throwErrors errs
+
+-- | Log warnings and throw errors, assuming the messages
+-- contain at least one error (e.g. coming from PFailed)
+handleWarningsThrowErrors :: Messages -> Hsc a
+handleWarningsThrowErrors (warns, errs) = do
+    logWarnings warns
+    dflags <- getDynFlags
+    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
+    liftIO $ printBagOfErrors dflags wWarns
+    throwErrors (unionBags errs wErrs)
+
+-- | Deal with errors and warnings returned by a compilation step
+--
+-- In order to reduce dependencies to other parts of the compiler, functions
+-- outside the "main" parts of GHC return warnings and errors as a parameter
+-- and signal success via by wrapping the result in a 'Maybe' type. This
+-- function logs the returned warnings and propagates errors as exceptions
+-- (of type 'SourceError').
+--
+-- This function assumes the following invariants:
+--
+--  1. If the second result indicates success (is of the form 'Just x'),
+--     there must be no error messages in the first result.
+--
+--  2. If there are no error messages, but the second result indicates failure
+--     there should be warnings in the first result. That is, if the action
+--     failed, it must have been due to the warnings (i.e., @-Werror@).
+ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
+ioMsgMaybe ioA = do
+    ((warns,errs), mb_r) <- liftIO ioA
+    logWarnings warns
+    case mb_r of
+        Nothing -> throwErrors errs
+        Just r  -> ASSERT( isEmptyBag errs ) return r
+
+-- | like ioMsgMaybe, except that we ignore error messages and return
+-- 'Nothing' instead.
+ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' ioA = do
+    ((warns,_errs), mb_r) <- liftIO $ ioA
+    logWarnings warns
+    return mb_r
+
+-- -----------------------------------------------------------------------------
+-- | Lookup things in the compiler's environment
+
+hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
+hscTcRnLookupRdrName hsc_env0 rdr_name
+  = runInteractiveHsc hsc_env0 $
+    do { hsc_env <- getHscEnv
+       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
+
+hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  ioMsgMaybe' $ tcRnLookupName hsc_env name
+      -- ignore errors: the only error we're likely to get is
+      -- "name not found", and the Maybe in the return type
+      -- is used to indicate that.
+
+hscTcRnGetInfo :: HscEnv -> Name
+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
+hscTcRnGetInfo hsc_env0 name
+  = runInteractiveHsc hsc_env0 $
+    do { hsc_env <- getHscEnv
+       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
+
+hscIsGHCiMonad :: HscEnv -> String -> IO Name
+hscIsGHCiMonad hsc_env name
+  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
+
+hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  ioMsgMaybe $ getModuleInterface hsc_env mod
+
+-- -----------------------------------------------------------------------------
+-- | Rename some import declarations
+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
+
+-- -----------------------------------------------------------------------------
+-- | parse a file, returning the abstract syntax
+
+hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
+
+-- internal version, that doesn't fail due to -Werror
+hscParse' :: ModSummary -> Hsc HsParsedModule
+hscParse' mod_summary
+ | Just r <- ms_parsed_mod mod_summary = return r
+ | otherwise = {-# SCC "Parser" #-}
+    withTiming getDynFlags
+               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
+               (const ()) $ do
+    dflags <- getDynFlags
+    let src_filename  = ms_hspp_file mod_summary
+        maybe_src_buf = ms_hspp_buf  mod_summary
+
+    --------------------------  Parser  ----------------
+    -- sometimes we already have the buffer in memory, perhaps
+    -- because we needed to parse the imports out of it, or get the
+    -- module name.
+    buf <- case maybe_src_buf of
+               Just b  -> return b
+               Nothing -> liftIO $ hGetStringBuffer src_filename
+
+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
+    let parseMod | HsigFile == ms_hsc_src mod_summary
+                 = parseSignature
+                 | otherwise = parseModule
+
+    case unP parseMod (mkPState dflags buf loc) of
+        PFailed pst ->
+            handleWarningsThrowErrors (getMessages pst dflags)
+        POk pst rdr_module -> do
+            let (warns, errs) = getMessages pst dflags
+            logWarnings warns
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
+                                   ppr rdr_module
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
+                                   showAstData NoBlankSrcSpan rdr_module
+            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
+                                   ppSourceStats False rdr_module
+            when (not $ isEmptyBag errs) $ throwErrors errs
+
+            -- To get the list of extra source files, we take the list
+            -- that the parser gave us,
+            --   - eliminate files beginning with '<'.  gcc likes to use
+            --     pseudo-filenames like "<built-in>" and "<command-line>"
+            --   - normalise them (eliminate differences between ./f and f)
+            --   - filter out the preprocessed source file
+            --   - filter out anything beginning with tmpdir
+            --   - remove duplicates
+            --   - filter out the .hs/.lhs source filename if we have one
+            --
+            let n_hspp  = FilePath.normalise src_filename
+                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
+                            $ filter (not . (== n_hspp))
+                            $ map FilePath.normalise
+                            $ filter (not . isPrefixOf "<")
+                            $ map unpackFS
+                            $ srcfiles pst
+                srcs1 = case ml_hs_file (ms_location mod_summary) of
+                          Just f  -> filter (/= FilePath.normalise f) srcs0
+                          Nothing -> srcs0
+
+            -- sometimes we see source files from earlier
+            -- preprocessing stages that cannot be found, so just
+            -- filter them out:
+            srcs2 <- liftIO $ filterM doesFileExist srcs1
+
+            let res = HsParsedModule {
+                      hpm_module    = rdr_module,
+                      hpm_src_files = srcs2,
+                      hpm_annotations
+                              = (M.fromListWith (++) $ annotations pst,
+                                 M.fromList $ ((noSrcSpan,comment_q pst)
+                                                 :(annotations_comments pst)))
+                   }
+
+            -- apply parse transformation of plugins
+            let applyPluginAction p opts
+                  = parsedResultAction p opts mod_summary
+            withPlugins dflags applyPluginAction res
+
+
+-- -----------------------------------------------------------------------------
+-- | If the renamed source has been kept, extract it. Dump it if requested.
+extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
+extract_renamed_stuff mod_summary tc_result = do
+    let rn_info = getRenamedStuff tc_result
+
+    dflags <- getDynFlags
+    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
+                           showAstData NoBlankSrcSpan rn_info
+
+    -- Create HIE files
+    when (gopt Opt_WriteHie dflags) $ do
+        -- I assume this fromJust is safe because `-fwrite-hie-file`
+        -- enables the option which keeps the renamed source.
+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
+        let out_file = ml_hie_file $ ms_location mod_summary
+        liftIO $ writeHieFile out_file hieFile
+
+        -- Validate HIE files
+        when (gopt Opt_ValidateHie dflags) $ do
+            hs_env <- Hsc $ \e w -> return (e, w)
+            liftIO $ do
+              -- Validate Scopes
+              case validateScopes $ getAsts $ hie_asts hieFile of
+                  [] -> putMsg dflags $ text "Got valid scopes"
+                  xs -> do
+                    putMsg dflags $ text "Got invalid scopes"
+                    mapM_ (putMsg dflags) xs
+              -- Roundtrip testing
+              nc <- readIORef $ hsc_NC hs_env
+              (file', _) <- readHieFile nc out_file
+              case diffFile hieFile file' of
+                [] ->
+                  putMsg dflags $ text "Got no roundtrip errors"
+                xs -> do
+                  putMsg dflags $ text "Got roundtrip errors"
+                  mapM_ (putMsg dflags) xs
+    return rn_info
+
+
+-- -----------------------------------------------------------------------------
+-- | Rename and typecheck a module, additionally returning the renamed syntax
+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
+                   -> IO (TcGblEnv, RenamedStuff)
+hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
+    tc_result <- hsc_typecheck True mod_summary (Just rdr_module)
+    rn_info <- extract_renamed_stuff mod_summary tc_result
+    return (tc_result, rn_info)
+
+-- | Rename and typecheck a module, but don't return the renamed syntax
+hscTypecheck :: Bool -- ^ Keep renamed source?
+             -> ModSummary -> Maybe HsParsedModule
+             -> Hsc TcGblEnv
+hscTypecheck keep_rn mod_summary mb_rdr_module = do
+    tc_result <- hsc_typecheck keep_rn mod_summary mb_rdr_module
+    _ <- extract_renamed_stuff mod_summary tc_result
+    return tc_result
+
+hsc_typecheck :: Bool -- ^ Keep renamed source?
+              -> ModSummary -> Maybe HsParsedModule
+              -> Hsc TcGblEnv
+hsc_typecheck keep_rn mod_summary mb_rdr_module = do
+    hsc_env <- getHscEnv
+    let hsc_src = ms_hsc_src mod_summary
+        dflags = hsc_dflags hsc_env
+        outer_mod = ms_mod mod_summary
+        mod_name = moduleName outer_mod
+        outer_mod' = mkModule (thisPackage dflags) mod_name
+        inner_mod = canonicalizeHomeModule dflags mod_name
+        src_filename  = ms_hspp_file mod_summary
+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    if hsc_src == HsigFile && not (isHoleModule inner_mod)
+        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
+        else
+         do hpm <- case mb_rdr_module of
+                    Just hpm -> return hpm
+                    Nothing -> hscParse' mod_summary
+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
+            if hsc_src == HsigFile
+                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
+                        ioMsgMaybe $
+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface
+                else return tc_result0
+
+-- wrapper around tcRnModule to handle safe haskell extras
+tcRnModule' :: ModSummary -> Bool -> HsParsedModule
+            -> Hsc TcGblEnv
+tcRnModule' sum save_rn_syntax mod = do
+    hsc_env <- getHscEnv
+    dflags   <- getDynFlags
+
+    tcg_res <- {-# SCC "Typecheck-Rename" #-}
+               ioMsgMaybe $
+                   tcRnModule hsc_env sum
+                     save_rn_syntax mod
+
+    -- See Note [Safe Haskell Overlapping Instances Implementation]
+    -- although this is used for more than just that failure case.
+    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
+    let allSafeOK = safeInferred dflags && tcSafeOK
+
+    -- end of the safe haskell line, how to respond to user?
+    res <- if not (safeHaskellOn dflags)
+                || (safeInferOn dflags && not allSafeOK)
+             -- if safe Haskell off or safe infer failed, mark unsafe
+             then markUnsafeInfer tcg_res whyUnsafe
+
+             -- module (could be) safe, throw warning if needed
+             else do
+                 tcg_res' <- hscCheckSafeImports tcg_res
+                 safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
+                 when safe $ do
+                   case wopt Opt_WarnSafe dflags of
+                     True -> (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnSafe) $
+                              mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
+                              errSafe tcg_res')
+                     False | safeHaskell dflags == Sf_Trustworthy &&
+                             wopt Opt_WarnTrustworthySafe dflags ->
+                             (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
+                              mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
+                              errTwthySafe tcg_res')
+                     False -> return ()
+                 return tcg_res'
+
+    -- apply plugins to the type checking result
+
+
+    return res
+  where
+    pprMod t  = ppr $ moduleName $ tcg_mod t
+    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
+    errTwthySafe t = quotes (pprMod t)
+      <+> text "is marked as Trustworthy but has been inferred as safe!"
+
+-- | Convert a typechecked module to Core
+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
+hscDesugar hsc_env mod_summary tc_result =
+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
+
+hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
+hscDesugar' mod_location tc_result = do
+    hsc_env <- getHscEnv
+    r <- ioMsgMaybe $
+      {-# SCC "deSugar" #-}
+      deSugar hsc_env mod_location tc_result
+
+    -- always check -Werror after desugaring, this is the last opportunity for
+    -- warnings to arise before the backend.
+    handleWarnings
+    return r
+
+-- | Make a 'ModDetails' from the results of typechecking. Used when
+-- typechecking only, as opposed to full compilation.
+makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
+makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
+
+
+{- **********************************************************************
+%*                                                                      *
+                The main compiler pipeline
+%*                                                                      *
+%********************************************************************* -}
+
+{-
+                   --------------------------------
+                        The compilation proper
+                   --------------------------------
+
+It's the task of the compilation proper to compile Haskell, hs-boot and core
+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
+(the module is still parsed and type-checked. This feature is mostly used by
+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
+targets byte-code.
+
+The modes are kept separate because of their different types and meanings:
+
+ * In 'one-shot' mode, we're only compiling a single file and can therefore
+ discard the new ModIface and ModDetails. This is also the reason it only
+ targets hard-code; compiling to byte-code or nothing doesn't make sense when
+ we discard the result.
+
+ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
+ return the newly compiled byte-code.
+
+ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
+ kept separate. This is because compiling to nothing is fairly special: We
+ don't output any interface files, we don't run the simplifier and we don't
+ generate any code.
+
+ * 'Interactive' mode is similar to 'batch' mode except that we return the
+ compiled byte-code together with the ModIface and ModDetails.
+
+Trying to compile a hs-boot file to byte-code will result in a run-time error.
+This is the only thing that isn't caught by the type-system.
+-}
+
+
+type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
+
+-- | This function runs GHC's frontend with recompilation
+-- avoidance. Specifically, it checks if recompilation is needed,
+-- and if it is, it parses and typechecks the input module.
+-- It does not write out the results of typechecking (See
+-- compileOne and hscIncrementalCompile).
+hscIncrementalFrontend :: Bool -- always do basic recompilation check?
+                       -> Maybe TcGblEnv
+                       -> Maybe Messager
+                       -> ModSummary
+                       -> SourceModified
+                       -> Maybe ModIface  -- Old interface, if available
+                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)
+                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
+
+hscIncrementalFrontend
+  always_do_basic_recompilation_check m_tc_result
+  mHscMessage mod_summary source_modified mb_old_iface mod_index
+    = do
+    hsc_env <- getHscEnv
+
+    let msg what = case mHscMessage of
+                   Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
+                   Nothing -> return ()
+
+        skip iface = do
+            liftIO $ msg UpToDate
+            return $ Left iface
+
+        compile mb_old_hash reason = do
+            liftIO $ msg reason
+            result <- genericHscFrontend mod_summary
+            return $ Right (result, mb_old_hash)
+
+        stable = case source_modified of
+                     SourceUnmodifiedAndStable -> True
+                     _                         -> False
+
+    case m_tc_result of
+         Just tc_result
+          | not always_do_basic_recompilation_check ->
+             return $ Right (FrontendTypecheck tc_result, Nothing)
+         _ -> do
+            (recomp_reqd, mb_checked_iface)
+                <- {-# SCC "checkOldIface" #-}
+                   liftIO $ checkOldIface hsc_env mod_summary
+                                source_modified mb_old_iface
+            -- save the interface that comes back from checkOldIface.
+            -- In one-shot mode we don't have the old iface until this
+            -- point, when checkOldIface reads it from the disk.
+            let mb_old_hash = fmap mi_iface_hash mb_checked_iface
+
+            case mb_checked_iface of
+                Just iface | not (recompileRequired recomp_reqd) ->
+                    -- If the module used TH splices when it was last
+                    -- compiled, then the recompilation check is not
+                    -- accurate enough (#481) and we must ignore
+                    -- it.  However, if the module is stable (none of
+                    -- the modules it depends on, directly or
+                    -- indirectly, changed), then we *can* skip
+                    -- recompilation. This is why the SourceModified
+                    -- type contains SourceUnmodifiedAndStable, and
+                    -- it's pretty important: otherwise ghc --make
+                    -- would always recompile TH modules, even if
+                    -- nothing at all has changed. Stability is just
+                    -- the same check that make is doing for us in
+                    -- one-shot mode.
+                    case m_tc_result of
+                    Nothing
+                     | mi_used_th iface && not stable ->
+                        compile mb_old_hash (RecompBecause "TH")
+                    _ ->
+                        skip iface
+                _ ->
+                    case m_tc_result of
+                    Nothing -> compile mb_old_hash recomp_reqd
+                    Just tc_result ->
+                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)
+
+genericHscFrontend :: ModSummary -> Hsc FrontendResult
+genericHscFrontend mod_summary =
+  getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
+
+genericHscFrontend' :: ModSummary -> Hsc FrontendResult
+genericHscFrontend' mod_summary
+    = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary
+
+--------------------------------------------------------------
+-- Compilers
+--------------------------------------------------------------
+
+-- Compile Haskell/boot in OneShot mode.
+hscIncrementalCompile :: Bool
+                      -> Maybe TcGblEnv
+                      -> Maybe Messager
+                      -> HscEnv
+                      -> ModSummary
+                      -> SourceModified
+                      -> Maybe ModIface
+                      -> (Int,Int)
+                      -- HomeModInfo does not contain linkable, since we haven't
+                      -- code-genned yet
+                      -> IO (HscStatus, HomeModInfo)
+hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
+    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
+  = do
+    dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
+    let hsc_env'' = hsc_env' { hsc_dflags = dflags }
+
+    -- One-shot mode needs a knot-tying mutable variable for interface
+    -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
+    -- See also Note [hsc_type_env_var hack]
+    type_env_var <- newIORef emptyNameEnv
+    let mod = ms_mod mod_summary
+        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
+                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
+                | otherwise
+                = hsc_env''
+
+    -- NB: enter Hsc monad here so that we don't bail out early with
+    -- -Werror on typechecker warnings; we also want to run the desugarer
+    -- to get those warnings too. (But we'll always exit at that point
+    -- because the desugarer runs ioMsgMaybe.)
+    runHsc hsc_env $ do
+    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
+            mod_summary source_modified mb_old_iface mod_index
+    case e of
+        -- We didn't need to do any typechecking; the old interface
+        -- file on disk was good enough.
+        Left iface -> do
+            -- Knot tying!  See Note [Knot-tying typecheckIface]
+            hmi <- liftIO . fixIO $ \hmi' -> do
+                let hsc_env' =
+                        hsc_env {
+                            hsc_HPT = addToHpt (hsc_HPT hsc_env)
+                                        (ms_mod_name mod_summary) hmi'
+                        }
+                -- NB: This result is actually not that useful
+                -- in one-shot mode, since we're not going to do
+                -- any further typechecking.  It's much more useful
+                -- in make mode, since this HMI will go into the HPT.
+                details <- genModDetails hsc_env' iface
+                return HomeModInfo{
+                    hm_details = details,
+                    hm_iface = iface,
+                    hm_linkable = Nothing }
+            return (HscUpToDate, hmi)
+        -- We finished type checking.  (mb_old_hash is the hash of
+        -- the interface that existed on disk; it's possible we had
+        -- to retypecheck but the resulting interface is exactly
+        -- the same.)
+        Right (FrontendTypecheck tc_result, mb_old_hash) ->
+            finish mod_summary tc_result mb_old_hash
+
+-- Runs the post-typechecking frontend (desugar and simplify),
+-- and then generates and writes out the final interface. We want
+-- to write the interface AFTER simplification so we can get
+-- as up-to-date and good unfoldings and other info as possible
+-- in the interface file.
+finish :: ModSummary
+       -> TcGblEnv
+       -> Maybe Fingerprint
+       -> Hsc (HscStatus, HomeModInfo)
+finish summary tc_result mb_old_hash = do
+  hsc_env <- getHscEnv
+  let dflags = hsc_dflags hsc_env
+      target = hscTarget dflags
+      hsc_src = ms_hsc_src summary
+      should_desugar =
+        ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
+      mk_simple_iface = do
+        let hsc_status =
+              case (target, hsc_src) of
+                (HscNothing, _) -> HscNotGeneratingCode
+                (_, HsBootFile) -> HscUpdateBoot
+                (_, HsigFile) -> HscUpdateSig
+                _ -> panic "finish"
+        (iface, no_change, details) <- liftIO $
+          hscSimpleIface hsc_env tc_result mb_old_hash
+        return (iface, no_change, details, hsc_status)
+  (iface, no_change, details, hsc_status) <-
+    -- we usually desugar even when we are not generating code, otherwise
+    -- we would miss errors thrown by the desugaring (see #10600). The only
+    -- exceptions are when the Module is Ghc.Prim or when
+    -- it is not a HsSrcFile Module.
+    if should_desugar
+      then do
+        desugared_guts0 <- hscDesugar' (ms_location summary) tc_result
+        if target == HscNothing
+          -- We are not generating code, so we can skip simplification
+          -- and generate a simple interface.
+          then mk_simple_iface
+          else do
+            plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
+            desugared_guts <- hscSimplify' plugins desugared_guts0
+            (iface, no_change, details, cgguts) <-
+              liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
+            return (iface, no_change, details, HscRecomp cgguts summary)
+      else mk_simple_iface
+  liftIO $ hscMaybeWriteIface dflags iface no_change summary
+  return
+    ( hsc_status
+    , HomeModInfo
+      {hm_details = details, hm_iface = iface, hm_linkable = Nothing})
+
+hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
+hscMaybeWriteIface dflags iface no_change summary =
+    let force_write_interface = gopt Opt_WriteInterface dflags
+        write_interface = case hscTarget dflags of
+                            HscNothing      -> False
+                            HscInterpreted  -> False
+                            _               -> True
+    in when (write_interface || force_write_interface) $
+            hscWriteIface dflags iface no_change summary
+
+--------------------------------------------------------------
+-- NoRecomp handlers
+--------------------------------------------------------------
+
+-- NB: this must be knot-tied appropriately, see hscIncrementalCompile
+genModDetails :: HscEnv -> ModIface -> IO ModDetails
+genModDetails hsc_env old_iface
+  = do
+    new_details <- {-# SCC "tcRnIface" #-}
+                   initIfaceLoad hsc_env (typecheckIface old_iface)
+    dumpIfaceStats hsc_env
+    return new_details
+
+--------------------------------------------------------------
+-- Progress displayers.
+--------------------------------------------------------------
+
+oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
+oneShotMsg hsc_env recomp =
+    case recomp of
+        UpToDate ->
+            compilationProgressMsg (hsc_dflags hsc_env) $
+                   "compilation IS NOT required"
+        _ ->
+            return ()
+
+batchMsg :: Messager
+batchMsg hsc_env mod_index recomp mod_summary =
+    case recomp of
+        MustCompile -> showMsg "Compiling " ""
+        UpToDate
+            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+            | otherwise -> return ()
+        RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+    where
+        dflags = hsc_dflags hsc_env
+        showMsg msg reason =
+            compilationProgressMsg dflags $
+            (showModuleIndex mod_index ++
+            msg ++ showModMsg dflags (hscTarget dflags)
+                              (recompileRequired recomp) mod_summary)
+                ++ reason
+
+--------------------------------------------------------------
+-- FrontEnds
+--------------------------------------------------------------
+
+-- | Given a 'ModSummary', parses and typechecks it, returning the
+-- 'TcGblEnv' resulting from type-checking.
+hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
+hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
+
+--------------------------------------------------------------
+-- Safe Haskell
+--------------------------------------------------------------
+
+-- Note [Safe Haskell Trust Check]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Safe Haskell checks that an import is trusted according to the following
+-- rules for an import of module M that resides in Package P:
+--
+--   * If M is recorded as Safe and all its trust dependencies are OK
+--     then M is considered safe.
+--   * If M is recorded as Trustworthy and P is considered trusted and
+--     all M's trust dependencies are OK then M is considered safe.
+--
+-- By trust dependencies we mean that the check is transitive. So if
+-- a module M that is Safe relies on a module N that is trustworthy,
+-- importing module M will first check (according to the second case)
+-- that N is trusted before checking M is trusted.
+--
+-- This is a minimal description, so please refer to the user guide
+-- for more details. The user guide is also considered the authoritative
+-- source in this matter, not the comments or code.
+
+
+-- Note [Safe Haskell Inference]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Safe Haskell does Safe inference on modules that don't have any specific
+-- safe haskell mode flag. The basic approach to this is:
+--   * When deciding if we need to do a Safe language check, treat
+--     an unmarked module as having -XSafe mode specified.
+--   * For checks, don't throw errors but return them to the caller.
+--   * Caller checks if there are errors:
+--     * For modules explicitly marked -XSafe, we throw the errors.
+--     * For unmarked modules (inference mode), we drop the errors
+--       and mark the module as being Unsafe.
+--
+-- It used to be that we only did safe inference on modules that had no Safe
+-- Haskell flags, but now we perform safe inference on all modules as we want
+-- to allow users to set the `-Wsafe`, `-Wunsafe` and
+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
+-- user can ensure their assumptions are correct and see reasons for why a
+-- module is safe or unsafe.
+--
+-- This is tricky as we must be careful when we should throw an error compared
+-- to just warnings. For checking safe imports we manage it as two steps. First
+-- we check any imports that are required to be safe, then we check all other
+-- imports to see if we can infer them to be safe.
+
+
+-- | Check that the safe imports of the module being compiled are valid.
+-- If not we either issue a compilation error if the module is explicitly
+-- using Safe Haskell, or mark the module as unsafe if we're in safe
+-- inference mode.
+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
+hscCheckSafeImports tcg_env = do
+    dflags   <- getDynFlags
+    tcg_env' <- checkSafeImports tcg_env
+    checkRULES dflags tcg_env'
+
+  where
+    checkRULES dflags tcg_env' = do
+      case safeLanguageOn dflags of
+          True -> do
+              -- XSafe: we nuke user written RULES
+              logWarnings $ warns dflags (tcg_rules tcg_env')
+              return tcg_env' { tcg_rules = [] }
+          False
+                -- SafeInferred: user defined RULES, so not safe
+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')
+              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
+
+                -- Trustworthy OR SafeInferred: with no RULES
+              | otherwise
+              -> return tcg_env'
+
+    warns dflags rules = listToBag $ map (warnRules dflags) rules
+    warnRules dflags (L loc (HsRule { rd_name = n })) =
+        mkPlainWarnMsg dflags loc $
+            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
+            text "User defined rules are disabled under Safe Haskell"
+    warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports"
+
+-- | Validate that safe imported modules are actually safe.  For modules in the
+-- HomePackage (the package the module we are compiling in resides) this just
+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
+-- that reside in another package we also must check that the external package
+-- is trusted. See the Note [Safe Haskell Trust Check] above for more
+-- information.
+--
+-- The code for this is quite tricky as the whole algorithm is done in a few
+-- distinct phases in different parts of the code base. See
+-- RnNames.rnImportDecl for where package trust dependencies for a module are
+-- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust
+-- Transitively] and the Note [RnNames . Trust Own Package].
+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
+checkSafeImports tcg_env
+    = do
+        dflags <- getDynFlags
+        imps <- mapM condense imports'
+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
+
+        -- We want to use the warning state specifically for detecting if safe
+        -- inference has failed, so store and clear any existing warnings.
+        oldErrs <- getWarnings
+        clearWarnings
+
+        -- Check safe imports are correct
+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
+        safeErrs <- getWarnings
+        clearWarnings
+
+        -- Check non-safe imports are correct if inferring safety
+        -- See the Note [Safe Haskell Inference]
+        (infErrs, infPkgs) <- case (safeInferOn dflags) of
+          False -> return (emptyBag, S.empty)
+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
+                     infErrs <- getWarnings
+                     clearWarnings
+                     return (infErrs, infPkgs)
+
+        -- restore old errors
+        logWarnings oldErrs
+
+        case (isEmptyBag safeErrs) of
+          -- Failed safe check
+          False -> liftIO . throwIO . mkSrcErr $ safeErrs
+
+          -- Passed safe check
+          True -> do
+            let infPassed = isEmptyBag infErrs
+            tcg_env' <- case (not infPassed) of
+              True  -> markUnsafeInfer tcg_env infErrs
+              False -> return tcg_env
+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
+
+  where
+    impInfo  = tcg_imports tcg_env     -- ImportAvails
+    imports  = imp_mods impInfo        -- ImportedMods
+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])
+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])
+    pkgReqs  = imp_trust_pkgs impInfo  -- [UnitId]
+
+    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
+    condense (_, [])   = panic "HscMain.condense: Pattern match failure!"
+    condense (m, x:xs) = do imv <- foldlM cond' x xs
+                            return (m, imv_span imv, imv_is_safe imv)
+
+    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
+    cond' v1 v2
+        | imv_is_safe v1 /= imv_is_safe v2
+        = do
+            dflags <- getDynFlags
+            throwOneError $ mkPlainErrMsg dflags (imv_span v1)
+              (text "Module" <+> ppr (imv_name v1) <+>
+              (text $ "is imported both as a safe and unsafe import!"))
+        | otherwise
+        = return v1
+
+    -- easier interface to work with
+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
+
+    -- what pkg's to add to our trust requirements
+    pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
+          Bool -> ImportAvails
+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
+                                  && not (safeHaskellModeEnabled dflags) && infPassed
+                                   = emptyImportAvails {
+                                       imp_trust_pkgs = req `S.union` inf
+                                   }
+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe
+                         = emptyImportAvails
+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
+
+-- | Check that a module is safe to import.
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an exception may be thrown first.
+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
+hscCheckSafe hsc_env m l = runHsc hsc_env $ do
+    dflags <- getDynFlags
+    pkgs <- snd `fmap` hscCheckSafe' m l
+    when (packageTrustOn dflags) $ checkPkgTrust pkgs
+    errs <- getWarnings
+    return $ isEmptyBag errs
+
+-- | Return if a module is trusted and the pkgs it depends on to be trusted.
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
+hscGetSafe hsc_env m l = runHsc hsc_env $ do
+    (self, pkgs) <- hscCheckSafe' m l
+    good         <- isEmptyBag `fmap` getWarnings
+    clearWarnings -- don't want them printed...
+    let pkgs' | Just p <- self = S.insert p pkgs
+              | otherwise      = pkgs
+    return (good, pkgs')
+
+-- | Is a module trusted? If not, throw or log errors depending on the type.
+-- Return (regardless of trusted or not) if the trust type requires the modules
+-- own package be trusted and a list of other packages required to be trusted
+-- (these later ones haven't been checked) but the own package trust has been.
+hscCheckSafe' :: Module -> SrcSpan
+  -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
+hscCheckSafe' m l = do
+    dflags <- getDynFlags
+    (tw, pkgs) <- isModSafe m l
+    case tw of
+        False                     -> return (Nothing, pkgs)
+        True | isHomePkg dflags m -> return (Nothing, pkgs)
+             -- TODO: do we also have to check the trust of the instantiation?
+             -- Not necessary if that is reflected in dependencies
+             | otherwise   -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
+  where
+    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
+    isModSafe m l = do
+        dflags <- getDynFlags
+        iface <- lookup' m
+        case iface of
+            -- can't load iface to check trust!
+            Nothing -> throwOneError $ mkPlainErrMsg dflags l
+                         $ text "Can't load the interface file for" <+> ppr m
+                           <> text ", to check that it can be safely imported"
+
+            -- got iface, check trust
+            Just iface' ->
+                let trust = getSafeMode $ mi_trust iface'
+                    trust_own_pkg = mi_trust_pkg iface'
+                    -- check module is trusted
+                    safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
+                    -- check package is trusted
+                    safeP = packageTrusted dflags trust trust_own_pkg m
+                    -- pkg trust reqs
+                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
+                    -- General errors we throw but Safe errors we log
+                    errs = case (safeM, safeP) of
+                        (True, True ) -> emptyBag
+                        (True, False) -> pkgTrustErr
+                        (False, _   ) -> modTrustErr
+                in do
+                    logWarnings errs
+                    return (trust == Sf_Trustworthy, pkgRs)
+
+                where
+                    pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
+                        sep [ ppr (moduleName m)
+                                <> text ": Can't be safely imported!"
+                            , text "The package (" <> ppr (moduleUnitId m)
+                                <> text ") the module resides in isn't trusted."
+                            ]
+                    modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
+                        sep [ ppr (moduleName m)
+                                <> text ": Can't be safely imported!"
+                            , text "The module itself isn't safe." ]
+
+    -- | Check the package a module resides in is trusted. Safe compiled
+    -- modules are trusted without requiring that their package is trusted. For
+    -- trustworthy modules, modules in the home package are trusted but
+    -- otherwise we check the package trust flag.
+    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
+    packageTrusted _ Sf_None      _ _ = False -- shouldn't hit these cases
+    packageTrusted _ Sf_Ignore    _ _ = False -- shouldn't hit these cases
+    packageTrusted _ Sf_Unsafe    _ _ = False -- prefer for completeness.
+    packageTrusted dflags _ _ _
+        | not (packageTrustOn dflags) = True
+    packageTrusted _ Sf_Safe  False _ = True
+    packageTrusted dflags _ _ m
+        | isHomePkg dflags m = True
+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
+
+    lookup' :: Module -> Hsc (Maybe ModIface)
+    lookup' m = do
+        dflags <- getDynFlags
+        hsc_env <- getHscEnv
+        hsc_eps <- liftIO $ hscEPS hsc_env
+        let pkgIfaceT = eps_PIT hsc_eps
+            homePkgT  = hsc_HPT hsc_env
+            iface     = lookupIfaceByModule dflags homePkgT pkgIfaceT m
+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
+        -- as the compiler hasn't filled in the various module tables
+        -- so we need to call 'getModuleInterface' to load from disk
+        iface' <- case iface of
+            Just _  -> return iface
+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
+        return iface'
+
+
+    isHomePkg :: DynFlags -> Module -> Bool
+    isHomePkg dflags m
+        | thisPackage dflags == moduleUnitId m = True
+        | otherwise                               = False
+
+-- | Check the list of packages are trusted.
+checkPkgTrust :: Set InstalledUnitId -> Hsc ()
+checkPkgTrust pkgs = do
+    dflags <- getDynFlags
+    let errors = S.foldr go [] pkgs
+        go pkg acc
+            | trusted $ getInstalledPackageDetails dflags pkg
+            = acc
+            | otherwise
+            = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
+                     $ text "The package (" <> ppr pkg <> text ") is required" <>
+                       text " to be trusted but it isn't!"
+    case errors of
+        [] -> return ()
+        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
+
+-- | Set module to unsafe and (potentially) wipe trust information.
+--
+-- Make sure to call this method to set a module to inferred unsafe, it should
+-- be a central and single failure method. We only wipe the trust information
+-- when we aren't in a specific Safe Haskell mode.
+--
+-- While we only use this for recording that a module was inferred unsafe, we
+-- may call it on modules using Trustworthy or Unsafe flags so as to allow
+-- warning flags for safety to function correctly. See Note [Safe Haskell
+-- Inference].
+markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
+markUnsafeInfer tcg_env whyUnsafe = do
+    dflags <- getDynFlags
+
+    when (wopt Opt_WarnUnsafe dflags)
+         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
+             mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
+
+    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
+    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
+    -- times inference may be on but we are in Trustworthy mode -- so we want
+    -- to record safe-inference failed but not wipe the trust dependencies.
+    case not (safeHaskellModeEnabled dflags) of
+      True  -> return $ tcg_env { tcg_imports = wiped_trust }
+      False -> return tcg_env
+
+  where
+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env
+    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
+                         , text "Reason:"
+                         , nest 4 $ (vcat $ badFlags df) $+$
+                                    (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
+                                    (vcat $ badInsts $ tcg_insts tcg_env)
+                         ]
+    badFlags df   = concat $ map (badFlag df) unsafeFlagsForInfer
+    badFlag df (str,loc,on,_)
+        | on df     = [mkLocMessage SevOutput (loc df) $
+                            text str <+> text "is not allowed in Safe Haskell"]
+        | otherwise = []
+    badInsts insts = concat $ map badInst insts
+
+    checkOverlap (NoOverlap _) = False
+    checkOverlap _             = True
+
+    badInst ins | checkOverlap (overlapMode (is_flag ins))
+                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
+                      ppr (overlapMode $ is_flag ins) <+>
+                      text "overlap mode isn't allowed in Safe Haskell"]
+                | otherwise = []
+
+
+-- | Figure out the final correct safe haskell mode
+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
+hscGetSafeMode tcg_env = do
+    dflags  <- getDynFlags
+    liftIO $ finalSafeMode dflags tcg_env
+
+--------------------------------------------------------------
+-- Simplifiers
+--------------------------------------------------------------
+
+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
+hscSimplify hsc_env plugins modguts =
+    runHsc hsc_env $ hscSimplify' plugins modguts
+
+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
+hscSimplify' plugins ds_result = do
+    hsc_env <- getHscEnv
+    let hsc_env_with_plugins = hsc_env
+          { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
+          }
+    {-# SCC "Core2Core" #-}
+      liftIO $ core2core hsc_env_with_plugins ds_result
+
+--------------------------------------------------------------
+-- Interface generators
+--------------------------------------------------------------
+
+hscSimpleIface :: HscEnv
+               -> TcGblEnv
+               -> Maybe Fingerprint
+               -> IO (ModIface, Bool, ModDetails)
+hscSimpleIface hsc_env tc_result mb_old_iface
+    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
+
+hscSimpleIface' :: TcGblEnv
+                -> Maybe Fingerprint
+                -> Hsc (ModIface, Bool, ModDetails)
+hscSimpleIface' tc_result mb_old_iface = do
+    hsc_env   <- getHscEnv
+    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result
+    safe_mode <- hscGetSafeMode tc_result
+    (new_iface, no_change)
+        <- {-# SCC "MkFinalIface" #-}
+           liftIO $
+               mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
+    -- And the answer is ...
+    liftIO $ dumpIfaceStats hsc_env
+    return (new_iface, no_change, details)
+
+hscNormalIface :: HscEnv
+               -> ModGuts
+               -> Maybe Fingerprint
+               -> IO (ModIface, Bool, ModDetails, CgGuts)
+hscNormalIface hsc_env simpl_result mb_old_iface =
+    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
+
+hscNormalIface' :: ModGuts
+                -> Maybe Fingerprint
+                -> Hsc (ModIface, Bool, ModDetails, CgGuts)
+hscNormalIface' simpl_result mb_old_iface = do
+    hsc_env <- getHscEnv
+    (cg_guts, details) <- {-# SCC "CoreTidy" #-}
+                          liftIO $ tidyProgram hsc_env simpl_result
+
+    -- BUILD THE NEW ModIface and ModDetails
+    --  and emit external core if necessary
+    -- This has to happen *after* code gen so that the back-end
+    -- info has been set. Not yet clear if it matters waiting
+    -- until after code output
+    (new_iface, no_change)
+        <- {-# SCC "MkFinalIface" #-}
+           liftIO $
+               mkIface hsc_env mb_old_iface details simpl_result
+
+    liftIO $ dumpIfaceStats hsc_env
+
+    -- Return the prepared code.
+    return (new_iface, no_change, details, cg_guts)
+
+--------------------------------------------------------------
+-- BackEnd combinators
+--------------------------------------------------------------
+
+hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
+hscWriteIface dflags iface no_change mod_summary = do
+    let ifaceFile = ml_hi_file (ms_location mod_summary)
+    unless no_change $
+        {-# SCC "writeIface" #-}
+        writeIfaceFile dflags ifaceFile iface
+    whenGeneratingDynamicToo dflags $ do
+        -- TODO: We should do a no_change check for the dynamic
+        --       interface file too
+        -- TODO: Should handle the dynamic hi filename properly
+        let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
+            dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
+            dynDflags = dynamicTooMkDynamicDynFlags dflags
+        writeIfaceFile dynDflags dynIfaceFile' iface
+
+-- | Compile to hard-code.
+hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
+               -- ^ @Just f@ <=> _stub.c is f
+hscGenHardCode hsc_env cgguts mod_summary output_filename = do
+        let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+                    -- From now on, we just use the bits we need.
+                    cg_module   = this_mod,
+                    cg_binds    = core_binds,
+                    cg_tycons   = tycons,
+                    cg_foreign  = foreign_stubs0,
+                    cg_foreign_files = foreign_files,
+                    cg_dep_pkgs = dependencies,
+                    cg_hpc_info = hpc_info } = cgguts
+            dflags = hsc_dflags hsc_env
+            location = ms_location mod_summary
+            data_tycons = filter isDataTyCon tycons
+            -- cg_tycons includes newtypes, for the benefit of External Core,
+            -- but we don't generate any code for newtypes
+
+        -------------------
+        -- PREPARE FOR CODE GENERATION
+        -- Do saturation and convert to A-normal form
+        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}
+                       corePrepPgm hsc_env this_mod location
+                                   core_binds data_tycons
+        -----------------  Convert to STG ------------------
+        (stg_binds, (caf_ccs, caf_cc_stacks))
+            <- {-# SCC "CoreToStg" #-}
+               myCoreToStg dflags this_mod prepd_binds
+
+        let cost_centre_info =
+              (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
+            prof_init = profilingInitCode this_mod cost_centre_info
+            foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+
+        ------------------  Code generation ------------------
+
+        -- The back-end is streamed: each top-level function goes
+        -- from Stg all the way to asm before dealing with the next
+        -- top-level function, so showPass isn't very useful here.
+        -- Hence we have one showPass for the whole backend, the
+        -- next showPass after this will be "Assembler".
+        withTiming (pure dflags)
+                   (text "CodeGen"<+>brackets (ppr this_mod))
+                   (const ()) $ do
+            cmms <- {-# SCC "StgCmm" #-}
+                            doCodeGen hsc_env this_mod data_tycons
+                                cost_centre_info
+                                stg_binds hpc_info
+
+            ------------------  Code output -----------------------
+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
+                      cmmToRawCmm dflags cmms
+
+            let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
+                              (ppr a)
+                            return a
+                rawcmms1 = Stream.mapM dump rawcmms0
+
+            (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
+            return (output_filename, stub_c_exists, foreign_fps)
+
+
+hscInteractive :: HscEnv
+               -> CgGuts
+               -> ModSummary
+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
+hscInteractive hsc_env cgguts mod_summary = do
+    let dflags = hsc_dflags hsc_env
+    let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+                -- From now on, we just use the bits we need.
+               cg_module   = this_mod,
+               cg_binds    = core_binds,
+               cg_tycons   = tycons,
+               cg_foreign  = foreign_stubs,
+               cg_modBreaks = mod_breaks,
+               cg_spt_entries = spt_entries } = cgguts
+
+        location = ms_location mod_summary
+        data_tycons = filter isDataTyCon tycons
+        -- cg_tycons includes newtypes, for the benefit of External Core,
+        -- but we don't generate any code for newtypes
+
+    -------------------
+    -- PREPARE FOR CODE GENERATION
+    -- Do saturation and convert to A-normal form
+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}
+                   corePrepPgm hsc_env this_mod location core_binds data_tycons
+    -----------------  Generate byte code ------------------
+    comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
+    ------------------ Create f-x-dynamic C-side stuff -----
+    (_istub_h_exists, istub_c_exists)
+        <- outputForeignStubs dflags this_mod location foreign_stubs
+    return (istub_c_exists, comp_bc, spt_entries)
+
+------------------------------
+
+hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
+hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
+    let dflags = hsc_dflags hsc_env
+    cmm <- ioMsgMaybe $ parseCmmFile dflags filename
+    liftIO $ do
+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
+        let -- Make up a module name to give the NCG. We can't pass bottom here
+            -- lest we reproduce #11784.
+            mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
+            cmm_mod = mkModule (thisPackage dflags) mod_name
+        (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup)
+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
+        _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
+             rawCmms
+        return ()
+  where
+    no_loc = ModLocation{ ml_hs_file  = Just filename,
+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",
+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",
+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}
+
+-------------------- Stuff for new code gen ---------------------
+
+doCodeGen   :: HscEnv -> Module -> [TyCon]
+            -> CollectedCCs
+            -> [StgTopBinding]
+            -> HpcInfo
+            -> IO (Stream IO CmmGroup ())
+         -- Note we produce a 'Stream' of CmmGroups, so that the
+         -- backend can be run incrementally.  Otherwise it generates all
+         -- the C-- up front, which has a significant space cost.
+doCodeGen hsc_env this_mod data_tycons
+              cost_centre_info stg_binds hpc_info = do
+    let dflags = hsc_dflags hsc_env
+
+    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
+    dumpIfSet_dyn dflags Opt_D_dump_stg_final
+                  "STG for code gen:" (pprGenStgTopBindings stg_binds_w_fvs)
+    let cmm_stream :: Stream IO CmmGroup ()
+        cmm_stream = {-# SCC "StgCmm" #-}
+            StgCmm.codeGen dflags this_mod data_tycons
+                           cost_centre_info stg_binds_w_fvs hpc_info
+
+        -- codegen consumes a stream of CmmGroup, and produces a new
+        -- stream of CmmGroup (not necessarily synchronised: one
+        -- CmmGroup on input may produce many CmmGroups on output due
+        -- to proc-point splitting).
+
+    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
+                       "Cmm produced by codegen" (ppr a)
+                     return a
+
+        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
+
+    let
+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
+                        "Output Cmm" (ppr a)
+                     return a
+
+        ppr_stream2 = Stream.mapM dump2 pipeline_stream
+
+    return ppr_stream2
+
+
+
+myCoreToStg :: DynFlags -> Module -> CoreProgram
+            -> IO ( [StgTopBinding] -- output program
+                  , CollectedCCs )  -- CAF cost centre info (declared and used)
+myCoreToStg dflags this_mod prepd_binds = do
+    let (stg_binds, cost_centre_info)
+         = {-# SCC "Core2Stg" #-}
+           coreToStg dflags this_mod prepd_binds
+
+    stg_binds2
+        <- {-# SCC "Stg2Stg" #-}
+           stg2stg dflags this_mod stg_binds
+
+    return (stg_binds2, cost_centre_info)
+
+
+{- **********************************************************************
+%*                                                                      *
+\subsection{Compiling a do-statement}
+%*                                                                      *
+%********************************************************************* -}
+
+{-
+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
+you run it you get a list of HValues that should be the same length as the list
+of names; add them to the ClosureEnv.
+
+A naked expression returns a singleton Name [it]. The stmt is lifted into the
+IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
+-}
+
+-- | Compile a stmt all the way to an HValue, but don't run it
+--
+-- We return Nothing to indicate an empty statement (or comment only), not a
+-- parse error.
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
+
+-- | Compile a stmt all the way to an HValue, but don't run it
+--
+-- We return Nothing to indicate an empty statement (or comment only), not a
+-- parse error.
+hscStmtWithLocation :: HscEnv
+                    -> String -- ^ The statement
+                    -> String -- ^ The source
+                    -> Int    -- ^ Starting line
+                    -> IO ( Maybe ([Id]
+                          , ForeignHValue {- IO [HValue] -}
+                          , FixityEnv))
+hscStmtWithLocation hsc_env0 stmt source linenumber =
+  runInteractiveHsc hsc_env0 $ do
+    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
+    case maybe_stmt of
+      Nothing -> return Nothing
+
+      Just parsed_stmt -> do
+        hsc_env <- getHscEnv
+        liftIO $ hscParsedStmt hsc_env parsed_stmt
+
+hscParsedStmt :: HscEnv
+              -> GhciLStmt GhcPs  -- ^ The parsed statement
+              -> IO ( Maybe ([Id]
+                    , ForeignHValue {- IO [HValue] -}
+                    , FixityEnv))
+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
+  -- Rename and typecheck it
+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
+
+  -- Desugar it
+  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
+  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
+  handleWarnings
+
+  -- Then code-gen, and link it
+  -- It's important NOT to have package 'interactive' as thisUnitId
+  -- for linking, else we try to link 'main' and can't find it.
+  -- Whereas the linker already knows to ignore 'interactive'
+  let src_span = srcLocSpan interactiveSrcLoc
+  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
+
+  return $ Just (ids, hval, fix_env)
+
+-- | Compile a decls
+hscDecls :: HscEnv
+         -> String -- ^ The statement
+         -> IO ([TyThing], InteractiveContext)
+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
+
+hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
+hscParseDeclsWithLocation hsc_env source line_num str = do
+    L _ (HsModule{ hsmodDecls = decls }) <-
+      runInteractiveHsc hsc_env $
+        hscParseThingWithLocation source line_num parseModule str
+    return decls
+
+-- | Compile a decls
+hscDeclsWithLocation :: HscEnv
+                     -> String -- ^ The statement
+                     -> String -- ^ The source
+                     -> Int    -- ^ Starting line
+                     -> IO ([TyThing], InteractiveContext)
+hscDeclsWithLocation hsc_env str source linenumber = do
+    L _ (HsModule{ hsmodDecls = decls }) <-
+      runInteractiveHsc hsc_env $
+        hscParseThingWithLocation source linenumber parseModule str
+    hscParsedDecls hsc_env decls
+
+hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
+hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
+    {- Rename and typecheck it -}
+    hsc_env <- getHscEnv
+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
+
+    {- Grab the new instances -}
+    -- We grab the whole environment because of the overlapping that may have
+    -- been done. See the notes at the definition of InteractiveContext
+    -- (ic_instances) for more details.
+    let defaults = tcg_default tc_gblenv
+
+    {- Desugar it -}
+    -- We use a basically null location for iNTERACTIVE
+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",
+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",
+                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }
+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
+
+    {- Simplify -}
+    simpl_mg <- liftIO $ do
+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
+      hscSimplify hsc_env plugins ds_result
+
+    {- Tidy -}
+    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
+
+    let !CgGuts{ cg_module    = this_mod,
+                 cg_binds     = core_binds,
+                 cg_tycons    = tycons,
+                 cg_modBreaks = mod_breaks } = tidy_cg
+
+        !ModDetails { md_insts     = cls_insts
+                    , md_fam_insts = fam_insts } = mod_details
+            -- Get the *tidied* cls_insts and fam_insts
+
+        data_tycons = filter isDataTyCon tycons
+
+    {- Prepare For Code Generation -}
+    -- Do saturation and convert to A-normal form
+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}
+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
+
+    {- Generate byte code -}
+    cbc <- liftIO $ byteCodeGen hsc_env this_mod
+                                prepd_binds data_tycons mod_breaks
+
+    let src_span = srcLocSpan interactiveSrcLoc
+    liftIO $ linkDecls hsc_env src_span cbc
+
+    {- Load static pointer table entries -}
+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
+
+    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
+        patsyns = mg_patsyns simpl_mg
+
+        ext_ids = [ id | id <- bindersOfBinds core_binds
+                       , isExternalName (idName id)
+                       , not (isDFunId id || isImplicitId id) ]
+            -- We only need to keep around the external bindings
+            -- (as decided by TidyPgm), since those are the only ones
+            -- that might later be looked up by name.  But we can exclude
+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
+            --    - Implicit Ids, which are implicit in tcs
+            -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
+
+        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
+        ictxt        = hsc_IC hsc_env
+        -- See Note [Fixity declarations in GHCi]
+        fix_env      = tcg_fix_env tc_gblenv
+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts
+                                                fam_insts defaults fix_env
+    return (new_tythings, new_ictxt)
+
+-- | Load the given static-pointer table entries into the interpreter.
+-- See Note [Grand plan for static forms] in StaticPtrTable.
+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
+hscAddSptEntries hsc_env entries = do
+    let add_spt_entry :: SptEntry -> IO ()
+        add_spt_entry (SptEntry i fpr) = do
+            val <- getHValue hsc_env (idName i)
+            addSptEntry hsc_env fpr val
+    mapM_ add_spt_entry entries
+
+{-
+  Note [Fixity declarations in GHCi]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  To support fixity declarations on types defined within GHCi (as requested
+  in #10018) we record the fixity environment in InteractiveContext.
+  When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
+  fixity environment and uses it to initialize the global typechecker environment.
+  After the typechecker has finished its business, an updated fixity environment
+  (reflecting whatever fixity declarations were present in the statements we
+  passed it) will be returned from hscParsedStmt. This is passed to
+  updateFixityEnv, which will stuff it back into InteractiveContext, to be
+  used in evaluating the next statement.
+
+-}
+
+hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
+hscImport hsc_env str = runInteractiveHsc hsc_env $ do
+    (L _ (HsModule{hsmodImports=is})) <-
+       hscParseThing parseModule str
+    case is of
+        [L _ i] -> return i
+        _ -> liftIO $ throwOneError $
+                 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
+                     text "parse error in import declaration"
+
+-- | Typecheck an expression (but don't run it)
+hscTcExpr :: HscEnv
+          -> TcRnExprMode
+          -> String -- ^ The expression
+          -> IO Type
+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  parsed_expr <- hscParseExpr expr
+  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
+
+-- | Find the kind of a type, after generalisation
+hscKcType
+  :: HscEnv
+  -> Bool            -- ^ Normalise the type
+  -> String          -- ^ The type as a string
+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
+    hsc_env <- getHscEnv
+    ty <- hscParseType str
+    ioMsgMaybe $ tcRnType hsc_env normalise ty
+
+hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
+hscParseExpr expr = do
+  hsc_env <- getHscEnv
+  maybe_stmt <- hscParseStmt expr
+  case maybe_stmt of
+    Just (L _ (BodyStmt _ expr _ _)) -> return expr
+    _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
+      (text "not an expression:" <+> quotes (text expr))
+
+hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
+hscParseStmt = hscParseThing parseStmt
+
+hscParseStmtWithLocation :: String -> Int -> String
+                         -> Hsc (Maybe (GhciLStmt GhcPs))
+hscParseStmtWithLocation source linenumber stmt =
+    hscParseThingWithLocation source linenumber parseStmt stmt
+
+hscParseType :: String -> Hsc (LHsType GhcPs)
+hscParseType = hscParseThing parseType
+
+hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
+hscParseIdentifier hsc_env str =
+    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
+
+hscParseThing :: (Outputable thing, Data thing)
+              => Lexer.P thing -> String -> Hsc thing
+hscParseThing = hscParseThingWithLocation "<interactive>" 1
+
+hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
+                          -> Lexer.P thing -> String -> Hsc thing
+hscParseThingWithLocation source linenumber parser str
+  = withTiming getDynFlags
+               (text "Parser [source]")
+               (const ()) $ {-# SCC "Parser" #-} do
+    dflags <- getDynFlags
+
+    let buf = stringToStringBuffer str
+        loc = mkRealSrcLoc (fsLit source) linenumber 1
+
+    case unP parser (mkPState dflags buf loc) of
+        PFailed pst -> do
+            handleWarningsThrowErrors (getMessages pst dflags)
+
+        POk pst thing -> do
+            logWarningsReportErrors (getMessages pst dflags)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
+                                   showAstData NoBlankSrcSpan thing
+            return thing
+
+
+{- **********************************************************************
+%*                                                                      *
+        Desugar, simplify, convert to bytecode, and link an expression
+%*                                                                      *
+%********************************************************************* -}
+
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
+hscCompileCoreExpr hsc_env =
+  lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
+
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
+hscCompileCoreExpr' hsc_env srcspan ds_expr
+    = do { let dflags = hsc_dflags hsc_env
+
+           {- Simplify it -}
+         ; simpl_expr <- simplifyExpr dflags ds_expr
+
+           {- Tidy it (temporary, until coreSat does cloning) -}
+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
+
+           {- Prepare for codegen -}
+         ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
+
+           {- Lint if necessary -}
+         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
+
+           {- Convert to BCOs -}
+         ; bcos <- coreExprToBCOs hsc_env
+                     (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+
+           {- link it -}
+         ; hval <- linkExpr hsc_env srcspan bcos
+
+         ; return hval }
+
+
+{- **********************************************************************
+%*                                                                      *
+        Statistics on reading interfaces
+%*                                                                      *
+%********************************************************************* -}
+
+dumpIfaceStats :: HscEnv -> IO ()
+dumpIfaceStats hsc_env = do
+    eps <- readIORef (hsc_EPS hsc_env)
+    dumpIfSet dflags (dump_if_trace || dump_rn_stats)
+              "Interface statistics"
+              (ifaceStats eps)
+  where
+    dflags = hsc_dflags hsc_env
+    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
+    dump_if_trace = dopt Opt_D_dump_if_trace dflags
+
+
+{- **********************************************************************
+%*                                                                      *
+        Progress Messages: Module i of n
+%*                                                                      *
+%********************************************************************* -}
+
+showModuleIndex :: (Int, Int) -> String
+showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
+  where
+    n_str = show n
+    i_str = show i
+    padded = replicate (length n_str - length i_str) ' ' ++ i_str
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/HscStats.hs
@@ -0,0 +1,190 @@
+-- |
+-- Statistics for per-module compilations
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+--
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module HscStats ( ppSourceStats ) where
+
+import GhcPrelude
+
+import Bag
+import HsSyn
+import Outputable
+import SrcLoc
+import Util
+
+import Data.Char
+
+-- | Source Statistics
+ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
+ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
+  = (if short then hcat else vcat)
+        (map pp_val
+            [("ExportAll        ", export_all), -- 1 if no export list
+             ("ExportDecls      ", export_ds),
+             ("ExportModules    ", export_ms),
+             ("Imports          ", imp_no),
+             ("  ImpSafe        ", imp_safe),
+             ("  ImpQual        ", imp_qual),
+             ("  ImpAs          ", imp_as),
+             ("  ImpAll         ", imp_all),
+             ("  ImpPartial     ", imp_partial),
+             ("  ImpHiding      ", imp_hiding),
+             ("FixityDecls      ", fixity_sigs),
+             ("DefaultDecls     ", default_ds),
+             ("TypeDecls        ", type_ds),
+             ("DataDecls        ", data_ds),
+             ("NewTypeDecls     ", newt_ds),
+             ("TypeFamilyDecls  ", type_fam_ds),
+             ("DataConstrs      ", data_constrs),
+             ("DataDerivings    ", data_derivs),
+             ("ClassDecls       ", class_ds),
+             ("ClassMethods     ", class_method_ds),
+             ("DefaultMethods   ", default_method_ds),
+             ("InstDecls        ", inst_ds),
+             ("InstMethods      ", inst_method_ds),
+             ("InstType         ", inst_type_ds),
+             ("InstData         ", inst_data_ds),
+             ("TypeSigs         ", bind_tys),
+             ("ClassOpSigs      ", generic_sigs),
+             ("ValBinds         ", val_bind_ds),
+             ("FunBinds         ", fn_bind_ds),
+             ("PatSynBinds      ", patsyn_ds),
+             ("InlineMeths      ", method_inlines),
+             ("InlineBinds      ", bind_inlines),
+             ("SpecialisedMeths ", method_specs),
+             ("SpecialisedBinds ", bind_specs)
+            ])
+  where
+    decls = map unLoc ldecls
+
+    pp_val (_, 0) = empty
+    pp_val (str, n)
+      | not short   = hcat [text str, int n]
+      | otherwise   = hcat [text (trim str), equals, int n, semi]
+
+    trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)
+
+    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
+        = count_sigs [d | SigD _ d <- decls]
+                -- NB: this omits fixity decls on local bindings and
+                -- in class decls. ToDo
+
+    tycl_decls = [d | TyClD _ d <- decls]
+    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
+      countTyClDecls tycl_decls
+
+    inst_decls = [d | InstD _ d <- decls]
+    inst_ds    = length inst_decls
+    default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
+    val_decls  = [d | ValD _ d <- decls]
+
+    real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }
+    n_exports    = length real_exports
+    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True
+                                                 ; _ -> False})
+                         real_exports
+    export_ds    = n_exports - export_ms
+    export_all   = case exports of { Nothing -> 1; _ -> 0 }
+
+    (val_bind_ds, fn_bind_ds, patsyn_ds)
+        = sum3 (map count_bind val_decls)
+
+    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
+        = sum7 (map import_info imports)
+    (data_constrs, data_derivs)
+        = sum2 (map data_info tycl_decls)
+    (class_method_ds, default_method_ds)
+        = sum2 (map class_info tycl_decls)
+    (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
+        = sum5 (map inst_info inst_decls)
+
+    count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)
+    count_bind (PatBind {})                           = (0,1,0)
+    count_bind (FunBind {})                           = (0,1,0)
+    count_bind (PatSynBind {})                        = (0,0,1)
+    count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
+
+    count_sigs sigs = sum5 (map sig_info sigs)
+
+    sig_info (FixSig {})     = (1,0,0,0,0)
+    sig_info (TypeSig {})    = (0,1,0,0,0)
+    sig_info (SpecSig {})    = (0,0,1,0,0)
+    sig_info (InlineSig {})  = (0,0,0,1,0)
+    sig_info (ClassOpSig {}) = (0,0,0,0,1)
+    sig_info _               = (0,0,0,0,0)
+
+    import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
+                                     , ideclAs = as, ideclHiding = spec }))
+        = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+    import_info (dL->L _ (XImportDecl _)) = panic "import_info"
+    import_info _ = panic " import_info: Impossible Match"
+                             -- due to #15884
+
+    safe_info False = 0
+    safe_info True = 1
+    qual_info NotQualified = 0
+    qual_info _  = 1
+    as_info Nothing  = 0
+    as_info (Just _) = 1
+    spec_info Nothing           = (0,0,0,0,1,0,0)
+    spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
+    spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
+
+    data_info (DataDecl { tcdDataDefn = HsDataDefn
+                                          { dd_cons = cs
+                                          , dd_derivs = (dL->L _ derivs)}})
+        = ( length cs
+          , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
+                   0 derivs )
+    data_info _ = (0,0)
+
+    class_info decl@(ClassDecl {})
+        = (classops, addpr (sum3 (map count_bind methods)))
+      where
+        methods = map unLoc $ bagToList (tcdMeths decl)
+        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
+    class_info _ = (0,0)
+
+    inst_info (TyFamInstD {}) = (0,0,0,1,0)
+    inst_info (DataFamInstD {}) = (0,0,0,0,1)
+    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
+                                                 , cid_sigs = inst_sigs
+                                                 , cid_tyfam_insts = ats
+                                                 , cid_datafam_insts = adts } })
+        = case count_sigs (map unLoc inst_sigs) of
+            (_,_,ss,is,_) ->
+                  (addpr (sum3 (map count_bind methods)),
+                   ss, is, length ats, length adts)
+      where
+        methods = map unLoc $ bagToList inst_meths
+    inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"
+    inst_info (XInstDecl _)                 = panic "inst_info"
+
+    -- TODO: use Sum monoid
+    addpr :: (Int,Int,Int) -> Int
+    sum2 :: [(Int, Int)] -> (Int, Int)
+    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
+    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
+    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)
+    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)
+         -> (Int, Int, Int, Int, Int, Int, Int)
+
+    addpr (x,y,z) = x+y+z
+    sum2 = foldr add2 (0,0)
+      where
+        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
+    sum3 = foldr add3 (0,0,0)
+      where
+        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
+    sum5 = foldr add5 (0,0,0,0,0)
+      where
+        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
+    sum7 = foldr add7 (0,0,0,0,0,0,0)
+
+    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/InteractiveEval.hs
@@ -0,0 +1,1046 @@
+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,
+    RecordWildCards, BangPatterns #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2005-2007
+--
+-- Running statements interactively
+--
+-- -----------------------------------------------------------------------------
+
+module InteractiveEval (
+        Resume(..), History(..),
+        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
+        runDecls, runDeclsWithLocation, runParsedDecls,
+        isStmt, hasImport, isImport, isDecl,
+        parseImportDecl, SingleStep(..),
+        abandon, abandonAll,
+        getResumeContext,
+        getHistorySpan,
+        getModBreaks,
+        getHistoryModule,
+        back, forward,
+        setContext, getContext,
+        availsToGlobalRdrEnv,
+        getNamesInScope,
+        getRdrNamesInScope,
+        moduleIsInterpreted,
+        getInfo,
+        exprType,
+        typeKind,
+        parseName,
+        getDocs,
+        GetDocsFailure(..),
+        showModule,
+        moduleIsBootOrNotObjectLinkable,
+        parseExpr, compileParsedExpr,
+        compileExpr, dynCompileExpr,
+        compileExprRemote, compileParsedExprRemote,
+        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import InteractiveEvalTypes
+
+import GHCi
+import GHCi.Message
+import GHCi.RemoteTypes
+import GhcMonad
+import HscMain
+import HsSyn
+import HscTypes
+import InstEnv
+import IfaceEnv   ( newInteractiveBinder )
+import FamInstEnv ( FamInst )
+import CoreFVs    ( orphNamesOfFamInst )
+import TyCon
+import Type             hiding( typeKind )
+import RepType
+import TcType
+import Var
+import Id
+import Name             hiding ( varName )
+import NameSet
+import Avail
+import RdrName
+import VarEnv
+import ByteCodeTypes
+import Linker
+import DynFlags
+import Unique
+import UniqSupply
+import MonadUtils
+import Module
+import PrelNames  ( toDynName, pretendNameIsInScope )
+import TysWiredIn ( isCTupleTyConName )
+import Panic
+import Maybes
+import ErrUtils
+import SrcLoc
+import RtClosureInspect
+import Outputable
+import FastString
+import Bag
+import Util
+import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
+import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
+
+import System.Directory
+import Data.Dynamic
+import Data.Either
+import qualified Data.IntMap as IntMap
+import Data.List (find,intercalate)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import StringBuffer (stringToStringBuffer)
+import Control.Monad
+import GHC.Exts
+import Data.Array
+import Exception
+
+-- -----------------------------------------------------------------------------
+-- running a statement interactively
+
+getResumeContext :: GhcMonad m => m [Resume]
+getResumeContext = withSession (return . ic_resume . hsc_IC)
+
+mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
+mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
+
+getHistoryModule :: History -> Module
+getHistoryModule = breakInfo_module . historyBreakInfo
+
+getHistorySpan :: HscEnv -> History -> SrcSpan
+getHistorySpan hsc_env History{..} =
+  let BreakInfo{..} = historyBreakInfo in
+  case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
+    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
+    _ -> panic "getHistorySpan"
+
+getModBreaks :: HomeModInfo -> ModBreaks
+getModBreaks hmi
+  | Just linkable <- hm_linkable hmi,
+    [BCOs cbc _] <- linkableUnlinked linkable
+  = fromMaybe emptyModBreaks (bc_breaks cbc)
+  | otherwise
+  = emptyModBreaks -- probably object code
+
+{- | Finds the enclosing top level function name -}
+-- ToDo: a better way to do this would be to keep hold of the decl_path computed
+-- by the coverage pass, which gives the list of lexically-enclosing bindings
+-- for each tick.
+findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
+findEnclosingDecls hsc_env (BreakInfo modl ix) =
+   let hmi = expectJust "findEnclosingDecls" $
+             lookupHpt (hsc_HPT hsc_env) (moduleName modl)
+       mb = getModBreaks hmi
+   in modBreaks_decls mb ! ix
+
+-- | Update fixity environment in the current interactive context.
+updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
+updateFixityEnv fix_env = do
+  hsc_env <- getSession
+  let ic = hsc_IC hsc_env
+  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
+
+-- -----------------------------------------------------------------------------
+-- execStmt
+
+-- | default ExecOptions
+execOptions :: ExecOptions
+execOptions = ExecOptions
+  { execSingleStep = RunToCompletion
+  , execSourceFile = "<interactive>"
+  , execLineNumber = 1
+  , execWrap = EvalThis -- just run the statement, don't wrap it in anything
+  }
+
+-- | Run a statement in the current interactive context.
+execStmt
+  :: GhcMonad m
+  => String             -- ^ a statement (bind or expression)
+  -> ExecOptions
+  -> m ExecResult
+execStmt input exec_opts@ExecOptions{..} = do
+    hsc_env <- getSession
+
+    mb_stmt <-
+      liftIO $
+      runInteractiveHsc hsc_env $
+      hscParseStmtWithLocation execSourceFile execLineNumber input
+
+    case mb_stmt of
+      -- empty statement / comment
+      Nothing -> return (ExecComplete (Right []) 0)
+      Just stmt -> execStmt' stmt input exec_opts
+
+-- | Like `execStmt`, but takes a parsed statement as argument. Useful when
+-- doing preprocessing on the AST before execution, e.g. in GHCi (see
+-- GHCi.UI.runStmt).
+execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
+execStmt' stmt stmt_text ExecOptions{..} = do
+    hsc_env <- getSession
+
+    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
+    -- warnings about the implicit bindings we introduce.
+    -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset
+    -- -wwarn-unused-local-binds)
+    let ic       = hsc_IC hsc_env -- use the interactive dflags
+        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
+        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } })
+
+    r <- liftIO $ hscParsedStmt hsc_env' stmt
+
+    case r of
+      Nothing ->
+        -- empty statement / comment
+        return (ExecComplete (Right []) 0)
+      Just (ids, hval, fix_env) -> do
+        updateFixityEnv fix_env
+
+        status <-
+          withVirtualCWD $
+            liftIO $
+              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
+
+        let ic = hsc_IC hsc_env
+            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
+
+            size = ghciHistSize idflags'
+
+        handleRunStatus execSingleStep stmt_text bindings ids
+                        status (emptyHistory size)
+
+runDecls :: GhcMonad m => String -> m [Name]
+runDecls = runDeclsWithLocation "<interactive>" 1
+
+-- | Run some declarations and return any user-visible names that were brought
+-- into scope.
+runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
+runDeclsWithLocation source line_num input = do
+    hsc_env <- getSession
+    decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
+    runParsedDecls decls
+
+-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
+-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
+-- (see GHCi.UI.runStmt).
+runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
+runParsedDecls decls = do
+    hsc_env <- getSession
+    (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
+
+    setSession $ hsc_env { hsc_IC = ic }
+    hsc_env <- getSession
+    hsc_env' <- liftIO $ rttiEnvironment hsc_env
+    setSession hsc_env'
+    return $ filter (not . isDerivedOccName . nameOccName)
+             -- For this filter, see Note [What to show to users]
+           $ map getName tyThings
+
+{- Note [What to show to users]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't want to display internally-generated bindings to users.
+Things like the coercion axiom for newtypes. These bindings all get
+OccNames that users can't write, to avoid the possibility of name
+clashes (in linker symbols).  That gives a convenient way to suppress
+them. The relevant predicate is OccName.isDerivedOccName.
+See #11051 for more background and examples.
+-}
+
+withVirtualCWD :: GhcMonad m => m a -> m a
+withVirtualCWD m = do
+  hsc_env <- getSession
+
+    -- a virtual CWD is only necessary when we're running interpreted code in
+    -- the same process as the compiler.
+  if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
+
+  let ic = hsc_IC hsc_env
+  let set_cwd = do
+        dir <- liftIO $ getCurrentDirectory
+        case ic_cwd ic of
+           Just dir -> liftIO $ setCurrentDirectory dir
+           Nothing  -> return ()
+        return dir
+
+      reset_cwd orig_dir = do
+        virt_dir <- liftIO $ getCurrentDirectory
+        hsc_env <- getSession
+        let old_IC = hsc_IC hsc_env
+        setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
+        liftIO $ setCurrentDirectory orig_dir
+
+  gbracket set_cwd reset_cwd $ \_ -> m
+
+parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
+parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
+
+emptyHistory :: Int -> BoundedList History
+emptyHistory size = nilBL size
+
+handleRunStatus :: GhcMonad m
+                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
+                -> EvalStatus_ [ForeignHValue] [HValueRef]
+                -> BoundedList History
+                -> m ExecResult
+
+handleRunStatus step expr bindings final_ids status history
+  | RunAndLogSteps <- step = tracing
+  | otherwise              = not_tracing
+ where
+  tracing
+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
+    , not is_exception
+    = do
+       hsc_env <- getSession
+       let hmi = expectJust "handleRunStatus" $
+                   lookupHptDirectly (hsc_HPT hsc_env)
+                                     (mkUniqueGrimily mod_uniq)
+           modl = mi_module (hm_iface hmi)
+           breaks = getModBreaks hmi
+
+       b <- liftIO $
+              breakpointStatus hsc_env (modBreaks_flags breaks) ix
+       if b
+         then not_tracing
+           -- This breakpoint is explicitly enabled; we want to stop
+           -- instead of just logging it.
+         else do
+           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+           let bi = BreakInfo modl ix
+               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
+                 -- history is strict, otherwise our BoundedList is pointless.
+           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
+           handleRunStatus RunAndLogSteps expr bindings final_ids
+                           status history'
+    | otherwise
+    = not_tracing
+
+  not_tracing
+    -- Hit a breakpoint
+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
+    = do
+         hsc_env <- getSession
+         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+         let hmi = expectJust "handleRunStatus" $
+                     lookupHptDirectly (hsc_HPT hsc_env)
+                                       (mkUniqueGrimily mod_uniq)
+             modl = mi_module (hm_iface hmi)
+             bp | is_exception = Nothing
+                | otherwise = Just (BreakInfo modl ix)
+         (hsc_env1, names, span, decl) <- liftIO $
+           bindLocalsAtBreakpoint hsc_env apStack_fhv bp
+         let
+           resume = Resume
+             { resumeStmt = expr, resumeContext = resume_ctxt_fhv
+             , resumeBindings = bindings, resumeFinalIds = final_ids
+             , resumeApStack = apStack_fhv
+             , resumeBreakInfo = bp
+             , resumeSpan = span, resumeHistory = toListBL history
+             , resumeDecl = decl
+             , resumeCCS = ccs
+             , resumeHistoryIx = 0 }
+           hsc_env2 = pushResume hsc_env1 resume
+
+         setSession hsc_env2
+         return (ExecBreak names bp)
+
+    -- Completed successfully
+    | EvalComplete allocs (EvalSuccess hvals) <- status
+    = do hsc_env <- getSession
+         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
+             final_names = map getName final_ids
+             dl = hsc_dynLinker hsc_env
+         liftIO $ Linker.extendLinkEnv dl (zip final_names hvals)
+         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+         setSession hsc_env'
+         return (ExecComplete (Right final_names) allocs)
+
+    -- Completed with an exception
+    | EvalComplete alloc (EvalException e) <- status
+    = return (ExecComplete (Left (fromSerializableException e)) alloc)
+
+    | otherwise
+    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
+
+
+resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
+resumeExec canLogSpan step
+ = do
+   hsc_env <- getSession
+   let ic = hsc_IC hsc_env
+       resume = ic_resume ic
+
+   case resume of
+     [] -> liftIO $
+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
+     (r:rs) -> do
+        -- unbind the temporary locals by restoring the TypeEnv from
+        -- before the breakpoint, and drop this Resume from the
+        -- InteractiveContext.
+        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
+            ic' = ic { ic_tythings = resume_tmp_te,
+                       ic_rn_gbl_env = resume_rdr_env,
+                       ic_resume   = rs }
+        setSession hsc_env{ hsc_IC = ic' }
+
+        -- remove any bindings created since the breakpoint from the
+        -- linker's environment
+        let old_names = map getName resume_tmp_te
+            new_names = [ n | thing <- ic_tythings ic
+                            , let n = getName thing
+                            , not (n `elem` old_names) ]
+            dl        = hsc_dynLinker hsc_env
+        liftIO $ Linker.deleteFromLinkEnv dl new_names
+
+        case r of
+          Resume { resumeStmt = expr, resumeContext = fhv
+                 , resumeBindings = bindings, resumeFinalIds = final_ids
+                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
+                 , resumeSpan = span
+                 , resumeHistory = hist } -> do
+               withVirtualCWD $ do
+                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
+                let prevHistoryLst = fromListBL 50 hist
+                    hist' = case mb_brkpt of
+                       Nothing -> prevHistoryLst
+                       Just bi
+                         | not $canLogSpan span -> prevHistoryLst
+                         | otherwise -> mkHistory hsc_env apStack bi `consBL`
+                                                        fromListBL 50 hist
+                handleRunStatus step expr bindings final_ids status hist'
+
+back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
+back n = moveHist (+n)
+
+forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
+forward n = moveHist (subtract n)
+
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
+moveHist fn = do
+  hsc_env <- getSession
+  case ic_resume (hsc_IC hsc_env) of
+     [] -> liftIO $
+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
+     (r:rs) -> do
+        let ix = resumeHistoryIx r
+            history = resumeHistory r
+            new_ix = fn ix
+        --
+        when (history `lengthLessThan` new_ix) $ liftIO $
+           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
+        when (new_ix < 0) $ liftIO $
+           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
+
+        let
+          update_ic apStack mb_info = do
+            (hsc_env1, names, span, decl) <-
+              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
+            let ic = hsc_IC hsc_env1
+                r' = r { resumeHistoryIx = new_ix }
+                ic' = ic { ic_resume = r':rs }
+
+            setSession hsc_env1{ hsc_IC = ic' }
+
+            return (names, new_ix, span, decl)
+
+        -- careful: we want apStack to be the AP_STACK itself, not a thunk
+        -- around it, hence the cases are carefully constructed below to
+        -- make this the case.  ToDo: this is v. fragile, do something better.
+        if new_ix == 0
+           then case r of
+                   Resume { resumeApStack = apStack,
+                            resumeBreakInfo = mb_brkpt } ->
+                          update_ic apStack mb_brkpt
+           else case history !! (new_ix - 1) of
+                   History{..} ->
+                     update_ic historyApStack (Just historyBreakInfo)
+
+
+-- -----------------------------------------------------------------------------
+-- After stopping at a breakpoint, add free variables to the environment
+
+result_fs :: FastString
+result_fs = fsLit "_result"
+
+bindLocalsAtBreakpoint
+        :: HscEnv
+        -> ForeignHValue
+        -> Maybe BreakInfo
+        -> IO (HscEnv, [Name], SrcSpan, String)
+
+-- Nothing case: we stopped when an exception was raised, not at a
+-- breakpoint.  We have no location information or local variables to
+-- bind, all we can do is bind a local variable to the exception
+-- value.
+bindLocalsAtBreakpoint hsc_env apStack Nothing = do
+   let exn_occ = mkVarOccFS (fsLit "_exception")
+       span    = mkGeneralSrcSpan (fsLit "<unknown>")
+   exn_name <- newInteractiveBinder hsc_env exn_occ span
+
+   let e_fs    = fsLit "e"
+       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
+       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
+       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
+
+       ictxt0 = hsc_IC hsc_env
+       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
+       dl     = hsc_dynLinker hsc_env
+   --
+   Linker.extendLinkEnv dl [(exn_name, apStack)]
+   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
+
+-- Just case: we stopped at a breakpoint, we have information about the location
+-- of the breakpoint and the free variables of the expression.
+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
+   let
+       hmi       = expectJust "bindLocalsAtBreakpoint" $
+                     lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
+       breaks    = getModBreaks hmi
+       info      = expectJust "bindLocalsAtBreakpoint2" $
+                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
+       vars      = cgb_vars info
+       result_ty = cgb_resty info
+       occs      = modBreaks_vars breaks ! breakInfo_number
+       span      = modBreaks_locs breaks ! breakInfo_number
+       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
+
+           -- Filter out any unboxed ids;
+           -- we can't bind these at the prompt
+       pointers = filter (\(id,_) -> isPointer id) vars
+       isPointer id | [rep] <- typePrimRep (idType id)
+                    , isGcPtrRep rep                   = True
+                    | otherwise                        = False
+
+       (ids, offsets) = unzip pointers
+
+       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
+
+   -- It might be that getIdValFromApStack fails, because the AP_STACK
+   -- has been accidentally evaluated, or something else has gone wrong.
+   -- So that we don't fall over in a heap when this happens, just don't
+   -- bind any free variables instead, and we emit a warning.
+   mb_hValues <-
+      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
+   when (any isNothing mb_hValues) $
+      debugTraceMsg (hsc_dflags hsc_env) 1 $
+          text "Warning: _result has been evaluated, some bindings have been lost"
+
+   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
+   let tv_subst     = newTyVars us free_tvs
+       filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
+       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
+                      map (substTy tv_subst . idType) filtered_ids
+
+   new_ids     <- zipWith3M mkNewId occs tidy_tys filtered_ids
+   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
+
+   let result_id = Id.mkVanillaGlobal result_name
+                     (substTy tv_subst result_ty)
+       result_ok = isPointer result_id
+
+       final_ids | result_ok = result_id : new_ids
+                 | otherwise = new_ids
+       ictxt0 = hsc_IC hsc_env
+       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
+       names  = map idName new_ids
+       dl     = hsc_dynLinker hsc_env
+
+   let fhvs = catMaybes mb_hValues
+   Linker.extendLinkEnv dl (zip names fhvs)
+   when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)]
+   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
+   return (hsc_env1, if result_ok then result_name:names else names, span, decl)
+  where
+        -- We need a fresh Unique for each Id we bind, because the linker
+        -- state is single-threaded and otherwise we'd spam old bindings
+        -- whenever we stop at a breakpoint.  The InteractveContext is properly
+        -- saved/restored, but not the linker state.  See #1743, test break026.
+   mkNewId :: OccName -> Type -> Id -> IO Id
+   mkNewId occ ty old_id
+     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
+          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
+
+   newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
+     -- Similarly, clone the type variables mentioned in the types
+     -- we have here, *and* make them all RuntimeUnk tyvars
+   newTyVars us tvs
+     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
+                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us
+                    , let name = setNameUnique (tyVarName tv) uniq ]
+
+rttiEnvironment :: HscEnv -> IO HscEnv
+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
+   let tmp_ids = [id | AnId id <- ic_tythings ic]
+       incompletelyTypedIds =
+           [id | id <- tmp_ids
+               , not $ noSkolems id
+               , (occNameFS.nameOccName.idName) id /= result_fs]
+   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+   return hsc_env'
+    where
+     noSkolems = noFreeVarsOfType . idType
+     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
+      let tmp_ids = [id | AnId id <- ic_tythings ic]
+          Just id = find (\i -> idName i == name) tmp_ids
+      if noSkolems id
+         then return hsc_env
+         else do
+           mb_new_ty <- reconstructType hsc_env 10 id
+           let old_ty = idType id
+           case mb_new_ty of
+             Nothing -> return hsc_env
+             Just new_ty -> do
+              case improveRTTIType hsc_env old_ty new_ty of
+               Nothing -> return $
+                        WARN(True, text (":print failed to calculate the "
+                                           ++ "improvement for a type")) hsc_env
+               Just subst -> do
+                 let dflags = hsc_dflags hsc_env
+                 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
+                   (fsep [text "RTTI Improvement for", ppr id, equals,
+                          ppr subst])
+
+                 let ic' = substInteractiveContext ic subst
+                 return hsc_env{hsc_IC=ic'}
+
+pushResume :: HscEnv -> Resume -> HscEnv
+pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
+  where
+        ictxt0 = hsc_IC hsc_env
+        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
+
+-- -----------------------------------------------------------------------------
+-- Abandoning a resume context
+
+abandon :: GhcMonad m => m Bool
+abandon = do
+   hsc_env <- getSession
+   let ic = hsc_IC hsc_env
+       resume = ic_resume ic
+   case resume of
+      []    -> return False
+      r:rs  -> do
+         setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
+         liftIO $ abandonStmt hsc_env (resumeContext r)
+         return True
+
+abandonAll :: GhcMonad m => m Bool
+abandonAll = do
+   hsc_env <- getSession
+   let ic = hsc_IC hsc_env
+       resume = ic_resume ic
+   case resume of
+      []  -> return False
+      rs  -> do
+         setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
+         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
+         return True
+
+-- -----------------------------------------------------------------------------
+-- Bounded list, optimised for repeated cons
+
+data BoundedList a = BL
+                        {-# UNPACK #-} !Int  -- length
+                        {-# UNPACK #-} !Int  -- bound
+                        [a] -- left
+                        [a] -- right,  list is (left ++ reverse right)
+
+nilBL :: Int -> BoundedList a
+nilBL bound = BL 0 bound [] []
+
+consBL :: a -> BoundedList a -> BoundedList a
+consBL a (BL len bound left right)
+  | len < bound = BL (len+1) bound (a:left) right
+  | null right  = BL len     bound [a]      $! tail (reverse left)
+  | otherwise   = BL len     bound (a:left) $! tail right
+
+toListBL :: BoundedList a -> [a]
+toListBL (BL _ _ left right) = left ++ reverse right
+
+fromListBL :: Int -> [a] -> BoundedList a
+fromListBL bound l = BL (length l) bound l []
+
+-- lenBL (BL len _ _ _) = len
+
+-- -----------------------------------------------------------------------------
+-- | Set the interactive evaluation context.
+--
+-- (setContext imports) sets the ic_imports field (which in turn
+-- determines what is in scope at the prompt) to 'imports', and
+-- constructs the ic_rn_glb_env environment to reflect it.
+--
+-- We retain in scope all the things defined at the prompt, and kept
+-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)
+
+setContext :: GhcMonad m => [InteractiveImport] -> m ()
+setContext imports
+  = do { hsc_env <- getSession
+       ; let dflags = hsc_dflags hsc_env
+       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
+       ; case all_env_err of
+           Left (mod, err) ->
+               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
+           Right all_env -> do {
+       ; let old_ic         = hsc_IC hsc_env
+             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
+       ; setSession
+         hsc_env{ hsc_IC = old_ic { ic_imports    = imports
+                                  , ic_rn_gbl_env = final_rdr_env }}}}
+  where
+    formatError dflags mod err = ProgramError . showSDoc dflags $
+      text "Cannot add module" <+> ppr mod <+>
+      text "to context:" <+> text err
+
+findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
+                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
+-- Compute the GlobalRdrEnv for the interactive context
+findGlobalRdrEnv hsc_env imports
+  = do { idecls_env <- hscRnImportDecls hsc_env idecls
+                    -- This call also loads any orphan modules
+       ; return $ case partitionEithers (map mkEnv imods) of
+           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
+           (err : _, _)    -> Left err }
+  where
+    idecls :: [LImportDecl GhcPs]
+    idecls = [noLoc d | IIDecl d <- imports]
+
+    imods :: [ModuleName]
+    imods = [m | IIModule m <- imports]
+
+    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
+      Left err -> Left (mod, err)
+      Right env -> Right env
+
+availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
+availsToGlobalRdrEnv mod_name avails
+  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
+  where
+      -- We're building a GlobalRdrEnv as if the user imported
+      -- all the specified modules into the global interactive module
+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
+    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
+                         is_qual = False,
+                         is_dloc = srcLocSpan interactiveSrcLoc }
+
+mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
+mkTopLevEnv hpt modl
+  = case lookupHpt hpt modl of
+      Nothing -> Left "not a home module"
+      Just details ->
+         case mi_globals (hm_iface details) of
+                Nothing  -> Left "not interpreted"
+                Just env -> Right env
+
+-- | Get the interactive evaluation context, consisting of a pair of the
+-- set of modules from which we take the full top-level scope, and the set
+-- of modules from which we take just the exports respectively.
+getContext :: GhcMonad m => m [InteractiveImport]
+getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
+             return (ic_imports ic)
+
+-- | Returns @True@ if the specified module is interpreted, and hence has
+-- its full top-level scope available.
+moduleIsInterpreted :: GhcMonad m => Module -> m Bool
+moduleIsInterpreted modl = withSession $ \h ->
+ if moduleUnitId modl /= thisPackage (hsc_dflags h)
+        then return False
+        else case lookupHpt (hsc_HPT h) (moduleName modl) of
+                Just details       -> return (isJust (mi_globals (hm_iface details)))
+                _not_a_home_module -> return False
+
+-- | Looks up an identifier in the current interactive context (for :info)
+-- Filter the instances by the ones whose tycons (or clases resp)
+-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
+-- The exact choice of which ones to show, and which to hide, is a judgement call.
+--      (see #1581)
+getInfo :: GhcMonad m => Bool -> Name
+        -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
+getInfo allInfo name
+  = withSession $ \hsc_env ->
+    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
+       case mb_stuff of
+         Nothing -> return Nothing
+         Just (thing, fixity, cls_insts, fam_insts, docs) -> do
+           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
+
+           -- Filter the instances based on whether the constituent names of their
+           -- instance heads are all in scope.
+           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
+               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
+           return (Just (thing, fixity, cls_insts', fam_insts', docs))
+  where
+    plausible rdr_env names
+          -- Dfun involving only names that are in ic_rn_glb_env
+        = allInfo
+       || nameSetAll ok names
+        where   -- A name is ok if it's in the rdr_env,
+                -- whether qualified or not
+          ok n | n == name              = True
+                       -- The one we looked for in the first place!
+               | pretendNameIsInScope n = True
+               | isBuiltInSyntax n      = True
+               | isCTupleTyConName n    = True
+               | isExternalName n       = isJust (lookupGRE_Name rdr_env n)
+               | otherwise              = True
+
+-- | Returns all names in scope in the current interactive context
+getNamesInScope :: GhcMonad m => m [Name]
+getNamesInScope = withSession $ \hsc_env -> do
+  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
+
+-- | Returns all 'RdrName's in scope in the current interactive
+-- context, excluding any that are internally-generated.
+getRdrNamesInScope :: GhcMonad m => m [RdrName]
+getRdrNamesInScope = withSession $ \hsc_env -> do
+  let
+      ic = hsc_IC hsc_env
+      gbl_rdrenv = ic_rn_gbl_env ic
+      gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
+  -- Exclude internally generated names; see e.g. #11328
+  return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
+
+
+-- | Parses a string as an identifier, and returns the list of 'Name's that
+-- the identifier can refer to in the current interactive context.
+parseName :: GhcMonad m => String -> m [Name]
+parseName str = withSession $ \hsc_env -> liftIO $
+   do { lrdr_name <- hscParseIdentifier hsc_env str
+      ; hscTcRnLookupRdrName hsc_env lrdr_name }
+
+-- | Returns @True@ if passed string is a statement.
+isStmt :: DynFlags -> String -> Bool
+isStmt dflags stmt =
+  case parseThing Parser.parseStmt dflags stmt of
+    Lexer.POk _ _ -> True
+    Lexer.PFailed _ -> False
+
+-- | Returns @True@ if passed string has an import declaration.
+hasImport :: DynFlags -> String -> Bool
+hasImport dflags stmt =
+  case parseThing Parser.parseModule dflags stmt of
+    Lexer.POk _ thing -> hasImports thing
+    Lexer.PFailed _ -> False
+  where
+    hasImports = not . null . hsmodImports . unLoc
+
+-- | Returns @True@ if passed string is an import declaration.
+isImport :: DynFlags -> String -> Bool
+isImport dflags stmt =
+  case parseThing Parser.parseImport dflags stmt of
+    Lexer.POk _ _ -> True
+    Lexer.PFailed _ -> False
+
+-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
+isDecl :: DynFlags -> String -> Bool
+isDecl dflags stmt = do
+  case parseThing Parser.parseDeclaration dflags stmt of
+    Lexer.POk _ thing ->
+      case unLoc thing of
+        SpliceD _ _ -> False
+        _ -> True
+    Lexer.PFailed _ -> False
+
+parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
+parseThing parser dflags stmt = do
+  let buf = stringToStringBuffer stmt
+      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+
+  Lexer.unP parser (Lexer.mkPState dflags buf loc)
+
+getDocs :: GhcMonad m
+        => Name
+        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
+           -- TODO: What about docs for constructors etc.?
+getDocs name =
+  withSession $ \hsc_env -> do
+     case nameModule_maybe name of
+       Nothing -> pure (Left (NameHasNoModule name))
+       Just mod -> do
+         if isInteractiveModule mod
+           then pure (Left InteractiveName)
+           else do
+             ModIface { mi_doc_hdr = mb_doc_hdr
+                      , mi_decl_docs = DeclDocMap dmap
+                      , mi_arg_docs = ArgDocMap amap
+                      } <- liftIO $ hscGetModuleInterface hsc_env mod
+             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
+               then pure (Left (NoDocsInIface mod compiled))
+               else pure (Right ( Map.lookup name dmap
+                                , Map.findWithDefault Map.empty name amap))
+  where
+    compiled =
+      -- TODO: Find a more direct indicator.
+      case nameSrcLoc name of
+        RealSrcLoc {} -> False
+        UnhelpfulLoc {} -> True
+
+-- | Failure modes for 'getDocs'.
+
+-- TODO: Find a way to differentiate between modules loaded without '-haddock'
+-- and modules that contain no docs.
+data GetDocsFailure
+
+    -- | 'nameModule_maybe' returned 'Nothing'.
+  = NameHasNoModule Name
+
+    -- | This is probably because the module was loaded without @-haddock@,
+    -- but it's also possible that the entire module contains no documentation.
+  | NoDocsInIface
+      Module
+      Bool -- ^ 'True': The module was compiled.
+           -- 'False': The module was :loaded.
+
+    -- | The 'Name' was defined interactively.
+  | InteractiveName
+
+instance Outputable GetDocsFailure where
+  ppr (NameHasNoModule name) =
+    quotes (ppr name) <+> text "has no module where we could look for docs."
+  ppr (NoDocsInIface mod compiled) = vcat
+    [ text "Can't find any documentation for" <+> ppr mod <> char '.'
+    , text "This is probably because the module was"
+        <+> text (if compiled then "compiled" else "loaded")
+        <+> text "without '-haddock',"
+    , text "but it's also possible that the module contains no documentation."
+    , text ""
+    , if compiled
+        then text "Try re-compiling with '-haddock'."
+        else text "Try running ':set -haddock' and :load the file again."
+        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
+    ]
+  ppr InteractiveName =
+    text "Docs are unavailable for interactive declarations."
+
+-- -----------------------------------------------------------------------------
+-- Getting the type of an expression
+
+-- | Get the type of an expression
+-- Returns the type as described by 'TcRnExprMode'
+exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
+exprType mode expr = withSession $ \hsc_env -> do
+   ty <- liftIO $ hscTcExpr hsc_env mode expr
+   return $ tidyType emptyTidyEnv ty
+
+-- -----------------------------------------------------------------------------
+-- Getting the kind of a type
+
+-- | Get the kind of a  type
+typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
+typeKind normalise str = withSession $ \hsc_env -> do
+   liftIO $ hscKcType hsc_env normalise str
+
+-----------------------------------------------------------------------------
+-- Compile an expression, run it, and deliver the result
+
+-- | Parse an expression, the parsed expression can be further processed and
+-- passed to compileParsedExpr.
+parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
+parseExpr expr = withSession $ \hsc_env -> do
+  liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
+
+-- | Compile an expression, run it, and deliver the resulting HValue.
+compileExpr :: GhcMonad m => String -> m HValue
+compileExpr expr = do
+  parsed_expr <- parseExpr expr
+  compileParsedExpr parsed_expr
+
+-- | Compile an expression, run it, and deliver the resulting HValue.
+compileExprRemote :: GhcMonad m => String -> m ForeignHValue
+compileExprRemote expr = do
+  parsed_expr <- parseExpr expr
+  compileParsedExprRemote parsed_expr
+
+-- | Compile a parsed expression (before renaming), run it, and deliver
+-- the resulting HValue.
+compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
+compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
+  -- > let _compileParsedExpr = expr
+  -- Create let stmt from expr to make hscParsedStmt happy.
+  -- We will ignore the returned [Id], namely [expr_id], and not really
+  -- create a new binding.
+  let expr_fs = fsLit "_compileParsedExpr"
+      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
+      let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $
+        ValBinds noExt
+                     (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
+
+  pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
+  let (hvals_io, fix_env) = case pstmt of
+        Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
+        _ -> panic "compileParsedExprRemote"
+
+  updateFixityEnv fix_env
+  status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
+  case status of
+    EvalComplete _ (EvalSuccess [hval]) -> return hval
+    EvalComplete _ (EvalException e) ->
+      liftIO $ throwIO (fromSerializableException e)
+    _ -> panic "compileParsedExpr"
+
+compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
+compileParsedExpr expr = do
+   fhv <- compileParsedExprRemote expr
+   dflags <- getDynFlags
+   liftIO $ wormhole dflags fhv
+
+-- | Compile an expression, run it and return the result as a Dynamic.
+dynCompileExpr :: GhcMonad m => String -> m Dynamic
+dynCompileExpr expr = do
+  parsed_expr <- parseExpr expr
+  -- > Data.Dynamic.toDyn expr
+  let loc = getLoc parsed_expr
+      to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)
+                            parsed_expr
+  hval <- compileParsedExpr to_dyn_expr
+  return (unsafeCoerce# hval :: Dynamic)
+
+-----------------------------------------------------------------------------
+-- show a module and it's source/object filenames
+
+showModule :: GhcMonad m => ModSummary -> m String
+showModule mod_summary =
+    withSession $ \hsc_env -> do
+        interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
+        let dflags = hsc_dflags hsc_env
+        return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
+
+moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
+moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
+  case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
+        Nothing       -> panic "missing linkable"
+        Just mod_info -> return $ case hm_linkable mod_info of
+          Nothing       -> True
+          Just linkable -> not (isObjectLinkable linkable)
+
+----------------------------------------------------------------------------
+-- RTTI primitives
+
+obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
+obtainTermFromVal hsc_env bound force ty x
+  | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env)
+  = throwIO (InstallationError
+      "this operation requires -fno-external-interpreter")
+  | otherwise
+  = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
+
+obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermFromId hsc_env bound force id =  do
+  hv <- Linker.getHValue hsc_env (varName id)
+  cvObtainTerm hsc_env bound force (idType id) hv
+
+-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
+reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
+reconstructType hsc_env bound id = do
+  hv <- Linker.getHValue hsc_env (varName id)
+  cvReconstructType hsc_env bound (idType id) hv
+
+mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
+mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/PprTyThing.hs
@@ -0,0 +1,206 @@
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing TyThings
+--
+-- (c) The GHC Team 2005
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+module PprTyThing (
+        pprTyThing,
+        pprTyThingInContext,
+        pprTyThingLoc,
+        pprTyThingInContextLoc,
+        pprTyThingHdr,
+        pprTypeForUser,
+        pprFamInst
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Type    ( ArgFlag(..), TyThing(..), mkTyVarBinders, pprUserForAll )
+import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
+  , showToHeader, pprIfaceDecl )
+import CoAxiom ( coAxiomTyCon )
+import HscTypes( tyThingParent_maybe )
+import MkIface ( tyThingToIfaceDecl )
+import Type ( tidyOpenType )
+import FamInstEnv( FamInst(..), FamFlavor(..) )
+import Type( Type, pprTypeApp, pprSigmaType )
+import Name
+import VarEnv( emptyTidyEnv )
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- Pretty-printing entities that we get from the GHC API
+
+{- Note [Pretty printing via IfaceSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Our general plan for prett-printing
+  - Types
+  - TyCons
+  - Classes
+  - Pattern synonyms
+  ...etc...
+
+is to convert them to IfaceSyn, and pretty-print that. For example
+  - pprType converts a Type to an IfaceType, and pretty prints that.
+  - pprTyThing converts the TyThing to an IfaceDecl,
+    and pretty prints that.
+
+So IfaceSyn play a dual role:
+  - it's the internal version of an interface files
+  - it's used for pretty-printing
+
+Why do this?
+
+* A significant reason is that we need to be able
+  to pretty-print IfaceSyn (to display Foo.hi), and it was a
+  pain to duplicate masses of pretty-printing goop, esp for
+  Type and IfaceType.
+
+* When pretty-printing (a type, say), we want to tidy (with
+  tidyType) to avoids having (forall a a. blah) where the two
+  a's have different uniques.
+
+  Alas, for type constructors, TyCon, tidying does not work well,
+  because a TyCon includes DataCons which include Types, which mention
+  TyCons. And tidying can't tidy a mutually recursive data structure
+  graph, only trees.
+
+* Interface files contains fast-strings, not uniques, so the very same
+  tidying must take place when we convert to IfaceDecl. E.g.
+  MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
+  Class etc) to an IfaceDecl.
+
+  Bottom line: IfaceDecls are already 'tidy', so it's straightforward
+  to print them.
+
+* An alternative I once explored was to ensure that TyCons get type
+  variables with distinct print-names. That's ok for type variables
+  but less easy for kind variables. Processing data type declarations
+  is already so complicated that I don't think it's sensible to add
+  the extra requirement that it generates only "pretty" types and
+  kinds.
+
+Consequences:
+
+- IfaceSyn (and IfaceType) must contain enough information to
+  print nicely.  Hence, for example, the IfaceAppArgs type, which
+  allows us to suppress invisible kind arguments in types
+  (see Note [Suppressing invisible arguments] in IfaceType)
+
+- In a few places we have info that is used only for pretty-printing,
+  and is totally ignored when turning IfaceSyn back into TyCons
+  etc (in TcIface). For example, IfaceClosedSynFamilyTyCon
+  stores a [IfaceAxBranch] that is used only for pretty-printing.
+
+- See Note [Free tyvars in IfaceType] in IfaceType
+
+See #7730, #8776 for details   -}
+
+--------------------
+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.
+pprFamInst :: FamInst -> SDoc
+--  * For data instances we go via pprTyThing of the representational TyCon,
+--    because there is already much cleverness associated with printing
+--    data type declarations that I don't want to duplicate
+--  * For type instances we print directly here; there is no TyCon
+--    to give to pprTyThing
+--
+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes
+
+pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })
+  = pprTyThingInContextLoc (ATyCon rep_tc)
+
+pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
+                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })
+  = showWithLoc (pprDefinedAt (getName axiom)) $
+    hang (text "type instance"
+            <+> pprUserForAll (mkTyVarBinders Specified tvs)
+                -- See Note [Printing foralls in type family instances]
+                -- in IfaceType
+            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
+       2 (equals <+> ppr rhs)
+
+----------------------------
+-- | Pretty-prints a 'TyThing' with its defining location.
+pprTyThingLoc :: TyThing -> SDoc
+pprTyThingLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThing showToHeader tyThing)
+
+-- | Pretty-prints the 'TyThing' header. For functions and data constructors
+-- the function is equivalent to 'pprTyThing' but for type constructors
+-- and classes it prints only the header part of the declaration.
+pprTyThingHdr :: TyThing -> SDoc
+pprTyThingHdr = pprTyThing showToHeader
+
+-- | Pretty-prints a 'TyThing' in context: that is, if the entity
+-- is a data constructor, record selector, or class method, then
+-- the entity's parent declaration is pretty-printed with irrelevant
+-- parts omitted.
+pprTyThingInContext :: ShowSub -> TyThing -> SDoc
+pprTyThingInContext show_sub thing
+  = go [] thing
+  where
+    go ss thing
+      = case tyThingParent_maybe thing of
+          Just parent ->
+            go (getOccName thing : ss) parent
+          Nothing ->
+            pprTyThing
+              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })
+              thing
+
+-- | Like 'pprTyThingInContext', but adds the defining location.
+pprTyThingInContextLoc :: TyThing -> SDoc
+pprTyThingInContextLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThingInContext showToHeader tyThing)
+
+-- | Pretty-prints a 'TyThing'.
+pprTyThing :: ShowSub -> TyThing -> SDoc
+-- We pretty-print 'TyThing' via 'IfaceDecl'
+-- See Note [Pretty-printing TyThings]
+pprTyThing ss ty_thing
+  = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing)
+  where
+    ss' = case ss_how_much ss of
+      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }
+      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }
+      _                   -> ss
+
+    ppr' = AltPpr $ ppr_bndr $ getName ty_thing
+
+    ppr_bndr :: Name -> Maybe (OccName -> SDoc)
+    ppr_bndr name
+      | isBuiltInSyntax name
+         = Nothing
+      | otherwise
+         = case nameModule_maybe name of
+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->
+               pprModulePrefix sty mod occ <> ppr occ
+             Nothing  -> WARN( True, ppr name ) Nothing
+             -- Nothing is unexpected here; TyThings have External names
+
+pprTypeForUser :: Type -> SDoc
+-- The type is tidied
+pprTypeForUser ty
+  = pprSigmaType tidy_ty
+  where
+    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty
+     -- Often the types/kinds we print in ghci are fully generalised
+     -- and have no free variables, but it turns out that we sometimes
+     -- print un-generalised kinds (eg when doing :k T), so it's
+     -- better to use tidyOpenType here
+
+showWithLoc :: SDoc -> SDoc -> SDoc
+showWithLoc loc doc
+    = hang doc 2 (char '\t' <> comment <+> loc)
+                -- The tab tries to make them line up a bit
+  where
+    comment = text "--"
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/StaticPtrTable.hs
@@ -0,0 +1,292 @@
+-- | Code generation for the Static Pointer Table
+--
+-- (c) 2014 I/O Tweag
+--
+-- Each module that uses 'static' keyword declares an initialization function of
+-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and
+-- annotated with __attribute__((constructor)) so that it gets executed at
+-- startup time.
+--
+-- The function's purpose is to call hs_spt_insert to insert the static
+-- pointers of this module in the hashtable of the RTS, and it looks something
+-- like this:
+--
+-- > static void hs_hpc_init_Main(void) __attribute__((constructor));
+-- > static void hs_hpc_init_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   extern StgPtr Main_r2wb_closure;
+-- >   hs_spt_insert(k0, &Main_r2wb_closure);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   extern StgPtr Main_r2wc_closure;
+-- >   hs_spt_insert(k1, &Main_r2wc_closure);
+-- >
+-- > }
+--
+-- where the constants are fingerprints produced from the static forms.
+--
+-- The linker must find the definitions matching the @extern StgPtr <name>@
+-- declarations. For this to work, the identifiers of static pointers need to be
+-- exported. This is done in SetLevels.newLvlVar.
+--
+-- There is also a finalization function for the time when the module is
+-- unloaded.
+--
+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
+-- > static void hs_hpc_fini_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   hs_spt_remove(k0);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   hs_spt_remove(k1);
+-- >
+-- > }
+--
+
+{-# LANGUAGE ViewPatterns, TupleSections #-}
+module StaticPtrTable
+    ( sptCreateStaticBinds
+    , sptModuleInitCode
+    ) where
+
+{- Note [Grand plan for static forms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Static forms go through the compilation phases as follows.
+Here is a running example:
+
+   f x = let k = map toUpper
+         in ...(static k)...
+
+* The renamer looks for out-of-scope names in the body of the static
+  form, as always. If all names are in scope, the free variables of the
+  body are stored in AST at the location of the static form.
+
+* The typechecker verifies that all free variables occurring in the
+  static form are floatable to top level (see Note [Meaning of
+  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable.
+  Even though it is bound in a nested let, we are fine.
+
+* The desugarer replaces the static form with an application of the
+  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
+  base).  So we get
+
+   f x = let k = map toUpper
+         in ...fromStaticPtr (makeStatic location k)...
+
+* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
+  to the top level. Thus the FloatOut pass is always executed, even when
+  optimizations are disabled.  So we get
+
+   k = map toUpper
+   static_ptr = makeStatic location k
+   f x = ...fromStaticPtr static_ptr...
+
+  The FloatOut pass is careful to produce an /exported/ Id for a floated
+  'makeStatic' call, so the binding is not removed or inlined by the
+  simplifier.
+  E.g. the code for `f` above might look like
+
+    static_ptr = makeStatic location k
+    f x = ...(case static_ptr of ...)...
+
+  which might be simplified to
+
+    f x = ...(case makeStatic location k of ...)...
+
+  BUT the top-level binding for static_ptr must remain, so that it can be
+  collected to populate the Static Pointer Table.
+
+  Making the binding exported also has a necessary effect during the
+  CoreTidy pass.
+
+* The CoreTidy pass replaces all bindings of the form
+
+  b = /\ ... -> makeStatic location value
+
+  with
+
+  b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
+
+  where a distinct key is generated for each binding.
+
+* If we are compiling to object code we insert a C stub (generated by
+  sptModuleInitCode) into the final object which runs when the module is loaded,
+  inserting the static forms defined by the module into the RTS's static pointer
+  table.
+
+* If we are compiling for the byte-code interpreter, we instead explicitly add
+  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
+  process' SPT table using the addSptEntry interpreter message. This happens
+  in upsweep after we have compiled the module (see GhcMake.upsweep').
+-}
+
+import GhcPrelude
+
+import CLabel
+import CoreSyn
+import CoreUtils (collectMakeStaticArgs)
+import DataCon
+import DynFlags
+import HscTypes
+import Id
+import MkCore (mkStringExprFSWith)
+import Module
+import Name
+import Outputable
+import Platform
+import PrelNames
+import TcEnv (lookupGlobal)
+import Type
+
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State
+import Data.List
+import Data.Maybe
+import GHC.Fingerprint
+import qualified GHC.LanguageExtensions as LangExt
+
+-- | Replaces all bindings of the form
+--
+-- > b = /\ ... -> makeStatic location value
+--
+--  with
+--
+-- > b = /\ ... ->
+-- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
+--
+--  where a distinct key is generated for each binding.
+--
+-- It also yields the C stub that inserts these bindings into the static
+-- pointer table.
+sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
+                     -> IO ([SptEntry], CoreProgram)
+sptCreateStaticBinds hsc_env this_mod binds
+    | not (xopt LangExt.StaticPointers dflags) =
+      return ([], binds)
+    | otherwise = do
+      -- Make sure the required interface files are loaded.
+      _ <- lookupGlobal hsc_env unpackCStringName
+      (fps, binds') <- evalStateT (go [] [] binds) 0
+      return (fps, binds')
+  where
+    go fps bs xs = case xs of
+      []        -> return (reverse fps, reverse bs)
+      bnd : xs' -> do
+        (fps', bnd') <- replaceStaticBind bnd
+        go (reverse fps' ++ fps) (bnd' : bs) xs'
+
+    dflags = hsc_dflags hsc_env
+
+    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
+    --
+    -- The 'Int' state is used to produce a different key for each binding.
+    replaceStaticBind :: CoreBind
+                      -> StateT Int IO ([SptEntry], CoreBind)
+    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
+                                        return (maybeToList mfp, NonRec b' e')
+    replaceStaticBind (Rec rbs) = do
+      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
+      return (catMaybes mfps, Rec rbs')
+
+    replaceStatic :: Id -> CoreExpr
+                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
+    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
+      case collectMakeStaticArgs e0 of
+        Nothing      -> return (Nothing, (b, e))
+        Just (_, t, info, arg) -> do
+          (fp, e') <- mkStaticBind t info arg
+          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
+
+    mkStaticBind :: Type -> CoreExpr -> CoreExpr
+                 -> StateT Int IO (Fingerprint, CoreExpr)
+    mkStaticBind t srcLoc e = do
+      i <- get
+      put (i + 1)
+      staticPtrInfoDataCon <-
+        lift $ lookupDataConHscEnv staticPtrInfoDataConName
+      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
+      info <- mkConApp staticPtrInfoDataCon <$>
+            (++[srcLoc]) <$>
+            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
+                 [ unitIdFS $ moduleUnitId this_mod
+                 , moduleNameFS $ moduleName this_mod
+                 ]
+
+      -- The module interface of GHC.StaticPtr should be loaded at least
+      -- when looking up 'fromStatic' during type-checking.
+      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
+      return (fp, mkConApp staticPtrDataCon
+                               [ Type t
+                               , mkWord64LitWordRep dflags w0
+                               , mkWord64LitWordRep dflags w1
+                               , info
+                               , e ])
+
+    mkStaticPtrFingerprint :: Int -> Fingerprint
+    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
+        [ unitIdString $ moduleUnitId this_mod
+        , moduleNameString $ moduleName this_mod
+        , show n
+        ]
+
+    -- 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
+
+    lookupIdHscEnv :: Name -> IO Id
+    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
+                         maybe (getError n) (return . tyThingId)
+
+    lookupDataConHscEnv :: Name -> IO DataCon
+    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
+                              maybe (getError n) (return . tyThingDataCon)
+
+    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
+      text "Couldn't find" <+> ppr n
+
+-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
+-- of @module@ into the static pointer table.
+--
+-- @fps@ is a list associating each binding corresponding to a static entry with
+-- its fingerprint.
+sptModuleInitCode :: Module -> [SptEntry] -> SDoc
+sptModuleInitCode _ [] = Outputable.empty
+sptModuleInitCode this_mod entries = vcat
+    [ text "static void hs_spt_init_" <> ppr this_mod
+           <> text "(void) __attribute__((constructor));"
+    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
+    , braces $ vcat $
+        [  text "static StgWord64 k" <> int i <> text "[2] = "
+           <> pprFingerprint fp <> semi
+        $$ text "extern StgPtr "
+           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
+        $$ text "hs_spt_insert" <> parens
+             (hcat $ punctuate comma
+                [ char 'k' <> int i
+                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
+                ]
+             )
+        <> semi
+        |  (i, SptEntry n fp) <- zip [0..] entries
+        ]
+    , text "static void hs_spt_fini_" <> ppr this_mod
+           <> text "(void) __attribute__((destructor));"
+    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
+    , braces $ vcat $
+        [  text "StgWord64 k" <> int i <> text "[2] = "
+           <> pprFingerprint fp <> semi
+        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
+        | (i, (SptEntry _ fp)) <- zip [0..] entries
+        ]
+    ]
+  where
+    pprFingerprint :: Fingerprint -> SDoc
+    pprFingerprint (Fingerprint w1 w2) =
+      braces $ hcat $ punctuate comma
+                 [ integer (fromIntegral w1) <> text "ULL"
+                 , integer (fromIntegral w2) <> text "ULL"
+                 ]
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools.hs
@@ -0,0 +1,656 @@
+{-
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2001-2003
+--
+-- Access to system tools: gcc, cp, rm etc
+--
+-----------------------------------------------------------------------------
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}
+
+module SysTools (
+        -- * Initialisation
+        initSysTools,
+        initLlvmConfig,
+
+        -- * Interface to system tools
+        module SysTools.Tasks,
+        module SysTools.Info,
+
+        linkDynLib,
+
+        copy,
+        copyWithHeader,
+
+        -- * General utilities
+        Option(..),
+        expandTopDir,
+
+        -- * Platform-specifics
+        libmLinkOpts,
+
+        -- * Mac OS X frameworks
+        getPkgFrameworkOpts,
+        getFrameworkOpts
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Module
+import Packages
+import Config
+import Outputable
+import ErrUtils
+import Platform
+import Util
+import DynFlags
+import Fingerprint
+
+import System.FilePath
+import System.IO
+import System.Directory
+import SysTools.ExtraObj
+import SysTools.Info
+import SysTools.Tasks
+import SysTools.BaseDir
+
+{-
+Note [How GHC finds toolchain utilities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+SysTools.initSysProgs figures out exactly where all the auxiliary programs
+are, and initialises mutable variables to make it easy to call them.
+To do this, it makes use of definitions in Config.hs, which is a Haskell
+file containing variables whose value is figured out by the build system.
+
+Config.hs contains two sorts of things
+
+  cGCC,         The *names* of the programs
+  cCPP            e.g.  cGCC = gcc
+  cUNLIT                cCPP = gcc -E
+  etc           They do *not* include paths
+
+
+  cUNLIT_DIR   The *path* to the directory containing unlit, split etc
+  cSPLIT_DIR   *relative* to the root of the build tree,
+                   for use when running *in-place* in a build tree (only)
+
+
+---------------------------------------------
+NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
+
+Another hair-brained scheme for simplifying the current tool location
+nightmare in GHC: Simon originally suggested using another
+configuration file along the lines of GCC's specs file - which is fine
+except that it means adding code to read yet another configuration
+file.  What I didn't notice is that the current package.conf is
+general enough to do this:
+
+Package
+    {name = "tools",    import_dirs = [],  source_dirs = [],
+     library_dirs = [], hs_libraries = [], extra_libraries = [],
+     include_dirs = [], c_includes = [],   package_deps = [],
+     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
+     extra_cc_opts = [], extra_ld_opts = []}
+
+Which would have the advantage that we get to collect together in one
+place the path-specific package stuff with the path-specific tool
+stuff.
+                End of NOTES
+---------------------------------------------
+
+************************************************************************
+*                                                                      *
+\subsection{Initialisation}
+*                                                                      *
+************************************************************************
+-}
+
+initLlvmConfig :: String
+               -> IO LlvmConfig
+initLlvmConfig top_dir
+  = do
+      targets <- readAndParse "llvm-targets" mkLlvmTarget
+      passes <- readAndParse "llvm-passes" id
+      return (targets, passes)
+  where
+    readAndParse name builder =
+      do let llvmConfigFile = top_dir </> name
+         llvmConfigStr <- readFile llvmConfigFile
+         case maybeReadFuzzy llvmConfigStr of
+           Just s -> return (fmap builder <$> s)
+           Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)
+
+    mkLlvmTarget :: (String, String, String) -> LlvmTarget
+    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)
+
+
+initSysTools :: String          -- TopDir path
+             -> IO Settings     -- Set all the mutable variables above, holding
+                                --      (a) the system programs
+                                --      (b) the package-config file
+                                --      (c) the GHC usage message
+initSysTools top_dir
+  = do       -- see Note [topdir: How GHC finds its files]
+             -- NB: top_dir is assumed to be in standard Unix
+             -- format, '/' separated
+       mtool_dir <- findToolDir top_dir
+             -- see Note [tooldir: How GHC finds mingw on Windows]
+
+       let installed :: FilePath -> FilePath
+           installed file = top_dir </> file
+           libexec :: FilePath -> FilePath
+           libexec file = top_dir </> "bin" </> file
+           settingsFile = installed "settings"
+           platformConstantsFile = installed "platformConstants"
+
+       settingsStr <- readFile settingsFile
+       platformConstantsStr <- readFile platformConstantsFile
+       mySettings <- case maybeReadFuzzy settingsStr of
+                     Just s ->
+                         return s
+                     Nothing ->
+                         pgmError ("Can't parse " ++ show settingsFile)
+       platformConstants <- case maybeReadFuzzy platformConstantsStr of
+                            Just s ->
+                                return s
+                            Nothing ->
+                                pgmError ("Can't parse " ++
+                                          show platformConstantsFile)
+       let getSetting key = case lookup key mySettings of
+                            Just xs -> return $ expandTopDir top_dir xs
+                            Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+           getToolSetting key = expandToolDir mtool_dir <$> getSetting key
+           getBooleanSetting key = case lookup key mySettings of
+                                   Just "YES" -> return True
+                                   Just "NO" -> return False
+                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
+                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+           readSetting key = case lookup key mySettings of
+                             Just xs ->
+                                 case maybeRead xs of
+                                 Just v -> return v
+                                 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
+                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+       crossCompiling <- getBooleanSetting "cross compiling"
+       targetPlatformString <- getSetting "target platform string"
+       targetArch <- readSetting "target arch"
+       targetOS <- readSetting "target os"
+       targetWordSize <- readSetting "target word size"
+       targetUnregisterised <- getBooleanSetting "Unregisterised"
+       targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
+       targetHasIdentDirective <- readSetting "target has .ident directive"
+       targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
+       tablesNextToCode <- getBooleanSetting "Tables next to code"
+       myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
+       -- On Windows, mingw is distributed with GHC,
+       -- so we look in TopDir/../mingw/bin,
+       -- as well as TopDir/../../mingw/bin for hadrian.
+       -- It would perhaps be nice to be able to override this
+       -- with the settings file, but it would be a little fiddly
+       -- to make that possible, so for now you can't.
+       gcc_prog <- getToolSetting "C compiler command"
+       gcc_args_str <- getSetting "C compiler flags"
+       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
+       cpp_prog <- getToolSetting "Haskell CPP command"
+       cpp_args_str <- getSetting "Haskell CPP flags"
+       let unreg_gcc_args = if targetUnregisterised
+                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
+                            else []
+           cpp_args= map Option (words cpp_args_str)
+           gcc_args = map Option (words gcc_args_str
+                               ++ unreg_gcc_args)
+       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
+       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
+       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
+       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
+
+       let pkgconfig_path = installed "package.conf.d"
+           ghc_usage_msg_path  = installed "ghc-usage.txt"
+           ghci_usage_msg_path = installed "ghci-usage.txt"
+
+       -- For all systems, unlit, split, mangle are GHC utilities
+       -- architecture-specific stuff is done when building Config.hs
+       unlit_path <- getToolSetting "unlit command"
+
+       windres_path <- getToolSetting "windres command"
+       libtool_path <- getToolSetting "libtool command"
+       ar_path <- getToolSetting "ar command"
+       ranlib_path <- getToolSetting "ranlib command"
+
+       tmpdir <- getTemporaryDirectory
+
+       touch_path <- getToolSetting "touch command"
+
+       mkdll_prog <- getToolSetting "dllwrap command"
+       let mkdll_args = []
+
+       -- cpp is derived from gcc on all platforms
+       -- HACK, see setPgmP below. We keep 'words' here to remember to fix
+       -- Config.hs one day.
+
+
+       -- Other things being equal, as and ld are simply gcc
+       gcc_link_args_str <- getSetting "C compiler link flags"
+       let   as_prog  = gcc_prog
+             as_args  = gcc_args
+             ld_prog  = gcc_prog
+             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)
+
+       -- We just assume on command line
+       lc_prog <- getSetting "LLVM llc command"
+       lo_prog <- getSetting "LLVM opt command"
+       lcc_prog <- getSetting "LLVM clang command"
+
+       let iserv_prog = libexec "ghc-iserv"
+
+       let platform = Platform {
+                          platformArch = targetArch,
+                          platformOS   = targetOS,
+                          platformWordSize = targetWordSize,
+                          platformUnregisterised = targetUnregisterised,
+                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,
+                          platformHasIdentDirective = targetHasIdentDirective,
+                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
+                          platformIsCrossCompiling = crossCompiling
+                      }
+
+       integerLibrary <- getSetting "integer library"
+       integerLibraryType <- case integerLibrary of
+         "integer-gmp" -> pure IntegerGMP
+         "integer-simple" -> pure IntegerSimple
+         _ -> pgmError $ unwords
+           [ "Entry for"
+           , show "integer library"
+           , "must be one of"
+           , show "integer-gmp"
+           , "or"
+           , show "integer-simple"
+           ]
+
+       ghcWithInterpreter <- getBooleanSetting "Use interpreter"
+       ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator"
+       ghcWithSMP <- getBooleanSetting "Support SMP"
+       ghcRTSWays <- getSetting "RTS ways"
+       leadingUnderscore <- getBooleanSetting "Leading underscore"
+       useLibFFI <- getBooleanSetting "Use LibFFI"
+       ghcThreaded <- getBooleanSetting "Use Threads"
+       ghcDebugged <- getBooleanSetting "Use Debugging"
+       ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"
+
+       return $ Settings {
+                    sTargetPlatform = platform,
+                    sTmpDir         = normalise tmpdir,
+                    sGhcUsagePath   = ghc_usage_msg_path,
+                    sGhciUsagePath  = ghci_usage_msg_path,
+                    sToolDir        = mtool_dir,
+                    sTopDir         = top_dir,
+                    sRawSettings    = mySettings,
+                    sExtraGccViaCFlags = words myExtraGccViaCFlags,
+                    sSystemPackageConfig = pkgconfig_path,
+                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
+                    sLdSupportsBuildId       = ldSupportsBuildId,
+                    sLdSupportsFilelist      = ldSupportsFilelist,
+                    sLdIsGnuLd               = ldIsGnuLd,
+                    sGccSupportsNoPie        = gccSupportsNoPie,
+                    sProgramName             = "ghc",
+                    sProjectVersion          = cProjectVersion,
+                    sPgm_L   = unlit_path,
+                    sPgm_P   = (cpp_prog, cpp_args),
+                    sPgm_F   = "",
+                    sPgm_c   = (gcc_prog, gcc_args),
+                    sPgm_a   = (as_prog, as_args),
+                    sPgm_l   = (ld_prog, ld_args),
+                    sPgm_dll = (mkdll_prog,mkdll_args),
+                    sPgm_T   = touch_path,
+                    sPgm_windres = windres_path,
+                    sPgm_libtool = libtool_path,
+                    sPgm_ar = ar_path,
+                    sPgm_ranlib = ranlib_path,
+                    sPgm_lo  = (lo_prog,[]),
+                    sPgm_lc  = (lc_prog,[]),
+                    sPgm_lcc = (lcc_prog,[]),
+                    sPgm_i   = iserv_prog,
+                    sOpt_L       = [],
+                    sOpt_P       = [],
+                    sOpt_P_fingerprint = fingerprint0,
+                    sOpt_F       = [],
+                    sOpt_c       = [],
+                    sOpt_cxx     = [],
+                    sOpt_a       = [],
+                    sOpt_l       = [],
+                    sOpt_windres = [],
+                    sOpt_lcc     = [],
+                    sOpt_lo      = [],
+                    sOpt_lc      = [],
+                    sOpt_i       = [],
+                    sPlatformConstants = platformConstants,
+
+                    sTargetPlatformString = targetPlatformString,
+                    sIntegerLibrary = integerLibrary,
+                    sIntegerLibraryType = integerLibraryType,
+                    sGhcWithInterpreter = ghcWithInterpreter,
+                    sGhcWithNativeCodeGen = ghcWithNativeCodeGen,
+                    sGhcWithSMP = ghcWithSMP,
+                    sGhcRTSWays = ghcRTSWays,
+                    sTablesNextToCode = tablesNextToCode,
+                    sLeadingUnderscore = leadingUnderscore,
+                    sLibFFI = useLibFFI,
+                    sGhcThreaded = ghcThreaded,
+                    sGhcDebugged = ghcDebugged,
+                    sGhcRtsWithLibdw = ghcRtsWithLibdw
+             }
+
+
+{- Note [Windows stack usage]
+
+See: #8870 (and #8834 for related info) and #12186
+
+On Windows, occasionally we need to grow the stack. In order to do
+this, we would normally just bump the stack pointer - but there's a
+catch on Windows.
+
+If the stack pointer is bumped by more than a single page, then the
+pages between the initial pointer and the resulting location must be
+properly committed by the Windows virtual memory subsystem. This is
+only needed in the event we bump by more than one page (i.e 4097 bytes
+or more).
+
+Windows compilers solve this by emitting a call to a special function
+called _chkstk, which does this committing of the pages for you.
+
+The reason this was causing a segfault was because due to the fact the
+new code generator tends to generate larger functions, we needed more
+stack space in GHC itself. In the x86 codegen, we needed approximately
+~12kb of stack space in one go, which caused the process to segfault,
+as the intervening pages were not committed.
+
+GCC can emit such a check for us automatically but only when the flag
+-fstack-check is used.
+
+See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html
+for more information.
+
+-}
+
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
+
+copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
+               -> IO ()
+copyWithHeader dflags purpose maybe_header from to = do
+  showPass dflags purpose
+
+  hout <- openBinaryFile to   WriteMode
+  hin  <- openBinaryFile from ReadMode
+  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
+  maybe (return ()) (header hout) maybe_header
+  hPutStr hout ls
+  hClose hout
+  hClose hin
+ where
+  -- write the header string in UTF-8.  The header is something like
+  --   {-# LINE "foo.hs" #-}
+  -- and we want to make sure a Unicode filename isn't mangled.
+  header h str = do
+   hSetEncoding h utf8
+   hPutStr h str
+   hSetBinaryMode h True
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Support code}
+*                                                                      *
+************************************************************************
+-}
+
+linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkDynLib dflags0 o_files dep_packages
+ = do
+    let -- This is a rather ugly hack to fix dynamically linked
+        -- GHC on Windows. If GHC is linked with -threaded, then
+        -- it links against libHSrts_thr. But if base is linked
+        -- against libHSrts, then both end up getting loaded,
+        -- and things go wrong. We therefore link the libraries
+        -- with the same RTS flags that we link GHC with.
+        dflags1 = if sGhcThreaded $ settings dflags0
+          then addWay' WayThreaded dflags0
+          else                     dflags0
+        dflags2 = if sGhcDebugged $ settings dflags1
+          then addWay' WayDebug dflags1
+          else                  dflags1
+        dflags = updateWays dflags2
+
+        verbFlags = getVerbFlags dflags
+        o_file = outputFile dflags
+
+    pkgs <- getPreloadPackagesAnd dflags dep_packages
+
+    let pkg_lib_paths = collectLibraryPaths dflags pkgs
+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
+        get_pkg_lib_path_opts l
+         | ( osElfTarget (platformOS (targetPlatform dflags)) ||
+             osMachOTarget (platformOS (targetPlatform dflags)) ) &&
+           dynLibLoader dflags == SystemDependent &&
+           WayDyn `elem` ways dflags
+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+         | otherwise = ["-L" ++ l]
+
+    let lib_paths = libraryPaths dflags
+    let lib_path_opts = map ("-L"++) lib_paths
+
+    -- We don't want to link our dynamic libs against the RTS package,
+    -- because the RTS lib comes in several flavours and we want to be
+    -- able to pick the flavour when a binary is linked.
+    -- On Windows we need to link the RTS import lib as Windows does
+    -- not allow undefined symbols.
+    -- The RTS library path is still added to the library search path
+    -- above in case the RTS is being explicitly linked in (see #3807).
+    let platform = targetPlatform dflags
+        os = platformOS platform
+        pkgs_no_rts = case os of
+                      OSMinGW32 ->
+                          pkgs
+                      _ ->
+                          filter ((/= rtsUnitId) . packageConfigId) pkgs
+    let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
+                        in  package_hs_libs ++ extra_libs ++ other_flags
+
+        -- probably _stub.o files
+        -- and last temporary shared object file
+    let extra_ld_inputs = ldInputs dflags
+
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform
+                                              (map unitId pkgs)
+    let framework_opts = getFrameworkOpts dflags platform
+
+    case os of
+        OSMinGW32 -> do
+            -------------------------------------------------------------
+            -- Making a DLL
+            -------------------------------------------------------------
+            let output_fn = case o_file of
+                            Just s -> s
+                            Nothing -> "HSdll.dll"
+
+            runLink dflags (
+                    map Option verbFlags
+                 ++ [ Option "-o"
+                    , FileOption "" output_fn
+                    , Option "-shared"
+                    ] ++
+                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
+                    | gopt Opt_SharedImplib dflags
+                    ]
+                 ++ map (FileOption "") o_files
+
+                 -- Permit the linker to auto link _symbol to _imp_symbol
+                 -- This lets us link against DLLs without needing an "import library"
+                 ++ [Option "-Wl,--enable-auto-import"]
+
+                 ++ extra_ld_inputs
+                 ++ map Option (
+                    lib_path_opts
+                 ++ pkg_lib_path_opts
+                 ++ pkg_link_opts
+                ))
+        _ | os == OSDarwin -> do
+            -------------------------------------------------------------------
+            -- Making a darwin dylib
+            -------------------------------------------------------------------
+            -- About the options used for Darwin:
+            -- -dynamiclib
+            --   Apple's way of saying -shared
+            -- -undefined dynamic_lookup:
+            --   Without these options, we'd have to specify the correct
+            --   dependencies for each of the dylibs. Note that we could
+            --   (and should) do without this for all libraries except
+            --   the RTS; all we need to do is to pass the correct
+            --   HSfoo_dyn.dylib files to the link command.
+            --   This feature requires Mac OS X 10.3 or later; there is
+            --   a similar feature, -flat_namespace -undefined suppress,
+            --   which works on earlier versions, but it has other
+            --   disadvantages.
+            -- -single_module
+            --   Build the dynamic library as a single "module", i.e. no
+            --   dynamic binding nonsense when referring to symbols from
+            --   within the library. The NCG assumes that this option is
+            --   specified (on i386, at least).
+            -- -install_name
+            --   Mac OS/X stores the path where a dynamic library is (to
+            --   be) installed in the library itself.  It's called the
+            --   "install name" of the library. Then any library or
+            --   executable that links against it before it's installed
+            --   will search for it in its ultimate install location.
+            --   By default we set the install name to the absolute path
+            --   at build time, but it can be overridden by the
+            --   -dylib-install-name option passed to ghc. Cabal does
+            --   this.
+            -------------------------------------------------------------------
+
+            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+
+            instName <- case dylibInstallName dflags of
+                Just n -> return n
+                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
+            runLink dflags (
+                    map Option verbFlags
+                 ++ [ Option "-dynamiclib"
+                    , Option "-o"
+                    , FileOption "" output_fn
+                    ]
+                 ++ map Option o_files
+                 ++ [ Option "-undefined",
+                      Option "dynamic_lookup",
+                      Option "-single_module" ]
+                 ++ (if platformArch platform == ArchX86_64
+                     then [ ]
+                     else [ Option "-Wl,-read_only_relocs,suppress" ])
+                 ++ [ Option "-install_name", Option instName ]
+                 ++ map Option lib_path_opts
+                 ++ extra_ld_inputs
+                 ++ map Option framework_opts
+                 ++ map Option pkg_lib_path_opts
+                 ++ map Option pkg_link_opts
+                 ++ map Option pkg_framework_opts
+                 ++ [ Option "-Wl,-dead_strip_dylibs" ]
+              )
+        _ -> do
+            -------------------------------------------------------------------
+            -- Making a DSO
+            -------------------------------------------------------------------
+
+            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+                unregisterised = platformUnregisterised (targetPlatform dflags)
+            let bsymbolicFlag = -- we need symbolic linking to resolve
+                                -- non-PIC intra-package-relocations for
+                                -- performance (where symbolic linking works)
+                                -- See Note [-Bsymbolic assumptions by GHC]
+                                ["-Wl,-Bsymbolic" | not unregisterised]
+
+            runLink dflags (
+                    map Option verbFlags
+                 ++ libmLinkOpts
+                 ++ [ Option "-o"
+                    , FileOption "" output_fn
+                    ]
+                 ++ map Option o_files
+                 ++ [ Option "-shared" ]
+                 ++ map Option bsymbolicFlag
+                    -- Set the library soname. We use -h rather than -soname as
+                    -- Solaris 10 doesn't support the latter:
+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
+                 ++ extra_ld_inputs
+                 ++ map Option lib_path_opts
+                 ++ map Option pkg_lib_path_opts
+                 ++ map Option pkg_link_opts
+              )
+
+-- | Some platforms require that we explicitly link against @libm@ if any
+-- math-y things are used (which we assume to include all programs). See #14022.
+libmLinkOpts :: [Option]
+libmLinkOpts =
+#if defined(HAVE_LIBM)
+  [Option "-lm"]
+#else
+  []
+#endif
+
+getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
+getPkgFrameworkOpts dflags platform dep_packages
+  | platformUsesFrameworks platform = do
+    pkg_framework_path_opts <- do
+        pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
+        return $ map ("-F" ++) pkg_framework_paths
+
+    pkg_framework_opts <- do
+        pkg_frameworks <- getPackageFrameworks dflags dep_packages
+        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
+
+    return (pkg_framework_path_opts ++ pkg_framework_opts)
+
+  | otherwise = return []
+
+getFrameworkOpts :: DynFlags -> Platform -> [String]
+getFrameworkOpts dflags platform
+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
+  | otherwise = []
+  where
+    framework_paths     = frameworkPaths dflags
+    framework_path_opts = map ("-F" ++) framework_paths
+
+    frameworks     = cmdlineFrameworks dflags
+    -- reverse because they're added in reverse order from the cmd line:
+    framework_opts = concat [ ["-framework", fw]
+                            | fw <- reverse frameworks ]
+
+{-
+Note [-Bsymbolic assumptions by GHC]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC has a few assumptions about interaction of relocations in NCG and linker:
+
+1. -Bsymbolic resolves internal references when the shared library is linked,
+   which is important for performance.
+2. When there is a reference to data in a shared library from the main program,
+   the runtime linker relocates the data object into the main program using an
+   R_*_COPY relocation.
+3. If we used -Bsymbolic, then this results in multiple copies of the data
+   object, because some references have already been resolved to point to the
+   original instance. This is bad!
+
+We work around [3.] for native compiled code by avoiding the generation of
+R_*_COPY relocations.
+
+Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
+-Bsymbolic linking there.
+
+See related tickets: #4210, #15338
+-}
diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/ExtraObj.hs
@@ -0,0 +1,243 @@
+-----------------------------------------------------------------------------
+--
+-- GHC Extra object linking code
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+
+module SysTools.ExtraObj (
+  mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
+  checkLinkInfo, getLinkInfo, getCompilerInfo,
+  ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts,
+  haveRtsOptsFlags
+) where
+
+import AsmUtils
+import ErrUtils
+import DynFlags
+import Packages
+import Platform
+import Outputable
+import SrcLoc           ( noSrcSpan )
+import Module
+import Elf
+import Util
+import GhcPrelude
+
+import Control.Monad
+import Data.Maybe
+
+import Control.Monad.IO.Class
+
+import FileCleanup
+import SysTools.Tasks
+import SysTools.Info
+
+mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
+mkExtraObj dflags extn xs
+ = do cFile <- newTempName dflags TFL_CurrentModule extn
+      oFile <- newTempName dflags TFL_GhcSession "o"
+      writeFile cFile xs
+      ccInfo <- liftIO $ getCompilerInfo dflags
+      runCc Nothing dflags
+            ([Option        "-c",
+              FileOption "" cFile,
+              Option        "-o",
+              FileOption "" oFile]
+              ++ if extn /= "s"
+                    then cOpts
+                    else asmOpts ccInfo)
+      return oFile
+    where
+      -- Pass a different set of options to the C compiler depending one whether
+      -- we're compiling C or assembler. When compiling C, we pass the usual
+      -- set of include directories and PIC flags.
+      cOpts = map Option (picCCOpts dflags)
+                    ++ map (FileOption "-I")
+                            (includeDirs $ getPackageDetails dflags rtsUnitId)
+
+      -- When compiling assembler code, we drop the usual C options, and if the
+      -- compiler is Clang, we add an extra argument to tell Clang to ignore
+      -- unused command line options. See trac #11684.
+      asmOpts ccInfo =
+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+                then [Option "-Qunused-arguments"]
+                else []
+
+-- When linking a binary, we need to create a C main() function that
+-- starts everything off.  This used to be compiled statically as part
+-- of the RTS, but that made it hard to change the -rtsopts setting,
+-- so now we generate and compile a main() stub as part of every
+-- binary and pass the -rtsopts setting directly to the RTS (#5373)
+--
+-- On Windows, when making a shared library we also may need a DllMain.
+--
+mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
+mkExtraObjToLinkIntoBinary dflags = do
+  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
+     putLogMsg dflags NoReason SevInfo noSrcSpan
+         (defaultUserStyle dflags)
+         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
+          text "    Call hs_init_ghc() from your main() function to set these options.")
+
+  mkExtraObj dflags "c" (showSDoc dflags main)
+  where
+    main
+      | gopt Opt_NoHsMain dflags = Outputable.empty
+      | otherwise
+          = case ghcLink dflags of
+                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32
+                                    then dllMain
+                                    else Outputable.empty
+                  _                      -> exeMain
+
+    exeMain = vcat [
+        text "#include \"Rts.h\"",
+        text "extern StgClosure ZCMain_main_closure;",
+        text "int main(int argc, char *argv[])",
+        char '{',
+        text " RtsConfig __conf = defaultRtsConfig;",
+        text " __conf.rts_opts_enabled = "
+            <> text (show (rtsOptsEnabled dflags)) <> semi,
+        text " __conf.rts_opts_suggestions = "
+            <> text (if rtsOptsSuggestions dflags
+                        then "true"
+                        else "false") <> semi,
+        text "__conf.keep_cafs = "
+            <> text (if gopt Opt_KeepCAFs dflags
+                       then "true"
+                       else "false") <> semi,
+        case rtsOpts dflags of
+            Nothing   -> Outputable.empty
+            Just opts -> text "    __conf.rts_opts= " <>
+                          text (show opts) <> semi,
+        text " __conf.rts_hs_main = true;",
+        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
+        char '}',
+        char '\n' -- final newline, to keep gcc happy
+        ]
+
+    dllMain = vcat [
+        text "#include \"Rts.h\"",
+        text "#include <windows.h>",
+        text "#include <stdbool.h>",
+        char '\n',
+        text "bool",
+        text "WINAPI",
+        text "DllMain ( HINSTANCE hInstance STG_UNUSED",
+        text "        , DWORD reason STG_UNUSED",
+        text "        , LPVOID reserved STG_UNUSED",
+        text "        )",
+        text "{",
+        text "  return true;",
+        text "}",
+        char '\n' -- final newline, to keep gcc happy
+        ]
+
+-- Write out the link info section into a new assembly file. Previously
+-- this was included as inline assembly in the main.c file but this
+-- is pretty fragile. gas gets upset trying to calculate relative offsets
+-- that span the .note section (notably .text) when debug info is present
+mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary dflags dep_packages = do
+   link_info <- getLinkInfo dflags dep_packages
+
+   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
+     else return []
+
+  where
+    link_opts info = hcat [
+      -- "link info" section (see Note [LinkInfo section])
+      makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,
+
+      -- ALL generated assembly must have this section to disable
+      -- executable stacks.  See also
+      -- compiler/nativeGen/AsmCodeGen.hs for another instance
+      -- where we need to do this.
+      if platformHasGnuNonexecStack (targetPlatform dflags)
+        then text ".section .note.GNU-stack,\"\","
+             <> sectionType "progbits" <> char '\n'
+        else Outputable.empty
+      ]
+
+-- | Return the "link info" string
+--
+-- See Note [LinkInfo section]
+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
+getLinkInfo dflags dep_packages = do
+   package_link_opts <- getPackageLinkOpts dflags dep_packages
+   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
+                     then getPackageFrameworks dflags dep_packages
+                     else return []
+   let extra_ld_inputs = ldInputs dflags
+   let
+      link_info = (package_link_opts,
+                   pkg_frameworks,
+                   rtsOpts dflags,
+                   rtsOptsEnabled dflags,
+                   gopt Opt_NoHsMain dflags,
+                   map showOpt extra_ld_inputs,
+                   getOpts dflags opt_l)
+   --
+   return (show link_info)
+
+platformSupportsSavingLinkOpts :: OS -> Bool
+platformSupportsSavingLinkOpts os
+ | os == OSSolaris2 = False -- see #5382
+ | otherwise        = osElfTarget os
+
+-- See Note [LinkInfo section]
+ghcLinkInfoSectionName :: String
+ghcLinkInfoSectionName = ".debug-ghc-link-info"
+  -- if we use the ".debug" prefix, then strip will strip it by default
+
+-- Identifier for the note (see Note [LinkInfo section])
+ghcLinkInfoNoteName :: String
+ghcLinkInfoNoteName = "GHC link info"
+
+-- Returns 'False' if it was, and we can avoid linking, because the
+-- previous binary was linked with "the same options".
+checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
+checkLinkInfo dflags pkg_deps exe_file
+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+ -- ToDo: Windows and OS X do not use the ELF binary format, so
+ -- readelf does not work there.  We need to find another way to do
+ -- this.
+ = return False -- conservatively we should return True, but not
+                -- linking in this case was the behaviour for a long
+                -- time so we leave it as-is.
+ | otherwise
+ = do
+   link_info <- getLinkInfo dflags pkg_deps
+   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
+   m_exe_link_info <- readElfNoteAsString dflags exe_file
+                          ghcLinkInfoSectionName ghcLinkInfoNoteName
+   let sameLinkInfo = (Just link_info == m_exe_link_info)
+   debugTraceMsg dflags 3 $ case m_exe_link_info of
+     Nothing -> text "Exe link info: Not found"
+     Just s
+       | sameLinkInfo -> text ("Exe link info is the same")
+       | otherwise    -> text ("Exe link info is different: " ++ s)
+   return (not sameLinkInfo)
+
+{- Note [LinkInfo section]
+   ~~~~~~~~~~~~~~~~~~~~~~~
+
+The "link info" is a string representing the parameters of the link. We save
+this information in the binary, and the next time we link, if nothing else has
+changed, we use the link info stored in the existing binary to decide whether
+to re-link or not.
+
+The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to
+not follow the specified record-based format (see #11022).
+
+-}
+
+haveRtsOptsFlags :: DynFlags -> Bool
+haveRtsOptsFlags dflags =
+        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
+                                       RtsOptsSafeOnly -> False
+                                       _ -> True
diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/Info.hs
@@ -0,0 +1,262 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Compiler information functions
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Info where
+
+import Exception
+import ErrUtils
+import DynFlags
+import Outputable
+import Util
+
+import Data.List
+import Data.IORef
+
+import System.IO
+
+import Platform
+import GhcPrelude
+
+import SysTools.Process
+
+{- Note [Run-time linker info]
+
+See also: #5240, #6063, #10110
+
+Before 'runLink', we need to be sure to get the relevant information
+about the linker we're using at runtime to see if we need any extra
+options. For example, GNU ld requires '--reduce-memory-overheads' and
+'--hash-size=31' in order to use reasonable amounts of memory (see
+trac #5240.) But this isn't supported in GNU gold.
+
+Generally, the linker changing from what was detected at ./configure
+time has always been possible using -pgml, but on Linux it can happen
+'transparently' by installing packages like binutils-gold, which
+change what /usr/bin/ld actually points to.
+
+Clang vs GCC notes:
+
+For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
+invoke the linker before the version information string. For 'clang',
+the version information for 'ld' is all that's output. For this
+reason, we typically need to slurp up all of the standard error output
+and look through it.
+
+Other notes:
+
+We cache the LinkerInfo inside DynFlags, since clients may link
+multiple times. The definition of LinkerInfo is there to avoid a
+circular dependency.
+
+-}
+
+{- Note [ELF needed shared libs]
+
+Some distributions change the link editor's default handling of
+ELF DT_NEEDED tags to include only those shared objects that are
+needed to resolve undefined symbols. For Template Haskell we need
+the last temporary shared library also if it is not needed for the
+currently linked temporary shared library. We specify --no-as-needed
+to override the default. This flag exists in GNU ld and GNU gold.
+
+The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
+(Mach-O) the flag is not needed.
+
+-}
+
+{- Note [Windows static libGCC]
+
+The GCC versions being upgraded to in #10726 are configured with
+dynamic linking of libgcc supported. This results in libgcc being
+linked dynamically when a shared library is created.
+
+This introduces thus an extra dependency on GCC dll that was not
+needed before by shared libraries created with GHC. This is a particular
+issue on Windows because you get a non-obvious error due to this missing
+dependency. This dependent dll is also not commonly on your path.
+
+For this reason using the static libgcc is preferred as it preserves
+the same behaviour that existed before. There are however some very good
+reasons to have the shared version as well as described on page 181 of
+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
+
+"There are several situations in which an application should use the
+ shared ‘libgcc’ instead of the static version. The most common of these
+ is when the application wishes to throw and catch exceptions across different
+ shared libraries. In that case, each of the libraries as well as the application
+ itself should use the shared ‘libgcc’. "
+
+-}
+
+neededLinkArgs :: LinkerInfo -> [Option]
+neededLinkArgs (GnuLD o)     = o
+neededLinkArgs (GnuGold o)   = o
+neededLinkArgs (LlvmLLD o)   = o
+neededLinkArgs (DarwinLD o)  = o
+neededLinkArgs (SolarisLD o) = o
+neededLinkArgs (AixLD o)     = o
+neededLinkArgs UnknownLD     = []
+
+-- Grab linker info and cache it in DynFlags.
+getLinkerInfo :: DynFlags -> IO LinkerInfo
+getLinkerInfo dflags = do
+  info <- readIORef (rtldInfo dflags)
+  case info of
+    Just v  -> return v
+    Nothing -> do
+      v <- getLinkerInfo' dflags
+      writeIORef (rtldInfo dflags) (Just v)
+      return v
+
+-- See Note [Run-time linker info].
+getLinkerInfo' :: DynFlags -> IO LinkerInfo
+getLinkerInfo' dflags = do
+  let platform = targetPlatform dflags
+      os = platformOS platform
+      (pgm,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1
+      args3     = filter notNull (map showOpt args2)
+
+      -- Try to grab the info from the process output.
+      parseLinkerInfo stdo _stde _exitc
+        | any ("GNU ld" `isPrefixOf`) stdo =
+          -- GNU ld specifically needs to use less memory. This especially
+          -- hurts on small object files. #5240.
+          -- Set DT_NEEDED for all shared libraries. #10110.
+          -- TODO: Investigate if these help or hurt when using split sections.
+          return (GnuLD $ map Option ["-Wl,--hash-size=31",
+                                      "-Wl,--reduce-memory-overheads",
+                                      -- ELF specific flag
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
+
+        | any ("GNU gold" `isPrefixOf`) stdo =
+          -- GNU gold only needs --no-as-needed. #10110.
+          -- ELF specific flag, see Note [ELF needed shared libs]
+          return (GnuGold [Option "-Wl,--no-as-needed"])
+
+        | any ("LLD" `isPrefixOf`) stdo =
+          return (LlvmLLD $ map Option [
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
+
+         -- Unknown linker.
+        | otherwise = fail "invalid --version output, or linker is unsupported"
+
+  -- Process the executable call
+  info <- catchIO (do
+             case os of
+               OSSolaris2 ->
+                 -- Solaris uses its own Solaris linker. Even all
+                 -- GNU C are recommended to configure with Solaris
+                 -- linker instead of using GNU binutils linker. Also
+                 -- all GCC distributed with Solaris follows this rule
+                 -- precisely so we assume here, the Solaris linker is
+                 -- used.
+                 return $ SolarisLD []
+               OSAIX ->
+                 -- IBM AIX uses its own non-binutils linker as well
+                 return $ AixLD []
+               OSDarwin ->
+                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
+                 -- that doesn't support --version. We can just assume that's
+                 -- what we're using.
+                 return $ DarwinLD []
+               OSMinGW32 ->
+                 -- GHC doesn't support anything but GNU ld on Windows anyway.
+                 -- Process creation is also fairly expensive on win32, so
+                 -- we short-circuit here.
+                 return $ GnuLD $ map Option
+                   [ -- Reduce ld memory usage
+                     "-Wl,--hash-size=31"
+                   , "-Wl,--reduce-memory-overheads"
+                     -- Emit gcc stack checks
+                     -- Note [Windows stack usage]
+                   , "-fstack-check"
+                     -- Force static linking of libGCC
+                     -- Note [Windows static libGCC]
+                   , "-static-libgcc" ]
+               _ -> do
+                 -- In practice, we use the compiler as the linker here. Pass
+                 -- -Wl,--version to get linker version info.
+                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
+                                        (["-Wl,--version"] ++ args3)
+                                        c_locale_env
+                 -- Split the output by lines to make certain kinds
+                 -- of processing easier. In particular, 'clang' and 'gcc'
+                 -- have slightly different outputs for '-Wl,--version', but
+                 -- it's still easy to figure out.
+                 parseLinkerInfo (lines stdo) (lines stde) exitc
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out linker information):" <+>
+                     text (show err))
+                errorMsg dflags $ hang (text "Warning:") 9 $
+                  text "Couldn't figure out linker information!" $$
+                  text "Make sure you're using GNU ld, GNU gold" <+>
+                  text "or the built in OS X linker, etc."
+                return UnknownLD)
+  return info
+
+-- Grab compiler info and cache it in DynFlags.
+getCompilerInfo :: DynFlags -> IO CompilerInfo
+getCompilerInfo dflags = do
+  info <- readIORef (rtccInfo dflags)
+  case info of
+    Just v  -> return v
+    Nothing -> do
+      v <- getCompilerInfo' dflags
+      writeIORef (rtccInfo dflags) (Just v)
+      return v
+
+-- See Note [Run-time linker info].
+getCompilerInfo' :: DynFlags -> IO CompilerInfo
+getCompilerInfo' dflags = do
+  let (pgm,_) = pgm_c dflags
+      -- Try to grab the info from the process output.
+      parseCompilerInfo _stdo stde _exitc
+        -- Regular GCC
+        | any ("gcc version" `isInfixOf`) stde =
+          return GCC
+        -- Regular clang
+        | any ("clang version" `isInfixOf`) stde =
+          return Clang
+        -- FreeBSD clang
+        | any ("FreeBSD clang version" `isInfixOf`) stde =
+          return Clang
+        -- XCode 5.1 clang
+        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
+          return AppleClang51
+        -- XCode 5 clang
+        | any ("Apple LLVM version" `isPrefixOf`) stde =
+          return AppleClang
+        -- XCode 4.1 clang
+        | any ("Apple clang version" `isPrefixOf`) stde =
+          return AppleClang
+         -- Unknown linker.
+        | otherwise = fail "invalid -v output, or compiler is unsupported"
+
+  -- Process the executable call
+  info <- catchIO (do
+                (exitc, stdo, stde) <-
+                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env
+                -- Split the output by lines to make certain kinds
+                -- of processing easier.
+                parseCompilerInfo (lines stdo) (lines stde) exitc
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out C compiler information):" <+>
+                     text (show err))
+                errorMsg dflags $ hang (text "Warning:") 9 $
+                  text "Couldn't figure out C compiler information!" $$
+                  text "Make sure you're using GNU gcc, or clang"
+                return UnknownCC)
+  return info
diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/Process.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+--
+-- Misc process handling code for SysTools
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Process where
+
+#include "HsVersions.h"
+
+import Exception
+import ErrUtils
+import DynFlags
+import FastString
+import Outputable
+import Panic
+import GhcPrelude
+import Util
+import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
+
+import Control.Concurrent
+import Data.Char
+
+import System.Exit
+import System.Environment
+import System.FilePath
+import System.IO
+import System.IO.Error as IO
+import System.Process
+
+import FileCleanup
+
+-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
+-- inherited from the parent process, and output to stderr is not captured.
+readCreateProcessWithExitCode'
+    :: CreateProcess
+    -> IO (ExitCode, String)    -- ^ stdout
+readCreateProcessWithExitCode' proc = do
+    (_, Just outh, _, pid) <-
+        createProcess proc{ std_out = CreatePipe }
+
+    -- fork off a thread to start consuming the output
+    output  <- hGetContents outh
+    outMVar <- newEmptyMVar
+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
+
+    -- wait on the output
+    takeMVar outMVar
+    hClose outh
+
+    -- wait on the process
+    ex <- waitForProcess pid
+
+    return (ex, output)
+
+replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
+replaceVar (var, value) env =
+    (var, value) : filter (\(var',_) -> var /= var') env
+
+-- | Version of @System.Process.readProcessWithExitCode@ that takes a
+-- key-value tuple to insert into the environment.
+readProcessEnvWithExitCode
+    :: String -- ^ program path
+    -> [String] -- ^ program args
+    -> (String, String) -- ^ addition to the environment
+    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
+readProcessEnvWithExitCode prog args env_update = do
+    current_env <- getEnvironment
+    readCreateProcessWithExitCode (proc prog args) {
+        env = Just (replaceVar env_update current_env) } ""
+
+-- Don't let gcc localize version info string, #8825
+c_locale_env :: (String, String)
+c_locale_env = ("LANGUAGE", "C")
+
+-- If the -B<dir> option is set, add <dir> to PATH.  This works around
+-- a bug in gcc on Windows Vista where it can't find its auxiliary
+-- binaries (see bug #1110).
+getGccEnv :: [Option] -> IO (Maybe [(String,String)])
+getGccEnv opts =
+  if null b_dirs
+     then return Nothing
+     else do env <- getEnvironment
+             return (Just (map mangle_path env))
+ where
+  (b_dirs, _) = partitionWith get_b_opt opts
+
+  get_b_opt (Option ('-':'B':dir)) = Left dir
+  get_b_opt other = Right other
+
+  mangle_path (path,paths) | map toUpper path == "PATH"
+        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
+  mangle_path other = other
+
+
+-----------------------------------------------------------------------------
+-- Running an external program
+
+runSomething :: DynFlags
+             -> String          -- For -v message
+             -> String          -- Command name (possibly a full path)
+                                --      assumed already dos-ified
+             -> [Option]        -- Arguments
+                                --      runSomething will dos-ify them
+             -> IO ()
+
+runSomething dflags phase_name pgm args =
+  runSomethingFiltered dflags id phase_name pgm args Nothing Nothing
+
+-- | Run a command, placing the arguments in an external response file.
+--
+-- This command is used in order to avoid overlong command line arguments on
+-- Windows. The command line arguments are first written to an external,
+-- temporary response file, and then passed to the linker via @filepath.
+-- response files for passing them in. See:
+--
+--     https://gcc.gnu.org/wiki/Response_Files
+--     https://gitlab.haskell.org/ghc/ghc/issues/10777
+runSomethingResponseFile
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe [(String,String)] -> IO ()
+
+runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        fp <- getResponseFile real_args
+        let args = ['@':fp]
+        r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env
+        return (r,())
+  where
+    getResponseFile args = do
+      fp <- newTempName dflags TFL_CurrentModule "rsp"
+      withFile fp WriteMode $ \h -> do
+#if defined(mingw32_HOST_OS)
+          hSetEncoding h latin1
+#else
+          hSetEncoding h utf8
+#endif
+          hPutStr h $ unlines $ map escape args
+      return fp
+
+    -- Note: Response files have backslash-escaping, double quoting, and are
+    -- whitespace separated (some implementations use newline, others any
+    -- whitespace character). Therefore, escape any backslashes, newlines, and
+    -- double quotes in the argument, and surround the content with double
+    -- quotes.
+    --
+    -- Another possibility that could be considered would be to convert
+    -- backslashes in the argument to forward slashes. This would generally do
+    -- the right thing, since backslashes in general only appear in arguments
+    -- as part of file paths on Windows, and the forward slash is accepted for
+    -- those. However, escaping is more reliable, in case somehow a backslash
+    -- appears in a non-file.
+    escape x = concat
+        [ "\""
+        , concatMap
+            (\c ->
+                case c of
+                    '\\' -> "\\\\"
+                    '\n' -> "\\n"
+                    '\"' -> "\\\""
+                    _    -> [c])
+            x
+        , "\""
+        ]
+
+runSomethingFiltered
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()
+
+runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env
+        return (r,())
+
+runSomethingWith
+  :: DynFlags -> String -> String -> [Option]
+  -> ([String] -> IO (ExitCode, a))
+  -> IO a
+
+runSomethingWith dflags phase_name pgm args io = do
+  let real_args = filter notNull (map showOpt args)
+      cmdLine = showCommandForUser pgm real_args
+  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
+
+handleProc :: String -> String -> IO (ExitCode, r) -> IO r
+handleProc pgm phase_name proc = do
+    (rc, r) <- proc `catchIO` handler
+    case rc of
+      ExitSuccess{} -> return r
+      ExitFailure n -> throwGhcExceptionIO (
+            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
+                          " failed in phase `" ++ phase_name ++ "'." ++
+                          " (Exit code: " ++ show n ++ ")"))
+  where
+    handler err =
+       if IO.isDoesNotExistError err
+          then does_not_exist
+          else throwGhcExceptionIO (ProgramError $ show err)
+
+    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
+
+
+builderMainLoop :: DynFlags -> (String -> String) -> FilePath
+                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
+                -> IO ExitCode
+builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
+  chan <- newChan
+
+  -- We use a mask here rather than a bracket because we want
+  -- to distinguish between cleaning up with and without an
+  -- exception. This is to avoid calling terminateProcess
+  -- unless an exception was raised.
+  let safely inner = mask $ \restore -> do
+        -- acquire
+        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $
+          runInteractiveProcess pgm real_args mb_cwd mb_env
+        let cleanup_handles = do
+              hClose hStdIn
+              hClose hStdOut
+              hClose hStdErr
+        r <- try $ restore $ do
+          hSetBuffering hStdOut LineBuffering
+          hSetBuffering hStdErr LineBuffering
+          let make_reader_proc h = forkIO $ readerProc chan h filter_fn
+          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
+            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
+            inner hProcess
+        case r of
+          -- onException
+          Left (SomeException e) -> do
+            terminateProcess hProcess
+            cleanup_handles
+            throw e
+          -- cleanup when there was no exception
+          Right s -> do
+            cleanup_handles
+            return s
+  safely $ \h -> do
+    -- we don't want to finish until 2 streams have been complete
+    -- (stdout and stderr)
+    log_loop chan (2 :: Integer)
+    -- after that, we wait for the process to finish and return the exit code.
+    waitForProcess h
+  where
+    -- t starts at the number of streams we're listening to (2) decrements each
+    -- time a reader process sends EOF. We are safe from looping forever if a
+    -- reader thread dies, because they send EOF in a finally handler.
+    log_loop _ 0 = return ()
+    log_loop chan t = do
+      msg <- readChan chan
+      case msg of
+        BuildMsg msg -> do
+          putLogMsg dflags NoReason SevInfo noSrcSpan
+              (defaultUserStyle dflags) msg
+          log_loop chan t
+        BuildError loc msg -> do
+          putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
+              (defaultUserStyle dflags) msg
+          log_loop chan t
+        EOF ->
+          log_loop chan  (t-1)
+
+readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
+readerProc chan hdl filter_fn =
+    (do str <- hGetContents hdl
+        loop (linesPlatform (filter_fn str)) Nothing)
+    `finally`
+       writeChan chan EOF
+        -- ToDo: check errors more carefully
+        -- ToDo: in the future, the filter should be implemented as
+        -- a stream transformer.
+    where
+        loop []     Nothing    = return ()
+        loop []     (Just err) = writeChan chan err
+        loop (l:ls) in_err     =
+                case in_err of
+                  Just err@(BuildError srcLoc msg)
+                    | leading_whitespace l -> do
+                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
+                    | otherwise -> do
+                        writeChan chan err
+                        checkError l ls
+                  Nothing -> do
+                        checkError l ls
+                  _ -> panic "readerProc/loop"
+
+        checkError l ls
+           = case parseError l of
+                Nothing -> do
+                    writeChan chan (BuildMsg (text l))
+                    loop ls Nothing
+                Just (file, lineNum, colNum, msg) -> do
+                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
+                    loop ls (Just (BuildError srcLoc (text msg)))
+
+        leading_whitespace []    = False
+        leading_whitespace (x:_) = isSpace x
+
+parseError :: String -> Maybe (String, Int, Int, String)
+parseError s0 = case breakColon s0 of
+                Just (filename, s1) ->
+                    case breakIntColon s1 of
+                    Just (lineNum, s2) ->
+                        case breakIntColon s2 of
+                        Just (columnNum, s3) ->
+                            Just (filename, lineNum, columnNum, s3)
+                        Nothing ->
+                            Just (filename, lineNum, 0, s2)
+                    Nothing -> Nothing
+                Nothing -> Nothing
+
+breakColon :: String -> Maybe (String, String)
+breakColon xs = case break (':' ==) xs of
+                    (ys, _:zs) -> Just (ys, zs)
+                    _ -> Nothing
+
+breakIntColon :: String -> Maybe (Int, String)
+breakIntColon xs = case break (':' ==) xs of
+                       (ys, _:zs)
+                        | not (null ys) && all isAscii ys && all isDigit ys ->
+                           Just (read ys, zs)
+                       _ -> Nothing
+
+data BuildMessage
+  = BuildMsg   !SDoc
+  | BuildError !SrcLoc !SDoc
+  | EOF
+
+-- Divvy up text stream into lines, taking platform dependent
+-- line termination into account.
+linesPlatform :: String -> [String]
+#if !defined(mingw32_HOST_OS)
+linesPlatform ls = lines ls
+#else
+linesPlatform "" = []
+linesPlatform xs =
+  case lineBreak xs of
+    (as,xs1) -> as : linesPlatform xs1
+  where
+   lineBreak "" = ("","")
+   lineBreak ('\r':'\n':xs) = ([],xs)
+   lineBreak ('\n':xs) = ([],xs)
+   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
+
+#endif
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/Tasks.hs
@@ -0,0 +1,359 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Tasks running external programs for SysTools
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Tasks where
+
+import Exception
+import ErrUtils
+import HscTypes
+import DynFlags
+import Outputable
+import Platform
+import Util
+
+import Data.Char
+import Data.List
+
+import System.IO
+import System.Process
+import GhcPrelude
+
+import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
+
+import SysTools.Process
+import SysTools.Info
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Running an external program}
+*                                                                      *
+************************************************************************
+-}
+
+runUnlit :: DynFlags -> [Option] -> IO ()
+runUnlit dflags args = do
+  let prog = pgm_L dflags
+      opts = getOpts dflags opt_L
+  runSomething dflags "Literate pre-processor" prog
+               (map Option opts ++ args)
+
+runCpp :: DynFlags -> [Option] -> IO ()
+runCpp dflags args =   do
+  let (p,args0) = pgm_P dflags
+      args1 = map Option (getOpts dflags opt_P)
+      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
+                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id  "C pre-processor" p
+                       (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
+
+runPp :: DynFlags -> [Option] -> IO ()
+runPp dflags args =   do
+  let prog = pgm_F dflags
+      opts = map Option (getOpts dflags opt_F)
+  runSomething dflags "Haskell pre-processor" prog (args ++ opts)
+
+-- | Run compiler of C-like languages and raw objects (such as gcc or clang).
+runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
+runCc mLanguage dflags args =   do
+  let (p,args0) = pgm_c dflags
+      args1 = map Option userOpts
+      args2 = args0 ++ languageOptions ++ args ++ args1
+      -- We take care to pass -optc flags in args1 last to ensure that the
+      -- user can override flags passed by GHC. See #14452.
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
+ where
+  -- discard some harmless warnings from gcc that we can't turn off
+  cc_filter = unlines . doFilter . lines
+
+  {-
+  gcc gives warnings in chunks like so:
+      In file included from /foo/bar/baz.h:11,
+                       from /foo/bar/baz2.h:22,
+                       from wibble.c:33:
+      /foo/flibble:14: global register variable ...
+      /foo/flibble:15: warning: call-clobbered r...
+  We break it up into its chunks, remove any call-clobbered register
+  warnings from each chunk, and then delete any chunks that we have
+  emptied of warnings.
+  -}
+  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
+  -- We can't assume that the output will start with an "In file inc..."
+  -- line, so we start off expecting a list of warnings rather than a
+  -- location stack.
+  chunkWarnings :: [String] -- The location stack to use for the next
+                            -- list of warnings
+                -> [String] -- The remaining lines to look at
+                -> [([String], [String])]
+  chunkWarnings loc_stack [] = [(loc_stack, [])]
+  chunkWarnings loc_stack xs
+      = case break loc_stack_start xs of
+        (warnings, lss:xs') ->
+            case span loc_start_continuation xs' of
+            (lsc, xs'') ->
+                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
+        _ -> [(loc_stack, xs)]
+
+  filterWarnings :: [([String], [String])] -> [([String], [String])]
+  filterWarnings [] = []
+  -- If the warnings are already empty then we are probably doing
+  -- something wrong, so don't delete anything
+  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
+  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
+                                       [] -> filterWarnings zs
+                                       ys' -> (xs, ys') : filterWarnings zs
+
+  unChunkWarnings :: [([String], [String])] -> [String]
+  unChunkWarnings [] = []
+  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
+
+  loc_stack_start        s = "In file included from " `isPrefixOf` s
+  loc_start_continuation s = "                 from " `isPrefixOf` s
+  wantedWarning w
+   | "warning: call-clobbered register used" `isContainedIn` w = False
+   | otherwise = True
+
+  -- force the C compiler to interpret this file as C when
+  -- compiling .hc files, by adding the -x c option.
+  -- Also useful for plain .c files, just in case GHC saw a
+  -- -x c option.
+  (languageOptions, userOpts) = case mLanguage of
+    Nothing -> ([], userOpts_c)
+    Just language -> ([Option "-x", Option languageName], opts) where
+      (languageName, opts) = case language of
+        LangCxx    -> ("c++",           userOpts_cxx)
+        LangObjc   -> ("objective-c",   userOpts_c)
+        LangObjcxx -> ("objective-c++", userOpts_cxx)
+        _          -> ("c",             userOpts_c)
+  userOpts_c   = getOpts dflags opt_c
+  userOpts_cxx = getOpts dflags opt_cxx
+
+isContainedIn :: String -> String -> Bool
+xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
+
+-- | Run the linker with some arguments and return the output
+askLd :: DynFlags -> [Option] -> IO String
+askLd dflags args = do
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingWith dflags "gcc" p args2 $ \real_args ->
+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
+
+runAs :: DynFlags -> [Option] -> IO ()
+runAs dflags args = do
+  let (p,args0) = pgm_a dflags
+      args1 = map Option (getOpts dflags opt_a)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env
+
+-- | Run the LLVM Optimiser
+runLlvmOpt :: DynFlags -> [Option] -> IO ()
+runLlvmOpt dflags args = do
+  let (p,args0) = pgm_lo dflags
+      args1 = map Option (getOpts dflags opt_lo)
+      -- We take care to pass -optlo flags (e.g. args0) last to ensure that the
+      -- user can override flags passed by GHC. See #14821.
+  runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0)
+
+-- | Run the LLVM Compiler
+runLlvmLlc :: DynFlags -> [Option] -> IO ()
+runLlvmLlc dflags args = do
+  let (p,args0) = pgm_lc dflags
+      args1 = map Option (getOpts dflags opt_lc)
+  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
+
+-- | Run the clang compiler (used as an assembler for the LLVM
+-- backend on OS X as LLVM doesn't support the OS X system
+-- assembler)
+runClang :: DynFlags -> [Option] -> IO ()
+runClang dflags args = do
+  let (clang,_) = pgm_lcc dflags
+      -- be careful what options we call clang with
+      -- see #5903 and #7617 for bugs caused by this.
+      (_,args0) = pgm_a dflags
+      args1 = map Option (getOpts dflags opt_a)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  Exception.catch (do
+        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env
+    )
+    (\(err :: SomeException) -> do
+        errorMsg dflags $
+            text ("Error running clang! you need clang installed to use the" ++
+                  " LLVM backend") $+$
+            text "(or GHC tried to execute clang incorrectly)"
+        throwIO err
+    )
+
+-- | Figure out which version of LLVM we are running this session
+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
+figureLlvmVersion dflags = do
+  let (pgm,opts) = pgm_lc dflags
+      args = filter notNull (map showOpt opts)
+      -- we grab the args even though they should be useless just in
+      -- case the user is using a customised 'llc' that requires some
+      -- 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
+              (pin, pout, perr, _) <- runInteractiveProcess pgm args'
+                                              Nothing Nothing
+              {- > llc -version
+                  LLVM (http://llvm.org/):
+                    LLVM version 3.5.2
+                    ...
+              -}
+              hSetBinaryMode pout False
+              _     <- hGetLine pout
+              vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
+              v     <- case span (/= '.') vline of
+                        ("",_)  -> fail "no digits!"
+                        (x,y) -> return (read x
+                                        , read $ takeWhile isDigit $ drop 1 y)
+
+              hClose pin
+              hClose pout
+              hClose perr
+              return $ Just v
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out LLVM version):" <+>
+                      text (show err))
+                errorMsg dflags $ vcat
+                    [ text "Warning:", nest 9 $
+                          text "Couldn't figure out LLVM version!" $$
+                          text ("Make sure you have installed LLVM " ++
+                                llvmVersionStr supportedLlvmVersion) ]
+                return Nothing)
+  return ver
+
+
+runLink :: DynFlags -> [Option] -> IO ()
+runLink dflags args = do
+  -- See Note [Run-time linker info]
+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ linkargs ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
+  where
+    ld_filter = case (platformOS (targetPlatform dflags)) of
+                  OSSolaris2 -> sunos_ld_filter
+                  _ -> id
+{-
+  SunOS/Solaris ld emits harmless warning messages about unresolved
+  symbols in case of compiling into shared library when we do not
+  link against all the required libs. That is the case of GHC which
+  does not link against RTS library explicitly in order to be able to
+  choose the library later based on binary application linking
+  parameters. The warnings look like:
+
+Undefined                       first referenced
+  symbol                             in file
+stg_ap_n_fast                       ./T2386_Lib.o
+stg_upd_frame_info                  ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
+newCAF                              ./T2386_Lib.o
+stg_bh_upd_frame_info               ./T2386_Lib.o
+stg_ap_ppp_fast                     ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
+stg_ap_p_fast                       ./T2386_Lib.o
+stg_ap_pp_fast                      ./T2386_Lib.o
+ld: warning: symbol referencing errors
+
+  this is actually coming from T2386 testcase. The emitting of those
+  warnings is also a reason why so many TH testcases fail on Solaris.
+
+  Following filter code is SunOS/Solaris linker specific and should
+  filter out only linker warnings. Please note that the logic is a
+  little bit more complex due to the simple reason that we need to preserve
+  any other linker emitted messages. If there are any. Simply speaking
+  if we see "Undefined" and later "ld: warning:..." then we omit all
+  text between (including) the marks. Otherwise we copy the whole output.
+-}
+    sunos_ld_filter :: String -> String
+    sunos_ld_filter = unlines . sunos_ld_filter' . lines
+    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+                          then (ld_prefix x) ++ (ld_postfix x)
+                          else x
+    breakStartsWith x y = break (isPrefixOf x) y
+    ld_prefix = fst . breakStartsWith "Undefined"
+    undefined_found = not . null . snd . breakStartsWith "Undefined"
+    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
+    ld_postfix = tail . snd . ld_warn_break
+    ld_warning_found = not . null . snd . ld_warn_break
+
+
+runLibtool :: DynFlags -> [Option] -> IO ()
+runLibtool dflags args = do
+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
+  let args1      = map Option (getOpts dflags opt_l)
+      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
+      libtool    = pgm_libtool dflags
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env
+
+runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()
+runAr dflags cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingFiltered dflags id "Ar" ar args cwd Nothing
+
+askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String
+askAr dflags mb_cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingWith dflags "Ar" ar args $ \real_args ->
+    readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
+
+runRanlib :: DynFlags -> [Option] -> IO ()
+runRanlib dflags args = do
+  let ranlib = pgm_ranlib dflags
+  runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
+
+runMkDLL :: DynFlags -> [Option] -> IO ()
+runMkDLL dflags args = do
+  let (p,args0) = pgm_dll dflags
+      args1 = args0 ++ args
+  mb_env <- getGccEnv (args0++args)
+  runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env
+
+runWindres :: DynFlags -> [Option] -> IO ()
+runWindres dflags args = do
+  let (gcc, gcc_args) = pgm_c dflags
+      windres = pgm_windres dflags
+      opts = map Option (getOpts dflags opt_windres)
+      quote x = "\"" ++ x ++ "\""
+      args' = -- If windres.exe and gcc.exe are in a directory containing
+              -- spaces then windres fails to run gcc. We therefore need
+              -- to tell it what command to use...
+              Option ("--preprocessor=" ++
+                      unwords (map quote (gcc :
+                                          map showOpt gcc_args ++
+                                          map showOpt opts ++
+                                          ["-E", "-xc", "-DRC_INVOKED"])))
+              -- ...but if we do that then if windres calls popen then
+              -- it can't understand the quoting, so we have to use
+              -- --use-temp-file so that it interprets it correctly.
+              -- See #1828.
+            : Option "--use-temp-file"
+            : args
+  mb_env <- getGccEnv gcc_args
+  runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env
+
+touch :: DynFlags -> String -> String -> IO ()
+touch dflags purpose arg =
+  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/TidyPgm.hs
@@ -0,0 +1,1463 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section{Tidying up Core}
+-}
+
+{-# LANGUAGE CPP, ViewPatterns #-}
+
+module TidyPgm (
+       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import DynFlags
+import CoreSyn
+import CoreUnfold
+import CoreFVs
+import CoreTidy
+import CoreMonad
+import CorePrep
+import CoreUtils        (rhsIsStatic)
+import CoreStats        (coreBindsStats, CoreStats(..))
+import CoreSeq          (seqBinds)
+import CoreLint
+import Literal
+import Rules
+import PatSyn
+import ConLike
+import CoreArity        ( exprArity, exprBotStrictness_maybe )
+import StaticPtrTable
+import VarEnv
+import VarSet
+import Var
+import Id
+import MkId             ( mkDictSelRhs )
+import IdInfo
+import InstEnv
+import FamInstEnv
+import Type             ( tidyTopType )
+import Demand           ( appIsBottom, isTopSig, isBottomingSig )
+import BasicTypes
+import Name hiding (varName)
+import NameSet
+import NameEnv
+import NameCache
+import Avail
+import IfaceEnv
+import TcEnv
+import TcRnMonad
+import DataCon
+import TyCon
+import Class
+import Module
+import Packages( isDllName )
+import HscTypes
+import Maybes
+import UniqSupply
+import Outputable
+import qualified ErrUtils as Err
+
+import Control.Monad
+import Data.Function
+import Data.List        ( sortBy )
+import Data.IORef       ( atomicModifyIORef' )
+
+{-
+Constructing the TypeEnv, Instances, Rules from which the
+ModIface is constructed, and which goes on to subsequent modules in
+--make mode.
+
+Most of the interface file is obtained simply by serialising the
+TypeEnv.  One important consequence is that if the *interface file*
+has pragma info if and only if the final TypeEnv does. This is not so
+important for *this* module, but it's essential for ghc --make:
+subsequent compilations must not see (e.g.) the arity if the interface
+file does not contain arity If they do, they'll exploit the arity;
+then the arity might change, but the iface file doesn't change =>
+recompilation does not happen => disaster.
+
+For data types, the final TypeEnv will have a TyThing for the TyCon,
+plus one for each DataCon; the interface file will contain just one
+data type declaration, but it is de-serialised back into a collection
+of TyThings.
+
+************************************************************************
+*                                                                      *
+                Plan A: simpleTidyPgm
+*                                                                      *
+************************************************************************
+
+
+Plan A: mkBootModDetails: omit pragmas, make interfaces small
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Ignore the bindings
+
+* Drop all WiredIn things from the TypeEnv
+        (we never want them in interface files)
+
+* Retain all TyCons and Classes in the TypeEnv, to avoid
+        having to find which ones are mentioned in the
+        types of exported Ids
+
+* Trim off the constructors of non-exported TyCons, both
+        from the TyCon and from the TypeEnv
+
+* Drop non-exported Ids from the TypeEnv
+
+* Tidy the types of the DFunIds of Instances,
+  make them into GlobalIds, (they already have External Names)
+  and add them to the TypeEnv
+
+* Tidy the types of the (exported) Ids in the TypeEnv,
+  make them into GlobalIds (they already have External Names)
+
+* Drop rules altogether
+
+* Tidy the bindings, to ensure that the Caf and Arity
+  information is correct for each top-level binder; the
+  code generator needs it. And to ensure that local names have
+  distinct OccNames in case of object-file splitting
+
+* If this an hsig file, drop the instances altogether too (they'll
+  get pulled in by the implicit module import.
+-}
+
+-- This is Plan A: make a small type env when typechecking only,
+-- or when compiling a hs-boot file, or simply when not using -O
+--
+-- We don't look at the bindings at all -- there aren't any
+-- for hs-boot files
+
+mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
+mkBootModDetailsTc hsc_env
+        TcGblEnv{ tcg_exports   = exports,
+                  tcg_type_env  = type_env, -- just for the Ids
+                  tcg_tcs       = tcs,
+                  tcg_patsyns   = pat_syns,
+                  tcg_insts     = insts,
+                  tcg_fam_insts = fam_insts,
+                  tcg_mod       = this_mod
+                }
+  = -- This timing isn't terribly useful since the result isn't forced, but
+    -- the message is useful to locating oneself in the compilation process.
+    Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr this_mod))
+                   (const ()) $
+    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
+              ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
+              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
+                                           (typeEnvIds type_env) tcs fam_insts
+              ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1
+              ; dfun_ids   = map instanceDFunId insts'
+              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
+              }
+        ; return (ModDetails { md_types     = type_env'
+                             , md_insts     = insts'
+                             , md_fam_insts = fam_insts
+                             , md_rules     = []
+                             , md_anns      = []
+                             , md_exports   = exports
+                             , md_complete_sigs = []
+                             })
+        }
+  where
+    dflags = hsc_dflags hsc_env
+
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+mkBootTypeEnv exports ids tcs fam_insts
+  = tidyTypeEnv True $
+       typeEnvFromEntities final_ids tcs fam_insts
+  where
+        -- Find the LocalIds in the type env that are exported
+        -- Make them into GlobalIds, and tidy their types
+        --
+        -- It's very important to remove the non-exported ones
+        -- because we don't tidy the OccNames, and if we don't remove
+        -- the non-exported ones we'll get many things with the
+        -- same name in the interface file, giving chaos.
+        --
+        -- Do make sure that we keep Ids that are already Global.
+        -- When typechecking an .hs-boot file, the Ids come through as
+        -- GlobalIds.
+    final_ids = [ (if isLocalId id then globaliseAndTidyId id
+                                   else id)
+                        `setIdUnfolding` BootUnfolding
+                | id <- ids
+                , keep_it id ]
+
+        -- default methods have their export flag set, but everything
+        -- else doesn't (yet), because this is pre-desugaring, so we
+        -- must test both.
+    keep_it id = isExportedId id || idName id `elemNameSet` exports
+
+
+
+globaliseAndTidyId :: Id -> Id
+-- Takes a LocalId with an External Name,
+-- makes it into a GlobalId
+--     * unchanged Name (might be Internal or External)
+--     * unchanged details
+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood)
+globaliseAndTidyId id
+  = Id.setIdType (globaliseId id) tidy_type
+  where
+    tidy_type = tidyTopType (idType id)
+
+{-
+************************************************************************
+*                                                                      *
+        Plan B: tidy bindings, make TypeEnv full of IdInfo
+*                                                                      *
+************************************************************************
+
+Plan B: include pragmas, make interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Step 1: Figure out which Ids are externally visible
+          See Note [Choosing external Ids]
+
+* Step 2: Gather the externally visible rules, separately from
+          the top-level bindings.
+          See Note [Finding external rules]
+
+* Step 3: Tidy the bindings, externalising appropriate Ids
+          See Note [Tidy the top-level bindings]
+
+* Drop all Ids from the TypeEnv, and add all the External Ids from
+  the bindings.  (This adds their IdInfo to the TypeEnv; and adds
+  floated-out Ids that weren't even in the TypeEnv before.)
+
+Note [Choosing external Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also the section "Interface stability" in the
+recompilation-avoidance commentary:
+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
+
+First we figure out which Ids are "external" Ids.  An
+"external" Id is one that is visible from outside the compilation
+unit.  These are
+  a) the user exported ones
+  b) the ones bound to static forms
+  c) ones mentioned in the unfoldings, workers, or
+     rules of externally-visible ones
+
+While figuring out which Ids are external, we pick a "tidy" OccName
+for each one.  That is, we make its OccName distinct from the other
+external OccNames in this module, so that in interface files and
+object code we can refer to it unambiguously by its OccName.  The
+OccName for each binder is prefixed by the name of the exported Id
+that references it; e.g. if "f" references "x" in its unfolding, then
+"x" is renamed to "f_x".  This helps distinguish the different "x"s
+from each other, and means that if "f" is later removed, things that
+depend on the other "x"s will not need to be recompiled.  Of course,
+if there are multiple "f_x"s, then we have to disambiguate somehow; we
+use "f_x0", "f_x1" etc.
+
+As far as possible we should assign names in a deterministic fashion.
+Each time this module is compiled with the same options, we should end
+up with the same set of external names with the same types.  That is,
+the ABI hash in the interface should not change.  This turns out to be
+quite tricky, since the order of the bindings going into the tidy
+phase is already non-deterministic, as it is based on the ordering of
+Uniques, which are assigned unpredictably.
+
+To name things in a stable way, we do a depth-first-search of the
+bindings, starting from the exports sorted by name.  This way, as long
+as the bindings themselves are deterministic (they sometimes aren't!),
+the order in which they are presented to the tidying phase does not
+affect the names we assign.
+
+Note [Tidy the top-level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Next we traverse the bindings top to bottom.  For each *top-level*
+binder
+
+ 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
+    reflecting the fact that from now on we regard it as a global,
+    not local, Id
+
+ 2. Give it a system-wide Unique.
+    [Even non-exported things need system-wide Uniques because the
+    byte-code generator builds a single Name->BCO symbol table.]
+
+    We use the NameCache kept in the HscEnv as the
+    source of such system-wide uniques.
+
+    For external Ids, use the original-name cache in the NameCache
+    to ensure that the unique assigned is the same as the Id had
+    in any previous compilation run.
+
+ 3. Rename top-level Ids according to the names we chose in step 1.
+    If it's an external Id, make it have a External Name, otherwise
+    make it have an Internal Name.  This is used by the code generator
+    to decide whether to make the label externally visible
+
+ 4. Give it its UTTERLY FINAL IdInfo; in ptic,
+        * its unfolding, if it should have one
+
+        * its arity, computed from the number of visible lambdas
+
+        * its CAF info, computed from what is free in its RHS
+
+
+Finally, substitute these new top-level binders consistently
+throughout, including in unfoldings.  We also tidy binders in
+RHSs, so that they print nicely in interfaces.
+-}
+
+tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
+tidyProgram hsc_env  (ModGuts { mg_module    = mod
+                              , mg_exports   = exports
+                              , mg_rdr_env   = rdr_env
+                              , mg_tcs       = tcs
+                              , mg_insts     = cls_insts
+                              , mg_fam_insts = fam_insts
+                              , mg_binds     = binds
+                              , mg_patsyns   = patsyns
+                              , mg_rules     = imp_rules
+                              , mg_anns      = anns
+                              , mg_complete_sigs = complete_sigs
+                              , mg_deps      = deps
+                              , mg_foreign   = foreign_stubs
+                              , mg_foreign_files = foreign_files
+                              , mg_hpc_info  = hpc_info
+                              , mg_modBreaks = modBreaks
+                              })
+
+  = Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr mod))
+                   (const ()) $
+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
+              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
+              ; print_unqual = mkPrintUnqualified dflags rdr_env
+              }
+
+        ; let { type_env = typeEnvFromEntities [] tcs fam_insts
+
+              ; implicit_binds
+                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
+                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
+              }
+
+        ; (unfold_env, tidy_occ_env)
+              <- chooseExternalIds hsc_env mod omit_prags expose_all
+                                   binds implicit_binds imp_rules
+        ; let { (trimmed_binds, trimmed_rules)
+                    = findExternalRules omit_prags binds imp_rules unfold_env }
+
+        ; (tidy_env, tidy_binds)
+                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds
+
+        ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
+                                    isExternalName (idName id)]
+              ; type_env1  = extendTypeEnvWithIds type_env final_ids
+
+              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts
+                -- A DFunId will have a binding in tidy_binds, and so will now be in
+                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since
+                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
+                -- tidy_cls_insts.  Similarly the Ids inside a PatSyn.
+
+              ; tidy_rules = tidyRules tidy_env trimmed_rules
+                -- You might worry that the tidy_env contains IdInfo-rich stuff
+                -- and indeed it does, but if omit_prags is on, ext_rules is
+                -- empty
+
+                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
+                -- and then override the PatSyns in the type_env with the new tidy ones
+                -- This is really the only reason we keep mg_patsyns at all; otherwise
+                -- they could just stay in type_env
+              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns
+              ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
+
+              ; tidy_type_env = tidyTypeEnv omit_prags type_env2
+              }
+          -- See Note [Grand plan for static forms] in StaticPtrTable.
+        ; (spt_entries, tidy_binds') <-
+             sptCreateStaticBinds hsc_env mod tidy_binds
+        ; let { spt_init_code = sptModuleInitCode mod spt_entries
+              ; add_spt_init_code =
+                  case hscTarget dflags of
+                    -- If we are compiling for the interpreter we will insert
+                    -- any necessary SPT entries dynamically
+                    HscInterpreted -> id
+                    -- otherwise add a C stub to do so
+                    _              -> (`appendStubC` spt_init_code)
+              }
+
+        ; let { -- See Note [Injecting implicit bindings]
+                all_tidy_binds = implicit_binds ++ tidy_binds'
+
+              -- Get the TyCons to generate code for.  Careful!  We must use
+              -- the untidied TypeEnv here, because we need
+              --  (a) implicit TyCons arising from types and classes defined
+              --      in this module
+              --  (b) wired-in TyCons, which are normally removed from the
+              --      TypeEnv we put in the ModDetails
+              --  (c) Constructors even if they are not exported (the
+              --      tidied TypeEnv has trimmed these away)
+              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
+              }
+
+        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
+
+          -- If the endPass didn't print the rules, but ddump-rules is
+          -- on, print now
+        ; unless (dopt Opt_D_dump_simpl dflags) $
+            Err.dumpIfSet_dyn dflags Opt_D_dump_rules
+              (showSDoc dflags (ppr CoreTidy <+> text "rules"))
+              (pprRulesForUser dflags tidy_rules)
+
+          -- Print one-line size info
+        ; let cs = coreBindsStats tidy_binds
+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"
+            (text "Tidy size (terms,types,coercions)"
+             <+> ppr (moduleName mod) <> colon
+             <+> int (cs_tm cs)
+             <+> int (cs_ty cs)
+             <+> int (cs_co cs) )
+
+        ; return (CgGuts { cg_module   = mod,
+                           cg_tycons   = alg_tycons,
+                           cg_binds    = all_tidy_binds,
+                           cg_foreign  = add_spt_init_code foreign_stubs,
+                           cg_foreign_files = foreign_files,
+                           cg_dep_pkgs = map fst $ dep_pkgs deps,
+                           cg_hpc_info = hpc_info,
+                           cg_modBreaks = modBreaks,
+                           cg_spt_entries = spt_entries },
+
+                   ModDetails { md_types     = tidy_type_env,
+                                md_rules     = tidy_rules,
+                                md_insts     = tidy_cls_insts,
+                                md_fam_insts = fam_insts,
+                                md_exports   = exports,
+                                md_anns      = anns,      -- are already tidy
+                                md_complete_sigs = complete_sigs
+                              })
+        }
+  where
+    dflags = hsc_dflags hsc_env
+
+tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
+            -> TypeEnv -> TypeEnv
+
+-- The completed type environment is gotten from
+--      a) the types and classes defined here (plus implicit things)
+--      b) adding Ids with correct IdInfo, including unfoldings,
+--              gotten from the bindings
+-- From (b) we keep only those Ids with External names;
+--          the CoreTidy pass makes sure these are all and only
+--          the externally-accessible ones
+-- This truncates the type environment to include only the
+-- exported Ids and things needed from them, which saves space
+--
+-- See Note [Don't attempt to trim data types]
+
+tidyTypeEnv omit_prags type_env
+ = let
+        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
+          -- (1) remove wired-in things
+        type_env2 | omit_prags = mapNameEnv trimThing type_env1
+                  | otherwise  = type_env1
+          -- (2) trimmed if necessary
+    in
+    type_env2
+
+--------------------------
+trimThing :: TyThing -> TyThing
+-- Trim off inessentials, for boot files and no -O
+trimThing (AnId id)
+   | not (isImplicitId id)
+   = AnId (id `setIdInfo` vanillaIdInfo)
+
+trimThing other_thing
+  = other_thing
+
+extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
+extendTypeEnvWithPatSyns tidy_patsyns type_env
+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
+
+{-
+Note [Don't attempt to trim data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For some time GHC tried to avoid exporting the data constructors
+of a data type if it wasn't strictly necessary to do so; see #835.
+But "strictly necessary" accumulated a longer and longer list
+of exceptions, and finally I gave up the battle:
+
+    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11
+    Author: Simon Peyton Jones <simonpj@microsoft.com>
+    Date:   Thu Dec 6 16:03:16 2012 +0000
+
+    Stop attempting to "trim" data types in interface files
+
+    Without -O, we previously tried to make interface files smaller
+    by not including the data constructors of data types.  But
+    there are a lot of exceptions, notably when Template Haskell is
+    involved or, more recently, DataKinds.
+
+    However #7445 shows that even without TemplateHaskell, using
+    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ
+    is enough to require us to expose the data constructors.
+
+    So I've given up on this "optimisation" -- it's probably not
+    important anyway.  Now I'm simply not attempting to trim off
+    the data constructors.  The gain in simplicity is worth the
+    modest cost in interface file growth, which is limited to the
+    bits reqd to describe those data constructors.
+
+************************************************************************
+*                                                                      *
+        Implicit bindings
+*                                                                      *
+************************************************************************
+
+Note [Injecting implicit bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We inject the implicit bindings right at the end, in CoreTidy.
+Some of these bindings, notably record selectors, are not
+constructed in an optimised form.  E.g. record selector for
+        data T = MkT { x :: {-# UNPACK #-} !Int }
+Then the unfolding looks like
+        x = \t. case t of MkT x1 -> let x = I# x1 in x
+This generates bad code unless it's first simplified a bit.  That is
+why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of
+optimisation first.  (Only matters when the selector is used curried;
+eg map x ys.)  See #2070.
+
+[Oct 09: in fact, record selectors are no longer implicit Ids at all,
+because we really do want to optimise them properly. They are treated
+much like any other Id.  But doing "light" optimisation on an implicit
+Id still makes sense.]
+
+At one time I tried injecting the implicit bindings *early*, at the
+beginning of SimplCore.  But that gave rise to real difficulty,
+because GlobalIds are supposed to have *fixed* IdInfo, but the
+simplifier and other core-to-core passes mess with IdInfo all the
+time.  The straw that broke the camels back was when a class selector
+got the wrong arity -- ie the simplifier gave it arity 2, whereas
+importing modules were expecting it to have arity 1 (#2844).
+It's much safer just to inject them right at the end, after tidying.
+
+Oh: two other reasons for injecting them late:
+
+  - If implicit Ids are already in the bindings when we start TidyPgm,
+    we'd have to be careful not to treat them as external Ids (in
+    the sense of chooseExternalIds); else the Ids mentioned in *their*
+    RHSs will be treated as external and you get an interface file
+    saying      a18 = <blah>
+    but nothing referring to a18 (because the implicit Id is the
+    one that does, and implicit Ids don't appear in interface files).
+
+  - More seriously, the tidied type-envt will include the implicit
+    Id replete with a18 in its unfolding; but we won't take account
+    of a18 when computing a fingerprint for the class; result chaos.
+
+There is one sort of implicit binding that is injected still later,
+namely those for data constructor workers. Reason (I think): it's
+really just a code generation trick.... binding itself makes no sense.
+See Note [Data constructor workers] in CorePrep.
+-}
+
+getTyConImplicitBinds :: TyCon -> [CoreBind]
+getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
+
+getClassImplicitBinds :: Class -> [CoreBind]
+getClassImplicitBinds cls
+  = [ NonRec op (mkDictSelRhs cls val_index)
+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
+
+get_defn :: Id -> CoreBind
+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Step 1: finding externals}
+*                                                                      *
+************************************************************************
+
+See Note [Choosing external Ids].
+-}
+
+type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
+  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
+  -- The Unique is unchanged.  If the new Name is external, it will be
+  -- visible in the interface file.
+  --
+  -- Bool => expose unfolding or not.
+
+chooseExternalIds :: HscEnv
+                  -> Module
+                  -> Bool -> Bool
+                  -> [CoreBind]
+                  -> [CoreBind]
+                  -> [CoreRule]
+                  -> IO (UnfoldEnv, TidyOccEnv)
+                  -- Step 1 from the notes above
+
+chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
+  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
+       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
+       ; tidy_internal internal_ids unfold_env1 occ_env1 }
+ where
+  nc_var = hsc_NC hsc_env
+
+  -- init_ext_ids is the initial list of Ids that should be
+  -- externalised.  It serves as the starting point for finding a
+  -- deterministic, tidy, renaming for all external Ids in this
+  -- module.
+  --
+  -- It is sorted, so that it has a deterministic order (i.e. it's the
+  -- same list every time this module is compiled), in contrast to the
+  -- bindings, which are ordered non-deterministically.
+  init_work_list = zip init_ext_ids init_ext_ids
+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
+
+  -- An Id should be external if either (a) it is exported,
+  -- (b) it appears in the RHS of a local rule for an imported Id, or
+  -- See Note [Which rules to expose]
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
+
+  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
+
+  binders          = map fst $ flattenBinds binds
+  implicit_binders = bindersOfBinds implicit_binds
+  binder_set       = mkVarSet binders
+
+  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
+                                let name = idName bndr,
+                                isExternalName name ]
+                -- In computing our "avoids" list, we must include
+                --      all implicit Ids
+                --      all things with global names (assigned once and for
+                --                                      all by the renamer)
+                -- since their names are "taken".
+                -- The type environment is a convenient source of such things.
+                -- In particular, the set of binders doesn't include
+                -- implicit Ids at this stage.
+
+        -- We also make sure to avoid any exported binders.  Consider
+        --      f{-u1-} = 1     -- Local decl
+        --      ...
+        --      f{-u2-} = 2     -- Exported decl
+        --
+        -- The second exported decl must 'get' the name 'f', so we
+        -- have to put 'f' in the avoids list before we get to the first
+        -- decl.  tidyTopId then does a no-op on exported binders.
+  init_occ_env = initTidyOccEnv avoids
+
+
+  search :: [(Id,Id)]    -- The work-list: (external id, referring id)
+                         -- Make a tidy, external Name for the external id,
+                         --   add it to the UnfoldEnv, and do the same for the
+                         --   transitive closure of Ids it refers to
+                         -- The referring id is used to generate a tidy
+                         ---  name for the external id
+         -> UnfoldEnv    -- id -> (new Name, show_unfold)
+         -> TidyOccEnv   -- occ env for choosing new Names
+         -> IO (UnfoldEnv, TidyOccEnv)
+
+  search [] unfold_env occ_env = return (unfold_env, occ_env)
+
+  search ((idocc,referrer) : rest) unfold_env occ_env
+    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
+    | otherwise = do
+      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc
+      let
+          (new_ids, show_unfold)
+                | omit_prags = ([], False)
+                | otherwise  = addExternal expose_all refined_id
+
+                -- 'idocc' is an *occurrence*, but we need to see the
+                -- unfolding in the *definition*; so look up in binder_set
+          refined_id = case lookupVarSet binder_set idocc of
+                         Just id -> id
+                         Nothing -> WARN( True, ppr idocc ) idocc
+
+          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
+          referrer' | isExportedId refined_id = refined_id
+                    | otherwise               = referrer
+      --
+      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
+
+  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
+                -> IO (UnfoldEnv, TidyOccEnv)
+  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)
+  tidy_internal (id:ids) unfold_env occ_env = do
+      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id
+      let unfold_env' = extendVarEnv unfold_env id (name',False)
+      tidy_internal ids unfold_env' occ_env'
+
+addExternal :: Bool -> Id -> ([Id], Bool)
+addExternal expose_all id = (new_needed_ids, show_unfold)
+  where
+    new_needed_ids = bndrFvsInOrder show_unfold id
+    idinfo         = idInfo id
+    show_unfold    = show_unfolding (unfoldingInfo idinfo)
+    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
+    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
+    bottoming_fn   = isBottomingSig (strictnessInfo idinfo)
+
+        -- Stuff to do with the Id's unfolding
+        -- We leave the unfolding there even if there is a worker
+        -- In GHCi the unfolding is used by importers
+
+    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
+       =  expose_all         -- 'expose_all' says to expose all
+                             -- unfoldings willy-nilly
+
+       || isStableSource src     -- Always expose things whose
+                                 -- source is an inline rule
+
+       || not (bottoming_fn      -- No need to inline bottom functions
+           || never_active       -- Or ones that say not to
+           || loop_breaker       -- Or that are loop breakers
+           || neverUnfoldGuidance guidance)
+    show_unfolding (DFunUnfolding {}) = True
+    show_unfolding _                  = False
+
+{-
+************************************************************************
+*                                                                      *
+               Deterministic free variables
+*                                                                      *
+************************************************************************
+
+We want a deterministic free-variable list.  exprFreeVars gives us
+a VarSet, which is in a non-deterministic order when converted to a
+list.  Hence, here we define a free-variable finder that returns
+the free variables in the order that they are encountered.
+
+See Note [Choosing external Ids]
+-}
+
+bndrFvsInOrder :: Bool -> Id -> [Id]
+bndrFvsInOrder show_unfold id
+  = run (dffvLetBndr show_unfold id)
+
+run :: DFFV () -> [Id]
+run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of
+                 ((_,ids),_) -> ids
+
+newtype DFFV a
+  = DFFV (VarSet              -- Envt: non-top-level things that are in scope
+                              -- we don't want to record these as free vars
+      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
+      -> ((VarSet,[Var]),a))  -- Output state
+
+instance Functor DFFV where
+    fmap = liftM
+
+instance Applicative DFFV where
+    pure a = DFFV $ \_ st -> (st, a)
+    (<*>) = ap
+
+instance Monad DFFV where
+  (DFFV m) >>= k = DFFV $ \env st ->
+    case m env st of
+       (st',a) -> case k a of
+                     DFFV f -> f env st'
+
+extendScope :: Var -> DFFV a -> DFFV a
+extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)
+
+extendScopeList :: [Var] -> DFFV a -> DFFV a
+extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)
+
+insert :: Var -> DFFV ()
+insert v = DFFV $ \ env (set, ids) ->
+           let keep_me = isLocalId v &&
+                         not (v `elemVarSet` env) &&
+                           not (v `elemVarSet` set)
+           in if keep_me
+              then ((extendVarSet set v, v:ids), ())
+              else ((set,                ids),   ())
+
+
+dffvExpr :: CoreExpr -> DFFV ()
+dffvExpr (Var v)              = insert v
+dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
+dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
+dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e
+dffvExpr (Tick _other e)    = dffvExpr e
+dffvExpr (Cast e _)           = dffvExpr e
+dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
+dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $
+                                (mapM_ dffvBind prs >> dffvExpr e)
+dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
+dffvExpr _other               = return ()
+
+dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()
+dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)
+
+dffvBind :: (Id, CoreExpr) -> DFFV ()
+dffvBind(x,r)
+  | not (isId x) = dffvExpr r
+  | otherwise    = dffvLetBndr False x >> dffvExpr r
+                -- Pass False because we are doing the RHS right here
+                -- If you say True you'll get *exponential* behaviour!
+
+dffvLetBndr :: Bool -> Id -> DFFV ()
+-- Gather the free vars of the RULES and unfolding of a binder
+-- We always get the free vars of a *stable* unfolding, but
+-- for a *vanilla* one (InlineRhs), the flag controls what happens:
+--   True <=> get fvs of even a *vanilla* unfolding
+--   False <=> ignore an InlineRhs
+-- For nested bindings (call from dffvBind) we always say "False" because
+--       we are taking the fvs of the RHS anyway
+-- For top-level bindings (call from addExternal, via bndrFvsInOrder)
+--       we say "True" if we are exposing that unfolding
+dffvLetBndr vanilla_unfold id
+  = do { go_unf (unfoldingInfo idinfo)
+       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }
+  where
+    idinfo = idInfo id
+
+    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+       = case src of
+           InlineRhs | vanilla_unfold -> dffvExpr rhs
+                     | otherwise      -> return ()
+           _                          -> dffvExpr rhs
+
+    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
+             = extendScopeList bndrs $ mapM_ dffvExpr args
+    go_unf _ = return ()
+
+    go_rule (BuiltinRule {}) = return ()
+    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
+      = extendScopeList bndrs (dffvExpr rhs)
+
+{-
+************************************************************************
+*                                                                      *
+               findExternalRules
+*                                                                      *
+************************************************************************
+
+Note [Finding external rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The complete rules are gotten by combining
+   a) local rules for imported Ids
+   b) rules embedded in the top-level Ids
+
+There are two complications:
+  * Note [Which rules to expose]
+  * Note [Trimming auto-rules]
+
+Note [Which rules to expose]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The function 'expose_rule' filters out rules that mention, on the LHS,
+Ids that aren't externally visible; these rules can't fire in a client
+module.
+
+The externally-visible binders are computed (by chooseExternalIds)
+assuming that all orphan rules are externalised (see init_ext_ids in
+function 'search'). So in fact it's a bit conservative and we may
+export more than we need.  (It's a sort of mutual recursion.)
+
+Note [Trimming auto-rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Second, with auto-specialisation we may specialise local or imported
+dfuns or INLINE functions, and then later inline them.  That may leave
+behind something like
+   RULE "foo" forall d. f @ Int d = f_spec
+where f is either local or imported, and there is no remaining
+reference to f_spec except from the RULE.
+
+Now that RULE *might* be useful to an importing module, but that is
+purely speculative, and meanwhile the code is taking up space and
+codegen time.  I found that binary sizes jumped by 6-10% when I
+started to specialise INLINE functions (again, Note [Inline
+specialisations] in Specialise).
+
+So it seems better to drop the binding for f_spec, and the rule
+itself, if the auto-generated rule is the *only* reason that it is
+being kept alive.
+
+(The RULE still might have been useful in the past; that is, it was
+the right thing to have generated it in the first place.  See Note
+[Inline specialisations] in Specialise.  But now it has served its
+purpose, and can be discarded.)
+
+So findExternalRules does this:
+  * Remove all bindings that are kept alive *only* by isAutoRule rules
+      (this is done in trim_binds)
+  * Remove all auto rules that mention bindings that have been removed
+      (this is done by filtering by keep_rule)
+
+NB: if a binding is kept alive for some *other* reason (e.g. f_spec is
+called in the final code), we keep the rule too.
+
+This stuff is the only reason for the ru_auto field in a Rule.
+-}
+
+findExternalRules :: Bool       -- Omit pragmas
+                  -> [CoreBind]
+                  -> [CoreRule] -- Local rules for imported fns
+                  -> UnfoldEnv  -- Ids that are exported, so we need their rules
+                  -> ([CoreBind], [CoreRule])
+-- See Note [Finding external rules]
+findExternalRules omit_prags binds imp_id_rules unfold_env
+  = (trimmed_binds, filter keep_rule all_rules)
+  where
+    imp_rules         = filter expose_rule imp_id_rules
+    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
+
+    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
+                           | otherwise       = ruleRhsFreeVars rule
+
+    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds
+
+    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs
+        -- Remove rules that make no sense, because they mention a
+        -- local binder (on LHS or RHS) that we have now discarded.
+        -- (NB: ruleFreeVars only includes LocalIds)
+        --
+        -- LHS: we have already filtered out rules that mention internal Ids
+        --     on LHS but that isn't enough because we might have by now
+        --     discarded a binding with an external Id. (How?
+        --     chooseExternalIds is a bit conservative.)
+        --
+        -- RHS: the auto rules that might mention a binder that has
+        --      been discarded; see Note [Trimming auto-rules]
+
+    expose_rule rule
+        | omit_prags = False
+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)
+                -- Don't expose a rule whose LHS mentions a locally-defined
+                -- Id that is completely internal (i.e. not visible to an
+                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.
+                -- See Note [Which rules to expose]
+
+    is_external_id id = case lookupVarEnv unfold_env id of
+                          Just (name, _) -> isExternalName name
+                          Nothing        -> False
+
+    trim_binds :: [CoreBind]
+               -> ( [CoreBind]   -- Trimmed bindings
+                  , VarSet       -- Binders of those bindings
+                  , VarSet       -- Free vars of those bindings + rhs of user rules
+                                 -- (we don't bother to delete the binders)
+                  , [CoreRule])  -- All rules, imported + from the bindings
+    -- This function removes unnecessary bindings, and gathers up rules from
+    -- the bindings we keep.  See Note [Trimming auto-rules]
+    trim_binds []  -- Base case, start with imp_user_rule_fvs
+       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)
+
+    trim_binds (bind:binds)
+       | any needed bndrs    -- Keep binding
+       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )
+       | otherwise           -- Discard binding altogether
+       = stuff
+       where
+         stuff@(binds', bndr_set, needed_fvs, rules)
+                       = trim_binds binds
+         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs
+
+         bndrs         = bindersOf  bind
+         rhss          = rhssOfBind bind
+         bndr_set'     = bndr_set `extendVarSetList` bndrs
+
+         needed_fvs'   = needed_fvs                                   `unionVarSet`
+                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`
+                              -- Ignore type variables in the type of bndrs
+                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`
+                         mapUnionVarSet user_rule_rhs_fvs local_rules
+            -- In needed_fvs', we don't bother to delete binders from the fv set
+
+         local_rules  = [ rule
+                        | id <- bndrs
+                        , is_external_id id   -- Only collect rules for external Ids
+                        , rule <- idCoreRules id
+                        , expose_rule rule ]  -- and ones that can fire in a client
+
+{-
+************************************************************************
+*                                                                      *
+               tidyTopName
+*                                                                      *
+************************************************************************
+
+This is where we set names to local/global based on whether they really are
+externally visible (see comment at the top of this module).  If the name
+was previously local, we have to give it a unique occurrence name if
+we intend to externalise it.
+-}
+
+tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv
+            -> Id -> IO (TidyOccEnv, Name)
+tidyTopName mod nc_var maybe_ref occ_env id
+  | global && internal = return (occ_env, localiseName name)
+
+  | global && external = return (occ_env, name)
+        -- Global names are assumed to have been allocated by the renamer,
+        -- so they already have the "right" unique
+        -- And it's a system-wide unique too
+
+  -- Now we get to the real reason that all this is in the IO Monad:
+  -- we have to update the name cache in a nice atomic fashion
+
+  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local
+                            ; return (occ_env', new_local_name) }
+        -- Even local, internal names must get a unique occurrence, because
+        -- if we do -split-objs we externalise the name later, in the code generator
+        --
+        -- Similarly, we must make sure it has a system-wide Unique, because
+        -- the byte-code generator builds a system-wide Name->BCO symbol table
+
+  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external
+                            ; return (occ_env', new_external_name) }
+
+  | otherwise = panic "tidyTopName"
+  where
+    name        = idName id
+    external    = isJust maybe_ref
+    global      = isExternalName name
+    local       = not global
+    internal    = not external
+    loc         = nameSrcSpan name
+
+    old_occ     = nameOccName name
+    new_occ | Just ref <- maybe_ref
+            , ref /= id
+            = mkOccName (occNameSpace old_occ) $
+                   let
+                       ref_str = occNameString (getOccName ref)
+                       occ_str = occNameString old_occ
+                   in
+                   case occ_str of
+                     '$':'w':_ -> occ_str
+                        -- workers: the worker for a function already
+                        -- includes the occname for its parent, so there's
+                        -- no need to prepend the referrer.
+                     _other | isSystemName name -> ref_str
+                            | otherwise         -> ref_str ++ '_' : occ_str
+                        -- If this name was system-generated, then don't bother
+                        -- to retain its OccName, just use the referrer.  These
+                        -- system-generated names will become "f1", "f2", etc. for
+                        -- a referrer "f".
+            | otherwise = old_occ
+
+    (occ_env', occ') = tidyOccName occ_env new_occ
+
+    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)
+                    where
+                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+
+    mk_new_external nc = allocateGlobalBinder nc mod occ' loc
+        -- If we want to externalise a currently-local name, check
+        -- whether we have already assigned a unique for it.
+        -- If so, use it; if not, extend the table.
+        -- All this is done by allcoateGlobalBinder.
+        -- This is needed when *re*-compiling a module in GHCi; we must
+        -- use the same name for externally-visible things as we did before.
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Step 2: top-level tidying}
+*                                                                      *
+************************************************************************
+-}
+
+-- TopTidyEnv: when tidying we need to know
+--   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
+--        These may have arisen because the
+--        renamer read in an interface file mentioning M.$wf, say,
+--        and assigned it unique r77.  If, on this compilation, we've
+--        invented an Id whose name is $wf (but with a different unique)
+--        we want to rename it to have unique r77, so that we can do easy
+--        comparisons with stuff from the interface file
+--
+--   * occ_env: The TidyOccEnv, which tells us which local occurrences
+--     are 'used'
+--
+--   * subst_env: A Var->Var mapping that substitutes the new Var for the old
+
+tidyTopBinds :: HscEnv
+             -> Module
+             -> UnfoldEnv
+             -> TidyOccEnv
+             -> CoreProgram
+             -> IO (TidyEnv, CoreProgram)
+
+tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
+  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+       mkNaturalId <- lookupMkNaturalName dflags hsc_env
+       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+       let cvt_literal nt i = case nt of
+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
+             _             -> Nothing
+           result      = tidy cvt_literal init_env binds
+       seqBinds (snd result) `seq` return result
+       -- This seqBinds avoids a spike in space usage (see #13564)
+  where
+    dflags = hsc_dflags hsc_env
+
+    init_env = (init_occ_env, emptyVarEnv)
+
+    tidy _           env []     = (env, [])
+    tidy cvt_literal env (b:bs)
+        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env
+                                        env b
+              (env2, bs') = tidy cvt_literal env1 bs
+          in  (env2, b':bs')
+
+------------------------
+tidyTopBind  :: DynFlags
+             -> Module
+             -> (LitNumType -> Integer -> Maybe CoreExpr)
+             -> UnfoldEnv
+             -> TidyEnv
+             -> CoreBind
+             -> (TidyEnv, CoreBind)
+
+tidyTopBind dflags this_mod cvt_literal unfold_env
+            (occ_env,subst1) (NonRec bndr rhs)
+  = (tidy_env2,  NonRec bndr' rhs')
+  where
+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
+    caf_info      = hasCafRefs dflags this_mod
+                               (subst1, cvt_literal)
+                               (idArity bndr) rhs
+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'
+                                (bndr, rhs)
+    subst2        = extendVarEnv subst1 bndr bndr'
+    tidy_env2     = (occ_env, subst2)
+
+tidyTopBind dflags this_mod cvt_literal unfold_env
+            (occ_env, subst1) (Rec prs)
+  = (tidy_env2, Rec prs')
+  where
+    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)
+           | (id,rhs) <- prs,
+             let (name',show_unfold) =
+                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
+           ]
+
+    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
+    tidy_env2 = (occ_env, subst2)
+
+    bndrs = map fst prs
+
+        -- the CafInfo for a recursive group says whether *any* rhs in
+        -- the group may refer indirectly to a CAF (because then, they all do).
+    caf_info
+        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod
+                                          (subst1, cvt_literal)
+                                          (idArity bndr) rhs)
+             | (bndr,rhs) <- prs ] = MayHaveCafRefs
+        | otherwise                = NoCafRefs
+
+-----------------------------------------------------------
+tidyTopPair :: DynFlags
+            -> Bool  -- show unfolding
+            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
+                        -- It is knot-tied: don't look at it!
+            -> CafInfo
+            -> Name             -- New name
+            -> (Id, CoreExpr)   -- Binder and RHS before tidying
+            -> (Id, CoreExpr)
+        -- This function is the heart of Step 2
+        -- The rec_tidy_env is the one to use for the IdInfo
+        -- It's necessary because when we are dealing with a recursive
+        -- group, a variable late in the group might be mentioned
+        -- in the IdInfo of one early in the group
+
+tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
+  = (bndr1, rhs1)
+  where
+    bndr1    = mkGlobalId details name' ty' idinfo'
+    details  = idDetails bndr   -- Preserve the IdDetails
+    ty'      = tidyTopType (idType bndr)
+    rhs1     = tidyExpr rhs_tidy_env rhs
+    idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)
+                             show_unfold caf_info
+
+-- tidyTopIdInfo creates the final IdInfo for top-level
+-- binders.  There are two delicate pieces:
+--
+--  * Arity.  After CoreTidy, this arity must not change any more.
+--      Indeed, CorePrep must eta expand where necessary to make
+--      the manifest arity equal to the claimed arity.
+--
+--  * CAF info.  This must also remain valid through to code generation.
+--      We add the info here so that it propagates to all
+--      occurrences of the binders in RHSs, and hence to occurrences in
+--      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
+--      CoreToStg makes use of this when constructing SRTs.
+tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr
+              -> IdInfo -> Bool -> CafInfo -> IdInfo
+tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
+  | not is_external     -- For internal Ids (not externally visible)
+  = vanillaIdInfo       -- we only need enough info for code generation
+                        -- Arity and strictness info are enough;
+                        --      c.f. CoreTidy.tidyLetBndr
+        `setCafInfo`        caf_info
+        `setArityInfo`      arity
+        `setStrictnessInfo` final_sig
+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
+                                                 -- in CoreTidy
+
+  | otherwise           -- Externally-visible Ids get the whole lot
+  = vanillaIdInfo
+        `setCafInfo`           caf_info
+        `setArityInfo`         arity
+        `setStrictnessInfo`    final_sig
+        `setOccInfo`           robust_occ_info
+        `setInlinePragInfo`    (inlinePragInfo idinfo)
+        `setUnfoldingInfo`     unfold_info
+                -- NB: we throw away the Rules
+                -- They have already been extracted by findExternalRules
+  where
+    is_external = isExternalName name
+
+    --------- OccInfo ------------
+    robust_occ_info = zapFragileOcc (occInfo idinfo)
+    -- It's important to keep loop-breaker information
+    -- when we are doing -fexpose-all-unfoldings
+
+    --------- Strictness ------------
+    mb_bot_str = exprBotStrictness_maybe orig_rhs
+
+    sig = strictnessInfo idinfo
+    final_sig | not $ isTopSig sig
+              = WARN( _bottom_hidden sig , ppr name ) sig
+              -- try a cheap-and-cheerful bottom analyser
+              | Just (_, nsig) <- mb_bot_str = nsig
+              | otherwise                    = sig
+
+    _bottom_hidden id_sig = case mb_bot_str of
+                                  Nothing         -> False
+                                  Just (arity, _) -> not (appIsBottom id_sig arity)
+
+    --------- Unfolding ------------
+    unf_info = unfoldingInfo idinfo
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
+                | otherwise   = minimal_unfold_info
+    minimal_unfold_info = zapUnfolding unf_info
+    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
+    is_bot = isBottomingSig final_sig
+    -- NB: do *not* expose the worker if show_unfold is off,
+    --     because that means this thing is a loop breaker or
+    --     marked NOINLINE or something like that
+    -- This is important: if you expose the worker for a loop-breaker
+    -- then you can make the simplifier go into an infinite loop, because
+    -- in effect the unfolding is exposed.  See #1709
+    --
+    -- You might think that if show_unfold is False, then the thing should
+    -- not be w/w'd in the first place.  But a legitimate reason is this:
+    --    the function returns bottom
+    -- In this case, show_unfold will be false (we don't expose unfoldings
+    -- for bottoming functions), but we might still have a worker/wrapper
+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs
+
+
+    --------- Arity ------------
+    -- Usually the Id will have an accurate arity on it, because
+    -- the simplifier has just run, but not always.
+    -- One case I found was when the last thing the simplifier
+    -- did was to let-bind a non-atomic argument and then float
+    -- it to the top level. So it seems more robust just to
+    -- fix it here.
+    arity = exprArity orig_rhs
+
+{-
+************************************************************************
+*                                                                      *
+           Figuring out CafInfo for an expression
+*                                                                      *
+************************************************************************
+
+hasCafRefs decides whether a top-level closure can point into the dynamic heap.
+We mark such things as `MayHaveCafRefs' because this information is
+used to decide whether a particular closure needs to be referenced
+in an SRT or not.
+
+There are two reasons for setting MayHaveCafRefs:
+        a) The RHS is a CAF: a top-level updatable thunk.
+        b) The RHS refers to something that MayHaveCafRefs
+
+Possible improvement: In an effort to keep the number of CAFs (and
+hence the size of the SRTs) down, we could also look at the expression and
+decide whether it requires a small bounded amount of heap, so we can ignore
+it as a CAF.  In these cases however, we would need to use an additional
+CAF list to keep track of non-collectable CAFs.
+
+Note [Disgusting computation of CafRefs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We compute hasCafRefs here, because IdInfo is supposed to be finalised
+after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.
+So we have to *predict* the result here, which is revolting.
+
+In particular CorePrep expands Integer and Natural literals. So in the
+prediction code here we resort to applying the same expansion (cvt_literal).
+Ugh!
+-}
+
+type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
+  -- The env finds the Caf-ness of the Id
+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for
+  -- Integer and Natural literals
+  -- See Note [Disgusting computation of CafRefs]
+
+hasCafRefs :: DynFlags -> Module
+           -> CafRefEnv -> Arity -> CoreExpr
+           -> CafInfo
+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr
+  | is_caf || mentions_cafs = MayHaveCafRefs
+  | otherwise               = NoCafRefs
+ where
+  mentions_cafs   = cafRefsE expr
+  is_dynamic_name = isDllName dflags this_mod
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name
+                                         cvt_literal expr)
+
+  -- NB. we pass in the arity of the expression, which is expected
+  -- to be calculated by exprArity.  This is because exprArity
+  -- knows how much eta expansion is going to be done by
+  -- CorePrep later on, and we don't want to duplicate that
+  -- knowledge in rhsIsStatic below.
+
+  cafRefsE :: Expr a -> Bool
+  cafRefsE (Var id)            = cafRefsV id
+  cafRefsE (Lit lit)           = cafRefsL lit
+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a
+  cafRefsE (Lam _ e)           = cafRefsE e
+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e
+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)
+  cafRefsE (Tick _n e)         = cafRefsE e
+  cafRefsE (Cast e _co)        = cafRefsE e
+  cafRefsE (Type _)            = False
+  cafRefsE (Coercion _)        = False
+
+  cafRefsEs :: [Expr a] -> Bool
+  cafRefsEs []     = False
+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es
+
+  cafRefsL :: Literal -> Bool
+  -- Don't forget that mk_integer id might have Caf refs!
+  -- We first need to convert the Integer into its final form, to
+  -- see whether mkInteger is used. Same for LitNatural.
+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of
+    Just e  -> cafRefsE e
+    Nothing -> False
+  cafRefsL _                = False
+
+  cafRefsV :: Id -> Bool
+  cafRefsV id
+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
+    | otherwise                         = False
+
+
+{-
+************************************************************************
+*                                                                      *
+                  Old, dead, type-trimming code
+*                                                                      *
+************************************************************************
+
+We used to try to "trim off" the constructors of data types that are
+not exported, to reduce the size of interface files, at least without
+-O.  But that is not always possible: see the old Note [When we can't
+trim types] below for exceptions.
+
+Then (#7445) I realised that the TH problem arises for any data type
+that we have deriving( Data ), because we can invoke
+   Language.Haskell.TH.Quote.dataToExpQ
+to get a TH Exp representation of a value built from that data type.
+You don't even need {-# LANGUAGE TemplateHaskell #-}.
+
+At this point I give up. The pain of trimming constructors just
+doesn't seem worth the gain.  So I've dumped all the code, and am just
+leaving it here at the end of the module in case something like this
+is ever resurrected.
+
+
+Note [When we can't trim types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea of type trimming is to export algebraic data types
+abstractly (without their data constructors) when compiling without
+-O, unless of course they are explicitly exported by the user.
+
+We always export synonyms, because they can be mentioned in the type
+of an exported Id.  We could do a full dependency analysis starting
+from the explicit exports, but that's quite painful, and not done for
+now.
+
+But there are some times we can't do that, indicated by the 'no_trim_types' flag.
+
+First, Template Haskell.  Consider (#2386) this
+        module M(T, makeOne) where
+          data T = Yay String
+          makeOne = [| Yay "Yep" |]
+Notice that T is exported abstractly, but makeOne effectively exports it too!
+A module that splices in $(makeOne) will then look for a declaration of Yay,
+so it'd better be there.  Hence, brutally but simply, we switch off type
+constructor trimming if TH is enabled in this module.
+
+Second, data kinds.  Consider (#5912)
+     {-# LANGUAGE DataKinds #-}
+     module M() where
+     data UnaryTypeC a = UnaryDataC a
+     type Bug = 'UnaryDataC
+We always export synonyms, so Bug is exposed, and that means that
+UnaryTypeC must be too, even though it's not explicitly exported.  In
+effect, DataKinds means that we'd need to do a full dependency analysis
+to see what data constructors are mentioned.  But we don't do that yet.
+
+In these two cases we just switch off type trimming altogether.
+
+mustExposeTyCon :: Bool         -- Type-trimming flag
+                -> NameSet      -- Exports
+                -> TyCon        -- The tycon
+                -> Bool         -- Can its rep be hidden?
+-- We are compiling without -O, and thus trying to write as little as
+-- possible into the interface file.  But we must expose the details of
+-- any data types whose constructors or fields are exported
+mustExposeTyCon no_trim_types exports tc
+  | no_trim_types               -- See Note [When we can't trim types]
+  = True
+
+  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to
+                                -- figure out whether it was mentioned in the type
+                                -- of any other exported thing)
+  = True
+
+  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
+  = True                        -- won't lead to the need for further exposure
+
+  | isFamilyTyCon tc            -- Open type family
+  = True
+
+  -- Below here we just have data/newtype decls or family instances
+
+  | null data_cons              -- Ditto if there are no data constructors
+  = True                        -- (NB: empty data types do not count as enumerations
+                                -- see Note [Enumeration types] in TyCon
+
+  | any exported_con data_cons  -- Expose rep if any datacon or field is exported
+  = True
+
+  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))
+  = True   -- Expose the rep for newtypes if the rep is an FFI type.
+           -- For a very annoying reason.  'Foreign import' is meant to
+           -- be able to look through newtypes transparently, but it
+           -- can only do that if it can "see" the newtype representation
+
+  | otherwise
+  = False
+  where
+    data_cons = tyConDataCons tc
+    exported_con con = any (`elemNameSet` exports)
+                           (dataConName con : dataConFieldLabels con)
+-}
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -0,0 +1,1204 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-- This is the top-level module in the native code generator.
+--
+-- -----------------------------------------------------------------------------
+
+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
+{-# LANGUAGE UnboxedTuples #-}
+#endif
+
+module AsmCodeGen (
+                    -- * Module entry point
+                    nativeCodeGen
+
+                    -- * Test-only exports: see trac #12744
+                    -- used by testGraphNoSpills, which needs to access
+                    -- the register allocator intermediate data structures
+                    -- cmmNativeGen emits
+                  , cmmNativeGen
+                  , NcgImpl(..)
+                  , x86NcgImpl
+                  ) where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+
+import GhcPrelude
+
+import qualified X86.CodeGen
+import qualified X86.Regs
+import qualified X86.Instr
+import qualified X86.Ppr
+
+import qualified SPARC.CodeGen
+import qualified SPARC.Regs
+import qualified SPARC.Instr
+import qualified SPARC.Ppr
+import qualified SPARC.ShortcutJump
+import qualified SPARC.CodeGen.Expand
+
+import qualified PPC.CodeGen
+import qualified PPC.Regs
+import qualified PPC.RegInfo
+import qualified PPC.Instr
+import qualified PPC.Ppr
+
+import RegAlloc.Liveness
+import qualified RegAlloc.Linear.Main           as Linear
+
+import qualified GraphColor                     as Color
+import qualified RegAlloc.Graph.Main            as Color
+import qualified RegAlloc.Graph.Stats           as Color
+import qualified RegAlloc.Graph.TrivColorable   as Color
+
+import AsmUtils
+import TargetReg
+import Platform
+import BlockLayout
+import Config
+import Instruction
+import PIC
+import Reg
+import NCGMonad
+import CFG
+import Dwarf
+import Debug
+
+import BlockId
+import CgUtils          ( fixStgRegisters )
+import Cmm
+import CmmUtils
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
+import CmmOpt           ( cmmMachOpFold )
+import PprCmm
+import CLabel
+
+import UniqFM
+import UniqSupply
+import DynFlags
+import Util
+
+import BasicTypes       ( Alignment )
+import qualified Pretty
+import BufWrite
+import Outputable
+import FastString
+import UniqSet
+import ErrUtils
+import Module
+import Stream (Stream)
+import qualified Stream
+
+-- DEBUGGING ONLY
+--import OrdList
+
+import Data.List
+import Data.Maybe
+import Data.Ord         ( comparing )
+import Control.Exception
+import Control.Monad
+import System.IO
+
+{-
+The native-code generator has machine-independent and
+machine-dependent modules.
+
+This module ("AsmCodeGen") is the top-level machine-independent
+module.  Before entering machine-dependent land, we do some
+machine-independent optimisations (defined below) on the
+'CmmStmts's.
+
+We convert to the machine-specific 'Instr' datatype with
+'cmmCodeGen', assuming an infinite supply of registers.  We then use
+a machine-independent register allocator ('regAlloc') to rejoin
+reality.  Obviously, 'regAlloc' has machine-specific helper
+functions (see about "RegAllocInfo" below).
+
+Finally, we order the basic blocks of the function so as to minimise
+the number of jumps between blocks, by utilising fallthrough wherever
+possible.
+
+The machine-dependent bits break down as follows:
+
+  * ["MachRegs"]  Everything about the target platform's machine
+    registers (and immediate operands, and addresses, which tend to
+    intermingle/interact with registers).
+
+  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
+    have a module of its own), plus a miscellany of other things
+    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
+
+  * ["MachCodeGen"]  is where 'Cmm' stuff turns into
+    machine instructions.
+
+  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
+    a 'SDoc').
+
+  * ["RegAllocInfo"] In the register allocator, we manipulate
+    'MRegsState's, which are 'BitSet's, one bit per machine register.
+    When we want to say something about a specific machine register
+    (e.g., ``it gets clobbered by this instruction''), we set/unset
+    its bit.  Obviously, we do this 'BitSet' thing for efficiency
+    reasons.
+
+    The 'RegAllocInfo' module collects together the machine-specific
+    info needed to do register allocation.
+
+   * ["RegisterAlloc"] The (machine-independent) register allocator.
+-}
+
+--------------------
+nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
+              -> Stream IO RawCmmGroup ()
+              -> IO UniqSupply
+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
+       nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+   in case platformArch platform of
+      ArchX86       -> nCG' (x86NcgImpl    dflags)
+      ArchX86_64    -> nCG' (x86_64NcgImpl dflags)
+      ArchPPC       -> nCG' (ppcNcgImpl    dflags)
+      ArchSPARC     -> nCG' (sparcNcgImpl  dflags)
+      ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"
+      ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"
+      ArchARM64     -> panic "nativeCodeGen: No NCG for ARM64"
+      ArchPPC_64 _  -> nCG' (ppcNcgImpl    dflags)
+      ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"
+      ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"
+      ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"
+      ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"
+      ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
+
+x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
+                                  X86.Instr.Instr X86.Instr.JumpDest
+x86NcgImpl dflags
+ = (x86_64NcgImpl dflags)
+
+x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
+                                  X86.Instr.Instr X86.Instr.JumpDest
+x86_64NcgImpl dflags
+ = NcgImpl {
+        cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
+       ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
+       ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
+       ,canShortcut               = X86.Instr.canShortcut
+       ,shortcutStatics           = X86.Instr.shortcutStatics
+       ,shortcutJump              = X86.Instr.shortcutJump
+       ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl
+       ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags
+       ,allocatableRegs           = X86.Regs.allocatableRegs platform
+       ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
+       ,ncgExpandTop              = id
+       ,ncgMakeFarBranches        = const id
+       ,extractUnwindPoints       = X86.CodeGen.extractUnwindPoints
+       ,invertCondBranches        = X86.CodeGen.invertCondBranches
+   }
+    where platform = targetPlatform dflags
+
+ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
+ppcNcgImpl dflags
+ = NcgImpl {
+        cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
+       ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
+       ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
+       ,canShortcut               = PPC.RegInfo.canShortcut
+       ,shortcutStatics           = PPC.RegInfo.shortcutStatics
+       ,shortcutJump              = PPC.RegInfo.shortcutJump
+       ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl
+       ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags
+       ,allocatableRegs           = PPC.Regs.allocatableRegs platform
+       ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform
+       ,ncgExpandTop              = id
+       ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches
+       ,extractUnwindPoints       = const []
+       ,invertCondBranches        = \_ _ -> id
+   }
+    where platform = targetPlatform dflags
+
+sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
+sparcNcgImpl dflags
+ = NcgImpl {
+        cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
+       ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
+       ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
+       ,canShortcut               = SPARC.ShortcutJump.canShortcut
+       ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
+       ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
+       ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl
+       ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags
+       ,allocatableRegs           = SPARC.Regs.allocatableRegs
+       ,ncgAllocMoreStack         = noAllocMoreStack
+       ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
+       ,ncgMakeFarBranches        = const id
+       ,extractUnwindPoints       = const []
+       ,invertCondBranches        = \_ _ -> id
+   }
+
+--
+-- Allocating more stack space for spilling is currently only
+-- supported for the linear register allocator on x86/x86_64, the rest
+-- default to the panic below.  To support allocating extra stack on
+-- more platforms provide a definition of ncgAllocMoreStack.
+--
+noAllocMoreStack :: Int -> NatCmmDecl statics instr
+                 -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)])
+noAllocMoreStack amount _
+  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
+        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
+        ++  "   is a known limitation in the linear allocator.\n"
+        ++  "\n"
+        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
+        ++  "   You can still file a bug report if you like.\n"
+
+
+-- | Data accumulated during code generation. Mostly about statistics,
+-- but also collects debug data for DWARF generation.
+data NativeGenAcc statics instr
+  = NGS { ngs_imports     :: ![[CLabel]]
+        , ngs_natives     :: ![[NatCmmDecl statics instr]]
+             -- ^ Native code generated, for statistics. This might
+             -- hold a lot of data, so it is important to clear this
+             -- field as early as possible if it isn't actually
+             -- required.
+        , ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]
+        , ngs_linearStats :: ![[Linear.RegAllocStats]]
+        , ngs_labels      :: ![Label]
+        , ngs_debug       :: ![DebugBlock]
+        , ngs_dwarfFiles  :: !DwarfFiles
+        , ngs_unwinds     :: !(LabelMap [UnwindPoint])
+             -- ^ see Note [Unwinding information in the NCG]
+             -- and Note [What is this unwinding business?] in Debug.
+        }
+
+{-
+Note [Unwinding information in the NCG]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwind information is a type of metadata which allows a debugging tool
+to reconstruct the values of machine registers at the time a procedure was
+entered. For the most part, the production of unwind information is handled by
+the Cmm stage, where it is represented by CmmUnwind nodes.
+
+Unfortunately, the Cmm stage doesn't know everything necessary to produce
+accurate unwinding information. For instance, the x86-64 calling convention
+requires that the stack pointer be aligned to 16 bytes, which in turn means that
+GHC must sometimes add padding to $sp prior to performing a foreign call. When
+this happens unwind information must be updated accordingly.
+For this reason, we make the NCG backends responsible for producing
+unwinding tables (with the extractUnwindPoints function in NcgImpl).
+
+We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
+field of NativeGenAcc. This is a label map which contains an entry for each
+procedure, containing a list of unwinding points (e.g. a label and an associated
+unwinding table).
+
+See also Note [What is this unwinding business?] in Debug.
+-}
+
+nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,
+                   Instruction instr)
+               => DynFlags
+               -> Module -> ModLocation
+               -> NcgImpl statics instr jumpDest
+               -> Handle
+               -> UniqSupply
+               -> Stream IO RawCmmGroup ()
+               -> IO UniqSupply
+nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+ = do
+        -- BufHandle is a performance hack.  We could hide it inside
+        -- Pretty if it weren't for the fact that we do lots of little
+        -- 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
+                                         cmms ngs0
+        finishNativeGen dflags modLoc bufh us' ngs
+
+finishNativeGen :: Instruction instr
+                => DynFlags
+                -> ModLocation
+                -> BufHandle
+                -> UniqSupply
+                -> NativeGenAcc statics instr
+                -> IO UniqSupply
+finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
+ = do
+        -- Write debug data and finish
+        let emitDw = debugLevel dflags > 0
+        us' <- if not emitDw then return us else do
+          (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
+          emitNativeCode dflags bufh dwarf
+          return us'
+        bFlush bufh
+
+        -- dump global NCG stats for graph coloring allocator
+        let stats = concat (ngs_colorStats ngs)
+        when (not (null stats)) $ do
+
+          -- build the global register conflict graph
+          let graphGlobal
+                  = foldl' Color.union Color.initGraph
+                  $ [ Color.raGraph stat
+                          | stat@Color.RegAllocStatsStart{} <- stats]
+
+          dump_stats (Color.pprStats stats graphGlobal)
+
+          let platform = targetPlatform dflags
+          dumpIfSet_dyn dflags
+                  Opt_D_dump_asm_conflicts "Register conflict graph"
+                  $ Color.dotGraph
+                          (targetRegDotColor platform)
+                          (Color.trivColorable platform
+                                  (targetVirtualRegSqueeze platform)
+                                  (targetRealRegSqueeze platform))
+                  $ graphGlobal
+
+
+        -- dump global NCG stats for linear allocator
+        let linearStats = concat (ngs_linearStats ngs)
+        when (not (null linearStats)) $
+          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
+
+        -- write out the imports
+        printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)
+                $ makeImportsDoc dflags (concat (ngs_imports ngs))
+        return us'
+  where
+    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
+
+cmmNativeGenStream :: (Outputable statics, Outputable instr
+                      ,Outputable jumpDest, Instruction instr)
+              => DynFlags
+              -> Module -> ModLocation
+              -> NcgImpl statics instr jumpDest
+              -> BufHandle
+              -> UniqSupply
+              -> Stream IO RawCmmGroup ()
+              -> NativeGenAcc statics instr
+              -> IO (NativeGenAcc statics instr, UniqSupply)
+
+cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
+ = do r <- Stream.runStream cmm_stream
+      case r of
+        Left () ->
+          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)
+        Right (cmms, cmm_stream') -> do
+
+          -- Generate debug information
+          let debugFlag = debugLevel dflags > 0
+              !ndbgs | debugFlag = cmmDebugGen modLoc cmms
+                     | otherwise = []
+              dbgMap = debugToMap ndbgs
+
+          -- Generate native code
+          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+                                             dbgMap us cmms ngs 0
+
+          -- 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)
+
+          -- Accumulate debug information for emission in finishNativeGen.
+          let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
+
+          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
+              cmm_stream' ngs''
+
+-- | Do native code generation on all these cmms.
+--
+cmmNativeGens :: forall statics instr jumpDest.
+                 (Outputable statics, Outputable instr
+                 ,Outputable jumpDest, Instruction instr)
+              => DynFlags
+              -> Module -> ModLocation
+              -> NcgImpl statics instr jumpDest
+              -> BufHandle
+              -> LabelMap DebugBlock
+              -> UniqSupply
+              -> [RawCmmDecl]
+              -> NativeGenAcc statics instr
+              -> Int
+              -> IO (NativeGenAcc statics instr, UniqSupply)
+
+cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
+  where
+    go :: UniqSupply -> [RawCmmDecl]
+       -> NativeGenAcc statics instr -> Int
+       -> IO (NativeGenAcc statics instr, UniqSupply)
+
+    go us [] ngs !_ =
+        return (ngs, us)
+
+    go us (cmm : cmms) ngs count = do
+        let fileIds = ngs_dwarfFiles ngs
+        (us', fileIds', native, imports, colorStats, linearStats, unwinds)
+          <- {-# SCC "cmmNativeGen" #-}
+             cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
+                          cmm count
+
+        -- Generate .file directives for every new file that has been
+        -- used. Note that it is important that we generate these in
+        -- ascending order, as Clang's 3.6 assembler complains.
+        let newFileIds = sortBy (comparing snd) $
+                         nonDetEltsUFM $ fileIds' `minusUFM` fileIds
+            -- See Note [Unique Determinism and code generation]
+            pprDecl (f,n) = text "\t.file " <> ppr n <+>
+                            pprFilePathString (unpackFS f)
+
+        emitNativeCode dflags h $ vcat $
+          map pprDecl newFileIds ++
+          map (pprNatCmmDecl ncgImpl) native
+
+        -- force evaluation all this stuff to avoid space leaks
+        {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
+
+        let !labels' = if debugLevel dflags > 0
+                       then cmmDebugLabels isMetaInstr native else []
+            !natives' = if dopt Opt_D_dump_asm_stats dflags
+                        then native : ngs_natives ngs else []
+
+            mCon = maybe id (:)
+            ngs' = ngs{ ngs_imports     = imports : ngs_imports ngs
+                      , ngs_natives     = natives'
+                      , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs
+                      , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
+                      , ngs_labels      = ngs_labels ngs ++ labels'
+                      , ngs_dwarfFiles  = fileIds'
+                      , 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 ()
+emitNativeCode dflags h sdoc = do
+
+        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h
+                                      (mkCodeStyle AsmStyle) sdoc
+
+        -- dump native code
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm "Asm code"
+                sdoc
+
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+--      Dumping the output of each stage along the way.
+--      Global conflict graph and NGC stats
+cmmNativeGen
+    :: forall statics instr jumpDest. (Instruction instr,
+        Outputable statics, Outputable instr, Outputable jumpDest)
+    => DynFlags
+    -> Module -> ModLocation
+    -> NcgImpl statics instr jumpDest
+        -> UniqSupply
+        -> DwarfFiles
+        -> LabelMap DebugBlock
+        -> RawCmmDecl                                   -- ^ the cmm to generate code for
+        -> Int                                          -- ^ sequence number of this top thing
+        -> IO   ( UniqSupply
+                , DwarfFiles
+                , [NatCmmDecl statics instr]                -- native code
+                , [CLabel]                                  -- things imported by this cmm
+                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
+                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators
+                , LabelMap [UnwindPoint]                    -- unwinding information for blocks
+                )
+
+cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
+ = do
+        let platform = targetPlatform dflags
+
+        -- rewrite assignments to global regs
+        let fixed_cmm =
+                {-# SCC "fixStgRegisters" #-}
+                fixStgRegisters dflags cmm
+
+        -- cmm to cmm optimisations
+        let (opt_cmm, imports) =
+                {-# SCC "cmmToCmm" #-}
+                cmmToCmm dflags this_mod fixed_cmm
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_opt_cmm "Optimised Cmm"
+                (pprCmmGroup [opt_cmm])
+
+        let cmmCfg = {-# SCC "getCFG" #-}
+                     getCfgProc (cfgWeightInfo dflags) opt_cmm
+
+        -- generate native code from cmm
+        let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =
+                {-# SCC "genMachCode" #-}
+                initUs us $ genMachCode dflags this_mod modLoc
+                                        (cmmTopCodeGen ncgImpl)
+                                        fileIds dbgMap opt_cmm cmmCfg
+
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_native "Native code"
+                (vcat $ map (pprNatCmmDecl ncgImpl) native)
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_cfg_weights "CFG Weights"
+                (pprEdgeWeights nativeCfgWeights)
+
+        -- tag instructions with register liveness information
+        -- also drops dead code
+        let livenessCfg = if (backendMaintainsCfg dflags)
+                                then Just nativeCfgWeights
+                                else Nothing
+        let (withLiveness, usLive) =
+                {-# SCC "regLiveness" #-}
+                initUs usGen
+                        $ mapM (cmmTopLiveness livenessCfg platform) native
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_liveness "Liveness annotations added"
+                (vcat $ map ppr withLiveness)
+
+        -- allocate registers
+        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-
+         if ( gopt Opt_RegsGraph dflags
+           || gopt Opt_RegsIterative dflags )
+          then do
+                -- the regs usable for allocation
+                let (alloc_regs :: UniqFM (UniqSet RealReg))
+                        = foldr (\r -> plusUFM_C unionUniqSets
+                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
+                                emptyUFM
+                        $ allocatableRegs ncgImpl
+
+                -- do the graph coloring register allocation
+                let ((alloced, maybe_more_stack, regAllocStats), usAlloc)
+                        = {-# SCC "RegAlloc-color" #-}
+                          initUs usLive
+                          $ Color.regAlloc
+                                dflags
+                                alloc_regs
+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])
+                                (maxSpillSlots ncgImpl)
+                                withLiveness
+                                livenessCfg
+
+                let ((alloced', stack_updt_blks), usAlloc')
+                        = initUs usAlloc $
+                                case maybe_more_stack of
+                                Nothing     -> return (alloced, [])
+                                Just amount -> do
+                                    (alloced',stack_updt_blks) <- unzip <$>
+                                                (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)
+                                    return (alloced', concat stack_updt_blks )
+
+
+                -- dump out what happened during register allocation
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc "Registers allocated"
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+                        (vcat   $ map (\(stage, stats)
+                                        -> text "# --------------------------"
+                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage
+                                        $$ ppr stats)
+                                $ zip [0..] regAllocStats)
+
+                let mPprStats =
+                        if dopt Opt_D_dump_asm_stats dflags
+                         then Just regAllocStats else Nothing
+
+                -- force evaluation of the Maybe to avoid space leak
+                mPprStats `seq` return ()
+
+                return  ( alloced', usAlloc'
+                        , mPprStats
+                        , Nothing
+                        , [], stack_updt_blks)
+
+          else do
+                -- do linear register allocation
+                let reg_alloc proc = do
+                       (alloced, maybe_more_stack, ra_stats) <-
+                               Linear.regAlloc dflags proc
+                       case maybe_more_stack of
+                         Nothing -> return ( alloced, ra_stats, [] )
+                         Just amount -> do
+                           (alloced',stack_updt_blks) <-
+                               ncgAllocMoreStack ncgImpl amount alloced
+                           return (alloced', ra_stats, stack_updt_blks )
+
+                let ((alloced, regAllocStats, stack_updt_blks), usAlloc)
+                        = {-# SCC "RegAlloc-linear" #-}
+                          initUs usLive
+                          $ liftM unzip3
+                          $ mapM reg_alloc withLiveness
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc "Registers allocated"
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+                let mPprStats =
+                        if dopt Opt_D_dump_asm_stats dflags
+                         then Just (catMaybes regAllocStats) else Nothing
+
+                -- force evaluation of the Maybe to avoid space leak
+                mPprStats `seq` return ()
+
+                return  ( alloced, usAlloc
+                        , Nothing
+                        , mPprStats, (catMaybes regAllocStats)
+                        , concat stack_updt_blks )
+
+        -- Fixupblocks the register allocator inserted (from, regMoves, to)
+        let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)]
+            cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
+
+        let cfgWithFixupBlks =
+                addNodesBetween nativeCfgWeights cfgRegAllocUpdates
+
+        -- Insert stack update blocks
+        let postRegCFG =
+                foldl' (\m (from,to) -> addImmediateSuccessor from to m )
+                       cfgWithFixupBlks stack_updt_blks
+
+        ---- generate jump tables
+        let tabled      =
+                {-# SCC "generateJumpTables" #-}
+                generateJumpTables ncgImpl alloced
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_cfg_weights "CFG Update information"
+                ( text "stack:" <+> ppr stack_updt_blks $$
+                  text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
+
+        ---- shortcut branches
+        let (shorted, postShortCFG)     =
+                {-# SCC "shortcutBranches" #-}
+                shortcutBranches dflags ncgImpl tabled postRegCFG
+
+        let optimizedCFG =
+                optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_cfg_weights "CFG Final Weights"
+                ( pprEdgeWeights optimizedCFG )
+
+        --TODO: Partially check validity of the cfg.
+        let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
+            getBlks _ = []
+
+        when ( backendMaintainsCfg dflags &&
+                (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
+                let blocks = concatMap getBlks shorted
+                let labels = setFromList $ fmap blockId blocks :: LabelSet
+                return $! seq (sanityCheckCfg optimizedCFG labels $
+                                text "cfg not in lockstep") ()
+
+        ---- sequence blocks
+        let sequenced :: [NatCmmDecl statics instr]
+            sequenced =
+                checkLayout shorted $
+                {-# SCC "sequenceBlocks" #-}
+                map (BlockLayout.sequenceTop
+                        dflags
+                        ncgImpl optimizedCFG)
+                    shorted
+
+        let branchOpt :: [NatCmmDecl statics instr]
+            branchOpt =
+                {-# SCC "invertCondBranches" #-}
+                map invert sequenced
+              where
+                invertConds = (invertCondBranches ncgImpl) optimizedCFG
+                invert top@CmmData {} = top
+                invert (CmmProc info lbl live (ListGraph blocks)) =
+                    CmmProc info lbl live (ListGraph $ invertConds info blocks)
+
+        ---- expansion of SPARC synthetic instrs
+        let expanded =
+                {-# SCC "sparc_expand" #-}
+                ncgExpandTop ncgImpl branchOpt
+                --ncgExpandTop ncgImpl sequenced
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
+
+        -- generate unwinding information from cmm
+        let unwinds :: BlockMap [UnwindPoint]
+            unwinds =
+                {-# SCC "unwindingInfo" #-}
+                foldl' addUnwind mapEmpty expanded
+              where
+                addUnwind acc proc =
+                    acc `mapUnion` computeUnwinding dflags ncgImpl proc
+
+        return  ( usAlloc
+                , fileIds'
+                , expanded
+                , lastMinuteImports ++ imports
+                , ppr_raStatsColor
+                , ppr_raStatsLinear
+                , unwinds )
+
+-- | Make sure all blocks we want the layout algorithm to place have been placed.
+checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+            -> [NatCmmDecl statics instr]
+checkLayout procsUnsequenced procsSequenced =
+        ASSERT2(setNull diff,
+                ppr "Block sequencing dropped blocks:" <> ppr diff)
+        procsSequenced
+  where
+        blocks1 = foldl' (setUnion) setEmpty $
+                        map getBlockIds procsUnsequenced :: LabelSet
+        blocks2 = foldl' (setUnion) setEmpty $
+                        map getBlockIds procsSequenced
+        diff = setDifference blocks1 blocks2
+
+        getBlockIds (CmmData _ _) = setEmpty
+        getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =
+                setFromList $ map blockId blocks
+
+-- | Compute unwinding tables for the blocks of a procedure
+computeUnwinding :: Instruction instr
+                 => DynFlags -> NcgImpl statics instr jumpDest
+                 -> NatCmmDecl statics instr
+                    -- ^ the native code generated for the procedure
+                 -> LabelMap [UnwindPoint]
+                    -- ^ unwinding tables for all points of all blocks of the
+                    -- procedure
+computeUnwinding dflags _ _
+  | debugLevel dflags == 0         = mapEmpty
+computeUnwinding _ _ (CmmData _ _) = mapEmpty
+computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
+    -- In general we would need to push unwinding information down the
+    -- block-level call-graph to ensure that we fully account for all
+    -- relevant register writes within a procedure.
+    --
+    -- However, the only unwinding information that we care about in GHC is for
+    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind
+    -- information at the beginning of every block means that there is no need
+    -- to perform this sort of push-down.
+    mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
+                | BasicBlock blk_lbl instrs <- blks ]
+
+-- | Build a doc for all the imports.
+--
+makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
+makeImportsDoc dflags imports
+ = dyld_stubs imports
+            $$
+            -- On recent versions of Darwin, the linker supports
+            -- dead-stripping of code and data on a per-symbol basis.
+            -- There's a hack to make this work in PprMach.pprNatCmmDecl.
+            (if platformHasSubsectionsViaSymbols platform
+             then text ".subsections_via_symbols"
+             else Outputable.empty)
+            $$
+                -- On recent GNU ELF systems one can mark an object file
+                -- as not requiring an executable stack. If all objects
+                -- linked into a program have this note then the program
+                -- will not use an executable stack, which is good for
+                -- security. GHC generated code does not need an executable
+                -- stack so add the note in:
+            (if platformHasGnuNonexecStack platform
+             then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"
+             else Outputable.empty)
+            $$
+                -- And just because every other compiler does, let's stick in
+                -- an identifier directive: .ident "GHC x.y.z"
+            (if platformHasIdentDirective platform
+             then let compilerIdent = text "GHC" <+> text cProjectVersion
+                   in text ".ident" <+> doubleQuotes compilerIdent
+             else Outputable.empty)
+
+ where
+        platform = targetPlatform dflags
+        arch = platformArch platform
+        os   = platformOS   platform
+
+        -- Generate "symbol stubs" for all external symbols that might
+        -- come from a dynamic library.
+        dyld_stubs :: [CLabel] -> SDoc
+{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
+                                    map head $ group $ sort imps-}
+        -- (Hack) sometimes two Labels pretty-print the same, but have
+        -- different uniques; so we compare their text versions...
+        dyld_stubs imps
+                | needImportedSymbols dflags arch os
+                = vcat $
+                        (pprGotDeclaration dflags arch os :) $
+                        map ( pprImportedSymbol dflags platform . fst . head) $
+                        groupBy (\(_,a) (_,b) -> a == b) $
+                        sortBy (\(_,a) (_,b) -> compare a b) $
+                        map doPpr $
+                        imps
+                | otherwise
+                = Outputable.empty
+
+        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle)
+        astyle = mkCodeStyle AsmStyle
+
+-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+        :: NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+generateJumpTables ncgImpl xs = concatMap f xs
+    where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
+          f p = [p]
+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
+
+-- -----------------------------------------------------------------------------
+-- Shortcut branches
+
+shortcutBranches
+        :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags
+        -> NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr]
+        -> CFG
+        -> ([NatCmmDecl statics instr],CFG)
+
+shortcutBranches dflags ncgImpl tops weights
+  | gopt Opt_AsmShortcutting dflags
+  = ( map (apply_mapping ncgImpl mapping) tops'
+    , shortcutWeightMap weights mappingBid )
+  | otherwise
+  = (tops, weights)
+  where
+    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
+    mapping = mapUnions mappings :: LabelMap jumpDest
+    mappingBid = fmap (getJumpDestBlockId ncgImpl) mapping
+
+build_mapping :: forall instr t d statics jumpDest.
+                 NcgImpl statics instr jumpDest
+              -> GenCmmDecl d (LabelMap t) (ListGraph instr)
+              -> (GenCmmDecl d (LabelMap t) (ListGraph instr)
+                 ,LabelMap jumpDest)
+build_mapping _ top@(CmmData _ _) = (top, mapEmpty)
+build_mapping _ (CmmProc info lbl live (ListGraph []))
+  = (CmmProc info lbl live (ListGraph []), mapEmpty)
+build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
+  = (CmmProc info lbl live (ListGraph (head:others)), mapping)
+        -- drop the shorted blocks, but don't ever drop the first one,
+        -- because it is pointed to by a global label.
+  where
+    -- find all the blocks that just consist of a jump that can be
+    -- shorted.
+    -- Don't completely eliminate loops here -- that can leave a dangling jump!
+    shortcut_blocks :: [(BlockId, jumpDest)]
+    (_, shortcut_blocks, others) =
+        foldl' split (setEmpty :: LabelSet, [], []) blocks
+    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
+        | Just jd <- canShortcut ncgImpl insn
+        , Just dest <- getJumpDestBlockId ncgImpl jd
+        , not (has_info id)
+        , (setMember dest s) || dest == id -- loop checks
+        = (s, shortcut_blocks, b : others)
+    split (s, shortcut_blocks, others) (BasicBlock id [insn])
+        | Just dest <- canShortcut ncgImpl insn
+        , not (has_info id)
+        = (setInsert id s, (id,dest) : shortcut_blocks, others)
+    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
+
+    -- do not eliminate blocks that have an info table
+    has_info l = mapMember l info
+
+    -- build a mapping from BlockId to JumpDest for shorting branches
+    mapping = mapFromList shortcut_blocks
+
+apply_mapping :: NcgImpl statics instr jumpDest
+              -> LabelMap jumpDest
+              -> GenCmmDecl statics h (ListGraph instr)
+              -> GenCmmDecl statics h (ListGraph instr)
+apply_mapping ncgImpl ufm (CmmData sec statics)
+  = CmmData sec (shortcutStatics ncgImpl (\bid -> mapLookup bid ufm) statics)
+apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
+  = CmmProc info lbl live (ListGraph $ map short_bb blocks)
+  where
+    short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
+    short_insn i = shortcutJump ncgImpl (\bid -> mapLookup bid ufm) i
+                 -- shortcutJump should apply the mapping repeatedly,
+                 -- just in case we can short multiple branches.
+
+-- -----------------------------------------------------------------------------
+-- Instruction selection
+
+-- Native code instruction selection for a chunk of stix code.  For
+-- this part of the computation, we switch from the UniqSM monad to
+-- the NatM monad.  The latter carries not only a Unique, but also an
+-- Int denoting the current C stack pointer offset in the generated
+-- code; this is needed for creating correct spill offsets on
+-- architectures which don't offer, or for which it would be
+-- prohibitively expensive to employ, a frame pointer register.  Viz,
+-- x86.
+
+-- The offset is measured in bytes, and indicates the difference
+-- between the current (simulated) C stack-ptr and the value it was at
+-- the beginning of the block.  For stacks which grow down, this value
+-- should be either zero or negative.
+
+-- Along with the stack pointer offset, we also carry along a LabelMap of
+-- DebugBlocks, which we read to generate .location directives.
+--
+-- Switching between the two monads whilst carrying along the same
+-- Unique supply breaks abstraction.  Is that bad?
+
+genMachCode
+        :: DynFlags
+        -> Module -> ModLocation
+        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
+        -> DwarfFiles
+        -> LabelMap DebugBlock
+        -> RawCmmDecl
+        -> CFG
+        -> UniqSM
+                ( [NatCmmDecl statics instr]
+                , [CLabel]
+                , DwarfFiles
+                , CFG
+                )
+
+genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
+  = do  { initial_us <- getUniqueSupplyM
+        ; let initial_st           = mkNatM_State initial_us 0 dflags this_mod
+                                                  modLoc fileIds dbgMap cmm_cfg
+              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+              final_delta          = natm_delta final_st
+              final_imports        = natm_imports final_st
+              final_cfg            = natm_cfg final_st
+        ; if   final_delta == 0
+          then return (new_tops, final_imports
+                      , natm_fileid final_st, final_cfg)
+          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
+    }
+
+-- -----------------------------------------------------------------------------
+-- Generic Cmm optimiser
+
+{-
+Here we do:
+
+  (a) Constant folding
+  (c) Position independent code and dynamic linking
+        (i)  introduce the appropriate indirections
+             and position independent refs
+        (ii) compile a list of imported symbols
+  (d) Some arch-specific optimizations
+
+(a) will be moving to the new Hoopl pipeline, however, (c) and
+(d) are only needed by the native backend and will continue to live
+here.
+
+Ideas for other things we could do (put these in Hoopl please!):
+
+  - shortcut jumps-to-jumps
+  - simple CSE: if an expr is assigned to a temp, then replace later occs of
+    that expr with the temp, until the expr is no longer valid (can push through
+    temp assignments, and certain assigns to mem...)
+-}
+
+cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
+cmmToCmm _ _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags this_mod (CmmProc info lbl live graph)
+    = runCmmOpt dflags this_mod $
+      do blocks' <- mapM cmmBlockConFold (toBlockList graph)
+         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
+
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type OptMResult a = (# a, [CLabel] #)
+
+pattern OptMResult :: a -> b -> (# a, b #)
+pattern OptMResult x y = (# x, y #)
+{-# COMPLETE OptMResult #-}
+#else
+
+data OptMResult a = OptMResult !a ![CLabel]
+#endif
+
+newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)
+
+instance Functor CmmOptM where
+    fmap = liftM
+
+instance Applicative CmmOptM where
+    pure x = CmmOptM $ \_ _ imports -> OptMResult x imports
+    (<*>) = ap
+
+instance Monad CmmOptM where
+  (CmmOptM f) >>= g =
+    CmmOptM $ \dflags this_mod imports0 ->
+                case f dflags this_mod imports0 of
+                  OptMResult x imports1 ->
+                    case g x of
+                      CmmOptM g' -> g' dflags this_mod imports1
+
+instance CmmMakeDynamicReferenceM CmmOptM where
+    addImport = addImportCmmOpt
+    getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports
+
+addImportCmmOpt :: CLabel -> CmmOptM ()
+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)
+
+instance HasDynFlags CmmOptM where
+    getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports
+
+runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags this_mod (CmmOptM f) =
+  case f dflags this_mod [] of
+    OptMResult result imports -> (result, imports)
+
+cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
+cmmBlockConFold block = do
+  let (entry, middle, last) = blockSplit block
+      stmts = blockToList middle
+  stmts' <- mapM cmmStmtConFold stmts
+  last' <- cmmStmtConFold last
+  return $ blockJoin entry (blockFromList stmts') last'
+
+-- This does three optimizations, but they're very quick to check, so we don't
+-- bother turning them off even when the Hoopl code is active.  Since
+-- this is on the old Cmm representation, we can't reuse the code either:
+--  * reg = reg      --> nop
+--  * if 0 then jump --> nop
+--  * if 1 then jump --> jump
+-- We might be tempted to skip this step entirely of not Opt_PIC, but
+-- there is some PowerPC code for the non-PIC case, which would also
+-- have to be separated.
+cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
+cmmStmtConFold stmt
+   = case stmt of
+        CmmAssign reg src
+           -> do src' <- cmmExprConFold DataReference src
+                 return $ case src' of
+                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
+                   new_src -> CmmAssign reg new_src
+
+        CmmStore addr src
+           -> do addr' <- cmmExprConFold DataReference addr
+                 src'  <- cmmExprConFold DataReference src
+                 return $ CmmStore addr' src'
+
+        CmmCall { cml_target = addr }
+           -> do addr' <- cmmExprConFold JumpReference addr
+                 return $ stmt { cml_target = addr' }
+
+        CmmUnsafeForeignCall target regs args
+           -> do target' <- case target of
+                              ForeignTarget e conv -> do
+                                e' <- cmmExprConFold CallReference e
+                                return $ ForeignTarget e' conv
+                              PrimTarget _ ->
+                                return target
+                 args' <- mapM (cmmExprConFold DataReference) args
+                 return $ CmmUnsafeForeignCall target' regs args'
+
+        CmmCondBranch test true false likely
+           -> do test' <- cmmExprConFold DataReference test
+                 return $ case test' of
+                   CmmLit (CmmInt 0 _) -> CmmBranch false
+                   CmmLit (CmmInt _ _) -> CmmBranch true
+                   _other -> CmmCondBranch test' true false likely
+
+        CmmSwitch expr ids
+           -> do expr' <- cmmExprConFold DataReference expr
+                 return $ CmmSwitch expr' ids
+
+        other
+           -> return other
+
+cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
+cmmExprConFold referenceKind expr = do
+    dflags <- getDynFlags
+
+    -- With -O1 and greater, the cmmSink pass does constant-folding, so
+    -- we don't need to do it again here.
+    let expr' = if optLevel dflags >= 1
+                    then expr
+                    else cmmExprCon dflags expr
+
+    cmmExprNative referenceKind expr'
+
+cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
+cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
+cmmExprCon dflags (CmmMachOp mop args)
+    = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
+cmmExprCon _ other = other
+
+-- handles both PIC and non-PIC cases... a very strange mixture
+-- of things to do.
+cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
+cmmExprNative referenceKind expr = do
+     dflags <- getDynFlags
+     let platform = targetPlatform dflags
+         arch = platformArch platform
+     case expr of
+        CmmLoad addr rep
+           -> do addr' <- cmmExprNative DataReference addr
+                 return $ CmmLoad addr' rep
+
+        CmmMachOp mop args
+           -> do args' <- mapM (cmmExprNative DataReference) args
+                 return $ CmmMachOp mop args'
+
+        CmmLit (CmmBlock id)
+           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
+           -- we must convert block Ids to CLabels here, because we
+           -- might have to do the PIC transformation.  Hence we must
+           -- not modify BlockIds beyond this point.
+
+        CmmLit (CmmLabel lbl)
+           -> do
+                cmmMakeDynamicReference dflags referenceKind lbl
+        CmmLit (CmmLabelOff lbl off)
+           -> do
+                 dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
+                 -- need to optimize here, since it's late
+                 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
+                     dynRef,
+                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
+                   ]
+
+        -- On powerpc (non-PIC), it's easier to jump directly to a label than
+        -- to use the register table, so we replace these registers
+        -- with the corresponding labels:
+        CmmReg (CmmGlobal EagerBlackholeInfo)
+          | arch == ArchPPC && not (positionIndependent dflags)
+          -> cmmExprNative referenceKind $
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
+        CmmReg (CmmGlobal GCEnter1)
+          | arch == ArchPPC && not (positionIndependent dflags)
+          -> cmmExprNative referenceKind $
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
+        CmmReg (CmmGlobal GCFun)
+          | arch == ArchPPC && not (positionIndependent dflags)
+          -> cmmExprNative referenceKind $
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
+
+        other
+           -> return other
diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -0,0 +1,758 @@
+--
+-- Copyright (c) 2018 Andreas Klebinger
+--
+
+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}
+
+{-# OPTIONS_GHC -fprof-auto #-}
+--{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}
+
+module BlockLayout
+    ( sequenceTop )
+where
+
+#include "HsVersions.h"
+import GhcPrelude
+
+import Instruction
+import NCGMonad
+import CFG
+
+import BlockId
+import Cmm
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
+
+import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)
+import UniqFM
+import Util
+import Unique
+
+import Digraph
+import Outputable
+import Maybes
+
+-- DEBUGGING ONLY
+--import Debug
+--import Debug.Trace
+import ListSetOps (removeDups)
+import PprCmm ()
+
+import OrdList
+import Data.List
+import Data.Foldable (toList)
+import Hoopl.Graph
+
+import qualified Data.Set as Set
+
+{-
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ~~~ Note [Chain based CFG serialization]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  For additional information also look at
+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout
+
+  We have a CFG with edge weights based on which we try to place blocks next to
+  each other.
+
+  Edge weights not only represent likelyhood of control transfer between blocks
+  but also how much a block would benefit from being placed sequentially after
+  it's predecessor.
+  For example blocks which are preceeded by an info table are more likely to end
+  up in a different cache line than their predecessor. So there is less benefit
+  in placing them sequentially.
+
+  For example consider this example:
+
+  A:  ...
+      jmp cond D (weak successor)
+      jmp B
+  B:  ...
+      jmp C
+  C:  ...
+      jmp X
+  D:  ...
+      jmp B (weak successor)
+
+  We determine a block layout by building up chunks (calling them chains) of
+  possible control flows for which blocks will be placed sequentially.
+
+  Eg for our example we might end up with two chains like:
+  [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially.
+  However there is no particular order in which chains are placed since
+  (hopefully) the blocks for which sequentially is important have already
+  been placed in the same chain.
+
+  -----------------------------------------------------------------------------
+      First try to create a lists of good chains.
+  -----------------------------------------------------------------------------
+
+  We do so by taking a block not yet placed in a chain and
+  looking at these cases:
+
+  *)  Check if the best predecessor of the block is at the end of a chain.
+      If so add the current block to the end of that chain.
+
+      Eg if we look at block C and already have the chain (A -> B)
+      then we extend the chain to (A -> B -> C).
+
+      Combined with the fact that we process blocks in reverse post order
+      this means loop bodies and trivially sequential control flow already
+      ends up as a single chain.
+
+  *)  Otherwise we create a singleton chain from the block we are looking at.
+      Eg if we have from the example above already constructed (A->B)
+      and look at D we create the chain (D) resulting in the chains [A->B, D]
+
+  -----------------------------------------------------------------------------
+      We then try to fuse chains.
+  -----------------------------------------------------------------------------
+
+  There are edge cases which result in two chains being created which trivially
+  represent linear control flow. For example we might have the chains
+  [(A-B-C),(D-E)] with an cfg triangle:
+
+      A----->C->D->E
+       \->B-/
+
+  We also get three independent chains if two branches end with a jump
+  to a common successor.
+
+  We take care of these cases by fusing chains which are connected by an
+  edge.
+
+  We do so by looking at the list of edges sorted by weight.
+  Given the edge (C -> D) we try to find two chains such that:
+      * C is at the end of chain one.
+      * D is in front of chain two.
+      * If two such chains exist we fuse them.
+  We then remove the edge and repeat the process for the rest of the edges.
+
+  -----------------------------------------------------------------------------
+      Place indirect successors (neighbours) after each other
+  -----------------------------------------------------------------------------
+
+  We might have chains [A,B,C,X],[E] in a CFG of the sort:
+
+    A ---> B ---> C --------> X(exit)
+                   \- ->E- -/
+
+  While E does not follow X it's still beneficial to place them near each other.
+  This can be advantageous if eg C,X,E will end up in the same cache line.
+
+  TODO: If we remove edges as we use them (eg if we build up A->B remove A->B
+        from the list) we could save some more work in later phases.
+
+
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ~~~ Note [Triangle Control Flow]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  Checking if an argument is already evaluating leads to a somewhat
+  special case  which looks like this:
+
+    A:
+        if (R1 & 7 != 0) goto Leval; else goto Lwork;
+    Leval: // global
+        call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8;
+    Lwork: // global
+        ...
+
+        A
+        |\
+        | Leval
+        |/ - (This edge can be missing because of optimizations)
+        Lwork
+
+  Once we hit the metal the call instruction is just 2-3 bytes large
+  depending on the register used. So we lay out the assembly like this:
+
+        movq %rbx,%rax
+        andl $7,%eax
+        cmpq $1,%rax
+        jne Lwork
+    Leval:
+        jmp *(%rbx) # encoded in 2-3 bytes.
+    <info table>
+    Lwork:
+        ...
+
+  We could explicitly check for this control flow pattern.
+
+  This is advantageous because:
+  * It's optimal if the argument isn't evaluated.
+  * If it's evaluated we only have the extra cost of jumping over
+    the 2-3 bytes for the call.
+  * Guarantees the smaller encoding for the conditional jump.
+
+  However given that Lwork usually has an info table we
+  penalize this edge. So Leval should get placed first
+  either way and things work out for the best.
+
+  Optimizing for the evaluated case instead would penalize
+  the other code path. It adds an jump as we can't fall through
+  to Lwork because of the info table.
+  Assuming that Lwork is large the chance that the "call" ends up
+  in the same cache line is also fairly small.
+
+-}
+
+
+-- | Look at X number of blocks in two chains to determine
+--   if they are "neighbours".
+neighbourOverlapp :: Int
+neighbourOverlapp = 2
+
+-- | Only edges heavier than this are considered
+--   for fusing two chains into a single chain.
+fuseEdgeThreshold :: EdgeWeight
+fuseEdgeThreshold = 0
+
+-- | Maps blocks near the end of a chain to it's chain AND
+-- the other blocks near the end.
+-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E]))
+-- where [A,B] are blocks in the end region of a chain.
+-- This is cheaper then recomputing the ends multiple times.
+type FrontierMap = LabelMap ([BlockId],BlockChain)
+
+-- | A non empty ordered sequence of basic blocks.
+--   It is suitable for serialization in this order.
+--
+--   We use OrdList instead of [] to allow fast append on both sides
+--   when combining chains.
+newtype BlockChain
+    = BlockChain { chainBlocks :: (OrdList BlockId) }
+
+instance Eq (BlockChain) where
+    (BlockChain blks1) == (BlockChain blks2)
+        = fromOL blks1 == fromOL blks2
+
+-- Useful for things like sets and debugging purposes, sorts by blocks
+-- in the chain.
+instance Ord (BlockChain) where
+   (BlockChain lbls1) `compare` (BlockChain lbls2)
+       = (fromOL lbls1) `compare` (fromOL lbls2)
+
+instance Outputable (BlockChain) where
+    ppr (BlockChain blks) =
+        parens (text "Chain:" <+> ppr (fromOL $ blks) )
+
+data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)
+
+
+-- | Non deterministic! (Uniques) Sorts edges by weight and nodes.
+instance Ord WeightedEdge where
+  compare (WeightedEdge from1 to1 weight1)
+          (WeightedEdge from2 to2 weight2)
+    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
+      weight1 == weight2 && from1 == from2 && to1 < to2
+    = LT
+    | from1 == from2 && to1 == to2 && weight1 == weight2
+    = EQ
+    | otherwise
+    = GT
+
+instance Outputable WeightedEdge where
+    ppr (WeightedEdge from to info) =
+        ppr from <> text "->" <> ppr to <> brackets (ppr info)
+
+type WeightedEdgeList = [WeightedEdge]
+
+noDups :: [BlockChain] -> Bool
+noDups chains =
+    let chainBlocks = concatMap chainToBlocks chains :: [BlockId]
+        (_blocks, dups) = removeDups compare chainBlocks
+    in if null dups then True
+        else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False
+
+inFront :: BlockId -> BlockChain -> Bool
+inFront bid (BlockChain seq)
+  = headOL seq == bid
+
+chainMember :: BlockId -> BlockChain -> Bool
+chainMember bid chain
+  = elem bid $ fromOL . chainBlocks $ chain
+--   = setMember bid . chainMembers $ chain
+
+chainSingleton :: BlockId -> BlockChain
+chainSingleton lbl
+    = BlockChain (unitOL lbl)
+
+chainSnoc :: BlockChain -> BlockId -> BlockChain
+chainSnoc (BlockChain blks) lbl
+  = BlockChain (blks `snocOL` lbl)
+
+chainConcat :: BlockChain -> BlockChain -> BlockChain
+chainConcat (BlockChain blks1) (BlockChain blks2)
+  = BlockChain (blks1 `appOL` blks2)
+
+chainToBlocks :: BlockChain -> [BlockId]
+chainToBlocks (BlockChain blks) = fromOL blks
+
+-- | Given the Chain A -> B -> C -> D and we break at C
+--   we get the two Chains (A -> B, C -> D) as result.
+breakChainAt :: BlockId -> BlockChain
+             -> (BlockChain,BlockChain)
+breakChainAt bid (BlockChain blks)
+    | not (bid == head rblks)
+    = panic "Block not in chain"
+    | otherwise
+    = (BlockChain (toOL lblks),
+       BlockChain (toOL rblks))
+  where
+    (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks)
+
+takeR :: Int -> BlockChain -> [BlockId]
+takeR n (BlockChain blks) =
+    take n . fromOLReverse $ blks
+
+takeL :: Int -> BlockChain -> [BlockId]
+takeL n (BlockChain blks) =
+    take n . fromOL $ blks
+
+-- | For a given list of chains try to fuse chains with strong
+--   edges between them into a single chain.
+--   Returns the list of fused chains together with a set of
+--   used edges. The set of edges is indirectly encoded in the
+--   chains so doesn't need to be considered for later passes.
+fuseChains :: WeightedEdgeList -> LabelMap BlockChain
+           -> (LabelMap BlockChain, Set.Set WeightedEdge)
+fuseChains weights chains
+    = let fronts = mapFromList $
+                    map (\chain -> (headOL . chainBlocks $ chain,chain)) $
+                    mapElems chains :: LabelMap BlockChain
+          (chains', used, _) = applyEdges weights chains fronts Set.empty
+      in (chains', used)
+    where
+        applyEdges :: WeightedEdgeList -> LabelMap BlockChain
+                   -> LabelMap BlockChain -> Set.Set WeightedEdge
+                   -> (LabelMap BlockChain, Set.Set WeightedEdge, LabelMap BlockChain)
+        applyEdges [] chainsEnd chainsFront used
+            = (chainsEnd, used, chainsFront)
+        applyEdges (edge@(WeightedEdge from to w):edges) chainsEnd chainsFront used
+            --Since we order edges descending by weight we can stop here
+            | w <= fuseEdgeThreshold
+            = ( chainsEnd, used, chainsFront)
+            --Fuse the two chains
+            | Just c1 <- mapLookup from chainsEnd
+            , Just c2 <- mapLookup to chainsFront
+            , c1 /= c2
+            = let newChain = chainConcat c1 c2
+                  front = headOL . chainBlocks $ newChain
+                  end = lastOL . chainBlocks $ newChain
+                  chainsFront' = mapInsert front newChain $
+                                 mapDelete to chainsFront
+                  chainsEnd'   = mapInsert end newChain $
+                                 mapDelete from chainsEnd
+              in applyEdges edges chainsEnd' chainsFront'
+                            (Set.insert edge used)
+            | otherwise
+            --Check next edge
+            = applyEdges edges chainsEnd chainsFront used
+
+
+-- See also Note [Chain based CFG serialization]
+-- We have the chains (A-B-C-D) and (E-F) and an Edge C->E.
+--
+-- While placing the later after the former doesn't result in sequential
+-- control flow it is still be benefical since block C and E might end
+-- up in the same cache line.
+--
+-- So we place these chains next to each other even if we can't fuse them.
+--
+--   A -> B -> C -> D
+--             v
+--             - -> E -> F ...
+--
+-- Simple heuristic to chose which chains we want to combine:
+--   * Process edges in descending priority.
+--   * Check if there is a edge near the end of one chain which goes
+--     to a block near the start of another edge.
+--
+-- While we could take into account the space between the two blocks which
+-- share an edge this blows up compile times quite a bit. It requires
+-- us to find all edges between two chains, check the distance for all edges,
+-- rank them based on the distance and and only then we can select two chains
+-- to combine. Which would add a lot of complexity for little gain.
+
+-- | For a given list of chains and edges try to combine chains with strong
+--   edges between them.
+combineNeighbourhood :: WeightedEdgeList -> [BlockChain]
+                     -> [BlockChain]
+combineNeighbourhood edges chains
+    = -- pprTraceIt "Neigbours" $
+      applyEdges edges endFrontier startFrontier
+    where
+        --Build maps from chain ends to chains
+        endFrontier, startFrontier :: FrontierMap
+        endFrontier =
+            mapFromList $ concatMap (\chain ->
+                                let ends = getEnds chain :: [BlockId]
+                                    entry = (ends,chain)
+                                in map (\x -> (x,entry)) ends ) chains
+        startFrontier =
+            mapFromList $ concatMap (\chain ->
+                                let front = getFronts chain
+                                    entry = (front,chain)
+                                in map (\x -> (x,entry)) front) chains
+        applyEdges :: WeightedEdgeList -> FrontierMap -> FrontierMap
+                   -> [BlockChain]
+        applyEdges [] chainEnds _chainFronts =
+            ordNub $ map snd $ mapElems chainEnds
+        applyEdges ((WeightedEdge from to _w):edges) chainEnds chainFronts
+            | Just (c1_e,c1) <- mapLookup from chainEnds
+            , Just (c2_f,c2) <- mapLookup to chainFronts
+            , c1 /= c2 -- Avoid trying to concat a short chain with itself.
+            = let newChain = chainConcat c1 c2
+                  newChainFrontier = getFronts newChain
+                  newChainEnds = getEnds newChain
+                  newFronts :: FrontierMap
+                  newFronts =
+                    let withoutOld =
+                            foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1)
+                        entry =
+                            (newChainFrontier,newChain) --let bound to ensure sharing
+                    in foldl' (\m x -> mapInsert x entry m)
+                              withoutOld newChainFrontier
+
+                  newEnds =
+                    let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2)
+                        entry = (newChainEnds,newChain) --let bound to ensure sharing
+                    in foldl' (\m x -> mapInsert x entry m)
+                              withoutOld newChainEnds
+              in
+                -- pprTrace "ApplyEdges"
+                --  (text "before" $$
+                --   text "fronts" <+> ppr chainFronts $$
+                --   text "ends" <+> ppr chainEnds $$
+
+                --   text "various" $$
+                --   text "newChain" <+> ppr newChain $$
+                --   text "newChainFrontier" <+> ppr newChainFrontier $$
+                --   text "newChainEnds" <+> ppr newChainEnds $$
+                --   text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$
+
+                --   text "after" $$
+                --   text "fronts" <+> ppr newFronts $$
+                --   text "ends" <+> ppr newEnds
+                --   )
+                 applyEdges edges newEnds newFronts
+            | otherwise
+            = --pprTrace "noNeigbours" (ppr ()) $
+              applyEdges edges chainEnds chainFronts
+         where
+
+        getFronts chain = takeL neighbourOverlapp chain
+        getEnds chain = takeR neighbourOverlapp chain
+
+
+
+-- See [Chain based CFG serialization]
+buildChains :: CFG -> [BlockId]
+            -> ( LabelMap BlockChain  -- Resulting chains.
+               , Set.Set (BlockId, BlockId)) --List of fused edges.
+buildChains succWeights blocks
+  = let (_, fusedEdges, chains) = buildNext setEmpty mapEmpty blocks Set.empty
+    in (chains, fusedEdges)
+  where
+    -- We keep a map from the last block in a chain to the chain itself.
+    -- This we we can easily check if an block should be appened to an
+    -- existing chain!
+    buildNext :: LabelSet
+              -> LabelMap BlockChain -- Map from last element to chain.
+              -> [BlockId] -- Blocks to place
+              -> Set.Set (BlockId, BlockId)
+              -> ( [BlockChain]  -- Placed Blocks
+                 , Set.Set (BlockId, BlockId) --List of fused edges
+                 , LabelMap BlockChain
+                 )
+    buildNext _placed chains [] linked =
+        ([], linked, chains)
+    buildNext placed chains (block:todo) linked
+        | setMember block placed
+        = buildNext placed chains todo linked
+        | otherwise
+        = buildNext placed' chains' todo linked'
+      where
+        placed' = (foldl' (flip setInsert) placed placedBlocks)
+        linked' = Set.union linked linkedEdges
+        (placedBlocks, chains', linkedEdges) = findChain block
+
+        --Add the block to a existing or new chain
+        --Returns placed blocks, list of resulting chains
+        --and fused edges
+        findChain :: BlockId
+                -> ([BlockId],LabelMap BlockChain, Set.Set (BlockId, BlockId))
+        findChain block
+        -- B) place block at end of existing chain if
+        -- there is no better block to append.
+          | (pred:_) <- preds
+          , alreadyPlaced pred
+          , Just predChain <- mapLookup pred chains
+          , (best:_) <- filter (not . alreadyPlaced) $ getSuccs pred
+          , best == lbl
+          = --pprTrace "B.2)" (ppr (pred,lbl)) $
+            let newChain = chainSnoc predChain block
+                chainMap = mapInsert lbl newChain $ mapDelete pred chains
+            in  ( [lbl]
+                , chainMap
+                , Set.singleton (pred,lbl) )
+
+          | otherwise
+          = --pprTrace "single" (ppr lbl)
+            ( [lbl]
+            , mapInsert lbl (chainSingleton lbl) chains
+            , Set.empty)
+            where
+              alreadyPlaced blkId = (setMember blkId placed)
+              lbl = block
+              getSuccs = map fst . getSuccEdgesSorted succWeights
+              preds = map fst $ getSuccEdgesSorted predWeights lbl
+    --For efficiency we also create the map to look up predecessors here
+    predWeights = reverseEdges succWeights
+
+
+
+-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
+newtype BlockNode e x = BN (BlockId,[BlockId])
+instance NonLocal (BlockNode) where
+  entryLabel (BN (lbl,_))   = lbl
+  successors (BN (_,succs)) = succs
+
+fromNode :: BlockNode C C -> BlockId
+fromNode (BN x) = fst x
+
+sequenceChain :: forall a i. (Instruction i, Outputable i) => LabelMap a -> CFG
+            -> [GenBasicBlock i] -> [GenBasicBlock i]
+sequenceChain _info _weights    [] = []
+sequenceChain _info _weights    [x] = [x]
+sequenceChain  info weights'     blocks@((BasicBlock entry _):_) =
+    --Optimization, delete edges of weight <= 0.
+    --This significantly improves performance whenever
+    --we iterate over all edges, which is a few times!
+    let weights :: CFG
+        weights
+            = filterEdges (\_f _t edgeInfo -> edgeWeight edgeInfo > 0) weights'
+        blockMap :: LabelMap (GenBasicBlock i)
+        blockMap
+            = foldl' (\m blk@(BasicBlock lbl _ins) ->
+                        mapInsert lbl blk m)
+                     mapEmpty blocks
+
+        toNode :: BlockId -> BlockNode C C
+        toNode bid =
+            -- sorted such that heavier successors come first.
+            BN (bid,map fst . getSuccEdgesSorted weights' $ bid)
+
+        orderedBlocks :: [BlockId]
+        orderedBlocks
+            = map fromNode $
+              revPostorderFrom (fmap (toNode . blockId) blockMap) entry
+
+        (builtChains, builtEdges)
+            = {-# SCC "buildChains" #-}
+              --pprTraceIt "generatedChains" $
+              --pprTrace "orderedBlocks" (ppr orderedBlocks) $
+              buildChains weights orderedBlocks
+
+        rankedEdges :: WeightedEdgeList
+        -- Sort edges descending, remove fused eges
+        rankedEdges =
+            map (\(from, to, weight) -> WeightedEdge from to weight) .
+            filter (\(from, to, _)
+                        -> not (Set.member (from,to) builtEdges)) .
+            sortWith (\(_,_,w) -> - w) $ weightedEdgeList weights
+
+        (fusedChains, fusedEdges)
+            = ASSERT(noDups $ mapElems builtChains)
+              {-# SCC "fuseChains" #-}
+              --(pprTrace "RankedEdges" $ ppr rankedEdges) $
+              --pprTraceIt "FusedChains" $
+              fuseChains rankedEdges builtChains
+
+        rankedEdges' =
+            filter (\edge -> not $ Set.member edge fusedEdges) $ rankedEdges
+
+        neighbourChains
+            = ASSERT(noDups $ mapElems fusedChains)
+              {-# SCC "groupNeighbourChains" #-}
+              --pprTraceIt "ResultChains" $
+              combineNeighbourhood rankedEdges' (mapElems fusedChains)
+
+        --Make sure the first block stays first
+        ([entryChain],chains')
+            = ASSERT(noDups $ neighbourChains)
+              partition (chainMember entry) neighbourChains
+        (entryChain':entryRest)
+            | inFront entry entryChain = [entryChain]
+            | (rest,entry) <- breakChainAt entry entryChain
+            = [entry,rest]
+            | otherwise = pprPanic "Entry point eliminated" $
+                            ppr ([entryChain],chains')
+
+        prepedChains
+            = entryChain':(entryRest++chains') :: [BlockChain]
+        blockList
+            -- = (concatMap chainToBlocks prepedChains)
+            = (concatMap fromOL $ map chainBlocks prepedChains)
+
+        --chainPlaced = setFromList $ map blockId blockList :: LabelSet
+        chainPlaced = setFromList $ blockList :: LabelSet
+        unplaced =
+            let blocks = mapKeys blockMap
+                isPlaced b = setMember (b) chainPlaced
+            in filter (\block -> not (isPlaced block)) blocks
+
+        placedBlocks =
+            --pprTraceIt "placedBlocks" $
+            blockList ++ unplaced
+        getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap
+    in
+        --Assert we placed all blocks given as input
+        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
+        dropJumps info $ map getBlock placedBlocks
+
+dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
+          -> [GenBasicBlock i]
+dropJumps _    [] = []
+dropJumps info ((BasicBlock lbl ins):todo)
+    | not . null $ ins --This can happen because of shortcutting
+    , [dest] <- jumpDestsOfInstr (last ins)
+    , ((BasicBlock nextLbl _) : _) <- todo
+    , not (mapMember dest info)
+    , nextLbl == dest
+    = BasicBlock lbl (init ins) : dropJumps info todo
+    | otherwise
+    = BasicBlock lbl ins : dropJumps info todo
+
+
+-- -----------------------------------------------------------------------------
+-- Sequencing the basic blocks
+
+-- Cmm BasicBlocks are self-contained entities: they always end in a
+-- jump, either non-local or to another basic block in the same proc.
+-- In this phase, we attempt to place the basic blocks in a sequence
+-- such that as many of the local jumps as possible turn into
+-- fallthroughs.
+
+sequenceTop
+    :: (Instruction instr, Outputable instr)
+    => DynFlags --Use new layout code
+    -> NcgImpl statics instr jumpDest -> CFG
+    -> NatCmmDecl statics instr -> NatCmmDecl statics instr
+
+sequenceTop _     _       _           top@(CmmData _ _) = top
+sequenceTop dflags ncgImpl edgeWeights
+            (CmmProc info lbl live (ListGraph blocks))
+  | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags
+  --Use chain based algorithm
+  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
+                            sequenceChain info edgeWeights blocks )
+  | otherwise
+  --Use old algorithm
+  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
+                            sequenceBlocks cfg info blocks)
+  where
+    cfg
+      | (gopt Opt_WeightlessBlocklayout dflags) ||
+        (not $ backendMaintainsCfg dflags)
+      -- Don't make use of cfg in the old algorithm
+      = Nothing
+      -- Use cfg in the old algorithm
+      | otherwise = Just edgeWeights
+
+-- The old algorithm:
+-- It is very simple (and stupid): We make a graph out of
+-- the blocks where there is an edge from one block to another iff the
+-- first block ends by jumping to the second.  Then we topologically
+-- sort this graph.  Then traverse the list: for each block, we first
+-- output the block, then if it has an out edge, we move the
+-- destination of the out edge to the front of the list, and continue.
+
+-- FYI, the classic layout for basic blocks uses postorder DFS; this
+-- algorithm is implemented in Hoopl.
+
+sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a
+               -> [GenBasicBlock inst] -> [GenBasicBlock inst]
+sequenceBlocks _edgeWeight _ [] = []
+sequenceBlocks edgeWeights infos (entry:blocks) =
+    let entryNode = mkNode edgeWeights entry
+        bodyNodes = reverse
+                    (flattenSCCs (sccBlocks edgeWeights blocks))
+    in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes)
+  -- the first block is the entry point ==> it must remain at the start.
+
+sccBlocks
+        :: Instruction instr
+        => Maybe CFG -> [NatBasicBlock instr]
+        -> [SCC (Node BlockId (NatBasicBlock instr))]
+sccBlocks edgeWeights blocks =
+    stronglyConnCompFromEdgedVerticesUniqR
+        (map (mkNode edgeWeights) blocks)
+
+mkNode :: (Instruction t)
+       => Maybe CFG -> GenBasicBlock t
+       -> Node BlockId (GenBasicBlock t)
+mkNode edgeWeights block@(BasicBlock id instrs) =
+    DigraphNode block id outEdges
+  where
+    outEdges :: [BlockId]
+    outEdges
+      --Select the heaviest successor, ignore weights <= zero
+      = successor
+      where
+        successor
+          | Just successors <- fmap (`getSuccEdgesSorted` id)
+                                    edgeWeights -- :: Maybe [(Label, EdgeInfo)]
+          = case successors of
+            [] -> []
+            ((target,info):_)
+              | length successors > 2 || edgeWeight info <= 0 -> []
+              | otherwise -> [target]
+          | otherwise
+          = case jumpDestsOfInstr (last instrs) of
+                [one] -> [one]
+                _many -> []
+
+
+seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
+                        -> [GenBasicBlock t1]
+seqBlocks infos blocks = placeNext pullable0 todo0
+  where
+    -- pullable: Blocks that are not yet placed
+    -- todo:     Original order of blocks, to be followed if we have no good
+    --           reason not to;
+    --           may include blocks that have already been placed, but then
+    --           these are not in pullable
+    pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
+    todo0     = map node_key blocks
+
+    placeNext _ [] = []
+    placeNext pullable (i:rest)
+        | Just (block, pullable') <- lookupDeleteUFM pullable i
+        = place pullable' rest block
+        | otherwise
+        -- We already placed this block, so ignore
+        = placeNext pullable rest
+
+    place pullable todo (block,[])
+                          = block : placeNext pullable todo
+    place pullable todo (block@(BasicBlock id instrs),[next])
+        | mapMember next infos
+        = block : placeNext pullable todo
+        | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
+        = BasicBlock id instrs : place pullable' todo nextBlock
+        | otherwise
+        = block : placeNext pullable todo
+    place _ _ (_,tooManyNextNodes)
+        = pprPanic "seqBlocks" (ppr tooManyNextNodes)
+
+
+lookupDeleteUFM :: Uniquable key => UniqFM elt -> key
+                -> Maybe (elt, UniqFM elt)
+lookupDeleteUFM m k = do -- Maybe monad
+    v <- lookupUFM m k
+    return (v, delFromUFM m k)
+
diff --git a/compiler/nativeGen/CFG.hs b/compiler/nativeGen/CFG.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/CFG.hs
@@ -0,0 +1,651 @@
+--
+-- Copyright (c) 2018 Andreas Klebinger
+--
+
+{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+
+module CFG
+    ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
+    , TransitionSource(..)
+
+    --Modify the CFG
+    , addWeightEdge, addEdge, delEdge
+    , addNodesBetween, shortcutWeightMap
+    , reverseEdges, filterEdges
+    , addImmediateSuccessor
+    , mkWeightInfo, adjustEdgeWeight
+
+    --Query the CFG
+    , infoEdgeList, edgeList
+    , getSuccessorEdges, getSuccessors
+    , getSuccEdgesSorted, weightedEdgeList
+    , getEdgeInfo
+    , getCfgNodes, hasNode
+    , loopMembers
+
+    --Construction/Misc
+    , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
+
+    --Find backedges and update their weight
+    , optimizeCFG )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BlockId
+import Cmm ( RawCmmDecl, GenCmmDecl( .. ), CmmBlock, succ, g_entry
+           , CmmGraph )
+import CmmNode
+import CmmUtils
+import CmmSwitch
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
+import qualified Hoopl.Graph as G
+
+import Util
+import Digraph
+
+import Outputable
+-- DEBUGGING ONLY
+--import Debug
+--import OrdList
+--import Debug.Trace
+import PprCmm ()
+import qualified DynFlags as D
+
+import Data.List
+
+-- import qualified Data.IntMap.Strict as M --TODO: LabelMap
+
+type Edge = (BlockId, BlockId)
+type Edges = [Edge]
+
+newtype EdgeWeight
+  = EdgeWeight Int
+  deriving (Eq,Ord,Enum,Num,Real,Integral)
+
+instance Outputable EdgeWeight where
+  ppr (EdgeWeight w) = ppr w
+
+type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)
+
+-- | A control flow graph where edges have been annotated with a weight.
+type CFG = EdgeInfoMap EdgeInfo
+
+data CfgEdge
+  = CfgEdge
+  { edgeFrom :: !BlockId
+  , edgeTo :: !BlockId
+  , edgeInfo :: !EdgeInfo
+  }
+
+-- | Careful! Since we assume there is at most one edge from A to B
+--   the Eq instance does not consider weight.
+instance Eq CfgEdge where
+  (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _)
+    = from1 == from2 && to1 == to2
+
+-- | Edges are sorted ascending pointwise by weight, source and destination
+instance Ord CfgEdge where
+  compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1}))
+          (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2}))
+    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
+      weight1 == weight2 && from1 == from2 && to1 < to2
+    = LT
+    | from1 == from2 && to1 == to2 && weight1 == weight2
+    = EQ
+    | otherwise
+    = GT
+
+instance Outputable CfgEdge where
+  ppr (CfgEdge from1 to1 edgeInfo)
+    = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1)
+
+-- | Can we trace back a edge to a specific Cmm Node
+-- or has it been introduced for codegen. We use this to maintain
+-- some information which would otherwise be lost during the
+-- Cmm <-> asm transition.
+-- See also Note [Inverting Conditional Branches]
+data TransitionSource
+  = CmmSource (CmmNode O C)
+  | AsmCodeGen
+  deriving (Eq)
+
+-- | Information about edges
+data EdgeInfo
+  = EdgeInfo
+  { transitionSource :: !TransitionSource
+  , edgeWeight :: !EdgeWeight
+  } deriving (Eq)
+
+instance Outputable EdgeInfo where
+  ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo)
+
+-- Allow specialization
+{-# INLINEABLE mkWeightInfo #-}
+-- | Convenience function, generate edge info based
+--   on weight not originating from cmm.
+mkWeightInfo :: Integral n => n -> EdgeInfo
+mkWeightInfo = EdgeInfo AsmCodeGen . fromIntegral
+
+-- | Adjust the weight between the blocks using the given function.
+--   If there is no such edge returns the original map.
+adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight)
+                 -> BlockId -> BlockId -> CFG
+adjustEdgeWeight cfg f from to
+  | Just info <- getEdgeInfo from to cfg
+  , weight <- edgeWeight info
+  = addEdge from to (info { edgeWeight = f weight}) cfg
+  | otherwise = cfg
+
+getCfgNodes :: CFG -> LabelSet
+getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m
+
+hasNode :: CFG -> BlockId -> Bool
+hasNode m node = mapMember node m || any (mapMember node) m
+
+-- | Check if the nodes in the cfg and the set of blocks are the same.
+--   In a case of a missmatch we panic and show the difference.
+sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
+sanityCheckCfg m blockSet msg
+    | blockSet == cfgNodes
+    = True
+    | otherwise =
+        pprPanic "Block list and cfg nodes don't match" (
+            text "difference:" <+> ppr diff $$
+            text "blocks:" <+> ppr blockSet $$
+            text "cfg:" <+> ppr m $$
+            msg )
+            False
+    where
+      cfgNodes = getCfgNodes m :: LabelSet
+      diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet
+
+-- | Filter the CFG with a custom function f.
+--   Paramaeters are `f from to edgeInfo`
+filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
+filterEdges f cfg =
+    mapMapWithKey filterSources cfg
+    where
+      filterSources from m =
+        mapFilterWithKey (\to w -> f from to w) m
+
+
+{- Note [Updating the CFG during shortcutting]
+
+See Note [What is shortcutting] in the control flow optimization
+code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting.
+
+In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs)
+This means we remove blocks containing only one jump from the code
+and instead redirecting all jumps targeting this block to the deleted
+blocks jump target.
+
+However we want to have an accurate representation of control
+flow in the CFG. So we add/remove edges accordingly to account
+for the eliminated blocks and new edges.
+
+If we shortcut A -> B -> C to A -> C:
+* We delete edges A -> B and B -> C
+* Replacing them with the edge A -> C
+
+We also try to preserve jump weights while doing so.
+
+Note that:
+* The edge B -> C can't have interesting weights since
+  the block B consists of a single unconditional jump without branching.
+* We delete the edge A -> B and add the edge A -> C.
+* The edge A -> B can be one of many edges originating from A so likely
+  has edge weights we want to preserve.
+
+For this reason we simply store the edge info from the original A -> B
+edge and apply this information to the new edge A -> C.
+
+Sometimes we have a scenario where jump target C is not represented by an
+BlockId but an immediate value. I'm only aware of this happening without
+tables next to code currently.
+
+Then we go from A ---> B - -> IMM   to   A - -> IMM where the dashed arrows
+are not stored in the CFG.
+
+In that case we simply delete the edge A -> B.
+
+In terms of implementation the native backend first builds a mapping
+from blocks suitable for shortcutting to their jump targets.
+Then it redirects all jump instructions to these blocks using the
+built up mapping.
+This function (shortcutWeightMap) takes the same mapping and
+applies the mapping to the CFG in the way layed out above.
+
+-}
+shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG
+shortcutWeightMap cfg cuts =
+  foldl' applyMapping cfg $ mapToList cuts
+    where
+-- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]
+      applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG
+      --Shortcut immediate
+      applyMapping m (from, Nothing) =
+        mapDelete from .
+        fmap (mapDelete from) $ m
+      --Regular shortcut
+      applyMapping m (from, Just to) =
+        let updatedMap :: CFG
+            updatedMap
+              = fmap (shortcutEdge (from,to)) $
+                (mapDelete from m :: CFG )
+        --Sometimes we can shortcut multiple blocks like so:
+        -- A -> B -> C -> D -> E => A -> E
+        -- so we check for such chains.
+        in case mapLookup to cuts of
+            Nothing -> updatedMap
+            Just dest -> applyMapping updatedMap (to, dest)
+      --Redirect edge from B to C
+      shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
+      shortcutEdge (from, to) m =
+        case mapLookup from m of
+          Just info -> mapInsert to info $ mapDelete from m
+          Nothing   -> m
+
+-- | Sometimes we insert a block which should unconditionally be executed
+--   after a given block. This function updates the CFG for these cases.
+--  So we get A -> B    => A -> A' -> B
+--             \                  \
+--              -> C    =>         -> C
+--
+addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG
+addImmediateSuccessor node follower cfg
+    = updateEdges . addWeightEdge node follower uncondWeight $ cfg
+    where
+        uncondWeight = fromIntegral . D.uncondWeight .
+                       D.cfgWeightInfo $ D.unsafeGlobalDynFlags
+        targets = getSuccessorEdges cfg node
+        successors = map fst targets :: [BlockId]
+        updateEdges = addNewSuccs . remOldSuccs
+        remOldSuccs m = foldl' (flip (delEdge node)) m successors
+        addNewSuccs m =
+          foldl' (\m' (t,info) -> addEdge follower t info m') m targets
+
+-- | Adds a new edge, overwrites existing edges if present
+addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
+addEdge from to info cfg =
+    mapAlter addDest from cfg
+    where
+        addDest Nothing = Just $ mapSingleton to info
+        addDest (Just wm) = Just $ mapInsert to info wm
+
+-- | Adds a edge with the given weight to the cfg
+--   If there already existed an edge it is overwritten.
+--   `addWeightEdge from to weight cfg`
+addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
+addWeightEdge from to weight cfg =
+    addEdge from to (mkWeightInfo weight) cfg
+
+delEdge :: BlockId -> BlockId -> CFG -> CFG
+delEdge from to m =
+    mapAlter remDest from m
+    where
+        remDest Nothing = Nothing
+        remDest (Just wm) = Just $ mapDelete to wm
+
+-- | Destinations from bid ordered by weight (descending)
+getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
+getSuccEdgesSorted m bid =
+    let destMap = mapFindWithDefault mapEmpty bid m
+        cfgEdges = mapToList destMap
+        sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges
+    in  --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)
+        sortedEdges
+
+-- | Get successors of a given node with edge weights.
+getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
+getSuccessorEdges m bid = maybe [] mapToList $ mapLookup bid m
+
+getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
+getEdgeInfo from to m
+    | Just wm <- mapLookup from m
+    , Just info <- mapLookup to wm
+    = Just $! info
+    | otherwise
+    = Nothing
+
+reverseEdges :: CFG -> CFG
+reverseEdges cfg = foldr add mapEmpty flatElems
+  where
+    elems = mapToList $ fmap mapToList cfg :: [(BlockId,[(BlockId,EdgeInfo)])]
+    flatElems =
+        concatMap (\(from,ws) -> map (\(to,info) -> (to,from,info)) ws ) elems
+    add (to,from,info) m = addEdge to from info m
+
+-- | Returns a unordered list of all edges with info
+infoEdgeList :: CFG -> [CfgEdge]
+infoEdgeList m =
+  mapFoldMapWithKey
+    (\from toMap ->
+      map (\(to,info) -> CfgEdge from to info) (mapToList toMap))
+    m
+
+-- | Unordered list of edges with weight as Tuple (from,to,weight)
+weightedEdgeList :: CFG -> [(BlockId,BlockId,EdgeWeight)]
+weightedEdgeList m =
+  mapFoldMapWithKey
+    (\from toMap ->
+      map (\(to,info) ->
+        (from,to, edgeWeight info)) (mapToList toMap))
+    m
+      --  (\(from, tos) -> map (\(to,info) -> (from,to, edgeWeight info)) tos )
+
+-- | Returns a unordered list of all edges without weights
+edgeList :: CFG -> [Edge]
+edgeList m =
+        mapFoldMapWithKey (\from toMap -> fmap (from,) (mapKeys toMap)) m
+
+-- | Get successors of a given node without edge weights.
+getSuccessors :: CFG -> BlockId -> [BlockId]
+getSuccessors m bid
+    | Just wm <- mapLookup bid m
+    = mapKeys wm
+    | otherwise = []
+
+pprEdgeWeights :: CFG -> SDoc
+pprEdgeWeights m =
+    let edges = sort $ weightedEdgeList m
+        printEdge (from, to, weight)
+            = text "\t" <> ppr from <+> text "->" <+> ppr to <>
+              text "[label=\"" <> ppr weight <> text "\",weight=\"" <>
+              ppr weight <> text "\"];\n"
+        --for the case that there are no edges from/to this node.
+        --This should rarely happen but it can save a lot of time
+        --to immediately see it when it does.
+        printNode node
+            = text "\t" <> ppr node <> text ";\n"
+        getEdgeNodes (from, to, _weight) = [from,to]
+        edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet
+        nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m
+    in
+    text "digraph {\n" <>
+        (foldl' (<>) empty (map printEdge edges)) <>
+        (foldl' (<>) empty (map printNode nodes)) <>
+    text "}\n"
+
+{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
+updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
+updateEdgeWeight f (from, to) cfg
+    | Just oldInfo <- getEdgeInfo from to cfg
+    = let oldWeight = edgeWeight oldInfo
+          newWeight = f oldWeight
+      in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg
+    | otherwise
+    = panic "Trying to update invalid edge"
+
+-- from to oldWeight => newWeight
+mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
+mapWeights f cfg =
+  foldl' (\cfg (CfgEdge from to info) ->
+            let oldWeight = edgeWeight info
+                newWeight = f from to oldWeight
+            in addEdge from to (info {edgeWeight = newWeight}) cfg)
+          cfg (infoEdgeList cfg)
+
+
+-- | Insert a block in the control flow between two other blocks.
+-- We pass a list of tuples (A,B,C) where
+-- * A -> C: Old edge
+-- * A -> B -> C : New Arc, where B is the new block.
+-- It's possible that a block has two jumps to the same block
+-- in the assembly code. However we still only store a single edge for
+-- these cases.
+-- We assign the old edge info to the edge A -> B and assign B -> C the
+-- weight of an unconditional jump.
+addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG
+addNodesBetween m updates =
+  foldl'  updateWeight m .
+          weightUpdates $ updates
+    where
+      weight = fromIntegral . D.uncondWeight .
+                D.cfgWeightInfo $ D.unsafeGlobalDynFlags
+      -- We might add two blocks for different jumps along a single
+      -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C
+      -- in this case after applying the first update the weight for A -> C
+      -- is no longer available. So we calculate future weights before updates.
+      weightUpdates = map getWeight
+      getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
+      getWeight (from,between,old)
+        | Just edgeInfo <- getEdgeInfo from old m
+        = (from,between,old,edgeInfo)
+        | otherwise
+        = pprPanic "Can't find weight for edge that should have one" (
+            text "triple" <+> ppr (from,between,old) $$
+            text "updates" <+> ppr updates )
+      updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
+      updateWeight m (from,between,old,edgeInfo)
+        = addEdge from between edgeInfo .
+          addWeightEdge between old weight .
+          delEdge from old $ m
+
+{-
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ~~~       Note [CFG Edge Weights]    ~~~
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  Edge weights assigned do not currently represent a specific
+  cost model and rather just a ranking of which blocks should
+  be placed next to each other given their connection type in
+  the CFG.
+  This is especially relevant if we whenever two blocks will
+  jump to the same target.
+
+                     A   B
+                      \ /
+                       C
+
+  Should A or B be placed in front of C? The block layout algorithm
+  decides this based on which edge (A,C)/(B,C) is heavier. So we
+  make a educated guess how often execution will transer control
+  along each edge as well as how much we gain by placing eg A before
+  C.
+
+  We rank edges in this order:
+  * Unconditional Control Transfer - They will always
+    transfer control to their target. Unless there is a info table
+    we can turn the jump into a fallthrough as well.
+    We use 20k as default, so it's easy to spot if values have been
+    modified but unlikely that we run into issues with overflow.
+  * If branches (likely) - We assume branches marked as likely
+    are taken more than 80% of the time.
+    By ranking them below unconditional jumps we make sure we
+    prefer the unconditional if there is a conditional and
+    unconditional edge towards a block.
+  * If branches (regular) - The false branch can potentially be turned
+    into a fallthrough so we prefer it slightly over the true branch.
+  * Unlikely branches - These can be assumed to be taken less than 20%
+    of the time. So we given them one of the lowest priorities.
+  * Switches - Switches at this level are implemented as jump tables
+    so have a larger number of successors. So without more information
+    we can only say that each individual successor is unlikely to be
+    jumped to and we rank them accordingly.
+  * Calls - We currently ignore calls completly:
+        * By the time we return from a call there is a good chance
+          that the address we return to has already been evicted from
+          cache eliminating a main advantage sequential placement brings.
+        * Calls always require a info table in front of their return
+          address. This reduces the chance that we return to the same
+          cache line further.
+
+
+-}
+-- | Generate weights for a Cmm proc based on some simple heuristics.
+getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG
+getCfgProc _       (CmmData {}) = mapEmpty
+getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph
+
+getCfg :: D.CfgWeights -> CmmGraph -> CFG
+getCfg weights graph =
+  foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
+  where
+    D.CFGWeights
+            { D.uncondWeight = uncondWeight
+            , D.condBranchWeight = condBranchWeight
+            , D.switchWeight = switchWeight
+            , D.callWeight = callWeight
+            , D.likelyCondWeight = likelyCondWeight
+            , D.unlikelyCondWeight = unlikelyCondWeight
+            --  Last two are used in other places
+            --, D.infoTablePenalty = infoTablePenalty
+            --, D.backEdgeBonus = backEdgeBonus
+            } = weights
+    -- Explicitly add all nodes to the cfg to ensure they are part of the
+    -- CFG.
+    edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty)
+    insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
+    insertEdge m ((from,to),weight) =
+      mapAlter f from m
+        where
+          f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
+          f Nothing = Just $ mapSingleton to weight
+          f (Just destMap) = Just $ mapInsert to weight destMap
+    getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
+    getBlockEdges block =
+      case branch of
+        CmmBranch dest -> [mkEdge dest uncondWeight]
+        CmmCondBranch _c t f l
+          | l == Nothing ->
+              [mkEdge f condBranchWeight,   mkEdge t condBranchWeight]
+          | l == Just True ->
+              [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight]
+          | l == Just False ->
+              [mkEdge f likelyCondWeight,   mkEdge t unlikelyCondWeight]
+        (CmmSwitch _e ids) ->
+          let switchTargets = switchTargetsToList ids
+              --Compiler performance hack - for very wide switches don't
+              --consider targets for layout.
+              adjustedWeight =
+                if (length switchTargets > 10) then -1 else switchWeight
+          in map (\x -> mkEdge x adjustedWeight) switchTargets
+        (CmmCall { cml_cont = Just cont})  -> [mkEdge cont callWeight]
+        (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight]
+        (CmmCall { cml_cont = Nothing })   -> []
+        other ->
+            panic "Foo" $
+            ASSERT2(False, ppr "Unkown successor cause:" <>
+              (ppr branch <+> text "=>" <> ppr (G.successors other)))
+            map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
+      where
+        bid = G.entryLabel block
+        mkEdgeInfo = EdgeInfo (CmmSource branch) . fromIntegral
+        mkEdge target weight = ((bid,target), mkEdgeInfo weight)
+        branch = lastNode block :: CmmNode O C
+
+    blocks = revPostorder graph :: [CmmBlock]
+
+--Find back edges by BFS
+findBackEdges :: BlockId -> CFG -> Edges
+findBackEdges root cfg =
+    --pprTraceIt "Backedges:" $
+    map fst .
+    filter (\x -> snd x == Backward) $ typedEdges
+  where
+    edges = edgeList cfg :: [(BlockId,BlockId)]
+    getSuccs = getSuccessors cfg :: BlockId -> [BlockId]
+    typedEdges =
+      classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
+
+
+optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optimizeCFG _ (CmmData {}) cfg = cfg
+optimizeCFG weights (CmmProc info _lab _live graph) cfg =
+    favourFewerPreds  .
+    penalizeInfoTables info .
+    increaseBackEdgeWeight (g_entry graph) $ cfg
+  where
+
+    -- | Increase the weight of all backedges in the CFG
+    -- this helps to make loop jumpbacks the heaviest edges
+    increaseBackEdgeWeight :: BlockId -> CFG -> CFG
+    increaseBackEdgeWeight root cfg =
+        let backedges = findBackEdges root cfg
+            update weight
+              --Keep irrelevant edges irrelevant
+              | weight <= 0 = 0
+              | otherwise
+              = weight + fromIntegral (D.backEdgeBonus weights)
+        in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)
+                    cfg backedges
+
+    -- | Since we cant fall through info tables we penalize these.
+    penalizeInfoTables :: LabelMap a -> CFG -> CFG
+    penalizeInfoTables info cfg =
+        mapWeights fupdate cfg
+      where
+        fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
+        fupdate _ to weight
+          | mapMember to info
+          = weight - (fromIntegral $ D.infoTablePenalty weights)
+          | otherwise = weight
+
+
+{- Note [Optimize for Fallthrough]
+
+-}
+    -- | If a block has two successors, favour the one with fewer
+    -- predecessors. (As that one is more likely to become a fallthrough)
+    favourFewerPreds :: CFG -> CFG
+    favourFewerPreds cfg =
+        let
+            revCfg =
+              reverseEdges $ filterEdges
+                              (\_from -> fallthroughTarget)  cfg
+
+            predCount n = length $ getSuccessorEdges revCfg n
+            nodes = getCfgNodes cfg
+
+            modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
+            modifiers preds1 preds2
+              | preds1 <  preds2 = ( 1,-1)
+              | preds1 == preds2 = ( 0, 0)
+              | otherwise        = (-1, 1)
+
+            update cfg node
+              | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node
+              , w1 <- edgeWeight e1
+              , w2 <- edgeWeight e2
+              --Only change the weights if there isn't already a ordering.
+              , w1 == w2
+              , (mod1,mod2) <- modifiers (predCount s1) (predCount s2)
+              = (\cfg' ->
+                  (adjustEdgeWeight cfg' (+mod2) node s2))
+                  (adjustEdgeWeight cfg  (+mod1) node s1)
+              | otherwise
+              = cfg
+        in setFoldl update cfg nodes
+      where
+        fallthroughTarget :: BlockId -> EdgeInfo -> Bool
+        fallthroughTarget to (EdgeInfo source _weight)
+          | mapMember to info = False
+          | AsmCodeGen <- source = True
+          | CmmSource (CmmBranch {}) <- source = True
+          | CmmSource (CmmCondBranch {}) <- source = True
+          | otherwise = False
+
+-- | Determine loop membership of blocks based on SCC analysis
+--   Ideally we would replace this with a variant giving us loop
+--   levels instead but the SCC code will do for now.
+loopMembers :: CFG -> LabelMap Bool
+loopMembers cfg =
+    foldl' (flip setLevel) mapEmpty sccs
+  where
+    mkNode :: BlockId -> Node BlockId BlockId
+    mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)
+    nodes = map mkNode (setElems $ getCfgNodes cfg)
+
+    sccs = stronglyConnCompFromEdgedVerticesOrd nodes
+
+    setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
+    setLevel (AcyclicSCC bid) m = mapInsert bid False m
+    setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/CPrim.hs
@@ -0,0 +1,133 @@
+-- | Generating C symbol names emitted by the compiler.
+module CPrim
+    ( atomicReadLabel
+    , atomicWriteLabel
+    , atomicRMWLabel
+    , cmpxchgLabel
+    , popCntLabel
+    , pdepLabel
+    , pextLabel
+    , bSwapLabel
+    , bRevLabel
+    , clzLabel
+    , ctzLabel
+    , word2FloatLabel
+    ) where
+
+import GhcPrelude
+
+import CmmType
+import CmmMachOp
+import Outputable
+
+popCntLabel :: Width -> String
+popCntLabel w = "hs_popcnt" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)
+
+pdepLabel :: Width -> String
+pdepLabel w = "hs_pdep" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)
+
+pextLabel :: Width -> String
+pextLabel w = "hs_pext" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)
+
+bSwapLabel :: Width -> String
+bSwapLabel w = "hs_bswap" ++ pprWidth w
+  where
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)
+
+bRevLabel :: Width -> String
+bRevLabel w = "hs_bitrev" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "bRevLabel: Unsupported word width " (ppr w)
+
+clzLabel :: Width -> String
+clzLabel w = "hs_clz" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "clzLabel: Unsupported word width " (ppr w)
+
+ctzLabel :: Width -> String
+ctzLabel w = "hs_ctz" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "ctzLabel: Unsupported word width " (ppr w)
+
+word2FloatLabel :: Width -> String
+word2FloatLabel w = "hs_word2float" ++ pprWidth w
+  where
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)
+
+atomicRMWLabel :: Width -> AtomicMachOp -> String
+atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
+
+    pprFunName AMO_Add  = "add"
+    pprFunName AMO_Sub  = "sub"
+    pprFunName AMO_And  = "and"
+    pprFunName AMO_Nand = "nand"
+    pprFunName AMO_Or   = "or"
+    pprFunName AMO_Xor  = "xor"
+
+cmpxchgLabel :: Width -> String
+cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)
+
+atomicReadLabel :: Width -> String
+atomicReadLabel w = "hs_atomicread" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)
+
+atomicWriteLabel :: Width -> String
+atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Dwarf.hs
@@ -0,0 +1,269 @@
+module Dwarf (
+  dwarfGen
+  ) where
+
+import GhcPrelude
+
+import CLabel
+import CmmExpr         ( GlobalReg(..) )
+import Config          ( cProjectName, cProjectVersion )
+import CoreSyn         ( Tickish(..) )
+import Debug
+import DynFlags
+import Module
+import Outputable
+import Platform
+import Unique
+import UniqSupply
+
+import Dwarf.Constants
+import Dwarf.Types
+
+import Control.Arrow    ( first )
+import Control.Monad    ( mfilter )
+import Data.Maybe
+import Data.List        ( sortBy )
+import Data.Ord         ( comparing )
+import qualified Data.Map as Map
+import System.FilePath
+import System.Directory ( getCurrentDirectory )
+
+import qualified Hoopl.Label as H
+import qualified Hoopl.Collections as H
+
+-- | Generate DWARF/debug information
+dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
+            -> IO (SDoc, UniqSupply)
+dwarfGen _  _      us [] = return (empty, us)
+dwarfGen df modLoc us blocks = do
+
+  -- Convert debug data structures to DWARF info records
+  -- We strip out block information when running with -g0 or -g1.
+  let procs = debugSplitProcs blocks
+      stripBlocks dbg
+        | debugLevel df < 2 = dbg { dblBlocks = [] }
+        | otherwise         = dbg
+  compPath <- getCurrentDirectory
+  let lowLabel = dblCLabel $ head procs
+      highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
+      dwarfUnit = DwarfCompileUnit
+        { dwChildren = map (procToDwarf df) (map stripBlocks procs)
+        , dwName = fromMaybe "" (ml_hs_file modLoc)
+        , dwCompDir = addTrailingPathSeparator compPath
+        , dwProducer = cProjectName ++ " " ++ cProjectVersion
+        , dwLowLabel = lowLabel
+        , dwHighLabel = highLabel
+        , dwLineLabel = dwarfLineLabel
+        }
+
+  -- Check whether we have any source code information, so we do not
+  -- end up writing a pointer to an empty .debug_line section
+  -- (dsymutil on Mac Os gets confused by this).
+  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
+                      || any haveSrcIn (dblBlocks blk)
+      haveSrc = any haveSrcIn procs
+
+  -- .debug_abbrev section: Declare the format we're using
+  let abbrevSct = pprAbbrevDecls haveSrc
+
+  -- .debug_info section: Information records on procedures and blocks
+  let -- unique to identify start and end compilation unit .debug_inf
+      (unitU, us') = takeUniqFromSupply us
+      infoSct = vcat [ ptext dwarfInfoLabel <> colon
+                     , dwarfInfoSection
+                     , compileUnitHeader unitU
+                     , pprDwarfInfo haveSrc dwarfUnit
+                     , compileUnitFooter unitU
+                     ]
+
+  -- .debug_line section: Generated mainly by the assembler, but we
+  -- need to label it
+  let lineSct = dwarfLineSection $$
+                ptext dwarfLineLabel <> colon
+
+  -- .debug_frame section: Information about the layout of the GHC stack
+  let (framesU, us'') = takeUniqFromSupply us'
+      frameSct = dwarfFrameSection $$
+                 ptext dwarfFrameLabel <> colon $$
+                 pprDwarfFrame (debugFrame framesU procs)
+
+  -- .aranges section: Information about the bounds of compilation units
+  let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
+               | otherwise                 = [DwarfARange lowLabel highLabel]
+  let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
+
+  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
+
+-- | Build an address range entry for one proc.
+-- With split sections, each proc needs its own entry, since they may get
+-- scattered in the final binary. Without split sections, we could make a
+-- single arange based on the first/last proc.
+mkDwarfARange :: DebugBlock -> DwarfARange
+mkDwarfARange proc = DwarfARange start end
+  where
+    start = dblCLabel proc
+    end = mkAsmTempEndLabel start
+
+-- | Header for a compilation unit, establishing global format
+-- parameters
+compileUnitHeader :: Unique -> SDoc
+compileUnitHeader unitU = sdocWithPlatform $ \plat ->
+  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field
+      length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
+               <> text "-4"       -- length of initialLength field
+  in vcat [ ppr cuLabel <> colon
+          , text "\t.long " <> length  -- compilation unit size
+          , pprHalf 3                          -- DWARF version
+          , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
+                                               -- abbrevs offset
+          , text "\t.byte " <> ppr (platformWordSize plat) -- word size
+          ]
+
+-- | Compilation unit footer, mainly establishing size of debug sections
+compileUnitFooter :: Unique -> SDoc
+compileUnitFooter unitU =
+  let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
+  in ppr cuEndLabel <> colon
+
+-- | Splits the blocks by procedures. In the result all nested blocks
+-- will come from the same procedure as the top-level block. See
+-- Note [Splitting DebugBlocks] for details.
+debugSplitProcs :: [DebugBlock] -> [DebugBlock]
+debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
+  where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
+        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
+        split parent blk = H.mapInsert prc [blk'] nested
+          where prc = dblProcedure blk
+                blk' = blk { dblBlocks = own_blks
+                           , dblParent = parent
+                           }
+                own_blks = fromMaybe [] $ H.mapLookup prc nested
+                nested = mergeMaps $ map (split parent') $ dblBlocks blk
+                -- Figure out who should be the parent of nested blocks.
+                -- If @blk@ is optimized out then it isn't a good choice
+                -- and we just use its parent.
+                parent'
+                  | Nothing <- dblPosition blk = parent
+                  | otherwise                  = Just blk
+
+{-
+Note [Splitting DebugBlocks]
+
+DWARF requires that we break up the nested DebugBlocks produced from
+the C-- AST. For instance, we begin with tick trees containing nested procs.
+For example,
+
+    proc A [tick1, tick2]
+      block B [tick3]
+        proc C [tick4]
+
+when producing DWARF we need to procs (which are represented in DWARF as
+TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
+this transform, pulling out the nested procs into top-level procs.
+
+However, in doing this we need to be careful to preserve the parentage of the
+nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
+us to reorganize the above tree as,
+
+    proc A [tick1, tick2]
+      block B [tick3]
+    proc C [tick4] parent=B
+
+Here we have annotated the new proc C with an attribute giving its original
+parent, B.
+-}
+
+-- | Generate DWARF info for a procedure debug block
+procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
+procToDwarf df prc
+  = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)
+                    , dwName     = case dblSourceTick prc of
+                         Just s@SourceNote{} -> sourceName s
+                         _otherwise -> showSDocDump df $ ppr $ dblLabel prc
+                    , dwLabel    = dblCLabel prc
+                    , dwParent   = fmap mkAsmTempDieLabel
+                                   $ mfilter goodParent
+                                   $ fmap dblCLabel (dblParent prc)
+                    }
+  where
+  goodParent a | a == dblCLabel prc = False
+               -- Omit parent if it would be self-referential
+  goodParent a | not (externallyVisibleCLabel a)
+               , debugLevel df < 2 = False
+               -- We strip block information when running -g0 or -g1, don't
+               -- refer to blocks in that case. Fixes #14894.
+  goodParent _ = True
+
+-- | Generate DWARF info for a block
+blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
+blockToDwarf df blk
+  = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)
+                              ++ map (blockToDwarf df) (dblBlocks blk)
+               , dwLabel    = dblCLabel blk
+               , dwMarker   = marker
+               }
+  where
+    marker
+      | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
+      | otherwise                 = Nothing   -- block was optimized out
+
+tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
+tickToDwarf _  (SourceNote ss _) = [DwarfSrcNote ss]
+tickToDwarf _ _ = []
+
+-- | Generates the data for the debug frame section, which encodes the
+-- desired stack unwind behaviour for the debugger
+debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
+debugFrame u procs
+  = DwarfFrame { dwCieLabel = mkAsmTempLabel u
+               , dwCieInit  = initUws
+               , dwCieProcs = map (procToFrame initUws) procs
+               }
+  where
+    initUws :: UnwindTable
+    initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
+
+-- | Generates unwind information for a procedure debug block
+procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
+procToFrame initUws blk
+  = DwarfFrameProc { dwFdeProc    = dblCLabel blk
+                   , dwFdeHasInfo = dblHasInfoTbl blk
+                   , dwFdeBlocks  = map (uncurry blockToFrame)
+                                        (setHasInfo blockUws)
+                   }
+  where blockUws :: [(DebugBlock, [UnwindPoint])]
+        blockUws = map snd $ sortBy (comparing fst) $ flatten blk
+
+        flatten :: DebugBlock
+                -> [(Int, (DebugBlock, [UnwindPoint]))]
+        flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
+          | Just p <- pos  = (p, (b, uws')):nested
+          | otherwise      = nested -- block was optimized out
+          where uws'   = addDefaultUnwindings initUws uws
+                nested = concatMap flatten blocks
+
+        -- | If the current procedure has an info table, then we also say that
+        -- its first block has one to ensure that it gets the necessary -1
+        -- offset applied to its start address.
+        -- See Note [Info Offset] in Dwarf.Types.
+        setHasInfo :: [(DebugBlock, [UnwindPoint])]
+                   -> [(DebugBlock, [UnwindPoint])]
+        setHasInfo [] = []
+        setHasInfo (c0:cs) = first setIt c0 : cs
+          where
+            setIt child =
+              child { dblHasInfoTbl = dblHasInfoTbl child
+                                      || dblHasInfoTbl blk }
+
+blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
+blockToFrame blk uws
+  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
+                    , dwFdeUnwind     = uws
+                    }
+
+addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
+addDefaultUnwindings tbl pts =
+    [ UnwindPoint lbl (tbl' `mappend` tbl)
+      -- mappend is left-biased
+    | UnwindPoint lbl tbl' <- pts
+    ]
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -0,0 +1,229 @@
+-- | Constants describing the DWARF format. Most of this simply
+-- mirrors /usr/include/dwarf.h.
+
+module Dwarf.Constants where
+
+import GhcPrelude
+
+import AsmUtils
+import FastString
+import Platform
+import Outputable
+
+import Reg
+import X86.Regs
+
+import Data.Word
+
+-- | Language ID used for Haskell.
+dW_LANG_Haskell :: Word
+dW_LANG_Haskell = 0x18
+  -- Thanks to Nathan Howell for getting us our very own language ID!
+
+-- * Dwarf tags
+dW_TAG_compile_unit, dW_TAG_subroutine_type,
+  dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block,
+  dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type,
+  dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef,
+  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable,
+  dW_TAG_ghc_src_note :: Word
+dW_TAG_array_type      = 1
+dW_TAG_lexical_block   = 11
+dW_TAG_pointer_type    = 15
+dW_TAG_compile_unit    = 17
+dW_TAG_structure_type  = 19
+dW_TAG_typedef         = 22
+dW_TAG_subroutine_type = 32
+dW_TAG_subrange_type   = 33
+dW_TAG_base_type       = 36
+dW_TAG_file_type       = 41
+dW_TAG_subprogram      = 46
+dW_TAG_variable        = 52
+dW_TAG_auto_variable   = 256
+dW_TAG_arg_variable    = 257
+
+dW_TAG_ghc_src_note    = 0x5b00
+
+-- * Dwarf attributes
+dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,
+  dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,
+  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word
+dW_AT_name              = 0x03
+dW_AT_stmt_list         = 0x10
+dW_AT_low_pc            = 0x11
+dW_AT_high_pc           = 0x12
+dW_AT_language          = 0x13
+dW_AT_comp_dir          = 0x1b
+dW_AT_producer          = 0x25
+dW_AT_external          = 0x3f
+dW_AT_frame_base        = 0x40
+dW_AT_use_UTF8          = 0x53
+dW_AT_MIPS_linkage_name = 0x2007
+
+-- * Custom DWARF attributes
+-- Chosen a more or less random section of the vendor-extensible region
+
+-- ** Describing C-- blocks
+-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks
+dW_AT_ghc_tick_parent :: Word
+dW_AT_ghc_tick_parent     = 0x2b20
+
+-- ** Describing source notes
+-- These appear in DW_TAG_ghc_src_note DIEs
+dW_AT_ghc_span_file, dW_AT_ghc_span_start_line,
+  dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line,
+  dW_AT_ghc_span_end_col :: Word
+dW_AT_ghc_span_file       = 0x2b00
+dW_AT_ghc_span_start_line = 0x2b01
+dW_AT_ghc_span_start_col  = 0x2b02
+dW_AT_ghc_span_end_line   = 0x2b03
+dW_AT_ghc_span_end_col    = 0x2b04
+
+
+-- * Abbrev declarations
+dW_CHILDREN_no, dW_CHILDREN_yes :: Word8
+dW_CHILDREN_no  = 0
+dW_CHILDREN_yes = 1
+
+dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,
+  dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word
+dW_FORM_addr   = 0x01
+dW_FORM_data2  = 0x05
+dW_FORM_data4  = 0x06
+dW_FORM_string = 0x08
+dW_FORM_flag   = 0x0c
+dW_FORM_block1 = 0x0a
+dW_FORM_ref_addr     = 0x10
+dW_FORM_ref4         = 0x13
+dW_FORM_flag_present = 0x19
+
+-- * Dwarf native types
+dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed,
+  dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word
+dW_ATE_address       = 1
+dW_ATE_boolean       = 2
+dW_ATE_float         = 4
+dW_ATE_signed        = 5
+dW_ATE_signed_char   = 6
+dW_ATE_unsigned      = 7
+dW_ATE_unsigned_char = 8
+
+-- * Call frame information
+dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value,
+  dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression,
+  dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf,
+  dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression,
+  dW_CFA_offset :: Word8
+dW_CFA_set_loc            = 0x01
+dW_CFA_undefined          = 0x07
+dW_CFA_same_value         = 0x08
+dW_CFA_def_cfa            = 0x0c
+dW_CFA_def_cfa_offset     = 0x0e
+dW_CFA_def_cfa_expression = 0x0f
+dW_CFA_expression         = 0x10
+dW_CFA_offset_extended_sf = 0x11
+dW_CFA_def_cfa_sf         = 0x12
+dW_CFA_def_cfa_offset_sf  = 0x13
+dW_CFA_val_offset         = 0x14
+dW_CFA_val_expression     = 0x16
+dW_CFA_offset             = 0x80
+
+-- * Operations
+dW_OP_addr, dW_OP_deref, dW_OP_consts,
+  dW_OP_minus, dW_OP_mul, dW_OP_plus,
+  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8
+dW_OP_addr           = 0x03
+dW_OP_deref          = 0x06
+dW_OP_consts         = 0x11
+dW_OP_minus          = 0x1c
+dW_OP_mul            = 0x1e
+dW_OP_plus           = 0x22
+dW_OP_lit0           = 0x30
+dW_OP_breg0          = 0x70
+dW_OP_call_frame_cfa = 0x9c
+
+-- * Dwarf section declarations
+dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
+  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
+dwarfInfoSection    = dwarfSection "info"
+dwarfAbbrevSection  = dwarfSection "abbrev"
+dwarfLineSection    = dwarfSection "line"
+dwarfFrameSection   = dwarfSection "frame"
+dwarfGhcSection     = dwarfSection "ghc"
+dwarfARangesSection = dwarfSection "aranges"
+
+dwarfSection :: String -> SDoc
+dwarfSection name = sdocWithPlatform $ \plat ->
+  case platformOS plat of
+    os | osElfTarget os
+       -> text "\t.section .debug_" <> text name <> text ",\"\","
+          <> sectionType "progbits"
+       | osMachOTarget os
+       -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
+       | otherwise
+       -> text "\t.section .debug_" <> text name <> text ",\"dr\""
+
+-- * Dwarf section labels
+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString
+dwarfInfoLabel   = sLit ".Lsection_info"
+dwarfAbbrevLabel = sLit ".Lsection_abbrev"
+dwarfLineLabel   = sLit ".Lsection_line"
+dwarfFrameLabel  = sLit ".Lsection_frame"
+
+-- | Mapping of registers to DWARF register numbers
+dwarfRegNo :: Platform -> Reg -> Word8
+dwarfRegNo p r = case platformArch p of
+  ArchX86
+    | r == eax  -> 0
+    | r == ecx  -> 1  -- yes, no typo
+    | r == edx  -> 2
+    | r == ebx  -> 3
+    | r == esp  -> 4
+    | r == ebp  -> 5
+    | r == esi  -> 6
+    | r == edi  -> 7
+  ArchX86_64
+    | r == rax  -> 0
+    | r == rdx  -> 1 -- this neither. The order GCC allocates registers in?
+    | r == rcx  -> 2
+    | r == rbx  -> 3
+    | r == rsi  -> 4
+    | r == rdi  -> 5
+    | r == rbp  -> 6
+    | r == rsp  -> 7
+    | r == r8   -> 8
+    | r == r9   -> 9
+    | r == r10  -> 10
+    | r == r11  -> 11
+    | r == r12  -> 12
+    | r == r13  -> 13
+    | r == r14  -> 14
+    | r == r15  -> 15
+    | r == xmm0 -> 17
+    | r == xmm1 -> 18
+    | r == xmm2 -> 19
+    | r == xmm3 -> 20
+    | r == xmm4 -> 21
+    | r == xmm5 -> 22
+    | r == xmm6 -> 23
+    | r == xmm7 -> 24
+    | r == xmm8 -> 25
+    | r == xmm9 -> 26
+    | r == xmm10 -> 27
+    | r == xmm11 -> 28
+    | r == xmm12 -> 29
+    | r == xmm13 -> 30
+    | r == xmm14 -> 31
+    | r == xmm15 -> 32
+  _other -> error "dwarfRegNo: Unsupported platform or unknown register!"
+
+-- | Virtual register number to use for return address.
+dwarfReturnRegNo :: Platform -> Word8
+dwarfReturnRegNo p
+  -- We "overwrite" IP with our pseudo register - that makes sense, as
+  -- when using this mechanism gdb already knows the IP anyway. Clang
+  -- does this too, so it must be safe.
+  = case platformArch p of
+    ArchX86    -> 8  -- eip
+    ArchX86_64 -> 16 -- rip
+    _other     -> error "dwarfReturnRegNo: Unsupported platform!"
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -0,0 +1,614 @@
+module Dwarf.Types
+  ( -- * Dwarf information
+    DwarfInfo(..)
+  , pprDwarfInfo
+  , pprAbbrevDecls
+    -- * Dwarf address range table
+  , DwarfARange(..)
+  , pprDwarfARanges
+    -- * Dwarf frame
+  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
+  , pprDwarfFrame
+    -- * Utilities
+  , pprByte
+  , pprHalf
+  , pprData4'
+  , pprDwWord
+  , pprWord
+  , pprLEBWord
+  , pprLEBInt
+  , wordAlign
+  , sectionOffset
+  )
+  where
+
+import GhcPrelude
+
+import Debug
+import CLabel
+import CmmExpr         ( GlobalReg(..) )
+import Encoding
+import FastString
+import Outputable
+import Platform
+import Unique
+import Reg
+import SrcLoc
+import Util
+
+import Dwarf.Constants
+
+import qualified Data.ByteString as BS
+import qualified Control.Monad.Trans.State.Strict as S
+import Control.Monad (zipWithM, join)
+import Data.Bits
+import qualified Data.Map as Map
+import Data.Word
+import Data.Char
+
+import CodeGen.Platform
+
+-- | Individual dwarf records. Each one will be encoded as an entry in
+-- the @.debug_info@ section.
+data DwarfInfo
+  = DwarfCompileUnit { dwChildren :: [DwarfInfo]
+                     , dwName :: String
+                     , dwProducer :: String
+                     , dwCompDir :: String
+                     , dwLowLabel :: CLabel
+                     , dwHighLabel :: CLabel
+                     , dwLineLabel :: PtrString }
+  | DwarfSubprogram { dwChildren :: [DwarfInfo]
+                    , dwName :: String
+                    , dwLabel :: CLabel
+                    , dwParent :: Maybe CLabel
+                      -- ^ label of DIE belonging to the parent tick
+                    }
+  | DwarfBlock { dwChildren :: [DwarfInfo]
+               , dwLabel :: CLabel
+               , dwMarker :: Maybe CLabel
+               }
+  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
+                 }
+
+-- | Abbreviation codes used for encoding above records in the
+-- @.debug_info@ section.
+data DwarfAbbrev
+  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
+  | DwAbbrCompileUnit
+  | DwAbbrSubprogram
+  | DwAbbrSubprogramWithParent
+  | DwAbbrBlockWithoutCode
+  | DwAbbrBlock
+  | DwAbbrGhcSrcNote
+  deriving (Eq, Enum)
+
+-- | Generate assembly for the given abbreviation code
+pprAbbrev :: DwarfAbbrev -> SDoc
+pprAbbrev = pprLEBWord . fromIntegral . fromEnum
+
+-- | Abbreviation declaration. This explains the binary encoding we
+-- use for representing 'DwarfInfo'. Be aware that this must be updated
+-- along with 'pprDwarfInfo'.
+pprAbbrevDecls :: Bool -> SDoc
+pprAbbrevDecls haveDebugLine =
+  let mkAbbrev abbr tag chld flds =
+        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
+        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
+           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
+      -- These are shared between DwAbbrSubprogram and
+      -- DwAbbrSubprogramWithParent
+      subprogramAttrs =
+           [ (dW_AT_name, dW_FORM_string)
+           , (dW_AT_MIPS_linkage_name, dW_FORM_string)
+           , (dW_AT_external, dW_FORM_flag)
+           , (dW_AT_low_pc, dW_FORM_addr)
+           , (dW_AT_high_pc, dW_FORM_addr)
+           , (dW_AT_frame_base, dW_FORM_block1)
+           ]
+  in dwarfAbbrevSection $$
+     ptext dwarfAbbrevLabel <> colon $$
+     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
+       ([(dW_AT_name,     dW_FORM_string)
+       , (dW_AT_producer, dW_FORM_string)
+       , (dW_AT_language, dW_FORM_data4)
+       , (dW_AT_comp_dir, dW_FORM_string)
+       , (dW_AT_use_UTF8, dW_FORM_flag_present)  -- not represented in body
+       , (dW_AT_low_pc,   dW_FORM_addr)
+       , (dW_AT_high_pc,  dW_FORM_addr)
+       ] ++
+       (if haveDebugLine
+        then [ (dW_AT_stmt_list, dW_FORM_data4) ]
+        else [])) $$
+     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
+       subprogramAttrs $$
+     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
+       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
+     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
+       [ (dW_AT_name, dW_FORM_string)
+       ] $$
+     mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
+       [ (dW_AT_name, dW_FORM_string)
+       , (dW_AT_low_pc, dW_FORM_addr)
+       , (dW_AT_high_pc, dW_FORM_addr)
+       ] $$
+     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
+       [ (dW_AT_ghc_span_file, dW_FORM_string)
+       , (dW_AT_ghc_span_start_line, dW_FORM_data4)
+       , (dW_AT_ghc_span_start_col, dW_FORM_data2)
+       , (dW_AT_ghc_span_end_line, dW_FORM_data4)
+       , (dW_AT_ghc_span_end_col, dW_FORM_data2)
+       ] $$
+     pprByte 0
+
+-- | Generate assembly for DWARF data
+pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
+pprDwarfInfo haveSrc d
+  = case d of
+      DwarfCompileUnit {}  -> hasChildren
+      DwarfSubprogram {}   -> hasChildren
+      DwarfBlock {}        -> hasChildren
+      DwarfSrcNote {}      -> noChildren
+  where
+    hasChildren =
+        pprDwarfInfoOpen haveSrc d $$
+        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
+        pprDwarfInfoClose
+    noChildren = pprDwarfInfoOpen haveSrc d
+
+-- | Prints assembler data corresponding to DWARF info records. Note
+-- that the binary format of this is parameterized in @abbrevDecls@ and
+-- has to be kept in synch.
+pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
+pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
+                                           highLabel lineLbl) =
+  pprAbbrev DwAbbrCompileUnit
+  $$ pprString name
+  $$ pprString producer
+  $$ pprData4 dW_LANG_Haskell
+  $$ pprString compDir
+  $$ pprWord (ppr lowLabel)
+  $$ pprWord (ppr highLabel)
+  $$ if haveSrc
+     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
+     else empty
+pprDwarfInfoOpen _ (DwarfSubprogram _ name label
+                                    parent) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev abbrev
+  $$ pprString name
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+  $$ pprFlag (externallyVisibleCLabel label)
+  $$ pprWord (ppr label)
+  $$ pprWord (ppr $ mkAsmTempEndLabel label)
+  $$ pprByte 1
+  $$ pprByte dW_OP_call_frame_cfa
+  $$ parentValue
+  where
+    abbrev = case parent of Nothing -> DwAbbrSubprogram
+                            Just _  -> DwAbbrSubprogramWithParent
+    parentValue = maybe empty pprParentDie parent
+    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
+pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev DwAbbrBlockWithoutCode
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev DwAbbrBlock
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+  $$ pprWord (ppr marker)
+  $$ pprWord (ppr $ mkAsmTempEndLabel marker)
+pprDwarfInfoOpen _ (DwarfSrcNote ss) =
+  pprAbbrev DwAbbrGhcSrcNote
+  $$ pprString' (ftext $ srcSpanFile ss)
+  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
+  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
+  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
+  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)
+
+-- | Close a DWARF info record with children
+pprDwarfInfoClose :: SDoc
+pprDwarfInfoClose = pprAbbrev DwAbbrNull
+
+-- | A DWARF address range. This is used by the debugger to quickly locate
+-- which compilation unit a given address belongs to. This type assumes
+-- a non-segmented address-space.
+data DwarfARange
+  = DwarfARange
+    { dwArngStartLabel :: CLabel
+    , dwArngEndLabel   :: CLabel
+    }
+
+-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
+-- address table entry.
+pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
+pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
+  let wordSize = platformWordSize plat
+      paddingSize = 4 :: Int
+      -- header is 12 bytes long.
+      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
+      -- pad such that first entry begins at multiple of entry size.
+      pad n = vcat $ replicate n $ pprByte 0
+      initialLength = 8 + paddingSize + 2*2*wordSize
+  in pprDwWord (ppr initialLength)
+     $$ pprHalf 2
+     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
+                      (ptext dwarfInfoLabel)
+     $$ pprByte (fromIntegral wordSize)
+     $$ pprByte 0
+     $$ pad paddingSize
+     -- body
+     $$ vcat (map pprDwarfARange arngs)
+     -- terminus
+     $$ pprWord (char '0')
+     $$ pprWord (char '0')
+
+pprDwarfARange :: DwarfARange -> SDoc
+pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
+  where
+    length = ppr (dwArngEndLabel arng)
+             <> char '-' <> ppr (dwArngStartLabel arng)
+
+-- | Information about unwind instructions for a procedure. This
+-- corresponds to a "Common Information Entry" (CIE) in DWARF.
+data DwarfFrame
+  = DwarfFrame
+    { dwCieLabel :: CLabel
+    , dwCieInit  :: UnwindTable
+    , dwCieProcs :: [DwarfFrameProc]
+    }
+
+-- | Unwind instructions for an individual procedure. Corresponds to a
+-- "Frame Description Entry" (FDE) in DWARF.
+data DwarfFrameProc
+  = DwarfFrameProc
+    { dwFdeProc    :: CLabel
+    , dwFdeHasInfo :: Bool
+    , dwFdeBlocks  :: [DwarfFrameBlock]
+      -- ^ List of blocks. Order must match asm!
+    }
+
+-- | Unwind instructions for a block. Will become part of the
+-- containing FDE.
+data DwarfFrameBlock
+  = DwarfFrameBlock
+    { dwFdeBlkHasInfo :: Bool
+    , dwFdeUnwind     :: [UnwindPoint]
+      -- ^ these unwind points must occur in the same order as they occur
+      -- in the block
+    }
+
+instance Outputable DwarfFrameBlock where
+  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds
+
+-- | Header for the @.debug_frame@ section. Here we emit the "Common
+-- Information Entry" record that etablishes general call frame
+-- parameters and the default stack layout.
+pprDwarfFrame :: DwarfFrame -> SDoc
+pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
+  = sdocWithPlatform $ \plat ->
+    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
+        cieEndLabel = mkAsmTempEndLabel cieLabel
+        length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
+        spReg       = dwarfGlobalRegNo plat Sp
+        retReg      = dwarfReturnRegNo plat
+        wordSize    = platformWordSize plat
+        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
+        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
+
+        -- Preserve C stack pointer: This necessary to override that default
+        -- unwinding behavior of setting $sp = CFA.
+        preserveSp = case platformArch plat of
+          ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4
+          ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
+          _          -> empty
+    in vcat [ ppr cieLabel <> colon
+            , pprData4' length -- Length of CIE
+            , ppr cieStartLabel <> colon
+            , pprData4' (text "-1")
+                               -- Common Information Entry marker (-1 = 0xf..f)
+            , pprByte 3        -- CIE version (we require DWARF 3)
+            , pprByte 0        -- Augmentation (none)
+            , pprByte 1        -- Code offset multiplicator
+            , pprByte (128-fromIntegral wordSize)
+                               -- Data offset multiplicator
+                               -- (stacks grow down => "-w" in signed LEB128)
+            , pprByte retReg   -- virtual register holding return address
+            ] $$
+       -- Initial unwind table
+       vcat (map pprInit $ Map.toList cieInit) $$
+       vcat [ -- RET = *CFA
+              pprByte (dW_CFA_offset+retReg)
+            , pprByte 0
+
+              -- Preserve C stack pointer
+            , preserveSp
+
+              -- Sp' = CFA
+              -- (we need to set this manually as our (STG) Sp register is
+              -- often not the architecture's default stack register)
+            , pprByte dW_CFA_val_offset
+            , pprLEBWord (fromIntegral spReg)
+            , pprLEBWord 0
+            ] $$
+       wordAlign $$
+       ppr cieEndLabel <> colon $$
+       -- Procedure unwind tables
+       vcat (map (pprFrameProc cieLabel cieInit) procs)
+
+-- | Writes a "Frame Description Entry" for a procedure. This consists
+-- mainly of referencing the CIE and writing state machine
+-- instructions to describe how the frame base (CFA) changes.
+pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
+pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
+  = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
+        fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
+        procEnd     = mkAsmTempEndLabel procLbl
+        ifInfo str  = if hasInfo then text str else empty
+                      -- see [Note: Info Offset]
+    in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
+            , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
+            , ppr fdeLabel <> colon
+            , pprData4' (ppr frameLbl <> char '-' <>
+                         ptext dwarfFrameLabel)    -- Reference to CIE
+            , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer
+            , pprWord (ppr procEnd <> char '-' <>
+                       ppr procLbl <> ifInfo "+1") -- Block byte length
+            ] $$
+       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
+       wordAlign $$
+       ppr fdeEndLabel <> colon
+
+-- | Generates unwind information for a block. We only generate
+-- instructions where unwind information actually changes. This small
+-- optimisations saves a lot of space, as subsequent blocks often have
+-- the same unwind information.
+pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
+pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
+    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
+  where
+    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
+    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
+        let -- Did a register's unwind expression change?
+            isChanged :: GlobalReg -> Maybe UnwindExpr
+                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
+            isChanged g new
+                -- the value didn't change
+              | Just new == old = Nothing
+                -- the value was and still is undefined
+              | Nothing <- old
+              , Nothing <- new  = Nothing
+                -- the value changed
+              | otherwise       = Just (join old, new)
+              where
+                old = Map.lookup g oldUws
+
+            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
+
+        in if oldUws == uws
+             then (empty, oldUws)
+             else let -- see [Note: Info Offset]
+                      needsOffset = firstDecl && hasInfo
+                      lblDoc = ppr lbl <>
+                               if needsOffset then text "-1" else empty
+                      doc = sdocWithPlatform $ \plat ->
+                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
+                           vcat (map (uncurry $ pprSetUnwind plat) changed)
+                  in (doc, uws)
+
+-- Note [Info Offset]
+--
+-- GDB was pretty much written with C-like programs in mind, and as a
+-- result they assume that once you have a return address, it is a
+-- good idea to look at (PC-1) to unwind further - as that's where the
+-- "call" instruction is supposed to be.
+--
+-- Now on one hand, code generated by GHC looks nothing like what GDB
+-- expects, and in fact going up from a return pointer is guaranteed
+-- to land us inside an info table! On the other hand, that actually
+-- gives us some wiggle room, as we expect IP to never *actually* end
+-- up inside the info table, so we can "cheat" by putting whatever GDB
+-- expects to see there. This is probably pretty safe, as GDB cannot
+-- assume (PC-1) to be a valid code pointer in the first place - and I
+-- have seen no code trying to correct this.
+--
+-- Note that this will not prevent GDB from failing to look-up the
+-- correct function name for the frame, as that uses the symbol table,
+-- which we can not manipulate as easily.
+--
+-- There's a GDB patch to address this at [1]. At the moment of writing
+-- it's not merged, so I recommend building GDB with the patch if you
+-- care about unwinding. The hack above doesn't cover every case.
+--
+-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html
+
+-- | Get DWARF register ID for a given GlobalReg
+dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
+dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
+dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
+
+-- | Generate code for setting the unwind information for a register,
+-- optimized using its known old value in the table. Note that "Sp" is
+-- special: We see it as synonym for the CFA.
+pprSetUnwind :: Platform
+             -> GlobalReg
+                -- ^ the register to produce an unwinding table entry for
+             -> (Maybe UnwindExpr, Maybe UnwindExpr)
+                -- ^ the old and new values of the register
+             -> SDoc
+pprSetUnwind plat g  (_, Nothing)
+  = pprUndefUnwind plat g
+pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
+  = if o' >= 0
+    then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
+    else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
+pprSetUnwind plat Sp (_, Just (UwReg s' o'))
+  = if o' >= 0
+    then pprByte dW_CFA_def_cfa $$
+         pprLEBRegNo plat s' $$
+         pprLEBWord (fromIntegral o')
+    else pprByte dW_CFA_def_cfa_sf $$
+         pprLEBRegNo plat s' $$
+         pprLEBInt o'
+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
+  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
+    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
+  | otherwise
+  = pprByte dW_CFA_offset_extended_sf $$
+    pprLEBRegNo plat g $$
+    pprLEBInt o
+pprSetUnwind plat g  (_, Just (UwDeref uw))
+  = pprByte dW_CFA_expression $$
+    pprLEBRegNo plat g $$
+    pprUnwindExpr True uw
+pprSetUnwind plat g  (_, Just (UwReg g' 0))
+  | g == g'
+  = pprByte dW_CFA_same_value $$
+    pprLEBRegNo plat g
+pprSetUnwind plat g  (_, Just uw)
+  = pprByte dW_CFA_val_expression $$
+    pprLEBRegNo plat g $$
+    pprUnwindExpr True uw
+
+-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
+-- encoded number.
+pprLEBRegNo :: Platform -> GlobalReg -> SDoc
+pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
+
+-- | Generates a DWARF expression for the given unwind expression. If
+-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
+-- mentioned.
+pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
+pprUnwindExpr spIsCFA expr
+  = sdocWithPlatform $ \plat ->
+    let pprE (UwConst i)
+          | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
+          | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
+        pprE (UwReg Sp i) | spIsCFA
+                             = if i == 0
+                               then pprByte dW_OP_call_frame_cfa
+                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))
+        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
+                               pprLEBInt i
+        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
+        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)
+        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
+        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
+        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
+    in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
+       -- computed as the difference of the following local labels 2: and 1:
+       text "1:" $$
+       pprE expr $$
+       text "2:"
+
+-- | Generate code for re-setting the unwind information for a
+-- register to @undefined@
+pprUndefUnwind :: Platform -> GlobalReg -> SDoc
+pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$
+                         pprLEBRegNo plat g
+
+
+-- | Align assembly at (machine) word boundary
+wordAlign :: SDoc
+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)
+
+-- | Assembly for a single byte of constant DWARF data
+pprByte :: Word8 -> SDoc
+pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
+
+-- | Assembly for a two-byte constant integer
+pprHalf :: Word16 -> SDoc
+pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)
+
+-- | Assembly for a constant DWARF flag
+pprFlag :: Bool -> SDoc
+pprFlag f = pprByte (if f then 0xff else 0x00)
+
+-- | Assembly for 4 bytes of dynamic DWARF data
+pprData4' :: SDoc -> SDoc
+pprData4' x = text "\t.long " <> x
+
+-- | Assembly for 4 bytes of constant DWARF data
+pprData4 :: Word -> SDoc
+pprData4 = pprData4' . ppr
+
+-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
+-- we are generating 32 bit DWARF.
+pprDwWord :: SDoc -> SDoc
+pprDwWord = pprData4'
+
+-- | Assembly for a machine word of dynamic data. Depends on the
+-- architecture we are currently generating code for.
+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 ++ "!"
+
+-- | Prints a number in "little endian base 128" format. The idea is
+-- to optimize for small numbers by stopping once all further bytes
+-- would be 0. The highest bit in every byte signals whether there
+-- are further bytes to read.
+pprLEBWord :: Word -> SDoc
+pprLEBWord x | x < 128   = pprByte (fromIntegral x)
+             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
+                           pprLEBWord (x `shiftR` 7)
+
+-- | Same as @pprLEBWord@, but for a signed number
+pprLEBInt :: Int -> SDoc
+pprLEBInt x | x >= -64 && x < 64
+                        = pprByte (fromIntegral (x .&. 127))
+            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
+                          pprLEBInt (x `shiftR` 7)
+
+-- | Generates a dynamic null-terminated string. If required the
+-- caller needs to make sure that the string is escaped properly.
+pprString' :: SDoc -> SDoc
+pprString' str = text "\t.asciz \"" <> str <> char '"'
+
+-- | Generate a string constant. We take care to escape the string.
+pprString :: String -> SDoc
+pprString str
+  = pprString' $ hcat $ map escapeChar $
+    if str `lengthIs` utf8EncodedLength str
+    then str
+    else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str
+
+-- | Escape a single non-unicode character
+escapeChar :: Char -> SDoc
+escapeChar '\\' = text "\\\\"
+escapeChar '\"' = text "\\\""
+escapeChar '\n' = text "\\n"
+escapeChar c
+  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
+  = char c
+  | otherwise
+  = char '\\' <> char (intToDigit (ch `div` 64)) <>
+                 char (intToDigit ((ch `div` 8) `mod` 8)) <>
+                 char (intToDigit (ch `mod` 8))
+  where ch = ord c
+
+-- | Generate an offset into another section. This is tricky because
+-- this is handled differently depending on platform: Mac Os expects
+-- us to calculate the offset using assembler arithmetic. Linux expects
+-- us to just reference the target directly, and will figure out on
+-- their own that we actually need an offset. Finally, Windows has
+-- a special directive to refer to relative offsets. Fun.
+sectionOffset :: SDoc -> SDoc -> SDoc
+sectionOffset target section = sdocWithPlatform $ \plat ->
+  case platformOS plat of
+    OSDarwin  -> pprDwWord (target <> char '-' <> section)
+    OSMinGW32 -> text "\t.secrel32 " <> target
+    _other    -> pprDwWord target
diff --git a/compiler/nativeGen/Format.hs b/compiler/nativeGen/Format.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Format.hs
@@ -0,0 +1,105 @@
+-- | Formats on this architecture
+--      A Format is a combination of width and class
+--
+--      TODO:   Signed vs unsigned?
+--
+--      TODO:   This module is currenly shared by all architectures because
+--              NCGMonad need to know about it to make a VReg. It would be better
+--              to have architecture specific formats, and do the overloading
+--              properly. eg SPARC doesn't care about FF80.
+--
+module Format (
+    Format(..),
+    intFormat,
+    floatFormat,
+    isFloatFormat,
+    cmmTypeFormat,
+    formatToWidth,
+    formatInBytes
+)
+
+where
+
+import GhcPrelude
+
+import Cmm
+import Outputable
+
+-- It looks very like the old MachRep, but it's now of purely local
+-- significance, here in the native code generator.  You can change it
+-- without global consequences.
+--
+-- A major use is as an opcode qualifier; thus the opcode
+--      mov.l a b
+-- might be encoded
+--      MOV II32 a b
+-- where the Format field encodes the ".l" part.
+
+-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats
+--        here.  I've removed them from the x86 version, we'll see what happens --SDM
+
+-- ToDo: quite a few occurrences of Format could usefully be replaced by Width
+
+data Format
+        = II8
+        | II16
+        | II32
+        | II64
+        | FF32
+        | FF64
+        deriving (Show, Eq)
+
+
+-- | Get the integer format of this width.
+intFormat :: Width -> Format
+intFormat width
+ = case width of
+        W8      -> II8
+        W16     -> II16
+        W32     -> II32
+        W64     -> II64
+        other   -> sorry $ "The native code generator cannot " ++
+            "produce code for Format.intFormat " ++ show other
+            ++ "\n\tConsider using the llvm backend with -fllvm"
+
+
+-- | Get the float format of this width.
+floatFormat :: Width -> Format
+floatFormat width
+ = case width of
+        W32     -> FF32
+        W64     -> FF64
+
+        other   -> pprPanic "Format.floatFormat" (ppr other)
+
+
+-- | Check if a format represents a floating point value.
+isFloatFormat :: Format -> Bool
+isFloatFormat format
+ = case format of
+        FF32    -> True
+        FF64    -> True
+        _       -> False
+
+
+-- | Convert a Cmm type to a Format.
+cmmTypeFormat :: CmmType -> Format
+cmmTypeFormat ty
+        | isFloatType ty        = floatFormat (typeWidth ty)
+        | otherwise             = intFormat (typeWidth ty)
+
+
+-- | Get the Width of a Format.
+formatToWidth :: Format -> Width
+formatToWidth format
+ = case format of
+        II8             -> W8
+        II16            -> W16
+        II32            -> W32
+        II64            -> W64
+        FF32            -> W32
+        FF64            -> W64
+
+
+formatInBytes :: Format -> Int
+formatInBytes = widthInBytes . formatToWidth
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Instruction.hs
@@ -0,0 +1,202 @@
+
+module Instruction (
+        RegUsage(..),
+        noUsage,
+        GenBasicBlock(..), blockId,
+        ListGraph(..),
+        NatCmm,
+        NatCmmDecl,
+        NatBasicBlock,
+        topInfoTable,
+        entryBlocks,
+        Instruction(..)
+)
+
+where
+
+import GhcPrelude
+
+import Reg
+
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import DynFlags
+import Cmm hiding (topInfoTable)
+import Platform
+
+-- | Holds a list of source and destination registers used by a
+--      particular instruction.
+--
+--   Machine registers that are pre-allocated to stgRegs are filtered
+--      out, because they are uninteresting from a register allocation
+--      standpoint.  (We wouldn't want them to end up on the free list!)
+--
+--   As far as we are concerned, the fixed registers simply don't exist
+--      (for allocation purposes, anyway).
+--
+data RegUsage
+        = RU [Reg] [Reg]
+
+-- | No regs read or written to.
+noUsage :: RegUsage
+noUsage  = RU [] []
+
+-- Our flavours of the Cmm types
+-- Type synonyms for Cmm populated with native code
+type NatCmm instr
+        = GenCmmGroup
+                CmmStatics
+                (LabelMap CmmStatics)
+                (ListGraph instr)
+
+type NatCmmDecl statics instr
+        = GenCmmDecl
+                statics
+                (LabelMap CmmStatics)
+                (ListGraph instr)
+
+
+type NatBasicBlock instr
+        = GenBasicBlock instr
+
+
+-- | Returns the info table associated with the CmmDecl's entry point,
+-- if any.
+topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i
+topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
+  = mapLookup (blockId b) infos
+topInfoTable _
+  = Nothing
+
+-- | Return the list of BlockIds in a CmmDecl that are entry points
+-- for this proc (i.e. they may be jumped to from outside this proc).
+entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
+entryBlocks (CmmProc info _ _ (ListGraph code)) = entries
+  where
+        infos = mapKeys info
+        entries = case code of
+                    [] -> infos
+                    BasicBlock entry _ : _ -- first block is the entry point
+                       | entry `elem` infos -> infos
+                       | otherwise          -> entry : infos
+entryBlocks _ = []
+
+-- | Common things that we can do with instructions, on all architectures.
+--      These are used by the shared parts of the native code generator,
+--      specifically the register allocators.
+--
+class   Instruction instr where
+
+        -- | Get the registers that are being used by this instruction.
+        --      regUsage doesn't need to do any trickery for jumps and such.
+        --      Just state precisely the regs read and written by that insn.
+        --      The consequences of control flow transfers, as far as register
+        --      allocation goes, are taken care of by the register allocator.
+        --
+        regUsageOfInstr
+                :: Platform
+                -> instr
+                -> RegUsage
+
+
+        -- | Apply a given mapping to all the register references in this
+        --      instruction.
+        patchRegsOfInstr
+                :: instr
+                -> (Reg -> Reg)
+                -> instr
+
+
+        -- | Checks whether this instruction is a jump/branch instruction.
+        --      One that can change the flow of control in a way that the
+        --      register allocator needs to worry about.
+        isJumpishInstr
+                :: instr -> Bool
+
+
+        -- | Give the possible destinations of this jump instruction.
+        --      Must be defined for all jumpish instructions.
+        jumpDestsOfInstr
+                :: instr -> [BlockId]
+
+
+        -- | Change the destination of this jump instruction.
+        --      Used in the linear allocator when adding fixup blocks for join
+        --      points.
+        patchJumpInstr
+                :: instr
+                -> (BlockId -> BlockId)
+                -> instr
+
+
+        -- | An instruction to spill a register into a spill slot.
+        mkSpillInstr
+                :: DynFlags
+                -> Reg          -- ^ the reg to spill
+                -> Int          -- ^ the current stack delta
+                -> Int          -- ^ spill slot to use
+                -> instr
+
+
+        -- | An instruction to reload a register from a spill slot.
+        mkLoadInstr
+                :: DynFlags
+                -> Reg          -- ^ the reg to reload.
+                -> Int          -- ^ the current stack delta
+                -> Int          -- ^ the spill slot to use
+                -> instr
+
+        -- | See if this instruction is telling us the current C stack delta
+        takeDeltaInstr
+                :: instr
+                -> Maybe Int
+
+        -- | Check whether this instruction is some meta thing inserted into
+        --      the instruction stream for other purposes.
+        --
+        --      Not something that has to be treated as a real machine instruction
+        --      and have its registers allocated.
+        --
+        --      eg, comments, delta, ldata, etc.
+        isMetaInstr
+                :: instr
+                -> Bool
+
+
+
+        -- | Copy the value in a register to another one.
+        --      Must work for all register classes.
+        mkRegRegMoveInstr
+                :: Platform
+                -> Reg          -- ^ source register
+                -> Reg          -- ^ destination register
+                -> instr
+
+        -- | Take the source and destination from this reg -> reg move instruction
+        --      or Nothing if it's not one
+        takeRegRegMoveInstr
+                :: instr
+                -> Maybe (Reg, Reg)
+
+        -- | Make an unconditional jump instruction.
+        --      For architectures with branch delay slots, its ok to put
+        --      a NOP after the jump. Don't fill the delay slot with an
+        --      instruction that references regs or you'll confuse the
+        --      linear allocator.
+        mkJumpInstr
+                :: BlockId
+                -> [instr]
+
+
+        -- Subtract an amount from the C stack pointer
+        mkStackAllocInstr
+                :: Platform
+                -> Int
+                -> [instr]
+
+        -- Add an amount to the C stack pointer
+        mkStackDeallocInstr
+                :: Platform
+                -> Int
+                -> [instr]
diff --git a/compiler/nativeGen/NCG.h b/compiler/nativeGen/NCG.h
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/NCG.h
@@ -0,0 +1,11 @@
+/* -----------------------------------------------------------------------------
+
+   (c) The University of Glasgow, 1994-2004
+
+   Native-code generator header file - just useful macros for now.
+
+   -------------------------------------------------------------------------- */
+
+#pragma once
+
+#include "ghc_boot_platform.h"
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE CPP #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-- The native code generator's monad.
+--
+-- -----------------------------------------------------------------------------
+
+module NCGMonad (
+        NcgImpl(..),
+        NatM_State(..), mkNatM_State,
+
+        NatM, -- instance Monad
+        initNat,
+        addImportNat,
+        addNodeBetweenNat,
+        addImmediateSuccessorNat,
+        updateCfgNat,
+        getUniqueNat,
+        mapAccumLNat,
+        setDeltaNat,
+        getDeltaNat,
+        getThisModuleNat,
+        getBlockIdNat,
+        getNewLabelNat,
+        getNewRegNat,
+        getNewRegPairNat,
+        getPicBaseMaybeNat,
+        getPicBaseNat,
+        getDynFlags,
+        getModLoc,
+        getFileId,
+        getDebugBlock,
+
+        DwarfFiles
+)
+
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Reg
+import Format
+import TargetReg
+
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import CLabel           ( CLabel )
+import Debug
+import FastString       ( FastString )
+import UniqFM
+import UniqSupply
+import Unique           ( Unique )
+import DynFlags
+import Module
+
+import Control.Monad    ( liftM, ap )
+
+import Instruction
+import Outputable (SDoc, pprPanic, ppr)
+import Cmm (RawCmmDecl, CmmStatics)
+import CFG
+
+data NcgImpl statics instr jumpDest = NcgImpl {
+    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
+    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
+    canShortcut               :: instr -> Maybe jumpDest,
+    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
+    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
+    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
+    maxSpillSlots             :: Int,
+    allocatableRegs           :: [RealReg],
+    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr
+                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
+    -- ^ The list of block ids records the redirected jumps to allow us to update
+    -- the CFG.
+    ncgMakeFarBranches        :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
+    extractUnwindPoints       :: [instr] -> [UnwindPoint],
+    -- ^ given the instruction sequence of a block, produce a list of
+    -- the block's 'UnwindPoint's
+    -- See Note [What is this unwinding business?] in Debug
+    -- and Note [Unwinding information in the NCG] in this module.
+    invertCondBranches        :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
+                              -> [NatBasicBlock instr]
+    -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
+    -- when possible.
+    }
+
+data NatM_State
+        = NatM_State {
+                natm_us          :: UniqSupply,
+                natm_delta       :: Int,
+                natm_imports     :: [(CLabel)],
+                natm_pic         :: Maybe Reg,
+                natm_dflags      :: DynFlags,
+                natm_this_module :: Module,
+                natm_modloc      :: ModLocation,
+                natm_fileid      :: DwarfFiles,
+                natm_debug_map   :: LabelMap DebugBlock,
+                natm_cfg         :: CFG
+        -- ^ Having a CFG with additional information is essential for some
+        -- operations. However we can't reconstruct all information once we
+        -- generated instructions. So instead we update the CFG as we go.
+        }
+
+type DwarfFiles = UniqFM (FastString, Int)
+
+newtype NatM result = NatM (NatM_State -> (result, NatM_State))
+
+unNat :: NatM a -> NatM_State -> (a, NatM_State)
+unNat (NatM a) = a
+
+mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
+                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
+mkNatM_State us delta dflags this_mod
+        = \loc dwf dbg cfg ->
+                NatM_State
+                        { natm_us = us
+                        , natm_delta = delta
+                        , natm_imports = []
+                        , natm_pic = Nothing
+                        , natm_dflags = dflags
+                        , natm_this_module = this_mod
+                        , natm_modloc = loc
+                        , natm_fileid = dwf
+                        , natm_debug_map = dbg
+                        , natm_cfg = cfg
+                        }
+
+initNat :: NatM_State -> NatM a -> (a, NatM_State)
+initNat init_st m
+        = case unNat m init_st of { (r,st) -> (r,st) }
+
+instance Functor NatM where
+      fmap = liftM
+
+instance Applicative NatM where
+      pure = returnNat
+      (<*>) = ap
+
+instance Monad NatM where
+  (>>=) = thenNat
+
+instance MonadUnique NatM where
+  getUniqueSupplyM = NatM $ \st ->
+      case splitUniqSupply (natm_us st) of
+          (us1, us2) -> (us1, st {natm_us = us2})
+
+  getUniqueM = NatM $ \st ->
+      case takeUniqFromSupply (natm_us st) of
+          (uniq, us') -> (uniq, st {natm_us = us'})
+
+thenNat :: NatM a -> (a -> NatM b) -> NatM b
+thenNat expr cont
+        = NatM $ \st -> case unNat expr st of
+                        (result, st') -> unNat (cont result) st'
+
+returnNat :: a -> NatM a
+returnNat result
+        = NatM $ \st ->  (result, st)
+
+mapAccumLNat :: (acc -> x -> NatM (acc, y))
+                -> acc
+                -> [x]
+                -> NatM (acc, [y])
+
+mapAccumLNat _ b []
+  = return (b, [])
+mapAccumLNat f b (x:xs)
+  = do (b__2, x__2)  <- f b x
+       (b__3, xs__2) <- mapAccumLNat f b__2 xs
+       return (b__3, x__2:xs__2)
+
+getUniqueNat :: NatM Unique
+getUniqueNat = NatM $ \ st ->
+    case takeUniqFromSupply $ natm_us st of
+    (uniq, us') -> (uniq, st {natm_us = us'})
+
+instance HasDynFlags NatM where
+    getDynFlags = NatM $ \ st -> (natm_dflags st, st)
+
+
+getDeltaNat :: NatM Int
+getDeltaNat = NatM $ \ st -> (natm_delta st, st)
+
+
+setDeltaNat :: Int -> NatM ()
+setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
+
+
+getThisModuleNat :: NatM Module
+getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)
+
+
+addImportNat :: CLabel -> NatM ()
+addImportNat imp
+        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
+
+updateCfgNat :: (CFG -> CFG) -> NatM ()
+updateCfgNat f
+        = NatM $ \ st -> ((), st { natm_cfg = f (natm_cfg st) })
+
+-- | Record that we added a block between `from` and `old`.
+addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
+addNodeBetweenNat from between to
+ = do   df <- getDynFlags
+        let jmpWeight = fromIntegral . uncondWeight .
+                        cfgWeightInfo $ df
+        updateCfgNat (updateCfg jmpWeight from between to)
+  where
+    -- When transforming A -> B to A -> A' -> B
+    -- A -> A' keeps the old edge info while
+    -- A' -> B gets the info for an unconditional
+    -- jump.
+    updateCfg weight from between old m
+        | Just info <- getEdgeInfo from old m
+        = addEdge from between info .
+          addWeightEdge between old weight .
+          delEdge from old $ m
+        | otherwise
+        = pprPanic "Faild to update cfg: Untracked edge" (ppr (from,to))
+
+
+-- | Place `succ` after `block` and change any edges
+--   block -> X to `succ` -> X
+addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
+addImmediateSuccessorNat block succ
+        = updateCfgNat (addImmediateSuccessor block succ)
+
+getBlockIdNat :: NatM BlockId
+getBlockIdNat
+ = do   u <- getUniqueNat
+        return (mkBlockId u)
+
+
+getNewLabelNat :: NatM CLabel
+getNewLabelNat
+ = blockLbl <$> getBlockIdNat
+
+
+getNewRegNat :: Format -> NatM Reg
+getNewRegNat rep
+ = do u <- getUniqueNat
+      dflags <- getDynFlags
+      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
+
+
+getNewRegPairNat :: Format -> NatM (Reg,Reg)
+getNewRegPairNat rep
+ = do u <- getUniqueNat
+      dflags <- getDynFlags
+      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
+      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
+      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
+      return (lo, hi)
+
+
+getPicBaseMaybeNat :: NatM (Maybe Reg)
+getPicBaseMaybeNat
+        = NatM (\state -> (natm_pic state, state))
+
+
+getPicBaseNat :: Format -> NatM Reg
+getPicBaseNat rep
+ = do   mbPicBase <- getPicBaseMaybeNat
+        case mbPicBase of
+                Just picBase -> return picBase
+                Nothing
+                 -> do
+                        reg <- getNewRegNat rep
+                        NatM (\state -> (reg, state { natm_pic = Just reg }))
+
+getModLoc :: NatM ModLocation
+getModLoc
+        = NatM $ \ st -> (natm_modloc st, st)
+
+getFileId :: FastString -> NatM Int
+getFileId f = NatM $ \st ->
+  case lookupUFM (natm_fileid st) f of
+    Just (_,n) -> (n, st)
+    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)
+                      fids = addToUFM (natm_fileid st) f (f,n)
+                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })
+
+getDebugBlock :: Label -> NatM (Maybe DebugBlock)
+getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PIC.hs
@@ -0,0 +1,838 @@
+{-
+  This module handles generation of position independent code and
+  dynamic-linking related issues for the native code generator.
+
+  This depends both the architecture and OS, so we define it here
+  instead of in one of the architecture specific modules.
+
+  Things outside this module which are related to this:
+
+  + module CLabel
+    - PIC base label (pretty printed as local label 1)
+    - DynamicLinkerLabels - several kinds:
+        CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset
+    - labelDynamic predicate
+  + module Cmm
+    - The GlobalReg datatype has a PicBaseReg constructor
+    - The CmmLit datatype has a CmmLabelDiffOff constructor
+  + codeGen & RTS
+    - When tablesNextToCode, no absolute addresses are stored in info tables
+      any more. Instead, offsets from the info label are used.
+    - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers
+      because Win32 doesn't support external references in data sections.
+      TODO: make sure this still works, it might be bitrotted
+  + NCG
+    - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all
+      labels.
+    - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output
+      all the necessary stuff for imported symbols.
+    - The NCG monad keeps track of a list of imported symbols.
+    - MachCodeGen invokes initializePicBase to generate code to initialize
+      the PIC base register when needed.
+    - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel
+      that wasn't in the original Cmm code (e.g. floating point literals).
+-}
+
+module PIC (
+        cmmMakeDynamicReference,
+        CmmMakeDynamicReferenceM(..),
+        ReferenceKind(..),
+        needImportedSymbols,
+        pprImportedSymbol,
+        pprGotDeclaration,
+
+        initializePicBase_ppc,
+        initializePicBase_x86
+)
+
+where
+
+import GhcPrelude
+
+import qualified PPC.Instr      as PPC
+import qualified PPC.Regs       as PPC
+
+import qualified X86.Instr      as X86
+
+import Platform
+import Instruction
+import Reg
+import NCGMonad
+
+
+import Hoopl.Collections
+import Cmm
+import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
+                          mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
+                          dynamicLinkerLabelInfo, mkPicBaseLabel,
+                          labelDynamic, externallyVisibleCLabel )
+
+import CLabel           ( mkForeignLabel )
+
+
+import BasicTypes
+import Module
+
+import Outputable
+
+import DynFlags
+import FastString
+
+
+
+--------------------------------------------------------------------------------
+-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm
+-- code. It does The Right Thing(tm) to convert the CmmLabel into a
+-- position-independent, dynamic-linking-aware reference to the thing
+-- in question.
+-- Note that this also has to be called from MachCodeGen in order to
+-- access static data like floating point literals (labels that were
+-- created after the cmmToCmm pass).
+-- The function must run in a monad that can keep track of imported symbols
+-- A function for recording an imported symbol must be passed in:
+-- - addImportCmmOpt for the CmmOptM monad
+-- - addImportNat for the NatM monad.
+
+data ReferenceKind
+        = DataReference
+        | CallReference
+        | JumpReference
+        deriving(Eq)
+
+class Monad m => CmmMakeDynamicReferenceM m where
+    addImport :: CLabel -> m ()
+    getThisModule :: m Module
+
+instance CmmMakeDynamicReferenceM NatM where
+    addImport = addImportNat
+    getThisModule = getThisModuleNat
+
+cmmMakeDynamicReference
+  :: CmmMakeDynamicReferenceM m
+  => DynFlags
+  -> ReferenceKind     -- whether this is the target of a jump
+  -> CLabel            -- the label
+  -> m CmmExpr
+
+cmmMakeDynamicReference dflags referenceKind lbl
+  | Just _ <- dynamicLinkerLabelInfo lbl
+  = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through
+
+  | otherwise
+  = do this_mod <- getThisModule
+       case howToAccessLabel
+                dflags
+                (platformArch $ targetPlatform dflags)
+                (platformOS   $ targetPlatform dflags)
+                this_mod
+                referenceKind lbl of
+
+        AccessViaStub -> do
+              let stub = mkDynamicLinkerLabel CodeStub lbl
+              addImport stub
+              return $ CmmLit $ CmmLabel stub
+
+        AccessViaSymbolPtr -> do
+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
+              addImport symbolPtr
+              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)
+
+        AccessDirectly -> case referenceKind of
+                -- for data, we might have to make some calculations:
+              DataReference -> return $ cmmMakePicReference dflags lbl
+                -- all currently supported processors support
+                -- PC-relative branch and call instructions,
+                -- so just jump there if it's a call or a jump
+              _ -> return $ CmmLit $ CmmLabel lbl
+
+
+-- -----------------------------------------------------------------------------
+-- Create a position independent reference to a label.
+-- (but do not bother with dynamic linking).
+-- We calculate the label's address by adding some (platform-dependent)
+-- offset to our base register; this offset is calculated by
+-- the function picRelative in the platform-dependent part below.
+
+cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr
+cmmMakePicReference dflags lbl
+
+        -- Windows doesn't need PIC,
+        -- everything gets relocated at runtime
+        | OSMinGW32 <- platformOS $ targetPlatform dflags
+        = CmmLit $ CmmLabel lbl
+
+        | OSAIX <- platformOS $ targetPlatform dflags
+        = CmmMachOp (MO_Add W32)
+                [ CmmReg (CmmGlobal PicBaseReg)
+                , CmmLit $ picRelative dflags
+                                (platformArch   $ targetPlatform dflags)
+                                (platformOS     $ targetPlatform dflags)
+                                lbl ]
+
+        -- both ABI versions default to medium code model
+        | ArchPPC_64 _ <- platformArch $ targetPlatform dflags
+        = CmmMachOp (MO_Add W32) -- code model medium
+                [ CmmReg (CmmGlobal PicBaseReg)
+                , CmmLit $ picRelative dflags
+                                (platformArch   $ targetPlatform dflags)
+                                (platformOS     $ targetPlatform dflags)
+                                lbl ]
+
+        | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)
+            && absoluteLabel lbl
+        = CmmMachOp (MO_Add (wordWidth dflags))
+                [ CmmReg (CmmGlobal PicBaseReg)
+                , CmmLit $ picRelative dflags
+                                (platformArch   $ targetPlatform dflags)
+                                (platformOS     $ targetPlatform dflags)
+                                lbl ]
+
+        | otherwise
+        = CmmLit $ CmmLabel lbl
+
+
+absoluteLabel :: CLabel -> Bool
+absoluteLabel lbl
+ = case dynamicLinkerLabelInfo lbl of
+        Just (GotSymbolPtr, _)    -> False
+        Just (GotSymbolOffset, _) -> False
+        _                         -> True
+
+
+--------------------------------------------------------------------------------
+-- Knowledge about how special dynamic linker labels like symbol
+-- pointers, code stubs and GOT offsets look like is located in the
+-- module CLabel.
+
+-- We have to decide which labels need to be accessed
+-- indirectly or via a piece of stub code.
+data LabelAccessStyle
+        = AccessViaStub
+        | AccessViaSymbolPtr
+        | AccessDirectly
+
+howToAccessLabel
+        :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle
+
+
+-- Windows
+-- In Windows speak, a "module" is a set of objects linked into the
+-- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs).
+--
+-- If we're compiling a multi-module program then symbols from other modules
+-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the
+-- following.
+--
+--   (in the local module)
+--     __imp_SYMBOL: addr of SYMBOL
+--
+--   (in the other module)
+--     SYMBOL: the real function / data.
+--
+-- To access the function at SYMBOL from our local module, we just need to
+-- dereference the local __imp_SYMBOL.
+--
+-- If not compiling with -dynamic we assume that all our code will be linked
+-- into the same .exe file. In this case we always access symbols directly,
+-- and never use __imp_SYMBOL.
+--
+howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl
+
+        -- Assume all symbols will be in the same PE, so just access them directly.
+        | not (gopt Opt_ExternalDynamicRefs dflags)
+        = AccessDirectly
+
+        -- If the target symbol is in another PE we need to access it via the
+        --      appropriate __imp_SYMBOL pointer.
+        | labelDynamic dflags this_mod lbl
+        = AccessViaSymbolPtr
+
+        -- Target symbol is in the same PE as the caller, so just access it directly.
+        | otherwise
+        = AccessDirectly
+
+
+-- Mach-O (Darwin, Mac OS X)
+--
+-- Indirect access is required in the following cases:
+--  * things imported from a dynamic library
+--  * (not on x86_64) data from a different module, if we're generating PIC code
+-- It is always possible to access something indirectly,
+-- even when it's not necessary.
+--
+howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
+        -- data access to a dynamic library goes via a symbol pointer
+        | labelDynamic dflags this_mod lbl
+        = AccessViaSymbolPtr
+
+        -- when generating PIC code, all cross-module data references must
+        -- must go via a symbol pointer, too, because the assembler
+        -- cannot generate code for a label difference where one
+        -- label is undefined. Doesn't apply t x86_64.
+        -- Unfortunately, we don't know whether it's cross-module,
+        -- so we do it for all externally visible labels.
+        -- This is a slight waste of time and space, but otherwise
+        -- we'd need to pass the current Module all the way in to
+        -- this function.
+        | arch /= ArchX86_64
+        , positionIndependent dflags && externallyVisibleCLabel lbl
+        = AccessViaSymbolPtr
+
+        | otherwise
+        = AccessDirectly
+
+howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl
+        -- dyld code stubs don't work for tailcalls because the
+        -- stack alignment is only right for regular calls.
+        -- Therefore, we have to go via a symbol pointer:
+        | arch == ArchX86 || arch == ArchX86_64
+        , labelDynamic dflags this_mod lbl
+        = AccessViaSymbolPtr
+
+
+howToAccessLabel dflags arch OSDarwin this_mod _ lbl
+        -- Code stubs are the usual method of choice for imported code;
+        -- not needed on x86_64 because Apple's new linker, ld64, generates
+        -- them automatically.
+        | arch /= ArchX86_64
+        , labelDynamic dflags this_mod lbl
+        = AccessViaStub
+
+        | otherwise
+        = AccessDirectly
+
+
+----------------------------------------------------------------------------
+-- AIX
+
+-- quite simple (for now)
+howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl
+        = case kind of
+            DataReference -> AccessViaSymbolPtr
+            CallReference -> AccessDirectly
+            JumpReference -> AccessDirectly
+
+-- ELF (Linux)
+--
+-- ELF tries to pretend to the main application code that dynamic linking does
+-- not exist. While this may sound convenient, it tends to mess things up in
+-- very bad ways, so we have to be careful when we generate code for a non-PIE
+-- main program (-dynamic but no -fPIC).
+--
+-- Indirect access is required for references to imported symbols
+-- from position independent code. It is also required from the main program
+-- when dynamic libraries containing Haskell code are used.
+
+howToAccessLabel _ (ArchPPC_64 _) os _ kind _
+        | osElfTarget os
+        = case kind of
+          -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
+          DataReference -> AccessViaSymbolPtr
+          -- RTLD does not generate stubs for function descriptors
+          -- in tail calls. Create a symbol pointer and generate
+          -- the code to load the function descriptor at the call site.
+          JumpReference -> AccessViaSymbolPtr
+          -- regular calls are handled by the runtime linker
+          _             -> AccessDirectly
+
+howToAccessLabel dflags _ os _ _ _
+        -- no PIC -> the dynamic linker does everything for us;
+        --           if we don't dynamically link to Haskell code,
+        --           it actually manages to do so without messing things up.
+        | osElfTarget os
+        , not (positionIndependent dflags) &&
+          not (gopt Opt_ExternalDynamicRefs dflags)
+        = AccessDirectly
+
+howToAccessLabel dflags arch os this_mod DataReference lbl
+        | osElfTarget os
+        = case () of
+            -- A dynamic label needs to be accessed via a symbol pointer.
+          _ | labelDynamic dflags this_mod lbl
+            -> AccessViaSymbolPtr
+
+            -- For PowerPC32 -fPIC, we have to access even static data
+            -- via a symbol pointer (see below for an explanation why
+            -- PowerPC32 Linux is especially broken).
+            | arch == ArchPPC
+            , positionIndependent dflags
+            -> AccessViaSymbolPtr
+
+            | otherwise
+            -> AccessDirectly
+
+
+        -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:
+        --   on i386, the position-independent symbol stubs in the Procedure Linkage Table
+        --   require the address of the GOT to be loaded into register %ebx on entry.
+        --   The linker will take any reference to the symbol stub as a hint that
+        --   the label in question is a code label. When linking executables, this
+        --   will cause the linker to replace even data references to the label with
+        --   references to the symbol stub.
+
+        -- This leaves calling a (foreign) function from non-PIC code
+        -- (AccessDirectly, because we get an implicit symbol stub)
+        -- and calling functions from PIC code on non-i386 platforms (via a symbol stub)
+
+howToAccessLabel dflags arch os this_mod CallReference lbl
+        | osElfTarget os
+        , labelDynamic dflags this_mod lbl && not (positionIndependent dflags)
+        = AccessDirectly
+
+        | osElfTarget os
+        , arch /= ArchX86
+        , labelDynamic dflags this_mod lbl
+        , positionIndependent dflags
+        = AccessViaStub
+
+howToAccessLabel dflags _ os this_mod _ lbl
+        | osElfTarget os
+        = if labelDynamic dflags this_mod lbl
+            then AccessViaSymbolPtr
+            else AccessDirectly
+
+-- all other platforms
+howToAccessLabel dflags _ _ _ _ _
+        | not (positionIndependent dflags)
+        = AccessDirectly
+
+        | otherwise
+        = panic "howToAccessLabel: PIC not defined for this platform"
+
+
+
+-- -------------------------------------------------------------------
+-- | Says what we have to add to our 'PIC base register' in order to
+--      get the address of a label.
+
+picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit
+
+-- Darwin, but not x86_64:
+-- The PIC base register points to the PIC base label at the beginning
+-- of the current CmmDecl. We just have to use a label difference to
+-- get the offset.
+-- We have already made sure that all labels that are not from the current
+-- module are accessed indirectly ('as' can't calculate differences between
+-- undefined labels).
+picRelative dflags arch OSDarwin lbl
+        | arch /= ArchX86_64
+        = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)
+
+-- On AIX we use an indirect local TOC anchored by 'gotLabel'.
+-- This way we use up only one global TOC entry per compilation-unit
+-- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)
+picRelative dflags _ OSAIX lbl
+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
+
+-- PowerPC Linux:
+-- The PIC base register points to our fake GOT. Use a label difference
+-- to get the offset.
+-- We have made sure that *everything* is accessed indirectly, so this
+-- is only used for offsets from the GOT to symbol pointers inside the
+-- GOT.
+picRelative dflags ArchPPC os lbl
+        | osElfTarget os
+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
+
+
+-- Most Linux versions:
+-- The PIC base register points to the GOT. Use foo@got for symbol
+-- pointers, and foo@gotoff for everything else.
+-- Linux and Darwin on x86_64:
+-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,
+-- and a GotSymbolOffset label for other things.
+-- For reasons of tradition, the symbol offset label is written as a plain label.
+picRelative _ arch os lbl
+        | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)
+        = let   result
+                        | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'
+
+                        | otherwise
+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl
+
+          in    result
+
+picRelative _ _ _ _
+        = panic "PositionIndependentCode.picRelative undefined for this platform"
+
+
+
+--------------------------------------------------------------------------------
+
+needImportedSymbols :: DynFlags -> Arch -> OS -> Bool
+needImportedSymbols dflags arch os
+        | os    == OSDarwin
+        , arch  /= ArchX86_64
+        = True
+
+        | os    == OSAIX
+        = True
+
+        -- PowerPC Linux: -fPIC or -dynamic
+        | osElfTarget os
+        , arch  == ArchPPC
+        = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags
+
+        -- PowerPC 64 Linux: always
+        | osElfTarget os
+        , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2
+        = True
+
+        -- i386 (and others?): -dynamic but not -fPIC
+        | osElfTarget os
+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
+        = gopt Opt_ExternalDynamicRefs dflags &&
+          not (positionIndependent dflags)
+
+        | otherwise
+        = False
+
+-- gotLabel
+-- The label used to refer to our "fake GOT" from
+-- position-independent code.
+gotLabel :: CLabel
+gotLabel
+        -- HACK: this label isn't really foreign
+        = mkForeignLabel
+                (fsLit ".LCTOC1")
+                Nothing ForeignLabelInThisPackage IsData
+
+
+
+--------------------------------------------------------------------------------
+-- We don't need to declare any offset tables.
+-- However, for PIC on x86, we need a small helper function.
+pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc
+pprGotDeclaration dflags ArchX86 OSDarwin
+        | positionIndependent dflags
+        = vcat [
+                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
+                text ".weak_definition ___i686.get_pc_thunk.ax",
+                text ".private_extern ___i686.get_pc_thunk.ax",
+                text "___i686.get_pc_thunk.ax:",
+                text "\tmovl (%esp), %eax",
+                text "\tret" ]
+
+pprGotDeclaration _ _ OSDarwin
+        = empty
+
+-- Emit XCOFF TOC section
+pprGotDeclaration _ _ OSAIX
+        = vcat $ [ text ".toc"
+                 , text ".tc ghc_toc_table[TC],.LCTOC1"
+                 , text ".csect ghc_toc_table[RW]"
+                   -- See Note [.LCTOC1 in PPC PIC code]
+                 , text ".set .LCTOC1,$+0x8000"
+                 ]
+
+
+-- PPC 64 ELF v1 needs a Table Of Contents (TOC)
+pprGotDeclaration _ (ArchPPC_64 ELF_V1) _
+        = text ".section \".toc\",\"aw\""
+-- In ELF v2 we also need to tell the assembler that we want ABI
+-- version 2. This would normally be done at the top of the file
+-- right after a file directive, but I could not figure out how
+-- to do that.
+pprGotDeclaration _ (ArchPPC_64 ELF_V2) _
+        = vcat [ text ".abiversion 2",
+                 text ".section \".toc\",\"aw\""
+               ]
+
+-- Emit GOT declaration
+-- Output whatever needs to be output once per .s file.
+pprGotDeclaration dflags arch os
+        | osElfTarget os
+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
+        , not (positionIndependent dflags)
+        = empty
+
+        | osElfTarget os
+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
+        = vcat [
+                -- See Note [.LCTOC1 in PPC PIC code]
+                text ".section \".got2\",\"aw\"",
+                text ".LCTOC1 = .+32768" ]
+
+pprGotDeclaration _ _ _
+        = panic "pprGotDeclaration: no match"
+
+
+--------------------------------------------------------------------------------
+-- On Darwin, we have to generate our own stub code for lazy binding..
+-- For each processor architecture, there are two versions, one for PIC
+-- and one for non-PIC.
+--
+
+pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc
+pprImportedSymbol dflags (Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl
+        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
+        = case positionIndependent dflags of
+           False ->
+            vcat [
+                text ".symbol_stub",
+                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
+                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
+                    text "\tjmp *L" <> pprCLabel dflags lbl
+                        <> text "$lazy_ptr",
+                text "L" <> pprCLabel dflags lbl
+                    <> text "$stub_binder:",
+                    text "\tpushl $L" <> pprCLabel dflags lbl
+                        <> text "$lazy_ptr",
+                    text "\tjmp dyld_stub_binding_helper"
+            ]
+           True ->
+            vcat [
+                text ".section __TEXT,__picsymbolstub2,"
+                    <> text "symbol_stubs,pure_instructions,25",
+                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
+                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
+                    text "\tcall ___i686.get_pc_thunk.ax",
+                text "1:",
+                    text "\tmovl L" <> pprCLabel dflags lbl
+                        <> text "$lazy_ptr-1b(%eax),%edx",
+                    text "\tjmp *%edx",
+                text "L" <> pprCLabel dflags lbl
+                    <> text "$stub_binder:",
+                    text "\tlea L" <> pprCLabel dflags lbl
+                        <> text "$lazy_ptr-1b(%eax),%eax",
+                    text "\tpushl %eax",
+                    text "\tjmp dyld_stub_binding_helper"
+            ]
+          $+$ vcat [        text ".section __DATA, __la_sym_ptr"
+                    <> (if positionIndependent dflags then int 2 else int 3)
+                    <> text ",lazy_symbol_pointers",
+                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),
+                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
+                    text "\t.long L" <> pprCLabel dflags lbl
+                    <> text "$stub_binder"]
+
+        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+        = vcat [
+                text ".non_lazy_symbol_pointer",
+                char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",
+                text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
+                text "\t.long\t0"]
+
+        | otherwise
+        = empty
+
+
+pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
+        = empty
+
+-- XCOFF / AIX
+--
+-- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To
+-- workaround the limitation of a global TOC we use an indirect TOC
+-- with the label `ghc_toc_table`.
+--
+-- See also GCC's `-mminimal-toc` compilation mode or
+-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/
+--
+-- NB: No DSO-support yet
+
+pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl
+        = case dynamicLinkerLabelInfo importedLbl of
+            Just (SymbolPtr, lbl)
+              -> vcat [
+                   text "LC.." <> pprCLabel dflags lbl <> char ':',
+                   text "\t.long" <+> pprCLabel dflags lbl ]
+            _ -> empty
+
+-- ELF / Linux
+--
+-- In theory, we don't need to generate any stubs or symbol pointers
+-- by hand for Linux.
+--
+-- Reality differs from this in two areas.
+--
+-- 1) If we just use a dynamically imported symbol directly in a read-only
+--    section of the main executable (as GCC does), ld generates R_*_COPY
+--    relocations, which are fundamentally incompatible with reversed info
+--    tables. Therefore, we need a table of imported addresses in a writable
+--    section.
+--    The "official" GOT mechanism (label@got) isn't intended to be used
+--    in position dependent code, so we have to create our own "fake GOT"
+--    when not Opt_PIC && WayDyn `elem` ways dflags.
+--
+-- 2) PowerPC Linux is just plain broken.
+--    While it's theoretically possible to use GOT offsets larger
+--    than 16 bit, the standard crt*.o files don't, which leads to
+--    linker errors as soon as the GOT size exceeds 16 bit.
+--    Also, the assembler doesn't support @gotoff labels.
+--    In order to be able to use a larger GOT, we have to circumvent the
+--    entire GOT mechanism and do it ourselves (this is also what GCC does).
+
+
+-- When needImportedSymbols is defined,
+-- the NCG will keep track of all DynamicLinkerLabels it uses
+-- and output each of them using pprImportedSymbol.
+
+pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC_64 _ })
+                  importedLbl
+        | osElfTarget (platformOS platform)
+        = case dynamicLinkerLabelInfo importedLbl of
+            Just (SymbolPtr, lbl)
+              -> vcat [
+                   text ".section \".toc\", \"aw\"",
+                   text ".LC_" <> pprCLabel dflags lbl <> char ':',
+                   text "\t.quad" <+> pprCLabel dflags lbl ]
+            _ -> empty
+
+pprImportedSymbol dflags platform importedLbl
+        | osElfTarget (platformOS platform)
+        = case dynamicLinkerLabelInfo importedLbl of
+            Just (SymbolPtr, lbl)
+              -> let symbolSize = case wordWidth dflags of
+                         W32 -> sLit "\t.long"
+                         W64 -> sLit "\t.quad"
+                         _ -> panic "Unknown wordRep in pprImportedSymbol"
+
+                 in vcat [
+                      text ".section \".got2\", \"aw\"",
+                      text ".LC_" <> pprCLabel dflags lbl <> char ':',
+                      ptext symbolSize <+> pprCLabel dflags lbl ]
+
+            -- PLT code stubs are generated automatically by the dynamic linker.
+            _ -> empty
+
+pprImportedSymbol _ _ _
+        = panic "PIC.pprImportedSymbol: no match"
+
+--------------------------------------------------------------------------------
+-- Generate code to calculate the address that should be put in the
+-- PIC base register.
+-- This is called by MachCodeGen for every CmmProc that accessed the
+-- PIC base register. It adds the appropriate instructions to the
+-- top of the CmmProc.
+
+-- It is assumed that the first NatCmmDecl in the input list is a Proc
+-- and the rest are CmmDatas.
+
+-- Darwin is simple: just fetch the address of a local label.
+-- The FETCHPC pseudo-instruction is expanded to multiple instructions
+-- during pretty-printing so that we don't have to deal with the
+-- local label:
+
+-- PowerPC version:
+--          bcl 20,31,1f.
+--      1:  mflr picReg
+
+-- i386 version:
+--          call 1f
+--      1:  popl %picReg
+
+
+
+-- Get a pointer to our own fake GOT, which is defined on a per-module basis.
+-- This is exactly how GCC does it in linux.
+
+initializePicBase_ppc
+        :: Arch -> OS -> Reg
+        -> [NatCmmDecl CmmStatics PPC.Instr]
+        -> NatM [NatCmmDecl CmmStatics PPC.Instr]
+
+initializePicBase_ppc ArchPPC os picReg
+    (CmmProc info lab live (ListGraph blocks) : statics)
+    | osElfTarget os
+    = do
+        let
+            gotOffset = PPC.ImmConstantDiff
+                                (PPC.ImmCLbl gotLabel)
+                                (PPC.ImmCLbl mkPicBaseLabel)
+
+            blocks' = case blocks of
+                       [] -> []
+                       (b:bs) -> fetchPC b : map maybeFetchPC bs
+
+            maybeFetchPC b@(BasicBlock bID _)
+              | bID `mapMember` info = fetchPC b
+              | otherwise            = b
+
+            -- GCC does PIC prologs thusly:
+            --     bcl 20,31,.L1
+            -- .L1:
+            --     mflr 30
+            --     addis 30,30,.LCTOC1-.L1@ha
+            --     addi 30,30,.LCTOC1-.L1@l
+            -- TODO: below we use it over temporary register,
+            -- it can and should be optimised by picking
+            -- correct PIC reg.
+            fetchPC (BasicBlock bID insns) =
+              BasicBlock bID (PPC.FETCHPC picReg
+                              : PPC.ADDIS picReg picReg (PPC.HA gotOffset)
+                              : PPC.ADD picReg picReg
+                                        (PPC.RIImm (PPC.LO gotOffset))
+                              : PPC.MR PPC.r30 picReg
+                              : insns)
+
+        return (CmmProc info lab live (ListGraph blocks') : statics)
+
+-------------------------------------------------------------------------
+-- Load TOC into register 2
+-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee
+-- in register 12.
+-- We pass the label to FETCHTOC and create a .localentry too.
+-- TODO: Explain this better and refer to ABI spec!
+{-
+We would like to do approximately this, but spill slot allocation
+might be added before the first BasicBlock. That violates the ABI.
+
+For now we will emit the prologue code in the pretty printer,
+which is also what we do for ELF v1.
+initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg
+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = do
+           bID <-getUniqueM
+           return (CmmProc info lab live (ListGraph (b':entry:blocks))
+                                         : statics)
+        where   BasicBlock entryID _ = entry
+                b' = BasicBlock bID [PPC.FETCHTOC picReg lab,
+                                     PPC.BCC PPC.ALWAYS entryID]
+-}
+
+initializePicBase_ppc _ _ _ _
+        = panic "initializePicBase_ppc: not needed"
+
+
+-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
+-- which pretty-prints as:
+--              call 1f
+-- 1:           popl %picReg
+--              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
+-- (See PprMach.hs)
+
+initializePicBase_x86
+        :: Arch -> OS -> Reg
+        -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr]
+        -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr]
+
+initializePicBase_x86 ArchX86 os picReg
+        (CmmProc info lab live (ListGraph blocks) : statics)
+    | osElfTarget os
+    = return (CmmProc info lab live (ListGraph blocks') : statics)
+    where blocks' = case blocks of
+                     [] -> []
+                     (b:bs) -> fetchGOT b : map maybeFetchGOT bs
+
+          -- we want to add a FETCHGOT instruction to the beginning of
+          -- every block that is an entry point, which corresponds to
+          -- the blocks that have entries in the info-table mapping.
+          maybeFetchGOT b@(BasicBlock bID _)
+            | bID `mapMember` info = fetchGOT b
+            | otherwise            = b
+
+          fetchGOT (BasicBlock bID insns) =
+             BasicBlock bID (X86.FETCHGOT picReg : insns)
+
+initializePicBase_x86 ArchX86 OSDarwin picReg
+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)
+
+    where BasicBlock bID insns = entry
+          block' = BasicBlock bID (X86.FETCHPC picReg : insns)
+
+initializePicBase_x86 _ _ _ _
+        = panic "initializePicBase_x86: not needed"
+
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -0,0 +1,2446 @@
+{-# LANGUAGE CPP, GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+
+-- This is a big module, but, if you pay attention to
+-- (a) the sectioning, and (b) the type signatures,
+-- the structure should not be too overwhelming.
+
+module PPC.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        InstrBlock
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "../includes/MachDeps.h"
+
+-- NCG stuff:
+import GhcPrelude
+
+import CodeGen.Platform
+import PPC.Instr
+import PPC.Cond
+import PPC.Regs
+import CPrim
+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat
+                  , getBlockIdNat, getPicBaseNat, getNewRegPairNat
+                  , getPicBaseMaybeNat )
+import Instruction
+import PIC
+import Format
+import RegClass
+import Reg
+import TargetReg
+import Platform
+
+-- Our intermediate code:
+import BlockId
+import PprCmm           ( pprExpr )
+import Cmm
+import CmmUtils
+import CmmSwitch
+import CLabel
+import Hoopl.Block
+import Hoopl.Graph
+
+-- The rest:
+import OrdList
+import Outputable
+import DynFlags
+
+import Control.Monad    ( mapAndUnzipM, when )
+import Data.Bits
+import Data.Word
+
+import BasicTypes
+import FastString
+import Util
+
+-- -----------------------------------------------------------------------------
+-- Top-level of the instruction selector
+
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+-- They are really trees of insns to facilitate fast appending, where a
+-- left-to-right traversal (pre-order?) yields the insns in the correct
+-- order.
+
+cmmTopCodeGen
+        :: RawCmmDecl
+        -> NatM [NatCmmDecl CmmStatics Instr]
+
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+  dflags <- getDynFlags
+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+      tops = proc : concat statics
+      os   = platformOS $ targetPlatform dflags
+      arch = platformArch $ targetPlatform dflags
+  case arch of
+    ArchPPC | os == OSAIX -> return tops
+            | otherwise -> do
+      picBaseMb <- getPicBaseMaybeNat
+      case picBaseMb of
+           Just picBase -> initializePicBase_ppc arch os picBase tops
+           Nothing -> return tops
+    ArchPPC_64 ELF_V1 -> fixup_entry tops
+                      -- generating function descriptor is handled in
+                      -- pretty printer
+    ArchPPC_64 ELF_V2 -> fixup_entry tops
+                      -- generating function prologue is handled in
+                      -- pretty printer
+    _          -> panic "PPC.cmmTopCodeGen: unknown arch"
+    where
+      fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = do
+        let BasicBlock bID insns = entry
+        bID' <- if lab == (blockLbl bID)
+                then newBlockId
+                else return bID
+        let b' = BasicBlock bID' insns
+        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
+      fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"
+
+cmmTopCodeGen (CmmData sec dat) = do
+  return [CmmData sec dat]  -- no translation, we just use CmmStatic
+
+basicBlockCodeGen
+        :: Block CmmNode C C
+        -> NatM ( [NatBasicBlock Instr]
+                , [NatCmmDecl CmmStatics Instr])
+
+basicBlockCodeGen block = do
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
+  -- code generation may introduce new basic block boundaries, which
+  -- are indicated by the NEWBLOCK instruction.  We must split up the
+  -- instruction stream into basic blocks again.  Also, we extract
+  -- LDATAs here too.
+  let
+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+
+        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+          = ([], BasicBlock id instrs : blocks, statics)
+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+          = (instrs, blocks, CmmData sec dat:statics)
+        mkBlocks instr (instrs,blocks,statics)
+          = (instr:instrs, blocks, statics)
+  return (BasicBlock id top : other_blocks, statics)
+
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs stmts
+   = do instrss <- mapM stmtToInstrs stmts
+        return (concatOL instrss)
+
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
+stmtToInstrs stmt = do
+  dflags <- getDynFlags
+  case stmt of
+    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
+
+    CmmAssign reg src
+      | isFloatType ty -> assignReg_FltCode format reg src
+      | target32Bit (targetPlatform dflags) &&
+        isWord64 ty    -> assignReg_I64Code      reg src
+      | otherwise      -> assignReg_IntCode format reg src
+        where ty = cmmRegType dflags reg
+              format = cmmTypeFormat ty
+
+    CmmStore addr src
+      | isFloatType ty -> assignMem_FltCode format addr src
+      | target32Bit (targetPlatform dflags) &&
+        isWord64 ty    -> assignMem_I64Code      addr src
+      | otherwise      -> assignMem_IntCode format addr src
+        where ty = cmmExprType dflags src
+              format = cmmTypeFormat ty
+
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall target result_regs args
+
+    CmmBranch id          -> genBranch id
+    CmmCondBranch arg true false prediction -> do
+      b1 <- genCondJump true arg prediction
+      b2 <- genBranch false
+      return (b1 `appOL` b2)
+    CmmSwitch arg ids -> do dflags <- getDynFlags
+                            genSwitch dflags arg ids
+    CmmCall { cml_target = arg
+            , cml_args_regs = gregs } -> do
+                                dflags <- getDynFlags
+                                genJump arg (jumpRegs dflags gregs)
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
+
+jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
+    where platform = targetPlatform dflags
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--      They are really trees of insns to facilitate fast appending, where a
+--      left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock
+        = OrdList Instr
+
+
+-- | Register's passed up the tree.  If the stix code forces the register
+--      to live in a pre-decided machine register, it comes out as @Fixed@;
+--      otherwise, it comes out as @Any@, and the parent can decide which
+--      register to put it in.
+--
+data Register
+        = Fixed Format Reg InstrBlock
+        | Any   Format (Reg -> InstrBlock)
+
+
+swizzleRegisterRep :: Register -> Format -> Register
+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
+
+
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform -> CmmReg -> Reg
+
+getRegisterReg _ (CmmLocal (LocalReg u pk))
+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
+
+getRegisterReg platform (CmmGlobal mid)
+  = case globalRegMaybe platform mid of
+        Just reg -> RegReal reg
+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+        -- By this stage, the only MagicIds remaining should be the
+        -- ones which map to a real machine register on this
+        -- platform.  Hence ...
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = blockLbl blockid
+
+
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
+mangleIndexTree dflags (CmmRegOff reg off)
+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+  where width = typeWidth (cmmRegType dflags reg)
+
+mangleIndexTree _ _
+        = panic "PPC.CodeGen.mangleIndexTree: no match"
+
+-- -----------------------------------------------------------------------------
+--  Code gen for 64-bit arithmetic on 32-bit platforms
+
+{-
+Simple support for generating 64-bit code (ie, 64 bit values and 64
+bit assignments) on 32-bit platforms.  Unlike the main code generator
+we merely shoot for generating working code as simply as possible, and
+pay little attention to code quality.  Specifically, there is no
+attempt to deal cleverly with the fixed-vs-floating register
+distinction; all values are generated into (pairs of) floating
+registers, even if this would mean some redundant reg-reg moves as a
+result.  Only one of the VRegUniques is returned, since it will be
+of the VRegUniqueLo form, and the upper-half VReg can be determined
+by applying getHiVRegFromLo to it.
+-}
+
+data ChildCode64        -- a.k.a "Register64"
+      = ChildCode64
+           InstrBlock   -- code
+           Reg          -- the lower 32-bit temporary which contains the
+                        -- result; use getHiVRegFromLo to find the other
+                        -- VRegUnique.  Rules of this simplified insn
+                        -- selection game are therefore that the returned
+                        -- Reg may be modified
+
+
+-- | Compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed _ reg code ->
+        return (reg, code)
+
+getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
+getI64Amodes addrTree = do
+    Amode hi_addr addr_code <- getAmode D addrTree
+    case addrOffset hi_addr 4 of
+        Just lo_addr -> return (hi_addr, lo_addr, addr_code)
+        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
+                           return (AddrRegImm hi_ptr (ImmInt 0),
+                                   AddrRegImm hi_ptr (ImmInt 4),
+                                   code)
+
+
+assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_I64Code addrTree valueTree = do
+        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+        ChildCode64 vcode rlo <- iselExpr64 valueTree
+        let
+                rhi = getHiVRegFromLo rlo
+
+                -- Big-endian store
+                mov_hi = ST II32 rhi hi_addr
+                mov_lo = ST II32 rlo lo_addr
+        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+
+assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+   let
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MR r_dst_lo r_src_lo
+         mov_hi = MR r_dst_hi r_src_hi
+   return (
+        vcode `snocOL` mov_lo `snocOL` mov_hi
+     )
+
+assignReg_I64Code _ _
+   = panic "assignReg_I64Code(powerpc): invalid lvalue"
+
+
+iselExpr64        :: CmmExpr -> NatM ChildCode64
+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
+    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = LD II32 rhi hi_addr
+        mov_lo = LD II32 rlo lo_addr
+    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
+
+iselExpr64 (CmmLit (CmmInt i _)) = do
+  (rlo,rhi) <- getNewRegPairNat II32
+  let
+        half0 = fromIntegral (fromIntegral i :: Word16)
+        half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
+        half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
+        half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
+
+        code = toOL [
+                LIS rlo (ImmInt half1),
+                OR rlo rlo (RIImm $ ImmInt half0),
+                LIS rhi (ImmInt half3),
+                OR rhi rhi (RIImm $ ImmInt half2)
+                ]
+  return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ ADDC rlo r1lo r2lo,
+                       ADDE rhi r1hi r2hi ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ SUBFC rlo r2lo (RIReg r1lo),
+                       SUBFE rhi r2hi r1hi ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
+    (expr_reg,expr_code) <- getSomeReg expr
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = LI rhi (ImmInt 0)
+        mov_lo = MR rlo expr_reg
+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
+    (expr_reg,expr_code) <- getSomeReg expr
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))
+        mov_lo = MR rlo expr_reg
+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+iselExpr64 expr
+   = pprPanic "iselExpr64(powerpc)" (pprExpr expr)
+
+
+
+getRegister :: CmmExpr -> NatM Register
+getRegister e = do dflags <- getDynFlags
+                   getRegister' dflags e
+
+getRegister' :: DynFlags -> CmmExpr -> NatM Register
+
+getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))
+  | OSAIX <- platformOS (targetPlatform dflags) = do
+        let code dst = toOL [ LD II32 dst tocAddr ]
+            tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
+        return (Any II32 code)
+  | target32Bit (targetPlatform dflags) = do
+      reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))
+      return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))
+                    reg nilOL)
+  | otherwise = return (Fixed II64 toc nilOL)
+
+getRegister' dflags (CmmReg reg)
+  = return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
+                  (getRegisterReg (targetPlatform dflags) reg) nilOL)
+
+getRegister' dflags tree@(CmmRegOff _ _)
+  = getRegister' dflags (mangleIndexTree dflags tree)
+
+    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
+    -- TO_W_(x), TO_W_(x >> 32)
+
+getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' dflags (CmmLoad mem pk)
+ | not (isWord64 pk) = do
+        let platform = targetPlatform dflags
+        Amode addr addr_code <- getAmode D mem
+        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
+                       addr_code `snocOL` LD format dst addr
+        return (Any format code)
+ | not (target32Bit (targetPlatform dflags)) = do
+        Amode addr addr_code <- getAmode DS mem
+        let code dst = addr_code `snocOL` LD II64 dst addr
+        return (Any II64 code)
+
+          where format = cmmTypeFormat pk
+
+-- catch simple cases of zero- or sign-extended load
+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+getRegister' _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+getRegister' _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+-- Note: there is no Load Byte Arithmetic instruction, so no signed case here
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
+
+getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
+    -- lwa is DS-form. See Note [Power instruction format]
+    Amode addr addr_code <- getAmode DS mem
+    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
+
+getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps
+  = case mop of
+      MO_Not rep   -> triv_ucode_int rep NOT
+
+      MO_F_Neg w   -> triv_ucode_float w FNEG
+      MO_S_Neg w   -> triv_ucode_int   w NEG
+
+      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x
+      MO_FF_Conv W32 W64 -> conversionNop FF64 x
+
+      MO_FS_Conv from to -> coerceFP2Int from to x
+      MO_SF_Conv from to -> coerceInt2FP from to x
+
+      MO_SS_Conv from to
+        | from >= to -> conversionNop (intFormat to) x
+        | otherwise  -> triv_ucode_int to (EXTS (intFormat from))
+
+      MO_UU_Conv from to
+        | from >= to -> conversionNop (intFormat to) x
+        | otherwise  -> clearLeft from to
+
+      MO_XX_Conv _ to -> conversionNop (intFormat to) x
+
+      _ -> panic "PPC.CodeGen.getRegister: no match"
+
+    where
+        triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x
+        triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x
+
+        conversionNop new_format expr
+            = do e_code <- getRegister' dflags expr
+                 return (swizzleRegisterRep e_code new_format)
+
+        clearLeft from to
+            = do (src1, code1) <- getSomeReg x
+                 let arch_fmt  = intFormat (wordWidth dflags)
+                     arch_bits = widthInBits (wordWidth dflags)
+                     size      = widthInBits from
+                     code dst  = code1 `snocOL`
+                                 CLRLI arch_fmt dst src1 (arch_bits - size)
+                 return (Any (intFormat to) code)
+
+getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
+  = case mop of
+      MO_F_Eq _ -> condFltReg EQQ x y
+      MO_F_Ne _ -> condFltReg NE  x y
+      MO_F_Gt _ -> condFltReg GTT x y
+      MO_F_Ge _ -> condFltReg GE  x y
+      MO_F_Lt _ -> condFltReg LTT x y
+      MO_F_Le _ -> condFltReg LE  x y
+
+      MO_Eq rep -> condIntReg EQQ rep x y
+      MO_Ne rep -> condIntReg NE  rep x y
+
+      MO_S_Gt rep -> condIntReg GTT rep x y
+      MO_S_Ge rep -> condIntReg GE  rep x y
+      MO_S_Lt rep -> condIntReg LTT rep x y
+      MO_S_Le rep -> condIntReg LE  rep x y
+
+      MO_U_Gt rep -> condIntReg GU  rep x y
+      MO_U_Ge rep -> condIntReg GEU rep x y
+      MO_U_Lt rep -> condIntReg LU  rep x y
+      MO_U_Le rep -> condIntReg LEU rep x y
+
+      MO_F_Add w  -> triv_float w FADD
+      MO_F_Sub w  -> triv_float w FSUB
+      MO_F_Mul w  -> triv_float w FMUL
+      MO_F_Quot w -> triv_float w FDIV
+
+         -- optimize addition with 32-bit immediate
+         -- (needed for PIC)
+      MO_Add W32 ->
+        case y of
+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm
+            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
+          CmmLit lit
+            -> do
+                (src, srcCode) <- getSomeReg x
+                let imm = litToImm lit
+                    code dst = srcCode `appOL` toOL [
+                                    ADDIS dst src (HA imm),
+                                    ADD dst dst (RIImm (LO imm))
+                                ]
+                return (Any II32 code)
+          _ -> trivialCode W32 True ADD x y
+
+      MO_Add rep -> trivialCode rep True ADD x y
+      MO_Sub rep ->
+        case y of
+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
+            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
+          _ -> case x of
+                 CmmLit (CmmInt imm _)
+                   | Just _ <- makeImmediate rep True imm
+                   -- subfi ('substract from' with immediate) doesn't exist
+                   -> trivialCode rep True SUBFC y x
+                 _ -> trivialCodeNoImm' (intFormat rep) SUBF y x
+
+      MO_Mul rep -> shiftMulCode rep True MULL x y
+      MO_S_MulMayOflo rep -> do
+        (src1, code1) <- getSomeReg x
+        (src2, code2) <- getSomeReg y
+        let
+          format = intFormat rep
+          code dst = code1 `appOL` code2
+                       `appOL` toOL [ MULLO format dst src1 src2
+                                    , MFOV  format dst
+                                    ]
+        return (Any format code)
+
+      MO_S_Quot rep -> divCode rep True x y
+      MO_U_Quot rep -> divCode rep False x y
+
+      MO_S_Rem rep -> remainder rep True x y
+      MO_U_Rem rep -> remainder rep False x y
+
+      MO_And rep   -> case y of
+        (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4
+            -> do
+                (src, srcCode) <- getSomeReg x
+                let clear_mask = if imm == -4 then 2 else 3
+                    fmt = intFormat rep
+                    code dst = srcCode
+                               `appOL` unitOL (CLRRI fmt dst src clear_mask)
+                return (Any fmt code)
+        _ -> trivialCode rep False AND x y
+      MO_Or rep    -> trivialCode rep False OR x y
+      MO_Xor rep   -> trivialCode rep False XOR x y
+
+      MO_Shl rep   -> shiftMulCode rep False SL x y
+      MO_S_Shr rep -> srCode rep True SRA x y
+      MO_U_Shr rep -> srCode rep False SR x y
+      _         -> panic "PPC.CodeGen.getRegister: no match"
+
+  where
+    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
+    triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y
+
+    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
+    remainder rep sgn x y = do
+      let fmt = intFormat rep
+      tmp <- getNewRegNat fmt
+      code <- remainderCode rep sgn tmp x y
+      return (Any fmt code)
+
+
+getRegister' _ (CmmLit (CmmInt i rep))
+  | Just imm <- makeImmediate rep True i
+  = let
+        code dst = unitOL (LI dst imm)
+    in
+        return (Any (intFormat rep) code)
+
+getRegister' _ (CmmLit (CmmFloat f frep)) = do
+    lbl <- getNewLabelNat
+    dflags <- getDynFlags
+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+    Amode addr addr_code <- getAmode D dynRef
+    let format = floatFormat frep
+        code dst =
+            LDATA (Section ReadOnlyData lbl)
+                  (Statics lbl [CmmStaticLit (CmmFloat f frep)])
+            `consOL` (addr_code `snocOL` LD format dst addr)
+    return (Any format code)
+
+getRegister' dflags (CmmLit lit)
+  | target32Bit (targetPlatform dflags)
+  = let rep = cmmLitType dflags lit
+        imm = litToImm lit
+        code dst = toOL [
+              LIS dst (HA imm),
+              ADD dst dst (RIImm (LO imm))
+          ]
+    in return (Any (cmmTypeFormat rep) code)
+  | otherwise
+  = do lbl <- getNewLabelNat
+       dflags <- getDynFlags
+       dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+       Amode addr addr_code <- getAmode D dynRef
+       let rep = cmmLitType dflags lit
+           format = cmmTypeFormat rep
+           code dst =
+            LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])
+            `consOL` (addr_code `snocOL` LD format dst addr)
+       return (Any format code)
+
+getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)
+
+    -- extend?Rep: wrap integer expression of type `from`
+    -- in a conversion to `to`
+extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
+extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]
+
+extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
+extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]
+
+-- -----------------------------------------------------------------------------
+--  The 'Amode' type: Memory addressing modes passed up the tree.
+
+data Amode
+        = Amode AddrMode InstrBlock
+
+{-
+Now, given a tree (the argument to a CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+{- Note [Power instruction format]
+In some instructions the 16 bit offset must be a multiple of 4, i.e.
+the two least significant bits must be zero. The "Power ISA" specification
+calls these instruction formats "DS-FORM" and the instructions with
+arbitrary 16 bit offsets are "D-FORM".
+
+The Power ISA specification document can be obtained from www.power.org.
+-}
+data InstrForm = D | DS
+
+getAmode :: InstrForm -> CmmExpr -> NatM Amode
+getAmode inf tree@(CmmRegOff _ _)
+  = do dflags <- getDynFlags
+       getAmode inf (mangleIndexTree dflags tree)
+
+getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W32 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+
+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W32 True i
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+
+getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True i
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        (reg', off', code')  <-
+                     if i `mod` 4 == 0
+                      then do return (reg, off, code)
+                      else do
+                           tmp <- getNewRegNat II64
+                           return (tmp, ImmInt 0,
+                                  code `snocOL` ADD tmp reg (RIImm off))
+        return (Amode (AddrRegImm reg' off') code')
+
+getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True i
+  = do
+        (reg, code) <- getSomeReg x
+        (reg', off', code')  <-
+                     if i `mod` 4 == 0
+                      then do return (reg, off, code)
+                      else do
+                           tmp <- getNewRegNat II64
+                           return (tmp, ImmInt 0,
+                                  code `snocOL` ADD tmp reg (RIImm off))
+        return (Amode (AddrRegImm reg' off') code')
+
+   -- optimize addition with 32-bit immediate
+   -- (needed for PIC)
+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])
+  = do
+        dflags <- getDynFlags
+        (src, srcCode) <- getSomeReg x
+        let imm = litToImm lit
+        case () of
+            _ | OSAIX <- platformOS (targetPlatform dflags)
+              , isCmmLabelType lit ->
+                    -- HA16/LO16 relocations on labels not supported on AIX
+                    return (Amode (AddrRegImm src imm) srcCode)
+              | otherwise -> do
+                    tmp <- getNewRegNat II32
+                    let code = srcCode `snocOL` ADDIS tmp src (HA imm)
+                    return (Amode (AddrRegImm tmp (LO imm)) code)
+  where
+      isCmmLabelType (CmmLabel {})        = True
+      isCmmLabelType (CmmLabelOff {})     = True
+      isCmmLabelType (CmmLabelDiffOff {}) = True
+      isCmmLabelType _                    = False
+
+getAmode _ (CmmLit lit)
+  = do
+        dflags <- getDynFlags
+        case platformArch $ targetPlatform dflags of
+             ArchPPC -> do
+                 tmp <- getNewRegNat II32
+                 let imm = litToImm lit
+                     code = unitOL (LIS tmp (HA imm))
+                 return (Amode (AddrRegImm tmp (LO imm)) code)
+             _        -> do -- TODO: Load from TOC,
+                            -- see getRegister' _ (CmmLit lit)
+                 tmp <- getNewRegNat II64
+                 let imm = litToImm lit
+                     code =  toOL [
+                          LIS tmp (HIGHESTA imm),
+                          OR tmp tmp (RIImm (HIGHERA imm)),
+                          SL  II64 tmp tmp (RIImm (ImmInt 32)),
+                          ORIS tmp tmp (HA imm)
+                          ]
+                 return (Amode (AddrRegImm tmp (LO imm)) code)
+
+getAmode _ (CmmMachOp (MO_Add W32) [x, y])
+  = do
+        (regX, codeX) <- getSomeReg x
+        (regY, codeY) <- getSomeReg y
+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+
+getAmode _ (CmmMachOp (MO_Add W64) [x, y])
+  = do
+        (regX, codeX) <- getSomeReg x
+        (regY, codeY) <- getSomeReg y
+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+
+getAmode _ other
+  = do
+        (reg, code) <- getSomeReg other
+        let
+            off  = ImmInt 0
+        return (Amode (AddrRegImm reg off) code)
+
+
+--  The 'CondCode' type:  Condition codes passed up the tree.
+data CondCode
+        = CondCode Bool Cond InstrBlock
+
+-- Set up a condition code for a conditional branch.
+
+getCondCode :: CmmExpr -> NatM CondCode
+
+-- almost the same as everywhere else - but we need to
+-- extend small integers to 32 bit or 64 bit first
+
+getCondCode (CmmMachOp mop [x, y])
+  = do
+    case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      MO_F_Lt W32 -> condFltCode LTT x y
+      MO_F_Le W32 -> condFltCode LE  x y
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode LTT x y
+      MO_F_Le W64 -> condFltCode LE  x y
+
+      MO_Eq rep -> condIntCode EQQ rep x y
+      MO_Ne rep -> condIntCode NE  rep x y
+
+      MO_S_Gt rep -> condIntCode GTT rep x y
+      MO_S_Ge rep -> condIntCode GE  rep x y
+      MO_S_Lt rep -> condIntCode LTT rep x y
+      MO_S_Le rep -> condIntCode LE  rep x y
+
+      MO_U_Gt rep -> condIntCode GU  rep x y
+      MO_U_Ge rep -> condIntCode GEU rep x y
+      MO_U_Lt rep -> condIntCode LU  rep x y
+      MO_U_Le rep -> condIntCode LEU rep x y
+
+      _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
+
+getCondCode _ = panic "getCondCode(2)(powerpc)"
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
+condIntCode cond width x y = do
+  dflags <- getDynFlags
+  condIntCode' (target32Bit (targetPlatform dflags)) cond width x y
+
+condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
+
+-- simple code for 64-bit on 32-bit platforms
+condIntCode' True cond W64 x y
+  | condUnsigned cond
+  = do
+      ChildCode64 code_x x_lo <- iselExpr64 x
+      ChildCode64 code_y y_lo <- iselExpr64 y
+      let x_hi = getHiVRegFromLo x_lo
+          y_hi = getHiVRegFromLo y_lo
+      end_lbl <- getBlockIdNat
+      let code = code_x `appOL` code_y `appOL` toOL
+                 [ CMPL II32 x_hi (RIReg y_hi)
+                 , BCC NE end_lbl Nothing
+                 , CMPL II32 x_lo (RIReg y_lo)
+                 , BCC ALWAYS end_lbl Nothing
+
+                 , NEWBLOCK end_lbl
+                 ]
+      return (CondCode False cond code)
+  | otherwise
+  = do
+      ChildCode64 code_x x_lo <- iselExpr64 x
+      ChildCode64 code_y y_lo <- iselExpr64 y
+      let x_hi = getHiVRegFromLo x_lo
+          y_hi = getHiVRegFromLo y_lo
+      end_lbl <- getBlockIdNat
+      cmp_lo  <- getBlockIdNat
+      let code = code_x `appOL` code_y `appOL` toOL
+                 [ CMP II32 x_hi (RIReg y_hi)
+                 , BCC NE end_lbl Nothing
+                 , CMP II32 x_hi (RIImm (ImmInt 0))
+                 , BCC LE cmp_lo Nothing
+                 , CMPL II32 x_lo (RIReg y_lo)
+                 , BCC ALWAYS end_lbl Nothing
+                 , CMPL II32 y_lo (RIReg x_lo)
+                 , BCC ALWAYS end_lbl Nothing
+
+                 , NEWBLOCK end_lbl
+                 ]
+      return (CondCode False cond code)
+
+-- optimize pointer tag checks. Operation andi. sets condition register
+-- so cmpi ..., 0 is redundant.
+condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])
+                 (CmmLit (CmmInt 0 _))
+  | not $ condUnsigned cond,
+    Just src2 <- makeImmediate rep False imm
+  = do
+      (src1, code) <- getSomeReg x
+      let code' = code `snocOL` AND r0 src1 (RIImm src2)
+      return (CondCode False cond code')
+
+condIntCode' _ cond width x (CmmLit (CmmInt y rep))
+  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
+  = do
+      let op_len = max W32 width
+      let extend = extendSExpr width op_len
+      (src1, code) <- getSomeReg (extend x)
+      let format = intFormat op_len
+          code' = code `snocOL`
+            (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
+      return (CondCode False cond code')
+
+condIntCode' _ cond width x y = do
+  let op_len = max W32 width
+  let extend = if condUnsigned cond then extendUExpr width op_len
+               else extendSExpr width op_len
+  (src1, code1) <- getSomeReg (extend x)
+  (src2, code2) <- getSomeReg (extend y)
+  let format = intFormat op_len
+      code' = code1 `appOL` code2 `snocOL`
+        (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)
+  return (CondCode False cond code')
+
+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condFltCode cond x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2
+        code'' = case cond of -- twiddle CR to handle unordered case
+                    GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
+                    LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
+                    _ -> code'
+                 where
+                    ltbit = 0 ; eqbit = 2 ; gtbit = 1
+    return (CondCode True cond code'')
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_IntCode pk addr src = do
+    (srcReg, code) <- getSomeReg src
+    Amode dstAddr addr_code <- case pk of
+                                II64 -> getAmode DS addr
+                                _    -> getAmode D  addr
+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode _ reg src
+    = do
+        dflags <- getDynFlags
+        let dst = getRegisterReg (targetPlatform dflags) reg
+        r <- getRegister src
+        return $ case r of
+            Any _ code         -> code dst
+            Fixed _ freg fcode -> fcode `snocOL` MR dst freg
+
+
+
+-- Easy, isn't it?
+assignMem_FltCode = assignMem_IntCode
+assignReg_FltCode = assignReg_IntCode
+
+
+
+genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock
+
+genJump (CmmLit (CmmLabel lbl)) regs
+  = return (unitOL $ JMP lbl regs)
+
+genJump tree gregs
+  = do
+        dflags <- getDynFlags
+        genJump' tree (platformToGCP (targetPlatform dflags)) gregs
+
+genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock
+
+genJump' tree (GCP64ELF 1) regs
+  = do
+        (target,code) <- getSomeReg tree
+        return (code
+               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))
+               `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))
+               `snocOL` MTCTR r11
+               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))
+               `snocOL` BCTR [] Nothing regs)
+
+genJump' tree (GCP64ELF 2) regs
+  = do
+        (target,code) <- getSomeReg tree
+        return (code
+               `snocOL` MR r12 target
+               `snocOL` MTCTR r12
+               `snocOL` BCTR [] Nothing regs)
+
+genJump' tree _ regs
+  = do
+        (target,code) <- getSomeReg tree
+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs)
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+-}
+
+
+genCondJump
+    :: BlockId      -- the branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> Maybe Bool
+    -> NatM InstrBlock
+
+genCondJump id bool prediction = do
+  CondCode _ cond code <- getCondCode bool
+  return (code `snocOL` BCC cond id prediction)
+
+
+
+-- -----------------------------------------------------------------------------
+--  Generating C calls
+
+-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations.  Apart from that, the code is easy.
+
+genCCall :: ForeignTarget      -- function to call
+         -> [CmmFormal]        -- where to put the result
+         -> [CmmActual]        -- arguments (of mixed type)
+         -> NatM InstrBlock
+genCCall (PrimTarget MO_WriteBarrier) _ _
+ = return $ unitOL LWSYNC
+
+genCCall (PrimTarget MO_Touch) _ _
+ = return $ nilOL
+
+genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
+ = return $ nilOL
+
+genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          fmt      = intFormat width
+          reg_dst  = getRegisterReg platform (CmmLocal dst)
+      (instr, n_code) <- case amop of
+            AMO_Add  -> getSomeRegOrImm ADD True reg_dst
+            AMO_Sub  -> case n of
+                CmmLit (CmmInt i _)
+                  | Just imm <- makeImmediate width True (-i)
+                   -> return (ADD reg_dst reg_dst (RIImm imm), nilOL)
+                _
+                   -> do
+                         (n_reg, n_code) <- getSomeReg n
+                         return  (SUBF reg_dst n_reg reg_dst, n_code)
+            AMO_And  -> getSomeRegOrImm AND False reg_dst
+            AMO_Nand -> do (n_reg, n_code) <- getSomeReg n
+                           return (NAND reg_dst reg_dst n_reg, n_code)
+            AMO_Or   -> getSomeRegOrImm OR False reg_dst
+            AMO_Xor  -> getSomeRegOrImm XOR False reg_dst
+      Amode addr_reg addr_code <- getAmodeIndex addr
+      lbl_retry <- getBlockIdNat
+      return $ n_code `appOL` addr_code
+        `appOL` toOL [ HWSYNC
+                     , BCC ALWAYS lbl_retry Nothing
+
+                     , NEWBLOCK lbl_retry
+                     , LDR fmt reg_dst addr_reg
+                     , instr
+                     , STC fmt reg_dst addr_reg
+                     , BCC NE lbl_retry (Just False)
+                     , ISYNC
+                     ]
+         where
+           getAmodeIndex (CmmMachOp (MO_Add _) [x, y])
+             = do
+                 (regX, codeX) <- getSomeReg x
+                 (regY, codeY) <- getSomeReg y
+                 return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+           getAmodeIndex other
+             = do
+                 (reg, code) <- getSomeReg other
+                 return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here!
+           getSomeRegOrImm op sign dst
+             = case n of
+                 CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i
+                    -> return (op dst dst (RIImm imm), nilOL)
+                 _
+                    -> do
+                          (n_reg, n_code) <- getSomeReg n
+                          return  (op dst dst (RIReg n_reg), n_code)
+
+genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          fmt      = intFormat width
+          reg_dst  = getRegisterReg platform (CmmLocal dst)
+          form     = if widthInBits width == 64 then DS else D
+      Amode addr_reg addr_code <- getAmode form addr
+      lbl_end <- getBlockIdNat
+      return $ addr_code `appOL` toOL [ HWSYNC
+                                      , LD fmt reg_dst addr_reg
+                                      , CMP fmt reg_dst (RIReg reg_dst)
+                                      , BCC NE lbl_end (Just False)
+                                      , BCC ALWAYS lbl_end Nothing
+                            -- See Note [Seemingly useless cmp and bne]
+                                      , NEWBLOCK lbl_end
+                                      , ISYNC
+                                      ]
+
+-- Note [Seemingly useless cmp and bne]
+-- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction
+-- the second paragraph says that isync may complete before storage accesses
+-- "associated" with a preceding instruction have been performed. The cmp
+-- operation and the following bne introduce a data and control dependency
+-- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe
+-- Fetch).
+-- This is also what gcc does.
+
+
+genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
+    code <- assignMem_IntCode (intFormat width) addr val
+    return $ unitOL(HWSYNC) `appOL` code
+
+genCCall (PrimTarget (MO_Clz width)) [dst] [src]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          reg_dst = getRegisterReg platform (CmmLocal dst)
+      if target32Bit platform && width == W64
+        then do
+          ChildCode64 code vr_lo <- iselExpr64 src
+          lbl1 <- getBlockIdNat
+          lbl2 <- getBlockIdNat
+          lbl3 <- getBlockIdNat
+          let vr_hi = getHiVRegFromLo vr_lo
+              cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))
+                           , BCC NE lbl2 Nothing
+                           , BCC ALWAYS lbl1 Nothing
+
+                           , NEWBLOCK lbl1
+                           , CNTLZ II32 reg_dst vr_lo
+                           , ADD reg_dst reg_dst (RIImm (ImmInt 32))
+                           , BCC ALWAYS lbl3 Nothing
+
+                           , NEWBLOCK lbl2
+                           , CNTLZ II32 reg_dst vr_hi
+                           , BCC ALWAYS lbl3 Nothing
+
+                           , NEWBLOCK lbl3
+                           ]
+          return $ code `appOL` cntlz
+        else do
+          let format = if width == W64 then II64 else II32
+          (s_reg, s_code) <- getSomeReg src
+          (pre, reg , post) <-
+            case width of
+              W64 -> return (nilOL, s_reg, nilOL)
+              W32 -> return (nilOL, s_reg, nilOL)
+              W16 -> do
+                reg_tmp <- getNewRegNat format
+                return
+                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
+                  , reg_tmp
+                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16)))
+                  )
+              W8  -> do
+                reg_tmp <- getNewRegNat format
+                return
+                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
+                  , reg_tmp
+                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24)))
+                  )
+              _   -> panic "genCall: Clz wrong format"
+          let cntlz = unitOL (CNTLZ format reg_dst reg)
+          return $ s_code `appOL` pre `appOL` cntlz `appOL` post
+
+genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          reg_dst = getRegisterReg platform (CmmLocal dst)
+      if target32Bit platform && width == W64
+        then do
+          let format = II32
+          ChildCode64 code vr_lo <- iselExpr64 src
+          lbl1 <- getBlockIdNat
+          lbl2 <- getBlockIdNat
+          lbl3 <- getBlockIdNat
+          x' <- getNewRegNat format
+          x'' <- getNewRegNat format
+          r' <- getNewRegNat format
+          cnttzlo <- cnttz format reg_dst vr_lo
+          let vr_hi = getHiVRegFromLo vr_lo
+              cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))
+                             , BCC NE lbl2 Nothing
+                             , BCC ALWAYS lbl1 Nothing
+
+                             , NEWBLOCK lbl1
+                             , ADD x' vr_hi (RIImm (ImmInt (-1)))
+                             , ANDC x'' x' vr_hi
+                             , CNTLZ format r' x''
+                               -- 32 + (32 - clz(x''))
+                             , SUBFC reg_dst r' (RIImm (ImmInt 64))
+                             , BCC ALWAYS lbl3 Nothing
+
+                             , NEWBLOCK lbl2
+                             ]
+                        `appOL` cnttzlo `appOL`
+                        toOL [ BCC ALWAYS lbl3 Nothing
+
+                             , NEWBLOCK lbl3
+                             ]
+          return $ code `appOL` cnttz64
+        else do
+          let format = if width == W64 then II64 else II32
+          (s_reg, s_code) <- getSomeReg src
+          (reg_ctz, pre_code) <-
+            case width of
+              W64 -> return (s_reg, nilOL)
+              W32 -> return (s_reg, nilOL)
+              W16 -> do
+                reg_tmp <- getNewRegNat format
+                return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
+              W8  -> do
+                reg_tmp <- getNewRegNat format
+                return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
+              _   -> panic "genCall: Ctz wrong format"
+          ctz_code <- cnttz format reg_dst reg_ctz
+          return $ s_code `appOL` pre_code `appOL` ctz_code
+        where
+          -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1))
+          -- see Henry S. Warren, Hacker's Delight, p 107
+          cnttz format dst src = do
+            let format_bits = 8 * formatInBytes format
+            x' <- getNewRegNat format
+            x'' <- getNewRegNat format
+            r' <- getNewRegNat format
+            return $ toOL [ ADD x' src (RIImm (ImmInt (-1)))
+                          , ANDC x'' x' src
+                          , CNTLZ format r' x''
+                          , SUBFC dst r' (RIImm (ImmInt (format_bits)))
+                          ]
+
+genCCall target dest_regs argsAndHints
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+      case target of
+        PrimTarget (MO_S_QuotRem  width) -> divOp1 platform True  width
+                                                   dest_regs argsAndHints
+        PrimTarget (MO_U_QuotRem  width) -> divOp1 platform False width
+                                                   dest_regs argsAndHints
+        PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs
+                                                   argsAndHints
+        PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs
+                                                argsAndHints
+        PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints
+        PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints
+        PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints
+        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width
+                                                   dest_regs argsAndHints
+        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width
+                                                   dest_regs argsAndHints
+        PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints
+        PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints
+        _ -> genCCall' dflags (platformToGCP platform)
+                       target dest_regs argsAndHints
+        where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]
+                = do let reg_q = getRegisterReg platform (CmmLocal res_q)
+                         reg_r = getRegisterReg platform (CmmLocal res_r)
+                     remainderCode width signed reg_q arg_x arg_y
+                       <*> pure reg_r
+
+              divOp1 _ _ _ _ _
+                = panic "genCCall: Wrong number of arguments for divOp1"
+              divOp2 platform width [res_q, res_r]
+                                    [arg_x_high, arg_x_low, arg_y]
+                = do let reg_q = getRegisterReg platform (CmmLocal res_q)
+                         reg_r = getRegisterReg platform (CmmLocal res_r)
+                         fmt   = intFormat width
+                         half  = 4 * (formatInBytes fmt)
+                     (xh_reg, xh_code) <- getSomeReg arg_x_high
+                     (xl_reg, xl_code) <- getSomeReg arg_x_low
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     s <- getNewRegNat fmt
+                     b <- getNewRegNat fmt
+                     v <- getNewRegNat fmt
+                     vn1 <- getNewRegNat fmt
+                     vn0 <- getNewRegNat fmt
+                     un32 <- getNewRegNat fmt
+                     tmp  <- getNewRegNat fmt
+                     un10 <- getNewRegNat fmt
+                     un1 <- getNewRegNat fmt
+                     un0 <- getNewRegNat fmt
+                     q1 <- getNewRegNat fmt
+                     rhat <- getNewRegNat fmt
+                     tmp1 <- getNewRegNat fmt
+                     q0 <- getNewRegNat fmt
+                     un21 <- getNewRegNat fmt
+                     again1 <- getBlockIdNat
+                     no1 <- getBlockIdNat
+                     then1 <- getBlockIdNat
+                     endif1 <- getBlockIdNat
+                     again2 <- getBlockIdNat
+                     no2 <- getBlockIdNat
+                     then2 <- getBlockIdNat
+                     endif2 <- getBlockIdNat
+                     return $ y_code `appOL` xl_code `appOL` xh_code `appOL`
+                              -- see Hacker's Delight p 196 Figure 9-3
+                              toOL [ -- b = 2 ^ (bits_in_word / 2)
+                                     LI b (ImmInt 1)
+                                   , SL fmt b b (RIImm (ImmInt half))
+                                     -- s = clz(y)
+                                   , CNTLZ fmt s y_reg
+                                     -- v = y << s
+                                   , SL fmt v y_reg (RIReg s)
+                                     -- vn1 = upper half of v
+                                   , SR fmt vn1 v (RIImm (ImmInt half))
+                                     -- vn0 = lower half of v
+                                   , CLRLI fmt vn0 v half
+                                     -- un32 = (u1 << s)
+                                     --      | (u0 >> (bits_in_word - s))
+                                   , SL fmt un32 xh_reg (RIReg s)
+                                   , SUBFC tmp s
+                                        (RIImm (ImmInt (8 * formatInBytes fmt)))
+                                   , SR fmt tmp xl_reg (RIReg tmp)
+                                   , OR un32 un32 (RIReg tmp)
+                                     -- un10 = u0 << s
+                                   , SL fmt un10 xl_reg (RIReg s)
+                                     -- un1 = upper half of un10
+                                   , SR fmt un1 un10 (RIImm (ImmInt half))
+                                     -- un0 = lower half of un10
+                                   , CLRLI fmt un0 un10 half
+                                     -- q1 = un32/vn1
+                                   , DIV fmt False q1 un32 vn1
+                                     -- rhat = un32 - q1*vn1
+                                   , MULL fmt tmp q1 (RIReg vn1)
+                                   , SUBF rhat tmp un32
+                                   , BCC ALWAYS again1 Nothing
+
+                                   , NEWBLOCK again1
+                                     -- if (q1 >= b || q1*vn0 > b*rhat + un1)
+                                   , CMPL fmt q1 (RIReg b)
+                                   , BCC GEU then1 Nothing
+                                   , BCC ALWAYS no1 Nothing
+
+                                   , NEWBLOCK no1
+                                   , MULL fmt tmp q1 (RIReg vn0)
+                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
+                                   , ADD tmp1 tmp1 (RIReg un1)
+                                   , CMPL fmt tmp (RIReg tmp1)
+                                   , BCC LEU endif1 Nothing
+                                   , BCC ALWAYS then1 Nothing
+
+                                   , NEWBLOCK then1
+                                     -- q1 = q1 - 1
+                                   , ADD q1 q1 (RIImm (ImmInt (-1)))
+                                     -- rhat = rhat + vn1
+                                   , ADD rhat rhat (RIReg vn1)
+                                     -- if (rhat < b) goto again1
+                                   , CMPL fmt rhat (RIReg b)
+                                   , BCC LTT again1 Nothing
+                                   , BCC ALWAYS endif1 Nothing
+
+                                   , NEWBLOCK endif1
+                                     -- un21 = un32*b + un1 - q1*v
+                                   , SL fmt un21 un32 (RIImm (ImmInt half))
+                                   , ADD un21 un21 (RIReg un1)
+                                   , MULL fmt tmp q1 (RIReg v)
+                                   , SUBF un21 tmp un21
+                                     -- compute second quotient digit
+                                     -- q0 = un21/vn1
+                                   , DIV fmt False q0 un21 vn1
+                                     -- rhat = un21- q0*vn1
+                                   , MULL fmt tmp q0 (RIReg vn1)
+                                   , SUBF rhat tmp un21
+                                   , BCC ALWAYS again2 Nothing
+
+                                   , NEWBLOCK again2
+                                     -- if (q0>b || q0*vn0 > b*rhat + un0)
+                                   , CMPL fmt q0 (RIReg b)
+                                   , BCC GEU then2 Nothing
+                                   , BCC ALWAYS no2 Nothing
+
+                                   , NEWBLOCK no2
+                                   , MULL fmt tmp q0 (RIReg vn0)
+                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
+                                   , ADD tmp1 tmp1 (RIReg un0)
+                                   , CMPL fmt tmp (RIReg tmp1)
+                                   , BCC LEU endif2 Nothing
+                                   , BCC ALWAYS then2 Nothing
+
+                                   , NEWBLOCK then2
+                                     -- q0 = q0 - 1
+                                   , ADD q0 q0 (RIImm (ImmInt (-1)))
+                                     -- rhat = rhat + vn1
+                                   , ADD rhat rhat (RIReg vn1)
+                                     -- if (rhat<b) goto again2
+                                   , CMPL fmt rhat (RIReg b)
+                                   , BCC LTT again2 Nothing
+                                   , BCC ALWAYS endif2 Nothing
+
+                                   , NEWBLOCK endif2
+                                     -- compute remainder
+                                     -- r = (un21*b + un0 - q0*v) >> s
+                                   , SL fmt reg_r un21 (RIImm (ImmInt half))
+                                   , ADD reg_r reg_r (RIReg un0)
+                                   , MULL fmt tmp q0 (RIReg v)
+                                   , SUBF reg_r tmp reg_r
+                                   , SR fmt reg_r reg_r (RIReg s)
+                                     -- compute quotient
+                                     -- q = q1*b + q0
+                                   , SL fmt reg_q q1 (RIImm (ImmInt half))
+                                   , ADD reg_q reg_q (RIReg q0)
+                                   ]
+              divOp2 _ _ _ _
+                = panic "genCCall: Wrong number of arguments for divOp2"
+              multOp2 platform width [res_h, res_l] [arg_x, arg_y]
+                = do let reg_h = getRegisterReg platform (CmmLocal res_h)
+                         reg_l = getRegisterReg platform (CmmLocal res_l)
+                         fmt = intFormat width
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)
+                                         , MULHU fmt reg_h x_reg y_reg
+                                         ]
+              multOp2 _ _ _ _
+                = panic "genCall: Wrong number of arguments for multOp2"
+              add2Op platform [res_h, res_l] [arg_x, arg_y]
+                = do let reg_h = getRegisterReg platform (CmmLocal res_h)
+                         reg_l = getRegisterReg platform (CmmLocal res_l)
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ LI reg_h (ImmInt 0)
+                                         , ADDC reg_l x_reg y_reg
+                                         , ADDZE reg_h reg_h
+                                         ]
+              add2Op _ _ _
+                = panic "genCCall: Wrong number of arguments/results for add2"
+
+              addcOp platform [res_r, res_c] [arg_x, arg_y]
+                = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]
+              addcOp _ _ _
+                = panic "genCCall: Wrong number of arguments/results for addc"
+
+              -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,
+              -- which is 0 for borrow and 1 otherwise. We need 1 and 0
+              -- so xor with 1.
+              subcOp platform [res_r, res_c] [arg_x, arg_y]
+                = do let reg_r = getRegisterReg platform (CmmLocal res_r)
+                         reg_c = getRegisterReg platform (CmmLocal res_c)
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ LI reg_c (ImmInt 0)
+                                         , SUBFC reg_r y_reg (RIReg x_reg)
+                                         , ADDZE reg_c reg_c
+                                         , XOR reg_c reg_c (RIImm (ImmInt 1))
+                                         ]
+              subcOp _ _ _
+                = panic "genCCall: Wrong number of arguments/results for subc"
+              addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]
+                = do let reg_r = getRegisterReg platform (CmmLocal res_r)
+                         reg_c = getRegisterReg platform (CmmLocal res_c)
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ instr reg_r y_reg x_reg,
+                                           -- SUBFO argument order reversed!
+                                           MFOV (intFormat width) reg_c
+                                         ]
+              addSubCOp _ _ _ _ _
+                = panic "genCall: Wrong number of arguments/results for addC"
+              fabs platform [res] [arg]
+                = do let res_r = getRegisterReg platform (CmmLocal res)
+                     (arg_reg, arg_code) <- getSomeReg arg
+                     return $ arg_code `snocOL` FABS res_r arg_reg
+              fabs _ _ _
+                = panic "genCall: Wrong number of arguments/results for fabs"
+
+-- TODO: replace 'Int' by an enum such as 'PPC_64ABI'
+data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX
+
+platformToGCP :: Platform -> GenCCallPlatform
+platformToGCP platform
+  = case platformOS platform of
+      OSAIX    -> GCPAIX
+      _ -> case platformArch platform of
+             ArchPPC           -> GCP32ELF
+             ArchPPC_64 ELF_V1 -> GCP64ELF 1
+             ArchPPC_64 ELF_V2 -> GCP64ELF 2
+             _ -> panic "platformToGCP: Not PowerPC"
+
+
+genCCall'
+    :: DynFlags
+    -> GenCCallPlatform
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+{-
+    PowerPC Linux uses the System V Release 4 Calling Convention
+    for PowerPC. It is described in the
+    "System V Application Binary Interface PowerPC Processor Supplement".
+
+    PowerPC 64 Linux uses the System V Release 4 Calling Convention for
+    64-bit PowerPC. It is specified in
+    "64-bit PowerPC ELF Application Binary Interface Supplement 1.9"
+    (PPC64 ELF v1.9).
+
+    PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit
+    ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement"
+    (PPC64 ELF v2).
+
+    AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian
+    32-Bit Hardware Implementation"
+
+    All four conventions are similar:
+    Parameters may be passed in general-purpose registers starting at r3, in
+    floating point registers starting at f1, or on the stack.
+
+    But there are substantial differences:
+    * The number of registers used for parameter passing and the exact set of
+      nonvolatile registers differs (see MachRegs.hs).
+    * On AIX and 64-bit ELF, stack space is always reserved for parameters,
+      even if they are passed in registers. The called routine may choose to
+      save parameters from registers to the corresponding space on the stack.
+    * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when
+      a floating point parameter is passed in an FPR.
+    * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
+      starting with an odd-numbered GPR. It may skip a GPR to achieve this.
+      AIX just treats an I64 likt two separate I32s (high word first).
+    * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only
+      4-byte aligned like everything else on AIX.
+    * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on
+      PowerPC Linux does not agree, so neither do we.
+
+    According to all conventions, the parameter area should be part of the
+    caller's stack frame, allocated in the caller's prologue code (large enough
+    to hold the parameter lists for all called routines). The NCG already
+    uses the stack for register spilling, leaving 64 bytes free at the top.
+    If we need a larger parameter area than that, we increase the size
+    of the stack frame just before ccalling.
+-}
+
+
+genCCall' dflags gcp target dest_regs args
+  = do
+        (finalStack,passArgumentsCode,usedRegs) <- passArguments
+                                                   (zip3 args argReps argHints)
+                                                   allArgRegs
+                                                   (allFPArgRegs platform)
+                                                   initialStackOffset
+                                                   nilOL []
+
+        (labelOrExpr, reduceToFF32) <- case target of
+            ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+                uses_pic_base_implicitly
+                return (Left lbl, False)
+            ForeignTarget expr _ -> do
+                uses_pic_base_implicitly
+                return (Right expr, False)
+            PrimTarget mop -> outOfLineMachOp mop
+
+        let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
+            codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
+
+        case labelOrExpr of
+            Left lbl -> do -- the linker does all the work for us
+                return (         codeBefore
+                        `snocOL` BL lbl usedRegs
+                        `appOL`  maybeNOP -- some ABI require a NOP after BL
+                        `appOL`  codeAfter)
+            Right dyn -> do -- implement call through function pointer
+                (dynReg, dynCode) <- getSomeReg dyn
+                case gcp of
+                     GCP64ELF 1      -> return ( dynCode
+                       `appOL`  codeBefore
+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40))
+                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0))
+                       `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8))
+                       `snocOL` MTCTR r11
+                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16))
+                       `snocOL` BCTRL usedRegs
+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40))
+                       `appOL`  codeAfter)
+                     GCP64ELF 2      -> return ( dynCode
+                       `appOL`  codeBefore
+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24))
+                       `snocOL` MR r12 dynReg
+                       `snocOL` MTCTR r12
+                       `snocOL` BCTRL usedRegs
+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24))
+                       `appOL`  codeAfter)
+                     GCPAIX          -> return ( dynCode
+                       -- AIX/XCOFF follows the PowerOPEN ABI
+                       -- which is quite similiar to LinuxPPC64/ELFv1
+                       `appOL`  codeBefore
+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))
+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))
+                       `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))
+                       `snocOL` MTCTR r11
+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))
+                       `snocOL` BCTRL usedRegs
+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))
+                       `appOL`  codeAfter)
+                     _               -> return ( dynCode
+                       `snocOL` MTCTR dynReg
+                       `appOL`  codeBefore
+                       `snocOL` BCTRL usedRegs
+                       `appOL`  codeAfter)
+    where
+        platform = targetPlatform dflags
+
+        uses_pic_base_implicitly = do
+            -- See Note [implicit register in PPC PIC code]
+            -- on why we claim to use PIC register here
+            when (positionIndependent dflags && target32Bit platform) $ do
+                _ <- getPicBaseNat $ archWordFormat True
+                return ()
+
+        initialStackOffset = case gcp of
+                             GCPAIX     -> 24
+                             GCP32ELF   -> 8
+                             GCP64ELF 1 -> 48
+                             GCP64ELF 2 -> 32
+                             _ -> panic "genCall': unknown calling convention"
+            -- size of linkage area + size of arguments, in bytes
+        stackDelta finalStack = case gcp of
+                                GCPAIX ->
+                                    roundTo 16 $ (24 +) $ max 32 $ sum $
+                                    map (widthInBytes . typeWidth) argReps
+                                GCP32ELF -> roundTo 16 finalStack
+                                GCP64ELF 1 ->
+                                    roundTo 16 $ (48 +) $ max 64 $ sum $
+                                    map (roundTo 8 . widthInBytes . typeWidth)
+                                        argReps
+                                GCP64ELF 2 ->
+                                    roundTo 16 $ (32 +) $ max 64 $ sum $
+                                    map (roundTo 8 . widthInBytes . typeWidth)
+                                        argReps
+                                _ -> panic "genCall': unknown calling conv."
+
+        argReps = map (cmmExprType dflags) args
+        (argHints, _) = foreignTargetHints target
+
+        roundTo a x | x `mod` a == 0 = x
+                    | otherwise = x + a - (x `mod` a)
+
+        spFormat = if target32Bit platform then II32 else II64
+
+        -- TODO: Do not create a new stack frame if delta is too large.
+        move_sp_down finalStack
+               | delta > stackFrameHeaderSize dflags =
+                        toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))),
+                              DELTA (-delta)]
+               | otherwise = nilOL
+               where delta = stackDelta finalStack
+        move_sp_up finalStack
+               | delta > stackFrameHeaderSize dflags =
+                        toOL [ADD sp sp (RIImm (ImmInt delta)),
+                              DELTA 0]
+               | otherwise = nilOL
+               where delta = stackDelta finalStack
+
+        -- A NOP instruction is required after a call (bl instruction)
+        -- on AIX and 64-Bit Linux.
+        -- If the call is to a function with a different TOC (r2) the
+        -- link editor replaces the NOP instruction with a load of the TOC
+        -- from the stack to restore the TOC.
+        maybeNOP = case gcp of
+           GCP32ELF        -> nilOL
+           -- See Section 3.9.4 of OpenPower ABI
+           GCPAIX          -> unitOL NOP
+           -- See Section 3.5.11 of PPC64 ELF v1.9
+           GCP64ELF 1      -> unitOL NOP
+           -- See Section 2.3.6 of PPC64 ELF v2
+           GCP64ELF 2      -> unitOL NOP
+           _               -> panic "maybeNOP: Unknown PowerPC 64-bit ABI"
+
+        passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
+        passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset
+               accumCode accumUsed | isWord64 arg_ty
+                                     && target32Bit (targetPlatform dflags) =
+            do
+                ChildCode64 code vr_lo <- iselExpr64 arg
+                let vr_hi = getHiVRegFromLo vr_lo
+
+                case gcp of
+                    GCPAIX ->
+                        do let storeWord vr (gpr:_) _ = MR gpr vr
+                               storeWord vr [] offset
+                                   = ST II32 vr (AddrRegImm sp (ImmInt offset))
+                           passArguments args
+                                         (drop 2 gprs)
+                                         fprs
+                                         (stackOffset+8)
+                                         (accumCode `appOL` code
+                                               `snocOL` storeWord vr_hi gprs stackOffset
+                                               `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
+                                         ((take 2 gprs) ++ accumUsed)
+                    GCP32ELF ->
+                        do let stackOffset' = roundTo 8 stackOffset
+                               stackCode = accumCode `appOL` code
+                                   `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
+                                   `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
+                               regCode hireg loreg =
+                                   accumCode `appOL` code
+                                       `snocOL` MR hireg vr_hi
+                                       `snocOL` MR loreg vr_lo
+
+                           case gprs of
+                               hireg : loreg : regs | even (length gprs) ->
+                                   passArguments args regs fprs stackOffset
+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)
+                               _skipped : hireg : loreg : regs ->
+                                   passArguments args regs fprs stackOffset
+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)
+                               _ -> -- only one or no regs left
+                                   passArguments args [] fprs (stackOffset'+8)
+                                                 stackCode accumUsed
+                    GCP64ELF _ -> panic "passArguments: 32 bit code"
+
+        passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed
+            | reg : _ <- regs = do
+                register <- getRegister arg_pro
+                let code = case register of
+                            Fixed _ freg fcode -> fcode `snocOL` MR reg freg
+                            Any _ acode -> acode reg
+                    stackOffsetRes = case gcp of
+                                     -- The PowerOpen ABI requires that we
+                                     -- reserve stack slots for register
+                                     -- parameters
+                                     GCPAIX    -> stackOffset + stackBytes
+                                     -- ... the SysV ABI 32-bit doesn't.
+                                     GCP32ELF -> stackOffset
+                                     -- ... but SysV ABI 64-bit does.
+                                     GCP64ELF _ -> stackOffset + stackBytes
+                passArguments args
+                              (drop nGprs gprs)
+                              (drop nFprs fprs)
+                              stackOffsetRes
+                              (accumCode `appOL` code)
+                              (reg : accumUsed)
+            | otherwise = do
+                (vr, code) <- getSomeReg arg_pro
+                passArguments args
+                              (drop nGprs gprs)
+                              (drop nFprs fprs)
+                              (stackOffset' + stackBytes)
+                              (accumCode `appOL` code
+                                         `snocOL` ST format_pro vr stackSlot)
+                              accumUsed
+            where
+                arg_pro
+                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg]
+                   | otherwise      = arg
+                format_pro
+                   | isBitsType rep = intFormat (wordWidth dflags)
+                   | otherwise      = cmmTypeFormat rep
+                conv_op = case hint of
+                            SignedHint -> MO_SS_Conv
+                            _          -> MO_UU_Conv
+
+                stackOffset' = case gcp of
+                               GCPAIX ->
+                                   -- The 32bit PowerOPEN ABI is happy with
+                                   -- 32bit-alignment ...
+                                   stackOffset
+                               GCP32ELF
+                                   -- ... the SysV ABI requires 8-byte
+                                   -- alignment for doubles.
+                                | isFloatType rep && typeWidth rep == W64 ->
+                                   roundTo 8 stackOffset
+                                | otherwise ->
+                                   stackOffset
+                               GCP64ELF _ ->
+                                   -- Everything on the stack is mapped to
+                                   -- 8-byte aligned doublewords
+                                   stackOffset
+                stackOffset''
+                     | isFloatType rep && typeWidth rep == W32 =
+                         case gcp of
+                         -- The ELF v1 ABI Section 3.2.3 requires:
+                         -- "Single precision floating point values
+                         -- are mapped to the second word in a single
+                         -- doubleword"
+                         GCP64ELF 1      -> stackOffset' + 4
+                         _               -> stackOffset'
+                     | otherwise = stackOffset'
+
+                stackSlot = AddrRegImm sp (ImmInt stackOffset'')
+                (nGprs, nFprs, stackBytes, regs)
+                    = case gcp of
+                      GCPAIX ->
+                          case cmmTypeFormat rep of
+                          II8  -> (1, 0, 4, gprs)
+                          II16 -> (1, 0, 4, gprs)
+                          II32 -> (1, 0, 4, gprs)
+                          -- The PowerOpen ABI requires that we skip a
+                          -- corresponding number of GPRs when we use
+                          -- the FPRs.
+                          --
+                          -- E.g. for a `double` two GPRs are skipped,
+                          -- whereas for a `float` one GPR is skipped
+                          -- when parameters are assigned to
+                          -- registers.
+                          --
+                          -- The PowerOpen ABI specification can be found at
+                          -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/
+                          FF32 -> (1, 1, 4, fprs)
+                          FF64 -> (2, 1, 8, fprs)
+                          II64 -> panic "genCCall' passArguments II64"
+
+                      GCP32ELF ->
+                          case cmmTypeFormat rep of
+                          II8  -> (1, 0, 4, gprs)
+                          II16 -> (1, 0, 4, gprs)
+                          II32 -> (1, 0, 4, gprs)
+                          -- ... the SysV ABI doesn't.
+                          FF32 -> (0, 1, 4, fprs)
+                          FF64 -> (0, 1, 8, fprs)
+                          II64 -> panic "genCCall' passArguments II64"
+                      GCP64ELF _ ->
+                          case cmmTypeFormat rep of
+                          II8  -> (1, 0, 8, gprs)
+                          II16 -> (1, 0, 8, gprs)
+                          II32 -> (1, 0, 8, gprs)
+                          II64 -> (1, 0, 8, gprs)
+                          -- The ELFv1 ABI requires that we skip a
+                          -- corresponding number of GPRs when we use
+                          -- the FPRs.
+                          FF32 -> (1, 1, 8, fprs)
+                          FF64 -> (1, 1, 8, fprs)
+
+        moveResult reduceToFF32 =
+            case dest_regs of
+                [] -> nilOL
+                [dest]
+                    | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)
+                    | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
+                    | isWord64 rep && target32Bit (targetPlatform dflags)
+                       -> toOL [MR (getHiVRegFromLo r_dest) r3,
+                                MR r_dest r4]
+                    | otherwise -> unitOL (MR r_dest r3)
+                    where rep = cmmRegType dflags (CmmLocal dest)
+                          r_dest = getRegisterReg platform (CmmLocal dest)
+                _ -> panic "genCCall' moveResult: Bad dest_regs"
+
+        outOfLineMachOp mop =
+            do
+                dflags <- getDynFlags
+                mopExpr <- cmmMakeDynamicReference dflags CallReference $
+                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
+                let mopLabelOrExpr = case mopExpr of
+                        CmmLit (CmmLabel lbl) -> Left lbl
+                        _ -> Right mopExpr
+                return (mopLabelOrExpr, reduce)
+            where
+                (functionName, reduce) = case mop of
+                    MO_F32_Exp   -> (fsLit "exp", True)
+                    MO_F32_Log   -> (fsLit "log", True)
+                    MO_F32_Sqrt  -> (fsLit "sqrt", True)
+                    MO_F32_Fabs  -> unsupported
+
+                    MO_F32_Sin   -> (fsLit "sin", True)
+                    MO_F32_Cos   -> (fsLit "cos", True)
+                    MO_F32_Tan   -> (fsLit "tan", True)
+
+                    MO_F32_Asin  -> (fsLit "asin", True)
+                    MO_F32_Acos  -> (fsLit "acos", True)
+                    MO_F32_Atan  -> (fsLit "atan", True)
+
+                    MO_F32_Sinh  -> (fsLit "sinh", True)
+                    MO_F32_Cosh  -> (fsLit "cosh", True)
+                    MO_F32_Tanh  -> (fsLit "tanh", True)
+                    MO_F32_Pwr   -> (fsLit "pow", True)
+
+                    MO_F32_Asinh -> (fsLit "asinh", True)
+                    MO_F32_Acosh -> (fsLit "acosh", True)
+                    MO_F32_Atanh -> (fsLit "atanh", True)
+
+                    MO_F64_Exp   -> (fsLit "exp", False)
+                    MO_F64_Log   -> (fsLit "log", False)
+                    MO_F64_Sqrt  -> (fsLit "sqrt", False)
+                    MO_F64_Fabs  -> unsupported
+
+                    MO_F64_Sin   -> (fsLit "sin", False)
+                    MO_F64_Cos   -> (fsLit "cos", False)
+                    MO_F64_Tan   -> (fsLit "tan", False)
+
+                    MO_F64_Asin  -> (fsLit "asin", False)
+                    MO_F64_Acos  -> (fsLit "acos", False)
+                    MO_F64_Atan  -> (fsLit "atan", False)
+
+                    MO_F64_Sinh  -> (fsLit "sinh", False)
+                    MO_F64_Cosh  -> (fsLit "cosh", False)
+                    MO_F64_Tanh  -> (fsLit "tanh", False)
+                    MO_F64_Pwr   -> (fsLit "pow", False)
+
+                    MO_F64_Asinh -> (fsLit "asinh", False)
+                    MO_F64_Acosh -> (fsLit "acosh", False)
+                    MO_F64_Atanh -> (fsLit "atanh", False)
+
+                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
+
+                    MO_Memcpy _  -> (fsLit "memcpy", False)
+                    MO_Memset _  -> (fsLit "memset", False)
+                    MO_Memmove _ -> (fsLit "memmove", False)
+                    MO_Memcmp _  -> (fsLit "memcmp", False)
+
+                    MO_BSwap w   -> (fsLit $ bSwapLabel w, False)
+                    MO_BRev w    -> (fsLit $ bRevLabel w, False)
+                    MO_PopCnt w  -> (fsLit $ popCntLabel w, False)
+                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)
+                    MO_Pext w    -> (fsLit $ pextLabel w, False)
+                    MO_Clz _     -> unsupported
+                    MO_Ctz _     -> unsupported
+                    MO_AtomicRMW {} -> unsupported
+                    MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
+                    MO_AtomicRead _  -> unsupported
+                    MO_AtomicWrite _ -> unsupported
+
+                    MO_S_QuotRem {}  -> unsupported
+                    MO_U_QuotRem {}  -> unsupported
+                    MO_U_QuotRem2 {} -> unsupported
+                    MO_Add2 {}       -> unsupported
+                    MO_AddWordC {}   -> unsupported
+                    MO_SubWordC {}   -> unsupported
+                    MO_AddIntC {}    -> unsupported
+                    MO_SubIntC {}    -> unsupported
+                    MO_U_Mul2 {}     -> unsupported
+                    MO_WriteBarrier  -> unsupported
+                    MO_Touch         -> unsupported
+                    MO_Prefetch_Data _ -> unsupported
+                unsupported = panic ("outOfLineCmmOp: " ++ show mop
+                                  ++ " not supported")
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch dflags expr targets
+  | OSAIX <- platformOS (targetPlatform dflags)
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
+            sha = if target32Bit $ targetPlatform dflags then 2 else 3
+        tmp <- getNewRegNat fmt
+        lbl <- getNewLabelNat
+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+        (tableReg,t_code) <- getSomeReg $ dynRef
+        let code = e_code `appOL` t_code `appOL` toOL [
+                            SL fmt tmp reg (RIImm (ImmInt sha)),
+                            LD fmt tmp (AddrRegReg tableReg tmp),
+                            MTCTR tmp,
+                            BCTR ids (Just lbl) []
+                    ]
+        return code
+
+  | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags)
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
+            sha = if target32Bit $ targetPlatform dflags then 2 else 3
+        tmp <- getNewRegNat fmt
+        lbl <- getNewLabelNat
+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+        (tableReg,t_code) <- getSomeReg $ dynRef
+        let code = e_code `appOL` t_code `appOL` toOL [
+                            SL fmt tmp reg (RIImm (ImmInt sha)),
+                            LD fmt tmp (AddrRegReg tableReg tmp),
+                            ADD tmp tmp (RIReg tableReg),
+                            MTCTR tmp,
+                            BCTR ids (Just lbl) []
+                    ]
+        return code
+  | otherwise
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
+            sha = if target32Bit $ targetPlatform dflags then 2 else 3
+        tmp <- getNewRegNat fmt
+        lbl <- getNewLabelNat
+        let code = e_code `appOL` toOL [
+                            SL fmt tmp reg (RIImm (ImmInt sha)),
+                            ADDIS tmp tmp (HA (ImmCLbl lbl)),
+                            LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
+                            MTCTR tmp,
+                            BCTR ids (Just lbl) []
+                    ]
+        return code
+  where (offset, ids) = switchTargetsToTable targets
+
+generateJumpTableForInstr :: DynFlags -> Instr
+                          -> Maybe (NatCmmDecl CmmStatics Instr)
+generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) =
+    let jumpTable
+            | (positionIndependent dflags)
+              || (not $ target32Bit $ targetPlatform dflags)
+            = map jumpTableEntryRel ids
+            | otherwise = map (jumpTableEntry dflags) ids
+                where jumpTableEntryRel Nothing
+                        = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+                      jumpTableEntryRel (Just blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0
+                                         (wordWidth dflags))
+                            where blockLabel = blockLbl blockid
+    in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))
+generateJumpTableForInstr _ _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- 'condIntReg' and 'condFltReg': condition codes into registers
+
+-- Turn those condition codes into integers now (when they appear on
+-- the right hand side of an assignment).
+
+
+
+condReg :: NatM CondCode -> NatM Register
+condReg getCond = do
+    CondCode _ cond cond_code <- getCond
+    dflags <- getDynFlags
+    let
+        code dst = cond_code
+            `appOL` negate_code
+            `appOL` toOL [
+                MFCR dst,
+                RLWINM dst dst (bit + 1) 31 31
+            ]
+
+        negate_code | do_negate = unitOL (CRNOR bit bit bit)
+                    | otherwise = nilOL
+
+        (bit, do_negate) = case cond of
+            LTT -> (0, False)
+            LE  -> (1, True)
+            EQQ -> (2, False)
+            GE  -> (0, True)
+            GTT -> (1, False)
+
+            NE  -> (2, True)
+
+            LU  -> (0, False)
+            LEU -> (1, True)
+            GEU -> (0, True)
+            GU  -> (1, False)
+            _   -> panic "PPC.CodeGen.codeReg: no match"
+
+        format = archWordFormat $ target32Bit $ targetPlatform dflags
+    return (Any format code)
+
+condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
+condIntReg cond width x y = condReg (condIntCode cond width x y)
+condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+condFltReg cond x y = condReg (condFltCode cond x y)
+
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+
+
+{-
+Wolfgang's PowerPC version of The Rules:
+
+A slightly modified version of The Rules to take advantage of the fact
+that PowerPC instructions work on all registers and don't implicitly
+clobber any fixed registers.
+
+* The only expression for which getRegister returns Fixed is (CmmReg reg).
+
+* If getRegister returns Any, then the code it generates may modify only:
+        (a) fresh temporaries
+        (b) the destination register
+  It may *not* modify global registers, unless the global
+  register happens to be the destination register.
+  It may not clobber any other registers. In fact, only ccalls clobber any
+  fixed registers.
+  Also, it may not modify the counter register (used by genCCall).
+
+  Corollary: If a getRegister for a subexpression returns Fixed, you need
+  not move it to a fresh temporary before evaluating the next subexpression.
+  The Fixed register won't be modified.
+  Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
+
+* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
+  the value of the destination register.
+-}
+
+trivialCode
+        :: Width
+        -> Bool
+        -> (Reg -> Reg -> RI -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+
+trivialCode rep signed instr x (CmmLit (CmmInt y _))
+    | Just imm <- makeImmediate rep signed y
+    = do
+        (src1, code1) <- getSomeReg x
+        let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
+        return (Any (intFormat rep) code)
+
+trivialCode rep _ instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
+    return (Any (intFormat rep) code)
+
+shiftMulCode
+        :: Width
+        -> Bool
+        -> (Format-> Reg -> Reg -> RI -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+shiftMulCode width sign instr x (CmmLit (CmmInt y _))
+    | Just imm <- makeImmediate width sign y
+    = do
+        (src1, code1) <- getSomeReg x
+        let format = intFormat width
+        let ins_fmt = intFormat (max W32 width)
+        let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm)
+        return (Any format code)
+
+shiftMulCode width _ instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let format = intFormat width
+    let ins_fmt = intFormat (max W32 width)
+    let code dst = code1 `appOL` code2
+                   `snocOL` instr ins_fmt dst src1 (RIReg src2)
+    return (Any format code)
+
+trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
+                 -> CmmExpr -> CmmExpr -> NatM Register
+trivialCodeNoImm' format instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
+    return (Any format code)
+
+trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
+                 -> CmmExpr -> CmmExpr -> NatM Register
+trivialCodeNoImm format instr x y
+  = trivialCodeNoImm' format (instr format) x y
+
+srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr)
+       -> CmmExpr -> CmmExpr -> NatM Register
+srCode width sgn instr x (CmmLit (CmmInt y _))
+    | Just imm <- makeImmediate width sgn y
+    = do
+        let op_len = max W32 width
+            extend = if sgn then extendSExpr else extendUExpr
+        (src1, code1) <- getSomeReg (extend width op_len x)
+        let code dst = code1 `snocOL`
+                       instr (intFormat op_len) dst src1 (RIImm imm)
+        return (Any (intFormat width) code)
+
+srCode width sgn instr x y = do
+  let op_len = max W32 width
+      extend = if sgn then extendSExpr else extendUExpr
+  (src1, code1) <- getSomeReg (extend width op_len x)
+  (src2, code2) <- getSomeReg (extendUExpr width op_len y)
+  -- Note: Shift amount `y` is unsigned
+  let code dst = code1 `appOL` code2 `snocOL`
+                 instr (intFormat op_len) dst src1 (RIReg src2)
+  return (Any (intFormat width) code)
+
+divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
+divCode width sgn x y = do
+  let op_len = max W32 width
+      extend = if sgn then extendSExpr else extendUExpr
+  (src1, code1) <- getSomeReg (extend width op_len x)
+  (src2, code2) <- getSomeReg (extend width op_len y)
+  let code dst = code1 `appOL` code2 `snocOL`
+                 DIV (intFormat op_len) sgn dst src1 src2
+  return (Any (intFormat width) code)
+
+
+trivialUCode :: Format
+             -> (Reg -> Reg -> Instr)
+             -> CmmExpr
+             -> NatM Register
+trivialUCode rep instr x = do
+    (src, code) <- getSomeReg x
+    let code' dst = code `snocOL` instr dst src
+    return (Any rep code')
+
+-- There is no "remainder" instruction on the PPC, so we have to do
+-- it the hard way.
+-- The "sgn" parameter is the signedness for the division instruction
+
+remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr
+               -> NatM (Reg -> InstrBlock)
+remainderCode rep sgn reg_q arg_x arg_y = do
+  let op_len = max W32 rep
+      fmt    = intFormat op_len
+      extend = if sgn then extendSExpr else extendUExpr
+  (x_reg, x_code) <- getSomeReg (extend rep op_len arg_x)
+  (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y)
+  return $ \reg_r -> y_code `appOL` x_code
+                     `appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg
+                                  , MULL fmt reg_r reg_q (RIReg y_reg)
+                                  , SUBF reg_r reg_r x_reg
+                                  ]
+
+
+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP fromRep toRep x = do
+    dflags <- getDynFlags
+    let arch =  platformArch $ targetPlatform dflags
+    coerceInt2FP' arch fromRep toRep x
+
+coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP' ArchPPC fromRep toRep x = do
+    (src, code) <- getSomeReg x
+    lbl <- getNewLabelNat
+    itmp <- getNewRegNat II32
+    ftmp <- getNewRegNat FF64
+    dflags <- getDynFlags
+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+    Amode addr addr_code <- getAmode D dynRef
+    let
+        code' dst = code `appOL` maybe_exts `appOL` toOL [
+                LDATA (Section ReadOnlyData lbl) $ Statics lbl
+                                 [CmmStaticLit (CmmInt 0x43300000 W32),
+                                  CmmStaticLit (CmmInt 0x80000000 W32)],
+                XORIS itmp src (ImmInt 0x8000),
+                ST II32 itmp (spRel dflags 3),
+                LIS itmp (ImmInt 0x4330),
+                ST II32 itmp (spRel dflags 2),
+                LD FF64 ftmp (spRel dflags 2)
+            ] `appOL` addr_code `appOL` toOL [
+                LD FF64 dst addr,
+                FSUB FF64 dst ftmp dst
+            ] `appOL` maybe_frsp dst
+
+        maybe_exts = case fromRep of
+                        W8 ->  unitOL $ EXTS II8 src src
+                        W16 -> unitOL $ EXTS II16 src src
+                        W32 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+        maybe_frsp dst
+                = case toRep of
+                        W32 -> unitOL $ FRSP dst dst
+                        W64 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+    return (Any (floatFormat toRep) code')
+
+-- On an ELF v1 Linux we use the compiler doubleword in the stack frame
+-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only
+-- set right before a call and restored right after return from the call.
+-- So it is fine.
+coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do
+    (src, code) <- getSomeReg x
+    dflags <- getDynFlags
+    let
+        code' dst = code `appOL` maybe_exts `appOL` toOL [
+                ST II64 src (spRel dflags 3),
+                LD FF64 dst (spRel dflags 3),
+                FCFID dst dst
+            ] `appOL` maybe_frsp dst
+
+        maybe_exts = case fromRep of
+                        W8 ->  unitOL $ EXTS II8 src src
+                        W16 -> unitOL $ EXTS II16 src src
+                        W32 -> unitOL $ EXTS II32 src src
+                        W64 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+        maybe_frsp dst
+                = case toRep of
+                        W32 -> unitOL $ FRSP dst dst
+                        W64 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+    return (Any (floatFormat toRep) code')
+
+coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch"
+
+
+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int fromRep toRep x = do
+    dflags <- getDynFlags
+    let arch =  platformArch $ targetPlatform dflags
+    coerceFP2Int' arch fromRep toRep x
+
+coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int' ArchPPC _ toRep x = do
+    dflags <- getDynFlags
+    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops
+    (src, code) <- getSomeReg x
+    tmp <- getNewRegNat FF64
+    let
+        code' dst = code `appOL` toOL [
+                -- convert to int in FP reg
+            FCTIWZ tmp src,
+                -- store value (64bit) from FP to stack
+            ST FF64 tmp (spRel dflags 2),
+                -- read low word of value (high word is undefined)
+            LD II32 dst (spRel dflags 3)]
+    return (Any (intFormat toRep) code')
+
+coerceFP2Int' (ArchPPC_64 _) _ toRep x = do
+    dflags <- getDynFlags
+    -- the reps don't really matter: F*->FF64 and II64->I* are no-ops
+    (src, code) <- getSomeReg x
+    tmp <- getNewRegNat FF64
+    let
+        code' dst = code `appOL` toOL [
+                -- convert to int in FP reg
+            FCTIDZ tmp src,
+                -- store value (64bit) from FP to compiler word on stack
+            ST FF64 tmp (spRel dflags 3),
+            LD II64 dst (spRel dflags 3)]
+    return (Any (intFormat toRep) code')
+
+coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"
+
+-- Note [.LCTOC1 in PPC PIC code]
+-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table
+-- to make the most of the PPC's 16-bit displacements.
+-- As 16-bit signed offset is used (usually via addi/lwz instructions)
+-- first element will have '-32768' offset against .LCTOC1.
+
+-- Note [implicit register in PPC PIC code]
+-- PPC generates calls by labels in assembly
+-- in form of:
+--     bl puts+32768@plt
+-- in this form it's not seen directly (by GHC NCG)
+-- that r30 (PicBaseReg) is used,
+-- but r30 is a required part of PLT code setup:
+--   puts+32768@plt:
+--       lwz     r11,-30484(r30) ; offset in .LCTOC1
+--       mtctr   r11
+--       bctr
diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Cond.hs
@@ -0,0 +1,63 @@
+module PPC.Cond (
+        Cond(..),
+        condNegate,
+        condUnsigned,
+        condToSigned,
+        condToUnsigned,
+)
+
+where
+
+import GhcPrelude
+
+import Panic
+
+data Cond
+        = ALWAYS
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        deriving Eq
+
+
+condNegate :: Cond -> Cond
+condNegate ALWAYS  = panic "condNegate: ALWAYS"
+condNegate EQQ     = NE
+condNegate GE      = LTT
+condNegate GEU     = LU
+condNegate GTT     = LE
+condNegate GU      = LEU
+condNegate LE      = GTT
+condNegate LEU     = GU
+condNegate LTT     = GE
+condNegate LU      = GEU
+condNegate NE      = EQQ
+
+-- Condition utils
+condUnsigned :: Cond -> Bool
+condUnsigned GU  = True
+condUnsigned LU  = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _   = False
+
+condToSigned :: Cond -> Cond
+condToSigned GU  = GTT
+condToSigned LU  = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x   = x
+
+condToUnsigned :: Cond -> Cond
+condToUnsigned GTT = GU
+condToUnsigned LTT = LU
+condToUnsigned GE  = GEU
+condToUnsigned LE  = LEU
+condToUnsigned x   = x
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -0,0 +1,712 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module PPC.Instr (
+    archWordFormat,
+    RI(..),
+    Instr(..),
+    stackFrameHeaderSize,
+    maxSpillSlots,
+    allocMoreStack,
+    makeFarBranches
+)
+
+where
+
+import GhcPrelude
+
+import PPC.Regs
+import PPC.Cond
+import Instruction
+import Format
+import TargetReg
+import RegClass
+import Reg
+
+import CodeGen.Platform
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import DynFlags
+import Cmm
+import CmmInfo
+import FastString
+import CLabel
+import Outputable
+import Platform
+import UniqFM (listToUFM, lookupUFM)
+import UniqSupply
+
+import Control.Monad (replicateM)
+import Data.Maybe (fromMaybe)
+
+--------------------------------------------------------------------------------
+-- Format of a PPC memory address.
+--
+archWordFormat :: Bool -> Format
+archWordFormat is32Bit
+ | is32Bit   = II32
+ | otherwise = II64
+
+
+-- | Instruction instance for powerpc
+instance Instruction Instr where
+        regUsageOfInstr         = ppc_regUsageOfInstr
+        patchRegsOfInstr        = ppc_patchRegsOfInstr
+        isJumpishInstr          = ppc_isJumpishInstr
+        jumpDestsOfInstr        = ppc_jumpDestsOfInstr
+        patchJumpInstr          = ppc_patchJumpInstr
+        mkSpillInstr            = ppc_mkSpillInstr
+        mkLoadInstr             = ppc_mkLoadInstr
+        takeDeltaInstr          = ppc_takeDeltaInstr
+        isMetaInstr             = ppc_isMetaInstr
+        mkRegRegMoveInstr _     = ppc_mkRegRegMoveInstr
+        takeRegRegMoveInstr     = ppc_takeRegRegMoveInstr
+        mkJumpInstr             = ppc_mkJumpInstr
+        mkStackAllocInstr       = ppc_mkStackAllocInstr
+        mkStackDeallocInstr     = ppc_mkStackDeallocInstr
+
+
+ppc_mkStackAllocInstr :: Platform -> Int -> [Instr]
+ppc_mkStackAllocInstr platform amount
+  = ppc_mkStackAllocInstr' platform (-amount)
+
+ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr]
+ppc_mkStackDeallocInstr platform amount
+  = ppc_mkStackAllocInstr' platform amount
+
+ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr]
+ppc_mkStackAllocInstr' platform amount
+  | fits16Bits amount
+  = [ LD fmt r0 (AddrRegImm sp zero)
+    , STU fmt r0 (AddrRegImm sp immAmount)
+    ]
+  | otherwise
+  = [ LD fmt r0 (AddrRegImm sp zero)
+    , ADDIS tmp sp (HA immAmount)
+    , ADD tmp tmp (RIImm (LO immAmount))
+    , STU fmt r0 (AddrRegReg sp tmp)
+    ]
+  where
+    fmt = intFormat $ widthFromBytes ((platformWordSize platform) `quot` 8)
+    zero = ImmInt 0
+    tmp = tmpReg platform
+    immAmount = ImmInt amount
+
+--
+-- See note [extra spill slots] in X86/Instr.hs
+--
+allocMoreStack
+  :: Platform
+  -> Int
+  -> NatCmmDecl statics PPC.Instr.Instr
+  -> UniqSM (NatCmmDecl statics PPC.Instr.Instr, [(BlockId,BlockId)])
+
+allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
+allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
+    let
+        infos   = mapKeys info
+        entries = case code of
+                    [] -> infos
+                    BasicBlock entry _ : _ -- first block is the entry point
+                        | entry `elem` infos -> infos
+                        | otherwise          -> entry : infos
+
+    uniqs <- replicateM (length entries) getUniqueM
+
+    let
+        delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
+            where x = slots * spillSlotSize -- sp delta
+
+        alloc   = mkStackAllocInstr   platform delta
+        dealloc = mkStackDeallocInstr platform delta
+
+        retargetList = (zip entries (map mkBlockId uniqs))
+
+        new_blockmap :: LabelMap BlockId
+        new_blockmap = mapFromList retargetList
+
+        insert_stack_insns (BasicBlock id insns)
+            | Just new_blockid <- mapLookup id new_blockmap
+                = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing]
+                  , BasicBlock new_blockid block'
+                  ]
+            | otherwise
+                = [ BasicBlock id block' ]
+            where
+              block' = foldr insert_dealloc [] insns
+
+        insert_dealloc insn r
+            -- BCTR might or might not be a non-local jump. For
+            -- "labeled-goto" we use JMP, and for "computed-goto" we
+            -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
+            = case insn of
+                JMP _ _           -> dealloc ++ (insn : r)
+                BCTR [] Nothing _ -> dealloc ++ (insn : r)
+                BCTR ids label rs -> BCTR (map (fmap retarget) ids) label rs : r
+                BCCFAR cond b p   -> BCCFAR cond (retarget b) p : r
+                BCC    cond b p   -> BCC    cond (retarget b) p : r
+                _                 -> insn : r
+            -- BL and BCTRL are call-like instructions rather than
+            -- jumps, and are used only for C calls.
+
+        retarget :: BlockId -> BlockId
+        retarget b
+            = fromMaybe b (mapLookup b new_blockmap)
+
+        new_code
+            = concatMap insert_stack_insns code
+
+    -- in
+    return (CmmProc info lbl live (ListGraph new_code),retargetList)
+
+
+-- -----------------------------------------------------------------------------
+-- Machine's assembly language
+
+-- We have a few common "instructions" (nearly all the pseudo-ops) but
+-- mostly all of 'Instr' is machine-specific.
+
+-- Register or immediate
+data RI
+    = RIReg Reg
+    | RIImm Imm
+
+data Instr
+    -- comment pseudo-op
+    = COMMENT FastString
+
+    -- some static data spat out during code
+    -- generation.  Will be extracted before
+    -- pretty-printing.
+    | LDATA   Section CmmStatics
+
+    -- start a new basic block.  Useful during
+    -- codegen, removed later.  Preceding
+    -- instruction should be a jump, as per the
+    -- invariants for a BasicBlock (see Cmm).
+    | NEWBLOCK BlockId
+
+    -- specify current stack offset for
+    -- benefit of subsequent passes
+    | DELTA   Int
+
+    -- Loads and stores.
+    | LD      Format Reg AddrMode   -- Load format, dst, src
+    | LDFAR   Format Reg AddrMode   -- Load format, dst, src 32 bit offset
+    | LDR     Format Reg AddrMode   -- Load and reserve format, dst, src
+    | LA      Format Reg AddrMode   -- Load arithmetic format, dst, src
+    | ST      Format Reg AddrMode   -- Store format, src, dst
+    | STFAR   Format Reg AddrMode   -- Store format, src, dst 32 bit offset
+    | STU     Format Reg AddrMode   -- Store with Update format, src, dst
+    | STC     Format Reg AddrMode   -- Store conditional format, src, dst
+    | LIS     Reg Imm               -- Load Immediate Shifted dst, src
+    | LI      Reg Imm               -- Load Immediate dst, src
+    | MR      Reg Reg               -- Move Register dst, src -- also for fmr
+
+    | CMP     Format Reg RI         -- format, src1, src2
+    | CMPL    Format Reg RI         -- format, src1, src2
+
+    | BCC     Cond BlockId (Maybe Bool) -- cond, block, hint
+    | BCCFAR  Cond BlockId (Maybe Bool) -- cond, block, hint
+                                    --   hint:
+                                    --    Just True:  branch likely taken
+                                    --    Just False: branch likely not taken
+                                    --    Nothing:    no hint
+    | JMP     CLabel [Reg]          -- same as branch,
+                                    -- but with CLabel instead of block ID
+                                    -- and live global registers
+    | MTCTR   Reg
+    | BCTR    [Maybe BlockId] (Maybe CLabel) [Reg]
+                                    -- with list of local destinations, and
+                                    -- jump table location if necessary
+    | BL      CLabel [Reg]          -- with list of argument regs
+    | BCTRL   [Reg]
+
+    | ADD     Reg Reg RI            -- dst, src1, src2
+    | ADDO    Reg Reg Reg           -- add and set overflow
+    | ADDC    Reg Reg Reg           -- (carrying) dst, src1, src2
+    | ADDE    Reg Reg Reg           -- (extended) dst, src1, src2
+    | ADDZE   Reg Reg               -- (to zero extended) dst, src
+    | ADDIS   Reg Reg Imm           -- Add Immediate Shifted dst, src1, src2
+    | SUBF    Reg Reg Reg           -- dst, src1, src2 ; dst = src2 - src1
+    | SUBFO   Reg Reg Reg           -- subtract from and set overflow
+    | SUBFC   Reg Reg RI            -- (carrying) dst, src1, src2 ;
+                                    -- dst = src2 - src1
+    | SUBFE   Reg Reg Reg           -- (extended) dst, src1, src2 ;
+                                    -- dst = src2 - src1
+    | MULL    Format Reg Reg RI
+    | MULLO   Format Reg Reg Reg    -- multiply and set overflow
+    | MFOV    Format Reg            -- move overflow bit (1|33) to register
+                                    -- pseudo-instruction; pretty printed as
+                                    -- mfxer dst
+                                    -- extr[w|d]i dst, dst, 1, [1|33]
+    | MULHU   Format Reg Reg Reg
+    | DIV     Format Bool Reg Reg Reg
+    | AND     Reg Reg RI            -- dst, src1, src2
+    | ANDC    Reg Reg Reg           -- AND with complement, dst = src1 & ~ src2
+    | NAND    Reg Reg Reg           -- dst, src1, src2
+    | OR      Reg Reg RI            -- dst, src1, src2
+    | ORIS    Reg Reg Imm           -- OR Immediate Shifted dst, src1, src2
+    | XOR     Reg Reg RI            -- dst, src1, src2
+    | XORIS   Reg Reg Imm           -- XOR Immediate Shifted dst, src1, src2
+
+    | EXTS    Format Reg Reg
+    | CNTLZ   Format Reg Reg
+
+    | NEG     Reg Reg
+    | NOT     Reg Reg
+
+    | SL      Format Reg Reg RI            -- shift left
+    | SR      Format Reg Reg RI            -- shift right
+    | SRA     Format Reg Reg RI            -- shift right arithmetic
+
+    | RLWINM  Reg Reg Int Int Int   -- Rotate Left Word Immediate then AND with Mask
+    | CLRLI   Format Reg Reg Int    -- clear left immediate (extended mnemonic)
+    | CLRRI   Format Reg Reg Int    -- clear right immediate (extended mnemonic)
+
+    | FADD    Format Reg Reg Reg
+    | FSUB    Format Reg Reg Reg
+    | FMUL    Format Reg Reg Reg
+    | FDIV    Format Reg Reg Reg
+    | FABS    Reg Reg               -- abs is the same for single and double
+    | FNEG    Reg Reg               -- negate is the same for single and double prec.
+
+    | FCMP    Reg Reg
+
+    | FCTIWZ  Reg Reg           -- convert to integer word
+    | FCTIDZ  Reg Reg           -- convert to integer double word
+    | FCFID   Reg Reg           -- convert from integer double word
+    | FRSP    Reg Reg           -- reduce to single precision
+                                -- (but destination is a FP register)
+
+    | CRNOR   Int Int Int       -- condition register nor
+    | MFCR    Reg               -- move from condition register
+
+    | MFLR    Reg               -- move from link register
+    | FETCHPC Reg               -- pseudo-instruction:
+                                -- bcl to next insn, mflr reg
+    | HWSYNC                    -- heavy weight sync
+    | ISYNC                     -- instruction synchronize
+    | LWSYNC                    -- memory barrier
+    | NOP                       -- no operation, PowerPC 64 bit
+                                -- needs this as place holder to
+                                -- reload TOC pointer
+
+-- | Get the registers that are being used by this instruction.
+-- regUsage doesn't need to do any trickery for jumps and such.
+-- Just state precisely the regs read and written by that insn.
+-- The consequences of control flow transfers, as far as register
+-- allocation goes, are taken care of by the register allocator.
+--
+ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage
+ppc_regUsageOfInstr platform instr
+ = case instr of
+    LD      _ reg addr       -> usage (regAddr addr, [reg])
+    LDFAR   _ reg addr       -> usage (regAddr addr, [reg])
+    LDR     _ reg addr       -> usage (regAddr addr, [reg])
+    LA      _ reg addr       -> usage (regAddr addr, [reg])
+    ST      _ reg addr       -> usage (reg : regAddr addr, [])
+    STFAR   _ reg addr       -> usage (reg : regAddr addr, [])
+    STU     _ reg addr       -> usage (reg : regAddr addr, [])
+    STC     _ reg addr       -> usage (reg : regAddr addr, [])
+    LIS     reg _            -> usage ([], [reg])
+    LI      reg _            -> usage ([], [reg])
+    MR      reg1 reg2        -> usage ([reg2], [reg1])
+    CMP     _ reg ri         -> usage (reg : regRI ri,[])
+    CMPL    _ reg ri         -> usage (reg : regRI ri,[])
+    BCC     _ _ _            -> noUsage
+    BCCFAR  _ _ _            -> noUsage
+    JMP     _ regs           -> usage (regs, [])
+    MTCTR   reg              -> usage ([reg],[])
+    BCTR    _ _ regs         -> usage (regs, [])
+    BL      _ params         -> usage (params, callClobberedRegs platform)
+    BCTRL   params           -> usage (params, callClobberedRegs platform)
+
+    ADD     reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])
+    ADDO    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    ADDC    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    ADDE    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    ADDZE   reg1 reg2        -> usage ([reg2], [reg1])
+    ADDIS   reg1 reg2 _      -> usage ([reg2], [reg1])
+    SUBF    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    SUBFO   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    SUBFC   reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])
+    SUBFE   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    MULL    _ reg1 reg2 ri   -> usage (reg2 : regRI ri, [reg1])
+    MULLO   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
+    MFOV    _ reg            -> usage ([], [reg])
+    MULHU   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
+    DIV     _ _ reg1 reg2 reg3
+                             -> usage ([reg2,reg3], [reg1])
+
+    AND     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
+    ANDC    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
+    NAND    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
+    OR      reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
+    ORIS    reg1 reg2 _     -> usage ([reg2], [reg1])
+    XOR     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
+    XORIS   reg1 reg2 _     -> usage ([reg2], [reg1])
+    EXTS    _  reg1 reg2    -> usage ([reg2], [reg1])
+    CNTLZ   _  reg1 reg2    -> usage ([reg2], [reg1])
+    NEG     reg1 reg2       -> usage ([reg2], [reg1])
+    NOT     reg1 reg2       -> usage ([reg2], [reg1])
+    SL      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
+    SR      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
+    SRA     _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
+    RLWINM  reg1 reg2 _ _ _ -> usage ([reg2], [reg1])
+    CLRLI   _ reg1 reg2 _   -> usage ([reg2], [reg1])
+    CLRRI   _ reg1 reg2 _   -> usage ([reg2], [reg1])
+
+    FADD    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FSUB    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FMUL    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FDIV    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FABS    r1 r2           -> usage ([r2], [r1])
+    FNEG    r1 r2           -> usage ([r2], [r1])
+    FCMP    r1 r2           -> usage ([r1,r2], [])
+    FCTIWZ  r1 r2           -> usage ([r2], [r1])
+    FCTIDZ  r1 r2           -> usage ([r2], [r1])
+    FCFID   r1 r2           -> usage ([r2], [r1])
+    FRSP    r1 r2           -> usage ([r2], [r1])
+    MFCR    reg             -> usage ([], [reg])
+    MFLR    reg             -> usage ([], [reg])
+    FETCHPC reg             -> usage ([], [reg])
+    _                       -> noUsage
+  where
+    usage (src, dst) = RU (filter (interesting platform) src)
+                          (filter (interesting platform) dst)
+    regAddr (AddrRegReg r1 r2) = [r1, r2]
+    regAddr (AddrRegImm r1 _)  = [r1]
+
+    regRI (RIReg r) = [r]
+    regRI  _        = []
+
+interesting :: Platform -> Reg -> Bool
+interesting _        (RegVirtual _)              = True
+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+interesting _        (RegReal (RealRegPair{}))
+    = panic "PPC.Instr.interesting: no reg pairs on this arch"
+
+
+
+-- | Apply a given mapping to all the register references in this
+-- instruction.
+ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+ppc_patchRegsOfInstr instr env
+ = case instr of
+    LD      fmt reg addr    -> LD fmt (env reg) (fixAddr addr)
+    LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)
+    LDR     fmt reg addr    -> LDR fmt (env reg) (fixAddr addr)
+    LA      fmt reg addr    -> LA fmt (env reg) (fixAddr addr)
+    ST      fmt reg addr    -> ST fmt (env reg) (fixAddr addr)
+    STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)
+    STU     fmt reg addr    -> STU fmt (env reg) (fixAddr addr)
+    STC     fmt reg addr    -> STC fmt (env reg) (fixAddr addr)
+    LIS     reg imm         -> LIS (env reg) imm
+    LI      reg imm         -> LI (env reg) imm
+    MR      reg1 reg2       -> MR (env reg1) (env reg2)
+    CMP     fmt reg ri      -> CMP fmt (env reg) (fixRI ri)
+    CMPL    fmt reg ri      -> CMPL fmt (env reg) (fixRI ri)
+    BCC     cond lbl p      -> BCC cond lbl p
+    BCCFAR  cond lbl p      -> BCCFAR cond lbl p
+    JMP     l regs          -> JMP l regs -- global regs will not be remapped
+    MTCTR   reg             -> MTCTR (env reg)
+    BCTR    targets lbl rs  -> BCTR targets lbl rs
+    BL      imm argRegs     -> BL imm argRegs    -- argument regs
+    BCTRL   argRegs         -> BCTRL argRegs     -- cannot be remapped
+    ADD     reg1 reg2 ri    -> ADD (env reg1) (env reg2) (fixRI ri)
+    ADDO    reg1 reg2 reg3  -> ADDO (env reg1) (env reg2) (env reg3)
+    ADDC    reg1 reg2 reg3  -> ADDC (env reg1) (env reg2) (env reg3)
+    ADDE    reg1 reg2 reg3  -> ADDE (env reg1) (env reg2) (env reg3)
+    ADDZE   reg1 reg2       -> ADDZE (env reg1) (env reg2)
+    ADDIS   reg1 reg2 imm   -> ADDIS (env reg1) (env reg2) imm
+    SUBF    reg1 reg2 reg3  -> SUBF (env reg1) (env reg2) (env reg3)
+    SUBFO   reg1 reg2 reg3  -> SUBFO (env reg1) (env reg2) (env reg3)
+    SUBFC   reg1 reg2 ri    -> SUBFC (env reg1) (env reg2) (fixRI ri)
+    SUBFE   reg1 reg2 reg3  -> SUBFE (env reg1) (env reg2) (env reg3)
+    MULL    fmt reg1 reg2 ri
+                            -> MULL fmt (env reg1) (env reg2) (fixRI ri)
+    MULLO   fmt reg1 reg2 reg3
+                            -> MULLO fmt (env reg1) (env reg2) (env reg3)
+    MFOV    fmt reg         -> MFOV fmt (env reg)
+    MULHU   fmt reg1 reg2 reg3
+                            -> MULHU fmt (env reg1) (env reg2) (env reg3)
+    DIV     fmt sgn reg1 reg2 reg3
+                            -> DIV fmt sgn (env reg1) (env reg2) (env reg3)
+
+    AND     reg1 reg2 ri    -> AND (env reg1) (env reg2) (fixRI ri)
+    ANDC    reg1 reg2 reg3  -> ANDC (env reg1) (env reg2) (env reg3)
+    NAND    reg1 reg2 reg3  -> NAND (env reg1) (env reg2) (env reg3)
+    OR      reg1 reg2 ri    -> OR  (env reg1) (env reg2) (fixRI ri)
+    ORIS    reg1 reg2 imm   -> ORIS (env reg1) (env reg2) imm
+    XOR     reg1 reg2 ri    -> XOR (env reg1) (env reg2) (fixRI ri)
+    XORIS   reg1 reg2 imm   -> XORIS (env reg1) (env reg2) imm
+    EXTS    fmt reg1 reg2   -> EXTS fmt (env reg1) (env reg2)
+    CNTLZ   fmt reg1 reg2   -> CNTLZ fmt (env reg1) (env reg2)
+    NEG     reg1 reg2       -> NEG (env reg1) (env reg2)
+    NOT     reg1 reg2       -> NOT (env reg1) (env reg2)
+    SL      fmt reg1 reg2 ri
+                            -> SL fmt (env reg1) (env reg2) (fixRI ri)
+    SR      fmt reg1 reg2 ri
+                            -> SR fmt (env reg1) (env reg2) (fixRI ri)
+    SRA     fmt reg1 reg2 ri
+                            -> SRA fmt (env reg1) (env reg2) (fixRI ri)
+    RLWINM  reg1 reg2 sh mb me
+                            -> RLWINM (env reg1) (env reg2) sh mb me
+    CLRLI   fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n
+    CLRRI   fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n
+    FADD    fmt r1 r2 r3    -> FADD fmt (env r1) (env r2) (env r3)
+    FSUB    fmt r1 r2 r3    -> FSUB fmt (env r1) (env r2) (env r3)
+    FMUL    fmt r1 r2 r3    -> FMUL fmt (env r1) (env r2) (env r3)
+    FDIV    fmt r1 r2 r3    -> FDIV fmt (env r1) (env r2) (env r3)
+    FABS    r1 r2           -> FABS (env r1) (env r2)
+    FNEG    r1 r2           -> FNEG (env r1) (env r2)
+    FCMP    r1 r2           -> FCMP (env r1) (env r2)
+    FCTIWZ  r1 r2           -> FCTIWZ (env r1) (env r2)
+    FCTIDZ  r1 r2           -> FCTIDZ (env r1) (env r2)
+    FCFID   r1 r2           -> FCFID (env r1) (env r2)
+    FRSP    r1 r2           -> FRSP (env r1) (env r2)
+    MFCR    reg             -> MFCR (env reg)
+    MFLR    reg             -> MFLR (env reg)
+    FETCHPC reg             -> FETCHPC (env reg)
+    _                       -> instr
+  where
+    fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
+    fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
+
+    fixRI (RIReg r) = RIReg (env r)
+    fixRI other     = other
+
+
+--------------------------------------------------------------------------------
+-- | Checks whether this instruction is a jump/branch instruction.
+-- One that can change the flow of control in a way that the
+-- register allocator needs to worry about.
+ppc_isJumpishInstr :: Instr -> Bool
+ppc_isJumpishInstr instr
+ = case instr of
+    BCC{}       -> True
+    BCCFAR{}    -> True
+    BCTR{}      -> True
+    BCTRL{}     -> True
+    BL{}        -> True
+    JMP{}       -> True
+    _           -> False
+
+
+-- | Checks whether this instruction is a jump/branch instruction.
+-- One that can change the flow of control in a way that the
+-- register allocator needs to worry about.
+ppc_jumpDestsOfInstr :: Instr -> [BlockId]
+ppc_jumpDestsOfInstr insn
+  = case insn of
+        BCC _ id _       -> [id]
+        BCCFAR _ id _    -> [id]
+        BCTR targets _ _ -> [id | Just id <- targets]
+        _                -> []
+
+
+-- | Change the destination of this jump instruction.
+-- Used in the linear allocator when adding fixup blocks for join
+-- points.
+ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
+ppc_patchJumpInstr insn patchF
+  = case insn of
+        BCC cc id p     -> BCC cc (patchF id) p
+        BCCFAR cc id p  -> BCCFAR cc (patchF id) p
+        BCTR ids lbl rs -> BCTR (map (fmap patchF) ids) lbl rs
+        _               -> insn
+
+
+-- -----------------------------------------------------------------------------
+
+-- | An instruction to spill a register into a spill slot.
+ppc_mkSpillInstr
+   :: DynFlags
+   -> Reg       -- register to spill
+   -> Int       -- current stack delta
+   -> Int       -- spill slot to use
+   -> Instr
+
+ppc_mkSpillInstr dflags reg delta slot
+  = let platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        arch     = platformArch platform
+    in
+    let fmt = case targetClassOfReg platform reg of
+                RcInteger -> case arch of
+                                ArchPPC -> II32
+                                _       -> II64
+                RcDouble  -> FF64
+                _         -> panic "PPC.Instr.mkSpillInstr: no match"
+        instr = case makeImmediate W32 True (off-delta) of
+                Just _  -> ST
+                Nothing -> STFAR -- pseudo instruction: 32 bit offsets
+
+    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))
+
+
+ppc_mkLoadInstr
+   :: DynFlags
+   -> Reg       -- register to load
+   -> Int       -- current stack delta
+   -> Int       -- spill slot to use
+   -> Instr
+
+ppc_mkLoadInstr dflags reg delta slot
+  = let platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        arch     = platformArch platform
+    in
+    let fmt = case targetClassOfReg platform reg of
+                RcInteger ->  case arch of
+                                 ArchPPC -> II32
+                                 _       -> II64
+                RcDouble  -> FF64
+                _         -> panic "PPC.Instr.mkLoadInstr: no match"
+        instr = case makeImmediate W32 True (off-delta) of
+                Just _  -> LD
+                Nothing -> LDFAR -- pseudo instruction: 32 bit offsets
+
+    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))
+
+
+-- | The size of a minimal stackframe header including minimal
+-- parameter save area.
+stackFrameHeaderSize :: DynFlags -> Int
+stackFrameHeaderSize dflags
+  = case platformOS platform of
+      OSAIX    -> 24 + 8 * 4
+      _ -> case platformArch platform of
+                             -- header + parameter save area
+             ArchPPC           -> 64 -- TODO: check ABI spec
+             ArchPPC_64 ELF_V1 -> 48 + 8 * 8
+             ArchPPC_64 ELF_V2 -> 32 + 8 * 8
+             _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS"
+     where platform = targetPlatform dflags
+
+-- | The maximum number of bytes required to spill a register. PPC32
+-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and
+-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike
+-- x86. Note that AltiVec's vector registers are 128-bit wide so we
+-- must not use this to spill them.
+spillSlotSize :: Int
+spillSlotSize = 8
+
+-- | The number of spill slots available without allocating more.
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+    = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags)
+       `div` spillSlotSize) - 1
+--     = 0 -- useful for testing allocMoreStack
+
+-- | The number of bytes that the stack pointer should be aligned
+-- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor
+-- specific supplements).
+stackAlign :: Int
+stackAlign = 16
+
+-- | Convert a spill slot number to a *byte* offset, with no sign.
+spillSlotToOffset :: DynFlags -> Int -> Int
+spillSlotToOffset dflags slot
+   = stackFrameHeaderSize dflags + spillSlotSize * slot
+
+
+--------------------------------------------------------------------------------
+-- | See if this instruction is telling us the current C stack delta
+ppc_takeDeltaInstr
+    :: Instr
+    -> Maybe Int
+
+ppc_takeDeltaInstr instr
+ = case instr of
+     DELTA i  -> Just i
+     _        -> Nothing
+
+
+ppc_isMetaInstr
+    :: Instr
+    -> Bool
+
+ppc_isMetaInstr instr
+ = case instr of
+    COMMENT{}   -> True
+    LDATA{}     -> True
+    NEWBLOCK{}  -> True
+    DELTA{}     -> True
+    _           -> False
+
+
+-- | Copy the value in a register to another one.
+-- Must work for all register classes.
+ppc_mkRegRegMoveInstr
+    :: Reg
+    -> Reg
+    -> Instr
+
+ppc_mkRegRegMoveInstr src dst
+    = MR dst src
+
+
+-- | Make an unconditional jump instruction.
+ppc_mkJumpInstr
+    :: BlockId
+    -> [Instr]
+
+ppc_mkJumpInstr id
+    = [BCC ALWAYS id Nothing]
+
+
+-- | Take the source and destination from this reg -> reg move instruction
+-- or Nothing if it's not one
+ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
+ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)
+ppc_takeRegRegMoveInstr _  = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Making far branches
+
+-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
+-- big, we have to work around this limitation.
+
+makeFarBranches
+        :: LabelMap CmmStatics
+        -> [NatBasicBlock Instr]
+        -> [NatBasicBlock Instr]
+makeFarBranches info_env blocks
+    | last blockAddresses < nearLimit = blocks
+    | otherwise = zipWith handleBlock blockAddresses blocks
+    where
+        blockAddresses = scanl (+) 0 $ map blockLen blocks
+        blockLen (BasicBlock _ instrs) = length instrs
+
+        handleBlock addr (BasicBlock id instrs)
+                = BasicBlock id (zipWith makeFar [addr..] instrs)
+
+        makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing
+        makeFar addr (BCC cond tgt p)
+            | abs (addr - targetAddr) >= nearLimit
+            = BCCFAR cond tgt p
+            | otherwise
+            = BCC cond tgt p
+            where Just targetAddr = lookupUFM blockAddressMap tgt
+        makeFar _ other            = other
+
+        -- 8192 instructions are allowed; let's keep some distance, as
+        -- we have a few pseudo-insns that are pretty-printed as
+        -- multiple instructions, and it's just not worth the effort
+        -- to calculate things exactly
+        nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW
+
+        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -0,0 +1,994 @@
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PPC.Ppr (pprNatCmmDecl) where
+
+import GhcPrelude
+
+import PPC.Regs
+import PPC.Instr
+import PPC.Cond
+import PprBase
+import Instruction
+import Format
+import Reg
+import RegClass
+import TargetReg
+
+import Cmm hiding (topInfoTable)
+import Hoopl.Collections
+import Hoopl.Label
+
+import BlockId
+import CLabel
+import PprCmmExpr ()
+
+import Unique                ( pprUniqueAlways, getUnique )
+import Platform
+import FastString
+import Outputable
+import DynFlags
+
+import Data.Word
+import Data.Int
+import Data.Bits
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
+
+pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionAlign section $$ pprDatas dats
+
+pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       sdocWithPlatform $ \platform ->
+         -- special case for code without info table:
+         pprSectionAlign (Section Text lbl) $$
+         (case platformArch platform of
+            ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl
+            ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl
+            _ -> pprLabel lbl) $$ -- blocks guaranteed not null,
+                                     -- so label needed
+         vcat (map (pprBasicBlock top_info) blocks)
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionAlign (Section Text info_lbl) $$
+      (if platformHasSubsectionsViaSymbols platform
+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+      -- above: Even the first block gets a label, because with branch-chain
+      -- elimination, it might be the target of a goto.
+      (if platformHasSubsectionsViaSymbols platform
+       then
+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs
+                text "\t.long "
+            <+> ppr info_lbl
+            <+> char '-'
+            <+> ppr (mkDeadStripPreventer info_lbl)
+       else empty)
+
+pprFunctionDescriptor :: CLabel -> SDoc
+pprFunctionDescriptor lab = pprGloblDecl lab
+                        $$  text "\t.section \".opd\", \"aw\""
+                        $$  text "\t.align 3"
+                        $$  ppr lab <> char ':'
+                        $$  text "\t.quad ."
+                        <>  ppr lab
+                        <>  text ",.TOC.@tocbase,0"
+                        $$  text "\t.previous"
+                        $$  text "\t.type"
+                        <+> ppr lab
+                        <>  text ", @function"
+                        $$  char '.' <> ppr lab <> char ':'
+
+pprFunctionPrologue :: CLabel ->SDoc
+pprFunctionPrologue lab =  pprGloblDecl lab
+                        $$  text ".type "
+                        <> ppr lab
+                        <> text ", @function"
+                        $$ ppr lab <> char ':'
+                        $$ text "0:\taddis\t" <> pprReg toc
+                        <> text ",12,.TOC.-0b@ha"
+                        $$ text "\taddi\t" <> pprReg toc
+                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"
+                        $$ text "\t.localentry\t" <> ppr lab
+                        <> text ",.-" <> ppr lab
+
+pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = maybe_infotable $$
+    pprLabel (blockLbl blockid) $$
+    vcat (map pprInstr instrs)
+  where
+    maybe_infotable = case mapLookup blockid info_env of
+       Nothing   -> empty
+       Just (Statics info_lbl info) ->
+           pprAlignForSection Text $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+
+
+
+pprDatas :: CmmStatics -> SDoc
+-- See note [emit-time elimination of static indirections] in CLabel.
+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+  | lbl == mkIndStaticInfoLabel
+  , let labelInd (CmmLabelOff l _) = Just l
+        labelInd (CmmLabel l) = Just l
+        labelInd _ = Nothing
+  , Just ind' <- labelInd ind
+  , alias `mayRedirectTo` ind'
+  = pprGloblDecl alias
+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
+
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str)          = pprBytes str
+pprData (CmmUninitialised bytes) = text ".space " <> int bytes
+pprData (CmmStaticLit lit)       = pprDataItem lit
+
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = text ".globl " <> ppr lbl
+
+pprTypeAndSizeDecl :: CLabel -> SDoc
+pprTypeAndSizeDecl lbl
+  = sdocWithPlatform $ \platform ->
+    if platformOS platform == OSLinux && externallyVisibleCLabel lbl
+    then text ".type " <>
+         ppr lbl <> text ", @object"
+    else empty
+
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeAndSizeDecl lbl
+            $$ (ppr lbl <> char ':')
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+    ppr instr = pprInstr instr
+
+
+pprReg :: Reg -> SDoc
+
+pprReg r
+  = case r of
+      RegReal    (RealRegSingle i) -> ppr_reg_no i
+      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"
+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u
+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u
+
+  where
+    ppr_reg_no :: Int -> SDoc
+    ppr_reg_no i
+         | i <= 31   = int i      -- GPRs
+         | i <= 63   = int (i-32) -- FPRs
+         | otherwise = text "very naughty powerpc register"
+
+
+
+pprFormat :: Format -> SDoc
+pprFormat x
+ = ptext (case x of
+                II8  -> sLit "b"
+                II16 -> sLit "h"
+                II32 -> sLit "w"
+                II64 -> sLit "d"
+                FF32 -> sLit "fs"
+                FF64 -> sLit "fd")
+
+
+pprCond :: Cond -> SDoc
+pprCond c
+ = ptext (case c of {
+                ALWAYS  -> sLit "";
+                EQQ     -> sLit "eq";  NE    -> sLit "ne";
+                LTT     -> sLit "lt";  GE    -> sLit "ge";
+                GTT     -> sLit "gt";  LE    -> sLit "le";
+                LU      -> sLit "lt";  GEU   -> sLit "ge";
+                GU      -> sLit "gt";  LEU   -> sLit "le"; })
+
+
+pprImm :: Imm -> SDoc
+
+pprImm (ImmInt i)     = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l)    = ppr l
+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
+pprImm (ImmLit s)     = s
+
+pprImm (ImmFloat _)  = text "naughty float immediate"
+pprImm (ImmDouble _) = text "naughty double immediate"
+
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+                   <> lparen <> pprImm b <> rparen
+
+pprImm (LO (ImmInt i))     = pprImm (LO (ImmInteger (toInteger i)))
+pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))
+  where
+    lo16 = fromInteger (i .&. 0xffff) :: Int16
+
+pprImm (LO i)
+  = pprImm i <> text "@l"
+
+pprImm (HI i)
+  = pprImm i <> text "@h"
+
+pprImm (HA (ImmInt i))     = pprImm (HA (ImmInteger (toInteger i)))
+pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)
+  where
+    ha16 = if lo16 >= 0x8000 then hi16+1 else hi16
+    hi16 = (i `shiftR` 16)
+    lo16 = i .&. 0xffff
+
+pprImm (HA i)
+  = pprImm i <> text "@ha"
+
+pprImm (HIGHERA i)
+  = pprImm i <> text "@highera"
+
+pprImm (HIGHESTA i)
+  = pprImm i <> text "@highesta"
+
+
+pprAddr :: AddrMode -> SDoc
+pprAddr (AddrRegReg r1 r2)
+  = pprReg r1 <> char ',' <+> pprReg r2
+pprAddr (AddrRegImm r1 (ImmInt i))
+  = hcat [ int i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 (ImmInteger i))
+  = hcat [ integer i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 imm)
+  = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
+
+
+pprSectionAlign :: Section -> SDoc
+pprSectionAlign sec@(Section seg _) =
+ sdocWithPlatform $ \platform ->
+   pprSectionHeader platform sec $$
+   pprAlignForSection seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: SectionType -> SDoc
+pprAlignForSection seg =
+ sdocWithPlatform $ \platform ->
+ let ppc64    = not $ target32Bit platform
+ in ptext $ case seg of
+       Text              -> sLit ".align 2"
+       Data
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       ReadOnlyData
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       RelocatableReadOnlyData
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       UninitialisedData
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       ReadOnlyData16    -> sLit ".align 4"
+       -- TODO: This is copied from the ReadOnlyData case, but it can likely be
+       -- made more efficient.
+       CString
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"
+
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit
+  = sdocWithDynFlags $ \dflags ->
+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)
+    where
+        imm = litToImm lit
+        archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags
+
+        ppr_item II8   _ _ = [text "\t.byte\t" <> pprImm imm]
+
+        ppr_item II32  _ _ = [text "\t.long\t" <> pprImm imm]
+
+        ppr_item II64 _ dflags
+           | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]
+
+
+        ppr_item FF32 (CmmFloat r _) _
+           = let bs = floatToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item FF64 (CmmFloat r _) _
+           = let bs = doubleToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item II16 _ _      = [text "\t.short\t" <> pprImm imm]
+
+        ppr_item II64 (CmmInt x _) dflags
+           | not(archPPC_64 dflags) =
+                [text "\t.long\t"
+                    <> int (fromIntegral
+                        (fromIntegral (x `shiftR` 32) :: Word32)),
+                 text "\t.long\t"
+                    <> int (fromIntegral (fromIntegral x :: Word32))]
+
+        ppr_item _ _ _
+                = panic "PPC.Ppr.pprDataItem: no match"
+
+
+pprInstr :: Instr -> SDoc
+
+pprInstr (COMMENT _) = empty -- nuke 'em
+{-
+pprInstr (COMMENT s) =
+     if platformOS platform == OSLinux
+     then text "# " <> ftext s
+     else text "; " <> ftext s
+-}
+pprInstr (DELTA d)
+   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+pprInstr (NEWBLOCK _)
+   = panic "PprMach.pprInstr: NEWBLOCK"
+
+pprInstr (LDATA _ _)
+   = panic "PprMach.pprInstr: LDATA"
+
+{-
+pprInstr (SPILL reg slot)
+   = hcat [
+           text "\tSPILL",
+        char '\t',
+        pprReg reg,
+        comma,
+        text "SLOT" <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+           text "\tRELOAD",
+        char '\t',
+        text "SLOT" <> parens (int slot),
+        comma,
+        pprReg reg]
+-}
+
+pprInstr (LD fmt reg addr) = hcat [
+        char '\t',
+        text "l",
+        ptext (case fmt of
+            II8  -> sLit "bz"
+            II16 -> sLit "hz"
+            II32 -> sLit "wz"
+            II64 -> sLit "d"
+            FF32 -> sLit "fs"
+            FF64 -> sLit "fd"
+            ),
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+
+pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+pprInstr (LDFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr LDFAR: no match"
+
+pprInstr (LDR fmt reg1 addr) = hcat [
+  text "\tl",
+  case fmt of
+    II32 -> char 'w'
+    II64 -> char 'd'
+    _    -> panic "PPC.Ppr.Instr LDR: no match",
+  text "arx\t",
+  pprReg reg1,
+  text ", ",
+  pprAddr addr
+  ]
+
+pprInstr (LA fmt reg addr) = hcat [
+        char '\t',
+        text "l",
+        ptext (case fmt of
+            II8  -> sLit "ba"
+            II16 -> sLit "ha"
+            II32 -> sLit "wa"
+            II64 -> sLit "d"
+            FF32 -> sLit "fs"
+            FF64 -> sLit "fd"
+            ),
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+pprInstr (ST fmt reg addr) = hcat [
+        char '\t',
+        text "st",
+        pprFormat fmt,
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+pprInstr (STFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+pprInstr (STFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr STFAR: no match"
+pprInstr (STU fmt reg addr) = hcat [
+        char '\t',
+        text "st",
+        pprFormat fmt,
+        char 'u',
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+pprInstr (STC fmt reg1 addr) = hcat [
+  text "\tst",
+  case fmt of
+    II32 -> char 'w'
+    II64 -> char 'd'
+    _    -> panic "PPC.Ppr.Instr STC: no match",
+  text "cx.\t",
+  pprReg reg1,
+  text ", ",
+  pprAddr addr
+  ]
+pprInstr (LIS reg imm) = hcat [
+        char '\t',
+        text "lis",
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprImm imm
+    ]
+pprInstr (LI reg imm) = hcat [
+        char '\t',
+        text "li",
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprImm imm
+    ]
+pprInstr (MR reg1 reg2)
+    | reg1 == reg2 = empty
+    | otherwise = hcat [
+        char '\t',
+        sdocWithPlatform $ \platform ->
+        case targetClassOfReg platform reg1 of
+            RcInteger -> text "mr"
+            _ -> text "fmr",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+pprInstr (CMP fmt reg ri) = hcat [
+        char '\t',
+        op,
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprRI ri
+    ]
+    where
+        op = hcat [
+                text "cmp",
+                pprFormat fmt,
+                case ri of
+                    RIReg _ -> empty
+                    RIImm _ -> char 'i'
+            ]
+pprInstr (CMPL fmt reg ri) = hcat [
+        char '\t',
+        op,
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprRI ri
+    ]
+    where
+        op = hcat [
+                text "cmpl",
+                pprFormat fmt,
+                case ri of
+                    RIReg _ -> empty
+                    RIImm _ -> char 'i'
+            ]
+pprInstr (BCC cond blockid prediction) = hcat [
+        char '\t',
+        text "b",
+        pprCond cond,
+        pprPrediction prediction,
+        char '\t',
+        ppr lbl
+    ]
+    where lbl = mkLocalBlockLabel (getUnique blockid)
+          pprPrediction p = case p of
+            Nothing    -> empty
+            Just True  -> char '+'
+            Just False -> char '-'
+
+pprInstr (BCCFAR cond blockid prediction) = vcat [
+        hcat [
+            text "\tb",
+            pprCond (condNegate cond),
+            neg_prediction,
+            text "\t$+8"
+        ],
+        hcat [
+            text "\tb\t",
+            ppr lbl
+        ]
+    ]
+    where lbl = mkLocalBlockLabel (getUnique blockid)
+          neg_prediction = case prediction of
+            Nothing    -> empty
+            Just True  -> char '-'
+            Just False -> char '+'
+
+pprInstr (JMP lbl _)
+  -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
+  | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"
+  | otherwise =
+    hcat [ -- an alias for b that takes a CLabel
+        char '\t',
+        text "b",
+        char '\t',
+        ppr lbl
+    ]
+
+pprInstr (MTCTR reg) = hcat [
+        char '\t',
+        text "mtctr",
+        char '\t',
+        pprReg reg
+    ]
+pprInstr (BCTR _ _ _) = hcat [
+        char '\t',
+        text "bctr"
+    ]
+pprInstr (BL lbl _) = do
+    sdocWithPlatform $ \platform -> case platformOS platform of
+        OSAIX ->
+          -- On AIX, "printf" denotes a function-descriptor (for use
+          -- by function pointers), whereas the actual entry-code
+          -- address is denoted by the dot-prefixed ".printf" label.
+          -- Moreover, the PPC NCG only ever emits a BL instruction
+          -- for calling C ABI functions. Most of the time these calls
+          -- originate from FFI imports and have a 'ForeignLabel',
+          -- but when profiling the codegen inserts calls via
+          -- 'emitRtsCallGen' which are 'CmmLabel's even though
+          -- they'd technically be more like 'ForeignLabel's.
+          hcat [
+            text "\tbl\t.",
+            ppr lbl
+          ]
+        _ ->
+          hcat [
+            text "\tbl\t",
+            ppr lbl
+          ]
+pprInstr (BCTRL _) = hcat [
+        char '\t',
+        text "bctrl"
+    ]
+pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
+pprInstr (ADDIS reg1 reg2 imm) = hcat [
+        char '\t',
+        text "addis",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+
+pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)
+pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
+pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
+pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2
+pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
+pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)
+pprInstr (SUBFC reg1 reg2 ri) = hcat [
+        char '\t',
+        text "subf",
+        case ri of
+            RIReg _ -> empty
+            RIImm _ -> char 'i',
+        text "c\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprRI ri
+    ]
+pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)
+pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri
+pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [
+        char '\t',
+        text "mull",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        text "o\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+pprInstr (MFOV fmt reg) = vcat [
+        hcat [
+            char '\t',
+            text "mfxer",
+            char '\t',
+            pprReg reg
+            ],
+        hcat [
+            char '\t',
+            text "extr",
+            case fmt of
+              II32 -> char 'w'
+              II64 -> char 'd'
+              _    -> panic "PPC: illegal format",
+            text "i\t",
+            pprReg reg,
+            text ", ",
+            pprReg reg,
+            text ", 1, ",
+            case fmt of
+              II32 -> text "1"
+              II64 -> text "33"
+              _    -> panic "PPC: illegal format"
+            ]
+        ]
+
+pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [
+        char '\t',
+        text "mulh",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        text "u\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+
+pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3
+
+        -- for some reason, "andi" doesn't exist.
+        -- we'll use "andi." instead.
+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
+        char '\t',
+        text "andi.",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
+pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)
+pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)
+
+pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
+pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
+
+pprInstr (ORIS reg1 reg2 imm) = hcat [
+        char '\t',
+        text "oris",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+
+pprInstr (XORIS reg1 reg2 imm) = hcat [
+        char '\t',
+        text "xoris",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+
+pprInstr (EXTS fmt reg1 reg2) = hcat [
+        char '\t',
+        text "exts",
+        pprFormat fmt,
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+pprInstr (CNTLZ fmt reg1 reg2) = hcat [
+        char '\t',
+        text "cntlz",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+
+pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
+pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
+
+pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =
+    -- Handle the case where we are asked to shift a 32 bit register by
+    -- less than zero or more than 31 bits. We convert this into a clear
+    -- of the destination register.
+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900
+    pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =
+    -- As above for SR, but for left shifts.
+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870
+    pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
+    -- PT: I don't know what to do for negative shift amounts:
+    -- For now just panic.
+    --
+    -- For shift amounts greater than 31 set all bit to the
+    -- value of the sign bit, this also what sraw does.
+    pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
+
+pprInstr (SL fmt reg1 reg2 ri) =
+         let op = case fmt of
+                       II32 -> "slw"
+                       II64 -> "sld"
+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
+
+pprInstr (SR fmt reg1 reg2 ri) =
+         let op = case fmt of
+                       II32 -> "srw"
+                       II64 -> "srd"
+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
+
+pprInstr (SRA fmt reg1 reg2 ri) =
+         let op = case fmt of
+                       II32 -> "sraw"
+                       II64 -> "srad"
+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
+
+pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
+        text "\trlwinm\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        int sh,
+        text ", ",
+        int mb,
+        text ", ",
+        int me
+    ]
+
+pprInstr (CLRLI fmt reg1 reg2 n) = hcat [
+        text "\tclrl",
+        pprFormat fmt,
+        text "i ",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        int n
+    ]
+pprInstr (CLRRI fmt reg1 reg2 n) = hcat [
+        text "\tclrr",
+        pprFormat fmt,
+        text "i ",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        int n
+    ]
+
+pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
+pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
+pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
+pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3
+pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2
+pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
+
+pprInstr (FCMP reg1 reg2) = hcat [
+        char '\t',
+        text "fcmpu\t0, ",
+            -- Note: we're using fcmpu, not fcmpo
+            -- The difference is with fcmpo, compare with NaN is an invalid operation.
+            -- We don't handle invalid fp ops, so we don't care.
+            -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for
+            -- better portability since some non-GNU assembler (such as
+            -- IBM's `as`) tend not to support the symbolic register name cr0.
+            -- This matches the syntax that GCC seems to emit for PPC targets.
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+
+pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
+pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2
+pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2
+pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
+
+pprInstr (CRNOR dst src1 src2) = hcat [
+        text "\tcrnor\t",
+        int dst,
+        text ", ",
+        int src1,
+        text ", ",
+        int src2
+    ]
+
+pprInstr (MFCR reg) = hcat [
+        char '\t',
+        text "mfcr",
+        char '\t',
+        pprReg reg
+    ]
+
+pprInstr (MFLR reg) = hcat [
+        char '\t',
+        text "mflr",
+        char '\t',
+        pprReg reg
+    ]
+
+pprInstr (FETCHPC reg) = vcat [
+        text "\tbcl\t20,31,1f",
+        hcat [ text "1:\tmflr\t", pprReg reg ]
+    ]
+
+pprInstr HWSYNC = text "\tsync"
+
+pprInstr ISYNC  = text "\tisync"
+
+pprInstr LWSYNC = text "\tlwsync"
+
+pprInstr NOP = text "\tnop"
+
+
+pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc
+pprLogic op reg1 reg2 ri = hcat [
+        char '\t',
+        ptext op,
+        case ri of
+            RIReg _ -> empty
+            RIImm _ -> char 'i',
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprRI ri
+    ]
+
+
+pprMul :: Format -> Reg -> Reg -> RI -> SDoc
+pprMul fmt reg1 reg2 ri = hcat [
+        char '\t',
+        text "mull",
+        case ri of
+            RIReg _ -> case fmt of
+              II32 -> char 'w'
+              II64 -> char 'd'
+              _    -> panic "PPC: illegal format"
+            RIImm _ -> char 'i',
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprRI ri
+    ]
+
+
+pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc
+pprDiv fmt sgn reg1 reg2 reg3 = hcat [
+        char '\t',
+        text "div",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        if sgn then empty else char 'u',
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+
+
+pprUnary :: PtrString -> Reg -> Reg -> SDoc
+pprUnary op reg1 reg2 = hcat [
+        char '\t',
+        ptext op,
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+
+
+pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
+pprBinaryF op fmt reg1 reg2 reg3 = hcat [
+        char '\t',
+        ptext op,
+        pprFFormat fmt,
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+
+pprRI :: RI -> SDoc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+
+pprFFormat :: Format -> SDoc
+pprFFormat FF64     = empty
+pprFFormat FF32     = char 's'
+pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"
+
+    -- limit immediate argument for shift instruction to range 0..63
+    -- for 64 bit size and 0..32 otherwise
+limitShiftRI :: Format -> RI -> RI
+limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
+  panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
+limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
+  panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
+limitShiftRI _ x = x
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-specific parts of the register allocator
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+module PPC.RegInfo (
+        JumpDest( DestBlockId ), getJumpDestBlockId,
+        canShortcut,
+        shortcutJump,
+
+        shortcutStatics
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import PPC.Instr
+
+import BlockId
+import Cmm
+import CLabel
+
+import Unique
+import Outputable (ppr, text, Outputable, (<>))
+
+data JumpDest = DestBlockId BlockId
+
+-- Debug Instance
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
+
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut _ = Nothing
+
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump _ other = other
+
+
+-- Here because it knows about JumpDest
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
+shortcutStatics fn (Statics lbl statics)
+  = Statics lbl $ map (shortcutStatic fn) statics
+  -- we need to get the jump tables, so apply the mapping to the entries
+  -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
+
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
+        -- slightly dodgy, we're ignoring the second label, but this
+        -- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic _ other_static
+        = other_static
+
+shortBlockId
+        :: (BlockId -> Maybe JumpDest)
+        -> BlockId
+        -> CLabel
+
+shortBlockId fn blockid =
+   case fn blockid of
+      Nothing -> mkLocalBlockLabel uq
+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
+   where uq = getUnique blockid
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -0,0 +1,334 @@
+{-# LANGUAGE CPP #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1994-2004
+--
+-- -----------------------------------------------------------------------------
+
+module PPC.Regs (
+        -- squeeze functions
+        virtualRegSqueeze,
+        realRegSqueeze,
+
+        mkVirtualReg,
+        regDotColor,
+
+        -- immediates
+        Imm(..),
+        strImmLit,
+        litToImm,
+
+        -- addressing modes
+        AddrMode(..),
+        addrOffset,
+
+        -- registers
+        spRel,
+        argRegs,
+        allArgRegs,
+        callClobberedRegs,
+        allMachRegNos,
+        classOfRealReg,
+        showReg,
+
+        -- machine specific
+        allFPArgRegs,
+        fits16Bits,
+        makeImmediate,
+        fReg,
+        r0, sp, toc, r3, r4, r11, r12, r30,
+        tmpReg,
+        f1,
+
+        allocatableRegs
+
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Reg
+import RegClass
+import Format
+
+import Cmm
+import CLabel           ( CLabel )
+import Unique
+
+import CodeGen.Platform
+import DynFlags
+import Outputable
+import Platform
+
+import Data.Word        ( Word8, Word16, Word32, Word64 )
+import Data.Int         ( Int8, Int16, Int32, Int64 )
+
+
+-- squeese functions for the graph allocator -----------------------------------
+
+-- | regSqueeze_class reg
+--      Calculate the maximum number of register colors that could be
+--      denied to a node of this class due to having this reg
+--      as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+virtualRegSqueeze cls vr
+ = case cls of
+        RcInteger
+         -> case vr of
+                VirtualRegI{}           -> 1
+                VirtualRegHi{}          -> 1
+                _other                  -> 0
+
+        RcDouble
+         -> case vr of
+                VirtualRegD{}           -> 1
+                VirtualRegF{}           -> 0
+                _other                  -> 0
+
+        _other -> 0
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+realRegSqueeze cls rr
+ = case cls of
+        RcInteger
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 1     -- first fp reg is 32
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcDouble
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 0
+                        | otherwise     -> 1
+
+                RealRegPair{}           -> 0
+
+        _other -> 0
+
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+   | not (isFloatFormat format) = VirtualRegI u
+   | otherwise
+   = case format of
+        FF32    -> VirtualRegD u
+        FF64    -> VirtualRegD u
+        _       -> panic "mkVirtualReg"
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg
+ = case classOfRealReg reg of
+        RcInteger       -> text "blue"
+        RcFloat         -> text "red"
+        RcDouble        -> text "green"
+
+
+
+-- immediates ------------------------------------------------------------------
+data Imm
+        = ImmInt        Int
+        | ImmInteger    Integer     -- Sigh.
+        | ImmCLbl       CLabel      -- AbstractC Label (with baggage)
+        | ImmLit        SDoc        -- Simple string
+        | ImmIndex    CLabel Int
+        | ImmFloat      Rational
+        | ImmDouble     Rational
+        | ImmConstantSum Imm Imm
+        | ImmConstantDiff Imm Imm
+        | LO Imm
+        | HI Imm
+        | HA Imm        {- high halfword adjusted -}
+        | HIGHERA Imm
+        | HIGHESTA Imm
+
+
+strImmLit :: String -> Imm
+strImmLit s = ImmLit (text s)
+
+
+litToImm :: CmmLit -> Imm
+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
+                -- narrow to the width: a CmmInt might be out of
+                -- range, but we assume that ImmInteger only contains
+                -- in-range values.  A signed value should be fine here.
+litToImm (CmmFloat f W32)    = ImmFloat f
+litToImm (CmmFloat f W64)    = ImmDouble f
+litToImm (CmmLabel l)        = ImmCLbl l
+litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off _)
+                             = ImmConstantSum
+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+                               (ImmInt off)
+litToImm _                   = panic "PPC.Regs.litToImm: no match"
+
+
+-- addressing modes ------------------------------------------------------------
+
+data AddrMode
+        = AddrRegReg    Reg Reg
+        | AddrRegImm    Reg Imm
+
+
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
+addrOffset addr off
+  = case addr of
+      AddrRegImm r (ImmInt n)
+       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2))
+       | otherwise     -> Nothing
+       where n2 = n + off
+
+      AddrRegImm r (ImmInteger n)
+       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
+       | otherwise     -> Nothing
+       where n2 = n + toInteger off
+
+      _ -> Nothing
+
+
+-- registers -------------------------------------------------------------------
+-- @spRel@ gives us a stack relative addressing mode for volatile
+-- temporaries and for excess call arguments.  @fpRel@, where
+-- applicable, is the same but for the frame pointer.
+
+spRel :: DynFlags
+      -> Int    -- desired stack offset in words, positive or negative
+      -> AddrMode
+
+spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags))
+
+
+-- argRegs is the set of regs which are read for an n-argument call to C.
+-- For archs which pass all args on the stack (x86), is empty.
+-- Sparc passes up to the first 6 args in regs.
+argRegs :: RegNo -> [Reg]
+argRegs 0 = []
+argRegs 1 = map regSingle [3]
+argRegs 2 = map regSingle [3,4]
+argRegs 3 = map regSingle [3..5]
+argRegs 4 = map regSingle [3..6]
+argRegs 5 = map regSingle [3..7]
+argRegs 6 = map regSingle [3..8]
+argRegs 7 = map regSingle [3..9]
+argRegs 8 = map regSingle [3..10]
+argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!"
+
+
+allArgRegs :: [Reg]
+allArgRegs = map regSingle [3..10]
+
+
+-- these are the regs which we cannot assume stay alive over a C call.
+callClobberedRegs :: Platform -> [Reg]
+callClobberedRegs _platform
+  = map regSingle (0:[2..12] ++ map fReg [0..13])
+
+
+allMachRegNos   :: [RegNo]
+allMachRegNos   = [0..63]
+
+
+{-# INLINE classOfRealReg      #-}
+classOfRealReg :: RealReg -> RegClass
+classOfRealReg (RealRegSingle i)
+        | i < 32        = RcInteger
+        | otherwise     = RcDouble
+
+classOfRealReg (RealRegPair{})
+        = panic "regClass(ppr): no reg pairs on this architecture"
+
+showReg :: RegNo -> String
+showReg n
+    | n >= 0 && n <= 31   = "%r" ++ show n
+    | n >= 32 && n <= 63  = "%f" ++ show (n - 32)
+    | otherwise           = "%unknown_powerpc_real_reg_" ++ show n
+
+
+
+-- machine specific ------------------------------------------------------------
+
+allFPArgRegs :: Platform -> [Reg]
+allFPArgRegs platform
+    = case platformOS platform of
+      OSAIX    -> map (regSingle . fReg) [1..13]
+      _        -> case platformArch platform of
+        ArchPPC      -> map (regSingle . fReg) [1..8]
+        ArchPPC_64 _ -> map (regSingle . fReg) [1..13]
+        _            -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux"
+
+fits16Bits :: Integral a => a -> Bool
+fits16Bits x = x >= -32768 && x < 32768
+
+makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm
+makeImmediate rep signed x = fmap ImmInt (toI16 rep signed)
+    where
+        narrow W64 False = fromIntegral (fromIntegral x :: Word64)
+        narrow W32 False = fromIntegral (fromIntegral x :: Word32)
+        narrow W16 False = fromIntegral (fromIntegral x :: Word16)
+        narrow W8  False = fromIntegral (fromIntegral x :: Word8)
+        narrow W64 True  = fromIntegral (fromIntegral x :: Int64)
+        narrow W32 True  = fromIntegral (fromIntegral x :: Int32)
+        narrow W16 True  = fromIntegral (fromIntegral x :: Int16)
+        narrow W8  True  = fromIntegral (fromIntegral x :: Int8)
+        narrow _   _     = panic "PPC.Regs.narrow: no match"
+
+        narrowed = narrow rep signed
+
+        toI16 W32 True
+            | narrowed >= -32768 && narrowed < 32768 = Just narrowed
+            | otherwise = Nothing
+        toI16 W32 False
+            | narrowed >= 0 && narrowed < 65536 = Just narrowed
+            | otherwise = Nothing
+        toI16 W64 True
+            | narrowed >= -32768 && narrowed < 32768 = Just narrowed
+            | otherwise = Nothing
+        toI16 W64 False
+            | narrowed >= 0 && narrowed < 65536 = Just narrowed
+            | otherwise = Nothing
+        toI16 _ _  = Just narrowed
+
+
+{-
+The PowerPC has 64 registers of interest; 32 integer registers and 32 floating
+point registers.
+-}
+
+fReg :: Int -> RegNo
+fReg x = (32 + x)
+
+r0, sp, toc, r3, r4, r11, r12, r30, f1 :: Reg
+r0      = regSingle 0
+sp      = regSingle 1
+toc     = regSingle 2
+r3      = regSingle 3
+r4      = regSingle 4
+r11     = regSingle 11
+r12     = regSingle 12
+r30     = regSingle 30
+f1      = regSingle $ fReg 1
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: Platform -> [RealReg]
+allocatableRegs platform
+   = let isFree i = freeReg platform i
+     in  map RealRegSingle $ filter isFree allMachRegNos
+
+-- temporary register for compiler use
+tmpReg :: Platform -> Reg
+tmpReg platform =
+       case platformArch platform of
+       ArchPPC      -> regSingle 13
+       ArchPPC_64 _ -> regSingle 30
+       _            -> panic "PPC.Regs.tmpReg: unknown arch"
diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PprBase.hs
@@ -0,0 +1,275 @@
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+module PprBase (
+        castFloatToWord8Array,
+        castDoubleToWord8Array,
+        floatToBytes,
+        doubleToBytes,
+        pprASCII,
+        pprBytes,
+        pprSectionHeader
+)
+
+where
+
+import GhcPrelude
+
+import AsmUtils
+import CLabel
+import Cmm
+import DynFlags
+import FastString
+import Outputable
+import Platform
+import FileCleanup
+
+import qualified Data.Array.Unsafe as U ( castSTUArray )
+import Data.Array.ST
+
+import Control.Monad.ST
+
+import Data.Word
+import Data.Bits
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import GHC.Exts
+import GHC.Word
+import System.IO.Unsafe
+
+
+
+-- -----------------------------------------------------------------------------
+-- Converting floating-point literals to integrals for printing
+
+castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToWord8Array = U.castSTUArray
+
+castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
+castDoubleToWord8Array = U.castSTUArray
+
+-- floatToBytes and doubleToBytes convert to the host's byte
+-- order.  Providing that we're not cross-compiling for a
+-- target with the opposite endianness, this should work ok
+-- on all targets.
+
+-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
+-- could they be merged?
+
+floatToBytes :: Float -> [Int]
+floatToBytes f
+   = runST (do
+        arr <- newArray_ ((0::Int),3)
+        writeArray arr 0 f
+        arr <- castFloatToWord8Array arr
+        i0 <- readArray arr 0
+        i1 <- readArray arr 1
+        i2 <- readArray arr 2
+        i3 <- readArray arr 3
+        return (map fromIntegral [i0,i1,i2,i3])
+     )
+
+doubleToBytes :: Double -> [Int]
+doubleToBytes d
+   = runST (do
+        arr <- newArray_ ((0::Int),7)
+        writeArray arr 0 d
+        arr <- castDoubleToWord8Array arr
+        i0 <- readArray arr 0
+        i1 <- readArray arr 1
+        i2 <- readArray arr 2
+        i3 <- readArray arr 3
+        i4 <- readArray arr 4
+        i5 <- readArray arr 5
+        i6 <- readArray arr 6
+        i7 <- readArray arr 7
+        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
+     )
+
+-- ---------------------------------------------------------------------------
+-- Printing ASCII strings.
+--
+-- Print as a string and escape non-printable characters.
+-- This is similar to charToC in Utils.
+
+pprASCII :: ByteString -> SDoc
+pprASCII str
+  -- Transform this given literal bytestring to escaped string and construct
+  -- the literal SDoc directly.
+  -- See #14741
+  -- and Note [Pretty print ASCII when AsmCodeGen]
+  = text $ BS.foldr (\w s -> do1 w ++ s) "" str
+    where
+       do1 :: Word8 -> String
+       do1 w | 0x09 == w = "\\t"
+             | 0x0A == w = "\\n"
+             | 0x22 == w = "\\\""
+             | 0x5C == w = "\\\\"
+               -- ASCII printable characters range
+             | w >= 0x20 && w <= 0x7E = [chr' w]
+             | otherwise = '\\' : octal w
+
+       -- we know that the Chars we create are in the ASCII range
+       -- so we bypass the check in "chr"
+       chr' :: Word8 -> Char
+       chr' (W8# w#) = C# (chr# (word2Int# w#))
+
+       octal :: Word8 -> String
+       octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
+                 , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)
+                 , chr' (ord0 + w .&. 0x07)
+                 ]
+       ord0 = 0x30 -- = ord '0'
+
+-- | Pretty print binary data.
+--
+-- Use either the ".string" directive or a ".incbin" directive.
+-- See Note [Embedding large binary blobs]
+--
+-- A NULL byte is added after the binary data.
+--
+pprBytes :: ByteString -> SDoc
+pprBytes bs = sdocWithDynFlags $ \dflags ->
+  if binBlobThreshold dflags == 0
+     || fromIntegral (BS.length bs) <= binBlobThreshold dflags
+    then text "\t.string " <> doubleQuotes (pprASCII bs)
+    else unsafePerformIO $ do
+      bFile <- newTempName dflags TFL_CurrentModule ".dat"
+      BS.writeFile bFile bs
+      return $ text "\t.incbin "
+         <> pprFilePathString bFile -- proper escape (see #16389)
+         <> text "\n\t.byte 0"
+
+{-
+Note [Embedding large binary blobs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated
+code object, we have several options:
+
+   1. Generate a ".byte" directive for each byte. This is what was done in the past
+      (see Note [Pretty print ASCII when AsmCodeGen]).
+
+   2. Generate a single ".string"/".asciz" directive for the whole sequence of
+      bytes. Bytes in the ASCII printable range are rendered as characters and
+      other values are escaped (e.g., "\t", "\077", etc.).
+
+   3. Create a temporary file into which we dump the binary data and generate a
+      single ".incbin" directive. The assembler will include the binary file for
+      us in the generated output object.
+
+Now the code generator uses either (2) or (3), depending on the binary blob
+size.  Using (3) for small blobs adds too much overhead (see benchmark results
+in #16190), so we only do it when the size is above a threshold (500K at the
+time of writing).
+
+The threshold is configurable via the `-fbinary-blob-threshold` flag.
+
+-}
+
+
+{-
+Note [Pretty print ASCII when AsmCodeGen]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, when generating assembly code, we created SDoc with
+`(ptext . sLit)` for every bytes in literal bytestring, then
+combine them using `hcat`.
+
+When handling literal bytestrings with millions of bytes,
+millions of SDoc would be created and to combine, leading to
+high memory usage.
+
+Now we escape the given bytestring to string directly and construct
+SDoc only once. This improvement could dramatically decrease the
+memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
+string in source code. See #14741 for profiling results.
+-}
+
+-- ----------------------------------------------------------------------------
+-- Printing section headers.
+--
+-- If -split-section was specified, include the suffix label, otherwise just
+-- print the section type. For Darwin, where subsections-for-symbols are
+-- used instead, only print section type.
+--
+-- For string literals, additional flags are specified to enable merging of
+-- identical strings in the linker. With -split-sections each string also gets
+-- a unique section to allow strings from unused code to be GC'd.
+
+pprSectionHeader :: Platform -> Section -> SDoc
+pprSectionHeader platform (Section t suffix) =
+ case platformOS platform of
+   OSAIX     -> pprXcoffSectionHeader t
+   OSDarwin  -> pprDarwinSectionHeader t
+   OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix
+   _         -> pprGNUSectionHeader (char '.') t suffix
+
+pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc
+pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags ->
+  let splitSections = gopt Opt_SplitSections dflags
+      subsection | splitSections = sep <> ppr suffix
+                 | otherwise     = empty
+  in  text ".section " <> ptext (header dflags) <> subsection <>
+      flags dflags
+  where
+    header dflags = case t of
+      Text -> sLit ".text"
+      Data -> sLit ".data"
+      ReadOnlyData  | OSMinGW32 <- platformOS (targetPlatform dflags)
+                                -> sLit ".rdata"
+                    | otherwise -> sLit ".rodata"
+      RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)
+                                -- Concept does not exist on Windows,
+                                -- So map these to R/O data.
+                                          -> sLit ".rdata$rel.ro"
+                              | otherwise -> sLit ".data.rel.ro"
+      UninitialisedData -> sLit ".bss"
+      ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags)
+                                 -> sLit ".rdata$cst16"
+                     | otherwise -> sLit ".rodata.cst16"
+      CString
+        | OSMinGW32 <- platformOS (targetPlatform dflags)
+                    -> sLit ".rdata"
+        | otherwise -> sLit ".rodata.str"
+      OtherSection _ ->
+        panic "PprBase.pprGNUSectionHeader: unknown section type"
+    flags dflags = case t of
+      CString
+        | OSMinGW32 <- platformOS (targetPlatform dflags)
+                    -> empty
+        | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1"
+      _ -> empty
+
+-- XCOFF doesn't support relocating label-differences, so we place all
+-- RO sections into .text[PR] sections
+pprXcoffSectionHeader :: SectionType -> SDoc
+pprXcoffSectionHeader t = text $ case t of
+     Text                    -> ".csect .text[PR]"
+     Data                    -> ".csect .data[RW]"
+     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"
+     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"
+     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"
+     CString                 -> ".csect .text[PR] # CString"
+     UninitialisedData       -> ".csect .data[BS]"
+     OtherSection _          ->
+       panic "PprBase.pprXcoffSectionHeader: unknown section type"
+
+pprDarwinSectionHeader :: SectionType -> SDoc
+pprDarwinSectionHeader t =
+  ptext $ case t of
+     Text -> sLit ".text"
+     Data -> sLit ".data"
+     ReadOnlyData -> sLit ".const"
+     RelocatableReadOnlyData -> sLit ".const_data"
+     UninitialisedData -> sLit ".data"
+     ReadOnlyData16 -> sLit ".const"
+     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"
+     OtherSection _ ->
+       panic "PprBase.pprDarwinSectionHeader: unknown section type"
diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Reg.hs
@@ -0,0 +1,241 @@
+-- | An architecture independent description of a register.
+--      This needs to stay architecture independent because it is used
+--      by NCGMonad and the register allocators, which are shared
+--      by all architectures.
+--
+module Reg (
+        RegNo,
+        Reg(..),
+        regPair,
+        regSingle,
+        isRealReg,      takeRealReg,
+        isVirtualReg,   takeVirtualReg,
+
+        VirtualReg(..),
+        renameVirtualReg,
+        classOfVirtualReg,
+        getHiVirtualRegFromLo,
+        getHiVRegFromLo,
+
+        RealReg(..),
+        regNosOfRealReg,
+        realRegsAlias,
+
+        liftPatchFnToRegReg
+)
+
+where
+
+import GhcPrelude
+
+import Outputable
+import Unique
+import RegClass
+import Data.List
+
+-- | An identifier for a primitive real machine register.
+type RegNo
+        = Int
+
+-- VirtualRegs are virtual registers.  The register allocator will
+--      eventually have to map them into RealRegs, or into spill slots.
+--
+--      VirtualRegs are allocated on the fly, usually to represent a single
+--      value in the abstract assembly code (i.e. dynamic registers are
+--      usually single assignment).
+--
+--      The  single assignment restriction isn't necessary to get correct code,
+--      although a better register allocation will result if single
+--      assignment is used -- because the allocator maps a VirtualReg into
+--      a single RealReg, even if the VirtualReg has multiple live ranges.
+--
+--      Virtual regs can be of either class, so that info is attached.
+--
+data VirtualReg
+        = VirtualRegI  {-# UNPACK #-} !Unique
+        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register
+        | VirtualRegF  {-# UNPACK #-} !Unique
+        | VirtualRegD  {-# UNPACK #-} !Unique
+
+        deriving (Eq, Show)
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord VirtualReg where
+  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b
+  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b
+  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b
+  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b
+
+  compare VirtualRegI{} _ = LT
+  compare _ VirtualRegI{} = GT
+  compare VirtualRegHi{} _ = LT
+  compare _ VirtualRegHi{} = GT
+  compare VirtualRegF{} _ = LT
+  compare _ VirtualRegF{} = GT
+
+
+
+instance Uniquable VirtualReg where
+        getUnique reg
+         = case reg of
+                VirtualRegI u   -> u
+                VirtualRegHi u  -> u
+                VirtualRegF u   -> u
+                VirtualRegD u   -> u
+
+instance Outputable VirtualReg where
+        ppr reg
+         = case reg of
+                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u
+                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u
+                -- this code is kinda wrong on x86
+                -- because float and double occupy the same register set
+                -- namely SSE2 register xmm0 .. xmm15
+                VirtualRegF  u  -> text "%vFloat_"   <> pprUniqueAlways u
+                VirtualRegD  u  -> text "%vDouble_"   <> pprUniqueAlways u
+
+
+
+renameVirtualReg :: Unique -> VirtualReg -> VirtualReg
+renameVirtualReg u r
+ = case r of
+        VirtualRegI _   -> VirtualRegI  u
+        VirtualRegHi _  -> VirtualRegHi u
+        VirtualRegF _   -> VirtualRegF  u
+        VirtualRegD _   -> VirtualRegD  u
+
+
+classOfVirtualReg :: VirtualReg -> RegClass
+classOfVirtualReg vr
+ = case vr of
+        VirtualRegI{}   -> RcInteger
+        VirtualRegHi{}  -> RcInteger
+        VirtualRegF{}   -> RcFloat
+        VirtualRegD{}   -> RcDouble
+
+
+
+-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform
+-- when supplied with the vreg for the lower-half of the quantity.
+-- (NB. Not reversible).
+getHiVirtualRegFromLo :: VirtualReg -> VirtualReg
+getHiVirtualRegFromLo reg
+ = case reg of
+        -- makes a pseudo-unique with tag 'H'
+        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')
+        _               -> panic "Reg.getHiVirtualRegFromLo"
+
+getHiVRegFromLo :: Reg -> Reg
+getHiVRegFromLo reg
+ = case reg of
+        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)
+        RegReal _       -> panic "Reg.getHiVRegFromLo"
+
+
+------------------------------------------------------------------------------------
+-- | RealRegs are machine regs which are available for allocation, in
+--      the usual way.  We know what class they are, because that's part of
+--      the processor's architecture.
+--
+--      RealRegPairs are pairs of real registers that are allocated together
+--      to hold a larger value, such as with Double regs on SPARC.
+--
+data RealReg
+        = RealRegSingle {-# UNPACK #-} !RegNo
+        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo
+        deriving (Eq, Show, Ord)
+
+instance Uniquable RealReg where
+        getUnique reg
+         = case reg of
+                RealRegSingle i         -> mkRegSingleUnique i
+                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)
+
+instance Outputable RealReg where
+        ppr reg
+         = case reg of
+                RealRegSingle i         -> text "%r"  <> int i
+                RealRegPair r1 r2       -> text "%r(" <> int r1
+                                           <> vbar <> int r2 <> text ")"
+
+regNosOfRealReg :: RealReg -> [RegNo]
+regNosOfRealReg rr
+ = case rr of
+        RealRegSingle r1        -> [r1]
+        RealRegPair   r1 r2     -> [r1, r2]
+
+
+realRegsAlias :: RealReg -> RealReg -> Bool
+realRegsAlias rr1 rr2
+        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)
+
+--------------------------------------------------------------------------------
+-- | A register, either virtual or real
+data Reg
+        = RegVirtual !VirtualReg
+        | RegReal    !RealReg
+        deriving (Eq, Ord)
+
+regSingle :: RegNo -> Reg
+regSingle regNo         = RegReal $ RealRegSingle regNo
+
+regPair :: RegNo -> RegNo -> Reg
+regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2
+
+
+-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets
+-- in the register allocator.
+instance Uniquable Reg where
+        getUnique reg
+         = case reg of
+                RegVirtual vr   -> getUnique vr
+                RegReal    rr   -> getUnique rr
+
+-- | Print a reg in a generic manner
+--      If you want the architecture specific names, then use the pprReg
+--      function from the appropriate Ppr module.
+instance Outputable Reg where
+        ppr reg
+         = case reg of
+                RegVirtual vr   -> ppr vr
+                RegReal    rr   -> ppr rr
+
+
+isRealReg :: Reg -> Bool
+isRealReg reg
+ = case reg of
+        RegReal _       -> True
+        RegVirtual _    -> False
+
+takeRealReg :: Reg -> Maybe RealReg
+takeRealReg reg
+ = case reg of
+        RegReal rr      -> Just rr
+        _               -> Nothing
+
+
+isVirtualReg :: Reg -> Bool
+isVirtualReg reg
+ = case reg of
+        RegReal _       -> False
+        RegVirtual _    -> True
+
+takeVirtualReg :: Reg -> Maybe VirtualReg
+takeVirtualReg reg
+ = case reg of
+        RegReal _       -> Nothing
+        RegVirtual vr   -> Just vr
+
+
+-- | The patch function supplied by the allocator maps VirtualReg to RealReg
+--      regs, but sometimes we want to apply it to plain old Reg.
+--
+liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)
+liftPatchFnToRegReg patchF reg
+ = case reg of
+        RegVirtual vr   -> RegReal (patchF vr)
+        RegReal _       -> reg
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -0,0 +1,161 @@
+
+-- | Utils for calculating general worst, bound, squeese and free, functions.
+--
+--   as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
+--           Michael Smith, Normal Ramsey, Glenn Holloway.
+--           PLDI 2004
+--
+--   These general versions are not used in GHC proper because they are too slow.
+--   Instead, hand written optimised versions are provided for each architecture
+--   in MachRegs*.hs
+--
+--   This code is here because we can test the architecture specific code against
+--   it.
+--
+module RegAlloc.Graph.ArchBase (
+        RegClass(..),
+        Reg(..),
+        RegSub(..),
+
+        worst,
+        bound,
+        squeese
+) where
+import GhcPrelude
+
+import UniqSet
+import UniqFM
+import Unique
+
+
+-- Some basic register classes.
+--      These aren't necessarily in 1-to-1 correspondence with the allocatable
+--      RegClasses in MachRegs.hs
+data RegClass
+        -- general purpose regs
+        = ClassG32      -- 32 bit GPRs
+        | ClassG16      -- 16 bit GPRs
+        | ClassG8       -- 8  bit GPRs
+
+        -- floating point regs
+        | ClassF64      -- 64 bit FPRs
+        deriving (Show, Eq, Enum)
+
+
+-- | A register of some class
+data Reg
+        -- a register of some class
+        = Reg RegClass Int
+
+        -- a sub-component of one of the other regs
+        | RegSub RegSub Reg
+        deriving (Show, Eq)
+
+
+-- | so we can put regs in UniqSets
+instance Uniquable Reg where
+        getUnique (Reg c i)
+         = mkRegSingleUnique
+         $ fromEnum c * 1000 + i
+
+        getUnique (RegSub s (Reg c i))
+         = mkRegSubUnique
+         $ fromEnum s * 10000 + fromEnum c * 1000 + i
+
+        getUnique (RegSub _ (RegSub _ _))
+          = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
+
+
+-- | A subcomponent of another register
+data RegSub
+        = SubL16        -- lowest 16 bits
+        | SubL8         -- lowest  8 bits
+        | SubL8H        -- second lowest 8 bits
+        deriving (Show, Enum, Ord, Eq)
+
+
+-- | Worst case displacement
+--
+--      a node N of classN has some number of neighbors,
+--      all of which are from classC.
+--
+--      (worst neighbors classN classC) is the maximum number of potential
+--      colors for N that can be lost by coloring its neighbors.
+--
+-- This should be hand coded/cached for each particular architecture,
+--      because the compute time is very long..
+worst   :: (RegClass    -> UniqSet Reg)
+        -> (Reg         -> UniqSet Reg)
+        -> Int -> RegClass -> RegClass -> Int
+
+worst regsOfClass regAlias neighbors classN classC
+ = let  regAliasS regs  = unionManyUniqSets
+                        $ map regAlias
+                        $ nonDetEltsUniqSet regs
+                        -- This is non-deterministic but we do not
+                        -- currently support deterministic code-generation.
+                        -- See Note [Unique Determinism and code generation]
+
+        -- all the regs in classes N, C
+        regsN           = regsOfClass classN
+        regsC           = regsOfClass classC
+
+        -- all the possible subsets of c which have size < m
+        regsS           = filter (\s -> sizeUniqSet s >= 1
+                                     && sizeUniqSet s <= neighbors)
+                        $ powersetLS regsC
+
+        -- for each of the subsets of C, the regs which conflict
+        -- with posiblities for N
+        regsS_conflict
+                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
+
+  in    maximum $ map sizeUniqSet $ regsS_conflict
+
+
+-- | For a node N of classN and neighbors of classesC
+--      (bound classN classesC) is the maximum number of potential
+--      colors for N that can be lost by coloring its neighbors.
+bound   :: (RegClass    -> UniqSet Reg)
+        -> (Reg         -> UniqSet Reg)
+        -> RegClass -> [RegClass] -> Int
+
+bound regsOfClass regAlias classN classesC
+ = let  regAliasS regs  = unionManyUniqSets
+                        $ map regAlias
+                        $ nonDetEltsUFM regs
+                        -- See Note [Unique Determinism and code generation]
+
+        regsC_aliases
+                = unionManyUniqSets
+                $ map (regAliasS . getUniqSet . regsOfClass) classesC
+
+        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
+
+   in   sizeUniqSet overlap
+
+
+-- | The total squeese on a particular node with a list of neighbors.
+--
+--   A version of this should be constructed for each particular architecture,
+--   possibly including uses of bound, so that alised registers don't get
+--   counted twice, as per the paper.
+squeese :: (RegClass    -> UniqSet Reg)
+        -> (Reg         -> UniqSet Reg)
+        -> RegClass -> [(Int, RegClass)] -> Int
+
+squeese regsOfClass regAlias classN countCs
+        = sum
+        $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)
+        $ countCs
+
+
+-- | powerset (for lists)
+powersetL :: [a] -> [[a]]
+powersetL       = map concat . mapM (\x -> [[],[x]])
+
+
+-- | powersetLS (list of sets)
+powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
+powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s
+  -- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
@@ -0,0 +1,161 @@
+
+-- | A description of the register set of the X86.
+--
+--   This isn't used directly in GHC proper.
+--
+--   See RegArchBase.hs for the reference.
+--   See MachRegs.hs for the actual trivColorable function used in GHC.
+--
+module RegAlloc.Graph.ArchX86 (
+        classOfReg,
+        regsOfClass,
+        regName,
+        regAlias,
+        worst,
+        squeese,
+) where
+
+import GhcPrelude
+
+import RegAlloc.Graph.ArchBase  (Reg(..), RegSub(..), RegClass(..))
+import UniqSet
+
+import qualified Data.Array as A
+
+
+-- | Determine the class of a register
+classOfReg :: Reg -> RegClass
+classOfReg reg
+ = case reg of
+        Reg c _         -> c
+
+        RegSub SubL16 _ -> ClassG16
+        RegSub SubL8  _ -> ClassG8
+        RegSub SubL8H _ -> ClassG8
+
+
+-- | Determine all the regs that make up a certain class.
+regsOfClass :: RegClass -> UniqSet Reg
+regsOfClass c
+ = case c of
+        ClassG32
+         -> mkUniqSet   [ Reg ClassG32  i
+                        | i <- [0..7] ]
+
+        ClassG16
+         -> mkUniqSet   [ RegSub SubL16 (Reg ClassG32 i)
+                        | i <- [0..7] ]
+
+        ClassG8
+         -> unionUniqSets
+                (mkUniqSet [ RegSub SubL8  (Reg ClassG32 i) | i <- [0..3] ])
+                (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])
+
+        ClassF64
+         -> mkUniqSet   [ Reg ClassF64  i
+                        | i <- [0..5] ]
+
+
+-- | Determine the common name of a reg
+--      returns Nothing if this reg is not part of the machine.
+regName :: Reg -> Maybe String
+regName reg
+ = case reg of
+        Reg ClassG32 i
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "eax", "ebx", "ecx", "edx"
+                       , "ebp", "esi", "edi", "esp" ]
+           in Just $ names A.! i
+
+        RegSub SubL16 (Reg ClassG32 i)
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "ax", "bx", "cx", "dx"
+                       , "bp", "si", "di", "sp"]
+           in Just $ names A.! i
+
+        RegSub SubL8  (Reg ClassG32 i)
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]
+           in Just $ names A.! i
+
+        RegSub SubL8H (Reg ClassG32 i)
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]
+           in Just $ names A.! i
+
+        _         -> Nothing
+
+
+-- | Which regs alias what other regs.
+regAlias :: Reg -> UniqSet Reg
+regAlias reg
+ = case reg of
+
+        -- 32 bit regs alias all of the subregs
+        Reg ClassG32 i
+
+         -- for eax, ebx, ecx, eds
+         |  i <= 3
+         -> mkUniqSet
+         $ [ Reg ClassG32 i,   RegSub SubL16 reg
+           , RegSub SubL8 reg, RegSub SubL8H reg ]
+
+         -- for esi, edi, esp, ebp
+         | 4 <= i && i <= 7
+         -> mkUniqSet
+         $ [ Reg ClassG32 i,   RegSub SubL16 reg ]
+
+        -- 16 bit subregs alias the whole reg
+        RegSub SubL16 r@(Reg ClassG32 _)
+         ->     regAlias r
+
+        -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
+        RegSub SubL8  r@(Reg ClassG32 _)
+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
+
+        RegSub SubL8H r@(Reg ClassG32 _)
+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
+
+        -- fp
+        Reg ClassF64 _
+         -> unitUniqSet reg
+
+        _ -> error "regAlias: invalid register"
+
+
+-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+        ClassG32
+         -> case classC of
+                ClassG32        -> min n 8
+                ClassG16        -> min n 8
+                ClassG8         -> min n 4
+                ClassF64        -> 0
+
+        ClassG16
+         -> case classC of
+                ClassG32        -> min n 8
+                ClassG16        -> min n 8
+                ClassG8         -> min n 4
+                ClassF64        -> 0
+
+        ClassG8
+         -> case classC of
+                ClassG32        -> min (n*2) 8
+                ClassG16        -> min (n*2) 8
+                ClassG8         -> min n 8
+                ClassF64        -> 0
+
+        ClassF64
+         -> case classC of
+                ClassF64        -> min n 6
+                _               -> 0
+
+squeese :: RegClass -> [(Int, RegClass)] -> Int
+squeese classN countCs
+        = sum (map (\(i, classC) -> worst i classN classC) countCs)
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -0,0 +1,99 @@
+-- | Register coalescing.
+module RegAlloc.Graph.Coalesce (
+        regCoalesce,
+        slurpJoinMovs
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import Cmm
+import Bag
+import Digraph
+import UniqFM
+import UniqSet
+import UniqSupply
+
+
+-- | Do register coalescing on this top level thing
+--
+--   For Reg -> Reg moves, if the first reg dies at the same time the
+--   second reg is born then the mov only serves to join live ranges.
+--   The two regs can be renamed to be the same and the move instruction
+--   safely erased.
+regCoalesce
+        :: Instruction instr
+        => [LiveCmmDecl statics instr]
+        -> UniqSM [LiveCmmDecl statics instr]
+
+regCoalesce code
+ = do
+        let joins       = foldl' unionBags emptyBag
+                        $ map slurpJoinMovs code
+
+        let alloc       = foldl' buildAlloc emptyUFM
+                        $ bagToList joins
+
+        let patched     = map (patchEraseLive (sinkReg alloc)) code
+
+        return patched
+
+
+-- | Add a v1 = v2 register renaming to the map.
+--   The register with the lowest lexical name is set as the
+--   canonical version.
+buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
+buildAlloc fm (r1, r2)
+ = let  rmin    = min r1 r2
+        rmax    = max r1 r2
+   in   addToUFM fm rmax rmin
+
+
+-- | Determine the canonical name for a register by following
+--   v1 = v2 renamings in this map.
+sinkReg :: UniqFM Reg -> Reg -> Reg
+sinkReg fm r
+ = case lookupUFM fm r of
+        Nothing -> r
+        Just r' -> sinkReg fm r'
+
+
+-- | Slurp out mov instructions that only serve to join live ranges.
+--
+--   During a mov, if the source reg dies and the destination reg is
+--   born then we can rename the two regs to the same thing and
+--   eliminate the move.
+slurpJoinMovs
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> Bag (Reg, Reg)
+
+slurpJoinMovs live
+        = slurpCmm emptyBag live
+ where
+        slurpCmm   rs  CmmData{}
+         = rs
+
+        slurpCmm   rs (CmmProc _ _ _ sccs)
+         = foldl' slurpBlock rs (flattenSCCs sccs)
+
+        slurpBlock rs (BasicBlock _ instrs)
+         = foldl' slurpLI    rs instrs
+
+        slurpLI    rs (LiveInstr _      Nothing)    = rs
+        slurpLI    rs (LiveInstr instr (Just live))
+                | Just (r1, r2) <- takeRegRegMoveInstr instr
+                , elementOfUniqSet r1 $ liveDieRead live
+                , elementOfUniqSet r2 $ liveBorn live
+
+                -- only coalesce movs between two virtuals for now,
+                -- else we end up with allocatable regs in the live
+                -- regs list..
+                , isVirtualReg r1 && isVirtualReg r2
+                = consBag (r1, r2) rs
+
+                | otherwise
+                = rs
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -0,0 +1,469 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Graph coloring register allocator.
+module RegAlloc.Graph.Main (
+        regAlloc
+) where
+import GhcPrelude
+
+import qualified GraphColor as Color
+import RegAlloc.Liveness
+import RegAlloc.Graph.Spill
+import RegAlloc.Graph.SpillClean
+import RegAlloc.Graph.SpillCost
+import RegAlloc.Graph.Stats
+import RegAlloc.Graph.TrivColorable
+import Instruction
+import TargetReg
+import RegClass
+import Reg
+
+import Bag
+import DynFlags
+import Outputable
+import Platform
+import UniqFM
+import UniqSet
+import UniqSupply
+import Util (seqList)
+import CFG
+
+import Data.Maybe
+import Control.Monad
+
+
+-- | The maximum number of build\/spill cycles we'll allow.
+--
+--   It should only take 3 or 4 cycles for the allocator to converge.
+--   If it takes any longer than this it's probably in an infinite loop,
+--   so it's better just to bail out and report a bug.
+maxSpinCount    :: Int
+maxSpinCount    = 10
+
+
+-- | The top level of the graph coloring register allocator.
+regAlloc
+        :: (Outputable statics, Outputable instr, Instruction instr)
+        => DynFlags
+        -> UniqFM (UniqSet RealReg)     -- ^ registers we can use for allocation
+        -> UniqSet Int                  -- ^ set of available spill slots.
+        -> Int                          -- ^ current number of spill slots
+        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.
+        -> Maybe CFG                    -- ^ CFG of basic blocks if available
+        -> UniqSM ( [NatCmmDecl statics instr]
+                  , Maybe Int, [RegAllocStats statics instr] )
+           -- ^ code with registers allocated, additional stacks required
+           -- and stats for each stage of allocation
+
+regAlloc dflags regsFree slotsFree slotsCount code cfg
+ = do
+        -- TODO: the regClass function is currently hard coded to the default
+        --       target architecture. Would prefer to determine this from dflags.
+        --       There are other uses of targetRegClass later in this module.
+        let platform = targetPlatform dflags
+            triv = trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform)
+
+        (code_final, debug_codeGraphs, slotsCount', _)
+                <- regAlloc_spin dflags 0
+                        triv
+                        regsFree slotsFree slotsCount [] code cfg
+
+        let needStack
+                | slotsCount == slotsCount'
+                = Nothing
+                | otherwise
+                = Just slotsCount'
+
+        return  ( code_final
+                , needStack
+                , reverse debug_codeGraphs )
+
+
+-- | Perform solver iterations for the graph coloring allocator.
+--
+--   We extract a register confict graph from the provided cmm code,
+--   and try to colour it. If that works then we use the solution rewrite
+--   the code with real hregs. If coloring doesn't work we add spill code
+--   and try to colour it again. After `maxSpinCount` iterations we give up.
+--
+regAlloc_spin
+        :: forall instr statics.
+           (Instruction instr,
+            Outputable instr,
+            Outputable statics)
+        => DynFlags
+        -> Int  -- ^ Number of solver iterations we've already performed.
+        -> Color.Triv VirtualReg RegClass RealReg
+                -- ^ Function for calculating whether a register is trivially
+                --   colourable.
+        -> UniqFM (UniqSet RealReg)      -- ^ Free registers that we can allocate.
+        -> UniqSet Int                   -- ^ Free stack slots that we can use.
+        -> Int                           -- ^ Number of spill slots in use
+        -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
+        -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.
+        -> Maybe CFG
+        -> UniqSM ( [NatCmmDecl statics instr]
+                  , [RegAllocStats statics instr]
+                  , Int                  -- Slots in use
+                  , Color.Graph VirtualReg RegClass RealReg)
+
+regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg
+ = do
+        let platform = targetPlatform dflags
+
+        -- If any of these dump flags are turned on we want to hang on to
+        -- intermediate structures in the allocator - otherwise tell the
+        -- allocator to ditch them early so we don't end up creating space leaks.
+        let dump = or
+                [ dopt Opt_D_dump_asm_regalloc_stages dflags
+                , dopt Opt_D_dump_asm_stats dflags
+                , dopt Opt_D_dump_asm_conflicts dflags ]
+
+        -- Check that we're not running off down the garden path.
+        when (spinCount > maxSpinCount)
+         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
+           (  text "It looks like the register allocator is stuck in an infinite loop."
+           $$ text "max cycles  = " <> int maxSpinCount
+           $$ text "regsFree    = " <> (hcat $ punctuate space $ map ppr
+                                             $ nonDetEltsUniqSet $ unionManyUniqSets
+                                             $ nonDetEltsUFM regsFree)
+              -- This is non-deterministic but we do not
+              -- currently support deterministic code-generation.
+              -- See Note [Unique Determinism and code generation]
+           $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
+
+        -- Build the register conflict graph from the cmm code.
+        (graph  :: Color.Graph VirtualReg RegClass RealReg)
+                <- {-# SCC "BuildGraph" #-} buildGraph code
+
+        -- VERY IMPORTANT:
+        --   We really do want the graph to be fully evaluated _before_ we
+        --   start coloring. If we don't do this now then when the call to
+        --   Color.colorGraph forces bits of it, the heap will be filled with
+        --   half evaluated pieces of graph and zillions of apply thunks.
+        seqGraph graph `seq` return ()
+
+        -- Build a map of the cost of spilling each instruction.
+        -- This is a lazy binding, so the map will only be computed if we
+        -- actually have to spill to the stack.
+        let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo
+                        $ map (slurpSpillCostInfo platform cfg) code
+
+        -- The function to choose regs to leave uncolored.
+        let spill       = chooseSpill spillCosts
+
+        -- Record startup state in our log.
+        let stat1
+             = if spinCount == 0
+                 then   Just $ RegAllocStatsStart
+                        { raLiveCmm     = code
+                        , raGraph       = graph
+                        , raSpillCosts  = spillCosts }
+                 else   Nothing
+
+        -- Try and color the graph.
+        let (graph_colored, rsSpill, rmCoalesce)
+                = {-# SCC "ColorGraph" #-}
+                  Color.colorGraph
+                       (gopt Opt_RegsIterative dflags)
+                       spinCount
+                       regsFree triv spill graph
+
+        -- Rewrite registers in the code that have been coalesced.
+        let patchF reg
+                | RegVirtual vr <- reg
+                = case lookupUFM rmCoalesce vr of
+                        Just vr'        -> patchF (RegVirtual vr')
+                        Nothing         -> reg
+
+                | otherwise
+                = reg
+
+        let (code_coalesced :: [LiveCmmDecl statics instr])
+                = map (patchEraseLive patchF) code
+
+        -- Check whether we've found a coloring.
+        if isEmptyUniqSet rsSpill
+
+         -- Coloring was successful because no registers needed to be spilled.
+         then do
+                -- if -fasm-lint is turned on then validate the graph.
+                -- This checks for bugs in the graph allocator itself.
+                let graph_colored_lint  =
+                        if gopt Opt_DoAsmLinting dflags
+                                then Color.validateGraph (text "")
+                                        True    -- Require all nodes to be colored.
+                                        graph_colored
+                                else graph_colored
+
+                -- Rewrite the code to use real hregs, using the colored graph.
+                let code_patched
+                        = map (patchRegsFromGraph platform graph_colored_lint)
+                              code_coalesced
+
+                -- Clean out unneeded SPILL/RELOAD meta instructions.
+                --   The spill code generator just spills the entire live range
+                --   of a vreg, but it might not need to be on the stack for
+                --   its entire lifetime.
+                let code_spillclean
+                        = map (cleanSpills platform) code_patched
+
+                -- Strip off liveness information from the allocated code.
+                -- Also rewrite SPILL/RELOAD meta instructions into real machine
+                -- instructions along the way
+                let code_final
+                        = map (stripLive dflags) code_spillclean
+
+                -- Record what happened in this stage for debugging
+                let stat
+                     =  RegAllocStatsColored
+                        { raCode                = code
+                        , raGraph               = graph
+                        , raGraphColored        = graph_colored_lint
+                        , raCoalesced           = rmCoalesce
+                        , raCodeCoalesced       = code_coalesced
+                        , raPatched             = code_patched
+                        , raSpillClean          = code_spillclean
+                        , raFinal               = code_final
+                        , raSRMs                = foldl' addSRM (0, 0, 0)
+                                                $ map countSRMs code_spillclean }
+
+                -- Bundle up all the register allocator statistics.
+                --   .. but make sure to drop them on the floor if they're not
+                --      needed, otherwise we'll get a space leak.
+                let statList =
+                        if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                                else []
+
+                -- Ensure all the statistics are evaluated, to avoid space leaks.
+                seqList statList (return ())
+
+                return  ( code_final
+                        , statList
+                        , slotsCount
+                        , graph_colored_lint)
+
+         -- Coloring was unsuccessful. We need to spill some register to the
+         -- stack, make a new graph, and try to color it again.
+         else do
+                -- if -fasm-lint is turned on then validate the graph
+                let graph_colored_lint  =
+                        if gopt Opt_DoAsmLinting dflags
+                                then Color.validateGraph (text "")
+                                        False   -- don't require nodes to be colored
+                                        graph_colored
+                                else graph_colored
+
+                -- Spill uncolored regs to the stack.
+                (code_spilled, slotsFree', slotsCount', spillStats)
+                        <- regSpill platform code_coalesced slotsFree slotsCount rsSpill
+
+                -- Recalculate liveness information.
+                -- NOTE: we have to reverse the SCCs here to get them back into
+                --       the reverse-dependency order required by computeLiveness.
+                --       If they're not in the correct order that function will panic.
+                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops)
+                                        code_spilled
+
+                -- Record what happened in this stage for debugging.
+                let stat        =
+                        RegAllocStatsSpill
+                        { raCode        = code
+                        , raGraph       = graph_colored_lint
+                        , raCoalesced   = rmCoalesce
+                        , raSpillStats  = spillStats
+                        , raSpillCosts  = spillCosts
+                        , raSpilled     = code_spilled }
+
+                -- Bundle up all the register allocator statistics.
+                --   .. but make sure to drop them on the floor if they're not
+                --      needed, otherwise we'll get a space leak.
+                let statList =
+                        if dump
+                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                                else []
+
+                -- Ensure all the statistics are evaluated, to avoid space leaks.
+                seqList statList (return ())
+
+                regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
+                              slotsCount' statList code_relive cfg
+
+
+-- | Build a graph from the liveness and coalesce information in this code.
+buildGraph
+        :: Instruction instr
+        => [LiveCmmDecl statics instr]
+        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)
+
+buildGraph code
+ = do
+        -- Slurp out the conflicts and reg->reg moves from this code.
+        let (conflictList, moveList) =
+                unzip $ map slurpConflicts code
+
+        -- Slurp out the spill/reload coalesces.
+        let moveList2           = map slurpReloadCoalesce code
+
+        -- Add the reg-reg conflicts to the graph.
+        let conflictBag         = unionManyBags conflictList
+        let graph_conflict
+                = foldrBag graphAddConflictSet Color.initGraph conflictBag
+
+        -- Add the coalescences edges to the graph.
+        let moveBag
+                = unionBags (unionManyBags moveList2)
+                            (unionManyBags moveList)
+
+        let graph_coalesce
+                = foldrBag graphAddCoalesce graph_conflict moveBag
+
+        return  graph_coalesce
+
+
+-- | Add some conflict edges to the graph.
+--   Conflicts between virtual and real regs are recorded as exclusions.
+graphAddConflictSet
+        :: UniqSet Reg
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> Color.Graph VirtualReg RegClass RealReg
+
+graphAddConflictSet set graph
+ = let  virtuals        = mkUniqSet
+                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
+
+        graph1  = Color.addConflicts virtuals classOfVirtualReg graph
+
+        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
+                        graph1
+                        [ (vr, rr)
+                                | RegVirtual vr <- nonDetEltsUniqSet set
+                                , RegReal    rr <- nonDetEltsUniqSet set]
+                          -- See Note [Unique Determinism and code generation]
+
+   in   graph2
+
+
+-- | Add some coalesence edges to the graph
+--   Coalesences between virtual and real regs are recorded as preferences.
+graphAddCoalesce
+        :: (Reg, Reg)
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> Color.Graph VirtualReg RegClass RealReg
+
+graphAddCoalesce (r1, r2) graph
+        | RegReal rr            <- r1
+        , RegVirtual vr         <- r2
+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph
+
+        | RegReal rr            <- r2
+        , RegVirtual vr         <- r1
+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph
+
+        | RegVirtual vr1        <- r1
+        , RegVirtual vr2        <- r2
+        = Color.addCoalesce
+                (vr1, classOfVirtualReg vr1)
+                (vr2, classOfVirtualReg vr2)
+                graph
+
+        -- We can't coalesce two real regs, but there could well be existing
+        --      hreg,hreg moves in the input code. We'll just ignore these
+        --      for coalescing purposes.
+        | RegReal _             <- r1
+        , RegReal _             <- r2
+        = graph
+
+        | otherwise
+        = panic "graphAddCoalesce"
+
+
+-- | Patch registers in code using the reg -> reg mapping in this graph.
+patchRegsFromGraph
+        :: (Outputable statics, Outputable instr, Instruction instr)
+        => Platform -> Color.Graph VirtualReg RegClass RealReg
+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+
+patchRegsFromGraph platform graph code
+ = patchEraseLive patchF code
+ where
+        -- Function to lookup the hardreg for a virtual reg from the graph.
+        patchF reg
+                -- leave real regs alone.
+                | RegReal{}     <- reg
+                = reg
+
+                -- this virtual has a regular node in the graph.
+                | RegVirtual vr <- reg
+                , Just node     <- Color.lookupNode graph vr
+                = case Color.nodeColor node of
+                        Just color      -> RegReal    color
+                        Nothing         -> RegVirtual vr
+
+                -- no node in the graph for this virtual, bad news.
+                | otherwise
+                = pprPanic "patchRegsFromGraph: register mapping failed."
+                        (  text "There is no node in the graph for register "
+                                <> ppr reg
+                        $$ ppr code
+                        $$ Color.dotGraph
+                                (\_ -> text "white")
+                                (trivColorable platform
+                                        (targetVirtualRegSqueeze platform)
+                                        (targetRealRegSqueeze platform))
+                                graph)
+
+
+-----
+-- for when laziness just isn't what you wanted...
+--  We need to deepSeq the whole graph before trying to colour it to avoid
+--  space leaks.
+seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
+seqGraph graph          = seqNodes (nonDetEltsUFM (Color.graphMap graph))
+   -- See Note [Unique Determinism and code generation]
+
+seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
+seqNodes ns
+ = case ns of
+        []              -> ()
+        (n : ns)        -> seqNode n `seq` seqNodes ns
+
+seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
+seqNode node
+        =     seqVirtualReg     (Color.nodeId node)
+        `seq` seqRegClass       (Color.nodeClass node)
+        `seq` seqMaybeRealReg   (Color.nodeColor node)
+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))
+        `seq` (seqRealRegList    (nonDetEltsUniqSet (Color.nodeExclusions node)))
+        `seq` (seqRealRegList (Color.nodePreference node))
+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))
+              -- It's OK to use nonDetEltsUniqSet for seq
+
+seqVirtualReg :: VirtualReg -> ()
+seqVirtualReg reg = reg `seq` ()
+
+seqRealReg :: RealReg -> ()
+seqRealReg reg = reg `seq` ()
+
+seqRegClass :: RegClass -> ()
+seqRegClass c = c `seq` ()
+
+seqMaybeRealReg :: Maybe RealReg -> ()
+seqMaybeRealReg mr
+ = case mr of
+        Nothing         -> ()
+        Just r          -> seqRealReg r
+
+seqVirtualRegList :: [VirtualReg] -> ()
+seqVirtualRegList rs
+ = case rs of
+        []              -> ()
+        (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs
+
+seqRealRegList :: [RealReg] -> ()
+seqRealRegList rs
+ = case rs of
+        []              -> ()
+        (r : rs)        -> seqRealReg r `seq` seqRealRegList rs
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -0,0 +1,382 @@
+
+-- | When there aren't enough registers to hold all the vregs we have to spill
+--   some of those vregs to slots on the stack. This module is used modify the
+--   code to use those slots.
+module RegAlloc.Graph.Spill (
+        regSpill,
+        SpillStats(..),
+        accSpillSL
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import Reg
+import Cmm hiding (RegSet)
+import BlockId
+import Hoopl.Collections
+
+import MonadUtils
+import State
+import Unique
+import UniqFM
+import UniqSet
+import UniqSupply
+import Outputable
+import Platform
+
+import Data.List
+import Data.Maybe
+import Data.IntSet              (IntSet)
+import qualified Data.IntSet    as IntSet
+
+
+-- | Spill all these virtual regs to stack slots.
+--
+--   Bumps the number of required stack slots if required.
+--
+--
+--   TODO: See if we can split some of the live ranges instead of just globally
+--         spilling the virtual reg. This might make the spill cleaner's job easier.
+--
+--   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction
+--         when making spills. If an instr is using a spilled virtual we may be able to
+--         address the spill slot directly.
+--
+regSpill
+        :: Instruction instr
+        => Platform
+        -> [LiveCmmDecl statics instr]  -- ^ the code
+        -> UniqSet Int                  -- ^ available stack slots
+        -> Int                          -- ^ current number of spill slots.
+        -> UniqSet VirtualReg           -- ^ the regs to spill
+        -> UniqSM
+            ([LiveCmmDecl statics instr]
+                 -- code with SPILL and RELOAD meta instructions added.
+            , UniqSet Int               -- left over slots
+            , Int                       -- slot count in use now.
+            , SpillStats )              -- stats about what happened during spilling
+
+regSpill platform code slotsFree slotCount regs
+
+        -- Not enough slots to spill these regs.
+        | sizeUniqSet slotsFree < sizeUniqSet regs
+        = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $
+          let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512])
+          in regSpill platform code slotsFree' (slotCount+512) regs
+
+        | otherwise
+        = do
+                -- Allocate a slot for each of the spilled regs.
+                let slots       = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
+                let regSlotMap  = listToUFM
+                                $ zip (nonDetEltsUniqSet regs) slots
+                    -- This is non-deterministic but we do not
+                    -- currently support deterministic code-generation.
+                    -- See Note [Unique Determinism and code generation]
+
+                -- Grab the unique supply from the monad.
+                us      <- getUniqueSupplyM
+
+                -- Run the spiller on all the blocks.
+                let (code', state')     =
+                        runState (mapM (regSpill_top platform regSlotMap) code)
+                                 (initSpillS us)
+
+                return  ( code'
+                        , minusUniqSet slotsFree (mkUniqSet slots)
+                        , slotCount
+                        , makeSpillStats state')
+
+
+-- | Spill some registers to stack slots in a top-level thing.
+regSpill_top
+        :: Instruction instr
+        => Platform
+        -> RegMap Int
+                -- ^ map of vregs to slots they're being spilled to.
+        -> LiveCmmDecl statics instr
+                -- ^ the top level thing.
+        -> SpillM (LiveCmmDecl statics instr)
+
+regSpill_top platform regSlotMap cmm
+ = case cmm of
+        CmmData{}
+         -> return cmm
+
+        CmmProc info label live sccs
+         |  LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info
+         -> do
+                -- The liveVRegsOnEntry contains the set of vregs that are live
+                -- on entry to each basic block. If we spill one of those vregs
+                -- we remove it from that set and add the corresponding slot
+                -- number to the liveSlotsOnEntry set. The spill cleaner needs
+                -- this information to erase unneeded spill and reload instructions
+                -- after we've done a successful allocation.
+                let liveSlotsOnEntry' :: BlockMap IntSet
+                    liveSlotsOnEntry'
+                        = mapFoldlWithKey patchLiveSlot
+                                          liveSlotsOnEntry liveVRegsOnEntry
+
+                let info'
+                        = LiveInfo static firstId
+                                liveVRegsOnEntry
+                                liveSlotsOnEntry'
+
+                -- Apply the spiller to all the basic blocks in the CmmProc.
+                sccs'   <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs
+
+                return  $ CmmProc info' label live sccs'
+
+ where  -- Given a BlockId and the set of registers live in it,
+        -- if registers in this block are being spilled to stack slots,
+        -- then record the fact that these slots are now live in those blocks
+        -- in the given slotmap.
+        patchLiveSlot
+                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
+
+        patchLiveSlot slotMap blockId regsLive
+         = let
+                -- Slots that are already recorded as being live.
+                curSlotsLive    = fromMaybe IntSet.empty
+                                $ mapLookup blockId slotMap
+
+                moreSlotsLive   = IntSet.fromList
+                                $ catMaybes
+                                $ map (lookupUFM regSlotMap)
+                                $ nonDetEltsUniqSet regsLive
+                    -- See Note [Unique Determinism and code generation]
+
+                slotMap'
+                 = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
+                             slotMap
+
+           in   slotMap'
+
+
+-- | Spill some registers to stack slots in a basic block.
+regSpill_block
+        :: Instruction instr
+        => Platform
+        -> UniqFM Int   -- ^ map of vregs to slots they're being spilled to.
+        -> LiveBasicBlock instr
+        -> SpillM (LiveBasicBlock instr)
+
+regSpill_block platform regSlotMap (BasicBlock i instrs)
+ = do   instrss'        <- mapM (regSpill_instr platform regSlotMap) instrs
+        return  $ BasicBlock i (concat instrss')
+
+
+-- | Spill some registers to stack slots in a single instruction.
+--   If the instruction uses registers that need to be spilled, then it is
+--   prefixed (or postfixed) with the appropriate RELOAD or SPILL meta
+--   instructions.
+regSpill_instr
+        :: Instruction instr
+        => Platform
+        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
+        -> LiveInstr instr
+        -> SpillM [LiveInstr instr]
+
+regSpill_instr _ _ li@(LiveInstr _ Nothing)
+ = do   return [li]
+
+regSpill_instr platform regSlotMap
+        (LiveInstr instr (Just _))
+ = do
+        -- work out which regs are read and written in this instr
+        let RU rlRead rlWritten = regUsageOfInstr platform instr
+
+        -- sometimes a register is listed as being read more than once,
+        --      nub this so we don't end up inserting two lots of spill code.
+        let rsRead_             = nub rlRead
+        let rsWritten_          = nub rlWritten
+
+        -- if a reg is modified, it appears in both lists, want to undo this..
+        let rsRead              = rsRead_    \\ rsWritten_
+        let rsWritten           = rsWritten_ \\ rsRead_
+        let rsModify            = intersect rsRead_ rsWritten_
+
+        -- work out if any of the regs being used are currently being spilled.
+        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
+        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
+        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
+
+        -- rewrite the instr and work out spill code.
+        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
+        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
+        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
+
+        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
+        let prefixes                    = concat mPrefixes
+        let postfixes                   = concat mPostfixes
+
+        -- final code
+        let instrs'     =  prefixes
+                        ++ [LiveInstr instr3 Nothing]
+                        ++ postfixes
+
+        return $ instrs'
+
+
+-- | Add a RELOAD met a instruction to load a value for an instruction that
+--   writes to a vreg that is being spilled.
+spillRead
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
+
+spillRead regSlotMap instr reg
+ | Just slot     <- lookupUFM regSlotMap reg
+ = do    (instr', nReg)  <- patchInstr reg instr
+
+         modify $ \s -> s
+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
+
+         return  ( instr'
+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]
+                 , []) )
+
+ | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
+
+
+-- | Add a SPILL meta instruction to store a value for an instruction that
+--   writes to a vreg that is being spilled.
+spillWrite
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
+
+spillWrite regSlotMap instr reg
+ | Just slot     <- lookupUFM regSlotMap reg
+ = do    (instr', nReg)  <- patchInstr reg instr
+
+         modify $ \s -> s
+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
+
+         return  ( instr'
+                 , ( []
+                   , [LiveInstr (SPILL nReg slot) Nothing]))
+
+ | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
+
+
+-- | Add both RELOAD and SPILL meta instructions for an instruction that
+--   both reads and writes to a vreg that is being spilled.
+spillModify
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
+
+spillModify regSlotMap instr reg
+ | Just slot     <- lookupUFM regSlotMap reg
+ = do    (instr', nReg)  <- patchInstr reg instr
+
+         modify $ \s -> s
+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
+
+         return  ( instr'
+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]
+                   , [LiveInstr (SPILL nReg slot) Nothing]))
+
+ | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
+
+
+-- | Rewrite uses of this virtual reg in an instr to use a different
+--   virtual reg.
+patchInstr
+        :: Instruction instr
+        => Reg -> instr -> SpillM (instr, Reg)
+
+patchInstr reg instr
+ = do   nUnique         <- newUnique
+
+        -- The register we're rewriting is suppoed to be virtual.
+        -- If it's not then something has gone horribly wrong.
+        let nReg
+             = case reg of
+                RegVirtual vr
+                 -> RegVirtual (renameVirtualReg nUnique vr)
+
+                RegReal{}
+                 -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
+
+        let instr'      = patchReg1 reg nReg instr
+        return          (instr', nReg)
+
+
+patchReg1
+        :: Instruction instr
+        => Reg -> Reg -> instr -> instr
+
+patchReg1 old new instr
+ = let  patchF r
+                | r == old      = new
+                | otherwise     = r
+   in   patchRegsOfInstr instr patchF
+
+
+-- Spiller monad --------------------------------------------------------------
+-- | State monad for the spill code generator.
+type SpillM a
+        = State SpillS a
+
+-- | Spill code generator state.
+data SpillS
+        = SpillS
+        { -- | Unique supply for generating fresh vregs.
+          stateUS       :: UniqSupply
+
+          -- | Spilled vreg vs the number of times it was loaded, stored.
+        , stateSpillSL  :: UniqFM (Reg, Int, Int) }
+
+
+-- | Create a new spiller state.
+initSpillS :: UniqSupply -> SpillS
+initSpillS uniqueSupply
+        = SpillS
+        { stateUS       = uniqueSupply
+        , stateSpillSL  = emptyUFM }
+
+
+-- | Allocate a new unique in the spiller monad.
+newUnique :: SpillM Unique
+newUnique
+ = do   us      <- gets stateUS
+        case takeUniqFromSupply us of
+         (uniq, us')
+          -> do modify $ \s -> s { stateUS = us' }
+                return uniq
+
+
+-- | Add a spill/reload count to a stats record for a register.
+accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
+accSpillSL (r1, s1, l1) (_, s2, l2)
+        = (r1, s1 + s2, l1 + l2)
+
+
+-- Spiller stats --------------------------------------------------------------
+-- | Spiller statistics.
+--   Tells us what registers were spilled.
+data SpillStats
+        = SpillStats
+        { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
+
+
+-- | Extract spiller statistics from the spiller state.
+makeSpillStats :: SpillS -> SpillStats
+makeSpillStats s
+        = SpillStats
+        { spillStoreLoad        = stateSpillSL s }
+
+
+instance Outputable SpillStats where
+ ppr stats
+        = pprUFM (spillStoreLoad stats)
+                 (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l))
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -0,0 +1,614 @@
+
+-- | Clean out unneeded spill\/reload instructions.
+--
+--   Handling of join points
+--   ~~~~~~~~~~~~~~~~~~~~~~~
+--
+--   B1:                          B2:
+--    ...                          ...
+--       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1
+--       ... A ...                    ... B ...
+--       jump B3                      jump B3
+--
+--                B3: ... C ...
+--                    RELOAD SLOT(0), %r1
+--                    ...
+--
+--   The Plan
+--   ~~~~~~~~
+--   As long as %r1 hasn't been written to in A, B or C then we don't need
+--   the reload in B3.
+--
+--   What we really care about here is that on the entry to B3, %r1 will
+--   always have the same value that is in SLOT(0) (ie, %r1 is _valid_)
+--
+--   This also works if the reloads in B1\/B2 were spills instead, because
+--   spilling %r1 to a slot makes that slot have the same value as %r1.
+--
+module RegAlloc.Graph.SpillClean (
+        cleanSpills
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import BlockId
+import Cmm
+import UniqSet
+import UniqFM
+import Unique
+import State
+import Outputable
+import Platform
+import Hoopl.Collections
+
+import Data.List
+import Data.Maybe
+import Data.IntSet              (IntSet)
+import qualified Data.IntSet    as IntSet
+
+
+-- | The identification number of a spill slot.
+--   A value is stored in a spill slot when we don't have a free
+--   register to hold it.
+type Slot = Int
+
+
+-- | Clean out unneeded spill\/reloads from this top level thing.
+cleanSpills
+        :: Instruction instr
+        => Platform
+        -> LiveCmmDecl statics instr
+        -> LiveCmmDecl statics instr
+
+cleanSpills platform cmm
+        = evalState (cleanSpin platform 0 cmm) initCleanS
+
+
+-- | Do one pass of cleaning.
+cleanSpin
+        :: Instruction instr
+        => Platform
+        -> Int                              -- ^ Iteration number for the cleaner.
+        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.
+        -> CleanM (LiveCmmDecl statics instr)
+
+cleanSpin platform spinCount code
+ = do
+        -- Initialise count of cleaned spill and reload instructions.
+        modify $ \s -> s
+                { sCleanedSpillsAcc     = 0
+                , sCleanedReloadsAcc    = 0
+                , sReloadedBy           = emptyUFM }
+
+        code_forward    <- mapBlockTopM (cleanBlockForward platform) code
+        code_backward   <- cleanTopBackward code_forward
+
+        -- During the cleaning of each block we collected information about
+        -- what regs were valid across each jump. Based on this, work out
+        -- whether it will be safe to erase reloads after join points for
+        -- the next pass.
+        collateJoinPoints
+
+        -- Remember how many spill and reload instructions we cleaned in this pass.
+        spills          <- gets sCleanedSpillsAcc
+        reloads         <- gets sCleanedReloadsAcc
+        modify $ \s -> s
+                { sCleanedCount = (spills, reloads) : sCleanedCount s }
+
+        -- If nothing was cleaned in this pass or the last one
+        --      then we're done and it's time to bail out.
+        cleanedCount    <- gets sCleanedCount
+        if take 2 cleanedCount == [(0, 0), (0, 0)]
+           then return code
+
+        -- otherwise go around again
+           else cleanSpin platform (spinCount + 1) code_backward
+
+
+-------------------------------------------------------------------------------
+-- | Clean out unneeded reload instructions,
+--   while walking forward over the code.
+cleanBlockForward
+        :: Instruction instr
+        => Platform
+        -> LiveBasicBlock instr
+        -> CleanM (LiveBasicBlock instr)
+
+cleanBlockForward platform (BasicBlock blockId instrs)
+ = do
+        -- See if we have a valid association for the entry to this block.
+        jumpValid       <- gets sJumpValid
+        let assoc       = case lookupUFM jumpValid blockId of
+                                Just assoc      -> assoc
+                                Nothing         -> emptyAssoc
+
+        instrs_reload   <- cleanForward platform blockId assoc [] instrs
+        return  $ BasicBlock blockId instrs_reload
+
+
+
+-- | Clean out unneeded reload instructions.
+--
+--   Walking forwards across the code
+--     On a reload, if we know a reg already has the same value as a slot
+--     then we don't need to do the reload.
+--
+cleanForward
+        :: Instruction instr
+        => Platform
+        -> BlockId                  -- ^ the block that we're currently in
+        -> Assoc Store              -- ^ two store locations are associated if
+                                    --     they have the same value
+        -> [LiveInstr instr]        -- ^ acc
+        -> [LiveInstr instr]        -- ^ instrs to clean (in backwards order)
+        -> CleanM [LiveInstr instr] -- ^ cleaned instrs  (in forward   order)
+
+cleanForward _ _ _ acc []
+        = return acc
+
+-- Rewrite live range joins via spill slots to just a spill and a reg-reg move
+-- hopefully the spill will be also be cleaned in the next pass
+cleanForward platform blockId assoc acc (li1 : li2 : instrs)
+
+        | LiveInstr (SPILL  reg1  slot1) _      <- li1
+        , LiveInstr (RELOAD slot2 reg2)  _      <- li2
+        , slot1 == slot2
+        = do
+                modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+                cleanForward platform blockId assoc acc
+                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing
+                       : instrs
+
+cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)
+        | Just (r1, r2) <- takeRegRegMoveInstr i1
+        = if r1 == r2
+                -- Erase any left over nop reg reg moves while we're here
+                -- this will also catch any nop moves that the previous case
+                -- happens to add.
+                then cleanForward platform blockId assoc acc instrs
+
+                -- If r1 has the same value as some slots and we copy r1 to r2,
+                --      then r2 is now associated with those slots instead
+                else do let assoc'      = addAssoc (SReg r1) (SReg r2)
+                                        $ delAssoc (SReg r2)
+                                        $ assoc
+
+                        cleanForward platform blockId assoc' (li : acc) instrs
+
+
+cleanForward platform blockId assoc acc (li : instrs)
+
+        -- Update association due to the spill.
+        | LiveInstr (SPILL reg slot) _  <- li
+        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)
+                        $ delAssoc (SSlot slot)
+                        $ assoc
+          in    cleanForward platform blockId assoc' (li : acc) instrs
+
+        -- Clean a reload instr.
+        | LiveInstr (RELOAD{}) _        <- li
+        = do    (assoc', mli)   <- cleanReload platform blockId assoc li
+                case mli of
+                 Nothing        -> cleanForward platform blockId assoc' acc
+                                                instrs
+
+                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)
+                                                instrs
+
+        -- Remember the association over a jump.
+        | LiveInstr instr _     <- li
+        , targets               <- jumpDestsOfInstr instr
+        , not $ null targets
+        = do    mapM_ (accJumpValid assoc) targets
+                cleanForward platform blockId assoc (li : acc) instrs
+
+        -- Writing to a reg changes its value.
+        | LiveInstr instr _     <- li
+        , RU _ written          <- regUsageOfInstr platform instr
+        = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)
+          in  cleanForward platform blockId assoc' (li : acc) instrs
+
+
+
+-- | Try and rewrite a reload instruction to something more pleasing
+cleanReload
+        :: Instruction instr
+        => Platform
+        -> BlockId
+        -> Assoc Store
+        -> LiveInstr instr
+        -> CleanM (Assoc Store, Maybe (LiveInstr instr))
+
+cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)
+
+        -- If the reg we're reloading already has the same value as the slot
+        --      then we can erase the instruction outright.
+        | elemAssoc (SSlot slot) (SReg reg) assoc
+        = do    modify  $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+                return  (assoc, Nothing)
+
+        -- If we can find another reg with the same value as this slot then
+        --      do a move instead of a reload.
+        | Just reg2     <- findRegOfSlot assoc slot
+        = do    modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+
+                let assoc'      = addAssoc (SReg reg) (SReg reg2)
+                                $ delAssoc (SReg reg)
+                                $ assoc
+
+                return  ( assoc'
+                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)
+
+        -- Gotta keep this instr.
+        | otherwise
+        = do    -- Update the association.
+                let assoc'
+                        = addAssoc (SReg reg)  (SSlot slot)
+                                -- doing the reload makes reg and slot the same value
+                        $ delAssoc (SReg reg)
+                                -- reg value changes on reload
+                        $ assoc
+
+                -- Remember that this block reloads from this slot.
+                accBlockReloadsSlot blockId slot
+
+                return  (assoc', Just li)
+
+cleanReload _ _ _ _
+        = panic "RegSpillClean.cleanReload: unhandled instr"
+
+
+-------------------------------------------------------------------------------
+-- | Clean out unneeded spill instructions,
+--   while walking backwards over the code.
+--
+--      If there were no reloads from a slot between a spill and the last one
+--      then the slot was never read and we don't need the spill.
+--
+--      SPILL   r0 -> s1
+--      RELOAD  s1 -> r2
+--      SPILL   r3 -> s1        <--- don't need this spill
+--      SPILL   r4 -> s1
+--      RELOAD  s1 -> r5
+--
+--      Maintain a set of
+--              "slots which were spilled to but not reloaded from yet"
+--
+--      Walking backwards across the code:
+--       a) On a reload from a slot, remove it from the set.
+--
+--       a) On a spill from a slot
+--              If the slot is in set then we can erase the spill,
+--               because it won't be reloaded from until after the next spill.
+--
+--              otherwise
+--               keep the spill and add the slot to the set
+--
+-- TODO: This is mostly inter-block
+--       we should really be updating the noReloads set as we cross jumps also.
+--
+-- TODO: generate noReloads from liveSlotsOnEntry
+--
+cleanTopBackward
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> CleanM (LiveCmmDecl statics instr)
+
+cleanTopBackward cmm
+ = case cmm of
+        CmmData{}
+         -> return cmm
+
+        CmmProc info label live sccs
+         | LiveInfo _ _ _ liveSlotsOnEntry <- info
+         -> do  sccs'   <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
+                return  $ CmmProc info label live sccs'
+
+
+cleanBlockBackward
+        :: Instruction instr
+        => BlockMap IntSet
+        -> LiveBasicBlock instr
+        -> CleanM (LiveBasicBlock instr)
+
+cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)
+ = do   instrs_spill    <- cleanBackward liveSlotsOnEntry  emptyUniqSet  [] instrs
+        return  $ BasicBlock blockId instrs_spill
+
+
+
+cleanBackward
+        :: Instruction instr
+        => BlockMap IntSet          -- ^ Slots live on entry to each block
+        -> UniqSet Int              -- ^ Slots that have been spilled, but not reloaded from
+        -> [LiveInstr instr]        -- ^ acc
+        -> [LiveInstr instr]        -- ^ Instrs to clean (in forwards order)
+        -> CleanM [LiveInstr instr] -- ^ Cleaned instrs  (in backwards order)
+
+cleanBackward liveSlotsOnEntry noReloads acc lis
+ = do   reloadedBy      <- gets sReloadedBy
+        cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis
+
+
+cleanBackward'
+        :: Instruction instr
+        => BlockMap IntSet
+        -> UniqFM [BlockId]
+        -> UniqSet Int
+        -> [LiveInstr instr]
+        -> [LiveInstr instr]
+        -> State CleanS [LiveInstr instr]
+
+cleanBackward' _ _ _      acc []
+        = return  acc
+
+cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
+
+        -- If nothing ever reloads from this slot then we don't need the spill.
+        | LiveInstr (SPILL _ slot) _    <- li
+        , Nothing       <- lookupUFM reloadedBy (SSlot slot)
+        = do    modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+                cleanBackward liveSlotsOnEntry noReloads acc instrs
+
+        | LiveInstr (SPILL _ slot) _    <- li
+        = if elementOfUniqSet slot noReloads
+
+           -- We can erase this spill because the slot won't be read until
+           -- after the next one
+           then do
+                modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+                cleanBackward liveSlotsOnEntry noReloads acc instrs
+
+           else do
+                -- This slot is being spilled to, but we haven't seen any reloads yet.
+                let noReloads'  = addOneToUniqSet noReloads slot
+                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
+
+        -- if we reload from a slot then it's no longer unused
+        | LiveInstr (RELOAD slot _) _   <- li
+        , noReloads'            <- delOneFromUniqSet noReloads slot
+        = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
+
+        -- If a slot is live in a jump target then assume it's reloaded there.
+        --
+        -- TODO: A real dataflow analysis would do a better job here.
+        --       If the target block _ever_ used the slot then we assume
+        --       it always does, but if those reloads are cleaned the slot
+        --       liveness map doesn't get updated.
+        | LiveInstr instr _     <- li
+        , targets               <- jumpDestsOfInstr instr
+        = do
+                let slotsReloadedByTargets
+                        = IntSet.unions
+                        $ catMaybes
+                        $ map (flip mapLookup liveSlotsOnEntry)
+                        $ targets
+
+                let noReloads'
+                        = foldl' delOneFromUniqSet noReloads
+                        $ IntSet.toList slotsReloadedByTargets
+
+                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
+
+        -- some other instruction
+        | otherwise
+        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
+
+
+-- | Combine the associations from all the inward control flow edges.
+--
+collateJoinPoints :: CleanM ()
+collateJoinPoints
+ = modify $ \s -> s
+        { sJumpValid    = mapUFM intersects (sJumpValidAcc s)
+        , sJumpValidAcc = emptyUFM }
+
+intersects :: [Assoc Store]     -> Assoc Store
+intersects []           = emptyAssoc
+intersects assocs       = foldl1' intersectAssoc assocs
+
+
+-- | See if we have a reg with the same value as this slot in the association table.
+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
+findRegOfSlot assoc slot
+        | close                 <- closeAssoc (SSlot slot) assoc
+        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUniqSet close
+           -- See Note [Unique Determinism and code generation]
+        = Just reg
+
+        | otherwise
+        = Nothing
+
+
+-------------------------------------------------------------------------------
+-- | Cleaner monad.
+type CleanM
+        = State CleanS
+
+-- | Cleaner state.
+data CleanS
+        = CleanS
+        { -- | Regs which are valid at the start of each block.
+          sJumpValid            :: UniqFM (Assoc Store)
+
+          -- | Collecting up what regs were valid across each jump.
+          --    in the next pass we can collate these and write the results
+          --    to sJumpValid.
+        , sJumpValidAcc         :: UniqFM [Assoc Store]
+
+          -- | Map of (slot -> blocks which reload from this slot)
+          --    used to decide if whether slot spilled to will ever be
+          --    reloaded from on this path.
+        , sReloadedBy           :: UniqFM [BlockId]
+
+          -- | Spills and reloads cleaned each pass (latest at front)
+        , sCleanedCount         :: [(Int, Int)]
+
+          -- | Spills and reloads that have been cleaned in this pass so far.
+        , sCleanedSpillsAcc     :: Int
+        , sCleanedReloadsAcc    :: Int }
+
+
+-- | Construct the initial cleaner state.
+initCleanS :: CleanS
+initCleanS
+        = CleanS
+        { sJumpValid            = emptyUFM
+        , sJumpValidAcc         = emptyUFM
+
+        , sReloadedBy           = emptyUFM
+
+        , sCleanedCount         = []
+
+        , sCleanedSpillsAcc     = 0
+        , sCleanedReloadsAcc    = 0 }
+
+
+-- | Remember the associations before a jump.
+accJumpValid :: Assoc Store -> BlockId -> CleanM ()
+accJumpValid assocs target
+ = modify $ \s -> s {
+        sJumpValidAcc = addToUFM_C (++)
+                                (sJumpValidAcc s)
+                                target
+                                [assocs] }
+
+
+accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
+accBlockReloadsSlot blockId slot
+ = modify $ \s -> s {
+        sReloadedBy = addToUFM_C (++)
+                                (sReloadedBy s)
+                                (SSlot slot)
+                                [blockId] }
+
+
+-------------------------------------------------------------------------------
+-- A store location can be a stack slot or a register
+data Store
+        = SSlot Int
+        | SReg  Reg
+
+
+-- | Check if this is a reg store.
+isStoreReg :: Store -> Bool
+isStoreReg ss
+ = case ss of
+        SSlot _ -> False
+        SReg  _ -> True
+
+
+-- Spill cleaning is only done once all virtuals have been allocated to realRegs
+instance Uniquable Store where
+    getUnique (SReg  r)
+        | RegReal (RealRegSingle i)     <- r
+        = mkRegSingleUnique i
+
+        | RegReal (RealRegPair r1 r2)   <- r
+        = mkRegPairUnique (r1 * 65535 + r2)
+
+        | otherwise
+        = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"
+                ++ "only real regs expected."
+
+    getUnique (SSlot i) = mkRegSubUnique i    -- [SLPJ] I hope "SubUnique" is ok
+
+
+instance Outputable Store where
+        ppr (SSlot i)   = text "slot" <> int i
+        ppr (SReg  r)   = ppr r
+
+
+-------------------------------------------------------------------------------
+-- Association graphs.
+-- In the spill cleaner, two store locations are associated if they are known
+-- to hold the same value.
+--
+type Assoc a    = UniqFM (UniqSet a)
+
+-- | An empty association
+emptyAssoc :: Assoc a
+emptyAssoc      = emptyUFM
+
+
+-- | Add an association between these two things.
+addAssoc :: Uniquable a
+         => a -> a -> Assoc a -> Assoc a
+
+addAssoc a b m
+ = let  m1      = addToUFM_C unionUniqSets m  a (unitUniqSet b)
+        m2      = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
+   in   m2
+
+
+-- | Delete all associations to a node.
+delAssoc :: (Uniquable a)
+         => a -> Assoc a -> Assoc a
+
+delAssoc a m
+        | Just aSet     <- lookupUFM  m a
+        , m1            <- delFromUFM m a
+        = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
+          -- It's OK to use nonDetFoldUFM here because deletion is commutative
+
+        | otherwise     = m
+
+
+-- | Delete a single association edge (a -> b).
+delAssoc1 :: Uniquable a
+          => a -> a -> Assoc a -> Assoc a
+
+delAssoc1 a b m
+        | Just aSet     <- lookupUFM m a
+        = addToUFM m a (delOneFromUniqSet aSet b)
+
+        | otherwise     = m
+
+
+-- | Check if these two things are associated.
+elemAssoc :: (Uniquable a)
+          => a -> a -> Assoc a -> Bool
+
+elemAssoc a b m
+        = elementOfUniqSet b (closeAssoc a m)
+
+
+-- | Find the refl. trans. closure of the association from this point.
+closeAssoc :: (Uniquable a)
+        => a -> Assoc a -> UniqSet a
+
+closeAssoc a assoc
+ =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)
+ where
+        closeAssoc' assoc visited toVisit
+         = case nonDetEltsUniqSet toVisit of
+             -- See Note [Unique Determinism and code generation]
+
+                -- nothing else to visit, we're done
+                []      -> visited
+
+                (x:_)
+                 -- we've already seen this node
+                 |  elementOfUniqSet x visited
+                 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
+
+                 -- haven't seen this node before,
+                 --     remember to visit all its neighbors
+                 |  otherwise
+                 -> let neighbors
+                         = case lookupUFM assoc x of
+                                Nothing         -> emptyUniqSet
+                                Just set        -> set
+
+                   in closeAssoc' assoc
+                        (addOneToUniqSet visited x)
+                        (unionUniqSets   toVisit neighbors)
+
+-- | Intersect two associations.
+intersectAssoc :: Assoc a -> Assoc a -> Assoc a
+intersectAssoc a b
+        = intersectUFM_C (intersectUniqSets) a b
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -0,0 +1,310 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module RegAlloc.Graph.SpillCost (
+        SpillCostRecord,
+        plusSpillCostRecord,
+        pprSpillCostRecord,
+
+        SpillCostInfo,
+        zeroSpillCostInfo,
+        plusSpillCostInfo,
+
+        slurpSpillCostInfo,
+        chooseSpill,
+
+        lifeMapFromSpillCostInfo
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import RegClass
+import Reg
+
+import GraphBase
+
+import Hoopl.Collections (mapLookup)
+import Cmm
+import UniqFM
+import UniqSet
+import Digraph          (flattenSCCs)
+import Outputable
+import Platform
+import State
+import CFG
+
+import Data.List        (nub, minimumBy)
+import Data.Maybe
+import Control.Monad (join)
+
+
+-- | Records the expected cost to spill some regster.
+type SpillCostRecord
+ =      ( VirtualReg    -- register name
+        , Int           -- number of writes to this reg
+        , Int           -- number of reads from this reg
+        , Int)          -- number of instrs this reg was live on entry to
+
+
+-- | Map of `SpillCostRecord`
+type SpillCostInfo
+        = UniqFM SpillCostRecord
+
+-- | Block membership in a loop
+type LoopMember = Bool
+
+type SpillCostState = State (UniqFM SpillCostRecord) ()
+
+-- | An empty map of spill costs.
+zeroSpillCostInfo :: SpillCostInfo
+zeroSpillCostInfo       = emptyUFM
+
+
+-- | Add two spill cost infos.
+plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
+plusSpillCostInfo sc1 sc2
+        = plusUFM_C plusSpillCostRecord sc1 sc2
+
+
+-- | Add two spill cost records.
+plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
+plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
+        | r1 == r2      = (r1, a1 + a2, b1 + b2, c1 + c2)
+        | otherwise     = error "RegSpillCost.plusRegInt: regs don't match"
+
+
+-- | Slurp out information used for determining spill costs.
+--
+--   For each vreg, the number of times it was written to, read from,
+--   and the number of instructions it was live on entry to (lifetime)
+--
+slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr)
+                   => Platform
+                   -> Maybe CFG
+                   -> LiveCmmDecl statics instr
+                   -> SpillCostInfo
+
+slurpSpillCostInfo platform cfg cmm
+        = execState (countCmm cmm) zeroSpillCostInfo
+ where
+        countCmm CmmData{}              = return ()
+        countCmm (CmmProc info _ _ sccs)
+                = mapM_ (countBlock info)
+                $ flattenSCCs sccs
+
+        -- Lookup the regs that are live on entry to this block in
+        --      the info table from the CmmProc.
+        countBlock info (BasicBlock blockId instrs)
+                | LiveInfo _ _ blockLive _ <- info
+                , Just rsLiveEntry  <- mapLookup blockId blockLive
+                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry
+                = countLIs (loopMember blockId) rsLiveEntry_virt instrs
+
+                | otherwise
+                = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
+
+        countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
+        countLIs _      _      []
+                = return ()
+
+        -- Skip over comment and delta pseudo instrs.
+        countLIs inLoop rsLive (LiveInstr instr Nothing : lis)
+                | isMetaInstr instr
+                = countLIs inLoop rsLive lis
+
+                | otherwise
+                = pprPanic "RegSpillCost.slurpSpillCostInfo"
+                $ text "no liveness information on instruction " <> ppr instr
+
+        countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)
+         = do
+                -- Increment the lifetime counts for regs live on entry to this instr.
+                mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry
+                    -- This is non-deterministic but we do not
+                    -- currently support deterministic code-generation.
+                    -- See Note [Unique Determinism and code generation]
+
+                -- Increment counts for what regs were read/written from.
+                let (RU read written)   = regUsageOfInstr platform instr
+                mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read
+                mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written
+
+                -- Compute liveness for entry to next instruction.
+                let liveDieRead_virt    = takeVirtuals (liveDieRead  live)
+                let liveDieWrite_virt   = takeVirtuals (liveDieWrite live)
+                let liveBorn_virt       = takeVirtuals (liveBorn     live)
+
+                let rsLiveAcross
+                        = rsLiveEntry `minusUniqSet` liveDieRead_virt
+
+                let rsLiveNext
+                        = (rsLiveAcross `unionUniqSets` liveBorn_virt)
+                                        `minusUniqSet`  liveDieWrite_virt
+
+                countLIs inLoop rsLiveNext lis
+
+        loopCount inLoop
+          | inLoop = 10
+          | otherwise = 1
+        incDefs     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
+        incUses     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
+        incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)
+
+        loopBlocks = CFG.loopMembers <$> cfg
+        loopMember bid
+          | Just isMember <- join (mapLookup bid <$> loopBlocks)
+          = isMember
+          | otherwise
+          = False
+
+-- | Take all the virtual registers from this set.
+takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
+takeVirtuals set = mkUniqSet
+  [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
+  -- See Note [Unique Determinism and code generation]
+
+
+-- | Choose a node to spill from this graph
+chooseSpill
+        :: SpillCostInfo
+        -> Graph VirtualReg RegClass RealReg
+        -> VirtualReg
+
+chooseSpill info graph
+ = let  cost    = spillCost_length info graph
+        node    = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+   in   nodeId node
+
+
+-------------------------------------------------------------------------------
+-- | Chaitins spill cost function is:
+--
+--   cost =     sum         loadCost * freq (u)  +    sum        storeCost * freq (d)
+--          u <- uses (v)                         d <- defs (v)
+--
+--   There are no loops in our code at the moment, so we can set the freq's to 1.
+--
+--  If we don't have live range splitting then Chaitins function performs badly
+--  if we have lots of nested live ranges and very few registers.
+--
+--               v1 v2 v3
+--      def v1   .
+--      use v1   .
+--      def v2   .  .
+--      def v3   .  .  .
+--      use v1   .  .  .
+--      use v3   .  .  .
+--      use v2   .  .
+--      use v1   .
+--
+--           defs uses degree   cost
+--      v1:  1     3     3      1.5
+--      v2:  1     2     3      1.0
+--      v3:  1     1     3      0.666
+--
+--   v3 has the lowest cost, but if we only have 2 hardregs and we insert
+--   spill code for v3 then this isn't going to improve the colorability of
+--   the graph.
+--
+--  When compiling SHA1, which as very long basic blocks and some vregs
+--  with very long live ranges the allocator seems to try and spill from
+--  the inside out and eventually run out of stack slots.
+--
+--  Without live range splitting, its's better to spill from the outside
+--  in so set the cost of very long live ranges to zero
+--
+{-
+spillCost_chaitin
+        :: SpillCostInfo
+        -> Graph Reg RegClass Reg
+        -> Reg
+        -> Float
+
+spillCost_chaitin info graph reg
+        -- Spilling a live range that only lives for 1 instruction
+        -- isn't going to help us at all - and we definitely want to avoid
+        -- trying to re-spill previously inserted spill code.
+        | lifetime <= 1         = 1/0
+
+        -- It's unlikely that we'll find a reg for a live range this long
+        -- better to spill it straight up and not risk trying to keep it around
+        -- and have to go through the build/color cycle again.
+        | lifetime > allocatableRegsInClass (regClass reg) * 10
+        = 0
+
+        -- Otherwise revert to chaitin's regular cost function.
+        | otherwise     = fromIntegral (uses + defs)
+                        / fromIntegral (nodeDegree graph reg)
+        where (_, defs, uses, lifetime)
+                = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
+-}
+
+-- Just spill the longest live range.
+spillCost_length
+        :: SpillCostInfo
+        -> Graph VirtualReg RegClass RealReg
+        -> VirtualReg
+        -> Float
+
+spillCost_length info _ reg
+        | lifetime <= 1         = 1/0
+        | otherwise             = 1 / fromIntegral lifetime
+        where (_, _, _, lifetime)
+                = fromMaybe (reg, 0, 0, 0)
+                $ lookupUFM info reg
+
+
+-- | Extract a map of register lifetimes from a `SpillCostInfo`.
+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)
+lifeMapFromSpillCostInfo info
+        = listToUFM
+        $ map (\(r, _, _, life) -> (r, (r, life)))
+        $ nonDetEltsUFM info
+        -- See Note [Unique Determinism and code generation]
+
+
+-- | Determine the degree (number of neighbors) of this node which
+--   have the same class.
+nodeDegree
+        :: (VirtualReg -> RegClass)
+        -> Graph VirtualReg RegClass RealReg
+        -> VirtualReg
+        -> Int
+
+nodeDegree classOfVirtualReg graph reg
+        | Just node     <- lookupUFM (graphMap graph) reg
+
+        , virtConflicts
+           <- length
+           $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
+           $ nonDetEltsUniqSet
+           -- See Note [Unique Determinism and code generation]
+           $ nodeConflicts node
+
+        = virtConflicts + sizeUniqSet (nodeExclusions node)
+
+        | otherwise
+        = 0
+
+
+-- | Show a spill cost record, including the degree from the graph
+--   and final calulated spill cost.
+pprSpillCostRecord
+        :: (VirtualReg -> RegClass)
+        -> (Reg -> SDoc)
+        -> Graph VirtualReg RegClass RealReg
+        -> SpillCostRecord
+        -> SDoc
+
+pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
+        =  hsep
+        [ pprReg (RegVirtual reg)
+        , ppr uses
+        , ppr defs
+        , ppr life
+        , ppr $ nodeDegree regClass graph reg
+        , text $ show $ (fromIntegral (uses + defs)
+                       / fromIntegral (nodeDegree regClass graph reg) :: Float) ]
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE BangPatterns, CPP #-}
+
+-- | Carries interesting info for debugging / profiling of the
+--   graph coloring register allocator.
+module RegAlloc.Graph.Stats (
+        RegAllocStats (..),
+
+        pprStats,
+        pprStatsSpills,
+        pprStatsLifetimes,
+        pprStatsConflict,
+        pprStatsLifeConflict,
+
+        countSRMs, addSRM
+) where
+
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import qualified GraphColor as Color
+import RegAlloc.Liveness
+import RegAlloc.Graph.Spill
+import RegAlloc.Graph.SpillCost
+import RegAlloc.Graph.TrivColorable
+import Instruction
+import RegClass
+import Reg
+import TargetReg
+
+import PprCmm()
+import Outputable
+import UniqFM
+import UniqSet
+import State
+
+-- | Holds interesting statistics from the register allocator.
+data RegAllocStats statics instr
+
+        -- Information about the initial conflict graph.
+        = RegAllocStatsStart
+        { -- | Initial code, with liveness.
+          raLiveCmm     :: [LiveCmmDecl statics instr]
+
+          -- | The initial, uncolored graph.
+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | Information to help choose which regs to spill.
+        , raSpillCosts  :: SpillCostInfo }
+
+
+        -- Information about an intermediate graph.
+        -- This is one that we couldn't color, so had to insert spill code
+        -- instruction stream.
+        | RegAllocStatsSpill
+        { -- | Code we tried to allocate registers for.
+          raCode        :: [LiveCmmDecl statics instr]
+
+          -- | Partially colored graph.
+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | The regs that were coalesced.
+        , raCoalesced   :: UniqFM VirtualReg
+
+          -- | Spiller stats.
+        , raSpillStats  :: SpillStats
+
+          -- | Number of instructions each reg lives for.
+        , raSpillCosts  :: SpillCostInfo
+
+          -- | Code with spill instructions added.
+        , raSpilled     :: [LiveCmmDecl statics instr] }
+
+
+        -- a successful coloring
+        | RegAllocStatsColored
+        { -- | Code we tried to allocate registers for.
+          raCode          :: [LiveCmmDecl statics instr]
+
+          -- | Uncolored graph.
+        , raGraph         :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | Coalesced and colored graph.
+        , raGraphColored  :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | Regs that were coalesced.
+        , raCoalesced     :: UniqFM VirtualReg
+
+          -- | Code with coalescings applied.
+        , raCodeCoalesced :: [LiveCmmDecl statics instr]
+
+          -- | Code with vregs replaced by hregs.
+        , raPatched       :: [LiveCmmDecl statics instr]
+
+          -- | Code with unneeded spill\/reloads cleaned out.
+        , raSpillClean    :: [LiveCmmDecl statics instr]
+
+          -- | Final code.
+        , raFinal         :: [NatCmmDecl statics instr]
+
+          -- | Spill\/reload\/reg-reg moves present in this code.
+        , raSRMs          :: (Int, Int, Int) }
+
+
+instance (Outputable statics, Outputable instr)
+       => Outputable (RegAllocStats statics instr) where
+
+ ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->
+           text "#  Start"
+        $$ text "#  Native code with liveness information."
+        $$ ppr (raLiveCmm s)
+        $$ text ""
+        $$ text "#  Initial register conflict graph."
+        $$ Color.dotGraph
+                (targetRegDotColor platform)
+                (trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform))
+                (raGraph s)
+
+
+ ppr (s@RegAllocStatsSpill{}) =
+           text "#  Spill"
+
+        $$ text "#  Code with liveness information."
+        $$ ppr (raCode s)
+        $$ text ""
+
+        $$ (if (not $ isNullUFM $ raCoalesced s)
+                then    text "#  Registers coalesced."
+                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
+                        $$ text ""
+                else empty)
+
+        $$ text "#  Spills inserted."
+        $$ ppr (raSpillStats s)
+        $$ text ""
+
+        $$ text "#  Code with spills inserted."
+        $$ ppr (raSpilled s)
+
+
+ ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
+    = sdocWithPlatform $ \platform ->
+           text "#  Colored"
+
+        $$ text "#  Code with liveness information."
+        $$ ppr (raCode s)
+        $$ text ""
+
+        $$ text "#  Register conflict graph (colored)."
+        $$ Color.dotGraph
+                (targetRegDotColor platform)
+                (trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform))
+                (raGraphColored s)
+        $$ text ""
+
+        $$ (if (not $ isNullUFM $ raCoalesced s)
+                then    text "#  Registers coalesced."
+                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
+                        $$ text ""
+                else empty)
+
+        $$ text "#  Native code after coalescings applied."
+        $$ ppr (raCodeCoalesced s)
+        $$ text ""
+
+        $$ text "#  Native code after register allocation."
+        $$ ppr (raPatched s)
+        $$ text ""
+
+        $$ text "#  Clean out unneeded spill/reloads."
+        $$ ppr (raSpillClean s)
+        $$ text ""
+
+        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
+        $$ ppr (raFinal s)
+        $$ text ""
+        $$  text "#  Score:"
+        $$ (text "#          spills  inserted: " <> int spills)
+        $$ (text "#          reloads inserted: " <> int reloads)
+        $$ (text "#   reg-reg moves remaining: " <> int moves)
+        $$ text ""
+
+
+-- | Do all the different analysis on this list of RegAllocStats
+pprStats
+        :: [RegAllocStats statics instr]
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> SDoc
+
+pprStats stats graph
+ = let  outSpills       = pprStatsSpills    stats
+        outLife         = pprStatsLifetimes stats
+        outConflict     = pprStatsConflict  stats
+        outScatter      = pprStatsLifeConflict stats graph
+
+  in    vcat [outSpills, outLife, outConflict, outScatter]
+
+
+-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
+pprStatsSpills
+        :: [RegAllocStats statics instr] -> SDoc
+
+pprStatsSpills stats
+ = let
+        finals  = [ s   | s@RegAllocStatsColored{} <- stats]
+
+        -- sum up how many stores\/loads\/reg-reg-moves were left in the code
+        total   = foldl' addSRM (0, 0, 0)
+                $ map raSRMs finals
+
+    in  (  text "-- spills-added-total"
+        $$ text "--    (stores, loads, reg_reg_moves_remaining)"
+        $$ ppr total
+        $$ text "")
+
+
+-- | Dump a table of how long vregs tend to live for in the initial code.
+pprStatsLifetimes
+        :: [RegAllocStats statics instr] -> SDoc
+
+pprStatsLifetimes stats
+ = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo
+                                [ raSpillCosts s
+                                        | s@RegAllocStatsStart{} <- stats ]
+
+        lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info
+
+   in   (  text "-- vreg-population-lifetimes"
+        $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
+        $$ pprUFM lifeBins (vcat . map ppr)
+        $$ text "\n")
+
+
+binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
+binLifetimeCount fm
+ = let  lifes   = map (\l -> (l, (l, 1)))
+                $ map snd
+                $ nonDetEltsUFM fm
+                -- See Note [Unique Determinism and code generation]
+
+   in   addListToUFM_C
+                (\(l1, c1) (_, c2) -> (l1, c1 + c2))
+                emptyUFM
+                lifes
+
+
+-- | Dump a table of how many conflicts vregs tend to have in the initial code.
+pprStatsConflict
+        :: [RegAllocStats statics instr] -> SDoc
+
+pprStatsConflict stats
+ = let  confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
+                        emptyUFM
+                $ map Color.slurpNodeConflictCount
+                        [ raGraph s | s@RegAllocStatsStart{} <- stats ]
+
+   in   (  text "-- vreg-conflicts"
+        $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
+        $$ pprUFM confMap (vcat . map ppr)
+        $$ text "\n")
+
+
+-- | For every vreg, dump how many conflicts it has, and its lifetime.
+--      Good for making a scatter plot.
+pprStatsLifeConflict
+        :: [RegAllocStats statics instr]
+        -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
+        -> SDoc
+
+pprStatsLifeConflict stats graph
+ = let  lifeMap = lifeMapFromSpillCostInfo
+                $ foldl' plusSpillCostInfo zeroSpillCostInfo
+                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
+
+        scatter = map   (\r ->  let lifetime  = case lookupUFM lifeMap r of
+                                                      Just (_, l) -> l
+                                                      Nothing     -> 0
+                                    Just node = Color.lookupNode graph r
+                                in parens $ hcat $ punctuate (text ", ")
+                                        [ doubleQuotes $ ppr $ Color.nodeId node
+                                        , ppr $ sizeUniqSet (Color.nodeConflicts node)
+                                        , ppr $ lifetime ])
+                $ map Color.nodeId
+                $ nonDetEltsUFM
+                -- See Note [Unique Determinism and code generation]
+                $ Color.graphMap graph
+
+   in   (  text "-- vreg-conflict-lifetime"
+        $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
+        $$ (vcat scatter)
+        $$ text "\n")
+
+
+-- | Count spill/reload/reg-reg moves.
+--      Lets us see how well the register allocator has done.
+countSRMs
+        :: Instruction instr
+        => LiveCmmDecl statics instr -> (Int, Int, Int)
+
+countSRMs cmm
+        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+
+
+countSRM_block
+        :: Instruction instr
+        => GenBasicBlock (LiveInstr instr)
+        -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
+
+countSRM_block (BasicBlock i instrs)
+ = do   instrs' <- mapM countSRM_instr instrs
+        return  $ BasicBlock i instrs'
+
+
+countSRM_instr
+        :: Instruction instr
+        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
+
+countSRM_instr li
+        | LiveInstr SPILL{} _    <- li
+        = do    modify  $ \(s, r, m)    -> (s + 1, r, m)
+                return li
+
+        | LiveInstr RELOAD{} _  <- li
+        = do    modify  $ \(s, r, m)    -> (s, r + 1, m)
+                return li
+
+        | LiveInstr instr _     <- li
+        , Just _        <- takeRegRegMoveInstr instr
+        = do    modify  $ \(s, r, m)    -> (s, r, m + 1)
+                return li
+
+        | otherwise
+        =       return li
+
+
+-- sigh..
+addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
+addSRM (s1, r1, m1) (s2, r2, m2)
+ = let  !s = s1 + s2
+        !r = r1 + r2
+        !m = m1 + m2
+   in   (s, r, m)
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -0,0 +1,271 @@
+{-# LANGUAGE CPP #-}
+
+module RegAlloc.Graph.TrivColorable (
+        trivColorable,
+)
+
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import RegClass
+import Reg
+
+import GraphBase
+
+import UniqSet
+import Platform
+import Panic
+
+-- trivColorable ---------------------------------------------------------------
+
+-- trivColorable function for the graph coloring allocator
+--
+--      This gets hammered by scanGraph during register allocation,
+--      so needs to be fairly efficient.
+--
+--      NOTE:   This only works for arcitectures with just RcInteger and RcDouble
+--              (which are disjoint) ie. x86, x86_64 and ppc
+--
+--      The number of allocatable regs is hard coded in here so we can do
+--              a fast comparison in trivColorable.
+--
+--      It's ok if these numbers are _less_ than the actual number of free
+--              regs, but they can't be more or the register conflict
+--              graph won't color.
+--
+--      If the graph doesn't color then the allocator will panic, but it won't
+--              generate bad object code or anything nasty like that.
+--
+--      There is an allocatableRegsInClass :: RegClass -> Int, but doing
+--      the unboxing is too slow for us here.
+--      TODO: Is that still true? Could we use allocatableRegsInClass
+--      without losing performance now?
+--
+--      Look at includes/stg/MachRegs.h to get the numbers.
+--
+
+
+-- Disjoint registers ----------------------------------------------------------
+--
+--      The definition has been unfolded into individual cases for speed.
+--      Each architecture has a different register setup, so we use a
+--      different regSqueeze function for each.
+--
+accSqueeze
+        :: Int
+        -> Int
+        -> (reg -> Int)
+        -> UniqSet reg
+        -> Int
+
+accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)
+  -- See Note [Unique Determinism and code generation]
+  where acc count [] = count
+        acc count _ | count >= maxCount = count
+        acc count (r:rs) = acc (count + squeeze r) rs
+
+{- Note [accSqueeze]
+~~~~~~~~~~~~~~~~~~~~
+BL 2007/09
+Doing a nice fold over the UniqSet makes trivColorable use
+32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs.
+Therefore the UniqFM is made non-abstract and we use custom fold.
+
+MS 2010/04
+When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal
+representation any more. But it is imperative that the accSqueeze stops
+the folding if the count gets greater or equal to maxCount. We thus convert
+UniqFM to a (lazy) list, do the fold and stops if necessary, which was
+the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows.
+(original = previous implementation, folding = fold of the whole UFM,
+ lazyFold = the current implementation,
+ hackFold = using internal representation of Data.IntMap)
+
+                                 original  folding   hackFold  lazyFold
+ -O -fasm (used everywhere)      31.509s   30.387s   30.791s   30.603s
+                                 100.00%   96.44%    97.72%    97.12%
+ -fregs-graph                    67.938s   74.875s   62.673s   64.679s
+                                 100.00%   110.21%   92.25%    95.20%
+ -fregs-iterative                89.761s   143.913s  81.075s   86.912s
+                                 100.00%   160.33%   90.32%    96.83%
+ -fnew-codegen                   38.225s   37.142s   37.551s   37.119s
+                                 100.00%   97.17%    98.24%    97.11%
+ -fnew-codegen -fregs-graph      91.786s   91.51s    87.368s   86.88s
+                                 100.00%   99.70%    95.19%    94.65%
+ -fnew-codegen -fregs-iterative  206.72s   343.632s  194.694s  208.677s
+                                 100.00%   166.23%   94.18%    100.95%
+-}
+
+trivColorable
+        :: Platform
+        -> (RegClass -> VirtualReg -> Int)
+        -> (RegClass -> RealReg    -> Int)
+        -> Triv VirtualReg RegClass RealReg
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions
+        | let cALLOCATABLE_REGS_INTEGER
+                  =        (case platformArch platform of
+                            ArchX86       -> 3
+                            ArchX86_64    -> 5
+                            ArchPPC       -> 16
+                            ArchSPARC     -> 14
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 15
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER
+                                (virtualRegSqueeze RcInteger)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_INTEGER
+                                (realRegSqueeze   RcInteger)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_INTEGER
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions
+        | let cALLOCATABLE_REGS_FLOAT
+                  =        (case platformArch platform of
+                    -- On x86_64 and x86, Float and RcDouble
+                    -- use the same registers,
+                    -- so we only use RcDouble to represent the
+                    -- register allocation problem on those types.
+                            ArchX86       -> 0
+                            ArchX86_64    -> 0
+                            ArchPPC       -> 0
+                            ArchSPARC     -> 22
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 0
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT
+                                (virtualRegSqueeze RcFloat)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_FLOAT
+                                (realRegSqueeze   RcFloat)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_FLOAT
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions
+        | let cALLOCATABLE_REGS_DOUBLE
+                  =        (case platformArch platform of
+                            ArchX86       -> 8
+                            -- in x86 32bit mode sse2 there are only
+                            -- 8 XMM registers xmm0 ... xmm7
+                            ArchX86_64    -> 10
+                            -- in x86_64 there are 16 XMM registers
+                            -- xmm0 .. xmm15, here 10 is a
+                            -- "dont need to solve conflicts" count that
+                            -- was chosen at some point in the past.
+                            ArchPPC       -> 26
+                            ArchSPARC     -> 11
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 20
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE
+                                (virtualRegSqueeze RcDouble)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_DOUBLE
+                                (realRegSqueeze   RcDouble)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_DOUBLE
+
+
+
+
+-- Specification Code ----------------------------------------------------------
+--
+--      The trivColorable function for each particular architecture should
+--      implement the following function, but faster.
+--
+
+{-
+trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
+trivColorable classN conflicts exclusions
+ = let
+
+        acc :: Reg -> (Int, Int) -> (Int, Int)
+        acc r (cd, cf)
+         = case regClass r of
+                RcInteger       -> (cd+1, cf)
+                RcFloat         -> (cd,   cf+1)
+                _               -> panic "Regs.trivColorable: reg class not handled"
+
+        tmp                     = nonDetFoldUFM acc (0, 0) conflicts
+        (countInt,  countFloat) = nonDetFoldUFM acc tmp    exclusions
+
+        squeese         = worst countInt   classN RcInteger
+                        + worst countFloat classN RcFloat
+
+   in   squeese < allocatableRegsInClass classN
+
+-- | Worst case displacement
+--      node N of classN has n neighbors of class C.
+--
+--      We currently only have RcInteger and RcDouble, which don't conflict at all.
+--      This is a bit boring compared to what's in RegArchX86.
+--
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+        RcInteger
+         -> case classC of
+                RcInteger       -> min n (allocatableRegsInClass RcInteger)
+                RcFloat         -> 0
+
+        RcDouble
+         -> case classC of
+                RcFloat         -> min n (allocatableRegsInClass RcFloat)
+                RcInteger       -> 0
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: [RegNo]
+allocatableRegs
+   = let isFree i = freeReg i
+     in  filter isFree allMachRegNos
+
+
+-- | The number of regs in each class.
+--      We go via top level CAFs to ensure that we're not recomputing
+--      the length of these lists each time the fn is called.
+allocatableRegsInClass :: RegClass -> Int
+allocatableRegsInClass cls
+ = case cls of
+        RcInteger       -> allocatableRegsInteger
+        RcFloat         -> allocatableRegsDouble
+
+allocatableRegsInteger :: Int
+allocatableRegsInteger
+        = length $ filter (\r -> regClass r == RcInteger)
+                 $ map RealReg allocatableRegs
+
+allocatableRegsFloat :: Int
+allocatableRegsFloat
+        = length $ filter (\r -> regClass r == RcFloat
+                 $ map RealReg allocatableRegs
+-}
diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs
@@ -0,0 +1,141 @@
+
+-- | Put common type definitions here to break recursive module dependencies.
+
+module RegAlloc.Linear.Base (
+        BlockAssignment,
+
+        Loc(..),
+        regsOfLoc,
+
+        -- for stats
+        SpillReason(..),
+        RegAllocStats(..),
+
+        -- the allocator monad
+        RA_State(..),
+)
+
+where
+
+import GhcPrelude
+
+import RegAlloc.Linear.StackMap
+import RegAlloc.Liveness
+import Reg
+
+import DynFlags
+import Outputable
+import Unique
+import UniqFM
+import UniqSupply
+import BlockId
+
+
+-- | Used to store the register assignment on entry to a basic block.
+--      We use this to handle join points, where multiple branch instructions
+--      target a particular label. We have to insert fixup code to make
+--      the register assignments from the different sources match up.
+--
+type BlockAssignment freeRegs
+        = BlockMap (freeRegs, RegMap Loc)
+
+
+-- | Where a vreg is currently stored
+--      A temporary can be marked as living in both a register and memory
+--      (InBoth), for example if it was recently loaded from a spill location.
+--      This makes it cheap to spill (no save instruction required), but we
+--      have to be careful to turn this into InReg if the value in the
+--      register is changed.
+
+--      This is also useful when a temporary is about to be clobbered.  We
+--      save it in a spill location, but mark it as InBoth because the current
+--      instruction might still want to read it.
+--
+data Loc
+        -- | vreg is in a register
+        = InReg   !RealReg
+
+        -- | vreg is held in a stack slot
+        | InMem   {-# UNPACK #-}  !StackSlot
+
+
+        -- | vreg is held in both a register and a stack slot
+        | InBoth   !RealReg
+                   {-# UNPACK #-} !StackSlot
+        deriving (Eq, Show, Ord)
+
+instance Outputable Loc where
+        ppr l = text (show l)
+
+
+-- | Get the reg numbers stored in this Loc.
+regsOfLoc :: Loc -> [RealReg]
+regsOfLoc (InReg r)    = [r]
+regsOfLoc (InBoth r _) = [r]
+regsOfLoc (InMem _)    = []
+
+
+-- | Reasons why instructions might be inserted by the spiller.
+--      Used when generating stats for -ddrop-asm-stats.
+--
+data SpillReason
+        -- | vreg was spilled to a slot so we could use its
+        --      current hreg for another vreg
+        = SpillAlloc    !Unique
+
+        -- | vreg was moved because its hreg was clobbered
+        | SpillClobber  !Unique
+
+        -- | vreg was loaded from a spill slot
+        | SpillLoad     !Unique
+
+        -- | reg-reg move inserted during join to targets
+        | SpillJoinRR   !Unique
+
+        -- | reg-mem move inserted during join to targets
+        | SpillJoinRM   !Unique
+
+
+-- | Used to carry interesting stats out of the register allocator.
+data RegAllocStats
+        = RegAllocStats
+        { ra_spillInstrs        :: UniqFM [Int]
+        , ra_fixupList     :: [(BlockId,BlockId,BlockId)]
+        -- ^ (from,fixup,to) : We inserted fixup code between from and to
+        }
+
+
+-- | The register allocator state
+data RA_State freeRegs
+        = RA_State
+
+        {
+        -- | the current mapping from basic blocks to
+        --      the register assignments at the beginning of that block.
+          ra_blockassig :: BlockAssignment freeRegs
+
+        -- | free machine registers
+        , ra_freeregs   :: !freeRegs
+
+        -- | assignment of temps to locations
+        , ra_assig      :: RegMap Loc
+
+        -- | current stack delta
+        , ra_delta      :: Int
+
+        -- | free stack slots for spilling
+        , ra_stack      :: StackMap
+
+        -- | unique supply for generating names for join point fixup blocks.
+        , ra_us         :: UniqSupply
+
+        -- | Record why things were spilled, for -ddrop-asm-stats.
+        --      Just keep a list here instead of a map of regs -> reasons.
+        --      We don't want to slow down the allocator if we're not going to emit the stats.
+        , ra_spills     :: [SpillReason]
+        , ra_DynFlags   :: DynFlags
+
+        -- | (from,fixup,to) : We inserted fixup code between from and to
+        , ra_fixups     :: [(BlockId,BlockId,BlockId)] }
+
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE CPP #-}
+
+module RegAlloc.Linear.FreeRegs (
+    FR(..),
+    maxSpillSlots
+)
+
+#include "HsVersions.h"
+
+where
+
+import GhcPrelude
+
+import Reg
+import RegClass
+
+import DynFlags
+import Panic
+import Platform
+
+-- -----------------------------------------------------------------------------
+-- The free register set
+-- This needs to be *efficient*
+-- Here's an inefficient 'executable specification' of the FreeRegs data type:
+--
+--      type FreeRegs = [RegNo]
+--      noFreeRegs = 0
+--      releaseReg n f = if n `elem` f then f else (n : f)
+--      initFreeRegs = allocatableRegs
+--      getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
+--      allocateReg f r = filter (/= r) f
+
+import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs    as X86
+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
+
+import qualified PPC.Instr
+import qualified SPARC.Instr
+import qualified X86.Instr
+
+class Show freeRegs => FR freeRegs where
+    frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs
+    frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg]
+    frInitFreeRegs :: Platform -> freeRegs
+    frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs
+
+instance FR X86.FreeRegs where
+    frAllocateReg  = \_ -> X86.allocateReg
+    frGetFreeRegs  = X86.getFreeRegs
+    frInitFreeRegs = X86.initFreeRegs
+    frReleaseReg   = \_ -> X86.releaseReg
+
+instance FR X86_64.FreeRegs where
+    frAllocateReg  = \_ -> X86_64.allocateReg
+    frGetFreeRegs  = X86_64.getFreeRegs
+    frInitFreeRegs = X86_64.initFreeRegs
+    frReleaseReg   = \_ -> X86_64.releaseReg
+
+instance FR PPC.FreeRegs where
+    frAllocateReg  = \_ -> PPC.allocateReg
+    frGetFreeRegs  = \_ -> PPC.getFreeRegs
+    frInitFreeRegs = PPC.initFreeRegs
+    frReleaseReg   = \_ -> PPC.releaseReg
+
+instance FR SPARC.FreeRegs where
+    frAllocateReg  = SPARC.allocateReg
+    frGetFreeRegs  = \_ -> SPARC.getFreeRegs
+    frInitFreeRegs = SPARC.initFreeRegs
+    frReleaseReg   = SPARC.releaseReg
+
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+              = case platformArch (targetPlatform dflags) of
+                ArchX86       -> X86.Instr.maxSpillSlots dflags
+                ArchX86_64    -> X86.Instr.maxSpillSlots dflags
+                ArchPPC       -> PPC.Instr.maxSpillSlots dflags
+                ArchSPARC     -> SPARC.Instr.maxSpillSlots dflags
+                ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"
+                ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"
+                ArchARM64     -> panic "maxSpillSlots ArchARM64"
+                ArchPPC_64 _  -> PPC.Instr.maxSpillSlots dflags
+                ArchAlpha     -> panic "maxSpillSlots ArchAlpha"
+                ArchMipseb    -> panic "maxSpillSlots ArchMipseb"
+                ArchMipsel    -> panic "maxSpillSlots ArchMipsel"
+                ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"
+                ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -0,0 +1,377 @@
+
+-- | Handles joining of a jump instruction to its targets.
+
+--      The first time we encounter a jump to a particular basic block, we
+--      record the assignment of temporaries.  The next time we encounter a
+--      jump to the same block, we compare our current assignment to the
+--      stored one.  They might be different if spilling has occurred in one
+--      branch; so some fixup code will be required to match up the assignments.
+--
+module RegAlloc.Linear.JoinToTargets (joinToTargets) where
+
+import GhcPrelude
+
+import RegAlloc.Linear.State
+import RegAlloc.Linear.Base
+import RegAlloc.Linear.FreeRegs
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import BlockId
+import Hoopl.Collections
+import Digraph
+import DynFlags
+import Outputable
+import Unique
+import UniqFM
+import UniqSet
+
+-- | For a jump instruction at the end of a block, generate fixup code so its
+--      vregs are in the correct regs for its destination.
+--
+joinToTargets
+        :: (FR freeRegs, Instruction instr, Outputable instr)
+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
+                                        --      that are known to be live on the entry to each block.
+
+        -> BlockId                      -- ^ id of the current block
+        -> instr                        -- ^ branch instr on the end of the source block.
+
+        -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
+                         , instr)               -- the original branch
+                                                -- instruction, but maybe
+                                                -- patched to jump
+                                                -- to a fixup block first.
+
+joinToTargets block_live id instr
+
+        -- we only need to worry about jump instructions.
+        | not $ isJumpishInstr instr
+        = return ([], instr)
+
+        | otherwise
+        = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)
+
+-----
+joinToTargets'
+        :: (FR freeRegs, Instruction instr, Outputable instr)
+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
+                                        --      that are known to be live on the entry to each block.
+
+        -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.
+
+        -> BlockId                      -- ^ id of the current block
+        -> instr                        -- ^ branch instr on the end of the source block.
+
+        -> [BlockId]                    -- ^ branch destinations still to consider.
+
+        -> RegM freeRegs ([NatBasicBlock instr], instr)
+
+-- no more targets to consider. all done.
+joinToTargets' _          new_blocks _ instr []
+        = return (new_blocks, instr)
+
+-- handle a branch target.
+joinToTargets' block_live new_blocks block_id instr (dest:dests)
+ = do
+        -- get the map of where the vregs are stored on entry to each basic block.
+        block_assig     <- getBlockAssigR
+
+        -- get the assignment on entry to the branch instruction.
+        assig           <- getAssigR
+
+        -- adjust the current assignment to remove any vregs that are not live
+        -- on entry to the destination block.
+        let Just live_set       = mapLookup dest block_live
+        let still_live uniq _   = uniq `elemUniqSet_Directly` live_set
+        let adjusted_assig      = filterUFM_Directly still_live assig
+
+        -- and free up those registers which are now free.
+        let to_free =
+                [ r     | (reg, loc) <- nonDetUFMToList assig
+                        -- This is non-deterministic but we do not
+                        -- currently support deterministic code-generation.
+                        -- See Note [Unique Determinism and code generation]
+                        , not (elemUniqSet_Directly reg live_set)
+                        , r          <- regsOfLoc loc ]
+
+        case mapLookup dest block_assig of
+         Nothing
+          -> joinToTargets_first
+                        block_live new_blocks block_id instr dest dests
+                        block_assig adjusted_assig to_free
+
+         Just (_, dest_assig)
+          -> joinToTargets_again
+                        block_live new_blocks block_id instr dest dests
+                        adjusted_assig dest_assig
+
+
+-- this is the first time we jumped to this block.
+joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)
+                    => BlockMap RegSet
+                    -> [NatBasicBlock instr]
+                    -> BlockId
+                    -> instr
+                    -> BlockId
+                    -> [BlockId]
+                    -> BlockAssignment freeRegs
+                    -> RegMap Loc
+                    -> [RealReg]
+                    -> RegM freeRegs ([NatBasicBlock instr], instr)
+joinToTargets_first block_live new_blocks block_id instr dest dests
+        block_assig src_assig
+        to_free
+
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+
+        -- free up the regs that are not live on entry to this block.
+        freeregs        <- getFreeRegsR
+        let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free
+
+        -- remember the current assignment on entry to this block.
+        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
+
+        joinToTargets' block_live new_blocks block_id instr dests
+
+
+-- we've jumped to this block before
+joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)
+                    => BlockMap RegSet
+                    -> [NatBasicBlock instr]
+                    -> BlockId
+                    -> instr
+                    -> BlockId
+                    -> [BlockId]
+                    -> UniqFM Loc
+                    -> UniqFM Loc
+                    -> RegM freeRegs ([NatBasicBlock instr], instr)
+joinToTargets_again
+    block_live new_blocks block_id instr dest dests
+    src_assig dest_assig
+
+        -- the assignments already match, no problem.
+        | nonDetUFMToList dest_assig == nonDetUFMToList src_assig
+        -- This is non-deterministic but we do not
+        -- currently support deterministic code-generation.
+        -- See Note [Unique Determinism and code generation]
+        = joinToTargets' block_live new_blocks block_id instr dests
+
+        -- assignments don't match, need fixup code
+        | otherwise
+        = do
+
+                -- make a graph of what things need to be moved where.
+                let graph = makeRegMovementGraph src_assig dest_assig
+
+                -- look for cycles in the graph. This can happen if regs need to be swapped.
+                -- Note that we depend on the fact that this function does a
+                --      bottom up traversal of the tree-like portions of the graph.
+                --
+                --  eg, if we have
+                --      R1 -> R2 -> R3
+                --
+                --  ie move value in R1 to R2 and value in R2 to R3.
+                --
+                -- We need to do the R2 -> R3 move before R1 -> R2.
+                --
+                let sccs  = stronglyConnCompFromEdgedVerticesOrdR graph
+
+              -- debugging
+                {-
+                pprTrace
+                        ("joinToTargets: making fixup code")
+                        (vcat   [ text "        in block: "     <> ppr block_id
+                                , text " jmp instruction: "     <> ppr instr
+                                , text "  src assignment: "     <> ppr src_assig
+                                , text " dest assignment: "     <> ppr dest_assig
+                                , text "  movement graph: "     <> ppr graph
+                                , text "   sccs of graph: "     <> ppr sccs
+                                , text ""])
+                        (return ())
+                -}
+                delta           <- getDeltaR
+                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs
+                let fixUpInstrs = concat fixUpInstrs_
+
+                -- make a new basic block containing the fixup code.
+                --      A the end of the current block we will jump to the fixup one,
+                --      then that will jump to our original destination.
+                fixup_block_id <- mkBlockId <$> getUniqueR
+                let block = BasicBlock fixup_block_id
+                                $ fixUpInstrs ++ mkJumpInstr dest
+
+                -- if we didn't need any fixups, then don't include the block
+                case fixUpInstrs of
+                 []     -> joinToTargets' block_live new_blocks block_id instr dests
+
+                 -- patch the original branch instruction so it goes to our
+                 --     fixup block instead.
+                 _      -> let  instr'  =  patchJumpInstr instr
+                                            (\bid -> if bid == dest
+                                                        then fixup_block_id
+                                                        else bid) -- no change!
+
+                           in do
+                                {- --debugging
+                                pprTrace "FixUpEdge info:"
+                                    (
+                                    text "inBlock:" <> ppr block_id $$
+                                    text "instr:" <> ppr instr $$
+                                    text "instr':" <> ppr instr' $$
+                                    text "fixup_block_id':" <>
+                                        ppr fixup_block_id $$
+                                    text "dest:" <> ppr dest
+                                    ) (return ())
+                                -}
+                                recordFixupBlock block_id fixup_block_id dest
+                                joinToTargets' block_live (block : new_blocks)
+                                               block_id instr' dests
+
+
+-- | Construct a graph of register\/spill movements.
+--
+--      Cyclic components seem to occur only very rarely.
+--
+--      We cut some corners by not handling memory-to-memory moves.
+--      This shouldn't happen because every temporary gets its own stack slot.
+--
+makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
+makeRegMovementGraph adjusted_assig dest_assig
+ = [ node       | (vreg, src) <- nonDetUFMToList adjusted_assig
+                    -- This is non-deterministic but we do not
+                    -- currently support deterministic code-generation.
+                    -- See Note [Unique Determinism and code generation]
+                    -- source reg might not be needed at the dest:
+                , Just loc <- [lookupUFM_Directly dest_assig vreg]
+                , node <- expandNode vreg src loc ]
+
+
+-- | Expand out the destination, so InBoth destinations turn into
+--      a combination of InReg and InMem.
+
+--      The InBoth handling is a little tricky here.  If the destination is
+--      InBoth, then we must ensure that the value ends up in both locations.
+--      An InBoth  destination must conflict with an InReg or InMem source, so
+--      we expand an InBoth destination as necessary.
+--
+--      An InBoth source is slightly different: we only care about the register
+--      that the source value is in, so that we can move it to the destinations.
+--
+expandNode
+        :: a
+        -> Loc                  -- ^ source of move
+        -> Loc                  -- ^ destination of move
+        -> [Node Loc a ]
+
+expandNode vreg loc@(InReg src) (InBoth dst mem)
+        | src == dst = [DigraphNode vreg loc [InMem mem]]
+        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]
+
+expandNode vreg loc@(InMem src) (InBoth dst mem)
+        | src == mem = [DigraphNode vreg loc [InReg dst]]
+        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]
+
+expandNode _        (InBoth _ src) (InMem dst)
+        | src == dst = [] -- guaranteed to be true
+
+expandNode _        (InBoth src _) (InReg dst)
+        | src == dst = []
+
+expandNode vreg     (InBoth src _) dst
+        = expandNode vreg (InReg src) dst
+
+expandNode vreg src dst
+        | src == dst = []
+        | otherwise  = [DigraphNode vreg src [dst]]
+
+
+-- | Generate fixup code for a particular component in the move graph
+--      This component tells us what values need to be moved to what
+--      destinations. We have eliminated any possibility of single-node
+--      cycles in expandNode above.
+--
+handleComponent
+        :: Instruction instr
+        => Int -> instr -> SCC (Node Loc Unique)
+        -> RegM freeRegs [instr]
+
+-- If the graph is acyclic then we won't get the swapping problem below.
+--      In this case we can just do the moves directly, and avoid having to
+--      go via a spill slot.
+--
+handleComponent delta _  (AcyclicSCC (DigraphNode vreg src dsts))
+        = mapM (makeMove delta vreg src) dsts
+
+
+-- Handle some cyclic moves.
+--      This can happen if we have two regs that need to be swapped.
+--      eg:
+--           vreg   source loc   dest loc
+--          (vreg1, InReg r1,    [InReg r2])
+--          (vreg2, InReg r2,    [InReg r1])
+--
+--      To avoid needing temp register, we just spill all the source regs, then
+--      reaload them into their destination regs.
+--
+--      Note that we can not have cycles that involve memory locations as
+--      sources as single destination because memory locations (stack slots)
+--      are allocated exclusively for a virtual register and therefore can not
+--      require a fixup.
+--
+handleComponent delta instr
+        (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))
+        -- dest list may have more than one element, if the reg is also InMem.
+ = do
+        -- spill the source into its slot
+        (instrSpill, slot)
+                        <- spillR (RegReal sreg) vreg
+
+        -- reload into destination reg
+        instrLoad       <- loadR (RegReal dreg) slot
+
+        remainingFixUps <- mapM (handleComponent delta instr)
+                                (stronglyConnCompFromEdgedVerticesOrdR rest)
+
+        -- make sure to do all the reloads after all the spills,
+        --      so we don't end up clobbering the source values.
+        return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad])
+
+handleComponent _ _ (CyclicSCC _)
+ = panic "Register Allocator: handleComponent cyclic"
+
+
+-- | Move a vreg between these two locations.
+--
+makeMove
+    :: Instruction instr
+    => Int      -- ^ current C stack delta.
+    -> Unique   -- ^ unique of the vreg that we're moving.
+    -> Loc      -- ^ source location.
+    -> Loc      -- ^ destination location.
+    -> RegM freeRegs instr  -- ^ move instruction.
+
+makeMove delta vreg src dst
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+
+      case (src, dst) of
+          (InReg s, InReg d) ->
+              do recordSpill (SpillJoinRR vreg)
+                 return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)
+          (InMem s, InReg d) ->
+              do recordSpill (SpillJoinRM vreg)
+                 return $ mkLoadInstr dflags (RegReal d) delta s
+          (InReg s, InMem d) ->
+              do recordSpill (SpillJoinRM vreg)
+                 return $ mkSpillInstr dflags (RegReal s) delta d
+          _ ->
+              -- we don't handle memory to memory moves.
+              -- they shouldn't happen because we don't share
+              -- stack slots between vregs.
+              panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
+                  ++ show dst ++ ")"
+                  ++ " we don't handle mem->mem moves.")
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -0,0 +1,917 @@
+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
+
+-----------------------------------------------------------------------------
+--
+-- The register allocator
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+{-
+The algorithm is roughly:
+
+  1) Compute strongly connected components of the basic block list.
+
+  2) Compute liveness (mapping from pseudo register to
+     point(s) of death?).
+
+  3) Walk instructions in each basic block.  We keep track of
+        (a) Free real registers (a bitmap?)
+        (b) Current assignment of temporaries to machine registers and/or
+            spill slots (call this the "assignment").
+        (c) Partial mapping from basic block ids to a virt-to-loc mapping.
+            When we first encounter a branch to a basic block,
+            we fill in its entry in this table with the current mapping.
+
+     For each instruction:
+        (a) For each temporary *read* by the instruction:
+            If the temporary does not have a real register allocation:
+                - Allocate a real register from the free list.  If
+                  the list is empty:
+                  - Find a temporary to spill.  Pick one that is
+                    not used in this instruction (ToDo: not
+                    used for a while...)
+                  - generate a spill instruction
+                - If the temporary was previously spilled,
+                  generate an instruction to read the temp from its spill loc.
+            (optimisation: if we can see that a real register is going to
+            be used soon, then don't use it for allocation).
+
+        (b) For each real register clobbered by this instruction:
+            If a temporary resides in it,
+                If the temporary is live after this instruction,
+                    Move the temporary to another (non-clobbered & free) reg,
+                    or spill it to memory.  Mark the temporary as residing
+                    in both memory and a register if it was spilled (it might
+                    need to be read by this instruction).
+
+            (ToDo: this is wrong for jump instructions?)
+
+            We do this after step (a), because if we start with
+               movq v1, %rsi
+            which is an instruction that clobbers %rsi, if v1 currently resides
+            in %rsi we want to get
+               movq %rsi, %freereg
+               movq %rsi, %rsi     -- will disappear
+            instead of
+               movq %rsi, %freereg
+               movq %freereg, %rsi
+
+        (c) Update the current assignment
+
+        (d) If the instruction is a branch:
+              if the destination block already has a register assignment,
+                Generate a new block with fixup code and redirect the
+                jump to the new block.
+              else,
+                Update the block id->assignment mapping with the current
+                assignment.
+
+        (e) Delete all register assignments for temps which are read
+            (only) and die here.  Update the free register list.
+
+        (f) Mark all registers clobbered by this instruction as not free,
+            and mark temporaries which have been spilled due to clobbering
+            as in memory (step (a) marks then as in both mem & reg).
+
+        (g) For each temporary *written* by this instruction:
+            Allocate a real register as for (b), spilling something
+            else if necessary.
+                - except when updating the assignment, drop any memory
+                  locations that the temporary was previously in, since
+                  they will be no longer valid after this instruction.
+
+        (h) Delete all register assignments for temps which are
+            written and die here (there should rarely be any).  Update
+            the free register list.
+
+        (i) Rewrite the instruction with the new mapping.
+
+        (j) For each spilled reg known to be now dead, re-add its stack slot
+            to the free list.
+
+-}
+
+module RegAlloc.Linear.Main (
+        regAlloc,
+        module  RegAlloc.Linear.Base,
+        module  RegAlloc.Linear.Stats
+  ) where
+
+#include "HsVersions.h"
+
+
+import GhcPrelude
+
+import RegAlloc.Linear.State
+import RegAlloc.Linear.Base
+import RegAlloc.Linear.StackMap
+import RegAlloc.Linear.FreeRegs
+import RegAlloc.Linear.Stats
+import RegAlloc.Linear.JoinToTargets
+import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs    as X86
+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
+import TargetReg
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import BlockId
+import Hoopl.Collections
+import Cmm hiding (RegSet)
+
+import Digraph
+import DynFlags
+import Unique
+import UniqSet
+import UniqFM
+import UniqSupply
+import Outputable
+import Platform
+
+import Data.Maybe
+import Data.List
+import Control.Monad
+
+-- -----------------------------------------------------------------------------
+-- Top level of the register allocator
+
+-- Allocate registers
+regAlloc
+        :: (Outputable instr, Instruction instr)
+        => DynFlags
+        -> LiveCmmDecl statics instr
+        -> UniqSM ( NatCmmDecl statics instr
+                  , Maybe Int  -- number of extra stack slots required,
+                               -- beyond maxSpillSlots
+                  , Maybe RegAllocStats
+                  )
+
+regAlloc _ (CmmData sec d)
+        = return
+                ( CmmData sec d
+                , Nothing
+                , Nothing )
+
+regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
+        = return ( CmmProc info lbl live (ListGraph [])
+                 , Nothing
+                 , Nothing )
+
+regAlloc dflags (CmmProc static lbl live sccs)
+        | LiveInfo info entry_ids@(first_id:_) block_live _ <- static
+        = do
+                -- do register allocation on each component.
+                (final_blocks, stats, stack_use)
+                        <- linearRegAlloc dflags entry_ids block_live sccs
+
+                -- make sure the block that was first in the input list
+                --      stays at the front of the output
+                let ((first':_), rest')
+                                = partition ((== first_id) . blockId) final_blocks
+
+                let max_spill_slots = maxSpillSlots dflags
+                    extra_stack
+                      | stack_use > max_spill_slots
+                      = Just (stack_use - max_spill_slots)
+                      | otherwise
+                      = Nothing
+
+                return  ( CmmProc info lbl live (ListGraph (first' : rest'))
+                        , extra_stack
+                        , Just stats)
+
+-- bogus. to make non-exhaustive match warning go away.
+regAlloc _ (CmmProc _ _ _ _)
+        = panic "RegAllocLinear.regAlloc: no match"
+
+
+-- -----------------------------------------------------------------------------
+-- Linear sweep to allocate registers
+
+
+-- | Do register allocation on some basic blocks.
+--   But be careful to allocate a block in an SCC only if it has
+--   an entry in the block map or it is the first block.
+--
+linearRegAlloc
+        :: (Outputable instr, Instruction instr)
+        => DynFlags
+        -> [BlockId] -- ^ entry points
+        -> BlockMap RegSet
+              -- ^ live regs on entry to each basic block
+        -> [SCC (LiveBasicBlock instr)]
+              -- ^ instructions annotated with "deaths"
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
+
+linearRegAlloc dflags entry_ids block_live sccs
+ = case platformArch platform of
+      ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
+      ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
+      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)
+      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"
+      ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
+      ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"
+      ArchARM64      -> panic "linearRegAlloc ArchARM64"
+      ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
+      ArchAlpha      -> panic "linearRegAlloc ArchAlpha"
+      ArchMipseb     -> panic "linearRegAlloc ArchMipseb"
+      ArchMipsel     -> panic "linearRegAlloc ArchMipsel"
+      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
+      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
+ where
+  go f = linearRegAlloc' dflags f entry_ids block_live sccs
+  platform = targetPlatform dflags
+
+linearRegAlloc'
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => DynFlags
+        -> freeRegs
+        -> [BlockId]                    -- ^ entry points
+        -> BlockMap RegSet              -- ^ live regs on entry to each basic block
+        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
+
+linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs
+ = do   us      <- getUniqueSupplyM
+        let (_, stack, stats, blocks) =
+                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us
+                    $ linearRA_SCCs entry_ids block_live [] sccs
+        return  (blocks, stats, getStackUse stack)
+
+
+linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
+              => [BlockId]
+              -> BlockMap RegSet
+              -> [NatBasicBlock instr]
+              -> [SCC (LiveBasicBlock instr)]
+              -> RegM freeRegs [NatBasicBlock instr]
+
+linearRA_SCCs _ _ blocksAcc []
+        = return $ reverse blocksAcc
+
+linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
+ = do   blocks' <- processBlock block_live block
+        linearRA_SCCs entry_ids block_live
+                ((reverse blocks') ++ blocksAcc)
+                sccs
+
+linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
+ = do
+        blockss' <- process entry_ids block_live blocks [] (return []) False
+        linearRA_SCCs entry_ids block_live
+                (reverse (concat blockss') ++ blocksAcc)
+                sccs
+
+{- from John Dias's patch 2008/10/16:
+   The linear-scan allocator sometimes allocates a block
+   before allocating one of its predecessors, which could lead to
+   inconsistent allocations. Make it so a block is only allocated
+   if a predecessor has set the "incoming" assignments for the block, or
+   if it's the procedure's entry block.
+
+   BL 2009/02: Careful. If the assignment for a block doesn't get set for
+   some reason then this function will loop. We should probably do some
+   more sanity checking to guard against this eventuality.
+-}
+
+process :: (FR freeRegs, Instruction instr, Outputable instr)
+        => [BlockId]
+        -> BlockMap RegSet
+        -> [GenBasicBlock (LiveInstr instr)]
+        -> [GenBasicBlock (LiveInstr instr)]
+        -> [[NatBasicBlock instr]]
+        -> Bool
+        -> RegM freeRegs [[NatBasicBlock instr]]
+
+process _ _ [] []         accum _
+        = return $ reverse accum
+
+process entry_ids block_live [] next_round accum madeProgress
+        | not madeProgress
+
+          {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
+             pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
+                (  text "Unreachable blocks:"
+                $$ vcat (map ppr next_round)) -}
+        = return $ reverse accum
+
+        | otherwise
+        = process entry_ids block_live
+                  next_round [] accum False
+
+process entry_ids block_live (b@(BasicBlock id _) : blocks)
+        next_round accum madeProgress
+ = do
+        block_assig <- getBlockAssigR
+
+        if isJust (mapLookup id block_assig)
+             || id `elem` entry_ids
+         then do
+                b'  <- processBlock block_live b
+                process entry_ids block_live blocks
+                        next_round (b' : accum) True
+
+         else   process entry_ids block_live blocks
+                        (b : next_round) accum madeProgress
+
+
+-- | Do register allocation on this basic block
+--
+processBlock
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => BlockMap RegSet              -- ^ live regs on entry to each basic block
+        -> LiveBasicBlock instr         -- ^ block to do register allocation on
+        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated
+
+processBlock block_live (BasicBlock id instrs)
+ = do   initBlock id block_live
+        (instrs', fixups)
+                <- linearRA block_live [] [] id instrs
+        return  $ BasicBlock id instrs' : fixups
+
+
+-- | Load the freeregs and current reg assignment into the RegM state
+--      for the basic block with this BlockId.
+initBlock :: FR freeRegs
+          => BlockId -> BlockMap RegSet -> RegM freeRegs ()
+initBlock id block_live
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+        block_assig     <- getBlockAssigR
+        case mapLookup id block_assig of
+                -- no prior info about this block: we must consider
+                -- any fixed regs to be allocated, but we can ignore
+                -- virtual regs (presumably this is part of a loop,
+                -- and we'll iterate again).  The assignment begins
+                -- empty.
+                Nothing
+                 -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
+                        case mapLookup id block_live of
+                          Nothing ->
+                            setFreeRegsR    (frInitFreeRegs platform)
+                          Just live ->
+                            setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
+                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]
+                            -- See Note [Unique Determinism and code generation]
+                        setAssigR       emptyRegMap
+
+                -- load info about register assignments leading into this block.
+                Just (freeregs, assig)
+                 -> do  setFreeRegsR    freeregs
+                        setAssigR       assig
+
+
+-- | Do allocation for a sequence of instructions.
+linearRA
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
+        -> [instr]                              -- ^ accumulator for instructions already processed.
+        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
+        -> BlockId                              -- ^ id of the current block, for debugging.
+        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
+
+        -> RegM freeRegs
+                ( [instr]                       --   instructions after register allocation
+                , [NatBasicBlock instr])        --   fresh blocks of fixup code.
+
+
+linearRA _          accInstr accFixup _ []
+        = return
+                ( reverse accInstr              -- instrs need to be returned in the correct order.
+                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.
+
+
+linearRA block_live accInstr accFixups id (instr:instrs)
+ = do
+        (accInstr', new_fixups) <- raInsn block_live accInstr id instr
+
+        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
+
+
+-- | Do allocation for a single instruction.
+raInsn
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
+        -> [instr]                              -- ^ accumulator for instructions already processed.
+        -> BlockId                              -- ^ the id of the current block, for debugging
+        -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
+        -> RegM freeRegs
+                ( [instr]                       -- new instructions
+                , [NatBasicBlock instr])        -- extra fixup blocks
+
+raInsn _     new_instrs _ (LiveInstr ii Nothing)
+        | Just n        <- takeDeltaInstr ii
+        = do    setDeltaR n
+                return (new_instrs, [])
+
+raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
+        | isMetaInstr ii
+        = return (i : new_instrs, [])
+
+
+raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
+ = do
+    assig    <- getAssigR
+
+    -- If we have a reg->reg move between virtual registers, where the
+    -- src register is not live after this instruction, and the dst
+    -- register does not already have an assignment,
+    -- and the source register is assigned to a register, not to a spill slot,
+    -- then we can eliminate the instruction.
+    -- (we can't eliminate it if the source register is on the stack, because
+    --  we do not want to use one spill slot for different virtual registers)
+    case takeRegRegMoveInstr instr of
+        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
+                          isVirtualReg dst,
+                          not (dst `elemUFM` assig),
+                          isRealReg src || isInReg src assig -> do
+           case src of
+              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
+                -- if src is a fixed reg, then we just map dest to this
+                -- reg in the assignment.  src must be an allocatable reg,
+                -- otherwise it wouldn't be in r_dying.
+              _virt -> case lookupUFM assig src of
+                         Nothing -> panic "raInsn"
+                         Just loc ->
+                           setAssigR (addToUFM (delFromUFM assig src) dst loc)
+
+           -- we have eliminated this instruction
+          {-
+          freeregs <- getFreeRegsR
+          assig <- getAssigR
+          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
+                        $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+          -}
+           return (new_instrs, [])
+
+        _ -> genRaInsn block_live new_instrs id instr
+                        (nonDetEltsUniqSet $ liveDieRead live)
+                        (nonDetEltsUniqSet $ liveDieWrite live)
+                        -- See Note [Unique Determinism and code generation]
+
+raInsn _ _ _ instr
+        = pprPanic "raInsn" (text "no match for:" <> ppr instr)
+
+-- ToDo: what can we do about
+--
+--     R1 = x
+--     jump I64[x] // [R1]
+--
+-- where x is mapped to the same reg as R1.  We want to coalesce x and
+-- R1, but the register allocator doesn't know whether x will be
+-- assigned to again later, in which case x and R1 should be in
+-- different registers.  Right now we assume the worst, and the
+-- assignment to R1 will clobber x, so we'll spill x into another reg,
+-- generating another reg->reg move.
+
+
+isInReg :: Reg -> RegMap Loc -> Bool
+isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
+                  | otherwise = False
+
+
+genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
+          => BlockMap RegSet
+          -> [instr]
+          -> BlockId
+          -> instr
+          -> [Reg]
+          -> [Reg]
+          -> RegM freeRegs ([instr], [NatBasicBlock instr])
+
+genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  case regUsageOfInstr platform instr of { RU read written ->
+    do
+    let real_written    = [ rr  | (RegReal     rr) <- written ]
+    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
+
+    -- we don't need to do anything with real registers that are
+    -- only read by this instr.  (the list is typically ~2 elements,
+    -- so using nub isn't a problem).
+    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]
+
+    -- debugging
+{-    freeregs <- getFreeRegsR
+    assig    <- getAssigR
+    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"
+        (ppr instr
+                $$ text "r_dying      = " <+> ppr r_dying
+                $$ text "w_dying      = " <+> ppr w_dying
+                $$ text "virt_read    = " <+> ppr virt_read
+                $$ text "virt_written = " <+> ppr virt_written
+                $$ text "freeregs     = " <+> text (show freeregs)
+                $$ text "assig        = " <+> ppr assig)
+        $ do
+-}
+
+    -- (a), (b) allocate real regs for all regs read by this instruction.
+    (r_spills, r_allocd) <-
+        allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
+
+    -- (c) save any temporaries which will be clobbered by this instruction
+    clobber_saves <- saveClobberedTemps real_written r_dying
+
+    -- (d) Update block map for new destinations
+    -- NB. do this before removing dead regs from the assignment, because
+    -- these dead regs might in fact be live in the jump targets (they're
+    -- only dead in the code that follows in the current basic block).
+    (fixup_blocks, adjusted_instr)
+        <- joinToTargets block_live block_id instr
+
+    -- Debugging - show places where the reg alloc inserted
+    -- assignment fixup blocks.
+    -- when (not $ null fixup_blocks) $
+    --    pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())
+
+    -- (e) Delete all register assignments for temps which are read
+    --     (only) and die here.  Update the free register list.
+    releaseRegs r_dying
+
+    -- (f) Mark regs which are clobbered as unallocatable
+    clobberRegs real_written
+
+    -- (g) Allocate registers for temporaries *written* (only)
+    (w_spills, w_allocd) <-
+        allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
+
+    -- (h) Release registers for temps which are written here and not
+    -- used again.
+    releaseRegs w_dying
+
+    let
+        -- (i) Patch the instruction
+        patch_map
+                = listToUFM
+                        [ (t, RegReal r)
+                                | (t, r) <- zip virt_read    r_allocd
+                                         ++ zip virt_written w_allocd ]
+
+        patched_instr
+                = patchRegsOfInstr adjusted_instr patchLookup
+
+        patchLookup x
+                = case lookupUFM patch_map x of
+                        Nothing -> x
+                        Just y  -> y
+
+
+    -- (j) free up stack slots for dead spilled regs
+    -- TODO (can't be bothered right now)
+
+    -- erase reg->reg moves where the source and destination are the same.
+    --  If the src temp didn't die in this instr but happened to be allocated
+    --  to the same real reg as the destination, then we can erase the move anyway.
+    let squashed_instr  = case takeRegRegMoveInstr patched_instr of
+                                Just (src, dst)
+                                 | src == dst   -> []
+                                _               -> [patched_instr]
+
+    let code = squashed_instr ++ w_spills ++ reverse r_spills
+                ++ clobber_saves ++ new_instrs
+
+--    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
+--    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
+
+    return (code, fixup_blocks)
+
+  }
+
+-- -----------------------------------------------------------------------------
+-- releaseRegs
+
+releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
+releaseRegs regs = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  assig <- getAssigR
+  free <- getFreeRegsR
+  let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
+      loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
+      loop assig !free (r:rs) =
+         case lookupUFM assig r of
+         Just (InBoth real _) -> loop (delFromUFM assig r)
+                                      (frReleaseReg platform real free) rs
+         Just (InReg real)    -> loop (delFromUFM assig r)
+                                      (frReleaseReg platform real free) rs
+         _                    -> loop (delFromUFM assig r) free rs
+  loop assig free regs
+
+
+-- -----------------------------------------------------------------------------
+-- Clobber real registers
+
+-- For each temp in a register that is going to be clobbered:
+--      - if the temp dies after this instruction, do nothing
+--      - otherwise, put it somewhere safe (another reg if possible,
+--              otherwise spill and record InBoth in the assignment).
+--      - for allocateRegs on the temps *read*,
+--      - clobbered regs are allocatable.
+--
+--      for allocateRegs on the temps *written*,
+--        - clobbered regs are not allocatable.
+--
+
+saveClobberedTemps
+        :: (Instruction instr, FR freeRegs)
+        => [RealReg]            -- real registers clobbered by this instruction
+        -> [Reg]                -- registers which are no longer live after this insn
+        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
+                                -- be clobbered.
+
+saveClobberedTemps [] _
+        = return []
+
+saveClobberedTemps clobbered dying
+ = do
+        assig   <- getAssigR
+        let to_spill
+                = [ (temp,reg)
+                        | (temp, InReg reg) <- nonDetUFMToList assig
+                        -- This is non-deterministic but we do not
+                        -- currently support deterministic code-generation.
+                        -- See Note [Unique Determinism and code generation]
+                        , any (realRegsAlias reg) clobbered
+                        , temp `notElem` map getUnique dying  ]
+
+        (instrs,assig') <- clobber assig [] to_spill
+        setAssigR assig'
+        return instrs
+
+   where
+     clobber assig instrs []
+            = return (instrs, assig)
+
+     clobber assig instrs ((temp, reg) : rest)
+       = do dflags <- getDynFlags
+            let platform = targetPlatform dflags
+
+            freeRegs <- getFreeRegsR
+            let regclass = targetClassOfRealReg platform reg
+                freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs
+
+            case filter (`notElem` clobbered) freeRegs_thisClass of
+
+              -- (1) we have a free reg of the right class that isn't
+              -- clobbered by this instruction; use it to save the
+              -- clobbered value.
+              (my_reg : _) -> do
+                  setFreeRegsR (frAllocateReg platform my_reg freeRegs)
+
+                  let new_assign = addToUFM assig temp (InReg my_reg)
+                  let instr = mkRegRegMoveInstr platform
+                                  (RegReal reg) (RegReal my_reg)
+
+                  clobber new_assign (instr : instrs) rest
+
+              -- (2) no free registers: spill the value
+              [] -> do
+                  (spill, slot)   <- spillR (RegReal reg) temp
+
+                  -- record why this reg was spilled for profiling
+                  recordSpill (SpillClobber temp)
+
+                  let new_assign  = addToUFM assig temp (InBoth reg slot)
+
+                  clobber new_assign (spill : instrs) rest
+
+
+
+-- | Mark all these real regs as allocated,
+--      and kick out their vreg assignments.
+--
+clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
+clobberRegs []
+        = return ()
+
+clobberRegs clobbered
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+
+        freeregs        <- getFreeRegsR
+        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered
+
+        assig           <- getAssigR
+        setAssigR $! clobber assig (nonDetUFMToList assig)
+          -- This is non-deterministic but we do not
+          -- currently support deterministic code-generation.
+          -- See Note [Unique Determinism and code generation]
+
+   where
+        -- if the temp was InReg and clobbered, then we will have
+        -- saved it in saveClobberedTemps above.  So the only case
+        -- we have to worry about here is InBoth.  Note that this
+        -- also catches temps which were loaded up during allocation
+        -- of read registers, not just those saved in saveClobberedTemps.
+
+        clobber assig []
+                = assig
+
+        clobber assig ((temp, InBoth reg slot) : rest)
+                | any (realRegsAlias reg) clobbered
+                = clobber (addToUFM assig temp (InMem slot)) rest
+
+        clobber assig (_:rest)
+                = clobber assig rest
+
+-- -----------------------------------------------------------------------------
+-- allocateRegsAndSpill
+
+-- Why are we performing a spill?
+data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
+              | WriteNew           -- writing to a new variable
+              | WriteMem           -- writing to register only in memory
+-- Note that ReadNew is not valid, since you don't want to be reading
+-- from an uninitialized register.  We also don't need the location of
+-- the register in memory, since that will be invalidated by the write.
+-- Technically, we could coalesce WriteNew and WriteMem into a single
+-- entry as well. -- EZY
+
+-- This function does several things:
+--   For each temporary referred to by this instruction,
+--   we allocate a real register (spilling another temporary if necessary).
+--   We load the temporary up from memory if necessary.
+--   We also update the register assignment in the process, and
+--   the list of free registers and free stack slots.
+
+allocateRegsAndSpill
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => Bool                 -- True <=> reading (load up spilled regs)
+        -> [VirtualReg]         -- don't push these out
+        -> [instr]              -- spill insns
+        -> [RealReg]            -- real registers allocated (accum.)
+        -> [VirtualReg]         -- temps to allocate
+        -> RegM freeRegs ( [instr] , [RealReg])
+
+allocateRegsAndSpill _       _    spills alloc []
+        = return (spills, reverse alloc)
+
+allocateRegsAndSpill reading keep spills alloc (r:rs)
+ = do   assig <- getAssigR
+        let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
+        case lookupUFM assig r of
+                -- case (1a): already in a register
+                Just (InReg my_reg) ->
+                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+                -- case (1b): already in a register (and memory)
+                -- NB1. if we're writing this register, update its assignment to be
+                -- InReg, because the memory value is no longer valid.
+                -- NB2. This is why we must process written registers here, even if they
+                -- are also read by the same instruction.
+                Just (InBoth my_reg _)
+                 -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
+                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+                -- Not already in a register, so we need to find a free one...
+                Just (InMem slot) | reading   -> doSpill (ReadMem slot)
+                                  | otherwise -> doSpill WriteMem
+                Nothing | reading   ->
+                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
+                   -- NOTE: if the input to the NCG contains some
+                   -- unreachable blocks with junk code, this panic
+                   -- might be triggered.  Make sure you only feed
+                   -- sensible code into the NCG.  In CmmPipeline we
+                   -- call removeUnreachableBlocks at the end for this
+                   -- reason.
+
+                        | otherwise -> doSpill WriteNew
+
+
+-- reading is redundant with reason, but we keep it around because it's
+-- convenient and it maintains the recursive structure of the allocator. -- EZY
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
+                        => Bool
+                        -> [VirtualReg]
+                        -> [instr]
+                        -> [RealReg]
+                        -> VirtualReg
+                        -> [VirtualReg]
+                        -> UniqFM Loc
+                        -> SpillLoc
+                        -> RegM freeRegs ([instr], [RealReg])
+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+        freeRegs                <- getFreeRegsR
+        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs
+
+        case freeRegs_thisClass of
+
+         -- case (2): we have a free register
+         (my_reg : _) ->
+           do   spills'   <- loadTemp r spill_loc my_reg spills
+
+                setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)
+                setFreeRegsR $  frAllocateReg platform my_reg freeRegs
+
+                allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
+
+
+          -- case (3): we need to push something out to free up a register
+         [] ->
+           do   let inRegOrBoth (InReg _) = True
+                    inRegOrBoth (InBoth _ _) = True
+                    inRegOrBoth _ = False
+                let candidates' =
+                      flip delListFromUFM keep $
+                      filterUFM inRegOrBoth $
+                      assig
+                      -- This is non-deterministic but we do not
+                      -- currently support deterministic code-generation.
+                      -- See Note [Unique Determinism and code generation]
+                let candidates = nonDetUFMToList candidates'
+
+                -- the vregs we could kick out that are already in a slot
+                let candidates_inBoth
+                        = [ (temp, reg, mem)
+                          | (temp, InBoth reg mem) <- candidates
+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
+
+                -- the vregs we could kick out that are only in a reg
+                --      this would require writing the reg to a new slot before using it.
+                let candidates_inReg
+                        = [ (temp, reg)
+                          | (temp, InReg reg) <- candidates
+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
+
+                let result
+
+                        -- we have a temporary that is in both register and mem,
+                        -- just free up its register for use.
+                        | (temp, my_reg, slot) : _      <- candidates_inBoth
+                        = do    spills' <- loadTemp r spill_loc my_reg spills
+                                let assig1  = addToUFM assig temp (InMem slot)
+                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg
+
+                                setAssigR assig2
+                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
+
+                        -- otherwise, we need to spill a temporary that currently
+                        -- resides in a register.
+                        | (temp_to_push_out, (my_reg :: RealReg)) : _
+                                        <- candidates_inReg
+                        = do
+                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
+                                let spill_store  = (if reading then id else reverse)
+                                                        [ -- COMMENT (fsLit "spill alloc")
+                                                           spill_insn ]
+
+                                -- record that this temp was spilled
+                                recordSpill (SpillAlloc temp_to_push_out)
+
+                                -- update the register assignment
+                                let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
+                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
+                                setAssigR assig2
+
+                                -- if need be, load up a spilled temp into the reg we've just freed up.
+                                spills' <- loadTemp r spill_loc my_reg spills
+
+                                allocateRegsAndSpill reading keep
+                                        (spill_store ++ spills')
+                                        (my_reg:alloc) rs
+
+
+                        -- there wasn't anything to spill, so we're screwed.
+                        | otherwise
+                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
+                        $ vcat
+                                [ text "allocating vreg:  " <> text (show r)
+                                , text "assignment:       " <> ppr assig
+                                , text "freeRegs:         " <> text (show freeRegs)
+                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]
+
+                result
+
+
+-- | Calculate a new location after a register has been loaded.
+newLocation :: SpillLoc -> RealReg -> Loc
+-- if the tmp was read from a slot, then now its in a reg as well
+newLocation (ReadMem slot) my_reg = InBoth my_reg slot
+-- writes will always result in only the register being available
+newLocation _ my_reg = InReg my_reg
+
+-- | Load up a spilled temporary if we need to (read from memory).
+loadTemp
+        :: (Instruction instr)
+        => VirtualReg   -- the temp being loaded
+        -> SpillLoc     -- the current location of this temp
+        -> RealReg      -- the hreg to load the temp into
+        -> [instr]
+        -> RegM freeRegs [instr]
+
+loadTemp vreg (ReadMem slot) hreg spills
+ = do
+        insn <- loadR (RegReal hreg) slot
+        recordSpill (SpillLoad $ getUnique vreg)
+        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills
+
+loadTemp _ _ _ spills =
+   return spills
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
@@ -0,0 +1,61 @@
+-- | Free regs map for PowerPC
+module RegAlloc.Linear.PPC.FreeRegs
+where
+
+import GhcPrelude
+
+import PPC.Regs
+import RegClass
+import Reg
+
+import Outputable
+import Platform
+
+import Data.Word
+import Data.Bits
+
+-- The PowerPC has 32 integer and 32 floating point registers.
+-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
+-- better.
+-- Note that when getFreeRegs scans for free registers, it starts at register
+-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
+-- registers are callee-saves, while the lower regs are caller-saves, so it
+-- makes sense to start at the high end.
+-- Apart from that, the code does nothing PowerPC-specific, so feel free to
+-- add your favourite platform to the #if (if you have 64 registers but only
+-- 32-bit words).
+
+data FreeRegs = FreeRegs !Word32 !Word32
+              deriving( Show )  -- The Show is used in an ASSERT
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle r) (FreeRegs g f)
+    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))
+    | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f
+
+releaseReg _ _
+        = panic "RegAlloc.Linear.PPC.releaseReg: bad reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
+getFreeRegs cls (FreeRegs g f)
+    | RcDouble <- cls = go f (0x80000000) 63
+    | RcInteger <- cls = go g (0x80000000) 31
+    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)
+    where
+        go _ 0 _ = []
+        go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)
+                 | otherwise    = go x (m `shiftR` 1) $! i-1
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs g f)
+    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))
+    | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f
+
+allocateReg _ _
+        = panic "RegAlloc.Linear.PPC.allocateReg: bad reg"
diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
@@ -0,0 +1,187 @@
+
+-- | Free regs map for SPARC
+module RegAlloc.Linear.SPARC.FreeRegs
+where
+
+import GhcPrelude
+
+import SPARC.Regs
+import RegClass
+import Reg
+
+import CodeGen.Platform
+import Outputable
+import Platform
+
+import Data.Word
+import Data.Bits
+
+
+--------------------------------------------------------------------------------
+-- SPARC is like PPC, except for twinning of floating point regs.
+--      When we allocate a double reg we must take an even numbered
+--      float reg, as well as the one after it.
+
+
+-- Holds bitmaps showing what registers are currently allocated.
+--      The float and double reg bitmaps overlap, but we only alloc
+--      float regs into the float map, and double regs into the double map.
+--
+--      Free regs have a bit set in the corresponding bitmap.
+--
+data FreeRegs
+        = FreeRegs
+                !Word32         -- int    reg bitmap    regs  0..31
+                !Word32         -- float  reg bitmap    regs 32..63
+                !Word32         -- double reg bitmap    regs 32..63
+
+instance Show FreeRegs where
+        show = showFreeRegs
+
+-- | A reg map where no regs are free to be allocated.
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0 0
+
+
+-- | The initial set of free regs.
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+ =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs
+
+
+-- | Get all the free registers of this class.
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
+getFreeRegs cls (FreeRegs g f d)
+        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0
+        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32
+        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32
+        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
+        where
+                go _    _      0    _
+                        = []
+
+                go step bitmap mask ix
+                        | bitmap .&. mask /= 0
+                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)
+
+                        | otherwise
+                        = go step bitmap (mask `shiftL` step) $! ix + step
+
+
+-- | Grab a register.
+allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
+allocateReg platform
+         reg@(RealRegSingle r)
+             (FreeRegs g f d)
+
+        -- can't allocate free regs
+        | not $ freeReg platform r
+        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)
+
+        -- a general purpose reg
+        | r <= 31
+        = let   mask    = complement (bitMask r)
+          in    FreeRegs
+                        (g .&. mask)
+                        f
+                        d
+
+        -- a float reg
+        | r >= 32, r <= 63
+        = let   mask    = complement (bitMask (r - 32))
+
+                -- the mask of the double this FP reg aliases
+                maskLow = if r `mod` 2 == 0
+                                then complement (bitMask (r - 32))
+                                else complement (bitMask (r - 32 - 1))
+          in    FreeRegs
+                        g
+                        (f .&. mask)
+                        (d .&. maskLow)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
+
+allocateReg _
+         reg@(RealRegPair r1 r2)
+             (FreeRegs g f d)
+
+        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
+        , r2 >= 32, r2 <= 63
+        = let   mask1   = complement (bitMask (r1 - 32))
+                mask2   = complement (bitMask (r2 - 32))
+          in
+                FreeRegs
+                        g
+                        ((f .&. mask1) .&. mask2)
+                        (d .&. mask1)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
+
+
+
+-- | Release a register from allocation.
+--      The register liveness information says that most regs die after a C call,
+--      but we still don't want to allocate to some of them.
+--
+releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
+releaseReg platform
+         reg@(RealRegSingle r)
+        regs@(FreeRegs g f d)
+
+        -- don't release pinned reg
+        | not $ freeReg platform r
+        = regs
+
+        -- a general purpose reg
+        | r <= 31
+        = let   mask    = bitMask r
+          in    FreeRegs (g .|. mask) f d
+
+        -- a float reg
+        | r >= 32, r <= 63
+        = let   mask    = bitMask (r - 32)
+
+                -- the mask of the double this FP reg aliases
+                maskLow = if r `mod` 2 == 0
+                                then bitMask (r - 32)
+                                else bitMask (r - 32 - 1)
+          in    FreeRegs
+                        g
+                        (f .|. mask)
+                        (d .|. maskLow)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
+
+releaseReg _
+         reg@(RealRegPair r1 r2)
+             (FreeRegs g f d)
+
+        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
+        , r2 >= 32, r2 <= 63
+        = let   mask1   = bitMask (r1 - 32)
+                mask2   = bitMask (r2 - 32)
+          in
+                FreeRegs
+                        g
+                        ((f .|. mask1) .|. mask2)
+                        (d .|. mask1)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
+
+
+
+bitMask :: Int -> Word32
+bitMask n       = 1 `shiftL` n
+
+
+showFreeRegs :: FreeRegs -> String
+showFreeRegs regs
+        =  "FreeRegs\n"
+        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"
+        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"
+        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -0,0 +1,61 @@
+
+-- | The assignment of virtual registers to stack slots
+
+--      We have lots of stack slots. Memory-to-memory moves are a pain on most
+--      architectures. Therefore, we avoid having to generate memory-to-memory moves
+--      by simply giving every virtual register its own stack slot.
+
+--      The StackMap stack map keeps track of virtual register - stack slot
+--      associations and of which stack slots are still free. Once it has been
+--      associated, a stack slot is never "freed" or removed from the StackMap again,
+--      it remains associated until we are done with the current CmmProc.
+--
+module RegAlloc.Linear.StackMap (
+        StackSlot,
+        StackMap(..),
+        emptyStackMap,
+        getStackSlotFor,
+        getStackUse
+)
+
+where
+
+import GhcPrelude
+
+import DynFlags
+import UniqFM
+import Unique
+
+
+-- | Identifier for a stack slot.
+type StackSlot = Int
+
+data StackMap
+        = StackMap
+        { -- | The slots that are still available to be allocated.
+          stackMapNextFreeSlot  :: !Int
+
+          -- | Assignment of vregs to stack slots.
+        , stackMapAssignment    :: UniqFM StackSlot }
+
+
+-- | An empty stack map, with all slots available.
+emptyStackMap :: DynFlags -> StackMap
+emptyStackMap _ = StackMap 0 emptyUFM
+
+
+-- | If this vreg unique already has a stack assignment then return the slot number,
+--      otherwise allocate a new slot, and update the map.
+--
+getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)
+
+getStackSlotFor fs@(StackMap _ reserved) reg
+  | Just slot <- lookupUFM reserved reg  =  (fs, slot)
+
+getStackSlotFor (StackMap freeSlot reserved) reg =
+    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)
+
+-- | Return the number of stack slots that were allocated
+getStackUse :: StackMap -> Int
+getStackUse (StackMap freeSlot _) = freeSlot
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE CPP, PatternSynonyms #-}
+
+#if !defined(GHC_LOADED_INTO_GHCI)
+{-# LANGUAGE UnboxedTuples #-}
+#endif
+
+-- | State monad for the linear register allocator.
+
+--      Here we keep all the state that the register allocator keeps track
+--      of as it walks the instructions in a basic block.
+
+module RegAlloc.Linear.State (
+        RA_State(..),
+        RegM,
+        runR,
+
+        spillR,
+        loadR,
+
+        getFreeRegsR,
+        setFreeRegsR,
+
+        getAssigR,
+        setAssigR,
+
+        getBlockAssigR,
+        setBlockAssigR,
+
+        setDeltaR,
+        getDeltaR,
+
+        getUniqueR,
+
+        recordSpill,
+        recordFixupBlock
+)
+where
+
+import GhcPrelude
+
+import RegAlloc.Linear.Stats
+import RegAlloc.Linear.StackMap
+import RegAlloc.Linear.Base
+import RegAlloc.Liveness
+import Instruction
+import Reg
+import BlockId
+
+import DynFlags
+import Unique
+import UniqSupply
+
+import Control.Monad (liftM, ap)
+
+-- Avoids using unboxed tuples when loading into GHCi
+#if !defined(GHC_LOADED_INTO_GHCI)
+
+type RA_Result freeRegs a = (# RA_State freeRegs, a #)
+
+pattern RA_Result :: a -> b -> (# a, b #)
+pattern RA_Result a b = (# a, b #)
+{-# COMPLETE RA_Result #-}
+#else
+
+data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a
+
+#endif
+
+-- | The register allocator monad type.
+newtype RegM freeRegs a
+        = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
+
+instance Functor (RegM freeRegs) where
+      fmap = liftM
+
+instance Applicative (RegM freeRegs) where
+      pure a  =  RegM $ \s -> RA_Result s a
+      (<*>) = ap
+
+instance Monad (RegM freeRegs) where
+  m >>= k   =  RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
+
+instance HasDynFlags (RegM a) where
+    getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s)
+
+
+-- | Run a computation in the RegM register allocator monad.
+runR    :: DynFlags
+        -> BlockAssignment freeRegs
+        -> freeRegs
+        -> RegMap Loc
+        -> StackMap
+        -> UniqSupply
+        -> RegM freeRegs a
+        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
+
+runR dflags block_assig freeregs assig stack us thing =
+  case unReg thing
+        (RA_State
+                { ra_blockassig = block_assig
+                , ra_freeregs   = freeregs
+                , ra_assig      = assig
+                , ra_delta      = 0{-???-}
+                , ra_stack      = stack
+                , ra_us         = us
+                , ra_spills     = []
+                , ra_DynFlags   = dflags
+                , ra_fixups     = [] })
+   of
+        RA_Result state returned_thing
+         ->     (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)
+
+
+-- | Make register allocator stats from its final state.
+makeRAStats :: RA_State freeRegs -> RegAllocStats
+makeRAStats state
+        = RegAllocStats
+        { ra_spillInstrs        = binSpillReasons (ra_spills state)
+        , ra_fixupList          = ra_fixups state }
+
+
+spillR :: Instruction instr
+       => Reg -> Unique -> RegM freeRegs (instr, Int)
+
+spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} ->
+  let dflags = ra_DynFlags s
+      (stack1,slot) = getStackSlotFor stack0 temp
+      instr  = mkSpillInstr dflags reg delta slot
+  in
+  RA_Result s{ra_stack=stack1} (instr,slot)
+
+
+loadR :: Instruction instr
+      => Reg -> Int -> RegM freeRegs instr
+
+loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
+  let dflags = ra_DynFlags s
+  in RA_Result s (mkLoadInstr dflags reg delta slot)
+
+getFreeRegsR :: RegM freeRegs freeRegs
+getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
+  RA_Result s freeregs
+
+setFreeRegsR :: freeRegs -> RegM freeRegs ()
+setFreeRegsR regs = RegM $ \ s ->
+  RA_Result s{ra_freeregs = regs} ()
+
+getAssigR :: RegM freeRegs (RegMap Loc)
+getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
+  RA_Result s assig
+
+setAssigR :: RegMap Loc -> RegM freeRegs ()
+setAssigR assig = RegM $ \ s ->
+  RA_Result s{ra_assig=assig} ()
+
+getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
+getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
+  RA_Result s assig
+
+setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
+setBlockAssigR assig = RegM $ \ s ->
+  RA_Result s{ra_blockassig = assig} ()
+
+setDeltaR :: Int -> RegM freeRegs ()
+setDeltaR n = RegM $ \ s ->
+  RA_Result s{ra_delta = n} ()
+
+getDeltaR :: RegM freeRegs Int
+getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)
+
+getUniqueR :: RegM freeRegs Unique
+getUniqueR = RegM $ \s ->
+  case takeUniqFromSupply (ra_us s) of
+    (uniq, us) -> RA_Result s{ra_us = us} uniq
+
+
+-- | Record that a spill instruction was inserted, for profiling.
+recordSpill :: SpillReason -> RegM freeRegs ()
+recordSpill spill
+    = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
+
+-- | Record a created fixup block
+recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
+recordFixupBlock from between to
+    = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -0,0 +1,87 @@
+module RegAlloc.Linear.Stats (
+        binSpillReasons,
+        countRegRegMovesNat,
+        pprStats
+)
+
+where
+
+import GhcPrelude
+
+import RegAlloc.Linear.Base
+import RegAlloc.Liveness
+import Instruction
+
+import UniqFM
+import Outputable
+
+import State
+
+-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
+binSpillReasons
+        :: [SpillReason] -> UniqFM [Int]
+
+binSpillReasons reasons
+        = addListToUFM_C
+                (zipWith (+))
+                emptyUFM
+                (map (\reason -> case reason of
+                        SpillAlloc r    -> (r, [1, 0, 0, 0, 0])
+                        SpillClobber r  -> (r, [0, 1, 0, 0, 0])
+                        SpillLoad r     -> (r, [0, 0, 1, 0, 0])
+                        SpillJoinRR r   -> (r, [0, 0, 0, 1, 0])
+                        SpillJoinRM r   -> (r, [0, 0, 0, 0, 1])) reasons)
+
+
+-- | Count reg-reg moves remaining in this code.
+countRegRegMovesNat
+        :: Instruction instr
+        => NatCmmDecl statics instr -> Int
+
+countRegRegMovesNat cmm
+        = execState (mapGenBlockTopM countBlock cmm) 0
+ where
+        countBlock b@(BasicBlock _ instrs)
+         = do   mapM_ countInstr instrs
+                return  b
+
+        countInstr instr
+                | Just _        <- takeRegRegMoveInstr instr
+                = do    modify (+ 1)
+                        return instr
+
+                | otherwise
+                =       return instr
+
+
+-- | Pretty print some RegAllocStats
+pprStats
+        :: Instruction instr
+        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
+
+pprStats code statss
+ = let  -- sum up all the instrs inserted by the spiller
+        spills          = foldl' (plusUFM_C (zipWith (+)))
+                                emptyUFM
+                        $ map ra_spillInstrs statss
+
+        spillTotals     = foldl' (zipWith (+))
+                                [0, 0, 0, 0, 0]
+                        $ nonDetEltsUFM spills
+                        -- See Note [Unique Determinism and code generation]
+
+        -- count how many reg-reg-moves remain in the code
+        moves           = sum $ map countRegRegMovesNat code
+
+        pprSpill (reg, spills)
+                = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
+
+   in   (  text "-- spills-added-total"
+        $$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
+        $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
+        $$ text ""
+        $$ text "-- spills-added"
+        $$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
+        $$ (pprUFMWithKeys spills (vcat . map pprSpill))
+        $$ text "")
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
@@ -0,0 +1,53 @@
+
+-- | Free regs map for i386
+module RegAlloc.Linear.X86.FreeRegs
+where
+
+import GhcPrelude
+
+import X86.Regs
+import RegClass
+import Reg
+import Panic
+import Platform
+
+import Data.Word
+import Data.Bits
+
+newtype FreeRegs = FreeRegs Word32
+    deriving Show
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle n) (FreeRegs f)
+        = FreeRegs (f .|. (1 `shiftL` n))
+
+releaseReg _ _
+        = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
+getFreeRegs platform cls (FreeRegs f) = go f 0
+
+  where go 0 _ = []
+        go n m
+          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
+          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
+
+          | otherwise
+          = go (n `shiftR` 1) $! (m+1)
+        -- ToDo: there's no point looking through all the integer registers
+        -- in order to find a floating-point one.
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs f)
+        = FreeRegs (f .&. complement (1 `shiftL` r))
+
+allocateReg _ _
+        = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
@@ -0,0 +1,54 @@
+
+-- | Free regs map for x86_64
+module RegAlloc.Linear.X86_64.FreeRegs
+where
+
+import GhcPrelude
+
+import X86.Regs
+import RegClass
+import Reg
+import Panic
+import Platform
+
+import Data.Word
+import Data.Bits
+
+newtype FreeRegs = FreeRegs Word64
+    deriving Show
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle n) (FreeRegs f)
+        = FreeRegs (f .|. (1 `shiftL` n))
+
+releaseReg _ _
+        = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
+getFreeRegs platform cls (FreeRegs f) = go f 0
+
+  where go 0 _ = []
+        go n m
+          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
+          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
+
+          | otherwise
+          = go (n `shiftR` 1) $! (m+1)
+        -- ToDo: there's no point looking through all the integer registers
+        -- in order to find a floating-point one.
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs f)
+        = FreeRegs (f .&. complement (1 `shiftL` r))
+
+allocateReg _ _
+        = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"
+
+
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -0,0 +1,1024 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+--
+-- The register liveness determinator
+--
+-- (c) The University of Glasgow 2004-2013
+--
+-----------------------------------------------------------------------------
+
+module RegAlloc.Liveness (
+        RegSet,
+        RegMap, emptyRegMap,
+        BlockMap, mapEmpty,
+        LiveCmmDecl,
+        InstrSR   (..),
+        LiveInstr (..),
+        Liveness (..),
+        LiveInfo (..),
+        LiveBasicBlock,
+
+        mapBlockTop,    mapBlockTopM,   mapSCCM,
+        mapGenBlockTop, mapGenBlockTopM,
+        stripLive,
+        stripLiveBlock,
+        slurpConflicts,
+        slurpReloadCoalesce,
+        eraseDeltasLive,
+        patchEraseLive,
+        patchRegsLiveInstr,
+        reverseBlocksInTops,
+        regLiveness,
+        cmmTopLiveness
+  ) where
+import GhcPrelude
+
+import Reg
+import Instruction
+
+import BlockId
+import CFG
+import Hoopl.Collections
+import Hoopl.Label
+import Cmm hiding (RegSet, emptyRegSet)
+import PprCmm()
+
+import Digraph
+import DynFlags
+import MonadUtils
+import Outputable
+import Platform
+import UniqSet
+import UniqFM
+import UniqSupply
+import Bag
+import State
+
+import Data.List
+import Data.Maybe
+import Data.IntSet              (IntSet)
+
+-----------------------------------------------------------------------------
+type RegSet = UniqSet Reg
+
+type RegMap a = UniqFM a
+
+emptyRegMap :: UniqFM a
+emptyRegMap = emptyUFM
+
+emptyRegSet :: RegSet
+emptyRegSet = emptyUniqSet
+
+type BlockMap a = LabelMap a
+
+
+-- | A top level thing which carries liveness information.
+type LiveCmmDecl statics instr
+        = GenCmmDecl
+                statics
+                LiveInfo
+                [SCC (LiveBasicBlock instr)]
+
+
+-- | The register allocator also wants to use SPILL/RELOAD meta instructions,
+--   so we'll keep those here.
+data InstrSR instr
+        -- | A real machine instruction
+        = Instr  instr
+
+        -- | spill this reg to a stack slot
+        | SPILL  Reg Int
+
+        -- | reload this reg from a stack slot
+        | RELOAD Int Reg
+
+instance Instruction instr => Instruction (InstrSR instr) where
+        regUsageOfInstr platform i
+         = case i of
+                Instr  instr    -> regUsageOfInstr platform instr
+                SPILL  reg _    -> RU [reg] []
+                RELOAD _ reg    -> RU [] [reg]
+
+        patchRegsOfInstr i f
+         = case i of
+                Instr instr     -> Instr (patchRegsOfInstr instr f)
+                SPILL  reg slot -> SPILL (f reg) slot
+                RELOAD slot reg -> RELOAD slot (f reg)
+
+        isJumpishInstr i
+         = case i of
+                Instr instr     -> isJumpishInstr instr
+                _               -> False
+
+        jumpDestsOfInstr i
+         = case i of
+                Instr instr     -> jumpDestsOfInstr instr
+                _               -> []
+
+        patchJumpInstr i f
+         = case i of
+                Instr instr     -> Instr (patchJumpInstr instr f)
+                _               -> i
+
+        mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
+        mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
+
+        takeDeltaInstr i
+         = case i of
+                Instr instr     -> takeDeltaInstr instr
+                _               -> Nothing
+
+        isMetaInstr i
+         = case i of
+                Instr instr     -> isMetaInstr instr
+                _               -> False
+
+        mkRegRegMoveInstr platform r1 r2
+            = Instr (mkRegRegMoveInstr platform r1 r2)
+
+        takeRegRegMoveInstr i
+         = case i of
+                Instr instr     -> takeRegRegMoveInstr instr
+                _               -> Nothing
+
+        mkJumpInstr target      = map Instr (mkJumpInstr target)
+
+        mkStackAllocInstr platform amount =
+             Instr <$> mkStackAllocInstr platform amount
+
+        mkStackDeallocInstr platform amount =
+             Instr <$> mkStackDeallocInstr platform amount
+
+
+-- | An instruction with liveness information.
+data LiveInstr instr
+        = LiveInstr (InstrSR instr) (Maybe Liveness)
+
+-- | Liveness information.
+--   The regs which die are ones which are no longer live in the *next* instruction
+--   in this sequence.
+--   (NB. if the instruction is a jump, these registers might still be live
+--   at the jump target(s) - you have to check the liveness at the destination
+--   block to find out).
+
+data Liveness
+        = Liveness
+        { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
+        , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
+        , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
+
+
+-- | Stash regs live on entry to each basic block in the info part of the cmm code.
+data LiveInfo
+        = LiveInfo
+                (LabelMap CmmStatics)     -- cmm info table static stuff
+                [BlockId]                 -- entry points (first one is the
+                                          -- entry point for the proc).
+                (BlockMap RegSet)         -- argument locals live on entry to this block
+                (BlockMap IntSet)         -- stack slots live on entry to this block
+
+
+-- | A basic block with liveness information.
+type LiveBasicBlock instr
+        = GenBasicBlock (LiveInstr instr)
+
+
+instance Outputable instr
+      => Outputable (InstrSR instr) where
+
+        ppr (Instr realInstr)
+           = ppr realInstr
+
+        ppr (SPILL reg slot)
+           = hcat [
+                text "\tSPILL",
+                char ' ',
+                ppr reg,
+                comma,
+                text "SLOT" <> parens (int slot)]
+
+        ppr (RELOAD slot reg)
+           = hcat [
+                text "\tRELOAD",
+                char ' ',
+                text "SLOT" <> parens (int slot),
+                comma,
+                ppr reg]
+
+instance Outputable instr
+      => Outputable (LiveInstr instr) where
+
+        ppr (LiveInstr instr Nothing)
+         = ppr instr
+
+        ppr (LiveInstr instr (Just live))
+         =  ppr instr
+                $$ (nest 8
+                        $ vcat
+                        [ pprRegs (text "# born:    ") (liveBorn live)
+                        , pprRegs (text "# r_dying: ") (liveDieRead live)
+                        , pprRegs (text "# w_dying: ") (liveDieWrite live) ]
+                    $+$ space)
+
+         where  pprRegs :: SDoc -> RegSet -> SDoc
+                pprRegs name regs
+                 | isEmptyUniqSet regs  = empty
+                 | otherwise            = name <>
+                     (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr))
+
+instance Outputable LiveInfo where
+    ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)
+        =  (ppr mb_static)
+        $$ text "# entryIds         = " <> ppr entryIds
+        $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
+        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
+
+
+
+-- | map a function across all the basic blocks in this code
+--
+mapBlockTop
+        :: (LiveBasicBlock instr -> LiveBasicBlock instr)
+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+
+mapBlockTop f cmm
+        = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+--
+mapBlockTopM
+        :: Monad m
+        => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
+        -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
+
+mapBlockTopM _ cmm@(CmmData{})
+        = return cmm
+
+mapBlockTopM f (CmmProc header label live sccs)
+ = do   sccs'   <- mapM (mapSCCM f) sccs
+        return  $ CmmProc header label live sccs'
+
+mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
+mapSCCM f (AcyclicSCC x)
+ = do   x'      <- f x
+        return  $ AcyclicSCC x'
+
+mapSCCM f (CyclicSCC xs)
+ = do   xs'     <- mapM f xs
+        return  $ CyclicSCC xs'
+
+
+-- map a function across all the basic blocks in this code
+mapGenBlockTop
+        :: (GenBasicBlock             i -> GenBasicBlock            i)
+        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
+
+mapGenBlockTop f cmm
+        = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+mapGenBlockTopM
+        :: Monad m
+        => (GenBasicBlock            i  -> m (GenBasicBlock            i))
+        -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
+
+mapGenBlockTopM _ cmm@(CmmData{})
+        = return cmm
+
+mapGenBlockTopM f (CmmProc header label live (ListGraph blocks))
+ = do   blocks' <- mapM f blocks
+        return  $ CmmProc header label live (ListGraph blocks')
+
+
+-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
+--   Slurping of conflicts and moves is wrapped up together so we don't have
+--   to make two passes over the same code when we want to build the graph.
+--
+slurpConflicts
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> (Bag (UniqSet Reg), Bag (Reg, Reg))
+
+slurpConflicts live
+        = slurpCmm (emptyBag, emptyBag) live
+
+ where  slurpCmm   rs  CmmData{}                = rs
+        slurpCmm   rs (CmmProc info _ _ sccs)
+                = foldl' (slurpSCC info) rs sccs
+
+        slurpSCC  info rs (AcyclicSCC b)
+                = slurpBlock info rs b
+
+        slurpSCC  info rs (CyclicSCC bs)
+                = foldl'  (slurpBlock info) rs bs
+
+        slurpBlock info rs (BasicBlock blockId instrs)
+                | LiveInfo _ _ blockLive _        <- info
+                , Just rsLiveEntry                <- mapLookup blockId blockLive
+                , (conflicts, moves)              <- slurpLIs rsLiveEntry rs instrs
+                = (consBag rsLiveEntry conflicts, moves)
+
+                | otherwise
+                = panic "Liveness.slurpConflicts: bad block"
+
+        slurpLIs rsLive (conflicts, moves) []
+                = (consBag rsLive conflicts, moves)
+
+        slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)
+                = slurpLIs rsLive rs lis
+
+        slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
+         = let
+                -- regs that die because they are read for the last time at the start of an instruction
+                --      are not live across it.
+                rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
+
+                -- regs live on entry to the next instruction.
+                --      be careful of orphans, make sure to delete dying regs _after_ unioning
+                --      in the ones that are born here.
+                rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
+                                                `minusUniqSet`  (liveDieWrite live)
+
+                -- orphan vregs are the ones that die in the same instruction they are born in.
+                --      these are likely to be results that are never used, but we still
+                --      need to assign a hreg to them..
+                rsOrphans       = intersectUniqSets
+                                        (liveBorn live)
+                                        (unionUniqSets (liveDieWrite live) (liveDieRead live))
+
+                --
+                rsConflicts     = unionUniqSets rsLiveNext rsOrphans
+
+          in    case takeRegRegMoveInstr instr of
+                 Just rr        -> slurpLIs rsLiveNext
+                                        ( consBag rsConflicts conflicts
+                                        , consBag rr moves) lis
+
+                 Nothing        -> slurpLIs rsLiveNext
+                                        ( consBag rsConflicts conflicts
+                                        , moves) lis
+
+
+-- | For spill\/reloads
+--
+--   SPILL  v1, slot1
+--   ...
+--   RELOAD slot1, v2
+--
+--   If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
+--   the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
+--
+--
+slurpReloadCoalesce
+        :: forall statics instr. Instruction instr
+        => LiveCmmDecl statics instr
+        -> Bag (Reg, Reg)
+
+slurpReloadCoalesce live
+        = slurpCmm emptyBag live
+
+ where
+        slurpCmm :: Bag (Reg, Reg)
+                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
+                 -> Bag (Reg, Reg)
+        slurpCmm cs CmmData{}   = cs
+        slurpCmm cs (CmmProc _ _ _ sccs)
+                = slurpComp cs (flattenSCCs sccs)
+
+        slurpComp :: Bag (Reg, Reg)
+                     -> [LiveBasicBlock instr]
+                     -> Bag (Reg, Reg)
+        slurpComp  cs blocks
+         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
+           in   unionManyBags (cs : moveBags)
+
+        slurpCompM :: [LiveBasicBlock instr]
+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
+        slurpCompM blocks
+         = do   -- run the analysis once to record the mapping across jumps.
+                mapM_   (slurpBlock False) blocks
+
+                -- run it a second time while using the information from the last pass.
+                --      We /could/ run this many more times to deal with graphical control
+                --      flow and propagating info across multiple jumps, but it's probably
+                --      not worth the trouble.
+                mapM    (slurpBlock True) blocks
+
+        slurpBlock :: Bool -> LiveBasicBlock instr
+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
+        slurpBlock propagate (BasicBlock blockId instrs)
+         = do   -- grab the slot map for entry to this block
+                slotMap         <- if propagate
+                                        then getSlotMap blockId
+                                        else return emptyUFM
+
+                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
+                return $ listToBag $ catMaybes mMoves
+
+        slurpLI :: UniqFM Reg                           -- current slotMap
+                -> LiveInstr instr
+                -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
+                                                        --      for tracking slotMaps across jumps
+
+                         ( UniqFM Reg                   -- new slotMap
+                         , Maybe (Reg, Reg))            -- maybe a new coalesce edge
+
+        slurpLI slotMap li
+
+                -- remember what reg was stored into the slot
+                | LiveInstr (SPILL reg slot) _  <- li
+                , slotMap'                      <- addToUFM slotMap slot reg
+                = return (slotMap', Nothing)
+
+                -- add an edge between the this reg and the last one stored into the slot
+                | LiveInstr (RELOAD slot reg) _ <- li
+                = case lookupUFM slotMap slot of
+                        Just reg2
+                         | reg /= reg2  -> return (slotMap, Just (reg, reg2))
+                         | otherwise    -> return (slotMap, Nothing)
+
+                        Nothing         -> return (slotMap, Nothing)
+
+                -- if we hit a jump, remember the current slotMap
+                | LiveInstr (Instr instr) _     <- li
+                , targets                       <- jumpDestsOfInstr instr
+                , not $ null targets
+                = do    mapM_   (accSlotMap slotMap) targets
+                        return  (slotMap, Nothing)
+
+                | otherwise
+                = return (slotMap, Nothing)
+
+        -- record a slotmap for an in edge to this block
+        accSlotMap slotMap blockId
+                = modify (\s -> addToUFM_C (++) s blockId [slotMap])
+
+        -- work out the slot map on entry to this block
+        --      if we have slot maps for multiple in-edges then we need to merge them.
+        getSlotMap blockId
+         = do   map             <- get
+                let slotMaps    = fromMaybe [] (lookupUFM map blockId)
+                return          $ foldr mergeSlotMaps emptyUFM slotMaps
+
+        mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
+        mergeSlotMaps map1 map2
+                = listToUFM
+                $ [ (k, r1)
+                  | (k, r1) <- nonDetUFMToList map1
+                  -- This is non-deterministic but we do not
+                  -- currently support deterministic code-generation.
+                  -- See Note [Unique Determinism and code generation]
+                  , case lookupUFM map2 k of
+                          Nothing -> False
+                          Just r2 -> r1 == r2 ]
+
+
+-- | Strip away liveness information, yielding NatCmmDecl
+stripLive
+        :: (Outputable statics, Outputable instr, Instruction instr)
+        => DynFlags
+        -> LiveCmmDecl statics instr
+        -> NatCmmDecl statics instr
+
+stripLive dflags live
+        = stripCmm live
+
+ where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
+                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
+        stripCmm (CmmData sec ds)       = CmmData sec ds
+        stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)
+         = let  final_blocks    = flattenSCCs sccs
+
+                -- make sure the block that was first in the input list
+                --      stays at the front of the output. This is the entry point
+                --      of the proc, and it needs to come first.
+                ((first':_), rest')
+                                = partition ((== first_id) . blockId) final_blocks
+
+           in   CmmProc info label live
+                          (ListGraph $ map (stripLiveBlock dflags) $ first' : rest')
+
+        -- If the proc has blocks but we don't know what the first one was, then we're dead.
+        stripCmm proc
+                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
+
+-- | Strip away liveness information from a basic block,
+--   and make real spill instructions out of SPILL, RELOAD pseudos along the way.
+
+stripLiveBlock
+        :: Instruction instr
+        => DynFlags
+        -> LiveBasicBlock instr
+        -> NatBasicBlock instr
+
+stripLiveBlock dflags (BasicBlock i lis)
+ =      BasicBlock i instrs'
+
+ where  (instrs', _)
+                = runState (spillNat [] lis) 0
+
+        spillNat acc []
+         =      return (reverse acc)
+
+        spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
+         = do   delta   <- get
+                spillNat (mkSpillInstr dflags reg delta slot : acc) instrs
+
+        spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
+         = do   delta   <- get
+                spillNat (mkLoadInstr dflags reg delta slot : acc) instrs
+
+        spillNat acc (LiveInstr (Instr instr) _ : instrs)
+         | Just i <- takeDeltaInstr instr
+         = do   put i
+                spillNat acc instrs
+
+        spillNat acc (LiveInstr (Instr instr) _ : instrs)
+         =      spillNat (instr : acc) instrs
+
+
+-- | Erase Delta instructions.
+
+eraseDeltasLive
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> LiveCmmDecl statics instr
+
+eraseDeltasLive cmm
+        = mapBlockTop eraseBlock cmm
+ where
+        eraseBlock (BasicBlock id lis)
+                = BasicBlock id
+                $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
+                $ lis
+
+
+-- | Patch the registers in this code according to this register mapping.
+--   also erase reg -> reg moves when the reg is the same.
+--   also erase reg -> reg moves when the destination dies in this instr.
+patchEraseLive
+        :: Instruction instr
+        => (Reg -> Reg)
+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+
+patchEraseLive patchF cmm
+        = patchCmm cmm
+ where
+        patchCmm cmm@CmmData{}  = cmm
+
+        patchCmm (CmmProc info label live sccs)
+         | LiveInfo static id blockMap mLiveSlots <- info
+         = let
+                patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set
+                  -- See Note [Unique Determinism and code generation]
+                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap
+
+                info'           = LiveInfo static id blockMap' mLiveSlots
+           in   CmmProc info' label live $ map patchSCC sccs
+
+        patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
+        patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
+
+        patchBlock (BasicBlock id lis)
+                = BasicBlock id $ patchInstrs lis
+
+        patchInstrs []          = []
+        patchInstrs (li : lis)
+
+                | LiveInstr i (Just live)       <- li'
+                , Just (r1, r2) <- takeRegRegMoveInstr i
+                , eatMe r1 r2 live
+                = patchInstrs lis
+
+                | otherwise
+                = li' : patchInstrs lis
+
+                where   li'     = patchRegsLiveInstr patchF li
+
+        eatMe   r1 r2 live
+                -- source and destination regs are the same
+                | r1 == r2      = True
+
+                -- destination reg is never used
+                | elementOfUniqSet r2 (liveBorn live)
+                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
+                = True
+
+                | otherwise     = False
+
+
+-- | Patch registers in this LiveInstr, including the liveness information.
+--
+patchRegsLiveInstr
+        :: Instruction instr
+        => (Reg -> Reg)
+        -> LiveInstr instr -> LiveInstr instr
+
+patchRegsLiveInstr patchF li
+ = case li of
+        LiveInstr instr Nothing
+         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
+
+        LiveInstr instr (Just live)
+         -> LiveInstr
+                (patchRegsOfInstr instr patchF)
+                (Just live
+                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
+                          liveBorn      = mapUniqSet patchF $ liveBorn live
+                        , liveDieRead   = mapUniqSet patchF $ liveDieRead live
+                        , liveDieWrite  = mapUniqSet patchF $ liveDieWrite live })
+                          -- See Note [Unique Determinism and code generation]
+
+
+--------------------------------------------------------------------------------
+-- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information
+
+cmmTopLiveness
+        :: (Outputable instr, Instruction instr)
+        => Maybe CFG -> Platform
+        -> NatCmmDecl statics instr
+        -> UniqSM (LiveCmmDecl statics instr)
+cmmTopLiveness cfg platform cmm
+        = regLiveness platform $ natCmmTopToLive cfg cmm
+
+natCmmTopToLive
+        :: (Instruction instr, Outputable instr)
+        => Maybe CFG -> NatCmmDecl statics instr
+        -> LiveCmmDecl statics instr
+
+natCmmTopToLive _ (CmmData i d)
+        = CmmData i d
+
+natCmmTopToLive _ (CmmProc info lbl live (ListGraph []))
+        = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live []
+
+natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
+        = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty)
+                lbl live sccsLive
+   where
+        first_id        = blockId first
+        all_entry_ids   = entryBlocks proc
+        sccs            = sccBlocks blocks all_entry_ids mCfg
+        sccsLive        = map (fmap (\(BasicBlock l instrs) ->
+                                       BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
+                        $ sccs
+
+        entry_ids       = filter (reachable_node) .
+                          filter (/= first_id) $ all_entry_ids
+        info'           = mapFilterWithKey (\node _ -> reachable_node node) info
+        reachable_node
+          | Just cfg <- mCfg
+          = hasNode cfg
+          | otherwise
+          = const True
+
+--
+-- Compute the liveness graph of the set of basic blocks.  Important:
+-- we also discard any unreachable code here, starting from the entry
+-- points (the first block in the list, and any blocks with info
+-- tables).  Unreachable code arises when code blocks are orphaned in
+-- earlier optimisation passes, and may confuse the register allocator
+-- by referring to registers that are not initialised.  It's easy to
+-- discard the unreachable code as part of the SCC pass, so that's
+-- exactly what we do. (#7574)
+--
+sccBlocks
+        :: forall instr . Instruction instr
+        => [NatBasicBlock instr]
+        -> [BlockId]
+        -> Maybe CFG
+        -> [SCC (NatBasicBlock instr)]
+
+sccBlocks blocks entries mcfg = map (fmap node_payload) sccs
+  where
+        nodes :: [ Node BlockId (NatBasicBlock instr) ]
+        nodes = [ DigraphNode block id (getOutEdges instrs)
+                | block@(BasicBlock id instrs) <- blocks ]
+
+        g1 = graphFromEdgedVerticesUniq nodes
+
+        reachable :: LabelSet
+        reachable
+            | Just cfg <- mcfg
+            -- Our CFG only contains reachable nodes by construction.
+            = getCfgNodes cfg
+            | otherwise
+            = setFromList $ [ node_key node | node <- reachablesG g1 roots ]
+
+        g2 = graphFromEdgedVerticesUniq [ node | node <- nodes
+                                               , node_key node
+                                                  `setMember` reachable ]
+
+        sccs = stronglyConnCompG g2
+
+        getOutEdges :: Instruction instr => [instr] -> [BlockId]
+        getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
+
+        -- This is truly ugly, but I don't see a good alternative.
+        -- Digraph just has the wrong API.  We want to identify nodes
+        -- by their keys (BlockId), but Digraph requires the whole
+        -- node: (NatBasicBlock, BlockId, [BlockId]).  This takes
+        -- advantage of the fact that Digraph only looks at the key,
+        -- even though it asks for the whole triple.
+        roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks")
+                | b <- entries ]
+
+--------------------------------------------------------------------------------
+-- Annotate code with register liveness information
+--
+
+regLiveness
+        :: (Outputable instr, Instruction instr)
+        => Platform
+        -> LiveCmmDecl statics instr
+        -> UniqSM (LiveCmmDecl statics instr)
+
+regLiveness _ (CmmData i d)
+        = return $ CmmData i d
+
+regLiveness _ (CmmProc info lbl live [])
+        | LiveInfo static mFirst _ _    <- info
+        = return $ CmmProc
+                        (LiveInfo static mFirst mapEmpty mapEmpty)
+                        lbl live []
+
+regLiveness platform (CmmProc info lbl live sccs)
+        | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
+        = let   (ann_sccs, block_live)  = computeLiveness platform sccs
+
+          in    return $ CmmProc (LiveInfo static mFirst block_live liveSlotsOnEntry)
+                           lbl live ann_sccs
+
+
+-- -----------------------------------------------------------------------------
+-- | Check ordering of Blocks
+--   The computeLiveness function requires SCCs to be in reverse
+--   dependent order.  If they're not the liveness information will be
+--   wrong, and we'll get a bad allocation.  Better to check for this
+--   precondition explicitly or some other poor sucker will waste a
+--   day staring at bad assembly code..
+--
+checkIsReverseDependent
+        :: Instruction instr
+        => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.
+        -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)
+
+checkIsReverseDependent sccs'
+ = go emptyUniqSet sccs'
+
+ where  go _ []
+         = Nothing
+
+        go blocksSeen (AcyclicSCC block : sccs)
+         = let  dests           = slurpJumpDestsOfBlock block
+                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
+                badDests        = dests `minusUniqSet` blocksSeen'
+           in   case nonDetEltsUniqSet badDests of
+                 -- See Note [Unique Determinism and code generation]
+                 []             -> go blocksSeen' sccs
+                 bad : _        -> Just bad
+
+        go blocksSeen (CyclicSCC blocks : sccs)
+         = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
+                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
+                badDests        = dests `minusUniqSet` blocksSeen'
+           in   case nonDetEltsUniqSet badDests of
+                 -- See Note [Unique Determinism and code generation]
+                 []             -> go blocksSeen' sccs
+                 bad : _        -> Just bad
+
+        slurpJumpDestsOfBlock (BasicBlock _ instrs)
+                = unionManyUniqSets
+                $ map (mkUniqSet . jumpDestsOfInstr)
+                        [ i | LiveInstr i _ <- instrs]
+
+
+-- | If we've compute liveness info for this code already we have to reverse
+--   the SCCs in each top to get them back to the right order so we can do it again.
+reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+reverseBlocksInTops top
+ = case top of
+        CmmData{}                       -> top
+        CmmProc info lbl live sccs      -> CmmProc info lbl live (reverse sccs)
+
+
+-- | Computing liveness
+--
+--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
+--  control to earlier ones only, else `panic`.
+--
+--  The SCCs returned are in the *opposite* order, which is exactly what we
+--  want for the next pass.
+--
+computeLiveness
+        :: (Outputable instr, Instruction instr)
+        => Platform
+        -> [SCC (LiveBasicBlock instr)]
+        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
+                                                -- which are "dead after this instruction".
+               BlockMap RegSet)                 -- blocks annotated with set of live registers
+                                                -- on entry to the block.
+
+computeLiveness platform sccs
+ = case checkIsReverseDependent sccs of
+        Nothing         -> livenessSCCs platform mapEmpty [] sccs
+        Just bad        -> pprPanic "RegAlloc.Liveness.computeLiveness"
+                                (vcat   [ text "SCCs aren't in reverse dependent order"
+                                        , text "bad blockId" <+> ppr bad
+                                        , ppr sccs])
+
+livenessSCCs
+       :: Instruction instr
+       => Platform
+       -> BlockMap RegSet
+       -> [SCC (LiveBasicBlock instr)]          -- accum
+       -> [SCC (LiveBasicBlock instr)]
+       -> ( [SCC (LiveBasicBlock instr)]
+          , BlockMap RegSet)
+
+livenessSCCs _ blockmap done []
+        = (done, blockmap)
+
+livenessSCCs platform blockmap done (AcyclicSCC block : sccs)
+ = let  (blockmap', block')     = livenessBlock platform blockmap block
+   in   livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs
+
+livenessSCCs platform blockmap done
+        (CyclicSCC blocks : sccs) =
+        livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs
+ where      (blockmap', blocks')
+                = iterateUntilUnchanged linearLiveness equalBlockMaps
+                                      blockmap blocks
+
+            iterateUntilUnchanged
+                :: (a -> b -> (a,c)) -> (a -> a -> Bool)
+                -> a -> b
+                -> (a,c)
+
+            iterateUntilUnchanged f eq a b
+                = head $
+                  concatMap tail $
+                  groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
+                  iterate (\(a, _) -> f a b) $
+                  (a, panic "RegLiveness.livenessSCCs")
+
+
+            linearLiveness
+                :: Instruction instr
+                => BlockMap RegSet -> [LiveBasicBlock instr]
+                -> (BlockMap RegSet, [LiveBasicBlock instr])
+
+            linearLiveness = mapAccumL (livenessBlock platform)
+
+                -- probably the least efficient way to compare two
+                -- BlockMaps for equality.
+            equalBlockMaps a b
+                = a' == b'
+              where a' = map f $ mapToList a
+                    b' = map f $ mapToList b
+                    f (key,elt) = (key, nonDetEltsUniqSet elt)
+                    -- See Note [Unique Determinism and code generation]
+
+
+
+-- | Annotate a basic block with register liveness information.
+--
+livenessBlock
+        :: Instruction instr
+        => Platform
+        -> BlockMap RegSet
+        -> LiveBasicBlock instr
+        -> (BlockMap RegSet, LiveBasicBlock instr)
+
+livenessBlock platform blockmap (BasicBlock block_id instrs)
+ = let
+        (regsLiveOnEntry, instrs1)
+            = livenessBack platform emptyUniqSet blockmap [] (reverse instrs)
+        blockmap'       = mapInsert block_id regsLiveOnEntry blockmap
+
+        instrs2         = livenessForward platform regsLiveOnEntry instrs1
+
+        output          = BasicBlock block_id instrs2
+
+   in   ( blockmap', output)
+
+-- | Calculate liveness going forwards,
+--   filling in when regs are born
+
+livenessForward
+        :: Instruction instr
+        => Platform
+        -> RegSet                       -- regs live on this instr
+        -> [LiveInstr instr] -> [LiveInstr instr]
+
+livenessForward _        _           []  = []
+livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis)
+        | Just live <- mLive
+        = let
+                RU _ written  = regUsageOfInstr platform instr
+                -- Regs that are written to but weren't live on entry to this instruction
+                --      are recorded as being born here.
+                rsBorn          = mkUniqSet
+                                $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
+
+                rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
+                                        `minusUniqSet` (liveDieRead live)
+                                        `minusUniqSet` (liveDieWrite live)
+
+        in LiveInstr instr (Just live { liveBorn = rsBorn })
+                : livenessForward platform rsLiveNext lis
+
+        | otherwise
+        = li : livenessForward platform rsLiveEntry lis
+
+
+-- | Calculate liveness going backwards,
+--   filling in when regs die, and what regs are live across each instruction
+
+livenessBack
+        :: Instruction instr
+        => Platform
+        -> RegSet                       -- regs live on this instr
+        -> BlockMap RegSet              -- regs live on entry to other BBs
+        -> [LiveInstr instr]            -- instructions (accum)
+        -> [LiveInstr instr]            -- instructions
+        -> (RegSet, [LiveInstr instr])
+
+livenessBack _        liveregs _        done []  = (liveregs, done)
+
+livenessBack platform liveregs blockmap acc (instr : instrs)
+ = let  (liveregs', instr')     = liveness1 platform liveregs blockmap instr
+   in   livenessBack platform liveregs' blockmap (instr' : acc) instrs
+
+
+-- don't bother tagging comments or deltas with liveness
+liveness1
+        :: Instruction instr
+        => Platform
+        -> RegSet
+        -> BlockMap RegSet
+        -> LiveInstr instr
+        -> (RegSet, LiveInstr instr)
+
+liveness1 _ liveregs _ (LiveInstr instr _)
+        | isMetaInstr instr
+        = (liveregs, LiveInstr instr Nothing)
+
+liveness1 platform liveregs blockmap (LiveInstr instr _)
+
+        | not_a_branch
+        = (liveregs1, LiveInstr instr
+                        (Just $ Liveness
+                        { liveBorn      = emptyUniqSet
+                        , liveDieRead   = mkUniqSet r_dying
+                        , liveDieWrite  = mkUniqSet w_dying }))
+
+        | otherwise
+        = (liveregs_br, LiveInstr instr
+                        (Just $ Liveness
+                        { liveBorn      = emptyUniqSet
+                        , liveDieRead   = mkUniqSet r_dying_br
+                        , liveDieWrite  = mkUniqSet w_dying }))
+
+        where
+            !(RU read written) = regUsageOfInstr platform instr
+
+            -- registers that were written here are dead going backwards.
+            -- registers that were read here are live going backwards.
+            liveregs1   = (liveregs `delListFromUniqSet` written)
+                                    `addListToUniqSet` read
+
+            -- registers that are not live beyond this point, are recorded
+            --  as dying here.
+            r_dying     = [ reg | reg <- read, reg `notElem` written,
+                              not (elementOfUniqSet reg liveregs) ]
+
+            w_dying     = [ reg | reg <- written,
+                             not (elementOfUniqSet reg liveregs) ]
+
+            -- union in the live regs from all the jump destinations of this
+            -- instruction.
+            targets      = jumpDestsOfInstr instr -- where we go from here
+            not_a_branch = null targets
+
+            targetLiveRegs target
+                  = case mapLookup target blockmap of
+                                Just ra -> ra
+                                Nothing -> emptyRegSet
+
+            live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
+
+            liveregs_br = liveregs1 `unionUniqSets` live_from_branch
+
+            -- registers that are live only in the branch targets should
+            -- be listed as dying here.
+            live_branch_only = live_from_branch `minusUniqSet` liveregs
+            r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
+                                             live_branch_only)
+                          -- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegClass.hs
@@ -0,0 +1,32 @@
+-- | An architecture independent description of a register's class.
+module RegClass
+        ( RegClass (..) )
+
+where
+
+import GhcPrelude
+
+import  Outputable
+import  Unique
+
+
+-- | The class of a register.
+--      Used in the register allocator.
+--      We treat all registers in a class as being interchangable.
+--
+data RegClass
+        = RcInteger
+        | RcFloat
+        | RcDouble
+        deriving Eq
+
+
+instance Uniquable RegClass where
+    getUnique RcInteger = mkRegClassUnique 0
+    getUnique RcFloat   = mkRegClassUnique 1
+    getUnique RcDouble  = mkRegClassUnique 2
+
+instance Outputable RegClass where
+    ppr RcInteger       = Outputable.text "I"
+    ppr RcFloat         = Outputable.text "F"
+    ppr RcDouble        = Outputable.text "D"
diff --git a/compiler/nativeGen/SPARC/AddrMode.hs b/compiler/nativeGen/SPARC/AddrMode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/AddrMode.hs
@@ -0,0 +1,44 @@
+
+module SPARC.AddrMode (
+        AddrMode(..),
+        addrOffset
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Imm
+import SPARC.Base
+import Reg
+
+-- addressing modes ------------------------------------------------------------
+
+-- | Represents a memory address in an instruction.
+--      Being a RISC machine, the SPARC addressing modes are very regular.
+--
+data AddrMode
+        = AddrRegReg    Reg Reg         -- addr = r1 + r2
+        | AddrRegImm    Reg Imm         -- addr = r1 + imm
+
+
+-- | Add an integer offset to the address in an AddrMode.
+--
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
+addrOffset addr off
+  = case addr of
+      AddrRegImm r (ImmInt n)
+       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))
+       | otherwise     -> Nothing
+       where n2 = n + off
+
+      AddrRegImm r (ImmInteger n)
+       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
+       | otherwise     -> Nothing
+       where n2 = n + toInteger off
+
+      AddrRegReg r (RegReal (RealRegSingle 0))
+       | fits13Bits off -> Just (AddrRegImm r (ImmInt off))
+       | otherwise     -> Nothing
+
+      _ -> Nothing
diff --git a/compiler/nativeGen/SPARC/Base.hs b/compiler/nativeGen/SPARC/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Base.hs
@@ -0,0 +1,77 @@
+
+-- | Bits and pieces on the bottom of the module dependency tree.
+--      Also import the required constants, so we know what we're using.
+--
+--      In the interests of cross-compilation, we want to free ourselves
+--      from the autoconf generated modules like main/Constants
+
+module SPARC.Base (
+        wordLength,
+        wordLengthInBits,
+        spillAreaLength,
+        spillSlotSize,
+        extraStackArgsHere,
+        fits13Bits,
+        is32BitInteger,
+        largeOffsetError
+)
+
+where
+
+import GhcPrelude
+
+import DynFlags
+import Panic
+
+import Data.Int
+
+
+-- On 32 bit SPARC, pointers are 32 bits.
+wordLength :: Int
+wordLength = 4
+
+wordLengthInBits :: Int
+wordLengthInBits
+        = wordLength * 8
+
+-- Size of the available spill area
+spillAreaLength :: DynFlags -> Int
+spillAreaLength
+        = rESERVED_C_STACK_BYTES
+
+-- | We need 8 bytes because our largest registers are 64 bit.
+spillSlotSize :: Int
+spillSlotSize = 8
+
+
+-- | We (allegedly) put the first six C-call arguments in registers;
+--      where do we start putting the rest of them?
+extraStackArgsHere :: Int
+extraStackArgsHere = 23
+
+
+{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}
+-- | Check whether an offset is representable with 13 bits.
+fits13Bits :: Integral a => a -> Bool
+fits13Bits x = x >= -4096 && x < 4096
+
+-- | Check whether an integer will fit in 32 bits.
+--      A CmmInt is intended to be truncated to the appropriate
+--      number of bits, so here we truncate it to Int64.  This is
+--      important because e.g. -1 as a CmmInt might be either
+--      -1 or 18446744073709551615.
+--
+is32BitInteger :: Integer -> Bool
+is32BitInteger i
+        = i64 <= 0x7fffffff && i64 >= -0x80000000
+        where i64 = fromIntegral i :: Int64
+
+
+-- | Sadness.
+largeOffsetError :: (Show a) => a -> b
+largeOffsetError i
+  = panic ("ERROR: SPARC native-code generator cannot handle large offset ("
+                ++ show i ++ ");\nprobably because of large constant data structures;" ++
+                "\nworkaround: use -fllvm on this module.\n")
+
+
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -0,0 +1,695 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2013
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GADTs #-}
+module SPARC.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        InstrBlock
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "../includes/MachDeps.h"
+
+-- NCG stuff:
+import GhcPrelude
+
+import SPARC.Base
+import SPARC.CodeGen.Sanity
+import SPARC.CodeGen.Amode
+import SPARC.CodeGen.CondCode
+import SPARC.CodeGen.Gen64
+import SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.Ppr        ()
+import SPARC.Instr
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Regs
+import SPARC.Stack
+import Instruction
+import Format
+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat )
+
+-- Our intermediate code:
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch
+import Hoopl.Block
+import Hoopl.Graph
+import PIC
+import Reg
+import CLabel
+import CPrim
+
+-- The rest:
+import BasicTypes
+import DynFlags
+import FastString
+import OrdList
+import Outputable
+import Platform
+
+import Control.Monad    ( mapAndUnzipM )
+
+-- | Top level code generation
+cmmTopCodeGen :: RawCmmDecl
+              -> NatM [NatCmmDecl CmmStatics Instr]
+
+cmmTopCodeGen (CmmProc info lab live graph)
+ = do let blocks = toBlockListEntryFirst graph
+      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+
+      let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+      let tops = proc : concat statics
+
+      return tops
+
+cmmTopCodeGen (CmmData sec dat) = do
+  return [CmmData sec dat]  -- no translation, we just use CmmStatic
+
+
+-- | Do code generation on a single block of CMM code.
+--      code generation may introduce new basic block boundaries, which
+--      are indicated by the NEWBLOCK instruction.  We must split up the
+--      instruction stream into basic blocks again.  Also, we extract
+--      LDATAs here too.
+basicBlockCodeGen :: CmmBlock
+                  -> NatM ( [NatBasicBlock Instr]
+                          , [NatCmmDecl CmmStatics Instr])
+
+basicBlockCodeGen block = do
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
+  let
+        (top,other_blocks,statics)
+                = foldrOL mkBlocks ([],[],[]) instrs
+
+        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+          = ([], BasicBlock id instrs : blocks, statics)
+
+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+          = (instrs, blocks, CmmData sec dat:statics)
+
+        mkBlocks instr (instrs,blocks,statics)
+          = (instr:instrs, blocks, statics)
+
+        -- do intra-block sanity checking
+        blocksChecked
+                = map (checkBlock block)
+                $ BasicBlock id top : other_blocks
+
+  return (blocksChecked, statics)
+
+
+-- | Convert some Cmm statements to SPARC instructions.
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs stmts
+   = do instrss <- mapM stmtToInstrs stmts
+        return (concatOL instrss)
+
+
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
+stmtToInstrs stmt = do
+  dflags <- getDynFlags
+  case stmt of
+    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
+
+    CmmAssign reg src
+      | isFloatType ty  -> assignReg_FltCode format reg src
+      | isWord64 ty     -> assignReg_I64Code        reg src
+      | otherwise       -> assignReg_IntCode format reg src
+        where ty = cmmRegType dflags reg
+              format = cmmTypeFormat ty
+
+    CmmStore addr src
+      | isFloatType ty  -> assignMem_FltCode format addr src
+      | isWord64 ty     -> assignMem_I64Code      addr src
+      | otherwise       -> assignMem_IntCode format addr src
+        where ty = cmmExprType dflags src
+              format = cmmTypeFormat ty
+
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall target result_regs args
+
+    CmmBranch   id              -> genBranch id
+    CmmCondBranch arg true false _ -> do
+      b1 <- genCondJump true arg
+      b2 <- genBranch false
+      return (b1 `appOL` b2)
+    CmmSwitch arg ids   -> do dflags <- getDynFlags
+                              genSwitch dflags arg ids
+    CmmCall { cml_target = arg } -> genJump arg
+
+    _
+     -> panic "stmtToInstrs: statement should have been cps'd away"
+
+
+{-
+Now, given a tree (the argument to a CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = blockLbl blockid
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_IntCode pk addr src = do
+    (srcReg, code) <- getSomeReg src
+    Amode dstAddr addr_code <- getAmode addr
+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
+
+
+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode _ reg src = do
+    dflags <- getDynFlags
+    r <- getRegister src
+    let dst = getRegisterReg (targetPlatform dflags) reg
+    return $ case r of
+        Any _ code         -> code dst
+        Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
+
+
+
+-- Floating point assignment to memory
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_FltCode pk addr src = do
+    dflags <- getDynFlags
+    Amode dst__2 code1 <- getAmode addr
+    (src__2, code2) <- getSomeReg src
+    tmp1 <- getNewRegNat pk
+    let
+        pk__2   = cmmExprType dflags src
+        code__2 = code1 `appOL` code2 `appOL`
+            if   formatToWidth pk == typeWidth pk__2
+            then unitOL (ST pk src__2 dst__2)
+            else toOL   [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1
+                        , ST    pk tmp1 dst__2]
+    return code__2
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode pk dstCmmReg srcCmmExpr = do
+    dflags <- getDynFlags
+    let platform = targetPlatform dflags
+    srcRegister <- getRegister srcCmmExpr
+    let dstReg  = getRegisterReg platform dstCmmReg
+
+    return $ case srcRegister of
+        Any _ code                  -> code dstReg
+        Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
+
+
+
+
+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
+
+genJump (CmmLit (CmmLabel lbl))
+  = return (toOL [CALL (Left target) 0 True, NOP])
+  where
+    target = ImmCLbl lbl
+
+genJump tree
+  = do
+        (target, code) <- getSomeReg tree
+        return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+
+SPARC: First, we have to ensure that the condition codes are set
+according to the supplied comparison operation.  We generate slightly
+different code for floating point comparisons, because a floating
+point operation cannot directly precede a @BF@.  We assume the worst
+and fill that slot with a @NOP@.
+
+SPARC: Do not fill the delay slots here; you will confuse the register
+allocator.
+-}
+
+
+genCondJump
+    :: BlockId      -- the branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> NatM InstrBlock
+
+
+
+genCondJump bid bool = do
+  CondCode is_float cond code <- getCondCode bool
+  return (
+       code `appOL`
+       toOL (
+         if   is_float
+         then [NOP, BF cond False bid, NOP]
+         else [BI cond False bid, NOP]
+       )
+    )
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch dflags expr targets
+        | positionIndependent dflags
+        = error "MachCodeGen: sparc genSwitch PIC not finished\n"
+
+        | otherwise
+        = do    (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)
+
+                base_reg        <- getNewRegNat II32
+                offset_reg      <- getNewRegNat II32
+                dst             <- getNewRegNat II32
+
+                label           <- getNewLabelNat
+
+                return $ e_code `appOL`
+                 toOL
+                        [ -- load base of jump table
+                          SETHI (HI (ImmCLbl label)) base_reg
+                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
+
+                        -- the addrs in the table are 32 bits wide..
+                        , SLL   e_reg (RIImm $ ImmInt 2) offset_reg
+
+                        -- load and jump to the destination
+                        , LD      II32 (AddrRegReg base_reg offset_reg) dst
+                        , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
+                        , NOP ]
+  where (offset, ids) = switchTargetsToTable targets
+
+generateJumpTableForInstr :: DynFlags -> Instr
+                          -> Maybe (NatCmmDecl CmmStatics Instr)
+generateJumpTableForInstr dflags (JMP_TBL _ ids label) =
+  let jumpTable = map (jumpTableEntry dflags) ids
+  in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable))
+generateJumpTableForInstr _ _ = Nothing
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating C calls
+
+{-
+   Now the biggest nightmare---calls.  Most of the nastiness is buried in
+   @get_arg@, which moves the arguments to the correct registers/stack
+   locations.  Apart from that, the code is easy.
+
+   The SPARC calling convention is an absolute
+   nightmare.  The first 6x32 bits of arguments are mapped into
+   %o0 through %o5, and the remaining arguments are dumped to the
+   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
+
+   If we have to put args on the stack, move %o6==%sp down by
+   the number of words to go on the stack, to ensure there's enough space.
+
+   According to Fraser and Hanson's lcc book, page 478, fig 17.2,
+   16 words above the stack pointer is a word for the address of
+   a structure return value.  I use this as a temporary location
+   for moving values from float to int regs.  Certainly it isn't
+   safe to put anything in the 16 words starting at %sp, since
+   this area can get trashed at any time due to window overflows
+   caused by signal handlers.
+
+   A final complication (if the above isn't enough) is that
+   we can't blithely calculate the arguments one by one into
+   %o0 .. %o5.  Consider the following nested calls:
+
+       fff a (fff b c)
+
+   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
+   the inner call will itself use %o0, which trashes the value put there
+   in preparation for the outer call.  Upshot: we need to calculate the
+   args into temporary regs, and move those to arg regs or onto the
+   stack only immediately prior to the call proper.  Sigh.
+-}
+
+genCCall
+    :: ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+
+
+-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream
+-- are guaranteed to take place before writes afterwards (unlike on PowerPC).
+-- Ref: Section 8.4 of the SPARC V9 Architecture manual.
+--
+-- In the SPARC case we don't need a barrier.
+--
+genCCall (PrimTarget MO_WriteBarrier) _ _
+ = return $ nilOL
+
+genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
+ = return $ nilOL
+
+genCCall target dest_regs args
+ = do   -- work out the arguments, and assign them to integer regs
+        argcode_and_vregs       <- mapM arg_to_int_vregs args
+        let (argcodes, vregss)  = unzip argcode_and_vregs
+        let vregs               = concat vregss
+
+        let n_argRegs           = length allArgRegs
+        let n_argRegs_used      = min (length vregs) n_argRegs
+
+
+        -- deal with static vs dynamic call targets
+        callinsns <- case target of
+                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->
+                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
+
+                ForeignTarget expr _
+                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr
+                        let dyn_r = case dyn_rs of
+                                      [dyn_r'] -> dyn_r'
+                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
+                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+
+                PrimTarget mop
+                 -> do  res     <- outOfLineMachOp mop
+                        lblOrMopExpr <- case res of
+                                Left lbl -> do
+                                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
+
+                                Right mopExpr -> do
+                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr
+                                        let dyn_r = case dyn_rs of
+                                                      [dyn_r'] -> dyn_r'
+                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
+                                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+
+                        return lblOrMopExpr
+
+        let argcode = concatOL argcodes
+
+        let (move_sp_down, move_sp_up)
+                   = let diff = length vregs - n_argRegs
+                         nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
+                     in  if   nn <= 0
+                         then (nilOL, nilOL)
+                         else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
+
+        let transfer_code
+                = toOL (move_final vregs allArgRegs extraStackArgsHere)
+
+        dflags <- getDynFlags
+        return
+         $      argcode                 `appOL`
+                move_sp_down            `appOL`
+                transfer_code           `appOL`
+                callinsns               `appOL`
+                unitOL NOP              `appOL`
+                move_sp_up              `appOL`
+                assign_code (targetPlatform dflags) dest_regs
+
+
+-- | Generate code to calculate an argument, and move it into one
+--      or two integer vregs.
+arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
+arg_to_int_vregs arg = do dflags <- getDynFlags
+                          arg_to_int_vregs' dflags arg
+
+arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])
+arg_to_int_vregs' dflags arg
+
+        -- If the expr produces a 64 bit int, then we can just use iselExpr64
+        | isWord64 (cmmExprType dflags arg)
+        = do    (ChildCode64 code r_lo) <- iselExpr64 arg
+                let r_hi                = getHiVRegFromLo r_lo
+                return (code, [r_hi, r_lo])
+
+        | otherwise
+        = do    (src, code)     <- getSomeReg arg
+                let pk          = cmmExprType dflags arg
+
+                case cmmTypeFormat pk of
+
+                 -- Load a 64 bit float return value into two integer regs.
+                 FF64 -> do
+                        v1 <- getNewRegNat II32
+                        v2 <- getNewRegNat II32
+
+                        let code2 =
+                                code                            `snocOL`
+                                FMOV FF64 src f0                `snocOL`
+                                ST   FF32  f0 (spRel 16)        `snocOL`
+                                LD   II32  (spRel 16) v1        `snocOL`
+                                ST   FF32  f1 (spRel 16)        `snocOL`
+                                LD   II32  (spRel 16) v2
+
+                        return  (code2, [v1,v2])
+
+                 -- Load a 32 bit float return value into an integer reg
+                 FF32 -> do
+                        v1 <- getNewRegNat II32
+
+                        let code2 =
+                                code                            `snocOL`
+                                ST   FF32  src (spRel 16)       `snocOL`
+                                LD   II32  (spRel 16) v1
+
+                        return (code2, [v1])
+
+                 -- Move an integer return value into its destination reg.
+                 _ -> do
+                        v1 <- getNewRegNat II32
+
+                        let code2 =
+                                code                            `snocOL`
+                                OR False g0 (RIReg src) v1
+
+                        return (code2, [v1])
+
+
+-- | Move args from the integer vregs into which they have been
+--      marshalled, into %o0 .. %o5, and the rest onto the stack.
+--
+move_final :: [Reg] -> [Reg] -> Int -> [Instr]
+
+-- all args done
+move_final [] _ _
+        = []
+
+-- out of aregs; move to stack
+move_final (v:vs) [] offset
+        = ST II32 v (spRel offset)
+        : move_final vs [] (offset+1)
+
+-- move into an arg (%o[0..5]) reg
+move_final (v:vs) (a:az) offset
+        = OR False g0 (RIReg v) a
+        : move_final vs az offset
+
+
+-- | Assign results returned from the call into their
+--      destination regs.
+--
+assign_code :: Platform -> [LocalReg] -> OrdList Instr
+
+assign_code _ [] = nilOL
+
+assign_code platform [dest]
+ = let  rep     = localRegType dest
+        width   = typeWidth rep
+        r_dest  = getRegisterReg platform (CmmLocal dest)
+
+        result
+                | isFloatType rep
+                , W32   <- width
+                = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest
+
+                | isFloatType rep
+                , W64   <- width
+                = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest
+
+                | not $ isFloatType rep
+                , W32   <- width
+                = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest
+
+                | not $ isFloatType rep
+                , W64           <- width
+                , r_dest_hi     <- getHiVRegFromLo r_dest
+                = toOL  [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi
+                        , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]
+
+                | otherwise
+                = panic "SPARC.CodeGen.GenCCall: no match"
+
+   in   result
+
+assign_code _ _
+        = panic "SPARC.CodeGen.GenCCall: no match"
+
+
+
+-- | Generate a call to implement an out-of-line floating point operation
+outOfLineMachOp
+        :: CallishMachOp
+        -> NatM (Either CLabel CmmExpr)
+
+outOfLineMachOp mop
+ = do   let functionName
+                = outOfLineMachOp_table mop
+
+        dflags  <- getDynFlags
+        mopExpr <- cmmMakeDynamicReference dflags CallReference
+                $  mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
+
+        let mopLabelOrExpr
+                = case mopExpr of
+                        CmmLit (CmmLabel lbl)   -> Left lbl
+                        _                       -> Right mopExpr
+
+        return mopLabelOrExpr
+
+
+-- | Decide what C function to use to implement a CallishMachOp
+--
+outOfLineMachOp_table
+        :: CallishMachOp
+        -> FastString
+
+outOfLineMachOp_table mop
+ = case mop of
+        MO_F32_Exp    -> fsLit "expf"
+        MO_F32_Log    -> fsLit "logf"
+        MO_F32_Sqrt   -> fsLit "sqrtf"
+        MO_F32_Fabs   -> unsupported
+        MO_F32_Pwr    -> fsLit "powf"
+
+        MO_F32_Sin    -> fsLit "sinf"
+        MO_F32_Cos    -> fsLit "cosf"
+        MO_F32_Tan    -> fsLit "tanf"
+
+        MO_F32_Asin   -> fsLit "asinf"
+        MO_F32_Acos   -> fsLit "acosf"
+        MO_F32_Atan   -> fsLit "atanf"
+
+        MO_F32_Sinh   -> fsLit "sinhf"
+        MO_F32_Cosh   -> fsLit "coshf"
+        MO_F32_Tanh   -> fsLit "tanhf"
+
+        MO_F32_Asinh  -> fsLit "asinhf"
+        MO_F32_Acosh  -> fsLit "acoshf"
+        MO_F32_Atanh  -> fsLit "atanhf"
+
+        MO_F64_Exp    -> fsLit "exp"
+        MO_F64_Log    -> fsLit "log"
+        MO_F64_Sqrt   -> fsLit "sqrt"
+        MO_F64_Fabs   -> unsupported
+        MO_F64_Pwr    -> fsLit "pow"
+
+        MO_F64_Sin    -> fsLit "sin"
+        MO_F64_Cos    -> fsLit "cos"
+        MO_F64_Tan    -> fsLit "tan"
+
+        MO_F64_Asin   -> fsLit "asin"
+        MO_F64_Acos   -> fsLit "acos"
+        MO_F64_Atan   -> fsLit "atan"
+
+        MO_F64_Sinh   -> fsLit "sinh"
+        MO_F64_Cosh   -> fsLit "cosh"
+        MO_F64_Tanh   -> fsLit "tanh"
+
+        MO_F64_Asinh  -> fsLit "asinh"
+        MO_F64_Acosh  -> fsLit "acosh"
+        MO_F64_Atanh  -> fsLit "atanh"
+
+        MO_UF_Conv w -> fsLit $ word2FloatLabel w
+
+        MO_Memcpy _  -> fsLit "memcpy"
+        MO_Memset _  -> fsLit "memset"
+        MO_Memmove _ -> fsLit "memmove"
+        MO_Memcmp _  -> fsLit "memcmp"
+
+        MO_BSwap w   -> fsLit $ bSwapLabel w
+        MO_BRev w    -> fsLit $ bRevLabel w
+        MO_PopCnt w  -> fsLit $ popCntLabel w
+        MO_Pdep w    -> fsLit $ pdepLabel w
+        MO_Pext w    -> fsLit $ pextLabel w
+        MO_Clz w     -> fsLit $ clzLabel w
+        MO_Ctz w     -> fsLit $ ctzLabel w
+        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
+        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w
+        MO_AtomicRead w -> fsLit $ atomicReadLabel w
+        MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
+
+        MO_S_QuotRem {}  -> unsupported
+        MO_U_QuotRem {}  -> unsupported
+        MO_U_QuotRem2 {} -> unsupported
+        MO_Add2 {}       -> unsupported
+        MO_AddWordC {}   -> unsupported
+        MO_SubWordC {}   -> unsupported
+        MO_AddIntC {}    -> unsupported
+        MO_SubIntC {}    -> unsupported
+        MO_U_Mul2 {}     -> unsupported
+        MO_WriteBarrier  -> unsupported
+        MO_Touch         -> unsupported
+        (MO_Prefetch_Data _) -> unsupported
+    where unsupported = panic ("outOfLineCmmOp: " ++ show mop
+                            ++ " not supported here")
+
diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs
@@ -0,0 +1,74 @@
+module SPARC.CodeGen.Amode (
+        getAmode
+)
+
+where
+
+import GhcPrelude
+
+import {-# SOURCE #-} SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.AddrMode
+import SPARC.Imm
+import SPARC.Instr
+import SPARC.Regs
+import SPARC.Base
+import NCGMonad
+import Format
+
+import Cmm
+
+import OrdList
+
+
+-- | Generate code to reference a memory address.
+getAmode
+        :: CmmExpr      -- ^ expr producing an address
+        -> NatM Amode
+
+getAmode tree@(CmmRegOff _ _)
+    = do dflags <- getDynFlags
+         getAmode (mangleIndexTree dflags tree)
+
+getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])
+  | fits13Bits (-i)
+  = do
+       (reg, code) <- getSomeReg x
+       let
+         off  = ImmInt (-(fromInteger i))
+       return (Amode (AddrRegImm reg off) code)
+
+
+getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])
+  | fits13Bits i
+  = do
+       (reg, code) <- getSomeReg x
+       let
+         off  = ImmInt (fromInteger i)
+       return (Amode (AddrRegImm reg off) code)
+
+getAmode (CmmMachOp (MO_Add _) [x, y])
+  = do
+    (regX, codeX) <- getSomeReg x
+    (regY, codeY) <- getSomeReg y
+    let
+        code = codeX `appOL` codeY
+    return (Amode (AddrRegReg regX regY) code)
+
+getAmode (CmmLit lit)
+  = do
+        let imm__2      = litToImm lit
+        tmp1    <- getNewRegNat II32
+        tmp2    <- getNewRegNat II32
+
+        let code = toOL [ SETHI (HI imm__2) tmp1
+                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]
+
+        return (Amode (AddrRegReg tmp2 g0) code)
+
+getAmode other
+  = do
+       (reg, code) <- getSomeReg other
+       let
+            off  = ImmInt 0
+       return (Amode (AddrRegImm reg off) code)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs
@@ -0,0 +1,119 @@
+module SPARC.CodeGen.Base (
+        InstrBlock,
+        CondCode(..),
+        ChildCode64(..),
+        Amode(..),
+
+        Register(..),
+        setFormatOfRegister,
+
+        getRegisterReg,
+        mangleIndexTree
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Cond
+import SPARC.AddrMode
+import SPARC.Regs
+import Format
+import Reg
+
+import CodeGen.Platform
+import DynFlags
+import Cmm
+import PprCmmExpr ()
+import Platform
+
+import Outputable
+import OrdList
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--      They are really trees of insns to facilitate fast appending, where a
+--      left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock
+        = OrdList Instr
+
+
+-- | Condition codes passed up the tree.
+--
+data CondCode
+        = CondCode Bool Cond InstrBlock
+
+
+-- | a.k.a "Register64"
+--      Reg is the lower 32-bit temporary which contains the result.
+--      Use getHiVRegFromLo to find the other VRegUnique.
+--
+--      Rules of this simplified insn selection game are therefore that
+--      the returned Reg may be modified
+--
+data ChildCode64
+   = ChildCode64
+        InstrBlock
+        Reg
+
+
+-- | Holds code that references a memory address.
+data Amode
+        = Amode
+                -- the AddrMode we can use in the instruction
+                --      that does the real load\/store.
+                AddrMode
+
+                -- other setup code we have to run first before we can use the
+                --      above AddrMode.
+                InstrBlock
+
+
+
+--------------------------------------------------------------------------------
+-- | Code to produce a result into a register.
+--      If the result must go in a specific register, it comes out as Fixed.
+--      Otherwise, the parent can decide which register to put it in.
+--
+data Register
+        = Fixed Format Reg InstrBlock
+        | Any   Format (Reg -> InstrBlock)
+
+
+-- | Change the format field in a Register.
+setFormatOfRegister
+        :: Register -> Format -> Register
+
+setFormatOfRegister reg format
+ = case reg of
+        Fixed _ reg code        -> Fixed format reg code
+        Any _ codefn            -> Any   format codefn
+
+
+--------------------------------------------------------------------------------
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform -> CmmReg -> Reg
+
+getRegisterReg _ (CmmLocal (LocalReg u pk))
+        = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
+
+getRegisterReg platform (CmmGlobal mid)
+  = case globalRegMaybe platform mid of
+        Just reg -> RegReal reg
+        Nothing  -> pprPanic
+                        "SPARC.CodeGen.Base.getRegisterReg: global is in memory"
+                        (ppr $ CmmGlobal mid)
+
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
+
+mangleIndexTree dflags (CmmRegOff reg off)
+        = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+        where width = typeWidth (cmmRegType dflags reg)
+
+mangleIndexTree _ _
+        = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
@@ -0,0 +1,110 @@
+module SPARC.CodeGen.CondCode (
+        getCondCode,
+        condIntCode,
+        condFltCode
+)
+
+where
+
+import GhcPrelude
+
+import {-# SOURCE #-} SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.Instr
+import SPARC.Regs
+import SPARC.Cond
+import SPARC.Imm
+import SPARC.Base
+import NCGMonad
+import Format
+
+import Cmm
+
+import OrdList
+import Outputable
+
+
+getCondCode :: CmmExpr -> NatM CondCode
+getCondCode (CmmMachOp mop [x, y])
+  =
+    case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      MO_F_Lt W32 -> condFltCode LTT x y
+      MO_F_Le W32 -> condFltCode LE  x y
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode LTT x y
+      MO_F_Le W64 -> condFltCode LE  x y
+
+      MO_Eq   _   -> condIntCode EQQ  x y
+      MO_Ne   _   -> condIntCode NE   x y
+
+      MO_S_Gt _   -> condIntCode GTT  x y
+      MO_S_Ge _   -> condIntCode GE   x y
+      MO_S_Lt _   -> condIntCode LTT  x y
+      MO_S_Le _   -> condIntCode LE   x y
+
+      MO_U_Gt _   -> condIntCode GU   x y
+      MO_U_Ge _   -> condIntCode GEU  x y
+      MO_U_Lt _   -> condIntCode LU   x y
+      MO_U_Le _   -> condIntCode LEU  x y
+
+      _           -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))
+
+getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)
+
+
+
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condIntCode cond x (CmmLit (CmmInt y _))
+  | fits13Bits y
+  = do
+       (src1, code) <- getSomeReg x
+       let
+           src2 = ImmInt (fromInteger y)
+           code' = code `snocOL` SUB False True src1 (RIImm src2) g0
+       return (CondCode False cond code')
+
+condIntCode cond x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 = code1 `appOL` code2 `snocOL`
+                  SUB False True src1 (RIReg src2) g0
+    return (CondCode False cond code__2)
+
+
+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condFltCode cond x y = do
+    dflags <- getDynFlags
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    tmp <- getNewRegNat FF64
+    let
+        promote x = FxTOy FF32 FF64 x tmp
+
+        pk1   = cmmExprType dflags x
+        pk2   = cmmExprType dflags y
+
+        code__2 =
+                if pk1 `cmmEqType` pk2 then
+                    code1 `appOL` code2 `snocOL`
+                    FCMP True (cmmTypeFormat pk1) src1 src2
+                else if typeWidth pk1 == W32 then
+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                    FCMP True FF64 tmp src2
+                else
+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                    FCMP True FF64 src1 tmp
+    return (CondCode True cond code__2)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
@@ -0,0 +1,155 @@
+-- | Expand out synthetic instructions into single machine instrs.
+module SPARC.CodeGen.Expand (
+        expandTop
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Regs
+import SPARC.Ppr        ()
+import Instruction
+import Reg
+import Format
+import Cmm
+
+
+import Outputable
+import OrdList
+
+-- | Expand out synthetic instructions in this top level thing
+expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr
+expandTop top@(CmmData{})
+        = top
+
+expandTop (CmmProc info lbl live (ListGraph blocks))
+        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)
+
+
+-- | Expand out synthetic instructions in this block
+expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr
+
+expandBlock (BasicBlock label instrs)
+ = let  instrs_ol       = expandBlockInstrs instrs
+        instrs'         = fromOL instrs_ol
+   in   BasicBlock label instrs'
+
+
+-- | Expand out some instructions
+expandBlockInstrs :: [Instr] -> OrdList Instr
+expandBlockInstrs []    = nilOL
+
+expandBlockInstrs (ii:is)
+ = let  ii_doubleRegs   = remapRegPair ii
+        is_misaligned   = expandMisalignedDoubles ii_doubleRegs
+
+   in   is_misaligned `appOL` expandBlockInstrs is
+
+
+
+-- | In the SPARC instruction set the FP register pairs that are used
+--      to hold 64 bit floats are refered to by just the first reg
+--      of the pair. Remap our internal reg pairs to the appropriate reg.
+--
+--      For example:
+--          ldd [%l1], (%f0 | %f1)
+--
+--      gets mapped to
+--          ldd [$l1], %f0
+--
+remapRegPair :: Instr -> Instr
+remapRegPair instr
+ = let  patchF reg
+         = case reg of
+                RegReal (RealRegSingle _)
+                        -> reg
+
+                RegReal (RealRegPair r1 r2)
+
+                        -- sanity checking
+                        | r1         >= 32
+                        , r1         <= 63
+                        , r1 `mod` 2 == 0
+                        , r2         == r1 + 1
+                        -> RegReal (RealRegSingle r1)
+
+                        | otherwise
+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)
+
+                RegVirtual _
+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)
+
+   in   patchRegsOfInstr instr patchF
+
+
+
+
+-- Expand out 64 bit load/stores into individual instructions to handle
+--      possible double alignment problems.
+--
+--      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.
+--              We might be able to do this faster if we use the UA2007 instr set
+--              instead of restricting ourselves to SPARC V9.
+--
+expandMisalignedDoubles :: Instr -> OrdList Instr
+expandMisalignedDoubles instr
+
+        -- Translate to:
+        --    add g1,g2,g1
+        --    ld  [g1],%fn
+        --    ld  [g1+4],%f(n+1)
+        --    sub g1,g2,g1           -- to restore g1
+        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr
+        =       toOL    [ ADD False False r1 (RIReg r2) r1
+                        , LD  FF32  (AddrRegReg r1 g0)          fReg
+                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)
+                        , SUB False False r1 (RIReg r2) r1 ]
+
+        -- Translate to
+        --    ld  [addr],%fn
+        --    ld  [addr+4],%f(n+1)
+        | LD FF64 addr fReg                     <- instr
+        = let   Just addr'      = addrOffset addr 4
+          in    toOL    [ LD  FF32  addr        fReg
+                        , LD  FF32  addr'       (fRegHi fReg) ]
+
+        -- Translate to:
+        --    add g1,g2,g1
+        --    st  %fn,[g1]
+        --    st  %f(n+1),[g1+4]
+        --    sub g1,g2,g1           -- to restore g1
+        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr
+        =       toOL    [ ADD False False r1 (RIReg r2) r1
+                        , ST  FF32  fReg           (AddrRegReg r1 g0)
+                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))
+                        , SUB False False r1 (RIReg r2) r1 ]
+
+        -- Translate to
+        --    ld  [addr],%fn
+        --    ld  [addr+4],%f(n+1)
+        | ST FF64 fReg addr                     <- instr
+        = let   Just addr'      = addrOffset addr 4
+          in    toOL    [ ST  FF32  fReg           addr
+                        , ST  FF32  (fRegHi fReg)  addr'         ]
+
+        -- some other instr
+        | otherwise
+        = unitOL instr
+
+
+
+-- | The high partner for this float reg.
+fRegHi :: Reg -> Reg
+fRegHi (RegReal (RealRegSingle r1))
+        | r1            >= 32
+        , r1            <= 63
+        , r1 `mod` 2 == 0
+        = (RegReal $ RealRegSingle (r1 + 1))
+
+-- Can't take high partner for non-low reg.
+fRegHi reg
+        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
@@ -0,0 +1,692 @@
+-- | Evaluation of 32 bit values.
+module SPARC.CodeGen.Gen32 (
+        getSomeReg,
+        getRegister
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.CodeGen.CondCode
+import SPARC.CodeGen.Amode
+import SPARC.CodeGen.Gen64
+import SPARC.CodeGen.Base
+import SPARC.Stack
+import SPARC.Instr
+import SPARC.Cond
+import SPARC.AddrMode
+import SPARC.Imm
+import SPARC.Regs
+import SPARC.Base
+import NCGMonad
+import Format
+import Reg
+
+import Cmm
+
+import Control.Monad (liftM)
+import DynFlags
+import OrdList
+import Outputable
+
+-- | The dual to getAnyReg: compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed _ reg code ->
+        return (reg, code)
+
+
+
+-- | Make code to evaluate a 32 bit expression.
+--
+getRegister :: CmmExpr -> NatM Register
+
+getRegister (CmmReg reg)
+  = do dflags <- getDynFlags
+       let platform = targetPlatform dflags
+       return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
+                     (getRegisterReg platform reg) nilOL)
+
+getRegister tree@(CmmRegOff _ _)
+  = do dflags <- getDynFlags
+       getRegister (mangleIndexTree dflags tree)
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+
+-- Load a literal float into a float register.
+--      The actual literal is stored in a new data area, and we load it
+--      at runtime.
+getRegister (CmmLit (CmmFloat f W32)) = do
+
+    -- a label for the new data area
+    lbl <- getNewLabelNat
+    tmp <- getNewRegNat II32
+
+    let code dst = toOL [
+            -- the data area
+            LDATA (Section ReadOnlyData lbl) $ Statics lbl
+                         [CmmStaticLit (CmmFloat f W32)],
+
+            -- load the literal
+            SETHI (HI (ImmCLbl lbl)) tmp,
+            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+
+    return (Any FF32 code)
+
+getRegister (CmmLit (CmmFloat d W64)) = do
+    lbl <- getNewLabelNat
+    tmp <- getNewRegNat II32
+    let code dst = toOL [
+            LDATA (Section ReadOnlyData lbl) $ Statics lbl
+                         [CmmStaticLit (CmmFloat d W64)],
+            SETHI (HI (ImmCLbl lbl)) tmp,
+            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+    return (Any FF64 code)
+
+
+-- Unary machine ops
+getRegister (CmmMachOp mop [x])
+  = case mop of
+        -- Floating point negation -------------------------
+        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x
+        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x
+
+
+        -- Integer negation --------------------------------
+        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x
+        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x
+
+
+        -- Float word size conversion ----------------------
+        MO_FF_Conv W64 W32      -> coerceDbl2Flt x
+        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x
+
+
+        -- Float <-> Signed Int conversion -----------------
+        MO_FS_Conv from to      -> coerceFP2Int from to x
+        MO_SF_Conv from to      -> coerceInt2FP from to x
+
+
+        -- Unsigned integer word size conversions ----------
+
+        -- If it's the same size, then nothing needs to be done.
+        MO_UU_Conv from to
+         | from == to           -> conversionNop (intFormat to)  x
+
+        -- To narrow an unsigned word, mask out the high bits to simulate what would
+        --      happen if we copied the value into a smaller register.
+        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+
+        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8
+        --      case because the only way we can load it is via SETHI, which needs 2 ops.
+        --      Do some shifts to chop out the high bits instead.
+        MO_UU_Conv W32 W16
+         -> do  tmpReg          <- getNewRegNat II32
+                (xReg, xCode)   <- getSomeReg x
+                let code dst
+                        =       xCode
+                        `appOL` toOL
+                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg
+                                , SRL tmpReg (RIImm $ ImmInt 16) dst]
+
+                return  $ Any II32 code
+
+                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))
+
+        -- To widen an unsigned word we don't have to do anything.
+        --      Just leave it in the same register and mark the result as the new size.
+        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x
+        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x
+        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x
+
+
+        -- Signed integer word size conversions ------------
+
+        -- Mask out high bits when narrowing them
+        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))
+
+        -- Sign extend signed words when widening them.
+        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x
+        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x
+        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x
+
+        _                       -> panic ("Unknown unary mach op: " ++ show mop)
+
+
+-- Binary machine ops
+getRegister (CmmMachOp mop [x, y])
+  = case mop of
+      MO_Eq _           -> condIntReg EQQ x y
+      MO_Ne _           -> condIntReg NE x y
+
+      MO_S_Gt _         -> condIntReg GTT x y
+      MO_S_Ge _         -> condIntReg GE x y
+      MO_S_Lt _         -> condIntReg LTT x y
+      MO_S_Le _         -> condIntReg LE x y
+
+      MO_U_Gt W32       -> condIntReg GU  x y
+      MO_U_Ge W32       -> condIntReg GEU x y
+      MO_U_Lt W32       -> condIntReg LU  x y
+      MO_U_Le W32       -> condIntReg LEU x y
+
+      MO_U_Gt W16       -> condIntReg GU  x y
+      MO_U_Ge W16       -> condIntReg GEU x y
+      MO_U_Lt W16       -> condIntReg LU  x y
+      MO_U_Le W16       -> condIntReg LEU x y
+
+      MO_Add W32        -> trivialCode W32 (ADD False False) x y
+      MO_Sub W32        -> trivialCode W32 (SUB False False) x y
+
+      MO_S_MulMayOflo rep -> imulMayOflo rep x y
+
+      MO_S_Quot W32     -> idiv True  False x y
+      MO_U_Quot W32     -> idiv False False x y
+
+      MO_S_Rem  W32     -> irem True  x y
+      MO_U_Rem  W32     -> irem False x y
+
+      MO_F_Eq _         -> condFltReg EQQ x y
+      MO_F_Ne _         -> condFltReg NE x y
+
+      MO_F_Gt _         -> condFltReg GTT x y
+      MO_F_Ge _         -> condFltReg GE x y
+      MO_F_Lt _         -> condFltReg LTT x y
+      MO_F_Le _         -> condFltReg LE x y
+
+      MO_F_Add  w       -> trivialFCode w FADD x y
+      MO_F_Sub  w       -> trivialFCode w FSUB x y
+      MO_F_Mul  w       -> trivialFCode w FMUL x y
+      MO_F_Quot w       -> trivialFCode w FDIV x y
+
+      MO_And rep        -> trivialCode rep (AND False) x y
+      MO_Or  rep        -> trivialCode rep (OR  False) x y
+      MO_Xor rep        -> trivialCode rep (XOR False) x y
+
+      MO_Mul rep        -> trivialCode rep (SMUL False) x y
+
+      MO_Shl rep        -> trivialCode rep SLL  x y
+      MO_U_Shr rep      -> trivialCode rep SRL x y
+      MO_S_Shr rep      -> trivialCode rep SRA x y
+
+      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
+
+getRegister (CmmLoad mem pk) = do
+    Amode src code <- getAmode mem
+    let
+        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst
+    return (Any (cmmTypeFormat pk) code__2)
+
+getRegister (CmmLit (CmmInt i _))
+  | fits13Bits i
+  = let
+        src = ImmInt (fromInteger i)
+        code dst = unitOL (OR False g0 (RIImm src) dst)
+    in
+        return (Any II32 code)
+
+getRegister (CmmLit lit)
+  = let imm = litToImm lit
+        code dst = toOL [
+            SETHI (HI imm) dst,
+            OR False dst (RIImm (LO imm)) dst]
+    in return (Any II32 code)
+
+
+getRegister _
+        = panic "SPARC.CodeGen.Gen32.getRegister: no match"
+
+
+-- | sign extend and widen
+integerExtend
+        :: Width                -- ^ width of source expression
+        -> Width                -- ^ width of result
+        -> CmmExpr              -- ^ source expression
+        -> NatM Register
+
+integerExtend from to expr
+ = do   -- load the expr into some register
+        (reg, e_code)   <- getSomeReg expr
+        tmp             <- getNewRegNat II32
+        let bitCount
+                = case (from, to) of
+                        (W8,  W32)      -> 24
+                        (W16, W32)      -> 16
+                        (W8,  W16)      -> 24
+                        _               -> panic "SPARC.CodeGen.Gen32: no match"
+        let code dst
+                = e_code
+
+                -- local shift word left to load the sign bit
+                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp
+
+                -- arithmetic shift right to sign extend
+                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst
+
+        return (Any (intFormat to) code)
+
+
+-- | For nop word format conversions we set the resulting value to have the
+--      required size, but don't need to generate any actual code.
+--
+conversionNop
+        :: Format -> CmmExpr -> NatM Register
+
+conversionNop new_rep expr
+ = do   e_code <- getRegister expr
+        return (setFormatOfRegister e_code new_rep)
+
+
+
+-- | Generate an integer division instruction.
+idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
+
+-- For unsigned division with a 32 bit numerator,
+--              we can just clear the Y register.
+idiv False cc x y
+ = do
+        (a_reg, a_code)         <- getSomeReg x
+        (b_reg, b_code)         <- getSomeReg y
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ WRY  g0 g0
+                        , UDIV cc a_reg (RIReg b_reg) dst]
+
+        return (Any II32 code)
+
+
+-- For _signed_ division with a 32 bit numerator,
+--              we have to sign extend the numerator into the Y register.
+idiv True cc x y
+ = do
+        (a_reg, a_code)         <- getSomeReg x
+        (b_reg, b_code)         <- getSomeReg y
+
+        tmp                     <- getNewRegNat II32
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend
+                        , SRA  tmp   (RIImm (ImmInt 16)) tmp
+
+                        , WRY  tmp g0
+                        , SDIV cc a_reg (RIReg b_reg) dst]
+
+        return (Any II32 code)
+
+
+-- | Do an integer remainder.
+--
+--       NOTE:  The SPARC v8 architecture manual says that integer division
+--              instructions _may_ generate a remainder, depending on the implementation.
+--              If so it is _recommended_ that the remainder is placed in the Y register.
+--
+--          The UltraSparc 2007 manual says Y is _undefined_ after division.
+--
+--              The SPARC T2 doesn't store the remainder, not sure about the others.
+--              It's probably best not to worry about it, and just generate our own
+--              remainders.
+--
+irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register
+
+-- For unsigned operands:
+--              Division is between a 64 bit numerator and a 32 bit denominator,
+--              so we still have to clear the Y register.
+irem False x y
+ = do
+        (a_reg, a_code) <- getSomeReg x
+        (b_reg, b_code) <- getSomeReg y
+
+        tmp_reg         <- getNewRegNat II32
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ WRY   g0 g0
+                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg
+                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg
+                        , SUB   False False   a_reg (RIReg tmp_reg) dst]
+
+        return  (Any II32 code)
+
+
+
+-- For signed operands:
+--              Make sure to sign extend into the Y register, or the remainder
+--              will have the wrong sign when the numerator is negative.
+--
+--      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
+--              not the full 32. Not sure why this is, something to do with overflow?
+--              If anyone cares enough about the speed of signed remainder they
+--              can work it out themselves (then tell me). -- BL 2009/01/20
+irem True x y
+ = do
+        (a_reg, a_code) <- getSomeReg x
+        (b_reg, b_code) <- getSomeReg y
+
+        tmp1_reg        <- getNewRegNat II32
+        tmp2_reg        <- getNewRegNat II32
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend
+                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend
+                        , WRY   tmp1_reg g0
+
+                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg
+                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg
+                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]
+
+        return (Any II32 code)
+
+
+imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
+imulMayOflo rep a b
+ = do
+        (a_reg, a_code) <- getSomeReg a
+        (b_reg, b_code) <- getSomeReg b
+        res_lo <- getNewRegNat II32
+        res_hi <- getNewRegNat II32
+
+        let shift_amt  = case rep of
+                          W32 -> 31
+                          W64 -> 63
+                          _ -> panic "shift_amt"
+
+        let code dst = a_code `appOL` b_code `appOL`
+                       toOL [
+                           SMUL False a_reg (RIReg b_reg) res_lo,
+                           RDY res_hi,
+                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
+                           SUB False False res_lo (RIReg res_hi) dst
+                        ]
+        return (Any II32 code)
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+trivialCode
+        :: Width
+        -> (Reg -> RI -> Reg -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+
+trivialCode _ instr x (CmmLit (CmmInt y _))
+  | fits13Bits y
+  = do
+      (src1, code) <- getSomeReg x
+      let
+        src2 = ImmInt (fromInteger y)
+        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
+      return (Any II32 code__2)
+
+
+trivialCode _ instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 dst = code1 `appOL` code2 `snocOL`
+                      instr src1 (RIReg src2) dst
+    return (Any II32 code__2)
+
+
+trivialFCode
+        :: Width
+        -> (Format -> Reg -> Reg -> Reg -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+
+trivialFCode pk instr x y = do
+    dflags <- getDynFlags
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    tmp <- getNewRegNat FF64
+    let
+        promote x = FxTOy FF32 FF64 x tmp
+
+        pk1   = cmmExprType dflags x
+        pk2   = cmmExprType dflags y
+
+        code__2 dst =
+                if pk1 `cmmEqType` pk2 then
+                    code1 `appOL` code2 `snocOL`
+                    instr (floatFormat pk) src1 src2 dst
+                else if typeWidth pk1 == W32 then
+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                    instr FF64 tmp src2 dst
+                else
+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                    instr FF64 src1 tmp dst
+    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)
+                code__2)
+
+
+
+trivialUCode
+        :: Format
+        -> (RI -> Reg -> Instr)
+        -> CmmExpr
+        -> NatM Register
+
+trivialUCode format instr x = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `snocOL` instr (RIReg src) dst
+    return (Any format code__2)
+
+
+trivialUFCode
+        :: Format
+        -> (Reg -> Reg -> Instr)
+        -> CmmExpr
+        -> NatM Register
+
+trivialUFCode pk instr x = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `snocOL` instr src dst
+    return (Any pk code__2)
+
+
+
+
+-- Coercions -------------------------------------------------------------------
+
+-- | Coerce a integer value to floating point
+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP width1 width2 x = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `appOL` toOL [
+            ST (intFormat width1) src (spRel (-2)),
+            LD (intFormat width1) (spRel (-2)) dst,
+            FxTOy (intFormat width1) (floatFormat width2) dst dst]
+    return (Any (floatFormat $ width2) code__2)
+
+
+
+-- | Coerce a floating point value to integer
+--
+--   NOTE: On sparc v9 there are no instructions to move a value from an
+--         FP register directly to an int register, so we have to use a load/store.
+--
+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int width1 width2 x
+ = do   let fformat1      = floatFormat width1
+            fformat2      = floatFormat width2
+
+            iformat2      = intFormat   width2
+
+        (fsrc, code)    <- getSomeReg x
+        fdst            <- getNewRegNat fformat2
+
+        let code2 dst
+                =       code
+                `appOL` toOL
+                        -- convert float to int format, leaving it in a float reg.
+                        [ FxTOy fformat1 iformat2 fsrc fdst
+
+                        -- store the int into mem, then load it back to move
+                        --      it into an actual int reg.
+                        , ST    fformat2 fdst (spRel (-2))
+                        , LD    iformat2 (spRel (-2)) dst]
+
+        return (Any iformat2 code2)
+
+
+-- | Coerce a double precision floating point value to single precision.
+coerceDbl2Flt :: CmmExpr -> NatM Register
+coerceDbl2Flt x = do
+    (src, code) <- getSomeReg x
+    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))
+
+
+-- | Coerce a single precision floating point value to double precision
+coerceFlt2Dbl :: CmmExpr -> NatM Register
+coerceFlt2Dbl x = do
+    (src, code) <- getSomeReg x
+    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))
+
+
+
+
+-- Condition Codes -------------------------------------------------------------
+--
+-- Evaluate a comparison, and get the result into a register.
+--
+-- Do not fill the delay slots here. you will confuse the register allocator.
+--
+condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `appOL` toOL [
+            SUB False True g0 (RIReg src) g0,
+            SUB True False g0 (RIImm (ImmInt (-1))) dst]
+    return (Any II32 code__2)
+
+condIntReg EQQ x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 dst = code1 `appOL` code2 `appOL` toOL [
+            XOR False src1 (RIReg src2) dst,
+            SUB False True g0 (RIReg dst) g0,
+            SUB True False g0 (RIImm (ImmInt (-1))) dst]
+    return (Any II32 code__2)
+
+condIntReg NE x (CmmLit (CmmInt 0 _)) = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `appOL` toOL [
+            SUB False True g0 (RIReg src) g0,
+            ADD True False g0 (RIImm (ImmInt 0)) dst]
+    return (Any II32 code__2)
+
+condIntReg NE x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 dst = code1 `appOL` code2 `appOL` toOL [
+            XOR False src1 (RIReg src2) dst,
+            SUB False True g0 (RIReg dst) g0,
+            ADD True False g0 (RIImm (ImmInt 0)) dst]
+    return (Any II32 code__2)
+
+condIntReg cond x y = do
+    bid1 <- liftM (\a -> seq a a) getBlockIdNat
+    bid2 <- liftM (\a -> seq a a) getBlockIdNat
+    CondCode _ cond cond_code <- condIntCode cond x y
+    let
+        code__2 dst
+         =      cond_code
+          `appOL` toOL
+                [ BI cond False bid1
+                , NOP
+
+                , OR False g0 (RIImm (ImmInt 0)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid1
+                , OR False g0 (RIImm (ImmInt 1)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid2]
+
+    return (Any II32 code__2)
+
+
+condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+condFltReg cond x y = do
+    bid1 <- liftM (\a -> seq a a) getBlockIdNat
+    bid2 <- liftM (\a -> seq a a) getBlockIdNat
+
+    CondCode _ cond cond_code <- condFltCode cond x y
+    let
+        code__2 dst
+         =      cond_code
+          `appOL` toOL
+                [ NOP
+                , BF cond False bid1
+                , NOP
+
+                , OR False g0 (RIImm (ImmInt 0)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid1
+                , OR False g0 (RIImm (ImmInt 1)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid2 ]
+
+    return (Any II32 code__2)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot
@@ -0,0 +1,16 @@
+
+module SPARC.CodeGen.Gen32 (
+        getSomeReg,
+        getRegister
+)
+
+where
+
+import SPARC.CodeGen.Base
+import NCGMonad
+import Reg
+
+import Cmm
+
+getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)
+getRegister :: CmmExpr -> NatM Register
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
@@ -0,0 +1,216 @@
+-- | Evaluation of 64 bit values on 32 bit platforms.
+module SPARC.CodeGen.Gen64 (
+        assignMem_I64Code,
+        assignReg_I64Code,
+        iselExpr64
+)
+
+where
+
+import GhcPrelude
+
+import {-# SOURCE #-} SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.CodeGen.Amode
+import SPARC.Regs
+import SPARC.AddrMode
+import SPARC.Imm
+import SPARC.Instr
+import SPARC.Ppr()
+import NCGMonad
+import Instruction
+import Format
+import Reg
+
+import Cmm
+
+import DynFlags
+import OrdList
+import Outputable
+
+-- | Code to assign a 64 bit value to memory.
+assignMem_I64Code
+        :: CmmExpr              -- ^ expr producing the destination address
+        -> CmmExpr              -- ^ expr producing the source value.
+        -> NatM InstrBlock
+
+assignMem_I64Code addrTree valueTree
+ = do
+     ChildCode64 vcode rlo      <- iselExpr64 valueTree
+
+     (src, acode) <- getSomeReg addrTree
+     let
+         rhi = getHiVRegFromLo rlo
+
+         -- Big-endian store
+         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))
+         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))
+
+         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo
+
+{-     pprTrace "assignMem_I64Code"
+        (vcat   [ text "addrTree:  " <+> ppr addrTree
+                , text "valueTree: " <+> ppr valueTree
+                , text "vcode:"
+                , vcat $ map ppr $ fromOL vcode
+                , text ""
+                , text "acode:"
+                , vcat $ map ppr $ fromOL acode ])
+       $ -}
+     return code
+
+
+-- | Code to assign a 64 bit value to a register.
+assignReg_I64Code
+        :: CmmReg               -- ^ the destination register
+        -> CmmExpr              -- ^ expr producing the source value
+        -> NatM InstrBlock
+
+assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree
+ = do
+     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+     let
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = mkMOV r_src_lo r_dst_lo
+         mov_hi = mkMOV r_src_hi r_dst_hi
+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+
+     return (vcode `snocOL` mov_hi `snocOL` mov_lo)
+
+assignReg_I64Code _ _
+   = panic "assignReg_I64Code(sparc): invalid lvalue"
+
+
+
+
+-- | Get the value of an expression into a 64 bit register.
+
+iselExpr64 :: CmmExpr -> NatM ChildCode64
+
+-- Load a 64 bit word
+iselExpr64 (CmmLoad addrTree ty)
+ | isWord64 ty
+ = do   Amode amode addr_code   <- getAmode addrTree
+        let result
+
+                | AddrRegReg r1 r2      <- amode
+                = do    rlo     <- getNewRegNat II32
+                        tmp     <- getNewRegNat II32
+                        let rhi = getHiVRegFromLo rlo
+
+                        return  $ ChildCode64
+                                (        addr_code
+                                `appOL`  toOL
+                                         [ ADD False False r1 (RIReg r2) tmp
+                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi
+                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])
+                                rlo
+
+                | AddrRegImm r1 (ImmInt i) <- amode
+                = do    rlo     <- getNewRegNat II32
+                        let rhi = getHiVRegFromLo rlo
+
+                        return  $ ChildCode64
+                                (        addr_code
+                                `appOL`  toOL
+                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi
+                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])
+                                rlo
+
+                | otherwise
+                = panic "SPARC.CodeGen.Gen64: no match"
+
+        result
+
+
+-- Add a literal to a 64 bit integer
+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])
+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
+        let r1_hi       = getHiVRegFromLo r1_lo
+
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    =  getHiVRegFromLo r_dst_lo
+
+        let code =      code1
+                `appOL` toOL
+                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo
+                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+
+-- Addition of II64
+iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])
+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
+        let r1_hi       = getHiVRegFromLo r1_lo
+
+        ChildCode64 code2 r2_lo <- iselExpr64 e2
+        let r2_hi       = getHiVRegFromLo r2_lo
+
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        let code =      code1
+                `appOL` code2
+                `appOL` toOL
+                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo
+                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))
+ | isWord64 ty
+ = do
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_lo = RegVirtual $ mkVirtualReg uq II32
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = mkMOV r_src_lo r_dst_lo
+         mov_hi = mkMOV r_src_hi r_dst_hi
+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+     return (
+            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo
+         )
+
+-- Convert something into II64
+iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])
+ = do
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        -- compute expr and load it into r_dst_lo
+        (a_reg, a_code) <- getSomeReg expr
+
+        dflags <- getDynFlags
+        let platform = targetPlatform dflags
+            code        = a_code
+                `appOL` toOL
+                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits
+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+-- only W32 supported for now
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])
+ = do
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        -- compute expr and load it into r_dst_lo
+        (a_reg, a_code) <- getSomeReg expr
+
+        dflags          <- getDynFlags
+        let platform    = targetPlatform dflags
+            code        = a_code
+                `appOL` toOL
+                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi
+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(sparc)" (ppr expr)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
@@ -0,0 +1,69 @@
+-- | One ounce of sanity checking is worth 10000000000000000 ounces
+-- of staring blindly at assembly code trying to find the problem..
+module SPARC.CodeGen.Sanity (
+        checkBlock
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Ppr        ()
+import Instruction
+
+import Cmm
+
+import Outputable
+
+
+-- | Enforce intra-block invariants.
+--
+checkBlock :: CmmBlock
+           -> NatBasicBlock Instr
+           -> NatBasicBlock Instr
+
+checkBlock cmm block@(BasicBlock _ instrs)
+        | checkBlockInstrs instrs
+        = block
+
+        | otherwise
+        = pprPanic
+                ("SPARC.CodeGen: bad block\n")
+                ( vcat  [ text " -- cmm -----------------\n"
+                        , ppr cmm
+                        , text " -- native code ---------\n"
+                        , ppr block ])
+
+
+checkBlockInstrs :: [Instr] -> Bool
+checkBlockInstrs ii
+
+        -- An unconditional jumps end the block.
+        --      There must be an unconditional jump in the block, otherwise
+        --      the register liveness determinator will get the liveness
+        --      information wrong.
+        --
+        --      If the block ends with a cmm call that never returns
+        --      then there can be unreachable instructions after the jump,
+        --      but we don't mind here.
+        --
+        | instr : NOP : _       <- ii
+        , isUnconditionalJump instr
+        = True
+
+        -- All jumps must have a NOP in their branch delay slot.
+        --      The liveness determinator and register allocators aren't smart
+        --      enough to handle branch delay slots.
+        --
+        | instr : NOP : is      <- ii
+        , isJumpishInstr instr
+        = checkBlockInstrs is
+
+        -- keep checking
+        | _:i2:is               <- ii
+        = checkBlockInstrs (i2:is)
+
+        -- this block is no good
+        | otherwise
+        = False
diff --git a/compiler/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Cond.hs
@@ -0,0 +1,54 @@
+module SPARC.Cond (
+        Cond(..),
+        condUnsigned,
+        condToSigned,
+        condToUnsigned
+)
+
+where
+
+import GhcPrelude
+
+-- | Branch condition codes.
+data Cond
+        = ALWAYS
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        | NEG
+        | NEVER
+        | POS
+        | VC
+        | VS
+        deriving Eq
+
+
+condUnsigned :: Cond -> Bool
+condUnsigned GU  = True
+condUnsigned LU  = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _   = False
+
+
+condToSigned :: Cond -> Cond
+condToSigned GU  = GTT
+condToSigned LU  = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x   = x
+
+
+condToUnsigned :: Cond -> Cond
+condToUnsigned GTT = GU
+condToUnsigned LTT = LU
+condToUnsigned GE  = GEU
+condToUnsigned LE  = LEU
+condToUnsigned x   = x
diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Imm.hs
@@ -0,0 +1,67 @@
+module SPARC.Imm (
+        -- immediate values
+        Imm(..),
+        strImmLit,
+        litToImm
+)
+
+where
+
+import GhcPrelude
+
+import Cmm
+import CLabel
+
+import Outputable
+
+-- | An immediate value.
+--      Not all of these are directly representable by the machine.
+--      Things like ImmLit are slurped out and put in a data segment instead.
+--
+data Imm
+        = ImmInt        Int
+
+        -- Sigh.
+        | ImmInteger    Integer
+
+        -- AbstractC Label (with baggage)
+        | ImmCLbl       CLabel
+
+        -- Simple string
+        | ImmLit        SDoc
+        | ImmIndex      CLabel Int
+        | ImmFloat      Rational
+        | ImmDouble     Rational
+
+        | ImmConstantSum  Imm Imm
+        | ImmConstantDiff Imm Imm
+
+        | LO    Imm
+        | HI    Imm
+
+
+-- | Create a ImmLit containing this string.
+strImmLit :: String -> Imm
+strImmLit s = ImmLit (text s)
+
+
+-- | Convert a CmmLit to an Imm.
+--      Narrow to the width: a CmmInt might be out of
+--      range, but we assume that ImmInteger only contains
+--      in-range values.  A signed value should be fine here.
+--
+litToImm :: CmmLit -> Imm
+litToImm lit
+ = case lit of
+        CmmInt i w              -> ImmInteger (narrowS w i)
+        CmmFloat f W32          -> ImmFloat f
+        CmmFloat f W64          -> ImmDouble f
+        CmmLabel l              -> ImmCLbl l
+        CmmLabelOff l off       -> ImmIndex l off
+
+        CmmLabelDiffOff l1 l2 off _
+         -> ImmConstantSum
+                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+                (ImmInt off)
+
+        _               -> panic "SPARC.Regs.litToImm: no match"
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -0,0 +1,482 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module SPARC.Instr (
+        RI(..),
+        riZero,
+
+        fpRelEA,
+        moveSp,
+
+        isUnconditionalJump,
+
+        Instr(..),
+        maxSpillSlots
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Stack
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Cond
+import SPARC.Regs
+import SPARC.Base
+import TargetReg
+import Instruction
+import RegClass
+import Reg
+import Format
+
+import CLabel
+import CodeGen.Platform
+import BlockId
+import DynFlags
+import Cmm
+import FastString
+import Outputable
+import Platform
+
+
+-- | Register or immediate
+data RI
+        = RIReg Reg
+        | RIImm Imm
+
+-- | Check if a RI represents a zero value.
+--      - a literal zero
+--      - register %g0, which is always zero.
+--
+riZero :: RI -> Bool
+riZero (RIImm (ImmInt 0))                       = True
+riZero (RIImm (ImmInteger 0))                   = True
+riZero (RIReg (RegReal (RealRegSingle 0)))      = True
+riZero _                                        = False
+
+
+-- | Calculate the effective address which would be used by the
+--      corresponding fpRel sequence.
+fpRelEA :: Int -> Reg -> Instr
+fpRelEA n dst
+   = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst
+
+
+-- | Code to shift the stack pointer by n words.
+moveSp :: Int -> Instr
+moveSp n
+   = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp
+
+-- | An instruction that will cause the one after it never to be exectuted
+isUnconditionalJump :: Instr -> Bool
+isUnconditionalJump ii
+ = case ii of
+        CALL{}          -> True
+        JMP{}           -> True
+        JMP_TBL{}       -> True
+        BI ALWAYS _ _   -> True
+        BF ALWAYS _ _   -> True
+        _               -> False
+
+
+-- | instance for sparc instruction set
+instance Instruction Instr where
+        regUsageOfInstr         = sparc_regUsageOfInstr
+        patchRegsOfInstr        = sparc_patchRegsOfInstr
+        isJumpishInstr          = sparc_isJumpishInstr
+        jumpDestsOfInstr        = sparc_jumpDestsOfInstr
+        patchJumpInstr          = sparc_patchJumpInstr
+        mkSpillInstr            = sparc_mkSpillInstr
+        mkLoadInstr             = sparc_mkLoadInstr
+        takeDeltaInstr          = sparc_takeDeltaInstr
+        isMetaInstr             = sparc_isMetaInstr
+        mkRegRegMoveInstr       = sparc_mkRegRegMoveInstr
+        takeRegRegMoveInstr     = sparc_takeRegRegMoveInstr
+        mkJumpInstr             = sparc_mkJumpInstr
+        mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"
+        mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"
+
+
+-- | SPARC instruction set.
+--      Not complete. This is only the ones we need.
+--
+data Instr
+
+        -- meta ops --------------------------------------------------
+        -- comment pseudo-op
+        = COMMENT FastString
+
+        -- some static data spat out during code generation.
+        -- Will be extracted before pretty-printing.
+        | LDATA   Section CmmStatics
+
+        -- Start a new basic block.  Useful during codegen, removed later.
+        -- Preceding instruction should be a jump, as per the invariants
+        -- for a BasicBlock (see Cmm).
+        | NEWBLOCK BlockId
+
+        -- specify current stack offset for benefit of subsequent passes.
+        | DELTA   Int
+
+        -- real instrs -----------------------------------------------
+        -- Loads and stores.
+        | LD            Format AddrMode Reg             -- format, src, dst
+        | ST            Format Reg AddrMode             -- format, src, dst
+
+        -- Int Arithmetic.
+        --      x:   add/sub with carry bit.
+        --              In SPARC V9 addx and friends were renamed addc.
+        --
+        --      cc:  modify condition codes
+        --
+        | ADD           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst
+        | SUB           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst
+
+        | UMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+        | SMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+
+
+        -- The SPARC divide instructions perform 64bit by 32bit division
+        --   The Y register is xored into the first operand.
+
+        --   On _some implementations_ the Y register is overwritten by
+        --   the remainder, so we have to make sure it is 0 each time.
+
+        --   dst <- ((Y `shiftL` 32) `or` src1) `div` src2
+        | UDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+        | SDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+
+        | RDY           Reg                             -- move contents of Y register to reg
+        | WRY           Reg  Reg                        -- Y <- src1 `xor` src2
+
+        -- Logic operations.
+        | AND           Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | ANDN          Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | OR            Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | ORN           Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | XOR           Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | XNOR          Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | SLL           Reg RI Reg                      -- src1, src2, dst
+        | SRL           Reg RI Reg                      -- src1, src2, dst
+        | SRA           Reg RI Reg                      -- src1, src2, dst
+
+        -- Load immediates.
+        | SETHI         Imm Reg                         -- src, dst
+
+        -- Do nothing.
+        -- Implemented by the assembler as SETHI 0, %g0, but worth an alias
+        | NOP
+
+        -- Float Arithmetic.
+        -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single
+        -- instructions right up until we spit them out.
+        --
+        | FABS          Format Reg Reg                  -- src dst
+        | FADD          Format Reg Reg Reg              -- src1, src2, dst
+        | FCMP          Bool Format Reg Reg             -- exception?, src1, src2, dst
+        | FDIV          Format Reg Reg Reg              -- src1, src2, dst
+        | FMOV          Format Reg Reg                  -- src, dst
+        | FMUL          Format Reg Reg Reg              -- src1, src2, dst
+        | FNEG          Format Reg Reg                  -- src, dst
+        | FSQRT         Format Reg Reg                  -- src, dst
+        | FSUB          Format Reg Reg Reg              -- src1, src2, dst
+        | FxTOy         Format Format Reg Reg           -- src, dst
+
+        -- Jumping around.
+        | BI            Cond Bool BlockId               -- cond, annul?, target
+        | BF            Cond Bool BlockId               -- cond, annul?, target
+
+        | JMP           AddrMode                        -- target
+
+        -- With a tabled jump we know all the possible destinations.
+        -- We also need this info so we can work out what regs are live across the jump.
+        --
+        | JMP_TBL       AddrMode [Maybe BlockId] CLabel
+
+        | CALL          (Either Imm Reg) Int Bool       -- target, args, terminal
+
+
+-- | regUsage returns the sets of src and destination registers used
+--      by a particular instruction.  Machine registers that are
+--      pre-allocated to stgRegs are filtered out, because they are
+--      uninteresting from a register allocation standpoint.  (We wouldn't
+--      want them to end up on the free list!)  As far as we are concerned,
+--      the fixed registers simply don't exist (for allocation purposes,
+--      anyway).
+
+--      regUsage doesn't need to do any trickery for jumps and such.  Just
+--      state precisely the regs read and written by that insn.  The
+--      consequences of control flow transfers, as far as register
+--      allocation goes, are taken care of by the register allocator.
+--
+sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage
+sparc_regUsageOfInstr platform instr
+ = case instr of
+    LD    _ addr reg            -> usage (regAddr addr,         [reg])
+    ST    _ reg addr            -> usage (reg : regAddr addr,   [])
+    ADD   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SUB   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    UMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    UDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    RDY       rd                -> usage ([],                   [rd])
+    WRY       r1 r2             -> usage ([r1, r2],             [])
+    AND     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    ANDN    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    OR      _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    ORN     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    XOR     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    XNOR    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SLL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SRL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SRA       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SETHI   _ reg               -> usage ([],                   [reg])
+    FABS    _ r1 r2             -> usage ([r1],                 [r2])
+    FADD    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FCMP    _ _  r1 r2          -> usage ([r1, r2],             [])
+    FDIV    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FMOV    _ r1 r2             -> usage ([r1],                 [r2])
+    FMUL    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FNEG    _ r1 r2             -> usage ([r1],                 [r2])
+    FSQRT   _ r1 r2             -> usage ([r1],                 [r2])
+    FSUB    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FxTOy   _ _  r1 r2          -> usage ([r1],                 [r2])
+
+    JMP     addr                -> usage (regAddr addr, [])
+    JMP_TBL addr _ _            -> usage (regAddr addr, [])
+
+    CALL  (Left _  )  _ True    -> noUsage
+    CALL  (Left _  )  n False   -> usage (argRegs n, callClobberedRegs)
+    CALL  (Right reg) _ True    -> usage ([reg], [])
+    CALL  (Right reg) n False   -> usage (reg : (argRegs n), callClobberedRegs)
+    _                           -> noUsage
+
+  where
+    usage (src, dst)
+     = RU (filter (interesting platform) src)
+          (filter (interesting platform) dst)
+
+    regAddr (AddrRegReg r1 r2)  = [r1, r2]
+    regAddr (AddrRegImm r1 _)   = [r1]
+
+    regRI (RIReg r)             = [r]
+    regRI  _                    = []
+
+
+-- | Interesting regs are virtuals, or ones that are allocatable
+--      by the register allocator.
+interesting :: Platform -> Reg -> Bool
+interesting platform reg
+ = case reg of
+        RegVirtual _                    -> True
+        RegReal (RealRegSingle r1)      -> freeReg platform r1
+        RegReal (RealRegPair r1 _)      -> freeReg platform r1
+
+
+
+-- | Apply a given mapping to tall the register references in this instruction.
+sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+sparc_patchRegsOfInstr instr env = case instr of
+    LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)
+    ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr)
+
+    ADD   x cc r1 ar r2         -> ADD   x cc  (env r1) (fixRI ar) (env r2)
+    SUB   x cc r1 ar r2         -> SUB   x cc  (env r1) (fixRI ar) (env r2)
+    UMUL    cc r1 ar r2         -> UMUL    cc  (env r1) (fixRI ar) (env r2)
+    SMUL    cc r1 ar r2         -> SMUL    cc  (env r1) (fixRI ar) (env r2)
+    UDIV    cc r1 ar r2         -> UDIV    cc  (env r1) (fixRI ar) (env r2)
+    SDIV    cc r1 ar r2         -> SDIV    cc  (env r1) (fixRI ar) (env r2)
+    RDY   rd                    -> RDY         (env rd)
+    WRY   r1 r2                 -> WRY         (env r1) (env r2)
+    AND   b r1 ar r2            -> AND   b     (env r1) (fixRI ar) (env r2)
+    ANDN  b r1 ar r2            -> ANDN  b     (env r1) (fixRI ar) (env r2)
+    OR    b r1 ar r2            -> OR    b     (env r1) (fixRI ar) (env r2)
+    ORN   b r1 ar r2            -> ORN   b     (env r1) (fixRI ar) (env r2)
+    XOR   b r1 ar r2            -> XOR   b     (env r1) (fixRI ar) (env r2)
+    XNOR  b r1 ar r2            -> XNOR  b     (env r1) (fixRI ar) (env r2)
+    SLL   r1 ar r2              -> SLL         (env r1) (fixRI ar) (env r2)
+    SRL   r1 ar r2              -> SRL         (env r1) (fixRI ar) (env r2)
+    SRA   r1 ar r2              -> SRA         (env r1) (fixRI ar) (env r2)
+
+    SETHI imm reg               -> SETHI imm (env reg)
+
+    FABS  s r1 r2               -> FABS    s   (env r1) (env r2)
+    FADD  s r1 r2 r3            -> FADD    s   (env r1) (env r2) (env r3)
+    FCMP  e s r1 r2             -> FCMP e  s   (env r1) (env r2)
+    FDIV  s r1 r2 r3            -> FDIV    s   (env r1) (env r2) (env r3)
+    FMOV  s r1 r2               -> FMOV    s   (env r1) (env r2)
+    FMUL  s r1 r2 r3            -> FMUL    s   (env r1) (env r2) (env r3)
+    FNEG  s r1 r2               -> FNEG    s   (env r1) (env r2)
+    FSQRT s r1 r2               -> FSQRT   s   (env r1) (env r2)
+    FSUB  s r1 r2 r3            -> FSUB    s   (env r1) (env r2) (env r3)
+    FxTOy s1 s2 r1 r2           -> FxTOy s1 s2 (env r1) (env r2)
+
+    JMP     addr                -> JMP     (fixAddr addr)
+    JMP_TBL addr ids l          -> JMP_TBL (fixAddr addr) ids l
+
+    CALL  (Left i) n t          -> CALL (Left i) n t
+    CALL  (Right r) n t         -> CALL (Right (env r)) n t
+    _                           -> instr
+
+  where
+    fixAddr (AddrRegReg r1 r2)  = AddrRegReg   (env r1) (env r2)
+    fixAddr (AddrRegImm r1 i)   = AddrRegImm   (env r1) i
+
+    fixRI (RIReg r)             = RIReg (env r)
+    fixRI other                 = other
+
+
+--------------------------------------------------------------------------------
+sparc_isJumpishInstr :: Instr -> Bool
+sparc_isJumpishInstr instr
+ = case instr of
+        BI{}            -> True
+        BF{}            -> True
+        JMP{}           -> True
+        JMP_TBL{}       -> True
+        CALL{}          -> True
+        _               -> False
+
+sparc_jumpDestsOfInstr :: Instr -> [BlockId]
+sparc_jumpDestsOfInstr insn
+  = case insn of
+        BI   _ _ id     -> [id]
+        BF   _ _ id     -> [id]
+        JMP_TBL _ ids _ -> [id | Just id <- ids]
+        _               -> []
+
+
+sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
+sparc_patchJumpInstr insn patchF
+  = case insn of
+        BI cc annul id  -> BI cc annul (patchF id)
+        BF cc annul id  -> BF cc annul (patchF id)
+        JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l
+        _               -> insn
+
+
+--------------------------------------------------------------------------------
+-- | Make a spill instruction.
+--      On SPARC we spill below frame pointer leaving 2 words/spill
+sparc_mkSpillInstr
+    :: DynFlags
+    -> Reg      -- ^ register to spill
+    -> Int      -- ^ current stack delta
+    -> Int      -- ^ spill slot to use
+    -> Instr
+
+sparc_mkSpillInstr dflags reg _ slot
+ = let  platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        off_w    = 1 + (off `div` 4)
+        fmt      = case targetClassOfReg platform reg of
+                        RcInteger -> II32
+                        RcFloat   -> FF32
+                        RcDouble  -> FF64
+
+    in ST fmt reg (fpRel (negate off_w))
+
+
+-- | Make a spill reload instruction.
+sparc_mkLoadInstr
+    :: DynFlags
+    -> Reg      -- ^ register to load into
+    -> Int      -- ^ current stack delta
+    -> Int      -- ^ spill slot to use
+    -> Instr
+
+sparc_mkLoadInstr dflags reg _ slot
+  = let platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        off_w    = 1 + (off `div` 4)
+        fmt      = case targetClassOfReg platform reg of
+                        RcInteger -> II32
+                        RcFloat   -> FF32
+                        RcDouble  -> FF64
+
+        in LD fmt (fpRel (- off_w)) reg
+
+
+--------------------------------------------------------------------------------
+-- | See if this instruction is telling us the current C stack delta
+sparc_takeDeltaInstr
+        :: Instr
+        -> Maybe Int
+
+sparc_takeDeltaInstr instr
+ = case instr of
+        DELTA i         -> Just i
+        _               -> Nothing
+
+
+sparc_isMetaInstr
+        :: Instr
+        -> Bool
+
+sparc_isMetaInstr instr
+ = case instr of
+        COMMENT{}       -> True
+        LDATA{}         -> True
+        NEWBLOCK{}      -> True
+        DELTA{}         -> True
+        _               -> False
+
+
+-- | Make a reg-reg move instruction.
+--      On SPARC v8 there are no instructions to move directly between
+--      floating point and integer regs. If we need to do that then we
+--      have to go via memory.
+--
+sparc_mkRegRegMoveInstr
+    :: Platform
+    -> Reg
+    -> Reg
+    -> Instr
+
+sparc_mkRegRegMoveInstr platform src dst
+        | srcClass      <- targetClassOfReg platform src
+        , dstClass      <- targetClassOfReg platform dst
+        , srcClass == dstClass
+        = case srcClass of
+                RcInteger -> ADD  False False src (RIReg g0) dst
+                RcDouble  -> FMOV FF64 src dst
+                RcFloat   -> FMOV FF32 src dst
+
+        | otherwise
+        = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"
+
+
+-- | Check whether an instruction represents a reg-reg move.
+--      The register allocator attempts to eliminate reg->reg moves whenever it can,
+--      by assigning the src and dest temporaries to the same real register.
+--
+sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
+sparc_takeRegRegMoveInstr instr
+ = case instr of
+        ADD False False src (RIReg src2) dst
+         | g0 == src2           -> Just (src, dst)
+
+        FMOV FF64 src dst       -> Just (src, dst)
+        FMOV FF32  src dst      -> Just (src, dst)
+        _                       -> Nothing
+
+
+-- | Make an unconditional branch instruction.
+sparc_mkJumpInstr
+        :: BlockId
+        -> [Instr]
+
+sparc_mkJumpInstr id
+ =       [BI ALWAYS False id
+        , NOP]                  -- fill the branch delay slot.
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -0,0 +1,646 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module SPARC.Ppr (
+        pprNatCmmDecl,
+        pprBasicBlock,
+        pprData,
+        pprInstr,
+        pprFormat,
+        pprImm,
+        pprDataItem
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import SPARC.Regs
+import SPARC.Instr
+import SPARC.Cond
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Base
+import Instruction
+import Reg
+import Format
+import PprBase
+
+import Cmm hiding (topInfoTable)
+import PprCmm()
+import BlockId
+import CLabel
+import Hoopl.Label
+import Hoopl.Collections
+
+import Unique           ( pprUniqueAlways )
+import Outputable
+import Platform
+import FastString
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
+
+pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionAlign section $$ pprDatas dats
+
+pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+        -- special case for code without info table:
+        pprSectionAlign (Section Text lbl) $$
+        pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+        vcat (map (pprBasicBlock top_info) blocks)
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      (if platformHasSubsectionsViaSymbols platform
+          then pprSectionAlign dspSection $$
+               ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+      -- above: Even the first block gets a label, because with branch-chain
+      -- elimination, it might be the target of a goto.
+      (if platformHasSubsectionsViaSymbols platform
+       then
+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs
+                text "\t.long "
+            <+> ppr info_lbl
+            <+> char '-'
+            <+> ppr (mkDeadStripPreventer info_lbl)
+       else empty)
+
+dspSection :: Section
+dspSection = Section Text $
+    panic "subsections-via-symbols doesn't combine with split-sections"
+
+pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = maybe_infotable $$
+    pprLabel (blockLbl blockid) $$
+    vcat (map pprInstr instrs)
+  where
+    maybe_infotable = case mapLookup blockid info_env of
+       Nothing   -> empty
+       Just (Statics info_lbl info) ->
+           pprAlignForSection Text $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+
+
+pprDatas :: CmmStatics -> SDoc
+-- See note [emit-time elimination of static indirections] in CLabel.
+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+  | lbl == mkIndStaticInfoLabel
+  , let labelInd (CmmLabelOff l _) = Just l
+        labelInd (CmmLabel l) = Just l
+        labelInd _ = Nothing
+  , Just ind' <- labelInd ind
+  , alias `mayRedirectTo` ind'
+  = pprGloblDecl alias
+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
+
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str)          = pprBytes str
+pprData (CmmUninitialised bytes) = text ".skip " <> int bytes
+pprData (CmmStaticLit lit)       = pprDataItem lit
+
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = text ".global " <> ppr lbl
+
+pprTypeAndSizeDecl :: CLabel -> SDoc
+pprTypeAndSizeDecl lbl
+    = sdocWithPlatform $ \platform ->
+      if platformOS platform == OSLinux && externallyVisibleCLabel lbl
+      then text ".type " <> ppr lbl <> ptext (sLit ", @object")
+      else empty
+
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeAndSizeDecl lbl
+            $$ (ppr lbl <> char ':')
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+    ppr instr = pprInstr instr
+
+
+-- | Pretty print a register.
+pprReg :: Reg -> SDoc
+pprReg reg
+ = case reg of
+        RegVirtual vr
+         -> case vr of
+                VirtualRegI   u -> text "%vI_"   <> pprUniqueAlways u
+                VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u
+                VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u
+                VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u
+
+
+        RegReal rr
+         -> case rr of
+                RealRegSingle r1
+                 -> pprReg_ofRegNo r1
+
+                RealRegPair r1 r2
+                 -> text "(" <> pprReg_ofRegNo r1
+                 <> vbar     <> pprReg_ofRegNo r2
+                 <> text ")"
+
+
+
+-- | Pretty print a register name, based on this register number.
+--   The definition has been unfolded so we get a jump-table in the
+--   object code. This function is called quite a lot when emitting
+--   the asm file..
+--
+pprReg_ofRegNo :: Int -> SDoc
+pprReg_ofRegNo i
+ = ptext
+    (case i of {
+         0 -> sLit "%g0";   1 -> sLit "%g1";
+         2 -> sLit "%g2";   3 -> sLit "%g3";
+         4 -> sLit "%g4";   5 -> sLit "%g5";
+         6 -> sLit "%g6";   7 -> sLit "%g7";
+         8 -> sLit "%o0";   9 -> sLit "%o1";
+        10 -> sLit "%o2";  11 -> sLit "%o3";
+        12 -> sLit "%o4";  13 -> sLit "%o5";
+        14 -> sLit "%o6";  15 -> sLit "%o7";
+        16 -> sLit "%l0";  17 -> sLit "%l1";
+        18 -> sLit "%l2";  19 -> sLit "%l3";
+        20 -> sLit "%l4";  21 -> sLit "%l5";
+        22 -> sLit "%l6";  23 -> sLit "%l7";
+        24 -> sLit "%i0";  25 -> sLit "%i1";
+        26 -> sLit "%i2";  27 -> sLit "%i3";
+        28 -> sLit "%i4";  29 -> sLit "%i5";
+        30 -> sLit "%i6";  31 -> sLit "%i7";
+        32 -> sLit "%f0";  33 -> sLit "%f1";
+        34 -> sLit "%f2";  35 -> sLit "%f3";
+        36 -> sLit "%f4";  37 -> sLit "%f5";
+        38 -> sLit "%f6";  39 -> sLit "%f7";
+        40 -> sLit "%f8";  41 -> sLit "%f9";
+        42 -> sLit "%f10"; 43 -> sLit "%f11";
+        44 -> sLit "%f12"; 45 -> sLit "%f13";
+        46 -> sLit "%f14"; 47 -> sLit "%f15";
+        48 -> sLit "%f16"; 49 -> sLit "%f17";
+        50 -> sLit "%f18"; 51 -> sLit "%f19";
+        52 -> sLit "%f20"; 53 -> sLit "%f21";
+        54 -> sLit "%f22"; 55 -> sLit "%f23";
+        56 -> sLit "%f24"; 57 -> sLit "%f25";
+        58 -> sLit "%f26"; 59 -> sLit "%f27";
+        60 -> sLit "%f28"; 61 -> sLit "%f29";
+        62 -> sLit "%f30"; 63 -> sLit "%f31";
+        _  -> sLit "very naughty sparc register" })
+
+
+-- | Pretty print a format for an instruction suffix.
+pprFormat :: Format -> SDoc
+pprFormat x
+ = ptext
+    (case x of
+        II8     -> sLit "ub"
+        II16    -> sLit "uh"
+        II32    -> sLit ""
+        II64    -> sLit "d"
+        FF32    -> sLit ""
+        FF64    -> sLit "d")
+
+
+-- | Pretty print a format for an instruction suffix.
+--      eg LD is 32bit on sparc, but LDD is 64 bit.
+pprStFormat :: Format -> SDoc
+pprStFormat x
+ = ptext
+    (case x of
+        II8   -> sLit "b"
+        II16  -> sLit "h"
+        II32  -> sLit ""
+        II64  -> sLit "x"
+        FF32  -> sLit ""
+        FF64  -> sLit "d")
+
+
+
+-- | Pretty print a condition code.
+pprCond :: Cond -> SDoc
+pprCond c
+ = ptext
+    (case c of
+        ALWAYS  -> sLit ""
+        NEVER   -> sLit "n"
+        GEU     -> sLit "geu"
+        LU      -> sLit "lu"
+        EQQ     -> sLit "e"
+        GTT     -> sLit "g"
+        GE      -> sLit "ge"
+        GU      -> sLit "gu"
+        LTT     -> sLit "l"
+        LE      -> sLit "le"
+        LEU     -> sLit "leu"
+        NE      -> sLit "ne"
+        NEG     -> sLit "neg"
+        POS     -> sLit "pos"
+        VC      -> sLit "vc"
+        VS      -> sLit "vs")
+
+
+-- | Pretty print an address mode.
+pprAddr :: AddrMode -> SDoc
+pprAddr am
+ = case am of
+        AddrRegReg r1 (RegReal (RealRegSingle 0))
+         -> pprReg r1
+
+        AddrRegReg r1 r2
+         -> hcat [ pprReg r1, char '+', pprReg r2 ]
+
+        AddrRegImm r1 (ImmInt i)
+         | i == 0               -> pprReg r1
+         | not (fits13Bits i)   -> largeOffsetError i
+         | otherwise            -> hcat [ pprReg r1, pp_sign, int i ]
+         where
+                pp_sign = if i > 0 then char '+' else empty
+
+        AddrRegImm r1 (ImmInteger i)
+         | i == 0               -> pprReg r1
+         | not (fits13Bits i)   -> largeOffsetError i
+         | otherwise            -> hcat [ pprReg r1, pp_sign, integer i ]
+         where
+                pp_sign = if i > 0 then char '+' else empty
+
+        AddrRegImm r1 imm
+         -> hcat [ pprReg r1, char '+', pprImm imm ]
+
+
+-- | Pretty print an immediate value.
+pprImm :: Imm -> SDoc
+pprImm imm
+ = case imm of
+        ImmInt i        -> int i
+        ImmInteger i    -> integer i
+        ImmCLbl l       -> ppr l
+        ImmIndex l i    -> ppr l <> char '+' <> int i
+        ImmLit s        -> s
+
+        ImmConstantSum a b
+         -> pprImm a <> char '+' <> pprImm b
+
+        ImmConstantDiff a b
+         -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen
+
+        LO i
+         -> hcat [ text "%lo(", pprImm i, rparen ]
+
+        HI i
+         -> hcat [ text "%hi(", pprImm i, rparen ]
+
+        -- these should have been converted to bytes and placed
+        --      in the data section.
+        ImmFloat _      -> text "naughty float immediate"
+        ImmDouble _     -> text "naughty double immediate"
+
+
+-- | Pretty print a section \/ segment header.
+--      On SPARC all the data sections must be at least 8 byte aligned
+--      incase we store doubles in them.
+--
+pprSectionAlign :: Section -> SDoc
+pprSectionAlign sec@(Section seg _) =
+  sdocWithPlatform $ \platform ->
+    pprSectionHeader platform sec $$
+    pprAlignForSection seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: SectionType -> SDoc
+pprAlignForSection seg =
+    ptext (case seg of
+      Text              -> sLit ".align 4"
+      Data              -> sLit ".align 8"
+      ReadOnlyData      -> sLit ".align 8"
+      RelocatableReadOnlyData
+                        -> sLit ".align 8"
+      UninitialisedData -> sLit ".align 8"
+      ReadOnlyData16    -> sLit ".align 16"
+      -- TODO: This is copied from the ReadOnlyData case, but it can likely be
+      -- made more efficient.
+      CString           -> sLit ".align 8"
+      OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")
+
+-- | Pretty print a data item.
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit
+  = sdocWithDynFlags $ \dflags ->
+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+    where
+        imm = litToImm lit
+
+        ppr_item II8   _        = [text "\t.byte\t" <> pprImm imm]
+        ppr_item II32  _        = [text "\t.long\t" <> pprImm imm]
+
+        ppr_item FF32  (CmmFloat r _)
+         = let bs = floatToBytes (fromRational r)
+           in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item FF64 (CmmFloat r _)
+         = let bs = doubleToBytes (fromRational r)
+           in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item II16  _        = [text "\t.short\t" <> pprImm imm]
+        ppr_item II64  _        = [text "\t.quad\t" <> pprImm imm]
+        ppr_item _ _            = panic "SPARC.Ppr.pprDataItem: no match"
+
+
+-- | Pretty print an instruction.
+pprInstr :: Instr -> SDoc
+
+-- nuke comments.
+pprInstr (COMMENT _)
+        = empty
+
+pprInstr (DELTA d)
+        = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+-- Newblocks and LData should have been slurped out before producing the .s file.
+pprInstr (NEWBLOCK _)
+        = panic "X86.Ppr.pprInstr: NEWBLOCK"
+
+pprInstr (LDATA _ _)
+        = panic "PprMach.pprInstr: LDATA"
+
+-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand
+pprInstr (LD FF64 _ reg)
+        | RegReal (RealRegSingle{})     <- reg
+        = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"
+
+pprInstr (LD format addr reg)
+        = hcat [
+               text "\tld",
+               pprFormat format,
+               char '\t',
+               lbrack,
+               pprAddr addr,
+               pp_rbracket_comma,
+               pprReg reg
+            ]
+
+-- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand
+pprInstr (ST FF64 reg _)
+        | RegReal (RealRegSingle{}) <- reg
+        = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"
+
+-- no distinction is made between signed and unsigned bytes on stores for the
+-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
+-- so we call a special-purpose pprFormat for ST..
+pprInstr (ST format reg addr)
+        = hcat [
+               text "\tst",
+               pprStFormat format,
+               char '\t',
+               pprReg reg,
+               pp_comma_lbracket,
+               pprAddr addr,
+               rbrack
+            ]
+
+
+pprInstr (ADD x cc reg1 ri reg2)
+        | not x && not cc && riZero ri
+        = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]
+
+        | otherwise
+        = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
+
+
+pprInstr (SUB x cc reg1 ri reg2)
+        | not x && cc && reg2 == g0
+        = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ]
+
+        | not x && not cc && riZero ri
+        = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]
+
+        | otherwise
+        = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
+
+pprInstr (AND  b reg1 ri reg2) = pprRegRIReg (sLit "and")  b reg1 ri reg2
+
+pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
+
+pprInstr (OR b reg1 ri reg2)
+        | not b && reg1 == g0
+        = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ]
+          in  case ri of
+                   RIReg rrr | rrr == reg2 -> empty
+                   _                       -> doit
+
+        | otherwise
+        = pprRegRIReg (sLit "or") b reg1 ri reg2
+
+pprInstr (ORN b reg1 ri reg2)  = pprRegRIReg (sLit "orn") b reg1 ri reg2
+
+pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg (sLit "xor")  b reg1 ri reg2
+pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
+
+pprInstr (SLL reg1 ri reg2)    = pprRegRIReg (sLit "sll") False reg1 ri reg2
+pprInstr (SRL reg1 ri reg2)    = pprRegRIReg (sLit "srl") False reg1 ri reg2
+pprInstr (SRA reg1 ri reg2)    = pprRegRIReg (sLit "sra") False reg1 ri reg2
+
+pprInstr (RDY rd)              = text "\trd\t%y," <> pprReg rd
+pprInstr (WRY reg1 reg2)
+        = text "\twr\t"
+                <> pprReg reg1
+                <> char ','
+                <> pprReg reg2
+                <> char ','
+                <> text "%y"
+
+pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul")  b reg1 ri reg2
+pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul")  b reg1 ri reg2
+pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv")  b reg1 ri reg2
+pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv")  b reg1 ri reg2
+
+pprInstr (SETHI imm reg)
+  = hcat [
+        text "\tsethi\t",
+        pprImm imm,
+        comma,
+        pprReg reg
+    ]
+
+pprInstr NOP
+        = text "\tnop"
+
+pprInstr (FABS format reg1 reg2)
+        = pprFormatRegReg (sLit "fabs") format reg1 reg2
+
+pprInstr (FADD format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3
+
+pprInstr (FCMP e format reg1 reg2)
+        = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")
+                          format reg1 reg2
+
+pprInstr (FDIV format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3
+
+pprInstr (FMOV format reg1 reg2)
+        = pprFormatRegReg (sLit "fmov") format reg1 reg2
+
+pprInstr (FMUL format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3
+
+pprInstr (FNEG format reg1 reg2)
+        = pprFormatRegReg (sLit "fneg") format reg1 reg2
+
+pprInstr (FSQRT format reg1 reg2)
+        = pprFormatRegReg (sLit "fsqrt") format reg1 reg2
+
+pprInstr (FSUB format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3
+
+pprInstr (FxTOy format1 format2 reg1 reg2)
+  = hcat [
+        text "\tf",
+        ptext
+        (case format1 of
+            II32  -> sLit "ito"
+            FF32  -> sLit "sto"
+            FF64  -> sLit "dto"
+            _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
+        ptext
+        (case format2 of
+            II32  -> sLit "i\t"
+            II64  -> sLit "x\t"
+            FF32  -> sLit "s\t"
+            FF64  -> sLit "d\t"
+            _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
+        pprReg reg1, comma, pprReg reg2
+    ]
+
+
+pprInstr (BI cond b blockid)
+  = hcat [
+        text "\tb", pprCond cond,
+        if b then pp_comma_a else empty,
+        char '\t',
+        ppr (blockLbl blockid)
+    ]
+
+pprInstr (BF cond b blockid)
+  = hcat [
+        text "\tfb", pprCond cond,
+        if b then pp_comma_a else empty,
+        char '\t',
+        ppr (blockLbl blockid)
+    ]
+
+pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr
+pprInstr (JMP_TBL op _ _)  = pprInstr (JMP op)
+
+pprInstr (CALL (Left imm) n _)
+  = hcat [ text "\tcall\t", pprImm imm, comma, int n ]
+
+pprInstr (CALL (Right reg) n _)
+  = hcat [ text "\tcall\t", pprReg reg, comma, int n ]
+
+
+-- | Pretty print a RI
+pprRI :: RI -> SDoc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+
+-- | Pretty print a two reg instruction.
+pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc
+pprFormatRegReg name format reg1 reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        (case format of
+            FF32 -> text "s\t"
+            FF64 -> text "d\t"
+            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),
+
+        pprReg reg1,
+        comma,
+        pprReg reg2
+    ]
+
+
+-- | Pretty print a three reg instruction.
+pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
+pprFormatRegRegReg name format reg1 reg2 reg3
+  = hcat [
+        char '\t',
+        ptext name,
+        (case format of
+            FF32  -> text "s\t"
+            FF64  -> text "d\t"
+            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),
+        pprReg reg1,
+        comma,
+        pprReg reg2,
+        comma,
+        pprReg reg3
+    ]
+
+
+-- | Pretty print an instruction of two regs and a ri.
+pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc
+pprRegRIReg name b reg1 ri reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        if b then text "cc\t" else char '\t',
+        pprReg reg1,
+        comma,
+        pprRI ri,
+        comma,
+        pprReg reg2
+    ]
+
+{-
+pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc
+pprRIReg name b ri reg1
+  = hcat [
+        char '\t',
+        ptext name,
+        if b then text "cc\t" else char '\t',
+        pprRI ri,
+        comma,
+        pprReg reg1
+    ]
+-}
+
+{-
+pp_ld_lbracket :: SDoc
+pp_ld_lbracket    = text "\tld\t["
+-}
+
+pp_rbracket_comma :: SDoc
+pp_rbracket_comma = text "],"
+
+
+pp_comma_lbracket :: SDoc
+pp_comma_lbracket = text ",["
+
+
+pp_comma_a :: SDoc
+pp_comma_a        = text ",a"
diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Regs.hs
@@ -0,0 +1,259 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1994-2004
+--
+-- -----------------------------------------------------------------------------
+
+module SPARC.Regs (
+        -- registers
+        showReg,
+        virtualRegSqueeze,
+        realRegSqueeze,
+        classOfRealReg,
+        allRealRegs,
+
+        -- machine specific info
+        gReg, iReg, lReg, oReg, fReg,
+        fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27,
+
+        -- allocatable
+        allocatableRegs,
+
+        -- args
+        argRegs,
+        allArgRegs,
+        callClobberedRegs,
+
+        --
+        mkVirtualReg,
+        regDotColor
+)
+
+where
+
+
+import GhcPrelude
+
+import CodeGen.Platform.SPARC
+import Reg
+import RegClass
+import Format
+
+import Unique
+import Outputable
+
+{-
+        The SPARC has 64 registers of interest; 32 integer registers and 32
+        floating point registers.  The mapping of STG registers to SPARC
+        machine registers is defined in StgRegs.h.  We are, of course,
+        prepared for any eventuality.
+
+        The whole fp-register pairing thing on sparcs is a huge nuisance.  See
+        includes/stg/MachRegs.h for a description of what's going on
+        here.
+-}
+
+
+-- | Get the standard name for the register with this number.
+showReg :: RegNo -> String
+showReg n
+        | n >= 0  && n < 8   = "%g" ++ show n
+        | n >= 8  && n < 16  = "%o" ++ show (n-8)
+        | n >= 16 && n < 24  = "%l" ++ show (n-16)
+        | n >= 24 && n < 32  = "%i" ++ show (n-24)
+        | n >= 32 && n < 64  = "%f" ++ show (n-32)
+        | otherwise          = panic "SPARC.Regs.showReg: unknown sparc register"
+
+
+-- Get the register class of a certain real reg
+classOfRealReg :: RealReg -> RegClass
+classOfRealReg reg
+ = case reg of
+        RealRegSingle i
+                | i < 32        -> RcInteger
+                | otherwise     -> RcFloat
+
+        RealRegPair{}           -> RcDouble
+
+
+-- | regSqueeze_class reg
+--      Calculate the maximum number of register colors that could be
+--      denied to a node of this class due to having this reg
+--      as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+
+virtualRegSqueeze cls vr
+ = case cls of
+        RcInteger
+         -> case vr of
+                VirtualRegI{}           -> 1
+                VirtualRegHi{}          -> 1
+                _other                  -> 0
+
+        RcFloat
+         -> case vr of
+                VirtualRegF{}           -> 1
+                VirtualRegD{}           -> 2
+                _other                  -> 0
+
+        RcDouble
+         -> case vr of
+                VirtualRegF{}           -> 1
+                VirtualRegD{}           -> 1
+                _other                  -> 0
+
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+
+realRegSqueeze cls rr
+ = case cls of
+        RcInteger
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 1
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcFloat
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 0
+                        | otherwise     -> 1
+
+                RealRegPair{}           -> 2
+
+        RcDouble
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 0
+                        | otherwise     -> 1
+
+                RealRegPair{}           -> 1
+
+
+-- | All the allocatable registers in the machine,
+--      including register pairs.
+allRealRegs :: [RealReg]
+allRealRegs
+        =  [ (RealRegSingle i)          | i <- [0..63] ]
+        ++ [ (RealRegPair   i (i+1))    | i <- [32, 34 .. 62 ] ]
+
+
+-- | Get the regno for this sort of reg
+gReg, lReg, iReg, oReg, fReg :: Int -> RegNo
+
+gReg x  = x             -- global regs
+oReg x  = (8 + x)       -- output regs
+lReg x  = (16 + x)      -- local regs
+iReg x  = (24 + x)      -- input regs
+fReg x  = (32 + x)      -- float regs
+
+
+-- | Some specific regs used by the code generator.
+g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg
+
+f6  = RegReal (RealRegSingle (fReg 6))
+f8  = RegReal (RealRegSingle (fReg 8))
+f22 = RegReal (RealRegSingle (fReg 22))
+f26 = RegReal (RealRegSingle (fReg 26))
+f27 = RegReal (RealRegSingle (fReg 27))
+
+-- g0 is always zero, and writes to it vanish.
+g0  = RegReal (RealRegSingle (gReg 0))
+g1  = RegReal (RealRegSingle (gReg 1))
+g2  = RegReal (RealRegSingle (gReg 2))
+
+-- FP, SP, int and float return (from C) regs.
+fp  = RegReal (RealRegSingle (iReg 6))
+sp  = RegReal (RealRegSingle (oReg 6))
+o0  = RegReal (RealRegSingle (oReg 0))
+o1  = RegReal (RealRegSingle (oReg 1))
+f0  = RegReal (RealRegSingle (fReg 0))
+f1  = RegReal (RealRegSingle (fReg 1))
+
+-- | Produce the second-half-of-a-double register given the first half.
+{-
+fPair :: Reg -> Maybe Reg
+fPair (RealReg n)
+        | n >= 32 && n `mod` 2 == 0  = Just (RealReg (n+1))
+
+fPair (VirtualRegD u)
+        = Just (VirtualRegHi u)
+
+fPair reg
+        = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg)
+                Nothing
+-}
+
+
+-- | All the regs that the register allocator can allocate to,
+--      with the fixed use regs removed.
+--
+allocatableRegs :: [RealReg]
+allocatableRegs
+   = let isFree rr
+           = case rr of
+                RealRegSingle r     -> freeReg r
+                RealRegPair   r1 r2 -> freeReg r1 && freeReg r2
+     in filter isFree allRealRegs
+
+
+-- | The registers to place arguments for function calls,
+--      for some number of arguments.
+--
+argRegs :: RegNo -> [Reg]
+argRegs r
+ = case r of
+        0       -> []
+        1       -> map (RegReal . RealRegSingle . oReg) [0]
+        2       -> map (RegReal . RealRegSingle . oReg) [0,1]
+        3       -> map (RegReal . RealRegSingle . oReg) [0,1,2]
+        4       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3]
+        5       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4]
+        6       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5]
+        _       -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"
+
+
+-- | All all the regs that could possibly be returned by argRegs
+--
+allArgRegs :: [Reg]
+allArgRegs
+        = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]]
+
+
+-- These are the regs that we cannot assume stay alive over a C call.
+--      TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02
+--
+callClobberedRegs :: [Reg]
+callClobberedRegs
+        = map (RegReal . RealRegSingle)
+                (  oReg 7 :
+                  [oReg i | i <- [0..5]] ++
+                  [gReg i | i <- [1..7]] ++
+                  [fReg i | i <- [0..31]] )
+
+
+
+-- | Make a virtual reg with this format.
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+        | not (isFloatFormat format)
+        = VirtualRegI u
+
+        | otherwise
+        = case format of
+                FF32    -> VirtualRegF u
+                FF64    -> VirtualRegD u
+                _       -> panic "mkVReg"
+
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg
+ = case classOfRealReg reg of
+        RcInteger       -> text "blue"
+        RcFloat         -> text "red"
+        _other          -> text "green"
diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/ShortcutJump.hs
@@ -0,0 +1,74 @@
+module SPARC.ShortcutJump (
+        JumpDest(..), getJumpDestBlockId,
+        canShortcut,
+        shortcutJump,
+        shortcutStatics,
+        shortBlockId
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Imm
+
+import CLabel
+import BlockId
+import Cmm
+
+import Panic
+import Outputable
+
+data JumpDest
+        = DestBlockId BlockId
+        | DestImm Imm
+
+-- Debug Instance
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "blk:" <> ppr bid
+  ppr (DestImm _bid)    = text "imm:?"
+
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
+
+
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut _ = Nothing
+
+
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump _ other = other
+
+
+
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
+shortcutStatics fn (Statics lbl statics)
+  = Statics lbl $ map (shortcutStatic fn) statics
+  -- we need to get the jump tables, so apply the mapping to the entries
+  -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
+
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+        = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
+-- slightly dodgy, we're ignoring the second label, but this
+-- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic _ other_static
+        = other_static
+
+
+shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel
+shortBlockId fn blockid =
+   case fn blockid of
+      Nothing -> blockLbl blockid
+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
+      Just (DestImm (ImmCLbl lbl)) -> lbl
+      _other -> panic "shortBlockId"
diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Stack.hs
@@ -0,0 +1,59 @@
+module SPARC.Stack (
+        spRel,
+        fpRel,
+        spillSlotToOffset,
+        maxSpillSlots
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.AddrMode
+import SPARC.Regs
+import SPARC.Base
+import SPARC.Imm
+
+import DynFlags
+import Outputable
+
+-- | Get an AddrMode relative to the address in sp.
+--      This gives us a stack relative addressing mode for volatile
+--      temporaries and for excess call arguments.
+--
+spRel :: Int            -- ^ stack offset in words, positive or negative
+      -> AddrMode
+
+spRel n = AddrRegImm sp (ImmInt (n * wordLength))
+
+
+-- | Get an address relative to the frame pointer.
+--      This doesn't work work for offsets greater than 13 bits; we just hope for the best
+--
+fpRel :: Int -> AddrMode
+fpRel n
+        = AddrRegImm fp (ImmInt (n * wordLength))
+
+
+-- | Convert a spill slot number to a *byte* offset, with no sign.
+--
+spillSlotToOffset :: DynFlags -> Int -> Int
+spillSlotToOffset dflags slot
+        | slot >= 0 && slot < maxSpillSlots dflags
+        = 64 + spillSlotSize * slot
+
+        | otherwise
+        = pprPanic "spillSlotToOffset:"
+                      (   text "invalid spill location: " <> int slot
+                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots dflags))
+
+
+-- | The maximum number of spill slots available on the C stack.
+--      If we use up all of the slots, then we're screwed.
+--
+--      Why do we reserve 64 bytes, instead of using the whole thing??
+--              -- BL 2009/02/15
+--
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+        = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1
diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/TargetReg.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE CPP #-}
+-- | Hard wired things related to registers.
+--      This is module is preventing the native code generator being able to
+--      emit code for non-host architectures.
+--
+--      TODO: Do a better job of the overloading, and eliminate this module.
+--      We'd probably do better with a Register type class, and hook this to
+--      Instruction somehow.
+--
+--      TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable
+module TargetReg (
+        targetVirtualRegSqueeze,
+        targetRealRegSqueeze,
+        targetClassOfRealReg,
+        targetMkVirtualReg,
+        targetRegDotColor,
+        targetClassOfReg
+)
+
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Reg
+import RegClass
+import Format
+
+import Outputable
+import Unique
+import Platform
+
+import qualified X86.Regs       as X86
+import qualified X86.RegInfo    as X86
+
+import qualified PPC.Regs       as PPC
+
+import qualified SPARC.Regs     as SPARC
+
+targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int
+targetVirtualRegSqueeze platform
+    = case platformArch platform of
+      ArchX86       -> X86.virtualRegSqueeze
+      ArchX86_64    -> X86.virtualRegSqueeze
+      ArchPPC       -> PPC.virtualRegSqueeze
+      ArchSPARC     -> SPARC.virtualRegSqueeze
+      ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"
+      ArchPPC_64 _  -> PPC.virtualRegSqueeze
+      ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"
+      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"
+      ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"
+      ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"
+      ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"
+      ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"
+      ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"
+
+
+targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int
+targetRealRegSqueeze platform
+    = case platformArch platform of
+      ArchX86       -> X86.realRegSqueeze
+      ArchX86_64    -> X86.realRegSqueeze
+      ArchPPC       -> PPC.realRegSqueeze
+      ArchSPARC     -> SPARC.realRegSqueeze
+      ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"
+      ArchPPC_64 _  -> PPC.realRegSqueeze
+      ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"
+      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"
+      ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"
+      ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"
+      ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"
+      ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"
+      ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"
+
+targetClassOfRealReg :: Platform -> RealReg -> RegClass
+targetClassOfRealReg platform
+    = case platformArch platform of
+      ArchX86       -> X86.classOfRealReg platform
+      ArchX86_64    -> X86.classOfRealReg platform
+      ArchPPC       -> PPC.classOfRealReg
+      ArchSPARC     -> SPARC.classOfRealReg
+      ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"
+      ArchPPC_64 _  -> PPC.classOfRealReg
+      ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"
+      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"
+      ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"
+      ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"
+      ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"
+      ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"
+      ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"
+
+targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg
+targetMkVirtualReg platform
+    = case platformArch platform of
+      ArchX86       -> X86.mkVirtualReg
+      ArchX86_64    -> X86.mkVirtualReg
+      ArchPPC       -> PPC.mkVirtualReg
+      ArchSPARC     -> SPARC.mkVirtualReg
+      ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"
+      ArchPPC_64 _  -> PPC.mkVirtualReg
+      ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"
+      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"
+      ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"
+      ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"
+      ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"
+      ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"
+      ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"
+
+targetRegDotColor :: Platform -> RealReg -> SDoc
+targetRegDotColor platform
+    = case platformArch platform of
+      ArchX86       -> X86.regDotColor platform
+      ArchX86_64    -> X86.regDotColor platform
+      ArchPPC       -> PPC.regDotColor
+      ArchSPARC     -> SPARC.regDotColor
+      ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"
+      ArchPPC_64 _  -> PPC.regDotColor
+      ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"
+      ArchARM64     -> panic "targetRegDotColor ArchARM64"
+      ArchAlpha     -> panic "targetRegDotColor ArchAlpha"
+      ArchMipseb    -> panic "targetRegDotColor ArchMipseb"
+      ArchMipsel    -> panic "targetRegDotColor ArchMipsel"
+      ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"
+      ArchUnknown   -> panic "targetRegDotColor ArchUnknown"
+
+
+targetClassOfReg :: Platform -> Reg -> RegClass
+targetClassOfReg platform reg
+ = case reg of
+   RegVirtual vr -> classOfVirtualReg vr
+   RegReal rr -> targetClassOfRealReg platform rr
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -0,0 +1,3446 @@
+{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}
+
+-- The default iteration limit is a bit too low for the definitions
+-- in this module.
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+
+-- This is a big module, but, if you pay attention to
+-- (a) the sectioning, and (b) the type signatures, the
+-- structure should not be too overwhelming.
+
+module X86.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        extractUnwindPoints,
+        invertCondBranches,
+        InstrBlock
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "../includes/MachDeps.h"
+
+-- NCG stuff:
+import GhcPrelude
+
+import X86.Instr
+import X86.Cond
+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
+                        , UnwindExpr(UwReg), toUnwindExpr )
+import Instruction
+import PIC
+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat
+                  , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat
+                  , getPicBaseMaybeNat, getDebugBlock, getFileId
+                  , addImmediateSuccessorNat, updateCfgNat)
+import CFG
+import Format
+import Reg
+import Platform
+
+-- Our intermediate code:
+import BasicTypes
+import BlockId
+import Module           ( primUnitId )
+import PprCmm           ()
+import CmmUtils
+import CmmSwitch
+import Cmm
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import CLabel
+import CoreSyn          ( Tickish(..) )
+import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
+
+-- The rest:
+import ForeignCall      ( CCallConv(..) )
+import OrdList
+import Outputable
+import FastString
+import DynFlags
+import Util
+import UniqSupply       ( getUniqueM )
+
+import Control.Monad
+import Data.Bits
+import Data.Foldable (fold)
+import Data.Int
+import Data.Maybe
+import Data.Word
+
+import qualified Data.Map as M
+
+is32BitPlatform :: NatM Bool
+is32BitPlatform = do
+    dflags <- getDynFlags
+    return $ target32Bit (targetPlatform dflags)
+
+sse2Enabled :: NatM Bool
+sse2Enabled = do
+  dflags <- getDynFlags
+  case platformArch (targetPlatform dflags) of
+  -- We Assume  SSE1 and SSE2 operations are available on both
+  -- x86 and x86_64. Historically we didn't default to SSE2 and
+  -- SSE1 on x86, which results in defacto nondeterminism for how
+  -- rounding behaves in the associated x87 floating point instructions
+  -- because variations in the spill/fpu stack placement of arguments for
+  -- operations would change the precision and final result of what
+  -- would otherwise be the same expressions with respect to single or
+  -- double precision IEEE floating point computations.
+    ArchX86_64 -> return True
+    ArchX86    -> return True
+    _          -> panic "trying to generate x86/x86_64 on the wrong platform"
+
+
+sse4_2Enabled :: NatM Bool
+sse4_2Enabled = do
+  dflags <- getDynFlags
+  return (isSse4_2Enabled dflags)
+
+
+cmmTopCodeGen
+        :: RawCmmDecl
+        -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
+
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+  picBaseMb <- getPicBaseMaybeNat
+  dflags <- getDynFlags
+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+      tops = proc : concat statics
+      os   = platformOS $ targetPlatform dflags
+
+  case picBaseMb of
+      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops
+      Nothing -> return tops
+
+cmmTopCodeGen (CmmData sec dat) = do
+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic
+
+
+basicBlockCodeGen
+        :: CmmBlock
+        -> NatM ( [NatBasicBlock Instr]
+                , [NatCmmDecl (Alignment, CmmStatics) Instr])
+
+basicBlockCodeGen block = do
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
+      stmts = blockToList nodes
+  -- Generate location directive
+  dbg <- getDebugBlock (entryLabel block)
+  loc_instrs <- case dblSourceTick =<< dbg of
+    Just (SourceNote span name)
+      -> do fileId <- getFileId (srcSpanFile span)
+            let line = srcSpanStartLine span; col = srcSpanStartCol span
+            return $ unitOL $ LOCATION fileId line col name
+    _ -> return nilOL
+  mid_instrs <- stmtsToInstrs id stmts
+  tail_instrs <- stmtToInstrs id tail
+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
+  instrs' <- fold <$> traverse addSpUnwindings instrs
+  -- code generation may introduce new basic block boundaries, which
+  -- are indicated by the NEWBLOCK instruction.  We must split up the
+  -- instruction stream into basic blocks again.  Also, we extract
+  -- LDATAs here too.
+  let
+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'
+
+        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+          = ([], BasicBlock id instrs : blocks, statics)
+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+          = (instrs, blocks, CmmData sec dat:statics)
+        mkBlocks instr (instrs,blocks,statics)
+          = (instr:instrs, blocks, statics)
+  return (BasicBlock id top : other_blocks, statics)
+
+-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
+-- in the @sp@ register. See Note [What is this unwinding business?] in Debug
+-- for details.
+addSpUnwindings :: Instr -> NatM (OrdList Instr)
+addSpUnwindings instr@(DELTA d) = do
+    dflags <- getDynFlags
+    if debugLevel dflags >= 1
+        then do lbl <- mkAsmTempLabel <$> getUniqueM
+                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
+                return $ toOL [ instr, UNWIND lbl unwind ]
+        else return (unitOL instr)
+addSpUnwindings instr = return $ unitOL instr
+
+stmtsToInstrs :: BlockId -> [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs bid stmts
+   = do instrss <- mapM (stmtToInstrs bid) stmts
+        return (concatOL instrss)
+
+-- | `bid` refers to the current block and is used to update the CFG
+--   if new blocks are inserted in the control flow.
+stmtToInstrs :: BlockId -> CmmNode e x -> NatM InstrBlock
+stmtToInstrs bid stmt = do
+  dflags <- getDynFlags
+  is32Bit <- is32BitPlatform
+  case stmt of
+    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
+
+    CmmUnwind regs -> do
+      let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
+          to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)
+      case foldMap to_unwind_entry regs of
+        tbl | M.null tbl -> return nilOL
+            | otherwise  -> do
+                lbl <- mkAsmTempLabel <$> getUniqueM
+                return $ unitOL $ UNWIND lbl tbl
+
+    CmmAssign reg src
+      | isFloatType ty         -> assignReg_FltCode format reg src
+      | is32Bit && isWord64 ty -> assignReg_I64Code      reg src
+      | otherwise              -> assignReg_IntCode format reg src
+        where ty = cmmRegType dflags reg
+              format = cmmTypeFormat ty
+
+    CmmStore addr src
+      | isFloatType ty         -> assignMem_FltCode format addr src
+      | is32Bit && isWord64 ty -> assignMem_I64Code      addr src
+      | otherwise              -> assignMem_IntCode format addr src
+        where ty = cmmExprType dflags src
+              format = cmmTypeFormat ty
+
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall dflags is32Bit target result_regs args bid
+
+    CmmBranch id          -> return $ genBranch id
+
+    --We try to arrange blocks such that the likely branch is the fallthrough
+    --in CmmContFlowOpt. So we can assume the condition is likely false here.
+    CmmCondBranch arg true false _ -> genCondBranch bid true false arg
+    CmmSwitch arg ids -> do dflags <- getDynFlags
+                            genSwitch dflags arg ids
+    CmmCall { cml_target = arg
+            , cml_args_regs = gregs } -> do
+                                dflags <- getDynFlags
+                                genJump arg (jumpRegs dflags gregs)
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
+
+
+jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
+    where platform = targetPlatform dflags
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--      They are really trees of insns to facilitate fast appending, where a
+--      left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock
+        = OrdList Instr
+
+
+-- | Condition codes passed up the tree.
+--
+data CondCode
+        = CondCode Bool Cond InstrBlock
+
+
+-- | a.k.a "Register64"
+--      Reg is the lower 32-bit temporary which contains the result.
+--      Use getHiVRegFromLo to find the other VRegUnique.
+--
+--      Rules of this simplified insn selection game are therefore that
+--      the returned Reg may be modified
+--
+data ChildCode64
+   = ChildCode64
+        InstrBlock
+        Reg
+
+
+-- | Register's passed up the tree.  If the stix code forces the register
+--      to live in a pre-decided machine register, it comes out as @Fixed@;
+--      otherwise, it comes out as @Any@, and the parent can decide which
+--      register to put it in.
+--
+data Register
+        = Fixed Format Reg InstrBlock
+        | Any   Format (Reg -> InstrBlock)
+
+
+swizzleRegisterRep :: Register -> Format -> Register
+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
+
+
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform  -> CmmReg -> Reg
+
+getRegisterReg _   (CmmLocal (LocalReg u pk))
+  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated
+   let fmt = cmmTypeFormat pk in
+        RegVirtual (mkVirtualReg u fmt)
+
+getRegisterReg platform  (CmmGlobal mid)
+  = case globalRegMaybe platform mid of
+        Just reg -> RegReal $ reg
+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+        -- By this stage, the only MagicIds remaining should be the
+        -- ones which map to a real machine register on this
+        -- platform.  Hence ...
+
+
+-- | Memory addressing modes passed up the tree.
+data Amode
+        = Amode AddrMode InstrBlock
+
+{-
+Now, given a tree (the argument to a CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+
+-- | Check whether an integer will fit in 32 bits.
+--      A CmmInt is intended to be truncated to the appropriate
+--      number of bits, so here we truncate it to Int64.  This is
+--      important because e.g. -1 as a CmmInt might be either
+--      -1 or 18446744073709551615.
+--
+is32BitInteger :: Integer -> Bool
+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
+  where i64 = fromIntegral i :: Int64
+
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = blockLbl blockid
+
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr
+mangleIndexTree dflags reg off
+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+  where width = typeWidth (cmmRegType dflags reg)
+
+-- | The dual to getAnyReg: compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed _ reg code ->
+        return (reg, code)
+
+
+assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_I64Code addrTree valueTree = do
+  Amode addr addr_code <- getAmode addrTree
+  ChildCode64 vcode rlo <- iselExpr64 valueTree
+  let
+        rhi = getHiVRegFromLo rlo
+
+        -- Little-endian store
+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)
+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+
+assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+   let
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)
+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)
+   return (
+        vcode `snocOL` mov_lo `snocOL` mov_hi
+     )
+
+assignReg_I64Code _ _
+   = panic "assignReg_I64Code(i386): invalid lvalue"
+
+
+iselExpr64        :: CmmExpr -> NatM ChildCode64
+iselExpr64 (CmmLit (CmmInt i _)) = do
+  (rlo,rhi) <- getNewRegPairNat II32
+  let
+        r = fromIntegral (fromIntegral i :: Word32)
+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
+        code = toOL [
+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),
+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)
+                ]
+  return (ChildCode64 code rlo)
+
+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
+   Amode addr addr_code <- getAmode addrTree
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)
+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
+   return (
+            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+                        rlo
+     )
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
+
+-- we handle addition, but rather badly
+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r = fromIntegral (fromIntegral i :: Word32)
+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
+        r1hi = getHiVRegFromLo r1lo
+        code =  code1 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       ADD II32 (OpReg r2lo) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       SUB II32 (OpReg r2lo) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
+     fn <- getAnyReg expr
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         code = fn r_dst_lo
+     return (
+             ChildCode64 (code `snocOL`
+                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))
+                          r_dst_lo
+            )
+
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
+     fn <- getAnyReg expr
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         code = fn r_dst_lo
+     return (
+             ChildCode64 (code `snocOL`
+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`
+                          CLTD II32 `snocOL`
+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`
+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))
+                          r_dst_lo
+            )
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(i386)" (ppr expr)
+
+
+--------------------------------------------------------------------------------
+getRegister :: CmmExpr -> NatM Register
+getRegister e = do dflags <- getDynFlags
+                   is32Bit <- is32BitPlatform
+                   getRegister' dflags is32Bit e
+
+getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register
+
+getRegister' dflags is32Bit (CmmReg reg)
+  = case reg of
+        CmmGlobal PicBaseReg
+         | is32Bit ->
+            -- on x86_64, we have %rip for PicBaseReg, but it's not
+            -- a full-featured register, it can only be used for
+            -- rip-relative addressing.
+            do reg' <- getPicBaseNat (archWordFormat is32Bit)
+               return (Fixed (archWordFormat is32Bit) reg' nilOL)
+        _ ->
+            do
+               let
+                 fmt = cmmTypeFormat (cmmRegType dflags reg)
+                 format  = fmt
+               --
+               let platform = targetPlatform dflags
+               return (Fixed format
+                             (getRegisterReg platform  reg)
+                             nilOL)
+
+
+getRegister' dflags is32Bit (CmmRegOff r n)
+  = getRegister' dflags is32Bit $ mangleIndexTree dflags r n
+
+getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
+  = addAlignmentCheck align <$> getRegister' dflags is32Bit e
+
+-- for 32-bit architectures, support some 64 -> 32 bit conversions:
+-- TO_W_(x), TO_W_(x >> 32)
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =
+  float_const_sse2  where
+  float_const_sse2
+    | f == 0.0 = do
+      let
+          format = floatFormat w
+          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))
+        -- I don't know why there are xorpd, xorps, and pxor instructions.
+        -- They all appear to do the same thing --SDM
+      return (Any format code)
+
+   | otherwise = do
+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
+      loadFloatAmode w addr code
+
+-- catch simple cases of zero- or sign-extended load
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVZxL II8) addr
+  return (Any II32 code)
+
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVSxL II8) addr
+  return (Any II32 code)
+
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVZxL II16) addr
+  return (Any II32 code)
+
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVSxL II16) addr
+  return (Any II32 code)
+
+-- catch simple cases of zero- or sign-extended load
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVZxL II8) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVSxL II8) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVZxL II16) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVSxL II16) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVSxL II32) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
+                                     CmmLit displacement])
+ | not is32Bit = do
+      return $ Any II64 (\dst -> unitOL $
+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
+
+getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
+    case mop of
+      MO_F_Neg w  -> sse2NegCode w x
+
+
+      MO_S_Neg w -> triv_ucode NEGI (intFormat w)
+      MO_Not w   -> triv_ucode NOT  (intFormat w)
+
+      -- Nop conversions
+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x
+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x
+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x
+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x
+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x
+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x
+      MO_UU_Conv W32 W16 -> toI16Reg W32 x
+      MO_SS_Conv W32 W16 -> toI16Reg W32 x
+      MO_XX_Conv W32 W16 -> toI16Reg W32 x
+
+      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+
+      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+
+      -- widenings
+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x
+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x
+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x
+
+      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x
+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x
+
+      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we
+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register
+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.
+      MO_XX_Conv W8  W32
+          | is32Bit   -> integerExtend W8 W32 MOVZxL x
+          | otherwise -> integerExtend W8 W32 MOV x
+      MO_XX_Conv W8  W16
+          | is32Bit   -> integerExtend W8 W16 MOVZxL x
+          | otherwise -> integerExtend W8 W16 MOV x
+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x
+
+      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x
+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x
+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x
+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x
+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x
+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x
+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.
+      -- However, we don't want the register allocator to throw it
+      -- away as an unnecessary reg-to-reg move, so we keep it in
+      -- the form of a movzl and print it as a movl later.
+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about
+      -- the upper bits. So we can just use MOV.
+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x
+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x
+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x
+
+      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x
+
+
+      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x
+
+      MO_FS_Conv from to -> coerceFP2Int from to x
+      MO_SF_Conv from to -> coerceInt2FP from to x
+
+      MO_V_Insert {}   -> needLlvm
+      MO_V_Extract {}  -> needLlvm
+      MO_V_Add {}      -> needLlvm
+      MO_V_Sub {}      -> needLlvm
+      MO_V_Mul {}      -> needLlvm
+      MO_VS_Quot {}    -> needLlvm
+      MO_VS_Rem {}     -> needLlvm
+      MO_VS_Neg {}     -> needLlvm
+      MO_VU_Quot {}    -> needLlvm
+      MO_VU_Rem {}     -> needLlvm
+      MO_VF_Insert {}  -> needLlvm
+      MO_VF_Extract {} -> needLlvm
+      MO_VF_Add {}     -> needLlvm
+      MO_VF_Sub {}     -> needLlvm
+      MO_VF_Mul {}     -> needLlvm
+      MO_VF_Quot {}    -> needLlvm
+      MO_VF_Neg {}     -> needLlvm
+
+      _other -> pprPanic "getRegister" (pprMachOp mop)
+   where
+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register
+        triv_ucode instr format = trivialUCode format (instr format) x
+
+        -- signed or unsigned extension.
+        integerExtend :: Width -> Width
+                      -> (Format -> Operand -> Operand -> Instr)
+                      -> CmmExpr -> NatM Register
+        integerExtend from to instr expr = do
+            (reg,e_code) <- if from == W8 then getByteReg expr
+                                          else getSomeReg expr
+            let
+                code dst =
+                  e_code `snocOL`
+                  instr (intFormat from) (OpReg reg) (OpReg dst)
+            return (Any (intFormat to) code)
+
+        toI8Reg :: Width -> CmmExpr -> NatM Register
+        toI8Reg new_rep expr
+            = do codefn <- getAnyReg expr
+                 return (Any (intFormat new_rep) codefn)
+                -- HACK: use getAnyReg to get a byte-addressable register.
+                -- If the source was a Fixed register, this will add the
+                -- mov instruction to put it into the desired destination.
+                -- We're assuming that the destination won't be a fixed
+                -- non-byte-addressable register; it won't be, because all
+                -- fixed registers are word-sized.
+
+        toI16Reg = toI8Reg -- for now
+
+        conversionNop :: Format -> CmmExpr -> NatM Register
+        conversionNop new_format expr
+            = do e_code <- getRegister' dflags is32Bit expr
+                 return (swizzleRegisterRep e_code new_format)
+
+
+getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
+  case mop of
+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y
+      MO_F_Ne _ -> condFltReg is32Bit NE  x y
+      MO_F_Gt _ -> condFltReg is32Bit GTT x y
+      MO_F_Ge _ -> condFltReg is32Bit GE  x y
+      -- Invert comparison condition and swap operands
+      -- See Note [SSE Parity Checks]
+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x
+      MO_F_Le _ -> condFltReg is32Bit GE   y x
+
+      MO_Eq _   -> condIntReg EQQ x y
+      MO_Ne _   -> condIntReg NE  x y
+
+      MO_S_Gt _ -> condIntReg GTT x y
+      MO_S_Ge _ -> condIntReg GE  x y
+      MO_S_Lt _ -> condIntReg LTT x y
+      MO_S_Le _ -> condIntReg LE  x y
+
+      MO_U_Gt _ -> condIntReg GU  x y
+      MO_U_Ge _ -> condIntReg GEU x y
+      MO_U_Lt _ -> condIntReg LU  x y
+      MO_U_Le _ -> condIntReg LEU x y
+
+      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y
+
+      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y
+
+      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y
+
+      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y
+
+
+      MO_Add rep -> add_code rep x y
+      MO_Sub rep -> sub_code rep x y
+
+      MO_S_Quot rep -> div_code rep True  True  x y
+      MO_S_Rem  rep -> div_code rep True  False x y
+      MO_U_Quot rep -> div_code rep False True  x y
+      MO_U_Rem  rep -> div_code rep False False x y
+
+      MO_S_MulMayOflo rep -> imulMayOflo rep x y
+
+      MO_Mul W8  -> imulW8 x y
+      MO_Mul rep -> triv_op rep IMUL
+      MO_And rep -> triv_op rep AND
+      MO_Or  rep -> triv_op rep OR
+      MO_Xor rep -> triv_op rep XOR
+
+        {- Shift ops on x86s have constraints on their source, it
+           either has to be Imm, CL or 1
+            => trivialCode is not restrictive enough (sigh.)
+        -}
+      MO_Shl rep   -> shift_code rep SHL x y {-False-}
+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}
+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}
+
+      MO_V_Insert {}   -> needLlvm
+      MO_V_Extract {}  -> needLlvm
+      MO_V_Add {}      -> needLlvm
+      MO_V_Sub {}      -> needLlvm
+      MO_V_Mul {}      -> needLlvm
+      MO_VS_Quot {}    -> needLlvm
+      MO_VS_Rem {}     -> needLlvm
+      MO_VS_Neg {}     -> needLlvm
+      MO_VF_Insert {}  -> needLlvm
+      MO_VF_Extract {} -> needLlvm
+      MO_VF_Add {}     -> needLlvm
+      MO_VF_Sub {}     -> needLlvm
+      MO_VF_Mul {}     -> needLlvm
+      MO_VF_Quot {}    -> needLlvm
+      MO_VF_Neg {}     -> needLlvm
+
+      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
+  where
+    --------------------
+    triv_op width instr = trivialCode width op (Just op) x y
+                        where op   = instr (intFormat width)
+
+    -- Special case for IMUL for bytes, since the result of IMULB will be in
+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider
+    -- values.
+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register
+    imulW8 arg_a arg_b = do
+        (a_reg, a_code) <- getNonClobberedReg arg_a
+        b_code <- getAnyReg arg_b
+
+        let code = a_code `appOL` b_code eax `appOL`
+                   toOL [ IMUL2 format (OpReg a_reg) ]
+            format = intFormat W8
+
+        return (Fixed format eax code)
+
+
+    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    imulMayOflo rep a b = do
+         (a_reg, a_code) <- getNonClobberedReg a
+         b_code <- getAnyReg b
+         let
+             shift_amt  = case rep of
+                           W32 -> 31
+                           W64 -> 63
+                           _ -> panic "shift_amt"
+
+             format = intFormat rep
+             code = a_code `appOL` b_code eax `appOL`
+                        toOL [
+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax
+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),
+                                -- sign extend lower part
+                           SUB format (OpReg edx) (OpReg eax)
+                                -- compare against upper
+                           -- eax==0 if high part == sign extended low part
+                        ]
+         return (Fixed format eax code)
+
+    --------------------
+    shift_code :: Width
+               -> (Format -> Operand -> Operand -> Instr)
+               -> CmmExpr
+               -> CmmExpr
+               -> NatM Register
+
+    {- Case1: shift length as immediate -}
+    shift_code width instr x (CmmLit lit) = do
+          x_code <- getAnyReg x
+          let
+               format = intFormat width
+               code dst
+                  = x_code dst `snocOL`
+                    instr format (OpImm (litToImm lit)) (OpReg dst)
+          return (Any format code)
+
+    {- Case2: shift length is complex (non-immediate)
+      * y must go in %ecx.
+      * we cannot do y first *and* put its result in %ecx, because
+        %ecx might be clobbered by x.
+      * if we do y second, then x cannot be
+        in a clobbered reg.  Also, we cannot clobber x's reg
+        with the instruction itself.
+      * so we can either:
+        - do y first, put its result in a fresh tmp, then copy it to %ecx later
+        - do y second and put its result into %ecx.  x gets placed in a fresh
+          tmp.  This is likely to be better, because the reg alloc can
+          eliminate this reg->reg move here (it won't eliminate the other one,
+          because the move is into the fixed %ecx).
+    -}
+    shift_code width instr x y{-amount-} = do
+        x_code <- getAnyReg x
+        let format = intFormat width
+        tmp <- getNewRegNat format
+        y_code <- getAnyReg y
+        let
+           code = x_code tmp `appOL`
+                  y_code ecx `snocOL`
+                  instr format (OpReg ecx) (OpReg tmp)
+        return (Fixed format tmp code)
+
+    --------------------
+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    add_code rep x (CmmLit (CmmInt y _))
+        | is32BitInteger y = add_int rep x y
+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
+      where format = intFormat rep
+    -- TODO: There are other interesting patterns we want to replace
+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.
+
+    --------------------
+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    sub_code rep x (CmmLit (CmmInt y _))
+        | is32BitInteger (-y) = add_int rep x (-y)
+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
+
+    -- our three-operand add instruction:
+    add_int width x y = do
+        (x_reg, x_code) <- getSomeReg x
+        let
+            format = intFormat width
+            imm = ImmInt (fromInteger y)
+            code dst
+               = x_code `snocOL`
+                 LEA format
+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
+                        (OpReg dst)
+        --
+        return (Any format code)
+
+    ----------------------
+
+    -- See Note [DIV/IDIV for bytes]
+    div_code W8 signed quotient x y = do
+        let widen | signed    = MO_SS_Conv W8 W16
+                  | otherwise = MO_UU_Conv W8 W16
+        div_code
+            W16
+            signed
+            quotient
+            (CmmMachOp widen [x])
+            (CmmMachOp widen [y])
+
+    div_code width signed quotient x y = do
+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
+           x_code <- getAnyReg x
+           let
+             format = intFormat width
+             widen | signed    = CLTD format
+                   | otherwise = XOR format (OpReg edx) (OpReg edx)
+
+             instr | signed    = IDIV
+                   | otherwise = DIV
+
+             code = y_code `appOL`
+                    x_code eax `appOL`
+                    toOL [widen, instr format y_op]
+
+             result | quotient  = eax
+                    | otherwise = edx
+
+           return (Fixed format result code)
+
+
+getRegister' _ _ (CmmLoad mem pk)
+  | isFloatType pk
+  = do
+    Amode addr mem_code <- getAmode mem
+    loadFloatAmode  (typeWidth pk) addr mem_code
+
+getRegister' _ is32Bit (CmmLoad mem pk)
+  | is32Bit && not (isWord64 pk)
+  = do
+    code <- intLoadCode instr mem
+    return (Any format code)
+  where
+    width = typeWidth pk
+    format = intFormat width
+    instr = case width of
+                W8     -> MOVZxL II8
+                _other -> MOV format
+        -- We always zero-extend 8-bit loads, if we
+        -- can't think of anything better.  This is because
+        -- we can't guarantee access to an 8-bit variant of every register
+        -- (esi and edi don't have 8-bit variants), so to make things
+        -- simpler we do our 8-bit arithmetic with full 32-bit registers.
+
+-- Simpler memory load code on x86_64
+getRegister' _ is32Bit (CmmLoad mem pk)
+ | not is32Bit
+  = do
+    code <- intLoadCode (MOV format) mem
+    return (Any format code)
+  where format = intFormat $ typeWidth pk
+
+getRegister' _ is32Bit (CmmLit (CmmInt 0 width))
+  = let
+        format = intFormat width
+
+        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
+        format1 = if is32Bit then format
+                           else case format of
+                                II64 -> II32
+                                _ -> format
+        code dst
+           = unitOL (XOR format1 (OpReg dst) (OpReg dst))
+    in
+        return (Any format code)
+
+  -- optimisation for loading small literals on x86_64: take advantage
+  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
+  -- instruction forms are shorter.
+getRegister' dflags is32Bit (CmmLit lit)
+  | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit)
+  = let
+        imm = litToImm lit
+        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
+    in
+        return (Any II64 code)
+  where
+   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff
+   isBigLit _ = False
+        -- note1: not the same as (not.is32BitLit), because that checks for
+        -- signed literals that fit in 32 bits, but we want unsigned
+        -- literals here.
+        -- note2: all labels are small, because we're assuming the
+        -- small memory model (see gcc docs, -mcmodel=small).
+
+getRegister' dflags _ (CmmLit lit)
+  = do let format = cmmTypeFormat (cmmLitType dflags lit)
+           imm = litToImm lit
+           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))
+       return (Any format code)
+
+getRegister' _ _ other
+    | isVecExpr other  = needLlvm
+    | otherwise        = pprPanic "getRegister(x86)" (ppr other)
+
+
+intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
+   -> NatM (Reg -> InstrBlock)
+intLoadCode instr mem = do
+  Amode src mem_code <- getAmode mem
+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
+
+-- Compute an expression into *any* register, adding the appropriate
+-- move instruction if necessary.
+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg expr = do
+  r <- getRegister expr
+  anyReg r
+
+anyReg :: Register -> NatM (Reg -> InstrBlock)
+anyReg (Any _ code)          = return code
+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
+
+-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
+-- Fixed registers might not be byte-addressable, so we make sure we've
+-- got a temporary, inserting an extra reg copy if necessary.
+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg expr = do
+  is32Bit <- is32BitPlatform
+  if is32Bit
+      then do r <- getRegister expr
+              case r of
+                Any rep code -> do
+                    tmp <- getNewRegNat rep
+                    return (tmp, code tmp)
+                Fixed rep reg code
+                    | isVirtualReg reg -> return (reg,code)
+                    | otherwise -> do
+                        tmp <- getNewRegNat rep
+                        return (tmp, code `snocOL` reg2reg rep reg tmp)
+                    -- ToDo: could optimise slightly by checking for
+                    -- byte-addressable real registers, but that will
+                    -- happen very rarely if at all.
+      else getSomeReg expr -- all regs are byte-addressable on x86_64
+
+-- Another variant: this time we want the result in a register that cannot
+-- be modified by code to evaluate an arbitrary expression.
+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg expr = do
+  dflags <- getDynFlags
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed rep reg code
+        -- only certain regs can be clobbered
+        | reg `elem` instrClobberedRegs (targetPlatform dflags)
+        -> do
+                tmp <- getNewRegNat rep
+                return (tmp, code `snocOL` reg2reg rep reg tmp)
+        | otherwise ->
+                return (reg, code)
+
+reg2reg :: Format -> Reg -> Reg -> Instr
+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)
+
+
+--------------------------------------------------------------------------------
+getAmode :: CmmExpr -> NatM Amode
+getAmode e = do is32Bit <- is32BitPlatform
+                getAmode' is32Bit e
+
+getAmode' :: Bool -> CmmExpr -> NatM Amode
+getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags
+                                 getAmode $ mangleIndexTree dflags r n
+
+getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
+                                                  CmmLit displacement])
+ | not is32Bit
+    = return $ Amode (ripRel (litToImm displacement)) nilOL
+
+
+-- This is all just ridiculous, since it carefully undoes
+-- what mangleIndexTree has just done.
+getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)])
+  | is32BitLit is32Bit lit
+  -- ASSERT(rep == II32)???
+  = do (x_reg, x_code) <- getSomeReg x
+       let off = ImmInt (-(fromInteger i))
+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
+
+getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit])
+  | is32BitLit is32Bit lit
+  -- ASSERT(rep == II32)???
+  = do (x_reg, x_code) <- getSomeReg x
+       let off = litToImm lit
+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
+
+-- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be
+-- recognised by the next rule.
+getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
+                                  b@(CmmLit _)])
+  = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a])
+
+-- Matches: (x + offset) + (y << shift)
+getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset,
+                                   CmmMachOp (MO_Shl _)
+                                        [y, CmmLit (CmmInt shift _)]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  = x86_complex_amode (CmmReg x) y shift (fromIntegral offset)
+
+getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _)
+                                        [y, CmmLit (CmmInt shift _)]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  = x86_complex_amode x y shift 0
+
+getAmode' _ (CmmMachOp (MO_Add _)
+                [x, CmmMachOp (MO_Add _)
+                        [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
+                         CmmLit (CmmInt offset _)]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  && is32BitInteger offset
+  = x86_complex_amode x y shift offset
+
+getAmode' _ (CmmMachOp (MO_Add _) [x,y])
+  = x86_complex_amode x y 0 0
+
+getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit
+  = return (Amode (ImmAddr (litToImm lit) 0) nilOL)
+
+getAmode' _ expr = do
+  (reg,code) <- getSomeReg expr
+  return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
+
+-- | Like 'getAmode', but on 32-bit use simple register addressing
+-- (i.e. no index register). This stops us from running out of
+-- registers on x86 when using instructions such as cmpxchg, which can
+-- use up to three virtual registers and one fixed register.
+getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode
+getSimpleAmode dflags is32Bit addr
+    | is32Bit = do
+        addr_code <- getAnyReg addr
+        addr_r <- getNewRegNat (intFormat (wordWidth dflags))
+        let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)
+        return $! Amode amode (addr_code addr_r)
+    | otherwise = getAmode addr
+
+x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
+x86_complex_amode base index shift offset
+  = do (x_reg, x_code) <- getNonClobberedReg base
+        -- x must be in a temp, because it has to stay live over y_code
+        -- we could compre x_reg and y_reg and do something better here...
+       (y_reg, y_code) <- getSomeReg index
+       let
+           code = x_code `appOL` y_code
+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;
+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"
+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
+               code)
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- getOperand: sometimes any operand will do.
+
+-- getNonClobberedOperand: the value of the operand will remain valid across
+-- the computation of an arbitrary expression, unless the expression
+-- is computed directly into a register which the operand refers to
+-- (see trivialCode where this function is used for an example).
+
+getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
+getNonClobberedOperand (CmmLit lit) = do
+  if  isSuitableFloatingPointLit lit
+    then do
+      let CmmFloat _ w = lit
+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
+      return (OpAddr addr, code)
+     else do
+
+  is32Bit <- is32BitPlatform
+  dflags <- getDynFlags
+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))
+    then return (OpImm (litToImm lit), nilOL)
+    else getNonClobberedOperand_generic (CmmLit lit)
+
+getNonClobberedOperand (CmmLoad mem pk) = do
+  is32Bit <- is32BitPlatform
+  -- this logic could be simplified
+  -- TODO FIXME
+  if   (if is32Bit then not (isWord64 pk) else True)
+      -- if 32bit and pk is at float/double/simd value
+      -- or if 64bit
+      --  this could use some eyeballs or i'll need to stare at it more later
+    then do
+      dflags <- getDynFlags
+      let platform = targetPlatform dflags
+      Amode src mem_code <- getAmode mem
+      (src',save_code) <-
+        if (amodeCouldBeClobbered platform src)
+                then do
+                   tmp <- getNewRegNat (archWordFormat is32Bit)
+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
+                           unitOL (LEA (archWordFormat is32Bit)
+                                       (OpAddr src)
+                                       (OpReg tmp)))
+                else
+                   return (src, nilOL)
+      return (OpAddr src', mem_code `appOL` save_code)
+    else do
+      -- if its a word or gcptr on 32bit?
+      getNonClobberedOperand_generic (CmmLoad mem pk)
+
+getNonClobberedOperand e = getNonClobberedOperand_generic e
+
+getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
+getNonClobberedOperand_generic e = do
+    (reg, code) <- getNonClobberedReg e
+    return (OpReg reg, code)
+
+amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)
+
+regClobbered :: Platform -> Reg -> Bool
+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr
+regClobbered _ _ = False
+
+-- getOperand: the operand is not required to remain valid across the
+-- computation of an arbitrary expression.
+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
+
+getOperand (CmmLit lit) = do
+  use_sse2 <- sse2Enabled
+  if (use_sse2 && isSuitableFloatingPointLit lit)
+    then do
+      let CmmFloat _ w = lit
+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
+      return (OpAddr addr, code)
+    else do
+
+  is32Bit <- is32BitPlatform
+  dflags <- getDynFlags
+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))
+    then return (OpImm (litToImm lit), nilOL)
+    else getOperand_generic (CmmLit lit)
+
+getOperand (CmmLoad mem pk) = do
+  is32Bit <- is32BitPlatform
+  use_sse2 <- sse2Enabled
+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)
+     then do
+       Amode src mem_code <- getAmode mem
+       return (OpAddr src, mem_code)
+     else
+       getOperand_generic (CmmLoad mem pk)
+
+getOperand e = getOperand_generic e
+
+getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
+getOperand_generic e = do
+    (reg, code) <- getSomeReg e
+    return (OpReg reg, code)
+
+isOperand :: Bool -> CmmExpr -> Bool
+isOperand _ (CmmLoad _ _) = True
+isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit
+                          || isSuitableFloatingPointLit lit
+isOperand _ _            = False
+
+-- | Given a 'Register', produce a new 'Register' with an instruction block
+-- which will check the value for alignment. Used for @-falignment-sanitisation@.
+addAlignmentCheck :: Int -> Register -> Register
+addAlignmentCheck align reg =
+    case reg of
+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)
+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)
+  where
+    check :: Format -> Reg -> InstrBlock
+    check fmt reg =
+        ASSERT(not $ isFloatFormat fmt)
+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)
+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
+             ]
+
+memConstant :: Alignment -> CmmLit -> NatM Amode
+memConstant align lit = do
+  lbl <- getNewLabelNat
+  let rosection = Section ReadOnlyData lbl
+  dflags <- getDynFlags
+  (addr, addr_code) <- if target32Bit (targetPlatform dflags)
+                       then do dynRef <- cmmMakeDynamicReference
+                                             dflags
+                                             DataReference
+                                             lbl
+                               Amode addr addr_code <- getAmode dynRef
+                               return (addr, addr_code)
+                       else return (ripRel (ImmCLbl lbl), nilOL)
+  let code =
+        LDATA rosection (align, Statics lbl [CmmStaticLit lit])
+        `consOL` addr_code
+  return (Amode addr code)
+
+
+loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register
+loadFloatAmode w addr addr_code = do
+  let format = floatFormat w
+      code dst = addr_code `snocOL`
+                    MOV format (OpAddr addr) (OpReg dst)
+
+  return (Any format code)
+
+
+-- if we want a floating-point literal as an operand, we can
+-- use it directly from memory.  However, if the literal is
+-- zero, we're better off generating it into a register using
+-- xor.
+isSuitableFloatingPointLit :: CmmLit -> Bool
+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
+isSuitableFloatingPointLit _ = False
+
+getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
+getRegOrMem e@(CmmLoad mem pk) = do
+  is32Bit <- is32BitPlatform
+  use_sse2 <- sse2Enabled
+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)
+     then do
+       Amode src mem_code <- getAmode mem
+       return (OpAddr src, mem_code)
+     else do
+       (reg, code) <- getNonClobberedReg e
+       return (OpReg reg, code)
+getRegOrMem e = do
+    (reg, code) <- getNonClobberedReg e
+    return (OpReg reg, code)
+
+is32BitLit :: Bool -> CmmLit -> Bool
+is32BitLit is32Bit (CmmInt i W64)
+ | not is32Bit
+    = -- assume that labels are in the range 0-2^31-1: this assumes the
+      -- small memory model (see gcc docs, -mcmodel=small).
+      is32BitInteger i
+is32BitLit _ _ = True
+
+
+
+
+-- Set up a condition code for a conditional branch.
+
+getCondCode :: CmmExpr -> NatM CondCode
+
+-- yes, they really do seem to want exactly the same!
+
+getCondCode (CmmMachOp mop [x, y])
+  =
+    case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      -- Invert comparison condition and swap operands
+      -- See Note [SSE Parity Checks]
+      MO_F_Lt W32 -> condFltCode GTT  y x
+      MO_F_Le W32 -> condFltCode GE   y x
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode GTT y x
+      MO_F_Le W64 -> condFltCode GE  y x
+
+      _ -> condIntCode (machOpToCond mop) x y
+
+getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)
+
+machOpToCond :: MachOp -> Cond
+machOpToCond mo = case mo of
+  MO_Eq _   -> EQQ
+  MO_Ne _   -> NE
+  MO_S_Gt _ -> GTT
+  MO_S_Ge _ -> GE
+  MO_S_Lt _ -> LTT
+  MO_S_Le _ -> LE
+  MO_U_Gt _ -> GU
+  MO_U_Ge _ -> GEU
+  MO_U_Lt _ -> LU
+  MO_U_Le _ -> LEU
+  _other -> pprPanic "machOpToCond" (pprMachOp mo)
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condIntCode cond x y = do is32Bit <- is32BitPlatform
+                          condIntCode' is32Bit cond x y
+
+condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+
+-- memory vs immediate
+condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)
+ | is32BitLit is32Bit lit = do
+    Amode x_addr x_code <- getAmode x
+    let
+        imm  = litToImm lit
+        code = x_code `snocOL`
+                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)
+    --
+    return (CondCode False cond code)
+
+-- anything vs zero, using a mask
+-- TODO: Add some sanity checking!!!!
+condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))
+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit
+    = do
+      (x_reg, x_code) <- getSomeReg x
+      let
+         code = x_code `snocOL`
+                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)
+      --
+      return (CondCode False cond code)
+
+-- anything vs zero
+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do
+    (x_reg, x_code) <- getSomeReg x
+    let
+        code = x_code `snocOL`
+                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)
+    --
+    return (CondCode False cond code)
+
+-- anything vs operand
+condIntCode' is32Bit cond x y
+ | isOperand is32Bit y = do
+    dflags <- getDynFlags
+    (x_reg, x_code) <- getNonClobberedReg x
+    (y_op,  y_code) <- getOperand y
+    let
+        code = x_code `appOL` y_code `snocOL`
+                  CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg)
+    return (CondCode False cond code)
+-- operand vs. anything: invert the comparison so that we can use a
+-- single comparison instruction.
+ | isOperand is32Bit x
+ , Just revcond <- maybeFlipCond cond = do
+    dflags <- getDynFlags
+    (y_reg, y_code) <- getNonClobberedReg y
+    (x_op,  x_code) <- getOperand x
+    let
+        code = y_code `appOL` x_code `snocOL`
+                  CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg)
+    return (CondCode False revcond code)
+
+-- anything vs anything
+condIntCode' _ cond x y = do
+  dflags <- getDynFlags
+  (y_reg, y_code) <- getNonClobberedReg y
+  (x_op, x_code) <- getRegOrMem x
+  let
+        code = y_code `appOL`
+               x_code `snocOL`
+                  CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op
+  return (CondCode False cond code)
+
+
+
+--------------------------------------------------------------------------------
+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+
+condFltCode cond x y
+  =  condFltCode_sse2
+  where
+
+
+  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
+  -- an operand, but the right must be a reg.  We can probably do better
+  -- than this general case...
+  condFltCode_sse2 = do
+    dflags <- getDynFlags
+    (x_reg, x_code) <- getNonClobberedReg x
+    (y_op, y_code) <- getOperand y
+    let
+        code = x_code `appOL`
+               y_code `snocOL`
+                  CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg)
+        -- NB(1): we need to use the unsigned comparison operators on the
+        -- result of this comparison.
+    return (CondCode True (condToUnsigned cond) code)
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+
+-- integer assignment to memory
+
+-- specific case of adding/subtracting an integer to a particular address.
+-- ToDo: catch other cases where we can use an operation directly on a memory
+-- address.
+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,
+                                                 CmmLit (CmmInt i _)])
+   | addr == addr2, pk /= II64 || is32BitInteger i,
+     Just instr <- check op
+   = do Amode amode code_addr <- getAmode addr
+        let code = code_addr `snocOL`
+                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
+        return code
+   where
+        check (MO_Add _) = Just ADD
+        check (MO_Sub _) = Just SUB
+        check _ = Nothing
+        -- ToDo: more?
+
+-- general case
+assignMem_IntCode pk addr src = do
+    is32Bit <- is32BitPlatform
+    Amode addr code_addr <- getAmode addr
+    (code_src, op_src)   <- get_op_RI is32Bit src
+    let
+        code = code_src `appOL`
+               code_addr `snocOL`
+                  MOV pk op_src (OpAddr addr)
+        -- NOTE: op_src is stable, so it will still be valid
+        -- after code_addr.  This may involve the introduction
+        -- of an extra MOV to a temporary register, but we hope
+        -- the register allocator will get rid of it.
+    --
+    return code
+  where
+    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator
+    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit
+      = return (nilOL, OpImm (litToImm lit))
+    get_op_RI _ op
+      = do (reg,code) <- getNonClobberedReg op
+           return (code, OpReg reg)
+
+
+-- Assign; dst is a reg, rhs is mem
+assignReg_IntCode pk reg (CmmLoad src _) = do
+  load_code <- intLoadCode (MOV pk) src
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  return (load_code (getRegisterReg platform reg))
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode _ reg src = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  code <- getAnyReg src
+  return (code (getRegisterReg platform reg))
+
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src = do
+  (src_reg, src_code) <- getNonClobberedReg src
+  Amode addr addr_code <- getAmode addr
+  let
+        code = src_code `appOL`
+               addr_code `snocOL`
+               MOV pk (OpReg src_reg) (OpAddr addr)
+
+  return code
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode _ reg src = do
+  src_code <- getAnyReg src
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  return (src_code (getRegisterReg platform  reg))
+
+
+genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock
+
+genJump (CmmLoad mem _) regs = do
+  Amode target code <- getAmode mem
+  return (code `snocOL` JMP (OpAddr target) regs)
+
+genJump (CmmLit lit) regs = do
+  return (unitOL (JMP (OpImm (litToImm lit)) regs))
+
+genJump expr regs = do
+  (reg,code) <- getSomeReg expr
+  return (code `snocOL` JMP (OpReg reg) regs)
+
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+
+genBranch :: BlockId -> InstrBlock
+genBranch = toOL . mkJumpInstr
+
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps/branches
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+
+I386: First, we have to ensure that the condition
+codes are set according to the supplied comparison operation.
+-}
+
+
+genCondBranch
+    :: BlockId      -- the source of the jump
+    -> BlockId      -- the true branch target
+    -> BlockId      -- the false branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> NatM InstrBlock -- Instructions
+
+genCondBranch bid id false expr = do
+  is32Bit <- is32BitPlatform
+  genCondBranch' is32Bit bid id false expr
+
+-- | We return the instructions generated.
+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
+               -> NatM InstrBlock
+
+-- 64-bit integer comparisons on 32-bit
+genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
+  | is32Bit, Just W64 <- maybeIntComparison mop = do
+  ChildCode64 code1 r1_lo <- iselExpr64 e1
+  ChildCode64 code2 r2_lo <- iselExpr64 e2
+  let r1_hi = getHiVRegFromLo r1_lo
+      r2_hi = getHiVRegFromLo r2_lo
+      cond = machOpToCond mop
+      Just cond' = maybeFlipCond cond
+  --TODO: Update CFG for x86
+  let code = code1 `appOL` code2 `appOL` toOL [
+        CMP II32 (OpReg r2_hi) (OpReg r1_hi),
+        JXX cond true,
+        JXX cond' false,
+        CMP II32 (OpReg r2_lo) (OpReg r1_lo),
+        JXX cond true] `appOL` genBranch false
+  return code
+
+genCondBranch' _ bid id false bool = do
+  CondCode is_float cond cond_code <- getCondCode bool
+  use_sse2 <- sse2Enabled
+  if not is_float || not use_sse2
+    then
+        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)
+    else do
+        -- See Note [SSE Parity Checks]
+        let jmpFalse = genBranch false
+            code
+                = case cond of
+                  NE  -> or_unordered
+                  GU  -> plain_test
+                  GEU -> plain_test
+                  -- Use ASSERT so we don't break releases if
+                  -- LTT/LE creep in somehow.
+                  LTT ->
+                    ASSERT2(False, ppr "Should have been turned into >")
+                    and_ordered
+                  LE  ->
+                    ASSERT2(False, ppr "Should have been turned into >=")
+                    and_ordered
+                  _   -> and_ordered
+
+            plain_test = unitOL (
+                  JXX cond id
+                ) `appOL` jmpFalse
+            or_unordered = toOL [
+                  JXX cond id,
+                  JXX PARITY id
+                ] `appOL` jmpFalse
+            and_ordered = toOL [
+                  JXX PARITY false,
+                  JXX cond id,
+                  JXX ALWAYS false
+                ]
+        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)
+        return (cond_code `appOL` code)
+
+-- -----------------------------------------------------------------------------
+--  Generating C calls
+
+-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations.  Apart from that, the code is easy.
+--
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genCCall
+    :: DynFlags
+    -> Bool                     -- 32 bit platform?
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> BlockId      -- The block we are in
+    -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+-- Unroll memcpy calls if the number of bytes to copy isn't too
+-- large.  Otherwise, call C's memcpy.
+genCCall dflags _ (PrimTarget (MO_Memcpy align)) _
+         [dst, src, CmmLit (CmmInt n _)] _
+    | fromInteger insns <= maxInlineMemcpyInsns dflags = do
+        code_dst <- getAnyReg dst
+        dst_r <- getNewRegNat format
+        code_src <- getAnyReg src
+        src_r <- getNewRegNat format
+        tmp_r <- getNewRegNat format
+        return $ code_dst dst_r `appOL` code_src src_r `appOL`
+            go dst_r src_r tmp_r (fromInteger n)
+  where
+    -- The number of instructions we will generate (approx). We need 2
+    -- instructions per move.
+    insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
+
+    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
+    effectiveAlignment = min (alignmentOf align) maxAlignment
+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
+
+    -- The size of each move, in bytes.
+    sizeBytes :: Integer
+    sizeBytes = fromIntegral (formatInBytes format)
+
+    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
+    go dst src tmp i
+        | i >= sizeBytes =
+            unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - sizeBytes)
+        -- Deal with remaining bytes.
+        | i >= 4 =  -- Will never happen on 32-bit
+            unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - 4)
+        | i >= 2 =
+            unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - 2)
+        | i >= 1 =
+            unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - 1)
+        | otherwise = nilOL
+      where
+        src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone
+                   (ImmInteger (n - i))
+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
+                   (ImmInteger (n - i))
+
+genCCall dflags _ (PrimTarget (MO_Memset align)) _
+         [dst,
+          CmmLit (CmmInt c _),
+          CmmLit (CmmInt n _)]
+         _
+    | fromInteger insns <= maxInlineMemsetInsns dflags = do
+        code_dst <- getAnyReg dst
+        dst_r <- getNewRegNat format
+        if format == II64 && n >= 8 then do
+          code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))
+          imm8byte_r <- getNewRegNat II64
+          return $ code_dst dst_r `appOL`
+                   code_imm8byte imm8byte_r `appOL`
+                   go8 dst_r imm8byte_r (fromInteger n)
+        else
+          return $ code_dst dst_r `appOL`
+                   go4 dst_r (fromInteger n)
+  where
+    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
+    effectiveAlignment = min (alignmentOf align) maxAlignment
+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
+    c2 = c `shiftL` 8 .|. c
+    c4 = c2 `shiftL` 16 .|. c2
+    c8 = c4 `shiftL` 32 .|. c4
+
+    -- The number of instructions we will generate (approx). We need 1
+    -- instructions per move.
+    insns = (n + sizeBytes - 1) `div` sizeBytes
+
+    -- The size of each move, in bytes.
+    sizeBytes :: Integer
+    sizeBytes = fromIntegral (formatInBytes format)
+
+    -- Depending on size returns the widest MOV instruction and its
+    -- width.
+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)
+    gen4 addr size
+        | size >= 4 =
+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)
+        | size >= 2 =
+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)
+        | size >= 1 =
+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)
+        | otherwise = (nilOL, 0)
+
+    -- Generates a 64-bit wide MOV instruction from REG to MEM.
+    gen8 :: AddrMode -> Reg -> InstrBlock
+    gen8 addr reg8byte =
+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))
+
+    -- Unrolls memset when the widest MOV is <= 4 bytes.
+    go4 :: Reg -> Integer -> InstrBlock
+    go4 dst left =
+      if left <= 0 then nilOL
+      else curMov `appOL` go4 dst (left - curWidth)
+      where
+        possibleWidth = minimum [left, sizeBytes]
+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))
+        (curMov, curWidth) = gen4 dst_addr possibleWidth
+
+    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg
+    -- argument). Falls back to go4 when all 8 byte moves are
+    -- exhausted.
+    go8 :: Reg -> Reg -> Integer -> InstrBlock
+    go8 dst reg8byte left =
+      if possibleWidth >= 8 then
+        let curMov = gen8 dst_addr reg8byte
+        in  curMov `appOL` go8 dst reg8byte (left - 8)
+      else go4 dst left
+      where
+        possibleWidth = minimum [left, sizeBytes]
+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))
+
+genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL
+        -- write barrier compiles to no code on x86/x86-64;
+        -- we keep it this long in order to prevent earlier optimisations.
+
+genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL
+
+genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =
+        case n of
+            0 -> genPrefetch src $ PREFETCH NTA  format
+            1 -> genPrefetch src $ PREFETCH Lvl2 format
+            2 -> genPrefetch src $ PREFETCH Lvl1 format
+            3 -> genPrefetch src $ PREFETCH Lvl0 format
+            l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l)
+            -- the c / llvm prefetch convention is 0, 1, 2, and 3
+            -- the x86 corresponding names are : NTA, 2 , 1, and 0
+   where
+        format = archWordFormat is32bit
+        -- need to know what register width for pointers!
+        genPrefetch inRegSrc prefetchCTor =
+            do
+                code_src <- getAnyReg inRegSrc
+                src_r <- getNewRegNat format
+                return $ code_src src_r `appOL`
+                  (unitOL (prefetchCTor  (OpAddr
+                              ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))
+                  -- prefetch always takes an address
+
+genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do
+    let platform = targetPlatform dflags
+    let dst_r = getRegisterReg platform (CmmLocal dst)
+    case width of
+        W64 | is32Bit -> do
+               ChildCode64 vcode rlo <- iselExpr64 src
+               let dst_rhi = getHiVRegFromLo dst_r
+                   rhi     = getHiVRegFromLo rlo
+               return $ vcode `appOL`
+                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),
+                               MOV II32 (OpReg rhi) (OpReg dst_r),
+                               BSWAP II32 dst_rhi,
+                               BSWAP II32 dst_r ]
+        W16 -> do code_src <- getAnyReg src
+                  return $ code_src dst_r `appOL`
+                           unitOL (BSWAP II32 dst_r) `appOL`
+                           unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))
+        _   -> do code_src <- getAnyReg src
+                  return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)
+  where
+    format = intFormat width
+
+genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
+         args@[src] bid = do
+    sse4_2 <- sse4_2Enabled
+    let platform = targetPlatform dflags
+    if sse4_2
+        then do code_src <- getAnyReg src
+                src_r <- getNewRegNat format
+                let dst_r = getRegisterReg platform  (CmmLocal dst)
+                return $ code_src src_r `appOL`
+                    (if width == W8 then
+                         -- The POPCNT instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`
+                         unitOL (POPCNT II16 (OpReg src_r) dst_r)
+                     else
+                         unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args bid
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
+         args@[src, mask] bid = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform  (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PDEP instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8  (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8  (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PDEP   II16 (OpReg mask_r) (OpReg src_r ) dst_r)
+                     else
+                         unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args bid
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
+         args@[src, mask] bid = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform  (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PEXT instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r)
+                     else
+                         unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args bid
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid
+  | is32Bit && width == W64 = do
+    -- Fallback to `hs_clz64` on i386
+    targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                           [NoHint] [NoHint]
+                                           CmmMayReturn)
+    genCCall dflags is32Bit target dest_regs args bid
+
+  | otherwise = do
+    code_src <- getAnyReg src
+    let dst_r = getRegisterReg platform (CmmLocal dst)
+    if isBmi2Enabled dflags
+        then do
+            src_r <- getNewRegNat (intFormat width)
+            return $ appOL (code_src src_r) $ case width of
+                W8 -> toOL
+                    [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit
+                    , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros
+                    , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros
+                    ]
+                W16 -> toOL
+                    [ LZCNT  II16 (OpReg src_r) dst_r
+                    , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit
+                    ]
+                _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)
+        else do
+            let format = if width == W8 then II16 else intFormat width
+            src_r <- getNewRegNat format
+            tmp_r <- getNewRegNat format
+            return $ code_src src_r `appOL` toOL
+                     ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++
+                      [ BSR     format (OpReg src_r) tmp_r
+                      , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)
+                      , CMOV NE format (OpReg tmp_r) dst_r
+                      , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)
+                      ]) -- NB: We don't need to zero-extend the result for the
+                         -- W8/W16 cases because the 'MOV' insn already
+                         -- took care of implicitly clearing the upper bits
+  where
+    bw = widthInBits width
+    platform = targetPlatform dflags
+    lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
+  | is32Bit, width == W64 = do
+      ChildCode64 vcode rlo <- iselExpr64 src
+      let rhi     = getHiVRegFromLo rlo
+          dst_r   = getRegisterReg platform  (CmmLocal dst)
+      lbl1 <- getBlockIdNat
+      lbl2 <- getBlockIdNat
+      let format = if width == W8 then II16 else intFormat width
+      tmp_r <- getNewRegNat format
+
+      -- New CFG Edges:
+      --  bid -> lbl2
+      --  bid -> lbl1 -> lbl2
+      --  We also changes edges originating at bid to start at lbl2 instead.
+      updateCfgNat (addWeightEdge bid lbl1 110 .
+                    addWeightEdge lbl1 lbl2 110 .
+                    addImmediateSuccessor bid lbl2)
+
+      -- The following instruction sequence corresponds to the pseudo-code
+      --
+      --  if (src) {
+      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);
+      --  } else {
+      --    dst = 64;
+      --  }
+      return $ vcode `appOL` toOL
+               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)
+                , OR       II32 (OpReg rlo)         (OpReg tmp_r)
+                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)
+                , JXX EQQ    lbl2
+                , JXX ALWAYS lbl1
+
+                , NEWBLOCK   lbl1
+                , BSF     II32 (OpReg rhi)         dst_r
+                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)
+                , BSF     II32 (OpReg rlo)         tmp_r
+                , CMOV NE II32 (OpReg tmp_r)       dst_r
+                , JXX ALWAYS lbl2
+
+                , NEWBLOCK   lbl2
+                ])
+
+  | otherwise = do
+    code_src <- getAnyReg src
+    let dst_r = getRegisterReg platform (CmmLocal dst)
+
+    if isBmi2Enabled dflags
+    then do
+        src_r <- getNewRegNat (intFormat width)
+        return $ appOL (code_src src_r) $ case width of
+            W8 -> toOL
+                [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)
+                , TZCNT II32 (OpReg src_r)        dst_r
+                ]
+            W16 -> toOL
+                [ TZCNT  II16 (OpReg src_r) dst_r
+                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)
+                ]
+            _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r
+    else do
+        -- The following insn sequence makes sure 'ctz 0' has a defined value.
+        -- starting with Haswell, one could use the TZCNT insn instead.
+        let format = if width == W8 then II16 else intFormat width
+        src_r <- getNewRegNat format
+        tmp_r <- getNewRegNat format
+        return $ code_src src_r `appOL` toOL
+                 ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++
+                  [ BSF     format (OpReg src_r) tmp_r
+                  , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)
+                  , CMOV NE format (OpReg tmp_r) dst_r
+                  ]) -- NB: We don't need to zero-extend the result for the
+                     -- W8/W16 cases because the 'MOV' insn already
+                     -- took care of implicitly clearing the upper bits
+  where
+    bw = widthInBits width
+    platform = targetPlatform dflags
+
+genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
+    targetExpr <- cmmMakeDynamicReference dflags
+                  CallReference lbl
+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                           [NoHint] [NoHint]
+                                           CmmMayReturn)
+    genCCall dflags is32Bit target dest_regs args bid
+  where
+    lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))
+                                           [dst] [addr, n] bid = do
+    Amode amode addr_code <-
+        if amop `elem` [AMO_Add, AMO_Sub]
+        then getAmode addr
+        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg
+    arg <- getNewRegNat format
+    arg_code <- getAnyReg n
+    let platform = targetPlatform dflags
+        dst_r    = getRegisterReg platform  (CmmLocal dst)
+    code <- op_code dst_r arg amode
+    return $ addr_code `appOL` arg_code arg `appOL` code
+  where
+    -- Code for the operation
+    op_code :: Reg       -- Destination reg
+            -> Reg       -- Register containing argument
+            -> AddrMode  -- Address of location to mutate
+            -> NatM (OrdList Instr)
+    op_code dst_r arg amode = case amop of
+        -- In the common case where dst_r is a virtual register the
+        -- final move should go away, because it's the last use of arg
+        -- and the first use of dst_r.
+        AMO_Add  -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))
+                                  , MOV format (OpReg arg) (OpReg dst_r)
+                                  ]
+        AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)
+                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))
+                                  , MOV format (OpReg arg) (OpReg dst_r)
+                                  ]
+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)
+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst
+                                                    , NOT format dst
+                                                    ])
+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)
+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)
+      where
+        -- Simulate operation that lacks a dedicated instruction using
+        -- cmpxchg.
+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)
+                     -> NatM (OrdList Instr)
+        cmpxchg_code instrs = do
+            lbl <- getBlockIdNat
+            tmp <- getNewRegNat format
+
+            --Record inserted blocks
+            addImmediateSuccessorNat bid lbl
+            updateCfgNat (addWeightEdge lbl lbl 0)
+
+            return $ toOL
+                [ MOV format (OpAddr amode) (OpReg eax)
+                , JXX ALWAYS lbl
+                , NEWBLOCK lbl
+                  -- Keep old value so we can return it:
+                , MOV format (OpReg eax) (OpReg dst_r)
+                , MOV format (OpReg eax) (OpReg tmp)
+                ]
+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL
+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))
+                , JXX NE lbl
+                ]
+
+    format = intFormat width
+
+genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do
+  load_code <- intLoadCode (MOV (intFormat width)) addr
+  let platform = targetPlatform dflags
+
+  return (load_code (getRegisterReg platform  (CmmLocal dst)))
+
+genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do
+    code <- assignMem_IntCode (intFormat width) addr val
+    return $ code `snocOL` MFENCE
+
+genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do
+    -- On x86 we don't have enough registers to use cmpxchg with a
+    -- complicated addressing mode, so on that architecture we
+    -- pre-compute the address first.
+    Amode amode addr_code <- getSimpleAmode dflags is32Bit addr
+    newval <- getNewRegNat format
+    newval_code <- getAnyReg new
+    oldval <- getNewRegNat format
+    oldval_code <- getAnyReg old
+    let platform = targetPlatform dflags
+        dst_r    = getRegisterReg platform  (CmmLocal dst)
+        code     = toOL
+                   [ MOV format (OpReg oldval) (OpReg eax)
+                   , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))
+                   , MOV format (OpReg eax) (OpReg dst_r)
+                   ]
+    return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval
+        `appOL` code
+  where
+    format = intFormat width
+
+genCCall _ is32Bit target dest_regs args bid = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  case (target, dest_regs) of
+    -- void return type prim op
+    (PrimTarget op, []) ->
+        outOfLineCmmOp bid op Nothing args
+    -- we only cope with a single result for foreign calls
+    (PrimTarget op, [r])  -> case op of
+          MO_F32_Fabs -> case args of
+            [x] -> sse2FabsCode W32 x
+            _ -> panic "genCCall: Wrong number of arguments for fabs"
+          MO_F64_Fabs -> case args of
+            [x] -> sse2FabsCode W64 x
+            _ -> panic "genCCall: Wrong number of arguments for fabs"
+
+          MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args
+          MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args
+          _other_op -> outOfLineCmmOp bid op (Just r) args
+
+       where
+        actuallyInlineSSE2Op = actuallyInlineFloatOp'
+
+        actuallyInlineFloatOp'  instr format [x]
+              = do res <- trivialUFCode format (instr format) x
+                   any <- anyReg res
+                   return (any (getRegisterReg platform  (CmmLocal r)))
+
+        actuallyInlineFloatOp' _ _ args
+              = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("
+                      ++ show (length args) ++ ")"
+
+        sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock
+        sse2FabsCode w x = do
+          let fmt = floatFormat w
+          x_code <- getAnyReg x
+          let
+            const | FF32 <- fmt = CmmInt 0x7fffffff W32
+                  | otherwise   = CmmInt 0x7fffffffffffffff W64
+          Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const
+          tmp <- getNewRegNat fmt
+          let
+            code dst = x_code dst `appOL` amode_code `appOL` toOL [
+                MOV fmt (OpAddr amode) (OpReg tmp),
+                AND fmt (OpReg tmp) (OpReg dst)
+                ]
+
+          return $ code (getRegisterReg platform (CmmLocal r))
+
+    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args
+    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args
+    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args
+    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->
+        case args of
+        [arg_x, arg_y] ->
+            do hCode <- getAnyReg (CmmLit (CmmInt 0 width))
+               let format = intFormat width
+               lCode <- anyReg =<< trivialCode width (ADD_CC format)
+                                     (Just (ADD_CC format)) arg_x arg_y
+               let reg_l = getRegisterReg platform (CmmLocal res_l)
+                   reg_h = getRegisterReg platform (CmmLocal res_h)
+                   code = hCode reg_h `appOL`
+                          lCode reg_l `snocOL`
+                          ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)
+               return code
+        _ -> panic "genCCall: Wrong number of arguments/results for add2"
+    (PrimTarget (MO_AddWordC width), [res_r, res_c]) ->
+        addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args
+    (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->
+        addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args
+    (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->
+        addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args
+    (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->
+        addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args
+    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->
+        case args of
+        [arg_x, arg_y] ->
+            do (y_reg, y_code) <- getRegOrMem arg_y
+               x_code <- getAnyReg arg_x
+               let format = intFormat width
+                   reg_h = getRegisterReg platform (CmmLocal res_h)
+                   reg_l = getRegisterReg platform (CmmLocal res_l)
+                   code = y_code `appOL`
+                          x_code rax `appOL`
+                          toOL [MUL2 format y_reg,
+                                MOV format (OpReg rdx) (OpReg reg_h),
+                                MOV format (OpReg rax) (OpReg reg_l)]
+               return code
+        _ -> panic "genCCall: Wrong number of arguments/results for mul2"
+
+    _ -> if is32Bit
+         then genCCall32' dflags target dest_regs args
+         else genCCall64' dflags target dest_regs args
+
+  where divOp1 platform signed width results [arg_x, arg_y]
+            = divOp platform signed width results Nothing arg_x arg_y
+        divOp1 _ _ _ _ _
+            = panic "genCCall: Wrong number of arguments for divOp1"
+        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]
+            = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y
+        divOp2 _ _ _ _ _
+            = panic "genCCall: Wrong number of arguments for divOp2"
+
+        -- See Note [DIV/IDIV for bytes]
+        divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =
+            let widen | signed = MO_SS_Conv W8 W16
+                      | otherwise = MO_UU_Conv W8 W16
+                arg_x_low_16 = CmmMachOp widen [arg_x_low]
+                arg_y_16 = CmmMachOp widen [arg_y]
+                m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high
+            in divOp
+                  platform signed W16 [res_q, res_r]
+                  m_arg_x_high_16 arg_x_low_16 arg_y_16
+
+        divOp platform signed width [res_q, res_r]
+              m_arg_x_high arg_x_low arg_y
+            = do let format = intFormat width
+                     reg_q = getRegisterReg platform (CmmLocal res_q)
+                     reg_r = getRegisterReg platform (CmmLocal res_r)
+                     widen | signed    = CLTD format
+                           | otherwise = XOR format (OpReg rdx) (OpReg rdx)
+                     instr | signed    = IDIV
+                           | otherwise = DIV
+                 (y_reg, y_code) <- getRegOrMem arg_y
+                 x_low_code <- getAnyReg arg_x_low
+                 x_high_code <- case m_arg_x_high of
+                                Just arg_x_high ->
+                                    getAnyReg arg_x_high
+                                Nothing ->
+                                    return $ const $ unitOL widen
+                 return $ y_code `appOL`
+                          x_low_code rax `appOL`
+                          x_high_code rdx `appOL`
+                          toOL [instr format y_reg,
+                                MOV format (OpReg rax) (OpReg reg_q),
+                                MOV format (OpReg rdx) (OpReg reg_r)]
+        divOp _ _ _ _ _ _ _
+            = panic "genCCall: Wrong number of results for divOp"
+
+        addSubIntC platform instr mrevinstr cond width
+                   res_r res_c [arg_x, arg_y]
+            = do let format = intFormat width
+                 rCode <- anyReg =<< trivialCode width (instr format)
+                                       (mrevinstr format) arg_x arg_y
+                 reg_tmp <- getNewRegNat II8
+                 let reg_c = getRegisterReg platform  (CmmLocal res_c)
+                     reg_r = getRegisterReg platform  (CmmLocal res_r)
+                     code = rCode reg_r `snocOL`
+                            SETCC cond (OpReg reg_tmp) `snocOL`
+                            MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
+
+                 return code
+        addSubIntC _ _ _ _ _ _ _ _
+            = panic "genCCall: Wrong number of arguments/results for addSubIntC"
+
+-- Note [DIV/IDIV for bytes]
+--
+-- IDIV reminder:
+--   Size    Dividend   Divisor   Quotient    Remainder
+--   byte    %ax         r/m8      %al          %ah
+--   word    %dx:%ax     r/m16     %ax          %dx
+--   dword   %edx:%eax   r/m32     %eax         %edx
+--   qword   %rdx:%rax   r/m64     %rax         %rdx
+--
+-- We do a special case for the byte division because the current
+-- codegen doesn't deal well with accessing %ah register (also,
+-- accessing %ah in 64-bit mode is complicated because it cannot be an
+-- operand of many instructions). So we just widen operands to 16 bits
+-- and get the results from %al, %dl. This is not optimal, but a few
+-- register moves are probably not a huge deal when doing division.
+
+genCCall32' :: DynFlags
+            -> ForeignTarget            -- function to call
+            -> [CmmFormal]        -- where to put the result
+            -> [CmmActual]        -- arguments (of mixed type)
+            -> NatM InstrBlock
+genCCall32' dflags target dest_regs args = do
+        let
+            prom_args = map (maybePromoteCArg dflags W32) args
+
+            -- Align stack to 16n for calls, assuming a starting stack
+            -- alignment of 16n - word_size on procedure entry. Which we
+            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
+            sizes               = map (arg_size_bytes . cmmExprType dflags) (reverse args)
+            raw_arg_size        = sum sizes + wORD_SIZE dflags
+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size
+            tot_arg_size        = raw_arg_size + arg_pad_size - wORD_SIZE dflags
+        delta0 <- getDeltaNat
+        setDeltaNat (delta0 - arg_pad_size)
+
+        push_codes <- mapM push_arg (reverse prom_args)
+        delta <- getDeltaNat
+        MASSERT(delta == delta0 - tot_arg_size)
+
+        -- deal with static vs dynamic call targets
+        (callinsns,cconv) <-
+          case target of
+            ForeignTarget (CmmLit (CmmLabel lbl)) conv
+               -> -- ToDo: stdcall arg sizes
+                  return (unitOL (CALL (Left fn_imm) []), conv)
+               where fn_imm = ImmCLbl lbl
+            ForeignTarget expr conv
+               -> do { (dyn_r, dyn_c) <- getSomeReg expr
+                     ; ASSERT( isWord32 (cmmExprType dflags expr) )
+                       return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
+            PrimTarget _
+                -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
+                            ++ "probably because too many return values."
+
+        let push_code
+                | arg_pad_size /= 0
+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
+                        DELTA (delta0 - arg_pad_size)]
+                  `appOL` concatOL push_codes
+                | otherwise
+                = concatOL push_codes
+
+              -- Deallocate parameters after call for ccall;
+              -- but not for stdcall (callee does it)
+              --
+              -- We have to pop any stack padding we added
+              -- even if we are doing stdcall, though (#5052)
+            pop_size
+               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size
+               | otherwise = tot_arg_size
+
+            call = callinsns `appOL`
+                   toOL (
+                      (if pop_size==0 then [] else
+                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])
+                      ++
+                      [DELTA delta0]
+                   )
+        setDeltaNat delta0
+
+        dflags <- getDynFlags
+        let platform = targetPlatform dflags
+
+        let
+            -- assign the results, if necessary
+            assign_code []     = nilOL
+            assign_code [dest]
+              | isFloatType ty =
+                  -- we assume SSE2
+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)
+                                                       EAIndexNone
+                                                       (ImmInt 0)
+                      fmt = floatFormat w
+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),
+                                   DELTA (delta0 - b),
+                                   X87Store fmt  tmp_amode,
+                                   -- X87Store only supported for the CDECL ABI
+                                   -- NB: This code will need to be
+                                   -- revisted once GHC does more work around
+                                   -- SIGFPE f
+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),
+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),
+                                   DELTA delta0]
+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]
+              | otherwise      = unitOL (MOV (intFormat w)
+                                             (OpReg eax)
+                                             (OpReg r_dest))
+              where
+                    ty = localRegType dest
+                    w  = typeWidth ty
+                    b  = widthInBytes w
+                    r_dest_hi = getHiVRegFromLo r_dest
+                    r_dest    = getRegisterReg platform  (CmmLocal dest)
+            assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)
+
+        return (push_code `appOL`
+                call `appOL`
+                assign_code dest_regs)
+
+      where
+        -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
+        arg_size_bytes :: CmmType -> Int
+        arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth dflags))
+
+        roundTo a x | x `mod` a == 0 = x
+                    | otherwise = x + a - (x `mod` a)
+
+        push_arg :: CmmActual {-current argument-}
+                        -> NatM InstrBlock  -- code
+
+        push_arg  arg -- we don't need the hints on x86
+          | isWord64 arg_ty = do
+            ChildCode64 code r_lo <- iselExpr64 arg
+            delta <- getDeltaNat
+            setDeltaNat (delta - 8)
+            let r_hi = getHiVRegFromLo r_lo
+            return (       code `appOL`
+                           toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
+                                 PUSH II32 (OpReg r_lo), DELTA (delta - 8),
+                                 DELTA (delta-8)]
+                )
+
+          | isFloatType arg_ty = do
+            (reg, code) <- getSomeReg arg
+            delta <- getDeltaNat
+            setDeltaNat (delta-size)
+            return (code `appOL`
+                            toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
+                                  DELTA (delta-size),
+                                  let addr = AddrBaseIndex (EABaseReg esp)
+                                                            EAIndexNone
+                                                            (ImmInt 0)
+                                      format = floatFormat (typeWidth arg_ty)
+                                  in
+
+                                  -- assume SSE2
+                                   MOV format (OpReg reg) (OpAddr addr)
+
+                                 ]
+                           )
+
+          | otherwise = do
+            -- Arguments can be smaller than 32-bit, but we still use @PUSH
+            -- II32@ - the usual calling conventions expect integers to be
+            -- 4-byte aligned.
+            ASSERT((typeWidth arg_ty) <= W32) return ()
+            (operand, code) <- getOperand arg
+            delta <- getDeltaNat
+            setDeltaNat (delta-size)
+            return (code `snocOL`
+                    PUSH II32 operand `snocOL`
+                    DELTA (delta-size))
+
+          where
+             arg_ty = cmmExprType dflags arg
+             size = arg_size_bytes arg_ty -- Byte size
+
+genCCall64' :: DynFlags
+            -> ForeignTarget      -- function to call
+            -> [CmmFormal]        -- where to put the result
+            -> [CmmActual]        -- arguments (of mixed type)
+            -> NatM InstrBlock
+genCCall64' dflags target dest_regs args = do
+    -- load up the register arguments
+    let prom_args = map (maybePromoteCArg dflags W32) args
+
+    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)
+         <-
+        if platformOS platform == OSMinGW32
+        then load_args_win prom_args [] [] (allArgRegs platform) nilOL
+        else do
+           (stack_args, aregs, fregs, load_args_code, assign_args_code)
+               <- load_args prom_args (allIntArgRegs platform)
+                                      (allFPArgRegs platform)
+                                      nilOL nilOL
+           let used_regs rs as = reverse (drop (length rs) (reverse as))
+               fregs_used      = used_regs fregs (allFPArgRegs platform)
+               aregs_used      = used_regs aregs (allIntArgRegs platform)
+           return (stack_args, aregs_used, fregs_used, load_args_code
+                                                      , assign_args_code)
+
+    let
+        arg_regs_used = int_regs_used ++ fp_regs_used
+        arg_regs = [eax] ++ arg_regs_used
+                -- for annotating the call instruction with
+        sse_regs = length fp_regs_used
+        arg_stack_slots = if platformOS platform == OSMinGW32
+                          then length stack_args + length (allArgRegs platform)
+                          else length stack_args
+        tot_arg_size = arg_size * arg_stack_slots
+
+
+    -- Align stack to 16n for calls, assuming a starting stack
+    -- alignment of 16n - word_size on procedure entry. Which we
+    -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]
+    (real_size, adjust_rsp) <-
+        if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0
+            then return (tot_arg_size, nilOL)
+            else do -- we need to adjust...
+                delta <- getDeltaNat
+                setDeltaNat (delta - wORD_SIZE dflags)
+                return (tot_arg_size + wORD_SIZE dflags, toOL [
+                                SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp),
+                                DELTA (delta - wORD_SIZE dflags) ])
+
+    -- push the stack args, right to left
+    push_code <- push_args (reverse stack_args) nilOL
+    -- On Win64, we also have to leave stack space for the arguments
+    -- that we are passing in registers
+    lss_code <- if platformOS platform == OSMinGW32
+                then leaveStackSpace (length (allArgRegs platform))
+                else return nilOL
+    delta <- getDeltaNat
+
+    -- deal with static vs dynamic call targets
+    (callinsns,_cconv) <-
+      case target of
+        ForeignTarget (CmmLit (CmmLabel lbl)) conv
+           -> -- ToDo: stdcall arg sizes
+              return (unitOL (CALL (Left fn_imm) arg_regs), conv)
+           where fn_imm = ImmCLbl lbl
+        ForeignTarget expr conv
+           -> do (dyn_r, dyn_c) <- getSomeReg expr
+                 return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
+        PrimTarget _
+            -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
+                        ++ "probably because too many return values."
+
+    let
+        -- The x86_64 ABI requires us to set %al to the number of SSE2
+        -- registers that contain arguments, if the called routine
+        -- is a varargs function.  We don't know whether it's a
+        -- varargs function or not, so we have to assume it is.
+        --
+        -- It's not safe to omit this assignment, even if the number
+        -- of SSE2 regs in use is zero.  If %al is larger than 8
+        -- on entry to a varargs function, seg faults ensue.
+        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
+
+    let call = callinsns `appOL`
+               toOL (
+                    -- Deallocate parameters after call for ccall;
+                    -- stdcall has callee do it, but is not supported on
+                    -- x86_64 target (see #3336)
+                  (if real_size==0 then [] else
+                   [ADD (intFormat (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)])
+                  ++
+                  [DELTA (delta + real_size)]
+               )
+    setDeltaNat (delta + real_size)
+
+    let
+        -- assign the results, if necessary
+        assign_code []     = nilOL
+        assign_code [dest] =
+          case typeWidth rep of
+                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)
+                                                     (OpReg xmm0)
+                                                     (OpReg r_dest))
+                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)
+                                                     (OpReg xmm0)
+                                                     (OpReg r_dest))
+                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))
+          where
+                rep = localRegType dest
+                r_dest = getRegisterReg platform  (CmmLocal dest)
+        assign_code _many = panic "genCCall.assign_code many"
+
+    return (adjust_rsp          `appOL`
+            push_code           `appOL`
+            load_args_code      `appOL`
+            assign_args_code    `appOL`
+            lss_code            `appOL`
+            assign_eax sse_regs `appOL`
+            call                `appOL`
+            assign_code dest_regs)
+
+  where platform = targetPlatform dflags
+        arg_size = 8 -- always, at the mo
+
+
+        load_args :: [CmmExpr]
+                  -> [Reg]         -- int regs avail for args
+                  -> [Reg]         -- FP regs avail for args
+                  -> InstrBlock    -- code computing args
+                  -> InstrBlock    -- code assigning args to ABI regs
+                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
+        -- no more regs to use
+        load_args args [] [] code acode     =
+            return (args, [], [], code, acode)
+
+        -- no more args to push
+        load_args [] aregs fregs code acode =
+            return ([], aregs, fregs, code, acode)
+
+        load_args (arg : rest) aregs fregs code acode
+            | isFloatType arg_rep = case fregs of
+                 []     -> push_this_arg
+                 (r:rs) -> do
+                    (code',acode') <- reg_this_arg r
+                    load_args rest aregs rs code' acode'
+            | otherwise           = case aregs of
+                 []     -> push_this_arg
+                 (r:rs) -> do
+                    (code',acode') <- reg_this_arg r
+                    load_args rest rs fregs code' acode'
+            where
+
+              -- put arg into the list of stack pushed args
+              push_this_arg = do
+                 (args',ars,frs,code',acode')
+                     <- load_args rest aregs fregs code acode
+                 return (arg:args', ars, frs, code', acode')
+
+              -- pass the arg into the given register
+              reg_this_arg r
+                -- "operand" args can be directly assigned into r
+                | isOperand False arg = do
+                    arg_code <- getAnyReg arg
+                    return (code, (acode `appOL` arg_code r))
+                -- The last non-operand arg can be directly assigned after its
+                -- computation without going into a temporary register
+                | all (isOperand False) rest = do
+                    arg_code   <- getAnyReg arg
+                    return (code `appOL` arg_code r,acode)
+
+                -- other args need to be computed beforehand to avoid clobbering
+                -- previously assigned registers used to pass parameters (see
+                -- #11792, #12614). They are assigned into temporary registers
+                -- and get assigned to proper call ABI registers after they all
+                -- have been computed.
+                | otherwise     = do
+                    arg_code <- getAnyReg arg
+                    tmp      <- getNewRegNat arg_fmt
+                    let
+                      code'  = code `appOL` arg_code tmp
+                      acode' = acode `snocOL` reg2reg arg_fmt tmp r
+                    return (code',acode')
+
+              arg_rep = cmmExprType dflags arg
+              arg_fmt = cmmTypeFormat arg_rep
+
+        load_args_win :: [CmmExpr]
+                      -> [Reg]        -- used int regs
+                      -> [Reg]        -- used FP regs
+                      -> [(Reg, Reg)] -- (int, FP) regs avail for args
+                      -> InstrBlock
+                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
+        load_args_win args usedInt usedFP [] code
+            = return (args, usedInt, usedFP, code, nilOL)
+            -- no more regs to use
+        load_args_win [] usedInt usedFP _ code
+            = return ([], usedInt, usedFP, code, nilOL)
+            -- no more args to push
+        load_args_win (arg : rest) usedInt usedFP
+                      ((ireg, freg) : regs) code
+            | isFloatType arg_rep = do
+                 arg_code <- getAnyReg arg
+                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs
+                               (code `appOL`
+                                arg_code freg `snocOL`
+                                -- If we are calling a varargs function
+                                -- then we need to define ireg as well
+                                -- as freg
+                                MOV II64 (OpReg freg) (OpReg ireg))
+            | otherwise = do
+                 arg_code <- getAnyReg arg
+                 load_args_win rest (ireg : usedInt) usedFP regs
+                               (code `appOL` arg_code ireg)
+            where
+              arg_rep = cmmExprType dflags arg
+
+        push_args [] code = return code
+        push_args (arg:rest) code
+           | isFloatType arg_rep = do
+             (arg_reg, arg_code) <- getSomeReg arg
+             delta <- getDeltaNat
+             setDeltaNat (delta-arg_size)
+             let code' = code `appOL` arg_code `appOL` toOL [
+                            SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp),
+                            DELTA (delta-arg_size),
+                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))]
+             push_args rest code'
+
+           | otherwise = do
+             -- Arguments can be smaller than 64-bit, but we still use @PUSH
+             -- II64@ - the usual calling conventions expect integers to be
+             -- 8-byte aligned.
+             ASSERT(width <= W64) return ()
+             (arg_op, arg_code) <- getOperand arg
+             delta <- getDeltaNat
+             setDeltaNat (delta-arg_size)
+             let code' = code `appOL` arg_code `appOL` toOL [
+                                    PUSH II64 arg_op,
+                                    DELTA (delta-arg_size)]
+             push_args rest code'
+            where
+              arg_rep = cmmExprType dflags arg
+              width = typeWidth arg_rep
+
+        leaveStackSpace n = do
+             delta <- getDeltaNat
+             setDeltaNat (delta - n * arg_size)
+             return $ toOL [
+                         SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp),
+                         DELTA (delta - n * arg_size)]
+
+maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr
+maybePromoteCArg dflags wto arg
+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]
+ | otherwise   = arg
+ where
+   wfrom = cmmExprWidth dflags arg
+
+outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]
+               -> NatM InstrBlock
+outOfLineCmmOp bid mop res args
+  = do
+      dflags <- getDynFlags
+      targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
+      let target = ForeignTarget targetExpr
+                           (ForeignConvention CCallConv [] [] CmmMayReturn)
+
+      stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)
+  where
+        -- Assume we can call these functions directly, and that they're not in a dynamic library.
+        -- TODO: Why is this ok? Under linux this code will be in libm.so
+        --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31
+        lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction
+
+        fn = case mop of
+              MO_F32_Sqrt  -> fsLit "sqrtf"
+              MO_F32_Fabs  -> fsLit "fabsf"
+              MO_F32_Sin   -> fsLit "sinf"
+              MO_F32_Cos   -> fsLit "cosf"
+              MO_F32_Tan   -> fsLit "tanf"
+              MO_F32_Exp   -> fsLit "expf"
+              MO_F32_Log   -> fsLit "logf"
+
+              MO_F32_Asin  -> fsLit "asinf"
+              MO_F32_Acos  -> fsLit "acosf"
+              MO_F32_Atan  -> fsLit "atanf"
+
+              MO_F32_Sinh  -> fsLit "sinhf"
+              MO_F32_Cosh  -> fsLit "coshf"
+              MO_F32_Tanh  -> fsLit "tanhf"
+              MO_F32_Pwr   -> fsLit "powf"
+
+              MO_F32_Asinh -> fsLit "asinhf"
+              MO_F32_Acosh -> fsLit "acoshf"
+              MO_F32_Atanh -> fsLit "atanhf"
+
+              MO_F64_Sqrt  -> fsLit "sqrt"
+              MO_F64_Fabs  -> fsLit "fabs"
+              MO_F64_Sin   -> fsLit "sin"
+              MO_F64_Cos   -> fsLit "cos"
+              MO_F64_Tan   -> fsLit "tan"
+              MO_F64_Exp   -> fsLit "exp"
+              MO_F64_Log   -> fsLit "log"
+
+              MO_F64_Asin  -> fsLit "asin"
+              MO_F64_Acos  -> fsLit "acos"
+              MO_F64_Atan  -> fsLit "atan"
+
+              MO_F64_Sinh  -> fsLit "sinh"
+              MO_F64_Cosh  -> fsLit "cosh"
+              MO_F64_Tanh  -> fsLit "tanh"
+              MO_F64_Pwr   -> fsLit "pow"
+
+              MO_F64_Asinh  -> fsLit "asinh"
+              MO_F64_Acosh  -> fsLit "acosh"
+              MO_F64_Atanh  -> fsLit "atanh"
+
+              MO_Memcpy _  -> fsLit "memcpy"
+              MO_Memset _  -> fsLit "memset"
+              MO_Memmove _ -> fsLit "memmove"
+              MO_Memcmp _  -> fsLit "memcmp"
+
+              MO_PopCnt _  -> fsLit "popcnt"
+              MO_BSwap _   -> fsLit "bswap"
+              {- Here the C implementation is used as there is no x86
+              instruction to reverse a word's bit order.
+              -}
+              MO_BRev w    -> fsLit $ bRevLabel w
+              MO_Clz w     -> fsLit $ clzLabel w
+              MO_Ctz _     -> unsupported
+
+              MO_Pdep w    -> fsLit $ pdepLabel w
+              MO_Pext w    -> fsLit $ pextLabel w
+
+              MO_AtomicRMW _ _ -> fsLit "atomicrmw"
+              MO_AtomicRead _  -> fsLit "atomicread"
+              MO_AtomicWrite _ -> fsLit "atomicwrite"
+              MO_Cmpxchg _     -> fsLit "cmpxchg"
+
+              MO_UF_Conv _ -> unsupported
+
+              MO_S_QuotRem {}  -> unsupported
+              MO_U_QuotRem {}  -> unsupported
+              MO_U_QuotRem2 {} -> unsupported
+              MO_Add2 {}       -> unsupported
+              MO_AddIntC {}    -> unsupported
+              MO_SubIntC {}    -> unsupported
+              MO_AddWordC {}   -> unsupported
+              MO_SubWordC {}   -> unsupported
+              MO_U_Mul2 {}     -> unsupported
+              MO_WriteBarrier  -> unsupported
+              MO_Touch         -> unsupported
+              (MO_Prefetch_Data _ ) -> unsupported
+        unsupported = panic ("outOfLineCmmOp: " ++ show mop
+                          ++ " not supported here")
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+
+genSwitch dflags expr targets
+  | positionIndependent dflags
+  = do
+        (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset)
+           -- getNonClobberedReg because it needs to survive across t_code
+        lbl <- getNewLabelNat
+        dflags <- getDynFlags
+        let is32bit = target32Bit (targetPlatform dflags)
+            os = platformOS (targetPlatform dflags)
+            -- Might want to use .rodata.<function we're in> instead, but as
+            -- long as it's something unique it'll work out since the
+            -- references to the jump table are in the appropriate section.
+            rosection = case os of
+              -- on Mac OS X/x86_64, put the jump table in the text section to
+              -- work around a limitation of the linker.
+              -- ld64 is unable to handle the relocations for
+              --     .quad L1 - L0
+              -- if L0 is not preceded by a non-anonymous label in its section.
+              OSDarwin | not is32bit -> Section Text lbl
+              _ -> Section ReadOnlyData lbl
+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+        (tableReg,t_code) <- getSomeReg $ dynRef
+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
+                                       (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0))
+
+        offsetReg <- getNewRegNat (intFormat (wordWidth dflags))
+        return $ if is32bit || os == OSDarwin
+                 then e_code `appOL` t_code `appOL` toOL [
+                                ADD (intFormat (wordWidth dflags)) op (OpReg tableReg),
+                                JMP_TBL (OpReg tableReg) ids rosection lbl
+                       ]
+                 else -- HACK: On x86_64 binutils<2.17 is only able to generate
+                      -- PC32 relocations, hence we only get 32-bit offsets in
+                      -- the jump table. As these offsets are always negative
+                      -- we need to properly sign extend them to 64-bit. This
+                      -- hack should be removed in conjunction with the hack in
+                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.
+                      e_code `appOL` t_code `appOL` toOL [
+                               MOVSxL II32 op (OpReg offsetReg),
+                               ADD (intFormat (wordWidth dflags))
+                                   (OpReg offsetReg)
+                                   (OpReg tableReg),
+                               JMP_TBL (OpReg tableReg) ids rosection lbl
+                       ]
+  | otherwise
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        lbl <- getNewLabelNat
+        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl))
+            code = e_code `appOL` toOL [
+                    JMP_TBL op ids (Section ReadOnlyData lbl) lbl
+                 ]
+        return code
+  where
+    (offset, blockIds) = switchTargetsToTable targets
+    ids = map (fmap DestBlockId) blockIds
+
+generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
+generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl)
+    = let getBlockId (DestBlockId id) = id
+          getBlockId _ = panic "Non-Label target in Jump Table"
+          blockIds = map (fmap getBlockId) ids
+      in Just (createJumpTable dflags blockIds section lbl)
+generateJumpTableForInstr _ _ = Nothing
+
+createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel
+                -> GenCmmDecl (Alignment, CmmStatics) h g
+createJumpTable dflags ids section lbl
+    = let jumpTable
+            | positionIndependent dflags =
+                  let ww = wordWidth dflags
+                      jumpTableEntryRel Nothing
+                          = CmmStaticLit (CmmInt 0 ww)
+                      jumpTableEntryRel (Just blockid)
+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)
+                          where blockLabel = blockLbl blockid
+                  in map jumpTableEntryRel ids
+            | otherwise = map (jumpTableEntry dflags) ids
+      in CmmData section (mkAlignment 1, Statics lbl jumpTable)
+
+extractUnwindPoints :: [Instr] -> [UnwindPoint]
+extractUnwindPoints instrs =
+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]
+
+-- -----------------------------------------------------------------------------
+-- 'condIntReg' and 'condFltReg': condition codes into registers
+
+-- Turn those condition codes into integers now (when they appear on
+-- the right hand side of an assignment).
+--
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+
+condIntReg cond x y = do
+  CondCode _ cond cond_code <- condIntCode cond x y
+  tmp <- getNewRegNat II8
+  let
+        code dst = cond_code `appOL` toOL [
+                    SETCC cond (OpReg tmp),
+                    MOVZxL II8 (OpReg tmp) (OpReg dst)
+                  ]
+  return (Any II32 code)
+
+
+-----------------------------------------------------------
+---          Note [SSE Parity Checks]                   ---
+-----------------------------------------------------------
+
+-- We have to worry about unordered operands (eg. comparisons
+-- against NaN).  If the operands are unordered, the comparison
+-- sets the parity flag, carry flag and zero flag.
+-- All comparisons are supposed to return false for unordered
+-- operands except for !=, which returns true.
+--
+-- Optimisation: we don't have to test the parity flag if we
+-- know the test has already excluded the unordered case: eg >
+-- and >= test for a zero carry flag, which can only occur for
+-- ordered operands.
+--
+-- By reversing comparisons we can avoid testing the parity
+-- for < and <= as well. If any of the arguments is an NaN we
+-- return false either way. If both arguments are valid then
+-- x <= y  <->  y >= x  holds. So it's safe to swap these.
+--
+-- We invert the condition inside getRegister'and  getCondCode
+-- which should cover all invertable cases.
+-- All other functions translating FP comparisons to assembly
+-- use these to two generate the comparison code.
+--
+-- As an example consider a simple check:
+--
+-- func :: Float -> Float -> Int
+-- func x y = if x < y then 1 else 0
+--
+-- Which in Cmm gives the floating point comparison.
+--
+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;
+--
+-- We used to compile this to an assembly code block like this:
+-- _c2gh:
+--  ucomiss %xmm2,%xmm1
+--  jp _c2gf
+--  jb _c2gg
+--  jmp _c2gf
+--
+-- Where we have to introduce an explicit
+-- check for unordered results (using jmp parity):
+--
+-- We can avoid this by exchanging the arguments and inverting the direction
+-- of the comparison. This results in the sequence of:
+--
+--  ucomiss %xmm1,%xmm2
+--  ja _c2g2
+--  jmp _c2g1
+--
+-- Removing the jump reduces the pressure on the branch predidiction system
+-- and plays better with the uOP cache.
+
+condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
+condFltReg is32Bit cond x y = condFltReg_sse2
+ where
+
+
+  condFltReg_sse2 = do
+    CondCode _ cond cond_code <- condFltCode cond x y
+    tmp1 <- getNewRegNat (archWordFormat is32Bit)
+    tmp2 <- getNewRegNat (archWordFormat is32Bit)
+    let -- See Note [SSE Parity Checks]
+        code dst =
+           cond_code `appOL`
+             (case cond of
+                NE  -> or_unordered dst
+                GU  -> plain_test   dst
+                GEU -> plain_test   dst
+                -- Use ASSERT so we don't break releases if these creep in.
+                LTT -> ASSERT2(False, ppr "Should have been turned into >")
+                       and_ordered  dst
+                LE  -> ASSERT2(False, ppr "Should have been turned into >=")
+                       and_ordered  dst
+                _   -> and_ordered  dst)
+
+        plain_test dst = toOL [
+                    SETCC cond (OpReg tmp1),
+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)
+                 ]
+        or_unordered dst = toOL [
+                    SETCC cond (OpReg tmp1),
+                    SETCC PARITY (OpReg tmp2),
+                    OR II8 (OpReg tmp1) (OpReg tmp2),
+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)
+                  ]
+        and_ordered dst = toOL [
+                    SETCC cond (OpReg tmp1),
+                    SETCC NOTPARITY (OpReg tmp2),
+                    AND II8 (OpReg tmp1) (OpReg tmp2),
+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)
+                  ]
+    return (Any II32 code)
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+
+{-
+The Rules of the Game are:
+
+* You cannot assume anything about the destination register dst;
+  it may be anything, including a fixed reg.
+
+* You may compute an operand into a fixed reg, but you may not
+  subsequently change the contents of that fixed reg.  If you
+  want to do so, first copy the value either to a temporary
+  or into dst.  You are free to modify dst even if it happens
+  to be a fixed reg -- that's not your problem.
+
+* You cannot assume that a fixed reg will stay live over an
+  arbitrary computation.  The same applies to the dst reg.
+
+* Temporary regs obtained from getNewRegNat are distinct from
+  each other and from all other regs, and stay live over
+  arbitrary computations.
+
+--------------------
+
+SDM's version of The Rules:
+
+* If getRegister returns Any, that means it can generate correct
+  code which places the result in any register, period.  Even if that
+  register happens to be read during the computation.
+
+  Corollary #1: this means that if you are generating code for an
+  operation with two arbitrary operands, you cannot assign the result
+  of the first operand into the destination register before computing
+  the second operand.  The second operand might require the old value
+  of the destination register.
+
+  Corollary #2: A function might be able to generate more efficient
+  code if it knows the destination register is a new temporary (and
+  therefore not read by any of the sub-computations).
+
+* If getRegister returns Any, then the code it generates may modify only:
+        (a) fresh temporaries
+        (b) the destination register
+        (c) known registers (eg. %ecx is used by shifts)
+  In particular, it may *not* modify global registers, unless the global
+  register happens to be the destination register.
+-}
+
+trivialCode :: Width -> (Operand -> Operand -> Instr)
+            -> Maybe (Operand -> Operand -> Instr)
+            -> CmmExpr -> CmmExpr -> NatM Register
+trivialCode width instr m a b
+    = do is32Bit <- is32BitPlatform
+         trivialCode' is32Bit width instr m a b
+
+trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)
+             -> Maybe (Operand -> Operand -> Instr)
+             -> CmmExpr -> CmmExpr -> NatM Register
+trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b
+  | is32BitLit is32Bit lit_a = do
+  b_code <- getAnyReg b
+  let
+       code dst
+         = b_code dst `snocOL`
+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)
+  return (Any (intFormat width) code)
+
+trivialCode' _ width instr _ a b
+  = genTrivialCode (intFormat width) instr a b
+
+-- This is re-used for floating pt instructions too.
+genTrivialCode :: Format -> (Operand -> Operand -> Instr)
+               -> CmmExpr -> CmmExpr -> NatM Register
+genTrivialCode rep instr a b = do
+  (b_op, b_code) <- getNonClobberedOperand b
+  a_code <- getAnyReg a
+  tmp <- getNewRegNat rep
+  let
+     -- We want the value of b to stay alive across the computation of a.
+     -- But, we want to calculate a straight into the destination register,
+     -- because the instruction only has two operands (dst := dst `op` src).
+     -- The troublesome case is when the result of b is in the same register
+     -- as the destination reg.  In this case, we have to save b in a
+     -- new temporary across the computation of a.
+     code dst
+        | dst `regClashesWithOp` b_op =
+                b_code `appOL`
+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`
+                a_code dst `snocOL`
+                instr (OpReg tmp) (OpReg dst)
+        | otherwise =
+                b_code `appOL`
+                a_code dst `snocOL`
+                instr b_op (OpReg dst)
+  return (Any rep code)
+
+regClashesWithOp :: Reg -> Operand -> Bool
+reg `regClashesWithOp` OpReg reg2   = reg == reg2
+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
+_   `regClashesWithOp` _            = False
+
+-----------
+
+trivialUCode :: Format -> (Operand -> Instr)
+             -> CmmExpr -> NatM Register
+trivialUCode rep instr x = do
+  x_code <- getAnyReg x
+  let
+     code dst =
+        x_code dst `snocOL`
+        instr (OpReg dst)
+  return (Any rep code)
+
+-----------
+
+
+trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)
+                  -> CmmExpr -> CmmExpr -> NatM Register
+trivialFCode_sse2 pk instr x y
+    = genTrivialCode format (instr format) x y
+    where format = floatFormat pk
+
+
+trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
+trivialUFCode format instr x = do
+  (x_reg, x_code) <- getSomeReg x
+  let
+     code dst =
+        x_code `snocOL`
+        instr x_reg dst
+  return (Any format code)
+
+
+--------------------------------------------------------------------------------
+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP from to x =  coerce_sse2
+ where
+
+   coerce_sse2 = do
+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
+     let
+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("
+                                         ++ show n ++ ")"
+           code dst = x_code `snocOL` opc (intFormat from) x_op dst
+     return (Any (floatFormat to) code)
+        -- works even if the destination rep is <II32
+
+--------------------------------------------------------------------------------
+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int from to x =  coerceFP2Int_sse2
+ where
+   coerceFP2Int_sse2 = do
+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
+     let
+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;
+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("
+                                           ++ show n ++ ")"
+           code dst = x_code `snocOL` opc (intFormat to) x_op dst
+     return (Any (intFormat to) code)
+         -- works even if the destination rep is <II32
+
+
+--------------------------------------------------------------------------------
+coerceFP2FP :: Width -> CmmExpr -> NatM Register
+coerceFP2FP to x = do
+  (x_reg, x_code) <- getSomeReg x
+  let
+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;
+                                     n -> panic $ "coerceFP2FP: unhandled width ("
+                                                 ++ show n ++ ")"
+        code dst = x_code `snocOL` opc x_reg dst
+  return (Any ( floatFormat to) code)
+
+--------------------------------------------------------------------------------
+
+sse2NegCode :: Width -> CmmExpr -> NatM Register
+sse2NegCode w x = do
+  let fmt = floatFormat w
+  x_code <- getAnyReg x
+  -- This is how gcc does it, so it can't be that bad:
+  let
+    const = case fmt of
+      FF32 -> CmmInt 0x80000000 W32
+      FF64 -> CmmInt 0x8000000000000000 W64
+      x@II8  -> wrongFmt x
+      x@II16 -> wrongFmt x
+      x@II32 -> wrongFmt x
+      x@II64 -> wrongFmt x
+
+      where
+        wrongFmt x = panic $ "sse2NegCode: " ++ show x
+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const
+  tmp <- getNewRegNat fmt
+  let
+    code dst = x_code dst `appOL` amode_code `appOL` toOL [
+        MOV fmt (OpAddr amode) (OpReg tmp),
+        XOR fmt (OpReg tmp) (OpReg dst)
+        ]
+  --
+  return (Any fmt code)
+
+isVecExpr :: CmmExpr -> Bool
+isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True
+isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True
+isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True
+isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True
+isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True
+isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True
+isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True
+isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True
+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True
+isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True
+isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True
+isVecExpr (CmmMachOp _ [e])                = isVecExpr e
+isVecExpr _                                = False
+
+needLlvm :: NatM a
+needLlvm =
+    sorry $ unlines ["The native code generator does not support vector"
+                    ,"instructions. Please use -fllvm."]
+
+-- | This works on the invariant that all jumps in the given blocks are required.
+--   Starting from there we try to make a few more jumps redundant by reordering
+--   them.
+invertCondBranches :: CFG -> LabelMap a -> [NatBasicBlock Instr]
+                   -> [NatBasicBlock Instr]
+invertCondBranches cfg keep bs =
+    --trace "Foo" $
+    invert bs
+  where
+    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
+    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)
+      | --pprTrace "Block" (ppr lbl1) True,
+        (jmp1,jmp2) <- last2 ins
+      , JXX cond1 target1 <- jmp1
+      , target1 == lbl2
+      --, pprTrace "CutChance" (ppr b1) True
+      , JXX ALWAYS target2 <- jmp2
+      -- We have enough information to check if we can perform the inversion
+      -- TODO: We could also check for the last asm instruction which sets
+      -- status flags instead. Which I suspect is worse in terms of compiler
+      -- performance, but might be applicable to more cases
+      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg
+      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg
+      -- Both jumps come from the same cmm statement
+      , transitionSource edgeInfo1 == transitionSource edgeInfo2
+      , (CmmSource cmmCondBranch) <- transitionSource edgeInfo1
+
+      --Int comparisons are invertable
+      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch
+      , Just _ <- maybeIntComparison op
+      , Just invCond <- maybeInvertCond cond1
+
+      --Swap the last two jumps, invert the conditional jumps condition.
+      = let jumps =
+              case () of
+                -- We are free the eliminate the jmp. So we do so.
+                _ | not (mapMember target1 keep)
+                    -> [JXX invCond target2]
+                -- If the conditional target is unlikely we put the other
+                -- target at the front.
+                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1
+                    -> [JXX invCond target2, JXX ALWAYS target1]
+                -- Keep things as-is otherwise
+                  | otherwise
+                    -> [jmp1, jmp2]
+        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $
+           (BasicBlock lbl1
+            (dropTail 2 ins ++ jumps))
+            : invert (b2:bs)
+    invert (b:bs) = b : invert bs
+    invert [] = []
diff --git a/compiler/nativeGen/X86/Cond.hs b/compiler/nativeGen/X86/Cond.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Cond.hs
@@ -0,0 +1,109 @@
+module X86.Cond (
+        Cond(..),
+        condUnsigned,
+        condToSigned,
+        condToUnsigned,
+        maybeFlipCond,
+        maybeInvertCond
+)
+
+where
+
+import GhcPrelude
+
+data Cond
+        = ALWAYS        -- What's really used? ToDo
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        | NEG
+        | POS
+        | CARRY
+        | OFLO
+        | PARITY
+        | NOTPARITY
+        deriving Eq
+
+condUnsigned :: Cond -> Bool
+condUnsigned GU  = True
+condUnsigned LU  = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _   = False
+
+
+condToSigned :: Cond -> Cond
+condToSigned GU  = GTT
+condToSigned LU  = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x   = x
+
+
+condToUnsigned :: Cond -> Cond
+condToUnsigned GTT = GU
+condToUnsigned LTT = LU
+condToUnsigned GE  = GEU
+condToUnsigned LE  = LEU
+condToUnsigned x   = x
+
+-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the
+-- arguments to the conditional @c@, and the new condition should be @c'@.
+maybeFlipCond :: Cond -> Maybe Cond
+maybeFlipCond cond  = case cond of
+        EQQ   -> Just EQQ
+        NE    -> Just NE
+        LU    -> Just GU
+        GU    -> Just LU
+        LEU   -> Just GEU
+        GEU   -> Just LEU
+        LTT   -> Just GTT
+        GTT   -> Just LTT
+        LE    -> Just GE
+        GE    -> Just LE
+        _other -> Nothing
+
+-- | If we apply @maybeInvertCond@ to the condition of a jump we turn
+-- jumps taken into jumps not taken and vice versa.
+--
+-- Careful! If the used comparison and the conditional jump
+-- don't match the above behaviour will NOT hold.
+-- When used for FP comparisons this does not consider unordered
+-- numbers.
+-- Also inverting twice might return a synonym for the original condition.
+maybeInvertCond :: Cond -> Maybe Cond
+maybeInvertCond cond  = case cond of
+        ALWAYS  -> Nothing
+        EQQ     -> Just NE
+        NE      -> Just EQQ
+
+        NEG     -> Just POS
+        POS     -> Just NEG
+
+        GEU     -> Just LU
+        LU      -> Just GEU
+
+        GE      -> Just LTT
+        LTT     -> Just GE
+
+        GTT     -> Just LE
+        LE      -> Just GTT
+
+        GU      -> Just LEU
+        LEU     -> Just GU
+
+        --GEU "==" NOTCARRY, they are synonyms
+        --at the assembly level
+        CARRY   -> Just GEU
+
+        OFLO    -> Nothing
+
+        PARITY  -> Just NOTPARITY
+        NOTPARITY -> Just PARITY
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -0,0 +1,1053 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+
+module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..),
+                  getJumpDestBlockId, canShortcut, shortcutStatics,
+                  shortcutJump, allocMoreStack,
+                  maxSpillSlots, archWordFormat )
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import X86.Cond
+import X86.Regs
+import Instruction
+import Format
+import RegClass
+import Reg
+import TargetReg
+
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import CodeGen.Platform
+import Cmm
+import FastString
+import Outputable
+import Platform
+
+import BasicTypes       (Alignment)
+import CLabel
+import DynFlags
+import UniqSet
+import Unique
+import UniqSupply
+import Debug (UnwindTable)
+
+import Control.Monad
+import Data.Maybe       (fromMaybe)
+
+-- Format of an x86/x86_64 memory address, in bytes.
+--
+archWordFormat :: Bool -> Format
+archWordFormat is32Bit
+ | is32Bit   = II32
+ | otherwise = II64
+
+-- | Instruction instance for x86 instruction set.
+instance Instruction Instr where
+        regUsageOfInstr         = x86_regUsageOfInstr
+        patchRegsOfInstr        = x86_patchRegsOfInstr
+        isJumpishInstr          = x86_isJumpishInstr
+        jumpDestsOfInstr        = x86_jumpDestsOfInstr
+        patchJumpInstr          = x86_patchJumpInstr
+        mkSpillInstr            = x86_mkSpillInstr
+        mkLoadInstr             = x86_mkLoadInstr
+        takeDeltaInstr          = x86_takeDeltaInstr
+        isMetaInstr             = x86_isMetaInstr
+        mkRegRegMoveInstr       = x86_mkRegRegMoveInstr
+        takeRegRegMoveInstr     = x86_takeRegRegMoveInstr
+        mkJumpInstr             = x86_mkJumpInstr
+        mkStackAllocInstr       = x86_mkStackAllocInstr
+        mkStackDeallocInstr     = x86_mkStackDeallocInstr
+
+
+-- -----------------------------------------------------------------------------
+-- Intel x86 instructions
+
+{-
+Intel, in their infinite wisdom, selected a stack model for floating
+point registers on x86.  That might have made sense back in 1979 --
+nowadays we can see it for the nonsense it really is.  A stack model
+fits poorly with the existing nativeGen infrastructure, which assumes
+flat integer and FP register sets.  Prior to this commit, nativeGen
+could not generate correct x86 FP code -- to do so would have meant
+somehow working the register-stack paradigm into the register
+allocator and spiller, which sounds very difficult.
+
+We have decided to cheat, and go for a simple fix which requires no
+infrastructure modifications, at the expense of generating ropey but
+correct FP code.  All notions of the x86 FP stack and its insns have
+been removed.  Instead, we pretend (to the instruction selector and
+register allocator) that x86 has six floating point registers, %fake0
+.. %fake5, which can be used in the usual flat manner.  We further
+claim that x86 has floating point instructions very similar to SPARC
+and Alpha, that is, a simple 3-operand register-register arrangement.
+Code generation and register allocation proceed on this basis.
+
+When we come to print out the final assembly, our convenient fiction
+is converted to dismal reality.  Each fake instruction is
+independently converted to a series of real x86 instructions.
+%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg
+arithmetic operations, the two operands are pushed onto the top of the
+FP stack, the operation done, and the result copied back into the
+relevant register.  There are only six %fake registers because 2 are
+needed for the translation, and x86 has 8 in total.
+
+The translation is inefficient but is simple and it works.  A cleverer
+translation would handle a sequence of insns, simulating the FP stack
+contents, would not impose a fixed mapping from %fake to %st regs, and
+hopefully could avoid most of the redundant reg-reg moves of the
+current translation.
+
+We might as well make use of whatever unique FP facilities Intel have
+chosen to bless us with (let's not be churlish, after all).
+Hence GLDZ and GLD1.  Bwahahahahahahaha!
+-}
+
+{-
+Note [x86 Floating point precision]
+
+Intel's internal floating point registers are by default 80 bit
+extended precision.  This means that all operations done on values in
+registers are done at 80 bits, and unless the intermediate values are
+truncated to the appropriate size (32 or 64 bits) by storing in
+memory, calculations in registers will give different results from
+calculations which pass intermediate values in memory (eg. via
+function calls).
+
+One solution is to set the FPU into 64 bit precision mode.  Some OSs
+do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is
+that this will only affect 64-bit precision arithmetic; 32-bit
+calculations will still be done at 64-bit precision in registers.  So
+it doesn't solve the whole problem.
+
+There's also the issue of what the C library is expecting in terms of
+precision.  It seems to be the case that glibc on Linux expects the
+FPU to be set to 80 bit precision, so setting it to 64 bit could have
+unexpected effects.  Changing the default could have undesirable
+effects on other 3rd-party library code too, so the right thing would
+be to save/restore the FPU control word across Haskell code if we were
+to do this.
+
+gcc's -ffloat-store gives consistent results by always storing the
+results of floating-point calculations in memory, which works for both
+32 and 64-bit precision.  However, it only affects the values of
+user-declared floating point variables in C, not intermediate results.
+GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision
+flag).
+
+Another problem is how to spill floating point registers in the
+register allocator.  Should we spill the whole 80 bits, or just 64?
+On an OS which is set to 64 bit precision, spilling 64 is fine.  On
+Linux, spilling 64 bits will round the results of some operations.
+This is what gcc does.  Spilling at 80 bits requires taking up a full
+128 bit slot (so we get alignment).  We spill at 80-bits and ignore
+the alignment problems.
+
+In the future [edit: now available in GHC 7.0.1, with the -msse2
+flag], we'll use the SSE registers for floating point.  This requires
+a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision
+float ops), which means P4 or Xeon and above.  Using SSE will solve
+all these problems, because the SSE registers use fixed 32 bit or 64
+bit precision.
+
+--SDM 1/2003
+-}
+
+data Instr
+        -- comment pseudo-op
+        = COMMENT FastString
+
+        -- location pseudo-op (file, line, col, name)
+        | LOCATION Int Int Int String
+
+        -- some static data spat out during code
+        -- generation.  Will be extracted before
+        -- pretty-printing.
+        | LDATA   Section (Alignment, CmmStatics)
+
+        -- start a new basic block.  Useful during
+        -- codegen, removed later.  Preceding
+        -- instruction should be a jump, as per the
+        -- invariants for a BasicBlock (see Cmm).
+        | NEWBLOCK BlockId
+
+        -- unwinding information
+        -- See Note [Unwinding information in the NCG].
+        | UNWIND CLabel UnwindTable
+
+        -- specify current stack offset for benefit of subsequent passes.
+        -- This carries a BlockId so it can be used in unwinding information.
+        | DELTA  Int
+
+        -- Moves.
+        | MOV         Format Operand Operand
+        | CMOV   Cond Format Operand Reg
+        | MOVZxL      Format Operand Operand -- format is the size of operand 1
+        | MOVSxL      Format Operand Operand -- format is the size of operand 1
+        -- x86_64 note: plain mov into a 32-bit register always zero-extends
+        -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which
+        -- don't affect the high bits of the register.
+
+        -- Load effective address (also a very useful three-operand add instruction :-)
+        | LEA         Format Operand Operand
+
+        -- Int Arithmetic.
+        | ADD         Format Operand Operand
+        | ADC         Format Operand Operand
+        | SUB         Format Operand Operand
+        | SBB         Format Operand Operand
+
+        | MUL         Format Operand Operand
+        | MUL2        Format Operand         -- %edx:%eax = operand * %rax
+        | IMUL        Format Operand Operand -- signed int mul
+        | IMUL2       Format Operand         -- %edx:%eax = operand * %eax
+
+        | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op
+        | IDIV        Format Operand         -- ditto, but signed
+
+        -- Int Arithmetic, where the effects on the condition register
+        -- are important. Used in specialized sequences such as MO_Add2.
+        -- Do not rewrite these instructions to "equivalent" ones that
+        -- have different effect on the condition register! (See #9013.)
+        | ADD_CC      Format Operand Operand
+        | SUB_CC      Format Operand Operand
+
+        -- Simple bit-twiddling.
+        | AND         Format Operand Operand
+        | OR          Format Operand Operand
+        | XOR         Format Operand Operand
+        | NOT         Format Operand
+        | NEGI        Format Operand         -- NEG instruction (name clash with Cond)
+        | BSWAP       Format Reg
+
+        -- Shifts (amount may be immediate or %cl only)
+        | SHL         Format Operand{-amount-} Operand
+        | SAR         Format Operand{-amount-} Operand
+        | SHR         Format Operand{-amount-} Operand
+
+        | BT          Format Imm Operand
+        | NOP
+
+
+        -- We need to support the FSTP (x87 store and pop) instruction
+        -- so that we can correctly read off the return value of an
+        -- x86 CDECL C function call when its floating point.
+        -- so we dont include a register argument, and just use st(0)
+        -- this instruction is used ONLY for return values of C ffi calls
+        -- in x86_32 abi
+        | X87Store         Format  AddrMode -- st(0), dst
+
+
+        -- SSE2 floating point: we use a restricted set of the available SSE2
+        -- instructions for floating-point.
+        -- use MOV for moving (either movss or movsd (movlpd better?))
+        | CVTSS2SD      Reg Reg            -- F32 to F64
+        | CVTSD2SS      Reg Reg            -- F64 to F32
+        | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)
+        | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)
+        | CVTSI2SS      Format Operand Reg -- I32/I64 to F32
+        | CVTSI2SD      Format Operand Reg -- I32/I64 to F64
+
+        -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands
+        -- are  Operand Reg.
+
+        -- SSE2 floating-point division:
+        | FDIV          Format Operand Operand   -- divisor, dividend(dst)
+
+        -- use CMP for comparisons.  ucomiss and ucomisd instructions
+        -- compare single/double prec floating point respectively.
+
+        | SQRT          Format Operand Reg      -- src, dst
+
+
+        -- Comparison
+        | TEST          Format Operand Operand
+        | CMP           Format Operand Operand
+        | SETCC         Cond Operand
+
+        -- Stack Operations.
+        | PUSH          Format Operand
+        | POP           Format Operand
+        -- both unused (SDM):
+        --  | PUSHA
+        --  | POPA
+
+        -- Jumping around.
+        | JMP         Operand [Reg] -- including live Regs at the call
+        | JXX         Cond BlockId  -- includes unconditional branches
+        | JXX_GBL     Cond Imm      -- non-local version of JXX
+        -- Table jump
+        | JMP_TBL     Operand   -- Address to jump to
+                      [Maybe JumpDest] -- Targets of the jump table
+                      Section   -- Data section jump table should be put in
+                      CLabel    -- Label of jump table
+        | CALL        (Either Imm Reg) [Reg]
+
+        -- Other things.
+        | CLTD Format            -- sign extend %eax into %edx:%eax
+
+        | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code
+                                 -- pretty-prints as
+                                 --       call 1f
+                                 -- 1:    popl %reg
+                                 --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg
+        | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code
+                                 -- pretty-prints as
+                                 --       call 1f
+                                 -- 1:    popl %reg
+
+    -- bit counting instructions
+        | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1
+        | LZCNT       Format Operand Reg -- [BMI2] count number of leading zeros
+        | TZCNT       Format Operand Reg -- [BMI2] count number of trailing zeros
+        | BSF         Format Operand Reg -- bit scan forward
+        | BSR         Format Operand Reg -- bit scan reverse
+
+    -- bit manipulation instructions
+        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask
+        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask
+
+    -- prefetch
+        | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch
+                                        -- variant can be NTA, Lvl0, Lvl1, or Lvl2
+
+        | LOCK        Instr -- lock prefix
+        | XADD        Format Operand Operand -- src (r), dst (r/m)
+        | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit
+        | MFENCE
+
+data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2
+
+
+data Operand
+        = OpReg  Reg            -- register
+        | OpImm  Imm            -- immediate value
+        | OpAddr AddrMode       -- memory reference
+
+
+
+-- | Returns which registers are read and written as a (read, written)
+-- pair.
+x86_regUsageOfInstr :: Platform -> Instr -> RegUsage
+x86_regUsageOfInstr platform instr
+ = case instr of
+    MOV    _ src dst    -> usageRW src dst
+    CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]
+    MOVZxL _ src dst    -> usageRW src dst
+    MOVSxL _ src dst    -> usageRW src dst
+    LEA    _ src dst    -> usageRW src dst
+    ADD    _ src dst    -> usageRM src dst
+    ADC    _ src dst    -> usageRM src dst
+    SUB    _ src dst    -> usageRM src dst
+    SBB    _ src dst    -> usageRM src dst
+    IMUL   _ src dst    -> usageRM src dst
+
+    -- Result of IMULB will be in just in %ax
+    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]
+    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and
+    -- %ax/%eax/%rax.
+    IMUL2  _ src        -> mkRU (eax:use_R src []) [eax,edx]
+
+    MUL    _ src dst    -> usageRM src dst
+    MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]
+    DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
+    IDIV   _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
+    ADD_CC _ src dst    -> usageRM src dst
+    SUB_CC _ src dst    -> usageRM src dst
+    AND    _ src dst    -> usageRM src dst
+    OR     _ src dst    -> usageRM src dst
+
+    XOR    _ (OpReg src) (OpReg dst)
+        | src == dst    -> mkRU [] [dst]
+
+    XOR    _ src dst    -> usageRM src dst
+    NOT    _ op         -> usageM op
+    BSWAP  _ reg        -> mkRU [reg] [reg]
+    NEGI   _ op         -> usageM op
+    SHL    _ imm dst    -> usageRM imm dst
+    SAR    _ imm dst    -> usageRM imm dst
+    SHR    _ imm dst    -> usageRM imm dst
+    BT     _ _   src    -> mkRUR (use_R src [])
+
+    PUSH   _ op         -> mkRUR (use_R op [])
+    POP    _ op         -> mkRU [] (def_W op)
+    TEST   _ src dst    -> mkRUR (use_R src $! use_R dst [])
+    CMP    _ src dst    -> mkRUR (use_R src $! use_R dst [])
+    SETCC  _ op         -> mkRU [] (def_W op)
+    JXX    _ _          -> mkRU [] []
+    JXX_GBL _ _         -> mkRU [] []
+    JMP     op regs     -> mkRUR (use_R op regs)
+    JMP_TBL op _ _ _    -> mkRUR (use_R op [])
+    CALL (Left _)  params   -> mkRU params (callClobberedRegs platform)
+    CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform)
+    CLTD   _            -> mkRU [eax] [edx]
+    NOP                 -> mkRU [] []
+
+    X87Store    _  dst    -> mkRUR ( use_EA dst [])
+
+    CVTSS2SD   src dst  -> mkRU [src] [dst]
+    CVTSD2SS   src dst  -> mkRU [src] [dst]
+    CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst]
+    CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst]
+    CVTSI2SS   _ src dst -> mkRU (use_R src []) [dst]
+    CVTSI2SD   _ src dst -> mkRU (use_R src []) [dst]
+    FDIV _     src dst  -> usageRM src dst
+    SQRT _ src dst      -> mkRU (use_R src []) [dst]
+
+    FETCHGOT reg        -> mkRU [] [reg]
+    FETCHPC  reg        -> mkRU [] [reg]
+
+    COMMENT _           -> noUsage
+    LOCATION{}          -> noUsage
+    UNWIND{}            -> noUsage
+    DELTA   _           -> noUsage
+
+    POPCNT _ src dst -> mkRU (use_R src []) [dst]
+    LZCNT  _ src dst -> mkRU (use_R src []) [dst]
+    TZCNT  _ src dst -> mkRU (use_R src []) [dst]
+    BSF    _ src dst -> mkRU (use_R src []) [dst]
+    BSR    _ src dst -> mkRU (use_R src []) [dst]
+
+    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+
+    -- note: might be a better way to do this
+    PREFETCH _  _ src -> mkRU (use_R src []) []
+    LOCK i              -> x86_regUsageOfInstr platform i
+    XADD _ src dst      -> usageMM src dst
+    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)
+    MFENCE -> noUsage
+
+    _other              -> panic "regUsage: unrecognised instr"
+ where
+    -- # Definitions
+    --
+    -- Written: If the operand is a register, it's written. If it's an
+    -- address, registers mentioned in the address are read.
+    --
+    -- Modified: If the operand is a register, it's both read and
+    -- written. If it's an address, registers mentioned in the address
+    -- are read.
+
+    -- 2 operand form; first operand Read; second Written
+    usageRW :: Operand -> Operand -> RegUsage
+    usageRW op (OpReg reg)      = mkRU (use_R op []) [reg]
+    usageRW op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])
+    usageRW _ _                 = panic "X86.RegInfo.usageRW: no match"
+
+    -- 2 operand form; first operand Read; second Modified
+    usageRM :: Operand -> Operand -> RegUsage
+    usageRM op (OpReg reg)      = mkRU (use_R op [reg]) [reg]
+    usageRM op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])
+    usageRM _ _                 = panic "X86.RegInfo.usageRM: no match"
+
+    -- 2 operand form; first operand Modified; second Modified
+    usageMM :: Operand -> Operand -> RegUsage
+    usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]
+    usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]
+    usageMM _ _                     = panic "X86.RegInfo.usageMM: no match"
+
+    -- 3 operand form; first operand Read; second Modified; third Modified
+    usageRMM :: Operand -> Operand -> Operand -> RegUsage
+    usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg]
+    usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg]
+    usageRMM _ _ _                               = panic "X86.RegInfo.usageRMM: no match"
+
+    -- 1 operand form; operand Modified
+    usageM :: Operand -> RegUsage
+    usageM (OpReg reg)          = mkRU [reg] [reg]
+    usageM (OpAddr ea)          = mkRUR (use_EA ea [])
+    usageM _                    = panic "X86.RegInfo.usageM: no match"
+
+    -- Registers defd when an operand is written.
+    def_W (OpReg reg)           = [reg]
+    def_W (OpAddr _ )           = []
+    def_W _                     = panic "X86.RegInfo.def_W: no match"
+
+    -- Registers used when an operand is read.
+    use_R (OpReg reg)  tl = reg : tl
+    use_R (OpImm _)    tl = tl
+    use_R (OpAddr ea)  tl = use_EA ea tl
+
+    -- Registers used to compute an effective address.
+    use_EA (ImmAddr _ _) tl = tl
+    use_EA (AddrBaseIndex base index _) tl =
+        use_base base $! use_index index tl
+        where use_base (EABaseReg r)  tl = r : tl
+              use_base _              tl = tl
+              use_index EAIndexNone   tl = tl
+              use_index (EAIndex i _) tl = i : tl
+
+    mkRUR src = src' `seq` RU src' []
+        where src' = filter (interesting platform) src
+
+    mkRU src dst = src' `seq` dst' `seq` RU src' dst'
+        where src' = filter (interesting platform) src
+              dst' = filter (interesting platform) dst
+
+-- | Is this register interesting for the register allocator?
+interesting :: Platform -> Reg -> Bool
+interesting _        (RegVirtual _)              = True
+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+interesting _        (RegReal (RealRegPair{}))   = panic "X86.interesting: no reg pairs on this arch"
+
+
+
+-- | Applies the supplied function to all registers in instructions.
+-- Typically used to change virtual registers to real registers.
+x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+x86_patchRegsOfInstr instr env
+ = case instr of
+    MOV  fmt src dst     -> patch2 (MOV  fmt) src dst
+    CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)
+    MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst
+    MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst
+    LEA  fmt src dst     -> patch2 (LEA  fmt) src dst
+    ADD  fmt src dst     -> patch2 (ADD  fmt) src dst
+    ADC  fmt src dst     -> patch2 (ADC  fmt) src dst
+    SUB  fmt src dst     -> patch2 (SUB  fmt) src dst
+    SBB  fmt src dst     -> patch2 (SBB  fmt) src dst
+    IMUL fmt src dst     -> patch2 (IMUL fmt) src dst
+    IMUL2 fmt src        -> patch1 (IMUL2 fmt) src
+    MUL fmt src dst      -> patch2 (MUL fmt) src dst
+    MUL2 fmt src         -> patch1 (MUL2 fmt) src
+    IDIV fmt op          -> patch1 (IDIV fmt) op
+    DIV fmt op           -> patch1 (DIV fmt) op
+    ADD_CC fmt src dst   -> patch2 (ADD_CC fmt) src dst
+    SUB_CC fmt src dst   -> patch2 (SUB_CC fmt) src dst
+    AND  fmt src dst     -> patch2 (AND  fmt) src dst
+    OR   fmt src dst     -> patch2 (OR   fmt) src dst
+    XOR  fmt src dst     -> patch2 (XOR  fmt) src dst
+    NOT  fmt op          -> patch1 (NOT  fmt) op
+    BSWAP fmt reg        -> BSWAP fmt (env reg)
+    NEGI fmt op          -> patch1 (NEGI fmt) op
+    SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst
+    SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst
+    SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst
+    BT   fmt imm src     -> patch1 (BT  fmt imm) src
+    TEST fmt src dst     -> patch2 (TEST fmt) src dst
+    CMP  fmt src dst     -> patch2 (CMP  fmt) src dst
+    PUSH fmt op          -> patch1 (PUSH fmt) op
+    POP  fmt op          -> patch1 (POP  fmt) op
+    SETCC cond op        -> patch1 (SETCC cond) op
+    JMP op regs          -> JMP (patchOp op) regs
+    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl
+
+    -- literally only support storing the top x87 stack value st(0)
+    X87Store  fmt  dst     -> X87Store fmt  (lookupAddr dst)
+
+    CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)
+    CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)
+    CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst)
+    CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)
+    CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)
+    CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)
+    FDIV fmt src dst     -> FDIV fmt (patchOp src) (patchOp dst)
+    SQRT fmt src dst    -> SQRT fmt (patchOp src) (env dst)
+
+    CALL (Left _)  _    -> instr
+    CALL (Right reg) p  -> CALL (Right (env reg)) p
+
+    FETCHGOT reg        -> FETCHGOT (env reg)
+    FETCHPC  reg        -> FETCHPC  (env reg)
+
+    NOP                 -> instr
+    COMMENT _           -> instr
+    LOCATION {}         -> instr
+    UNWIND {}           -> instr
+    DELTA _             -> instr
+
+    JXX _ _             -> instr
+    JXX_GBL _ _         -> instr
+    CLTD _              -> instr
+
+    POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)
+    LZCNT  fmt src dst -> LZCNT  fmt (patchOp src) (env dst)
+    TZCNT  fmt src dst -> TZCNT  fmt (patchOp src) (env dst)
+    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)
+    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)
+    BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)
+    BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)
+
+    PREFETCH lvl format src -> PREFETCH lvl format (patchOp src)
+
+    LOCK i               -> LOCK (x86_patchRegsOfInstr i env)
+    XADD fmt src dst     -> patch2 (XADD fmt) src dst
+    CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst
+    MFENCE               -> instr
+
+    _other              -> panic "patchRegs: unrecognised instr"
+
+  where
+    patch1 :: (Operand -> a) -> Operand -> a
+    patch1 insn op      = insn $! patchOp op
+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
+    patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
+
+    patchOp (OpReg  reg) = OpReg $! env reg
+    patchOp (OpImm  imm) = OpImm imm
+    patchOp (OpAddr ea)  = OpAddr $! lookupAddr ea
+
+    lookupAddr (ImmAddr imm off) = ImmAddr imm off
+    lookupAddr (AddrBaseIndex base index disp)
+      = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp
+      where
+        lookupBase EABaseNone       = EABaseNone
+        lookupBase EABaseRip        = EABaseRip
+        lookupBase (EABaseReg r)    = EABaseReg $! env r
+
+        lookupIndex EAIndexNone     = EAIndexNone
+        lookupIndex (EAIndex r i)   = (EAIndex $! env r) i
+
+
+--------------------------------------------------------------------------------
+x86_isJumpishInstr
+        :: Instr -> Bool
+
+x86_isJumpishInstr instr
+ = case instr of
+        JMP{}           -> True
+        JXX{}           -> True
+        JXX_GBL{}       -> True
+        JMP_TBL{}       -> True
+        CALL{}          -> True
+        _               -> False
+
+
+x86_jumpDestsOfInstr
+        :: Instr
+        -> [BlockId]
+
+x86_jumpDestsOfInstr insn
+  = case insn of
+        JXX _ id        -> [id]
+        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
+        _               -> []
+
+
+x86_patchJumpInstr
+        :: Instr -> (BlockId -> BlockId) -> Instr
+
+x86_patchJumpInstr insn patchF
+  = case insn of
+        JXX cc id       -> JXX cc (patchF id)
+        JMP_TBL op ids section lbl
+          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl
+        _               -> insn
+    where
+        patchJumpDest f (DestBlockId id) = DestBlockId (f id)
+        patchJumpDest _ dest             = dest
+
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- | Make a spill instruction.
+x86_mkSpillInstr
+    :: DynFlags
+    -> Reg      -- register to spill
+    -> Int      -- current stack delta
+    -> Int      -- spill slot to use
+    -> Instr
+
+x86_mkSpillInstr dflags reg delta slot
+  = let off     = spillSlotToOffset platform slot - delta
+    in
+    case targetClassOfReg platform reg of
+           RcInteger   -> MOV (archWordFormat is32Bit)
+                              (OpReg reg) (OpAddr (spRel dflags off))
+           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))
+           _         -> panic "X86.mkSpillInstr: no match"
+    where platform = targetPlatform dflags
+          is32Bit = target32Bit platform
+
+-- | Make a spill reload instruction.
+x86_mkLoadInstr
+    :: DynFlags
+    -> Reg      -- register to load
+    -> Int      -- current stack delta
+    -> Int      -- spill slot to use
+    -> Instr
+
+x86_mkLoadInstr dflags reg delta slot
+  = let off     = spillSlotToOffset platform slot - delta
+    in
+        case targetClassOfReg platform reg of
+              RcInteger -> MOV (archWordFormat is32Bit)
+                               (OpAddr (spRel dflags off)) (OpReg reg)
+              RcDouble  -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)
+              _           -> panic "X86.x86_mkLoadInstr"
+    where platform = targetPlatform dflags
+          is32Bit = target32Bit platform
+
+spillSlotSize :: Platform -> Int
+spillSlotSize dflags = if is32Bit then 12 else 8
+    where is32Bit = target32Bit dflags
+
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+    = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1
+--     = 0 -- useful for testing allocMoreStack
+
+-- number of bytes that the stack pointer should be aligned to
+stackAlign :: Int
+stackAlign = 16
+
+-- convert a spill slot number to a *byte* offset, with no sign:
+-- decide on a per arch basis whether you are spilling above or below
+-- the C stack pointer.
+spillSlotToOffset :: Platform -> Int -> Int
+spillSlotToOffset platform slot
+   = 64 + spillSlotSize platform * slot
+
+--------------------------------------------------------------------------------
+
+-- | See if this instruction is telling us the current C stack delta
+x86_takeDeltaInstr
+        :: Instr
+        -> Maybe Int
+
+x86_takeDeltaInstr instr
+ = case instr of
+        DELTA i         -> Just i
+        _               -> Nothing
+
+
+x86_isMetaInstr
+        :: Instr
+        -> Bool
+
+x86_isMetaInstr instr
+ = case instr of
+        COMMENT{}       -> True
+        LOCATION{}      -> True
+        LDATA{}         -> True
+        NEWBLOCK{}      -> True
+        UNWIND{}        -> True
+        DELTA{}         -> True
+        _               -> False
+
+
+
+---  TODO: why is there
+-- | Make a reg-reg move instruction.
+--      On SPARC v8 there are no instructions to move directly between
+--      floating point and integer regs. If we need to do that then we
+--      have to go via memory.
+--
+x86_mkRegRegMoveInstr
+    :: Platform
+    -> Reg
+    -> Reg
+    -> Instr
+
+x86_mkRegRegMoveInstr platform src dst
+ = case targetClassOfReg platform src of
+        RcInteger -> case platformArch platform of
+                     ArchX86    -> MOV II32 (OpReg src) (OpReg dst)
+                     ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)
+                     _          -> panic "x86_mkRegRegMoveInstr: Bad arch"
+        RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)
+        -- this code is the lie we tell ourselves because both float and double
+        -- use the same register class.on x86_64 and x86 32bit with SSE2,
+        -- more plainly, both use the XMM registers
+        _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
+
+-- | Check whether an instruction represents a reg-reg move.
+--      The register allocator attempts to eliminate reg->reg moves whenever it can,
+--      by assigning the src and dest temporaries to the same real register.
+--
+x86_takeRegRegMoveInstr
+        :: Instr
+        -> Maybe (Reg,Reg)
+
+x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))
+        = Just (r1,r2)
+
+x86_takeRegRegMoveInstr _  = Nothing
+
+
+-- | Make an unconditional branch instruction.
+x86_mkJumpInstr
+        :: BlockId
+        -> [Instr]
+
+x86_mkJumpInstr id
+        = [JXX ALWAYS id]
+
+-- Note [Windows stack layout]
+-- | On most OSes the kernel will place a guard page after the current stack
+--   page.  If you allocate larger than a page worth you may jump over this
+--   guard page.  Not only is this a security issue, but on certain OSes such
+--   as Windows a new page won't be allocated if you don't hit the guard.  This
+--   will cause a segfault or access fault.
+--
+--   This function defines if the current allocation amount requires a probe.
+--   On Windows (for now) we emit a call to _chkstk for this.  For other OSes
+--   this is not yet implemented.
+--   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk
+--   The Windows stack looks like this:
+--
+--                         +-------------------+
+--                         |        SP         |
+--                         +-------------------+
+--                         |                   |
+--                         |    GUARD PAGE     |
+--                         |                   |
+--                         +-------------------+
+--                         |                   |
+--                         |                   |
+--                         |     UNMAPPED      |
+--                         |                   |
+--                         |                   |
+--                         +-------------------+
+--
+--   In essense each allocation larger than a page size needs to be chunked and
+--   a probe emitted after each page allocation.  You have to hit the guard
+--   page so the kernel can map in the next page, otherwise you'll segfault.
+--
+needs_probe_call :: Platform -> Int -> Bool
+needs_probe_call platform amount
+  = case platformOS platform of
+     OSMinGW32 -> case platformArch platform of
+                    ArchX86    -> amount > (4 * 1024)
+                    ArchX86_64 -> amount > (8 * 1024)
+                    _          -> False
+     _         -> False
+
+x86_mkStackAllocInstr
+        :: Platform
+        -> Int
+        -> [Instr]
+x86_mkStackAllocInstr platform amount
+  = case platformOS platform of
+      OSMinGW32 ->
+        -- These will clobber AX but this should be ok because
+        --
+        -- 1. It is the first thing we do when entering the closure and AX is
+        --    a caller saved registers on Windows both on x86_64 and x86.
+        --
+        -- 2. The closures are only entered via a call or longjmp in which case
+        --    there are no expectations for volatile registers.
+        --
+        -- 3. When the target is a local branch point it is re-targeted
+        --    after the dealloc, preserving #2.  See note [extra spill slots].
+        --
+        -- We emit a call because the stack probes are quite involved and
+        -- would bloat code size a lot.  GHC doesn't really have an -Os.
+        -- __chkstk is guaranteed to leave all nonvolatile registers and AX
+        -- untouched.  It's part of the standard prologue code for any Windows
+        -- function dropping the stack more than a page.
+        -- See Note [Windows stack layout]
+        case platformArch platform of
+            ArchX86    | needs_probe_call platform amount ->
+                           [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax)
+                           , CALL (Left $ strImmLit "___chkstk_ms") [eax]
+                           , SUB II32 (OpReg eax) (OpReg esp)
+                           ]
+                       | otherwise ->
+                           [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
+                           , TEST II32 (OpReg esp) (OpReg esp)
+                           ]
+            ArchX86_64 | needs_probe_call platform amount ->
+                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)
+                           , CALL (Left $ strImmLit "___chkstk_ms") [rax]
+                           , SUB II64 (OpReg rax) (OpReg rsp)
+                           ]
+                       | otherwise ->
+                           [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)
+                           , TEST II64 (OpReg rsp) (OpReg rsp)
+                           ]
+            _ -> panic "x86_mkStackAllocInstr"
+      _       ->
+        case platformArch platform of
+          ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]
+          ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]
+          _ -> panic "x86_mkStackAllocInstr"
+
+x86_mkStackDeallocInstr
+        :: Platform
+        -> Int
+        -> [Instr]
+x86_mkStackDeallocInstr platform amount
+  = case platformArch platform of
+      ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]
+      ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]
+      _ -> panic "x86_mkStackDeallocInstr"
+
+
+--
+-- Note [extra spill slots]
+--
+-- If the register allocator used more spill slots than we have
+-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more
+-- C stack space on entry and exit from this proc.  Therefore we
+-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"
+-- before every non-local jump.
+--
+-- This became necessary when the new codegen started bundling entire
+-- functions together into one proc, because the register allocator
+-- assigns a different stack slot to each virtual reg within a proc.
+-- To avoid using so many slots we could also:
+--
+--   - split up the proc into connected components before code generator
+--
+--   - rename the virtual regs, so that we re-use vreg names and hence
+--     stack slots for non-overlapping vregs.
+--
+-- Note that when a block is both a non-local entry point (with an
+-- info table) and a local branch target, we have to split it into
+-- two, like so:
+--
+--    <info table>
+--    L:
+--       <code>
+--
+-- becomes
+--
+--    <info table>
+--    L:
+--       subl $rsp, N
+--       jmp Lnew
+--    Lnew:
+--       <code>
+--
+-- and all branches pointing to L are retargetted to point to Lnew.
+-- Otherwise, we would repeat the $rsp adjustment for each branch to
+-- L.
+--
+-- Returns a list of (L,Lnew) pairs.
+--
+allocMoreStack
+  :: Platform
+  -> Int
+  -> NatCmmDecl statics X86.Instr.Instr
+  -> UniqSM (NatCmmDecl statics X86.Instr.Instr, [(BlockId,BlockId)])
+
+allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
+    let entries = entryBlocks proc
+
+    uniqs <- replicateM (length entries) getUniqueM
+
+    let
+      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
+        where x = slots * spillSlotSize platform -- sp delta
+
+      alloc   = mkStackAllocInstr   platform delta
+      dealloc = mkStackDeallocInstr platform delta
+
+      retargetList = (zip entries (map mkBlockId uniqs))
+
+      new_blockmap :: LabelMap BlockId
+      new_blockmap = mapFromList retargetList
+
+      insert_stack_insns (BasicBlock id insns)
+         | Just new_blockid <- mapLookup id new_blockmap
+         = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid]
+           , BasicBlock new_blockid block' ]
+         | otherwise
+         = [ BasicBlock id block' ]
+         where
+           block' = foldr insert_dealloc [] insns
+
+      insert_dealloc insn r = case insn of
+         JMP _ _     -> dealloc ++ (insn : r)
+         JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"
+         _other      -> x86_patchJumpInstr insn retarget : r
+           where retarget b = fromMaybe b (mapLookup b new_blockmap)
+
+      new_code = concatMap insert_stack_insns code
+    -- in
+    return (CmmProc info lbl live (ListGraph new_code), retargetList)
+
+data JumpDest = DestBlockId BlockId | DestImm Imm
+
+-- Debug Instance
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
+  ppr (DestImm _imm)    = text "jd<imm>:noShow"
+
+
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
+
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut (JXX ALWAYS id)      = Just (DestBlockId id)
+canShortcut (JMP (OpImm imm) _)  = Just (DestImm imm)
+canShortcut _                    = Nothing
+
+
+-- This helper shortcuts a sequence of branches.
+-- The blockset helps avoid following cycles.
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn
+  where
+    shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
+    shortcutJump' fn seen insn@(JXX cc id) =
+        if setMember id seen then insn
+        else case fn id of
+            Nothing                -> insn
+            Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
+            Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
+        where seen' = setInsert id seen
+    shortcutJump' fn _ (JMP_TBL addr blocks section tblId) =
+        let updateBlock (Just (DestBlockId bid))  =
+                case fn bid of
+                    Nothing   -> Just (DestBlockId bid )
+                    Just dest -> Just dest
+            updateBlock dest = dest
+            blocks' = map updateBlock blocks
+        in  JMP_TBL addr blocks' section tblId
+    shortcutJump' _ _ other = other
+
+-- Here because it knows about JumpDest
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
+shortcutStatics fn (align, Statics lbl statics)
+  = (align, Statics lbl $ map (shortcutStatic fn) statics)
+  -- we need to get the jump tables, so apply the mapping to the entries
+  -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId
+  | otherwise                              = lab
+
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
+        -- slightly dodgy, we're ignoring the second label, but this
+        -- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic _ other_static
+        = other_static
+
+shortBlockId
+        :: (BlockId -> Maybe JumpDest)
+        -> UniqSet Unique
+        -> BlockId
+        -> CLabel
+
+shortBlockId fn seen blockid =
+  case (elementOfUniqSet uq seen, fn blockid) of
+    (True, _)    -> blockLbl blockid
+    (_, Nothing) -> blockLbl blockid
+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
+    (_, Just (DestImm (ImmCLbl lbl))) -> lbl
+    (_, _other) -> panic "shortBlockId"
+  where uq = getUnique blockid
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -0,0 +1,1010 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module X86.Ppr (
+        pprNatCmmDecl,
+        pprData,
+        pprInstr,
+        pprFormat,
+        pprImm,
+        pprDataItem,
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import X86.Regs
+import X86.Instr
+import X86.Cond
+import Instruction
+import Format
+import Reg
+import PprBase
+
+
+import Hoopl.Collections
+import Hoopl.Label
+import BasicTypes       (Alignment, mkAlignment, alignmentBytes)
+import DynFlags
+import Cmm              hiding (topInfoTable)
+import BlockId
+import CLabel
+import Unique           ( pprUniqueAlways )
+import Platform
+import FastString
+import Outputable
+
+import Data.Word
+import Data.Bits
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
+--
+--
+-- Note [Subsections Via Symbols]
+--
+-- If we are using the .subsections_via_symbols directive
+-- (available on recent versions of Darwin),
+-- we have to make sure that there is some kind of reference
+-- from the entry code to a label on the _top_ of of the info table,
+-- so that the linker will not think it is unreferenced and dead-strip
+-- it. That's why the label is called a DeadStripPreventer (_dsp).
+--
+-- The LLVM code gen already creates `iTableSuf` symbols, where
+-- the X86 would generate the DeadStripPreventer (_dsp) symbol.
+-- Therefore all that is left for llvm code gen, is to ensure
+-- that all the `iTableSuf` symbols are marked as used.
+-- As of this writing the documentation regarding the
+-- .subsections_via_symbols and -dead_strip can be found at
+-- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>
+
+pprProcAlignment :: SDoc
+pprProcAlignment = sdocWithDynFlags $ \dflags ->
+  (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags))
+
+pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionAlign section $$ pprDatas dats
+
+pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  sdocWithDynFlags $ \dflags ->
+  pprProcAlignment $$
+  case topInfoTable proc of
+    Nothing ->
+        -- special case for code without info table:
+        pprSectionAlign (Section Text lbl) $$
+        pprProcAlignment $$
+        pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+        vcat (map (pprBasicBlock top_info) blocks) $$
+        (if debugLevel dflags > 0
+         then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
+        pprSizeDecl lbl
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionAlign (Section Text info_lbl) $$
+      pprProcAlignment $$
+      (if platformHasSubsectionsViaSymbols platform
+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+      -- above: Even the first block gets a label, because with branch-chain
+      -- elimination, it might be the target of a goto.
+      (if platformHasSubsectionsViaSymbols platform
+       then -- See Note [Subsections Via Symbols]
+                text "\t.long "
+            <+> ppr info_lbl
+            <+> char '-'
+            <+> ppr (mkDeadStripPreventer info_lbl)
+       else empty) $$
+      pprSizeDecl info_lbl
+
+-- | Output the ELF .size directive.
+pprSizeDecl :: CLabel -> SDoc
+pprSizeDecl lbl
+ = sdocWithPlatform $ \platform ->
+   if osElfTarget (platformOS platform)
+   then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl
+   else empty
+
+pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = sdocWithDynFlags $ \dflags ->
+    maybe_infotable dflags $
+    pprLabel asmLbl $$
+    vcat (map pprInstr instrs) $$
+    (if debugLevel dflags > 0
+     then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
+  where
+    asmLbl = blockLbl blockid
+    maybe_infotable dflags c = case mapLookup blockid info_env of
+       Nothing -> c
+       Just (Statics infoLbl info) ->
+           pprAlignForSection Text $$
+           infoTableLoc $$
+           vcat (map pprData info) $$
+           pprLabel infoLbl $$
+           c $$
+           (if debugLevel dflags > 0
+            then ppr (mkAsmTempEndLabel infoLbl) <> char ':' else empty)
+    -- Make sure the info table has the right .loc for the block
+    -- coming right after it. See [Note: Info Offset]
+    infoTableLoc = case instrs of
+      (l@LOCATION{} : _) -> pprInstr l
+      _other             -> empty
+
+
+pprDatas :: (Alignment, CmmStatics) -> SDoc
+-- See note [emit-time elimination of static indirections] in CLabel.
+pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+  | lbl == mkIndStaticInfoLabel
+  , let labelInd (CmmLabelOff l _) = Just l
+        labelInd (CmmLabel l) = Just l
+        labelInd _ = Nothing
+  , Just ind' <- labelInd ind
+  , alias `mayRedirectTo` ind'
+  = pprGloblDecl alias
+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
+
+pprDatas (align, (Statics lbl dats))
+ = vcat (pprAlign align : pprLabel lbl : map pprData dats)
+
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str) = pprBytes str
+
+pprData (CmmUninitialised bytes)
+ = sdocWithPlatform $ \platform ->
+   if platformOS platform == OSDarwin then text ".space " <> int bytes
+                                      else text ".skip "  <> int bytes
+
+pprData (CmmStaticLit lit) = pprDataItem lit
+
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = text ".globl " <> ppr lbl
+
+pprLabelType' :: DynFlags -> CLabel -> SDoc
+pprLabelType' dflags lbl =
+  if isCFunctionLabel lbl || functionOkInfoTable then
+    text "@function"
+  else
+    text "@object"
+  where
+    {-
+    NOTE: This is a bit hacky.
+
+    With the `tablesNextToCode` info tables look like this:
+    ```
+      <info table data>
+    label_info:
+      <info table code>
+    ```
+    So actually info table label points exactly to the code and we can mark
+    the label as @function. (This is required to make perf and potentially other
+    tools to work on Haskell binaries).
+    This usually works well but it can cause issues with a linker.
+    A linker uses different algorithms for the relocation depending on
+    the symbol type.For some reason, a linker will generate JUMP_SLOT relocation
+    when constructor info table is referenced from a data section.
+    This only happens with static constructor call so
+    we mark _con_info symbols as `@object` to avoid the issue with relocations.
+
+    @SimonMarlow hack explanation:
+    "The reasoning goes like this:
+
+    * The danger when we mark a symbol as `@function` is that the linker will
+      redirect it to point to the PLT and use a `JUMP_SLOT` relocation when
+      the symbol refers to something outside the current shared object.
+      A PLT / JUMP_SLOT reference only works for symbols that we jump to, not
+      for symbols representing data,, nor for info table symbol references which
+      we expect to point directly to the info table.
+    * GHC generates code that might refer to any info table symbol from the text
+      segment, but that's OK, because those will be explicit GOT references
+      generated by the code generator.
+    * When we refer to info tables from the data segment, it's either
+      * a FUN_STATIC/THUNK_STATIC local to this module
+      * a `con_info` that could be from anywhere
+
+    So, the only info table symbols that we might refer to from the data segment
+    of another shared object are `con_info` symbols, so those are the ones we
+    need to exclude from getting the @function treatment.
+    "
+
+    A good place to check for more
+    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code
+
+    Another possible hack is to create an extra local function symbol for
+    every code-like thing to give the needed information for to the tools
+    but mess up with the relocation. https://phabricator.haskell.org/D4730
+    -}
+    functionOkInfoTable = tablesNextToCode dflags &&
+      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)
+
+
+pprTypeDecl :: CLabel -> SDoc
+pprTypeDecl lbl
+    = sdocWithPlatform $ \platform ->
+      if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
+      then
+        sdocWithDynFlags $ \df ->
+          text ".type " <> ppr lbl <> ptext (sLit  ", ") <> pprLabelType' df lbl
+      else empty
+
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeDecl lbl
+            $$ (ppr lbl <> char ':')
+
+pprAlign :: Alignment -> SDoc
+pprAlign alignment
+        = sdocWithPlatform $ \platform ->
+          text ".align " <> int (alignmentOn platform)
+  where
+        bytes = alignmentBytes alignment
+        alignmentOn platform = if platformOS platform == OSDarwin
+                               then log2 bytes
+                               else      bytes
+
+        log2 :: Int -> Int  -- cache the common ones
+        log2 1 = 0
+        log2 2 = 1
+        log2 4 = 2
+        log2 8 = 3
+        log2 n = 1 + log2 (n `quot` 2)
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+    ppr instr = pprInstr instr
+
+
+pprReg :: Format -> Reg -> SDoc
+pprReg f r
+  = case r of
+      RegReal    (RealRegSingle i) ->
+          sdocWithPlatform $ \platform ->
+          if target32Bit platform then ppr32_reg_no f i
+                                  else ppr64_reg_no f i
+      RegReal    (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"
+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u
+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u
+
+  where
+    ppr32_reg_no :: Format -> Int -> SDoc
+    ppr32_reg_no II8   = ppr32_reg_byte
+    ppr32_reg_no II16  = ppr32_reg_word
+    ppr32_reg_no _     = ppr32_reg_long
+
+    ppr32_reg_byte i = ptext
+      (case i of {
+         0 -> sLit "%al";     1 -> sLit "%bl";
+         2 -> sLit "%cl";     3 -> sLit "%dl";
+        _  -> sLit $ "very naughty I386 byte register: " ++ show i
+      })
+
+    ppr32_reg_word i = ptext
+      (case i of {
+         0 -> sLit "%ax";     1 -> sLit "%bx";
+         2 -> sLit "%cx";     3 -> sLit "%dx";
+         4 -> sLit "%si";     5 -> sLit "%di";
+         6 -> sLit "%bp";     7 -> sLit "%sp";
+        _  -> sLit "very naughty I386 word register"
+      })
+
+    ppr32_reg_long i = ptext
+      (case i of {
+         0 -> sLit "%eax";    1 -> sLit "%ebx";
+         2 -> sLit "%ecx";    3 -> sLit "%edx";
+         4 -> sLit "%esi";    5 -> sLit "%edi";
+         6 -> sLit "%ebp";    7 -> sLit "%esp";
+         _  -> ppr_reg_float i
+      })
+
+    ppr64_reg_no :: Format -> Int -> SDoc
+    ppr64_reg_no II8   = ppr64_reg_byte
+    ppr64_reg_no II16  = ppr64_reg_word
+    ppr64_reg_no II32  = ppr64_reg_long
+    ppr64_reg_no _     = ppr64_reg_quad
+
+    ppr64_reg_byte i = ptext
+      (case i of {
+         0 -> sLit "%al";     1 -> sLit "%bl";
+         2 -> sLit "%cl";     3 -> sLit "%dl";
+         4 -> sLit "%sil";    5 -> sLit "%dil"; -- new 8-bit regs!
+         6 -> sLit "%bpl";    7 -> sLit "%spl";
+         8 -> sLit "%r8b";    9  -> sLit "%r9b";
+        10 -> sLit "%r10b";   11 -> sLit "%r11b";
+        12 -> sLit "%r12b";   13 -> sLit "%r13b";
+        14 -> sLit "%r14b";   15 -> sLit "%r15b";
+        _  -> sLit $ "very naughty x86_64 byte register: " ++ show i
+      })
+
+    ppr64_reg_word i = ptext
+      (case i of {
+         0 -> sLit "%ax";     1 -> sLit "%bx";
+         2 -> sLit "%cx";     3 -> sLit "%dx";
+         4 -> sLit "%si";     5 -> sLit "%di";
+         6 -> sLit "%bp";     7 -> sLit "%sp";
+         8 -> sLit "%r8w";    9  -> sLit "%r9w";
+        10 -> sLit "%r10w";   11 -> sLit "%r11w";
+        12 -> sLit "%r12w";   13 -> sLit "%r13w";
+        14 -> sLit "%r14w";   15 -> sLit "%r15w";
+        _  -> sLit "very naughty x86_64 word register"
+      })
+
+    ppr64_reg_long i = ptext
+      (case i of {
+         0 -> sLit "%eax";    1  -> sLit "%ebx";
+         2 -> sLit "%ecx";    3  -> sLit "%edx";
+         4 -> sLit "%esi";    5  -> sLit "%edi";
+         6 -> sLit "%ebp";    7  -> sLit "%esp";
+         8 -> sLit "%r8d";    9  -> sLit "%r9d";
+        10 -> sLit "%r10d";   11 -> sLit "%r11d";
+        12 -> sLit "%r12d";   13 -> sLit "%r13d";
+        14 -> sLit "%r14d";   15 -> sLit "%r15d";
+        _  -> sLit "very naughty x86_64 register"
+      })
+
+    ppr64_reg_quad i = ptext
+      (case i of {
+         0 -> sLit "%rax";      1 -> sLit "%rbx";
+         2 -> sLit "%rcx";      3 -> sLit "%rdx";
+         4 -> sLit "%rsi";      5 -> sLit "%rdi";
+         6 -> sLit "%rbp";      7 -> sLit "%rsp";
+         8 -> sLit "%r8";       9 -> sLit "%r9";
+        10 -> sLit "%r10";    11 -> sLit "%r11";
+        12 -> sLit "%r12";    13 -> sLit "%r13";
+        14 -> sLit "%r14";    15 -> sLit "%r15";
+        _  -> ppr_reg_float i
+      })
+
+ppr_reg_float :: Int -> PtrString
+ppr_reg_float i = case i of
+        16 -> sLit "%xmm0" ;   17 -> sLit "%xmm1"
+        18 -> sLit "%xmm2" ;   19 -> sLit "%xmm3"
+        20 -> sLit "%xmm4" ;   21 -> sLit "%xmm5"
+        22 -> sLit "%xmm6" ;   23 -> sLit "%xmm7"
+        24 -> sLit "%xmm8" ;   25 -> sLit "%xmm9"
+        26 -> sLit "%xmm10";   27 -> sLit "%xmm11"
+        28 -> sLit "%xmm12";   29 -> sLit "%xmm13"
+        30 -> sLit "%xmm14";   31 -> sLit "%xmm15"
+        _  -> sLit "very naughty x86 register"
+
+pprFormat :: Format -> SDoc
+pprFormat x
+ = ptext (case x of
+                II8   -> sLit "b"
+                II16  -> sLit "w"
+                II32  -> sLit "l"
+                II64  -> sLit "q"
+                FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)
+                FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)
+                )
+
+pprFormat_x87 :: Format -> SDoc
+pprFormat_x87 x
+  = ptext $ case x of
+                FF32  -> sLit "s"
+                FF64  -> sLit "l"
+                _     -> panic "X86.Ppr.pprFormat_x87"
+
+
+pprCond :: Cond -> SDoc
+pprCond c
+ = ptext (case c of {
+                GEU     -> sLit "ae";   LU    -> sLit "b";
+                EQQ     -> sLit "e";    GTT   -> sLit "g";
+                GE      -> sLit "ge";   GU    -> sLit "a";
+                LTT     -> sLit "l";    LE    -> sLit "le";
+                LEU     -> sLit "be";   NE    -> sLit "ne";
+                NEG     -> sLit "s";    POS   -> sLit "ns";
+                CARRY   -> sLit "c";   OFLO  -> sLit "o";
+                PARITY  -> sLit "p";   NOTPARITY -> sLit "np";
+                ALWAYS  -> sLit "mp"})
+
+
+pprImm :: Imm -> SDoc
+pprImm (ImmInt i)     = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l)    = ppr l
+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
+pprImm (ImmLit s)     = s
+
+pprImm (ImmFloat _)  = text "naughty float immediate"
+pprImm (ImmDouble _) = text "naughty double immediate"
+
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+                            <> lparen <> pprImm b <> rparen
+
+
+
+pprAddr :: AddrMode -> SDoc
+pprAddr (ImmAddr imm off)
+  = let pp_imm = pprImm imm
+    in
+    if (off == 0) then
+        pp_imm
+    else if (off < 0) then
+        pp_imm <> int off
+    else
+        pp_imm <> char '+' <> int off
+
+pprAddr (AddrBaseIndex base index displacement)
+  = sdocWithPlatform $ \platform ->
+    let
+        pp_disp  = ppr_disp displacement
+        pp_off p = pp_disp <> char '(' <> p <> char ')'
+        pp_reg r = pprReg (archWordFormat (target32Bit platform)) r
+    in
+    case (base, index) of
+      (EABaseNone,  EAIndexNone) -> pp_disp
+      (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
+      (EABaseRip,   EAIndexNone) -> pp_off (text "%rip")
+      (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
+      (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
+                                       <> comma <> int i)
+      _                         -> panic "X86.Ppr.pprAddr: no match"
+
+  where
+    ppr_disp (ImmInt 0) = empty
+    ppr_disp imm        = pprImm imm
+
+-- | Print section header and appropriate alignment for that section.
+pprSectionAlign :: Section -> SDoc
+pprSectionAlign (Section (OtherSection _) _) =
+     panic "X86.Ppr.pprSectionAlign: unknown section"
+pprSectionAlign sec@(Section seg _) =
+  sdocWithPlatform $ \platform ->
+    pprSectionHeader platform sec $$
+    pprAlignForSection seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: SectionType -> SDoc
+pprAlignForSection seg =
+  sdocWithPlatform $ \platform ->
+    text ".align " <>
+    case platformOS platform of
+      -- Darwin: alignments are given as shifts.
+      OSDarwin
+       | target32Bit platform ->
+          case seg of
+           ReadOnlyData16    -> int 4
+           CString           -> int 1
+           _                 -> int 2
+       | otherwise ->
+          case seg of
+           ReadOnlyData16    -> int 4
+           CString           -> int 1
+           _                 -> int 3
+      -- Other: alignments are given as bytes.
+      _
+       | target32Bit platform ->
+          case seg of
+           Text              -> text "4,0x90"
+           ReadOnlyData16    -> int 16
+           CString           -> int 1
+           _                 -> int 4
+       | otherwise ->
+          case seg of
+           ReadOnlyData16    -> int 16
+           CString           -> int 1
+           _                 -> int 8
+
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit
+
+pprDataItem' :: DynFlags -> CmmLit -> SDoc
+pprDataItem' dflags lit
+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+    where
+        platform = targetPlatform dflags
+        imm = litToImm lit
+
+        -- These seem to be common:
+        ppr_item II8   _ = [text "\t.byte\t" <> pprImm imm]
+        ppr_item II16  _ = [text "\t.word\t" <> pprImm imm]
+        ppr_item II32  _ = [text "\t.long\t" <> pprImm imm]
+
+        ppr_item FF32  (CmmFloat r _)
+           = let bs = floatToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item FF64 (CmmFloat r _)
+           = let bs = doubleToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item II64 _
+            = case platformOS platform of
+              OSDarwin
+               | target32Bit platform ->
+                  case lit of
+                  CmmInt x _ ->
+                      [text "\t.long\t"
+                          <> int (fromIntegral (fromIntegral x :: Word32)),
+                       text "\t.long\t"
+                          <> int (fromIntegral
+                              (fromIntegral (x `shiftR` 32) :: Word32))]
+                  _ -> panic "X86.Ppr.ppr_item: no match for II64"
+               | otherwise ->
+                  [text "\t.quad\t" <> pprImm imm]
+              _
+               | target32Bit platform ->
+                  [text "\t.quad\t" <> pprImm imm]
+               | otherwise ->
+                  -- x86_64: binutils can't handle the R_X86_64_PC64
+                  -- relocation type, which means we can't do
+                  -- pc-relative 64-bit addresses. Fortunately we're
+                  -- assuming the small memory model, in which all such
+                  -- offsets will fit into 32 bits, so we have to stick
+                  -- to 32-bit offset fields and modify the RTS
+                  -- appropriately
+                  --
+                  -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h
+                  --
+                  case lit of
+                  -- A relative relocation:
+                  CmmLabelDiffOff _ _ _ _ ->
+                      [text "\t.long\t" <> pprImm imm,
+                       text "\t.long\t0"]
+                  _ ->
+                      [text "\t.quad\t" <> pprImm imm]
+
+        ppr_item _ _
+                = panic "X86.Ppr.ppr_item: no match"
+
+
+asmComment :: SDoc -> SDoc
+asmComment c = whenPprDebug $ text "# " <> c
+
+pprInstr :: Instr -> SDoc
+
+pprInstr (COMMENT s)
+   = asmComment (ftext s)
+
+pprInstr (LOCATION file line col _name)
+   = text "\t.loc " <> ppr file <+> ppr line <+> ppr col
+
+pprInstr (DELTA d)
+   = asmComment $ text ("\tdelta = " ++ show d)
+
+pprInstr (NEWBLOCK _)
+   = panic "PprMach.pprInstr: NEWBLOCK"
+
+pprInstr (UNWIND lbl d)
+   = asmComment (text "\tunwind = " <> ppr d)
+     $$ ppr lbl <> colon
+
+pprInstr (LDATA _ _)
+   = panic "PprMach.pprInstr: LDATA"
+
+{-
+pprInstr (SPILL reg slot)
+   = hcat [
+        text "\tSPILL",
+        char ' ',
+        pprUserReg reg,
+        comma,
+        text "SLOT" <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+        text "\tRELOAD",
+        char ' ',
+        text "SLOT" <> parens (int slot),
+        comma,
+        pprUserReg reg]
+-}
+
+-- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.
+-- The code generator catches most of these already, but not all.
+pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _))
+  = pprInstr (XOR format' dst dst)
+  where format' = case format of
+          II64 -> II32          -- 32-bit version is equivalent, and smaller
+          _    -> format
+pprInstr (MOV format src dst)
+  = pprFormatOpOp (sLit "mov") format src dst
+
+pprInstr (CMOV cc format src dst)
+  = pprCondOpReg (sLit "cmov") format cc src dst
+
+pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst
+        -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
+        -- movl.  But we represent it as a MOVZxL instruction, because
+        -- the reg alloc would tend to throw away a plain reg-to-reg
+        -- move, and we still want it to do that.
+
+pprInstr (MOVZxL formats src dst)
+  = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst
+        -- zero-extension only needs to extend to 32 bits: on x86_64,
+        -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
+        -- instruction is shorter.
+
+pprInstr (MOVSxL formats src dst)
+  = sdocWithPlatform $ \platform ->
+    pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst
+
+-- here we do some patching, since the physical registers are only set late
+-- in the code generation.
+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
+  | reg1 == reg3
+  = pprFormatOpOp (sLit "add") format (OpReg reg2) dst
+
+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
+  | reg2 == reg3
+  = pprFormatOpOp (sLit "add") format (OpReg reg1) dst
+
+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
+  | reg1 == reg3
+  = pprInstr (ADD format (OpImm displ) dst)
+
+pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst
+
+pprInstr (ADD format (OpImm (ImmInt (-1))) dst)
+  = pprFormatOp (sLit "dec") format dst
+pprInstr (ADD format (OpImm (ImmInt 1)) dst)
+  = pprFormatOp (sLit "inc") format dst
+pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst
+pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst
+pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst
+pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst
+pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2
+
+pprInstr (ADD_CC format src dst)
+  = pprFormatOpOp (sLit "add") format src dst
+pprInstr (SUB_CC format src dst)
+  = pprFormatOpOp (sLit "sub") format src dst
+
+{- A hack.  The Intel documentation says that "The two and three
+   operand forms [of IMUL] may also be used with unsigned operands
+   because the lower half of the product is the same regardless if
+   (sic) the operands are signed or unsigned.  The CF and OF flags,
+   however, cannot be used to determine if the upper half of the
+   result is non-zero."  So there.
+-}
+
+-- Use a 32-bit instruction when possible as it saves a byte.
+-- Notably, extracting the tag bits of a pointer has this form.
+-- TODO: we could save a byte in a subsequent CMP instruction too,
+-- but need something like a peephole pass for this
+pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst)
+  | 0 <= mask && mask < 0xffffffff
+    = pprInstr (AND II32 src dst)
+pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst
+pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst
+pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst
+pprInstr (OR  format src dst) = pprFormatOpOp (sLit "or")  format src dst
+
+pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
+pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
+pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor")  format src dst
+
+pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)
+pprInstr (LZCNT format src dst)  = pprOpOp (sLit "lzcnt")  format src (OpReg dst)
+pprInstr (TZCNT format src dst)  = pprOpOp (sLit "tzcnt")  format src (OpReg dst)
+pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst)
+pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst)
+
+pprInstr (PDEP format src mask dst)   = pprFormatOpOpReg (sLit "pdep") format src mask dst
+pprInstr (PEXT format src mask dst)   = pprFormatOpOpReg (sLit "pext") format src mask dst
+
+pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src
+pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src
+pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src
+pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src
+
+pprInstr (NOT format op) = pprFormatOp (sLit "not") format op
+pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op)
+pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op
+
+pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst
+pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst
+pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst
+
+pprInstr (BT  format imm src) = pprFormatImmOp (sLit "bt") format imm src
+
+pprInstr (CMP format src dst)
+  | isFloatFormat format =  pprFormatOpOp (sLit "ucomi") format src dst -- SSE2
+  | otherwise     =  pprFormatOpOp (sLit "cmp")   format src dst
+
+pprInstr (TEST format src dst) = sdocWithPlatform $ \platform ->
+  let format' = case (src,dst) of
+        -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.
+        -- We can replace them by equivalent, but smaller instructions
+        -- by reducing the size of the immediate operand as far as possible.
+        -- (We could handle masks larger than a single byte too,
+        -- but it would complicate the code considerably
+        -- and tag checks are by far the most common case.)
+        -- The mask must have the high bit clear for this smaller encoding
+        -- to be completely equivalent to the original; in particular so
+        -- that the signed comparison condition bits are the same as they
+        -- would be if doing a full word comparison. See #13425.
+        (OpImm (ImmInteger mask), OpReg dstReg)
+          | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg
+        _ -> format
+  in pprFormatOpOp (sLit "test") format' src dst
+  where
+    minSizeOfReg platform (RegReal (RealRegSingle i))
+      | target32Bit platform && i <= 3        = II8  -- al, bl, cl, dl
+      | target32Bit platform && i <= 7        = II16 -- si, di, bp, sp
+      | not (target32Bit platform) && i <= 15 = II8  -- al .. r15b
+    minSizeOfReg _ _ = format                 -- other
+
+pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op
+pprInstr (POP format op) = pprFormatOp (sLit "pop") format op
+
+-- both unused (SDM):
+-- pprInstr PUSHA = text "\tpushal"
+-- pprInstr POPA = text "\tpopal"
+
+pprInstr NOP = text "\tnop"
+pprInstr (CLTD II8) = text "\tcbtw"
+pprInstr (CLTD II16) = text "\tcwtd"
+pprInstr (CLTD II32) = text "\tcltd"
+pprInstr (CLTD II64) = text "\tcqto"
+pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x
+
+pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
+
+pprInstr (JXX cond blockid)
+  = pprCondInstr (sLit "j") cond (ppr lab)
+  where lab = blockLbl blockid
+
+pprInstr        (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
+
+pprInstr        (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm
+pprInstr (JMP op _)          = sdocWithPlatform $ \platform ->
+                               text "\tjmp *"
+                                   <> pprOperand (archWordFormat (target32Bit platform)) op
+pprInstr (JMP_TBL op _ _ _)  = pprInstr (JMP op [])
+pprInstr        (CALL (Left imm) _)    = text "\tcall " <> pprImm imm
+pprInstr (CALL (Right reg) _)   = sdocWithPlatform $ \platform ->
+                                  text "\tcall *"
+                                      <> pprReg (archWordFormat (target32Bit platform)) reg
+
+pprInstr (IDIV fmt op)   = pprFormatOp (sLit "idiv") fmt op
+pprInstr (DIV fmt op)    = pprFormatOp (sLit "div")  fmt op
+pprInstr (IMUL2 fmt op)  = pprFormatOp (sLit "imul") fmt op
+
+-- x86_64 only
+pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2
+pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op
+
+pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2
+pprInstr (SQRT format op1 op2) = pprFormatOpReg (sLit "sqrt") format op1 op2
+
+pprInstr (CVTSS2SD from to)      = pprRegReg (sLit "cvtss2sd") from to
+pprInstr (CVTSD2SS from to)      = pprRegReg (sLit "cvtsd2ss") from to
+pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to
+pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to
+pprInstr (CVTSI2SS fmt from to)   = pprFormatOpReg (sLit "cvtsi2ss") fmt from to
+pprInstr (CVTSI2SD fmt from to)   = pprFormatOpReg (sLit "cvtsi2sd") fmt from to
+
+    -- FETCHGOT for PIC on ELF platforms
+pprInstr (FETCHGOT reg)
+   = vcat [ text "\tcall 1f",
+            hcat [ text "1:\tpopl\t", pprReg II32 reg ],
+            hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",
+                   pprReg II32 reg ]
+          ]
+
+    -- FETCHPC for PIC on Darwin/x86
+    -- get the instruction pointer into a register
+    -- (Terminology note: the IP is called Program Counter on PPC,
+    --  and it's a good thing to use the same name on both platforms)
+pprInstr (FETCHPC reg)
+   = vcat [ text "\tcall 1f",
+            hcat [ text "1:\tpopl\t", pprReg II32 reg ]
+          ]
+
+
+-- the
+-- GST fmt src addr ==> FLD dst ; FSTPsz addr
+pprInstr g@(X87Store fmt  addr)
+ = pprX87 g (hcat [gtab,
+                 text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr])
+
+
+-- Atomics
+
+pprInstr (LOCK i) = text "\tlock" $$ pprInstr i
+
+pprInstr MFENCE = text "\tmfence"
+
+pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst
+
+pprInstr (CMPXCHG format src dst)
+   = pprFormatOpOp (sLit "cmpxchg") format src dst
+
+
+
+--------------------------
+-- some left over
+
+
+
+gtab :: SDoc
+gtab  = char '\t'
+
+gsp :: SDoc
+gsp   = char ' '
+
+
+
+pprX87 :: Instr -> SDoc -> SDoc
+pprX87 fake actual
+   = (char '#' <> pprX87Instr fake) $$ actual
+
+pprX87Instr :: Instr -> SDoc
+pprX87Instr (X87Store fmt  dst) = pprFormatAddr (sLit "gst") fmt  dst
+pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"
+
+pprDollImm :: Imm -> SDoc
+pprDollImm i = text "$" <> pprImm i
+
+
+pprOperand :: Format -> Operand -> SDoc
+pprOperand f (OpReg r)   = pprReg f r
+pprOperand _ (OpImm i)   = pprDollImm i
+pprOperand _ (OpAddr ea) = pprAddr ea
+
+
+pprMnemonic_  :: PtrString -> SDoc
+pprMnemonic_ name =
+   char '\t' <> ptext name <> space
+
+
+pprMnemonic  :: PtrString -> Format -> SDoc
+pprMnemonic name format =
+   char '\t' <> ptext name <> pprFormat format <> space
+
+
+pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc
+pprFormatImmOp name format imm op1
+  = hcat [
+        pprMnemonic name format,
+        char '$',
+        pprImm imm,
+        comma,
+        pprOperand format op1
+    ]
+
+
+pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc
+pprFormatOp_ name format op1
+  = hcat [
+        pprMnemonic_ name ,
+        pprOperand format op1
+    ]
+
+pprFormatOp :: PtrString -> Format -> Operand -> SDoc
+pprFormatOp name format op1
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1
+    ]
+
+
+pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc
+pprFormatOpOp name format op1 op2
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2
+    ]
+
+
+pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc
+pprOpOp name format op1 op2
+  = hcat [
+        pprMnemonic_ name,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2
+    ]
+
+
+
+pprRegReg :: PtrString -> Reg -> Reg -> SDoc
+pprRegReg name reg1 reg2
+  = sdocWithPlatform $ \platform ->
+    hcat [
+        pprMnemonic_ name,
+        pprReg (archWordFormat (target32Bit platform)) reg1,
+        comma,
+        pprReg (archWordFormat (target32Bit platform)) reg2
+    ]
+
+
+pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc
+pprFormatOpReg name format op1 reg2
+  = sdocWithPlatform $ \platform ->
+    hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprReg (archWordFormat (target32Bit platform)) reg2
+    ]
+
+pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc
+pprCondOpReg name format cond op1 reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        pprCond cond,
+        space,
+        pprOperand format op1,
+        comma,
+        pprReg format reg2
+    ]
+
+pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc
+pprFormatFormatOpReg name format1 format2 op1 reg2
+  = hcat [
+        pprMnemonic name format2,
+        pprOperand format1 op1,
+        comma,
+        pprReg format2 reg2
+    ]
+
+pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc
+pprFormatOpOpReg name format op1 op2 reg3
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2,
+        comma,
+        pprReg format reg3
+    ]
+
+
+
+pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc
+pprFormatAddr name format  op
+  = hcat [
+        pprMnemonic name format,
+        comma,
+        pprAddr op
+    ]
+
+pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc
+pprShift name format src dest
+  = hcat [
+        pprMnemonic name format,
+        pprOperand II8 src,  -- src is 8-bit sized
+        comma,
+        pprOperand format dest
+    ]
+
+
+pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc
+pprFormatOpOpCoerce name format1 format2 op1 op2
+  = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,
+        pprOperand format1 op1,
+        comma,
+        pprOperand format2 op2
+    ]
+
+
+pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc
+pprCondInstr name cond arg
+  = hcat [ char '\t', ptext name, pprCond cond, space, arg]
diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/RegInfo.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE CPP #-}
+module X86.RegInfo (
+        mkVirtualReg,
+        regDotColor
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Format
+import Reg
+
+import Outputable
+import Platform
+import Unique
+
+import UniqFM
+import X86.Regs
+
+
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+   = case format of
+        FF32    -> VirtualRegD u
+        -- for scalar F32, we use the same xmm as F64!
+        -- this is a hack that needs some improvement.
+        -- For now we map both to being allocated as "Double" Registers
+        -- on X86/X86_64
+        FF64    -> VirtualRegD u
+        _other  -> VirtualRegI u
+
+regDotColor :: Platform -> RealReg -> SDoc
+regDotColor platform reg
+ = case (lookupUFM (regColors platform) reg) of
+        Just str -> text str
+        _        -> panic "Register not assigned a color"
+
+regColors :: Platform -> UniqFM [Char]
+regColors platform = listToUFM (normalRegColors platform)
+
+normalRegColors :: Platform -> [(Reg,String)]
+normalRegColors platform =
+    zip (map regSingle [0..lastint platform]) colors
+        ++ zip (map regSingle [firstxmm..lastxmm platform]) greys
+  where
+    -- 16 colors - enough for amd64 gp regs
+    colors = ["#800000","#ff0000","#808000","#ffff00","#008000"
+             ,"#00ff00","#008080","#00ffff","#000080","#0000ff"
+             ,"#800080","#ff00ff","#87005f","#875f00","#87af00"
+             ,"#ff00af"]
+
+    -- 16 shades of grey, enough for the currently supported
+    -- SSE extensions.
+    greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646"
+            ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c"
+            ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2"
+            ,"#e0e0e0"]
+
+
+
+--     32 shades of grey - use for avx 512 if we ever need it
+--     greys = ["#070707","#0e0e0e","#151515","#1c1c1c"
+--             ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f"
+--             ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262"
+--             ,"#696969","#707070","#777777","#7e7e7e","#858585"
+--             ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8"
+--             ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb"
+--             ,"#d2d2d2","#d9d9d9","#e0e0e0"]
+
+
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -0,0 +1,443 @@
+{-# LANGUAGE CPP #-}
+
+module X86.Regs (
+        -- squeese functions for the graph allocator
+        virtualRegSqueeze,
+        realRegSqueeze,
+
+        -- immediates
+        Imm(..),
+        strImmLit,
+        litToImm,
+
+        -- addressing modes
+        AddrMode(..),
+        addrOffset,
+
+        -- registers
+        spRel,
+        argRegs,
+        allArgRegs,
+        allIntArgRegs,
+        callClobberedRegs,
+        instrClobberedRegs,
+        allMachRegNos,
+        classOfRealReg,
+        showReg,
+
+        -- machine specific
+        EABase(..), EAIndex(..), addrModeRegs,
+
+        eax, ebx, ecx, edx, esi, edi, ebp, esp,
+
+
+        rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,
+        r8,  r9,  r10, r11, r12, r13, r14, r15,
+        lastint,
+        xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
+        xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,
+        xmm,
+        firstxmm, lastxmm,
+
+        ripRel,
+        allFPArgRegs,
+
+        allocatableRegs
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CodeGen.Platform
+import Reg
+import RegClass
+
+import Cmm
+import CLabel           ( CLabel )
+import DynFlags
+import Outputable
+import Platform
+
+import qualified Data.Array as A
+
+-- | regSqueeze_class reg
+--      Calculate the maximum number of register colors that could be
+--      denied to a node of this class due to having this reg
+--      as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+
+virtualRegSqueeze cls vr
+ = case cls of
+        RcInteger
+         -> case vr of
+                VirtualRegI{}           -> 1
+                VirtualRegHi{}          -> 1
+                _other                  -> 0
+
+        RcDouble
+         -> case vr of
+                VirtualRegD{}           -> 1
+                VirtualRegF{}           -> 0
+                _other                  -> 0
+
+
+        _other -> 0
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+realRegSqueeze cls rr
+ = case cls of
+        RcInteger
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < firstxmm -> 1
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcDouble
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo >= firstxmm  -> 1
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+
+        _other -> 0
+
+-- -----------------------------------------------------------------------------
+-- Immediates
+
+data Imm
+  = ImmInt      Int
+  | ImmInteger  Integer     -- Sigh.
+  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)
+  | ImmLit      SDoc        -- Simple string
+  | ImmIndex    CLabel Int
+  | ImmFloat    Rational
+  | ImmDouble   Rational
+  | ImmConstantSum Imm Imm
+  | ImmConstantDiff Imm Imm
+
+strImmLit :: String -> Imm
+strImmLit s = ImmLit (text s)
+
+
+litToImm :: CmmLit -> Imm
+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
+                -- narrow to the width: a CmmInt might be out of
+                -- range, but we assume that ImmInteger only contains
+                -- in-range values.  A signed value should be fine here.
+litToImm (CmmFloat f W32)    = ImmFloat f
+litToImm (CmmFloat f W64)    = ImmDouble f
+litToImm (CmmLabel l)        = ImmCLbl l
+litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off _)
+                             = ImmConstantSum
+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+                               (ImmInt off)
+litToImm _                   = panic "X86.Regs.litToImm: no match"
+
+-- addressing modes ------------------------------------------------------------
+
+data AddrMode
+        = AddrBaseIndex EABase EAIndex Displacement
+        | ImmAddr Imm Int
+
+data EABase       = EABaseNone  | EABaseReg Reg | EABaseRip
+data EAIndex      = EAIndexNone | EAIndex Reg Int
+type Displacement = Imm
+
+
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
+addrOffset addr off
+  = case addr of
+      ImmAddr i off0      -> Just (ImmAddr i (off0 + off))
+
+      AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off)))
+      AddrBaseIndex r i (ImmInteger n)
+        -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off))))
+
+      AddrBaseIndex r i (ImmCLbl lbl)
+        -> Just (AddrBaseIndex r i (ImmIndex lbl off))
+
+      AddrBaseIndex r i (ImmIndex lbl ix)
+        -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off)))
+
+      _ -> Nothing  -- in theory, shouldn't happen
+
+
+addrModeRegs :: AddrMode -> [Reg]
+addrModeRegs (AddrBaseIndex b i _) =  b_regs ++ i_regs
+  where
+   b_regs = case b of { EABaseReg r -> [r]; _ -> [] }
+   i_regs = case i of { EAIndex r _ -> [r]; _ -> [] }
+addrModeRegs _ = []
+
+
+-- registers -------------------------------------------------------------------
+
+-- @spRel@ gives us a stack relative addressing mode for volatile
+-- temporaries and for excess call arguments.  @fpRel@, where
+-- applicable, is the same but for the frame pointer.
+
+
+spRel :: DynFlags
+      -> Int -- ^ desired stack offset in bytes, positive or negative
+      -> AddrMode
+spRel dflags n
+ | target32Bit (targetPlatform dflags)
+    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)
+ | otherwise
+    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)
+
+-- The register numbers must fit into 32 bits on x86, so that we can
+-- use a Word32 to represent the set of free registers in the register
+-- allocator.
+
+
+
+firstxmm :: RegNo
+firstxmm  = 16
+
+--  on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available
+lastxmm :: Platform -> RegNo
+lastxmm platform
+ | target32Bit platform = firstxmm + 7  -- xmm0 - xmmm7
+ | otherwise            = firstxmm + 15 -- xmm0 -xmm15
+
+lastint :: Platform -> RegNo
+lastint platform
+ | target32Bit platform = 7 -- not %r8..%r15
+ | otherwise            = 15
+
+intregnos :: Platform -> [RegNo]
+intregnos platform = [0 .. lastint platform]
+
+
+
+xmmregnos :: Platform -> [RegNo]
+xmmregnos platform = [firstxmm  .. lastxmm platform]
+
+floatregnos :: Platform -> [RegNo]
+floatregnos platform = xmmregnos platform
+
+-- argRegs is the set of regs which are read for an n-argument call to C.
+-- For archs which pass all args on the stack (x86), is empty.
+-- Sparc passes up to the first 6 args in regs.
+argRegs :: RegNo -> [Reg]
+argRegs _       = panic "MachRegs.argRegs(x86): should not be used!"
+
+-- | The complete set of machine registers.
+allMachRegNos :: Platform -> [RegNo]
+allMachRegNos platform = intregnos platform ++ floatregnos platform
+
+-- | Take the class of a register.
+{-# INLINE classOfRealReg #-}
+classOfRealReg :: Platform -> RealReg -> RegClass
+-- On x86, we might want to have an 8-bit RegClass, which would
+-- contain just regs 1-4 (the others don't have 8-bit versions).
+-- However, we can get away without this at the moment because the
+-- only allocatable integer regs are also 8-bit compatible (1, 3, 4).
+classOfRealReg platform reg
+    = case reg of
+        RealRegSingle i
+            | i <= lastint platform -> RcInteger
+            | i <= lastxmm platform -> RcDouble
+            | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"
+        _   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"
+
+-- | Get the name of the register with this number.
+-- NOTE: fixme, we dont track which "way" the XMM registers are used
+showReg :: Platform -> RegNo -> String
+showReg platform n
+        | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)
+        | n >= 8   && n < firstxmm      = "%r" ++ show n
+        | otherwise      = regNames platform A.! n
+
+regNames :: Platform -> A.Array Int String
+regNames platform
+    = if target32Bit platform
+      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]
+      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]
+
+
+
+-- machine specific ------------------------------------------------------------
+
+
+{-
+Intel x86 architecture:
+- All registers except 7 (esp) are available for use.
+- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
+- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
+- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
+
+The fp registers are all Double registers; we don't have any RcFloat class
+regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should
+never generate them.
+
+TODO: cleanup modelling float vs double registers and how they are the same class.
+-}
+
+
+eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg
+
+eax   = regSingle 0
+ebx   = regSingle 1
+ecx   = regSingle 2
+edx   = regSingle 3
+esi   = regSingle 4
+edi   = regSingle 5
+ebp   = regSingle 6
+esp   = regSingle 7
+
+
+
+
+{-
+AMD x86_64 architecture:
+- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:
+
+  8     16    32    64
+  ---------------------
+  al    ax    eax   rax
+  bl    bx    ebx   rbx
+  cl    cx    ecx   rcx
+  dl    dx    edx   rdx
+  sil   si    esi   rsi
+  dil   si    edi   rdi
+  bpl   bp    ebp   rbp
+  spl   sp    esp   rsp
+  r10b  r10w  r10d  r10
+  r11b  r11w  r11d  r11
+  r12b  r12w  r12d  r12
+  r13b  r13w  r13d  r13
+  r14b  r14w  r14d  r14
+  r15b  r15w  r15d  r15
+-}
+
+rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,
+  r8, r9, r10, r11, r12, r13, r14, r15,
+  xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
+  xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg
+
+rax   = regSingle 0
+rbx   = regSingle 1
+rcx   = regSingle 2
+rdx   = regSingle 3
+rsi   = regSingle 4
+rdi   = regSingle 5
+rbp   = regSingle 6
+rsp   = regSingle 7
+r8    = regSingle 8
+r9    = regSingle 9
+r10   = regSingle 10
+r11   = regSingle 11
+r12   = regSingle 12
+r13   = regSingle 13
+r14   = regSingle 14
+r15   = regSingle 15
+xmm0  = regSingle 16
+xmm1  = regSingle 17
+xmm2  = regSingle 18
+xmm3  = regSingle 19
+xmm4  = regSingle 20
+xmm5  = regSingle 21
+xmm6  = regSingle 22
+xmm7  = regSingle 23
+xmm8  = regSingle 24
+xmm9  = regSingle 25
+xmm10 = regSingle 26
+xmm11 = regSingle 27
+xmm12 = regSingle 28
+xmm13 = regSingle 29
+xmm14 = regSingle 30
+xmm15 = regSingle 31
+
+ripRel :: Displacement -> AddrMode
+ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm
+
+
+ -- so we can re-use some x86 code:
+{-
+eax = rax
+ebx = rbx
+ecx = rcx
+edx = rdx
+esi = rsi
+edi = rdi
+ebp = rbp
+esp = rsp
+-}
+
+xmm :: RegNo -> Reg
+xmm n = regSingle (firstxmm+n)
+
+
+
+
+-- | these are the regs which we cannot assume stay alive over a C call.
+callClobberedRegs       :: Platform -> [Reg]
+-- caller-saves registers
+callClobberedRegs platform
+ | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)
+ | platformOS platform == OSMinGW32
+   = [rax,rcx,rdx,r8,r9,r10,r11]
+   -- Only xmm0-5 are caller-saves registers on 64bit windows.
+   -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )
+   -- For details check the Win64 ABI.
+   ++ map xmm [0  .. 5]
+ | otherwise
+    -- all xmm regs are caller-saves
+    -- caller-saves registers
+    = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11]
+   ++ map regSingle (floatregnos platform)
+
+allArgRegs :: Platform -> [(Reg, Reg)]
+allArgRegs platform
+ | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9]
+                                          (map regSingle [firstxmm ..])
+ | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch"
+
+allIntArgRegs :: Platform -> [Reg]
+allIntArgRegs platform
+ | (platformOS platform == OSMinGW32) || target32Bit platform
+    = panic "X86.Regs.allIntArgRegs: not defined for this platform"
+ | otherwise = [rdi,rsi,rdx,rcx,r8,r9]
+
+
+-- | on 64bit platforms we pass the first 8 float/double arguments
+-- in the xmm registers.
+allFPArgRegs :: Platform -> [Reg]
+allFPArgRegs platform
+ | platformOS platform == OSMinGW32
+    = panic "X86.Regs.allFPArgRegs: not defined for this platform"
+ | otherwise = map regSingle [firstxmm .. firstxmm + 7 ]
+
+
+-- Machine registers which might be clobbered by instructions that
+-- generate results into fixed registers, or need arguments in a fixed
+-- register.
+instrClobberedRegs :: Platform -> [Reg]
+instrClobberedRegs platform
+ | target32Bit platform = [ eax, ecx, edx ]
+ | otherwise            = [ rax, rcx, rdx ]
+
+--
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: Platform -> [RealReg]
+allocatableRegs platform
+   = let isFree i = freeReg platform i
+     in  map RealRegSingle $ filter isFree (allMachRegNos platform)
+
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/prelude/PrelInfo.hs
@@ -0,0 +1,285 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP #-}
+
+-- | The @PrelInfo@ interface to the compiler's prelude knowledge.
+--
+-- This module serves as the central gathering point for names which the
+-- compiler knows something about. This includes functions for,
+--
+--  * discerning whether a 'Name' is known-key
+--
+--  * given a 'Unique', looking up its corresponding known-key 'Name'
+--
+-- See Note [Known-key names] and Note [About wired-in things] for information
+-- about the two types of prelude things in GHC.
+--
+module PrelInfo (
+        -- * Known-key names
+        isKnownKeyName,
+        lookupKnownKeyName,
+        lookupKnownNameInfo,
+
+        -- ** Internal use
+        -- | 'knownKeyNames' is exported to seed the original name cache only;
+        -- if you find yourself wanting to look at it you might consider using
+        -- 'lookupKnownKeyName' or 'isKnownKeyName'.
+        knownKeyNames,
+
+        -- * Miscellaneous
+        wiredInIds, ghcPrimIds,
+        primOpRules, builtinRules,
+
+        ghcPrimExports,
+        primOpId,
+
+        -- * Random other things
+        maybeCharLikeCon, maybeIntLikeCon,
+
+        -- * Class categories
+        isNumericClass, isStandardClass
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import KnownUniques
+import Unique           ( isValidKnownKeyUnique )
+
+import ConLike          ( ConLike(..) )
+import THNames          ( templateHaskellNames )
+import PrelNames
+import PrelRules
+import Avail
+import PrimOp
+import DataCon
+import Id
+import Name
+import NameEnv
+import MkId
+import Outputable
+import TysPrim
+import TysWiredIn
+import HscTypes
+import Class
+import TyCon
+import UniqFM
+import Util
+import TcTypeNats ( typeNatTyCons )
+
+import Control.Applicative ((<|>))
+import Data.List        ( intercalate )
+import Data.Array
+import Data.Maybe
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[builtinNameInfo]{Lookup built-in names}
+*                                                                      *
+************************************************************************
+
+Note [About wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Wired-in things are Ids\/TyCons that are completely known to the compiler.
+  They are global values in GHC, (e.g.  listTyCon :: TyCon).
+
+* A wired in Name contains the thing itself inside the Name:
+        see Name.wiredInNameTyThing_maybe
+  (E.g. listTyConName contains listTyCon.
+
+* The name cache is initialised with (the names of) all wired-in things
+  (except tuples and sums; see Note [Known-])
+
+* The type environment itself contains no wired in things. The type
+  checker sees if the Name is wired in before looking up the name in
+  the type environment.
+
+* MkIface prunes out wired-in things before putting them in an interface file.
+  So interface files never contain wired-in things.
+-}
+
+
+-- | This list is used to ensure that when you say "Prelude.map" in your source
+-- code, or in an interface file, you get a Name with the correct known key (See
+-- Note [Known-key names] in PrelNames)
+knownKeyNames :: [Name]
+knownKeyNames
+  | debugIsOn
+  , Just badNamesStr <- knownKeyNamesOkay all_names
+  = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
+       -- NB: We can't use ppr here, because this is sometimes evaluated in a
+       -- context where there are no DynFlags available, leading to a cryptic
+       -- "<<details unavailable>>" error. (This seems to happen only in the
+       -- stage 2 compiler, for reasons I [Richard] have no clue of.)
+  | otherwise
+  = all_names
+  where
+    all_names =
+      concat [ wired_tycon_kk_names funTyCon
+             , concatMap wired_tycon_kk_names primTyCons
+
+             , concatMap wired_tycon_kk_names wiredInTyCons
+               -- Does not include tuples
+
+             , concatMap wired_tycon_kk_names typeNatTyCons
+
+             , map idName wiredInIds
+             , map (idName . primOpId) allThePrimOps
+             , basicKnownKeyNames
+             , templateHaskellNames
+             ]
+    -- All of the names associated with a wired-in TyCon.
+    -- This includes the TyCon itself, its DataCons and promoted TyCons.
+    wired_tycon_kk_names :: TyCon -> [Name]
+    wired_tycon_kk_names tc =
+        tyConName tc : (rep_names tc ++ implicits)
+      where implicits = concatMap thing_kk_names (implicitTyConThings tc)
+
+    wired_datacon_kk_names :: DataCon -> [Name]
+    wired_datacon_kk_names dc =
+      dataConName dc : rep_names (promoteDataCon dc)
+
+    thing_kk_names :: TyThing -> [Name]
+    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc
+    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc
+    thing_kk_names thing                       = [getName thing]
+
+    -- The TyConRepName for a known-key TyCon has a known key,
+    -- but isn't itself an implicit thing.  Yurgh.
+    -- NB: if any of the wired-in TyCons had record fields, the record
+    --     field names would be in a similar situation.  Ditto class ops.
+    --     But it happens that there aren't any
+    rep_names tc = case tyConRepName_maybe tc of
+                        Just n  -> [n]
+                        Nothing -> []
+
+-- | Check the known-key names list of consistency.
+knownKeyNamesOkay :: [Name] -> Maybe String
+knownKeyNamesOkay all_names
+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
+  = Just $ "    Out-of-range known-key uniques: ["
+        ++ intercalate ", " (map (occNameString . nameOccName) ns) ++
+         "]"
+  | null badNamesPairs
+  = Nothing
+  | otherwise
+  = Just badNamesStr
+  where
+    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)
+                           emptyUFM all_names
+    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
+    badNamesPairs = nonDetUFMToList badNamesEnv
+      -- It's OK to use nonDetUFMToList here because the ordering only affects
+      -- the message when we get a panic
+    badNamesStrs  = map pairToStr badNamesPairs
+    badNamesStr   = unlines badNamesStrs
+
+    pairToStr (uniq, ns) = "        " ++
+                           show uniq ++
+                           ": [" ++
+                           intercalate ", " (map (occNameString . nameOccName) ns) ++
+                           "]"
+
+-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
+-- known-key thing.
+lookupKnownKeyName :: Unique -> Maybe Name
+lookupKnownKeyName u =
+    knownUniqueName u <|> lookupUFM knownKeysMap u
+
+-- | Is a 'Name' known-key?
+isKnownKeyName :: Name -> Bool
+isKnownKeyName n =
+    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
+
+knownKeysMap :: UniqFM Name
+knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]
+
+-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
+-- GHCi's ':info' command.
+lookupKnownNameInfo :: Name -> SDoc
+lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of
+    -- If we do find a doc, we add comment delimeters to make the output
+    -- of ':info' valid Haskell.
+    Nothing  -> empty
+    Just doc -> vcat [text "{-", doc, text "-}"]
+
+-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390)
+knownNamesInfo :: NameEnv SDoc
+knownNamesInfo = unitNameEnv coercibleTyConName $
+    vcat [ text "Coercible is a special constraint with custom solving rules."
+         , text "It is not a class."
+         , text "Please see section 9.14.4 of the user's guide for details." ]
+
+{-
+We let a lot of "non-standard" values be visible, so that we can make
+sense of them in interface pragmas. It's cool, though they all have
+"non-standard" names, so they won't get past the parser in user code.
+
+************************************************************************
+*                                                                      *
+                PrimOpIds
+*                                                                      *
+************************************************************************
+-}
+
+primOpIds :: Array Int Id
+-- A cache of the PrimOp Ids, indexed by PrimOp tag
+primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)
+                                   | op <- allThePrimOps ]
+
+primOpId :: PrimOp -> Id
+primOpId op = primOpIds ! primOpTag op
+
+{-
+************************************************************************
+*                                                                      *
+            Export lists for pseudo-modules (GHC.Prim)
+*                                                                      *
+************************************************************************
+
+GHC.Prim "exports" all the primops and primitive types, some
+wired-in Ids.
+-}
+
+ghcPrimExports :: [IfaceExport]
+ghcPrimExports
+ = map (avail . idName) ghcPrimIds ++
+   map (avail . idName . primOpId) allThePrimOps ++
+   [ AvailTC n [n] []
+   | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc  ]
+
+{-
+************************************************************************
+*                                                                      *
+            Built-in keys
+*                                                                      *
+************************************************************************
+
+ToDo: make it do the ``like'' part properly (as in 0.26 and before).
+-}
+
+maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
+maybeCharLikeCon con = con `hasKey` charDataConKey
+maybeIntLikeCon  con = con `hasKey` intDataConKey
+
+{-
+************************************************************************
+*                                                                      *
+            Class predicates
+*                                                                      *
+************************************************************************
+-}
+
+isNumericClass, isStandardClass :: Class -> Bool
+
+isNumericClass     clas = classKey clas `is_elem` numericClassKeys
+isStandardClass    clas = classKey clas `is_elem` standardClassKeys
+
+is_elem :: Eq a => a -> [a] -> Bool
+is_elem = isIn "is_X_Class"
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
new file mode 100644
--- /dev/null
+++ b/compiler/prelude/THNames.hs
@@ -0,0 +1,1105 @@
+-- %************************************************************************
+-- %*                                                                   *
+--              The known-key names for Template Haskell
+-- %*                                                                   *
+-- %************************************************************************
+
+module THNames where
+
+import GhcPrelude ()
+
+import PrelNames( mk_known_key_name )
+import Module( Module, mkModuleNameFS, mkModule, thUnitId )
+import Name( Name )
+import OccName( tcName, clsName, dataName, varName )
+import RdrName( RdrName, nameRdrName )
+import Unique
+import FastString
+
+-- To add a name, do three things
+--
+--  1) Allocate a key
+--  2) Make a "Name"
+--  3) Add the name to templateHaskellNames
+
+templateHaskellNames :: [Name]
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+
+templateHaskellNames = [
+    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
+    mkNameSName,
+    liftStringName,
+    unTypeName,
+    unTypeQName,
+    unsafeTExpCoerceName,
+
+    -- Lit
+    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
+    charPrimLName,
+    -- Pat
+    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
+    conPName, tildePName, bangPName, infixPName,
+    asPName, wildPName, recPName, listPName, sigPName, viewPName,
+    -- FieldPat
+    fieldPatName,
+    -- Match
+    matchName,
+    -- Clause
+    clauseName,
+    -- Exp
+    varEName, conEName, litEName, appEName, appTypeEName, infixEName,
+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
+    tupEName, unboxedTupEName, unboxedSumEName,
+    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
+    fromEName, fromThenEName, fromToEName, fromThenToEName,
+    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
+    labelEName, implicitParamVarEName,
+    -- FieldExp
+    fieldExpName,
+    -- Body
+    guardedBName, normalBName,
+    -- Guard
+    normalGEName, patGEName,
+    -- Stmt
+    bindSName, letSName, noBindSName, parSName, recSName,
+    -- Dec
+    funDName, valDName, dataDName, newtypeDName, tySynDName,
+    classDName, instanceWithOverlapDName,
+    standaloneDerivWithStrategyDName, sigDName, forImpDName,
+    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,
+    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
+    dataInstDName, newtypeInstDName, tySynInstDName,
+    infixLDName, infixRDName, infixNDName,
+    roleAnnotDName, patSynDName, patSynSigDName,
+    implicitParamBindDName,
+    -- Cxt
+    cxtName,
+
+    -- SourceUnpackedness
+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
+    -- SourceStrictness
+    noSourceStrictnessName, sourceLazyName, sourceStrictName,
+    -- Con
+    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
+    -- Bang
+    bangName,
+    -- BangType
+    bangTypeName,
+    -- VarBangType
+    varBangTypeName,
+    -- PatSynDir (for pattern synonyms)
+    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,
+    -- PatSynArgs (for pattern synonyms)
+    prefixPatSynName, infixPatSynName, recordPatSynName,
+    -- Type
+    forallTName, forallVisTName, varTName, conTName, infixTName, appTName,
+    appKindTName, equalityTName, tupleTName, unboxedTupleTName,
+    unboxedSumTName, arrowTName, listTName, sigTName, litTName,
+    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
+    wildCardTName, implicitParamTName,
+    -- TyLit
+    numTyLitName, strTyLitName,
+    -- TyVarBndr
+    plainTVName, kindedTVName,
+    -- Role
+    nominalRName, representationalRName, phantomRName, inferRName,
+    -- Kind
+    varKName, conKName, tupleKName, arrowKName, listKName, appKName,
+    starKName, constraintKName,
+    -- FamilyResultSig
+    noSigName, kindSigName, tyVarSigName,
+    -- InjectivityAnn
+    injectivityAnnName,
+    -- Callconv
+    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,
+    -- Safety
+    unsafeName,
+    safeName,
+    interruptibleName,
+    -- Inline
+    noInlineDataConName, inlineDataConName, inlinableDataConName,
+    -- RuleMatch
+    conLikeDataConName, funLikeDataConName,
+    -- Phases
+    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
+    -- Overlap
+    overlappableDataConName, overlappingDataConName, overlapsDataConName,
+    incoherentDataConName,
+    -- DerivStrategy
+    stockStrategyName, anyclassStrategyName,
+    newtypeStrategyName, viaStrategyName,
+    -- TExp
+    tExpDataConName,
+    -- RuleBndr
+    ruleVarName, typedRuleVarName,
+    -- FunDep
+    funDepName,
+    -- TySynEqn
+    tySynEqnName,
+    -- AnnTarget
+    valueAnnotationName, typeAnnotationName, moduleAnnotationName,
+    -- DerivClause
+    derivClauseName,
+
+    -- The type classes
+    liftClassName,
+
+    -- And the tycons
+    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
+    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
+    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+    typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
+    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
+    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
+    roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
+    overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
+
+    -- Quasiquoting
+    quoteDecName, quoteTypeName, quoteExpName, quotePatName]
+
+thSyn, thLib, qqLib :: Module
+thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
+qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
+
+mkTHModule :: FastString -> Module
+mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
+
+libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
+libFun = mk_known_key_name OccName.varName  thLib
+libTc  = mk_known_key_name OccName.tcName   thLib
+thFun  = mk_known_key_name OccName.varName  thSyn
+thTc   = mk_known_key_name OccName.tcName   thSyn
+thCls  = mk_known_key_name OccName.clsName  thSyn
+thCon  = mk_known_key_name OccName.dataName thSyn
+qqFun  = mk_known_key_name OccName.varName  qqLib
+
+-------------------- TH.Syntax -----------------------
+liftClassName :: Name
+liftClassName = thCls (fsLit "Lift") liftClassKey
+
+qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
+    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
+    tExpTyConName, injAnnTyConName, overlapTyConName :: Name
+qTyConName             = thTc (fsLit "Q")              qTyConKey
+nameTyConName          = thTc (fsLit "Name")           nameTyConKey
+fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey
+patTyConName           = thTc (fsLit "Pat")            patTyConKey
+fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey
+expTyConName           = thTc (fsLit "Exp")            expTyConKey
+decTyConName           = thTc (fsLit "Dec")            decTyConKey
+typeTyConName          = thTc (fsLit "Type")           typeTyConKey
+matchTyConName         = thTc (fsLit "Match")          matchTyConKey
+clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey
+funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey
+predTyConName          = thTc (fsLit "Pred")           predTyConKey
+tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey
+injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey
+overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
+
+returnQName, bindQName, sequenceQName, newNameName, liftName,
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
+    unsafeTExpCoerceName, liftTypedName :: Name
+returnQName    = thFun (fsLit "returnQ")   returnQIdKey
+bindQName      = thFun (fsLit "bindQ")     bindQIdKey
+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
+newNameName    = thFun (fsLit "newName")   newNameIdKey
+liftName       = thFun (fsLit "lift")      liftIdKey
+liftStringName = thFun (fsLit "liftString")  liftStringIdKey
+mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
+mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
+mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
+mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
+unTypeName     = thFun (fsLit "unType")     unTypeIdKey
+unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey
+unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
+liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
+
+
+-------------------- TH.Lib -----------------------
+-- data Lit = ...
+charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
+    charPrimLName :: Name
+charLName       = libFun (fsLit "charL")       charLIdKey
+stringLName     = libFun (fsLit "stringL")     stringLIdKey
+integerLName    = libFun (fsLit "integerL")    integerLIdKey
+intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey
+wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey
+floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey
+doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
+rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
+stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
+charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey
+
+-- data Pat = ...
+litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
+    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
+    sigPName, viewPName :: Name
+litPName   = libFun (fsLit "litP")   litPIdKey
+varPName   = libFun (fsLit "varP")   varPIdKey
+tupPName   = libFun (fsLit "tupP")   tupPIdKey
+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
+unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey
+conPName   = libFun (fsLit "conP")   conPIdKey
+infixPName = libFun (fsLit "infixP") infixPIdKey
+tildePName = libFun (fsLit "tildeP") tildePIdKey
+bangPName  = libFun (fsLit "bangP")  bangPIdKey
+asPName    = libFun (fsLit "asP")    asPIdKey
+wildPName  = libFun (fsLit "wildP")  wildPIdKey
+recPName   = libFun (fsLit "recP")   recPIdKey
+listPName  = libFun (fsLit "listP")  listPIdKey
+sigPName   = libFun (fsLit "sigP")   sigPIdKey
+viewPName  = libFun (fsLit "viewP")  viewPIdKey
+
+-- type FieldPat = ...
+fieldPatName :: Name
+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
+
+-- data Match = ...
+matchName :: Name
+matchName = libFun (fsLit "match") matchIdKey
+
+-- data Clause = ...
+clauseName :: Name
+clauseName = libFun (fsLit "clause") clauseIdKey
+
+-- data Exp = ...
+varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
+    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
+    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
+    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
+    labelEName, implicitParamVarEName :: Name
+varEName              = libFun (fsLit "varE")              varEIdKey
+conEName              = libFun (fsLit "conE")              conEIdKey
+litEName              = libFun (fsLit "litE")              litEIdKey
+appEName              = libFun (fsLit "appE")              appEIdKey
+appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey
+infixEName            = libFun (fsLit "infixE")            infixEIdKey
+infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey
+sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey
+sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey
+lamEName              = libFun (fsLit "lamE")              lamEIdKey
+lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey
+tupEName              = libFun (fsLit "tupE")              tupEIdKey
+unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey
+unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey
+condEName             = libFun (fsLit "condE")             condEIdKey
+multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey
+letEName              = libFun (fsLit "letE")              letEIdKey
+caseEName             = libFun (fsLit "caseE")             caseEIdKey
+doEName               = libFun (fsLit "doE")               doEIdKey
+mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey
+compEName             = libFun (fsLit "compE")             compEIdKey
+-- ArithSeq skips a level
+fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
+fromEName             = libFun (fsLit "fromE")             fromEIdKey
+fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey
+fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey
+fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey
+-- end ArithSeq
+listEName, sigEName, recConEName, recUpdEName :: Name
+listEName             = libFun (fsLit "listE")             listEIdKey
+sigEName              = libFun (fsLit "sigE")              sigEIdKey
+recConEName           = libFun (fsLit "recConE")           recConEIdKey
+recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey
+staticEName           = libFun (fsLit "staticE")           staticEIdKey
+unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey
+labelEName            = libFun (fsLit "labelE")            labelEIdKey
+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
+
+-- type FieldExp = ...
+fieldExpName :: Name
+fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
+
+-- data Body = ...
+guardedBName, normalBName :: Name
+guardedBName = libFun (fsLit "guardedB") guardedBIdKey
+normalBName  = libFun (fsLit "normalB")  normalBIdKey
+
+-- data Guard = ...
+normalGEName, patGEName :: Name
+normalGEName = libFun (fsLit "normalGE") normalGEIdKey
+patGEName    = libFun (fsLit "patGE")    patGEIdKey
+
+-- data Stmt = ...
+bindSName, letSName, noBindSName, parSName, recSName :: Name
+bindSName   = libFun (fsLit "bindS")   bindSIdKey
+letSName    = libFun (fsLit "letS")    letSIdKey
+noBindSName = libFun (fsLit "noBindS") noBindSIdKey
+parSName    = libFun (fsLit "parS")    parSIdKey
+recSName    = libFun (fsLit "recS")    recSIdKey
+
+-- data Dec = ...
+funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
+    instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
+    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
+    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
+    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
+    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
+    pragCompleteDName, implicitParamBindDName :: Name
+funDName                         = libFun (fsLit "funD")                         funDIdKey
+valDName                         = libFun (fsLit "valD")                         valDIdKey
+dataDName                        = libFun (fsLit "dataD")                        dataDIdKey
+newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey
+tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey
+classDName                       = libFun (fsLit "classD")                       classDIdKey
+instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey
+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+sigDName                         = libFun (fsLit "sigD")                         sigDIdKey
+defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey
+forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey
+pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey
+pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey
+pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey
+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey
+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey
+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey
+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey
+dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey
+newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey
+tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey
+openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey
+closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey
+dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey
+infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey
+infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey
+infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey
+roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey
+patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey
+patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey
+implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey
+
+-- type Ctxt = ...
+cxtName :: Name
+cxtName = libFun (fsLit "cxt") cxtIdKey
+
+-- data SourceUnpackedness = ...
+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name
+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey
+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey
+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey
+
+-- data SourceStrictness = ...
+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name
+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey
+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey
+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey
+
+-- data Con = ...
+normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
+normalCName  = libFun (fsLit "normalC" ) normalCIdKey
+recCName     = libFun (fsLit "recC"    ) recCIdKey
+infixCName   = libFun (fsLit "infixC"  ) infixCIdKey
+forallCName  = libFun (fsLit "forallC" ) forallCIdKey
+gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey
+recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
+
+-- data Bang = ...
+bangName :: Name
+bangName = libFun (fsLit "bang") bangIdKey
+
+-- type BangType = ...
+bangTypeName :: Name
+bangTypeName = libFun (fsLit "bangType") bangTKey
+
+-- type VarBangType = ...
+varBangTypeName :: Name
+varBangTypeName = libFun (fsLit "varBangType") varBangTKey
+
+-- data PatSynDir = ...
+unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name
+unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey
+implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey
+explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey
+
+-- data PatSynArgs = ...
+prefixPatSynName, infixPatSynName, recordPatSynName :: Name
+prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey
+infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey
+recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
+
+-- data Type = ...
+forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,
+    unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName,
+    appKindTName, sigTName, equalityTName, litTName, promotedTName,
+    promotedTupleTName, promotedNilTName, promotedConsTName,
+    wildCardTName, implicitParamTName :: Name
+forallTName         = libFun (fsLit "forallT")        forallTIdKey
+forallVisTName      = libFun (fsLit "forallVisT")     forallVisTIdKey
+varTName            = libFun (fsLit "varT")           varTIdKey
+conTName            = libFun (fsLit "conT")           conTIdKey
+tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey
+unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey
+unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey
+arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
+listTName           = libFun (fsLit "listT")          listTIdKey
+appTName            = libFun (fsLit "appT")           appTIdKey
+appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey
+sigTName            = libFun (fsLit "sigT")           sigTIdKey
+equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
+litTName            = libFun (fsLit "litT")           litTIdKey
+promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey
+promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
+promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey
+promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey
+wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey
+infixTName          = libFun (fsLit "infixT")         infixTIdKey
+implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey
+
+-- data TyLit = ...
+numTyLitName, strTyLitName :: Name
+numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
+strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
+
+-- data TyVarBndr = ...
+plainTVName, kindedTVName :: Name
+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+
+-- data Role = ...
+nominalRName, representationalRName, phantomRName, inferRName :: Name
+nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey
+representationalRName = libFun (fsLit "representationalR") representationalRIdKey
+phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey
+inferRName            = libFun (fsLit "inferR")            inferRIdKey
+
+-- data Kind = ...
+varKName, conKName, tupleKName, arrowKName, listKName, appKName,
+  starKName, constraintKName :: Name
+varKName        = libFun (fsLit "varK")         varKIdKey
+conKName        = libFun (fsLit "conK")         conKIdKey
+tupleKName      = libFun (fsLit "tupleK")       tupleKIdKey
+arrowKName      = libFun (fsLit "arrowK")       arrowKIdKey
+listKName       = libFun (fsLit "listK")        listKIdKey
+appKName        = libFun (fsLit "appK")         appKIdKey
+starKName       = libFun (fsLit "starK")        starKIdKey
+constraintKName = libFun (fsLit "constraintK")  constraintKIdKey
+
+-- data FamilyResultSig = ...
+noSigName, kindSigName, tyVarSigName :: Name
+noSigName    = libFun (fsLit "noSig")    noSigIdKey
+kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey
+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
+
+-- data InjectivityAnn = ...
+injectivityAnnName :: Name
+injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey
+
+-- data Callconv = ...
+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name
+cCallName = libFun (fsLit "cCall") cCallIdKey
+stdCallName = libFun (fsLit "stdCall") stdCallIdKey
+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey
+primCallName = libFun (fsLit "prim") primCallIdKey
+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey
+
+-- data Safety = ...
+unsafeName, safeName, interruptibleName :: Name
+unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
+safeName       = libFun (fsLit "safe") safeIdKey
+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
+
+-- newtype TExp a = ...
+tExpDataConName :: Name
+tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
+
+-- data RuleBndr = ...
+ruleVarName, typedRuleVarName :: Name
+ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey
+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
+
+-- data FunDep = ...
+funDepName :: Name
+funDepName     = libFun (fsLit "funDep") funDepIdKey
+
+-- data TySynEqn = ...
+tySynEqnName :: Name
+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
+
+-- data AnnTarget = ...
+valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name
+valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey
+typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey
+moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
+
+-- type DerivClause = ...
+derivClauseName :: Name
+derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey
+
+-- data DerivStrategy = ...
+stockStrategyName, anyclassStrategyName, newtypeStrategyName,
+  viaStrategyName :: Name
+stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey
+anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
+newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey
+viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey
+
+matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
+    decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
+    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
+    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
+    derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
+    derivStrategyQTyConName :: Name
+matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
+clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
+expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
+stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey
+decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey
+decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
+conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey
+bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey
+varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey
+typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
+fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
+patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
+fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
+predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
+ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
+tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey
+roleTyConName           = libTc (fsLit "Role")           roleTyConKey
+derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey
+kindQTyConName          = libTc (fsLit "KindQ")          kindQTyConKey
+tyVarBndrQTyConName     = libTc (fsLit "TyVarBndrQ")     tyVarBndrQTyConKey
+derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
+
+-- quasiquoting
+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
+quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey
+quotePatName        = qqFun (fsLit "quotePat")  quotePatKey
+quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
+quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey
+
+-- data Inline = ...
+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
+noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey
+inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey
+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
+
+-- data RuleMatch = ...
+conLikeDataConName, funLikeDataConName :: Name
+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
+
+-- data Phases = ...
+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey
+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey
+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
+
+-- data Overlap = ...
+overlappableDataConName,
+  overlappingDataConName,
+  overlapsDataConName,
+  incoherentDataConName :: Name
+overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey
+overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey
+overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey
+incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey
+
+{- *********************************************************************
+*                                                                      *
+                     Class keys
+*                                                                      *
+********************************************************************* -}
+
+-- ClassUniques available: 200-299
+-- Check in PrelNames if you want to change this
+
+liftClassKey :: Unique
+liftClassKey = mkPreludeClassUnique 200
+
+{- *********************************************************************
+*                                                                      *
+                     TyCon keys
+*                                                                      *
+********************************************************************* -}
+
+-- TyConUniques available: 200-299
+-- Check in PrelNames if you want to change this
+
+expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
+    decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
+    tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
+    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
+    overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
+expTyConKey             = mkPreludeTyConUnique 200
+matchTyConKey           = mkPreludeTyConUnique 201
+clauseTyConKey          = mkPreludeTyConUnique 202
+qTyConKey               = mkPreludeTyConUnique 203
+expQTyConKey            = mkPreludeTyConUnique 204
+decQTyConKey            = mkPreludeTyConUnique 205
+patTyConKey             = mkPreludeTyConUnique 206
+matchQTyConKey          = mkPreludeTyConUnique 207
+clauseQTyConKey         = mkPreludeTyConUnique 208
+stmtQTyConKey           = mkPreludeTyConUnique 209
+conQTyConKey            = mkPreludeTyConUnique 210
+typeQTyConKey           = mkPreludeTyConUnique 211
+typeTyConKey            = mkPreludeTyConUnique 212
+decTyConKey             = mkPreludeTyConUnique 213
+bangTypeQTyConKey       = mkPreludeTyConUnique 214
+varBangTypeQTyConKey    = mkPreludeTyConUnique 215
+fieldExpTyConKey        = mkPreludeTyConUnique 216
+fieldPatTyConKey        = mkPreludeTyConUnique 217
+nameTyConKey            = mkPreludeTyConUnique 218
+patQTyConKey            = mkPreludeTyConUnique 219
+fieldPatQTyConKey       = mkPreludeTyConUnique 220
+fieldExpQTyConKey       = mkPreludeTyConUnique 221
+funDepTyConKey          = mkPreludeTyConUnique 222
+predTyConKey            = mkPreludeTyConUnique 223
+predQTyConKey           = mkPreludeTyConUnique 224
+tyVarBndrQTyConKey      = mkPreludeTyConUnique 225
+decsQTyConKey           = mkPreludeTyConUnique 226
+ruleBndrQTyConKey       = mkPreludeTyConUnique 227
+tySynEqnQTyConKey       = mkPreludeTyConUnique 228
+roleTyConKey            = mkPreludeTyConUnique 229
+tExpTyConKey            = mkPreludeTyConUnique 230
+injAnnTyConKey          = mkPreludeTyConUnique 231
+kindQTyConKey           = mkPreludeTyConUnique 232
+overlapTyConKey         = mkPreludeTyConUnique 233
+derivClauseQTyConKey    = mkPreludeTyConUnique 234
+derivStrategyQTyConKey  = mkPreludeTyConUnique 235
+
+{- *********************************************************************
+*                                                                      *
+                     DataCon keys
+*                                                                      *
+********************************************************************* -}
+
+-- DataConUniques available: 100-150
+-- If you want to change this, make sure you check in PrelNames
+
+-- data Inline = ...
+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
+noInlineDataConKey  = mkPreludeDataConUnique 200
+inlineDataConKey    = mkPreludeDataConUnique 201
+inlinableDataConKey = mkPreludeDataConUnique 202
+
+-- data RuleMatch = ...
+conLikeDataConKey, funLikeDataConKey :: Unique
+conLikeDataConKey = mkPreludeDataConUnique 203
+funLikeDataConKey = mkPreludeDataConUnique 204
+
+-- data Phases = ...
+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
+allPhasesDataConKey   = mkPreludeDataConUnique 205
+fromPhaseDataConKey   = mkPreludeDataConUnique 206
+beforePhaseDataConKey = mkPreludeDataConUnique 207
+
+-- newtype TExp a = ...
+tExpDataConKey :: Unique
+tExpDataConKey = mkPreludeDataConUnique 208
+
+-- data Overlap = ..
+overlappableDataConKey,
+  overlappingDataConKey,
+  overlapsDataConKey,
+  incoherentDataConKey :: Unique
+overlappableDataConKey = mkPreludeDataConUnique 209
+overlappingDataConKey  = mkPreludeDataConUnique 210
+overlapsDataConKey     = mkPreludeDataConUnique 211
+incoherentDataConKey   = mkPreludeDataConUnique 212
+
+{- *********************************************************************
+*                                                                      *
+                     Id keys
+*                                                                      *
+********************************************************************* -}
+
+-- IdUniques available: 200-499
+-- If you want to change this, make sure you check in PrelNames
+
+returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
+    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
+    unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique
+returnQIdKey        = mkPreludeMiscIdUnique 200
+bindQIdKey          = mkPreludeMiscIdUnique 201
+sequenceQIdKey      = mkPreludeMiscIdUnique 202
+liftIdKey           = mkPreludeMiscIdUnique 203
+newNameIdKey         = mkPreludeMiscIdUnique 204
+mkNameIdKey          = mkPreludeMiscIdUnique 205
+mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
+mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
+mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
+mkNameLIdKey         = mkPreludeMiscIdUnique 209
+mkNameSIdKey         = mkPreludeMiscIdUnique 210
+unTypeIdKey          = mkPreludeMiscIdUnique 211
+unTypeQIdKey         = mkPreludeMiscIdUnique 212
+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
+liftTypedIdKey        = mkPreludeMiscIdUnique 214
+
+
+-- data Lit = ...
+charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
+    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,
+    charPrimLIdKey:: Unique
+charLIdKey        = mkPreludeMiscIdUnique 220
+stringLIdKey      = mkPreludeMiscIdUnique 221
+integerLIdKey     = mkPreludeMiscIdUnique 222
+intPrimLIdKey     = mkPreludeMiscIdUnique 223
+wordPrimLIdKey    = mkPreludeMiscIdUnique 224
+floatPrimLIdKey   = mkPreludeMiscIdUnique 225
+doublePrimLIdKey  = mkPreludeMiscIdUnique 226
+rationalLIdKey    = mkPreludeMiscIdUnique 227
+stringPrimLIdKey  = mkPreludeMiscIdUnique 228
+charPrimLIdKey    = mkPreludeMiscIdUnique 229
+
+liftStringIdKey :: Unique
+liftStringIdKey     = mkPreludeMiscIdUnique 230
+
+-- data Pat = ...
+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
+  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
+  listPIdKey, sigPIdKey, viewPIdKey :: Unique
+litPIdKey         = mkPreludeMiscIdUnique 240
+varPIdKey         = mkPreludeMiscIdUnique 241
+tupPIdKey         = mkPreludeMiscIdUnique 242
+unboxedTupPIdKey  = mkPreludeMiscIdUnique 243
+unboxedSumPIdKey  = mkPreludeMiscIdUnique 244
+conPIdKey         = mkPreludeMiscIdUnique 245
+infixPIdKey       = mkPreludeMiscIdUnique 246
+tildePIdKey       = mkPreludeMiscIdUnique 247
+bangPIdKey        = mkPreludeMiscIdUnique 248
+asPIdKey          = mkPreludeMiscIdUnique 249
+wildPIdKey        = mkPreludeMiscIdUnique 250
+recPIdKey         = mkPreludeMiscIdUnique 251
+listPIdKey        = mkPreludeMiscIdUnique 252
+sigPIdKey         = mkPreludeMiscIdUnique 253
+viewPIdKey        = mkPreludeMiscIdUnique 254
+
+-- type FieldPat = ...
+fieldPatIdKey :: Unique
+fieldPatIdKey       = mkPreludeMiscIdUnique 260
+
+-- data Match = ...
+matchIdKey :: Unique
+matchIdKey          = mkPreludeMiscIdUnique 261
+
+-- data Clause = ...
+clauseIdKey :: Unique
+clauseIdKey         = mkPreludeMiscIdUnique 262
+
+
+-- data Exp = ...
+varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
+    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,
+    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
+    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
+    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique
+varEIdKey              = mkPreludeMiscIdUnique 270
+conEIdKey              = mkPreludeMiscIdUnique 271
+litEIdKey              = mkPreludeMiscIdUnique 272
+appEIdKey              = mkPreludeMiscIdUnique 273
+appTypeEIdKey          = mkPreludeMiscIdUnique 274
+infixEIdKey            = mkPreludeMiscIdUnique 275
+infixAppIdKey          = mkPreludeMiscIdUnique 276
+sectionLIdKey          = mkPreludeMiscIdUnique 277
+sectionRIdKey          = mkPreludeMiscIdUnique 278
+lamEIdKey              = mkPreludeMiscIdUnique 279
+lamCaseEIdKey          = mkPreludeMiscIdUnique 280
+tupEIdKey              = mkPreludeMiscIdUnique 281
+unboxedTupEIdKey       = mkPreludeMiscIdUnique 282
+unboxedSumEIdKey       = mkPreludeMiscIdUnique 283
+condEIdKey             = mkPreludeMiscIdUnique 284
+multiIfEIdKey          = mkPreludeMiscIdUnique 285
+letEIdKey              = mkPreludeMiscIdUnique 286
+caseEIdKey             = mkPreludeMiscIdUnique 287
+doEIdKey               = mkPreludeMiscIdUnique 288
+compEIdKey             = mkPreludeMiscIdUnique 289
+fromEIdKey             = mkPreludeMiscIdUnique 290
+fromThenEIdKey         = mkPreludeMiscIdUnique 291
+fromToEIdKey           = mkPreludeMiscIdUnique 292
+fromThenToEIdKey       = mkPreludeMiscIdUnique 293
+listEIdKey             = mkPreludeMiscIdUnique 294
+sigEIdKey              = mkPreludeMiscIdUnique 295
+recConEIdKey           = mkPreludeMiscIdUnique 296
+recUpdEIdKey           = mkPreludeMiscIdUnique 297
+staticEIdKey           = mkPreludeMiscIdUnique 298
+unboundVarEIdKey       = mkPreludeMiscIdUnique 299
+labelEIdKey            = mkPreludeMiscIdUnique 300
+implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
+mdoEIdKey              = mkPreludeMiscIdUnique 302
+
+-- type FieldExp = ...
+fieldExpIdKey :: Unique
+fieldExpIdKey       = mkPreludeMiscIdUnique 305
+
+-- data Body = ...
+guardedBIdKey, normalBIdKey :: Unique
+guardedBIdKey     = mkPreludeMiscIdUnique 306
+normalBIdKey      = mkPreludeMiscIdUnique 307
+
+-- data Guard = ...
+normalGEIdKey, patGEIdKey :: Unique
+normalGEIdKey     = mkPreludeMiscIdUnique 308
+patGEIdKey        = mkPreludeMiscIdUnique 309
+
+-- data Stmt = ...
+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
+bindSIdKey       = mkPreludeMiscIdUnique 310
+letSIdKey        = mkPreludeMiscIdUnique 311
+noBindSIdKey     = mkPreludeMiscIdUnique 312
+parSIdKey        = mkPreludeMiscIdUnique 313
+recSIdKey        = mkPreludeMiscIdUnique 314
+
+-- data Dec = ...
+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
+    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
+    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
+    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
+    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
+    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
+funDIdKey                         = mkPreludeMiscIdUnique 320
+valDIdKey                         = mkPreludeMiscIdUnique 321
+dataDIdKey                        = mkPreludeMiscIdUnique 322
+newtypeDIdKey                     = mkPreludeMiscIdUnique 323
+tySynDIdKey                       = mkPreludeMiscIdUnique 324
+classDIdKey                       = mkPreludeMiscIdUnique 325
+instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326
+instanceDIdKey                    = mkPreludeMiscIdUnique 327
+sigDIdKey                         = mkPreludeMiscIdUnique 328
+forImpDIdKey                      = mkPreludeMiscIdUnique 329
+pragInlDIdKey                     = mkPreludeMiscIdUnique 330
+pragSpecDIdKey                    = mkPreludeMiscIdUnique 331
+pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332
+pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333
+pragRuleDIdKey                    = mkPreludeMiscIdUnique 334
+pragAnnDIdKey                     = mkPreludeMiscIdUnique 335
+dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336
+openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337
+dataInstDIdKey                    = mkPreludeMiscIdUnique 338
+newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339
+tySynInstDIdKey                   = mkPreludeMiscIdUnique 340
+closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341
+infixLDIdKey                      = mkPreludeMiscIdUnique 342
+infixRDIdKey                      = mkPreludeMiscIdUnique 343
+infixNDIdKey                      = mkPreludeMiscIdUnique 344
+roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345
+standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
+defaultSigDIdKey                  = mkPreludeMiscIdUnique 347
+patSynDIdKey                      = mkPreludeMiscIdUnique 348
+patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
+pragCompleteDIdKey                = mkPreludeMiscIdUnique 350
+implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351
+
+-- type Cxt = ...
+cxtIdKey :: Unique
+cxtIdKey               = mkPreludeMiscIdUnique 361
+
+-- data SourceUnpackedness = ...
+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 363
+sourceUnpackKey         = mkPreludeMiscIdUnique 364
+
+-- data SourceStrictness = ...
+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 365
+sourceLazyKey           = mkPreludeMiscIdUnique 366
+sourceStrictKey         = mkPreludeMiscIdUnique 367
+
+-- data Con = ...
+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
+  recGadtCIdKey :: Unique
+normalCIdKey      = mkPreludeMiscIdUnique 368
+recCIdKey         = mkPreludeMiscIdUnique 369
+infixCIdKey       = mkPreludeMiscIdUnique 370
+forallCIdKey      = mkPreludeMiscIdUnique 371
+gadtCIdKey        = mkPreludeMiscIdUnique 372
+recGadtCIdKey     = mkPreludeMiscIdUnique 373
+
+-- data Bang = ...
+bangIdKey :: Unique
+bangIdKey         = mkPreludeMiscIdUnique 374
+
+-- type BangType = ...
+bangTKey :: Unique
+bangTKey          = mkPreludeMiscIdUnique 375
+
+-- type VarBangType = ...
+varBangTKey :: Unique
+varBangTKey       = mkPreludeMiscIdUnique 376
+
+-- data PatSynDir = ...
+unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
+unidirPatSynIdKey    = mkPreludeMiscIdUnique 377
+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378
+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379
+
+-- data PatSynArgs = ...
+prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
+prefixPatSynIdKey = mkPreludeMiscIdUnique 380
+infixPatSynIdKey  = mkPreludeMiscIdUnique 381
+recordPatSynIdKey = mkPreludeMiscIdUnique 382
+
+-- data Type = ...
+forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,
+    unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,
+    appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
+    promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
+    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique
+forallTIdKey        = mkPreludeMiscIdUnique 390
+forallVisTIdKey     = mkPreludeMiscIdUnique 391
+varTIdKey           = mkPreludeMiscIdUnique 392
+conTIdKey           = mkPreludeMiscIdUnique 393
+tupleTIdKey         = mkPreludeMiscIdUnique 394
+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395
+unboxedSumTIdKey    = mkPreludeMiscIdUnique 396
+arrowTIdKey         = mkPreludeMiscIdUnique 397
+listTIdKey          = mkPreludeMiscIdUnique 398
+appTIdKey           = mkPreludeMiscIdUnique 399
+appKindTIdKey       = mkPreludeMiscIdUnique 400
+sigTIdKey           = mkPreludeMiscIdUnique 401
+equalityTIdKey      = mkPreludeMiscIdUnique 402
+litTIdKey           = mkPreludeMiscIdUnique 403
+promotedTIdKey      = mkPreludeMiscIdUnique 404
+promotedTupleTIdKey = mkPreludeMiscIdUnique 405
+promotedNilTIdKey   = mkPreludeMiscIdUnique 406
+promotedConsTIdKey  = mkPreludeMiscIdUnique 407
+wildCardTIdKey      = mkPreludeMiscIdUnique 408
+implicitParamTIdKey = mkPreludeMiscIdUnique 409
+infixTIdKey         = mkPreludeMiscIdUnique 410
+
+-- data TyLit = ...
+numTyLitIdKey, strTyLitIdKey :: Unique
+numTyLitIdKey = mkPreludeMiscIdUnique 411
+strTyLitIdKey = mkPreludeMiscIdUnique 412
+
+-- data TyVarBndr = ...
+plainTVIdKey, kindedTVIdKey :: Unique
+plainTVIdKey       = mkPreludeMiscIdUnique 413
+kindedTVIdKey      = mkPreludeMiscIdUnique 414
+
+-- data Role = ...
+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
+nominalRIdKey          = mkPreludeMiscIdUnique 415
+representationalRIdKey = mkPreludeMiscIdUnique 416
+phantomRIdKey          = mkPreludeMiscIdUnique 417
+inferRIdKey            = mkPreludeMiscIdUnique 418
+
+-- data Kind = ...
+varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
+  starKIdKey, constraintKIdKey :: Unique
+varKIdKey         = mkPreludeMiscIdUnique 419
+conKIdKey         = mkPreludeMiscIdUnique 420
+tupleKIdKey       = mkPreludeMiscIdUnique 421
+arrowKIdKey       = mkPreludeMiscIdUnique 422
+listKIdKey        = mkPreludeMiscIdUnique 423
+appKIdKey         = mkPreludeMiscIdUnique 424
+starKIdKey        = mkPreludeMiscIdUnique 425
+constraintKIdKey  = mkPreludeMiscIdUnique 426
+
+-- data FamilyResultSig = ...
+noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
+noSigIdKey        = mkPreludeMiscIdUnique 427
+kindSigIdKey      = mkPreludeMiscIdUnique 428
+tyVarSigIdKey     = mkPreludeMiscIdUnique 429
+
+-- data InjectivityAnn = ...
+injectivityAnnIdKey :: Unique
+injectivityAnnIdKey = mkPreludeMiscIdUnique 430
+
+-- data Callconv = ...
+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
+  javaScriptCallIdKey :: Unique
+cCallIdKey          = mkPreludeMiscIdUnique 431
+stdCallIdKey        = mkPreludeMiscIdUnique 432
+cApiCallIdKey       = mkPreludeMiscIdUnique 433
+primCallIdKey       = mkPreludeMiscIdUnique 434
+javaScriptCallIdKey = mkPreludeMiscIdUnique 435
+
+-- data Safety = ...
+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
+unsafeIdKey        = mkPreludeMiscIdUnique 440
+safeIdKey          = mkPreludeMiscIdUnique 441
+interruptibleIdKey = mkPreludeMiscIdUnique 442
+
+-- data FunDep = ...
+funDepIdKey :: Unique
+funDepIdKey = mkPreludeMiscIdUnique 445
+
+-- data TySynEqn = ...
+tySynEqnIdKey :: Unique
+tySynEqnIdKey = mkPreludeMiscIdUnique 460
+
+-- quasiquoting
+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
+quoteExpKey  = mkPreludeMiscIdUnique 470
+quotePatKey  = mkPreludeMiscIdUnique 471
+quoteDecKey  = mkPreludeMiscIdUnique 472
+quoteTypeKey = mkPreludeMiscIdUnique 473
+
+-- data RuleBndr = ...
+ruleVarIdKey, typedRuleVarIdKey :: Unique
+ruleVarIdKey      = mkPreludeMiscIdUnique 480
+typedRuleVarIdKey = mkPreludeMiscIdUnique 481
+
+-- data AnnTarget = ...
+valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
+valueAnnotationIdKey  = mkPreludeMiscIdUnique 490
+typeAnnotationIdKey   = mkPreludeMiscIdUnique 491
+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
+
+-- type DerivPred = ...
+derivClauseIdKey :: Unique
+derivClauseIdKey = mkPreludeMiscIdUnique 493
+
+-- data DerivStrategy = ...
+stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,
+  viaStrategyIdKey :: Unique
+stockStrategyIdKey    = mkPreludeDataConUnique 494
+anyclassStrategyIdKey = mkPreludeDataConUnique 495
+newtypeStrategyIdKey  = mkPreludeDataConUnique 496
+viaStrategyIdKey      = mkPreludeDataConUnique 497
+
+{-
+************************************************************************
+*                                                                      *
+                        RdrNames
+*                                                                      *
+************************************************************************
+-}
+
+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
+lift_RDR     = nameRdrName liftName
+liftTyped_RDR = nameRdrName liftTypedName
+mkNameG_dRDR = nameRdrName mkNameG_dName
+mkNameG_vRDR = nameRdrName mkNameG_vName
+
+-- data Exp = ...
+conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName
+conE_RDR     = nameRdrName conEName
+litE_RDR     = nameRdrName litEName
+appE_RDR     = nameRdrName appEName
+infixApp_RDR = nameRdrName infixAppName
+
+-- data Lit = ...
+stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,
+    doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName
+stringL_RDR     = nameRdrName stringLName
+intPrimL_RDR    = nameRdrName intPrimLName
+wordPrimL_RDR   = nameRdrName wordPrimLName
+floatPrimL_RDR  = nameRdrName floatPrimLName
+doublePrimL_RDR = nameRdrName doublePrimLName
+stringPrimL_RDR = nameRdrName stringPrimLName
+charPrimL_RDR   = nameRdrName charPrimLName
diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
new file mode 100644
--- /dev/null
+++ b/compiler/profiling/ProfInit.hs
@@ -0,0 +1,64 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- Generate code to initialise cost centres
+--
+-- -----------------------------------------------------------------------------
+
+module ProfInit (profilingInitCode) where
+
+import GhcPrelude
+
+import CLabel
+import CostCentre
+import DynFlags
+import Outputable
+import Module
+
+-- -----------------------------------------------------------------------------
+-- Initialising cost centres
+
+-- We must produce declarations for the cost-centres defined in this
+-- module;
+
+profilingInitCode :: Module -> CollectedCCs -> SDoc
+profilingInitCode this_mod (local_CCs, singleton_CCSs)
+ = sdocWithDynFlags $ \dflags ->
+   if not (gopt Opt_SccProfilingOn dflags)
+   then empty
+   else vcat
+    $  map emit_cc_decl local_CCs
+    ++ map emit_ccs_decl singleton_CCSs
+    ++ [emit_cc_list local_CCs]
+    ++ [emit_ccs_list singleton_CCSs]
+    ++ [ text "static void prof_init_" <> ppr this_mod
+            <> text "(void) __attribute__((constructor));"
+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"
+       , braces (vcat
+                 [ text "registerCcList" <> parens local_cc_list_label <> semi
+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
+                 ])
+       ]
+ where
+   emit_cc_decl cc =
+       text "extern CostCentre" <+> cc_lbl <> text "[];"
+     where cc_lbl = ppr (mkCCLabel cc)
+   local_cc_list_label = text "local_cc_" <> ppr this_mod
+   emit_cc_list ccs =
+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
+
+   emit_ccs_decl ccs =
+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
+     where ccs_lbl = ppr (mkCCSLabel ccs)
+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
+   emit_ccs_list ccs =
+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnBinds.hs
@@ -0,0 +1,1333 @@
+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnBinds]{Renaming and dependency analysis of bindings}
+
+This module does renaming and dependency analysis on value bindings in
+the abstract syntax.  It does {\em not} do cycle-checks on class or
+type-synonym declarations; those cannot be done at this stage because
+they may be affected by renaming (which isn't fully worked out yet).
+-}
+
+module RnBinds (
+   -- Renaming top-level bindings
+   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,
+
+   -- Renaming local bindings
+   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+
+   -- Other bindings
+   rnMethodBinds, renameSigs,
+   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
+   makeMiniFixityEnv, MiniFixityEnv,
+   HsSigCtxt(..)
+   ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
+
+import HsSyn
+import TcRnMonad
+import RnTypes
+import RnPat
+import RnNames
+import RnEnv
+import RnFixity
+import RnUtils          ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn
+                        , checkDupRdrNames, warnUnusedLocalBinds,
+                        checkUnusedRecordWildcard
+                        , checkDupAndShadowedNames, bindLocalNamesFV )
+import DynFlags
+import Module
+import Name
+import NameEnv
+import NameSet
+import RdrName          ( RdrName, rdrNameOcc )
+import SrcLoc
+import ListSetOps       ( findDupsEq )
+import BasicTypes       ( RecFlag(..) )
+import Digraph          ( SCC(..) )
+import Bag
+import Util
+import Outputable
+import UniqSet
+import Maybes           ( orElse )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable      ( toList )
+import Data.List          ( partition, sort )
+import Data.List.NonEmpty ( NonEmpty(..) )
+
+{-
+-- ToDo: Put the annotations into the monad, so that they arrive in the proper
+-- place and can be used when complaining.
+
+The code tree received by the function @rnBinds@ contains definitions
+in where-clauses which are all apparently mutually recursive, but which may
+not really depend upon each other. For example, in the top level program
+\begin{verbatim}
+f x = y where a = x
+              y = x
+\end{verbatim}
+the definitions of @a@ and @y@ do not depend on each other at all.
+Unfortunately, the typechecker cannot always check such definitions.
+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
+definitions. In Proceedings of the International Symposium on Programming,
+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
+However, the typechecker usually can check definitions in which only the
+strongly connected components have been collected into recursive bindings.
+This is precisely what the function @rnBinds@ does.
+
+ToDo: deal with case where a single monobinds binds the same variable
+twice.
+
+The vertag tag is a unique @Int@; the tags only need to be unique
+within one @MonoBinds@, so that unique-Int plumbing is done explicitly
+(heavy monad machinery not needed).
+
+
+************************************************************************
+*                                                                      *
+* naming conventions                                                   *
+*                                                                      *
+************************************************************************
+
+\subsection[name-conventions]{Name conventions}
+
+The basic algorithm involves walking over the tree and returning a tuple
+containing the new tree plus its free variables. Some functions, such
+as those walking polymorphic bindings (HsBinds) and qualifier lists in
+list comprehensions (@Quals@), return the variables bound in local
+environments. These are then used to calculate the free variables of the
+expression evaluated in these environments.
+
+Conventions for variable names are as follows:
+\begin{itemize}
+\item
+new code is given a prime to distinguish it from the old.
+
+\item
+a set of variables defined in @Exp@ is written @dvExp@
+
+\item
+a set of variables free in @Exp@ is written @fvExp@
+\end{itemize}
+
+************************************************************************
+*                                                                      *
+* analysing polymorphic bindings (HsBindGroup, HsBind)
+*                                                                      *
+************************************************************************
+
+\subsubsection[dep-HsBinds]{Polymorphic bindings}
+
+Non-recursive expressions are reconstructed without any changes at top
+level, although their component expressions may have to be altered.
+However, non-recursive expressions are currently not expected as
+\Haskell{} programs, and this code should not be executed.
+
+Monomorphic bindings contain information that is returned in a tuple
+(a @FlatMonoBinds@) containing:
+
+\begin{enumerate}
+\item
+a unique @Int@ that serves as the ``vertex tag'' for this binding.
+
+\item
+the name of a function or the names in a pattern. These are a set
+referred to as @dvLhs@, the defined variables of the left hand side.
+
+\item
+the free variables of the body. These are referred to as @fvBody@.
+
+\item
+the definition's actual code. This is referred to as just @code@.
+\end{enumerate}
+
+The function @nonRecDvFv@ returns two sets of variables. The first is
+the set of variables defined in the set of monomorphic bindings, while the
+second is the set of free variables in those bindings.
+
+The set of variables defined in a non-recursive binding is just the
+union of all of them, as @union@ removes duplicates. However, the
+free variables in each successive set of cumulative bindings is the
+union of those in the previous set plus those of the newest binding after
+the defined variables of the previous set have been removed.
+
+@rnMethodBinds@ deals only with the declarations in class and
+instance declarations.  It expects only to see @FunMonoBind@s, and
+it expects the global environment to contain bindings for the binders
+(which are all class operations).
+
+************************************************************************
+*                                                                      *
+\subsubsection{ Top-level bindings}
+*                                                                      *
+************************************************************************
+-}
+
+-- for top-level bindings, we need to make top-level names,
+-- so we have a different entry point than for local bindings
+rnTopBindsLHS :: MiniFixityEnv
+              -> HsValBinds GhcPs
+              -> RnM (HsValBindsLR GhcRn GhcPs)
+rnTopBindsLHS fix_env binds
+  = rnValBindsLHS (topRecNameMaker fix_env) binds
+
+rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
+               -> RnM (HsValBinds GhcRn, DefUses)
+-- A hs-boot file has no bindings.
+-- Return a single HsBindGroup with empty binds and renamed signatures
+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
+  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
+        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
+        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
+rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
+
+{-
+*********************************************************
+*                                                      *
+                HsLocalBinds
+*                                                      *
+*********************************************************
+-}
+
+rnLocalBindsAndThen :: HsLocalBinds GhcPs
+                   -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
+                   -> RnM (result, FreeVars)
+-- This version (a) assumes that the binding vars are *not* already in scope
+--               (b) removes the binders from the free vars of the thing inside
+-- The parser doesn't produce ThenBinds
+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
+  thing_inside (EmptyLocalBinds x) emptyNameSet
+
+rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside
+  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
+      thing_inside (HsValBinds x val_binds')
+
+rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
+    (binds',fv_binds) <- rnIPBinds binds
+    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
+    return (thing, fvs_thing `plusFV` fv_binds)
+
+rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"
+
+rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
+rnIPBinds (IPBinds _ ip_binds ) = do
+    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
+    return (IPBinds noExt ip_binds', plusFVs fvs_s)
+rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"
+
+rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
+rnIPBind (IPBind _ ~(Left n) expr) = do
+    (expr',fvExpr) <- rnLExpr expr
+    return (IPBind noExt (Left n) expr', fvExpr)
+rnIPBind (XIPBind _) = panic "rnIPBind"
+
+{-
+************************************************************************
+*                                                                      *
+                ValBinds
+*                                                                      *
+************************************************************************
+-}
+
+-- Renaming local binding groups
+-- Does duplicate/shadow check
+rnLocalValBindsLHS :: MiniFixityEnv
+                   -> HsValBinds GhcPs
+                   -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
+rnLocalValBindsLHS fix_env binds
+  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
+
+         -- Check for duplicates and shadowing
+         -- Must do this *after* renaming the patterns
+         -- See Note [Collect binders only after renaming] in HsUtils
+
+         -- We need to check for dups here because we
+         -- don't don't bind all of the variables from the ValBinds at once
+         -- with bindLocatedLocals any more.
+         --
+         -- Note that we don't want to do this at the top level, since
+         -- sorting out duplicates and shadowing there happens elsewhere.
+         -- The behavior is even different. For example,
+         --   import A(f)
+         --   f = ...
+         -- should not produce a shadowing warning (but it will produce
+         -- an ambiguity warning if you use f), but
+         --   import A(f)
+         --   g = let f = ... in f
+         -- should.
+       ; let bound_names = collectHsValBinders binds'
+             -- There should be only Ids, but if there are any bogus
+             -- pattern synonyms, we'll collect them anyway, so that
+             -- we don't generate subsequent out-of-scope messages
+       ; envs <- getRdrEnvs
+       ; checkDupAndShadowedNames envs bound_names
+
+       ; return (bound_names, binds') }
+
+-- renames the left-hand sides
+-- generic version used both at the top level and for local binds
+-- does some error checking, but not what gets done elsewhere at the top level
+rnValBindsLHS :: NameMaker
+              -> HsValBinds GhcPs
+              -> RnM (HsValBindsLR GhcRn GhcPs)
+rnValBindsLHS topP (ValBinds x mbinds sigs)
+  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
+       ; return $ ValBinds x mbinds' sigs }
+  where
+    bndrs = collectHsBindsBinders mbinds
+    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
+
+rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
+
+-- General version used both from the top-level and for local things
+-- Assumes the LHS vars are in scope
+--
+-- Does not bind the local fixity declarations
+rnValBindsRHS :: HsSigCtxt
+              -> HsValBindsLR GhcRn GhcPs
+              -> RnM (HsValBinds GhcRn, DefUses)
+
+rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
+  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
+       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
+       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
+
+       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
+                          getPatSynBinds anal_binds
+                -- The uses in binds_w_dus for PatSynBinds do not include
+                -- variables used in the patsyn builders; see
+                -- Note [Pattern synonym builders don't yield dependencies]
+                -- But psb_fvs /does/ include those builder fvs.  So we
+                -- add them back in here to avoid bogus warnings about
+                -- unused variables (#12548)
+
+             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
+                                     `plusDU` usesOnly patsyn_fvs
+                            -- Put the sig uses *after* the bindings
+                            -- so that the binders are removed from
+                            -- the uses in the sigs
+
+        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
+
+rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
+
+-- Wrapper for local binds
+--
+-- The *client* of this function is responsible for checking for unused binders;
+-- it doesn't (and can't: we don't have the thing inside the binds) happen here
+--
+-- The client is also responsible for bringing the fixities into scope
+rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes
+                   -> HsValBindsLR GhcRn GhcPs
+                   -> RnM (HsValBinds GhcRn, DefUses)
+rnLocalValBindsRHS bound_names binds
+  = rnValBindsRHS (LocalBindCtxt bound_names) binds
+
+-- for local binds
+-- wrapper that does both the left- and right-hand sides
+--
+-- here there are no local fixity decls passed in;
+-- the local fixity decls come from the ValBinds sigs
+rnLocalValBindsAndThen
+  :: HsValBinds GhcPs
+  -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
+  -> RnM (result, FreeVars)
+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
+ = do   {     -- (A) Create the local fixity environment
+          new_fixities <- makeMiniFixityEnv [ L loc sig
+                                            | L loc (FixSig _ sig) <- sigs]
+
+              -- (B) Rename the LHSes
+        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
+
+              --     ...and bring them (and their fixities) into scope
+        ; bindLocalNamesFV bound_names              $
+          addLocalFixities new_fixities bound_names $ do
+
+        {      -- (C) Do the RHS and thing inside
+          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
+        ; (result, result_fvs) <- thing_inside binds' (allUses dus)
+
+                -- Report unused bindings based on the (accurate)
+                -- findUses.  E.g.
+                --      let x = x in 3
+                -- should report 'x' unused
+        ; let real_uses = findUses dus result_fvs
+              -- Insert fake uses for variables introduced implicitly by
+              -- wildcards (#4404)
+              rec_uses = hsValBindsImplicits binds'
+              implicit_uses = mkNameSet $ concatMap snd
+                                        $ rec_uses
+        ; mapM_ (\(loc, ns) ->
+                    checkUnusedRecordWildcard loc real_uses (Just ns))
+                rec_uses
+        ; warnUnusedLocalBinds bound_names
+                                      (real_uses `unionNameSet` implicit_uses)
+
+        ; let
+            -- The variables "used" in the val binds are:
+            --   (1) the uses of the binds (allUses)
+            --   (2) the FVs of the thing-inside
+            all_uses = allUses dus `plusFV` result_fvs
+                -- Note [Unused binding hack]
+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+                -- Note that *in contrast* to the above reporting of
+                -- unused bindings, (1) above uses duUses to return *all*
+                -- the uses, even if the binding is unused.  Otherwise consider:
+                --      x = 3
+                --      y = let p = x in 'x'    -- NB: p not used
+                -- If we don't "see" the dependency of 'y' on 'x', we may put the
+                -- bindings in the wrong order, and the type checker will complain
+                -- that x isn't in scope
+                --
+                -- But note that this means we won't report 'x' as unused,
+                -- whereas we would if we had { x = 3; p = x; y = 'x' }
+
+        ; return (result, all_uses) }}
+                -- The bound names are pruned out of all_uses
+                -- by the bindLocalNamesFV call above
+
+rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
+
+
+---------------------
+
+-- renaming a single bind
+
+rnBindLHS :: NameMaker
+          -> SDoc
+          -> HsBind GhcPs
+          -- returns the renamed left-hand side,
+          -- and the FreeVars *of the LHS*
+          -- (i.e., any free variables of the pattern)
+          -> RnM (HsBindLR GhcRn GhcPs)
+
+rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
+  = do
+      -- we don't actually use the FV processing of rnPatsAndThen here
+      (pat',pat'_fvs) <- rnBindPat name_maker pat
+      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
+                -- We temporarily store the pat's FVs in bind_fvs;
+                -- gets updated to the FVs of the whole bind
+                -- when doing the RHS below
+
+rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
+  = do { name <- applyNameMaker name_maker rdr_name
+       ; return (bind { fun_id = name
+                      , fun_ext = noExt }) }
+
+rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
+  | isTopRecNameMaker name_maker
+  = do { addLocM checkConName rdrname
+       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
+
+  | otherwise  -- Pattern synonym, not at top level
+  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake
+                                        -- name so that we can carry on
+       ; name <- applyNameMaker name_maker rdrname
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
+  where
+    localPatternSynonymErr :: SDoc
+    localPatternSynonymErr
+      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
+           2 (text "Pattern synonym declarations are only valid at top level")
+
+rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
+
+rnLBind :: (Name -> [Name])      -- Signature tyvar function
+        -> LHsBindLR GhcRn GhcPs
+        -> RnM (LHsBind GhcRn, [Name], Uses)
+rnLBind sig_fn (L loc bind)
+  = setSrcSpan loc $
+    do { (bind', bndrs, dus) <- rnBind sig_fn bind
+       ; return (L loc bind', bndrs, dus) }
+
+-- assumes the left-hands-side vars are in scope
+rnBind :: (Name -> [Name])        -- Signature tyvar function
+       -> HsBindLR GhcRn GhcPs
+       -> RnM (HsBind GhcRn, [Name], Uses)
+rnBind _ bind@(PatBind { pat_lhs = pat
+                       , pat_rhs = grhss
+                                   -- pat fvs were stored in bind_fvs
+                                   -- after processing the LHS
+                       , pat_ext = pat_fvs })
+  = do  { mod <- getModule
+        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
+
+                -- No scoped type variables for pattern bindings
+        ; let all_fvs = pat_fvs `plusFV` rhs_fvs
+              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+              bndrs = collectPatBinders pat
+              bind' = bind { pat_rhs  = grhss'
+                           , pat_ext = fvs' }
+
+              ok_nobind_pat
+                  = -- See Note [Pattern bindings that bind no variables]
+                    case unLoc pat of
+                       WildPat {}   -> True
+                       BangPat {}   -> True -- #9127, #13646
+                       SplicePat {} -> True
+                       _            -> False
+
+        -- Warn if the pattern binds no variables
+        -- See Note [Pattern bindings that bind no variables]
+        ; whenWOptM Opt_WarnUnusedPatternBinds $
+          when (null bndrs && not ok_nobind_pat) $
+          addWarn (Reason Opt_WarnUnusedPatternBinds) $
+          unusedPatBindWarn bind'
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind', bndrs, all_fvs) }
+
+rnBind sig_fn bind@(FunBind { fun_id = name
+                            , fun_matches = matches })
+       -- invariant: no free vars here when it's a FunBind
+  = do  { let plain_name = unLoc name
+
+        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
+                                -- bindSigTyVars tests for LangExt.ScopedTyVars
+                                 rnMatchGroup (mkPrefixFunRhs name)
+                                              rnLExpr matches
+        ; let is_infix = isInfixFunBind bind
+        ; when is_infix $ checkPrecMatch plain_name matches'
+
+        ; mod <- getModule
+        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind { fun_matches = matches'
+                       , fun_ext     = fvs' },
+                  [plain_name], rhs_fvs)
+      }
+
+rnBind sig_fn (PatSynBind x bind)
+  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
+        ; return (PatSynBind x bind', name, fvs) }
+
+rnBind _ b = pprPanic "rnBind" (ppr b)
+
+{- Note [Pattern bindings that bind no variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally, we want to warn about pattern bindings like
+  Just _ = e
+because they don't do anything!  But we have three exceptions:
+
+* A wildcard pattern
+       _ = rhs
+  which (a) is not that different from  _v = rhs
+        (b) is sometimes used to give a type sig for,
+            or an occurrence of, a variable on the RHS
+
+* A strict pattern binding; that is, one with an outermost bang
+     !Just _ = e
+  This can fail, so unlike the lazy variant, it is not a no-op.
+  Moreover, #13646 argues that even for single constructor
+  types, you might want to write the constructor.  See also #9127.
+
+* A splice pattern
+      $(th-lhs) = rhs
+   It is impossible to determine whether or not th-lhs really
+   binds any variable. We should disable the warning for any pattern
+   which contain splices, but that is a more expensive check.
+
+Note [Free-variable space leak]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have
+    fvs' = trim fvs
+and we seq fvs' before turning it as part of a record.
+
+The reason is that trim is sometimes something like
+    \xs -> intersectNameSet (mkNameSet bound_names) xs
+and we don't want to retain the list bound_names. This showed up in
+trac ticket #1136.
+-}
+
+{- *********************************************************************
+*                                                                      *
+          Dependency analysis and other support functions
+*                                                                      *
+********************************************************************* -}
+
+depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)
+             -> ([(RecFlag, LHsBinds GhcRn)], DefUses)
+-- Dependency analysis; this is important so that
+-- unused-binding reporting is accurate
+depAnalBinds binds_w_dus
+  = (map get_binds sccs, map get_du sccs)
+  where
+    sccs = depAnal (\(_, defs, _) -> defs)
+                   (\(_, _, uses) -> nonDetEltsUniqSet uses)
+                   -- It's OK to use nonDetEltsUniqSet here as explained in
+                   -- Note [depAnal determinism] in NameEnv.
+                   (bagToList binds_w_dus)
+
+    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
+
+    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
+    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
+        where
+          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
+          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]
+
+---------------------
+-- Bind the top-level forall'd type variables in the sigs.
+-- E.g  f :: forall a. a -> a
+--      f = rhs
+--      The 'a' scopes over the rhs
+--
+-- NB: there'll usually be just one (for a function binding)
+--     but if there are many, one may shadow the rest; too bad!
+--      e.g  x :: forall a. [a] -> [a]
+--           y :: forall a. [(a,a)] -> a
+--           (x,y) = e
+--      In e, 'a' will be in scope, and it'll be the one from 'y'!
+
+mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
+-- Return a lookup function that maps an Id Name to the names
+-- of the type variables that should scope over its body.
+mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
+  where
+    env = mkHsSigEnv get_scoped_tvs sigs
+
+    get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
+    -- Returns (binders, scoped tvs for those binders)
+    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
+      = Just (names, hsScopedTvs sig_ty)
+    get_scoped_tvs (L _ (TypeSig _ names sig_ty))
+      = Just (names, hsWcScopedTvs sig_ty)
+    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
+      = Just (names, hsScopedTvs sig_ty)
+    get_scoped_tvs _ = Nothing
+
+-- Process the fixity declarations, making a FastString -> (Located Fixity) map
+-- (We keep the location around for reporting duplicate fixity declarations.)
+--
+-- Checks for duplicates, but not that only locally defined things are fixed.
+-- Note: for local fixity declarations, duplicates would also be checked in
+--       check_sigs below.  But we also use this function at the top level.
+
+makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
+
+makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
+ where
+   add_one_sig env (L loc (FixitySig _ names fixity)) =
+     foldlM add_one env [ (loc,name_loc,name,fixity)
+                        | L name_loc name <- names ]
+   add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"
+
+   add_one env (loc, name_loc, name,fixity) = do
+     { -- this fixity decl is a duplicate iff
+       -- the ReaderName's OccName's FastString is already in the env
+       -- (we only need to check the local fix_env because
+       --  definitions of non-local will be caught elsewhere)
+       let { fs = occNameFS (rdrNameOcc name)
+           ; fix_item = L loc fixity };
+
+       case lookupFsEnv env fs of
+         Nothing -> return $ extendFsEnv env fs fix_item
+         Just (L loc' _) -> do
+           { setSrcSpan loc $
+             addErrAt name_loc (dupFixityDecl loc' name)
+           ; return env}
+     }
+
+dupFixityDecl :: SrcSpan -> RdrName -> SDoc
+dupFixityDecl loc rdr_name
+  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),
+          text "also at " <+> ppr loc]
+
+
+{- *********************************************************************
+*                                                                      *
+                Pattern synonym bindings
+*                                                                      *
+********************************************************************* -}
+
+rnPatSynBind :: (Name -> [Name])           -- Signature tyvar function
+             -> PatSynBind GhcRn GhcPs
+             -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)
+rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
+                              , psb_args = details
+                              , psb_def = pat
+                              , psb_dir = dir })
+       -- invariant: no free vars here when it's a FunBind
+  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
+        ; unless pattern_synonym_ok (addErr patternSynonymErr)
+        ; let scoped_tvs = sig_fn name
+
+        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
+                                      rnPat PatSyn pat $ \pat' ->
+         -- We check the 'RdrName's instead of the 'Name's
+         -- so that the binding locations are reported
+         -- from the left-hand side
+            case details of
+               PrefixCon vars ->
+                   do { checkDupRdrNames vars
+                      ; names <- mapM lookupPatSynBndr vars
+                      ; return ( (pat', PrefixCon names)
+                               , mkFVs (map unLoc names)) }
+               InfixCon var1 var2 ->
+                   do { checkDupRdrNames [var1, var2]
+                      ; name1 <- lookupPatSynBndr var1
+                      ; name2 <- lookupPatSynBndr var2
+                      -- ; checkPrecMatch -- TODO
+                      ; return ( (pat', InfixCon name1 name2)
+                               , mkFVs (map unLoc [name1, name2])) }
+               RecCon vars ->
+                   do { checkDupRdrNames (map recordPatSynSelectorId vars)
+                      ; let rnRecordPatSynField
+                              (RecordPatSynField { recordPatSynSelectorId = visible
+                                                 , recordPatSynPatVar = hidden })
+                              = do { visible' <- lookupLocatedTopBndrRn visible
+                                   ; hidden'  <- lookupPatSynBndr hidden
+                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
+                                                                , recordPatSynPatVar = hidden' } }
+                      ; names <- mapM rnRecordPatSynField  vars
+                      ; return ( (pat', RecCon names)
+                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
+
+        ; (dir', fvs2) <- case dir of
+            Unidirectional -> return (Unidirectional, emptyFVs)
+            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
+            ExplicitBidirectional mg ->
+                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
+                                   rnMatchGroup (mkPrefixFunRhs (L l name))
+                                                rnLExpr mg
+                   ; return (ExplicitBidirectional mg', fvs) }
+
+        ; mod <- getModule
+        ; let fvs = fvs1 `plusFV` fvs2
+              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+
+              bind' = bind{ psb_args = details'
+                          , psb_def = pat'
+                          , psb_dir = dir'
+                          , psb_ext = fvs' }
+              selector_names = case details' of
+                                 RecCon names ->
+                                  map (unLoc . recordPatSynSelectorId) names
+                                 _ -> []
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind', name : selector_names , fvs1)
+          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]
+      }
+  where
+    -- See Note [Renaming pattern synonym variables]
+    lookupPatSynBndr = wrapLocM lookupLocalOccRn
+
+    patternSynonymErr :: SDoc
+    patternSynonymErr
+      = hang (text "Illegal pattern synonym declaration")
+           2 (text "Use -XPatternSynonyms to enable this extension")
+
+rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"
+
+{-
+Note [Renaming pattern synonym variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We rename pattern synonym declaractions backwards to normal to reuse
+the logic already implemented for renaming patterns.
+
+We first rename the RHS of a declaration which brings into
+scope the variables bound by the pattern (as they would be
+in normal function definitions). We then lookup the variables
+which we want to bind in this local environment.
+
+It is crucial that we then only lookup in the *local* environment which
+only contains the variables brought into scope by the pattern and nothing
+else. Amazingly no-one encountered this bug for 3 GHC versions but
+it was possible to define a pattern synonym which referenced global
+identifiers and worked correctly.
+
+```
+x = 5
+
+pattern P :: Int -> ()
+pattern P x <- _
+
+f (P x) = x
+
+> f () = 5
+```
+
+See #13470 for the original report.
+
+Note [Pattern synonym builders don't yield dependencies]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming a pattern synonym that has an explicit builder,
+references in the builder definition should not be used when
+calculating dependencies. For example, consider the following pattern
+synonym definition:
+
+pattern P x <- C1 x where
+  P x = f (C1 x)
+
+f (P x) = C2 x
+
+In this case, 'P' needs to be typechecked in two passes:
+
+1. Typecheck the pattern definition of 'P', which fully determines the
+   type of 'P'. This step doesn't require knowing anything about 'f',
+   since the builder definition is not looked at.
+
+2. Typecheck the builder definition, which needs the typechecked
+   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind
+   in TcBinds.tcValBinds.
+
+This behaviour is implemented in 'tcValBinds', but it crucially
+depends on 'P' not being put in a recursive group with 'f' (which
+would make it look like a recursive pattern synonym a la 'pattern P =
+P' which is unsound and rejected).
+
+So:
+ * We do not include builder fvs in the Uses returned by rnPatSynBind
+   (which is then used for dependency analysis)
+ * But we /do/ include them in the psb_fvs for the PatSynBind
+ * In rnValBinds we record these builder uses, to avoid bogus
+   unused-variable warnings (#12548)
+-}
+
+{- *********************************************************************
+*                                                                      *
+                Class/instance method bindings
+*                                                                      *
+********************************************************************* -}
+
+{- @rnMethodBinds@ is used for the method bindings of a class and an instance
+declaration.   Like @rnBinds@ but without dependency analysis.
+
+NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
+That's crucial when dealing with an instance decl:
+\begin{verbatim}
+        instance Foo (T a) where
+           op x = ...
+\end{verbatim}
+This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
+and unless @op@ occurs we won't treat the type signature of @op@ in the class
+decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
+in many ways the @op@ in an instance decl is just like an occurrence, not
+a binder.
+-}
+
+rnMethodBinds :: Bool                   -- True <=> is a class declaration
+              -> Name                   -- Class name
+              -> [Name]                 -- Type variables from the class/instance header
+              -> LHsBinds GhcPs         -- Binds
+              -> [LSig GhcPs]           -- and signatures/pragmas
+              -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
+-- Used for
+--   * the default method bindings in a class decl
+--   * the method bindings in an instance decl
+rnMethodBinds is_cls_decl cls ktv_names binds sigs
+  = do { checkDupRdrNames (collectMethodBinders binds)
+             -- Check that the same method is not given twice in the
+             -- same instance decl      instance C T where
+             --                       f x = ...
+             --                       g y = ...
+             --                       f x = ...
+             -- We must use checkDupRdrNames because the Name of the
+             -- method is the Name of the class selector, whose SrcSpan
+             -- points to the class declaration; and we use rnMethodBinds
+             -- for instance decls too
+
+       -- Rename the bindings LHSs
+       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
+
+       -- Rename the pragmas and signatures
+       -- Annoyingly the type variables /are/ in scope for signatures, but
+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.
+       --    instance Eq a => Eq (T a) where
+       --       (==) :: a -> a -> a
+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
+             bound_nms = mkNameSet (collectHsBindsBinders binds')
+             sig_ctxt | is_cls_decl = ClsDeclCtxt cls
+                      | otherwise   = InstDeclCtxt bound_nms
+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
+       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $
+                                        renameSigs sig_ctxt other_sigs
+
+       -- Rename the bindings RHSs.  Again there's an issue about whether the
+       -- type variables from the class/instance head are in scope.
+       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
+       ; 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)
+                                           emptyFVs binds_w_dus
+                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
+
+       ; return ( binds'', spec_inst_prags' ++ other_sigs'
+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
+  where
+    -- For the method bindings in class and instance decls, we extend
+    -- the type variable environment iff -XScopedTypeVariables
+    maybe_extend_tyvar_env scoped_tvs thing_inside
+       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside
+       | otherwise  = thing_inside
+
+rnMethodBindLHS :: Bool -> Name
+                -> LHsBindLR GhcPs GhcPs
+                -> LHsBindsLR GhcRn GhcPs
+                -> RnM (LHsBindsLR GhcRn GhcPs)
+rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
+  = setSrcSpan loc $ do
+    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
+                     -- We use the selector name as the binder
+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }
+       ; return (L loc bind' `consBag` rest ) }
+
+-- Report error for all other forms of bindings
+-- This is why we use a fold rather than map
+rnMethodBindLHS is_cls_decl _ (L loc bind) rest
+  = do { addErrAt loc $
+         vcat [ what <+> text "not allowed in" <+> decl_sort
+              , nest 2 (ppr bind) ]
+       ; return rest }
+  where
+    decl_sort | is_cls_decl = text "class declaration:"
+              | otherwise   = text "instance declaration:"
+    what = case bind of
+              PatBind {}    -> text "Pattern bindings (except simple variables)"
+              PatSynBind {} -> text "Pattern synonyms"
+                               -- Associated pattern synonyms are not implemented yet
+              _ -> pprPanic "rnMethodBind" (ppr bind)
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
+*                                                                      *
+************************************************************************
+
+@renameSigs@ checks for:
+\begin{enumerate}
+\item more than one sig for one thing;
+\item signatures given for things not bound here;
+\end{enumerate}
+
+At the moment we don't gather free-var info from the types in
+signatures.  We'd only need this if we wanted to report unused tyvars.
+-}
+
+renameSigs :: HsSigCtxt
+           -> [LSig GhcPs]
+           -> RnM ([LSig GhcRn], FreeVars)
+-- Renames the signatures and performs error checks
+renameSigs ctxt sigs
+  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)
+
+        ; checkDupMinimalSigs sigs
+
+        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
+
+        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
+        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
+
+        ; return (good_sigs, sig_fvs) }
+
+----------------------
+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
+-- because this won't work for:
+--      instance Foo T where
+--        {-# INLINE op #-}
+--        Baz.op = ...
+-- We'll just rename the INLINE prag to refer to whatever other 'op'
+-- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
+-- Doesn't seem worth much trouble to sort this.
+
+renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
+renameSig _ (IdSig _ x)
+  = return (IdSig noExt x, emptyFVs)    -- Actually this never occurs
+
+renameSig ctxt sig@(TypeSig _ vs ty)
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
+        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty
+        ; return (TypeSig noExt new_vs new_ty, fvs) }
+
+renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
+  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures
+        ; when (is_deflt && not defaultSigs_on) $
+          addErr (defaultSigErr sig)
+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
+        ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }
+  where
+    (v1:_) = vs
+    ty_ctxt = GenericCtx (text "a class method signature for"
+                          <+> quotes (ppr v1))
+
+renameSig _ (SpecInstSig _ src ty)
+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
+        ; return (SpecInstSig noExt src new_ty,fvs) }
+
+-- {-# SPECIALISE #-} pragmas can refer to imported Ids
+-- so, in the top-level case (when mb_names is Nothing)
+-- we use lookupOccRn.  If there's both an imported and a local 'f'
+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
+renameSig ctxt sig@(SpecSig _ v tys inl)
+  = do  { new_v <- case ctxt of
+                     TopSigCtxt {} -> lookupLocatedOccRn v
+                     _             -> lookupSigOccRn ctxt sig v
+        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
+        ; return (SpecSig noExt new_v new_ty inl, fvs) }
+  where
+    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
+                          <+> quotes (ppr v))
+    do_one (tys,fvs) ty
+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
+           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
+
+renameSig ctxt sig@(InlineSig _ v s)
+  = do  { new_v <- lookupSigOccRn ctxt sig v
+        ; return (InlineSig noExt new_v s, emptyFVs) }
+
+renameSig ctxt (FixSig _ fsig)
+  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig
+        ; return (FixSig noExt new_fsig, emptyFVs) }
+
+renameSig ctxt sig@(MinimalSig _ s (L l bf))
+  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
+       return (MinimalSig noExt s (L l new_bf), emptyFVs)
+
+renameSig ctxt sig@(PatSynSig _ vs ty)
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+        ; (ty', fvs) <- rnHsSigType ty_ctxt ty
+        ; return (PatSynSig noExt new_vs ty', fvs) }
+  where
+    ty_ctxt = GenericCtx (text "a pattern synonym signature for"
+                          <+> ppr_sig_bndrs vs)
+
+renameSig ctxt sig@(SCCFunSig _ st v s)
+  = do  { new_v <- lookupSigOccRn ctxt sig v
+        ; return (SCCFunSig noExt st new_v s, emptyFVs) }
+
+-- COMPLETE Sigs can refer to imported IDs which is why we use
+-- lookupLocatedOccRn rather than lookupSigOccRn
+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
+  = do new_bf <- traverse lookupLocatedOccRn bf
+       new_mty  <- traverse lookupLocatedOccRn mty
+
+       this_mod <- fmap tcg_mod getGblEnv
+       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do
+         -- Why 'any'? See Note [Orphan COMPLETE pragmas]
+         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
+
+       return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)
+  where
+    orphanError :: SDoc
+    orphanError =
+      text "Orphan COMPLETE pragmas not supported" $$
+      text "A COMPLETE pragma must mention at least one data constructor" $$
+      text "or pattern synonym defined in the same module."
+
+renameSig _ (XSig _) = panic "renameSig"
+
+{-
+Note [Orphan COMPLETE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We define a COMPLETE pragma to be a non-orphan if it includes at least
+one conlike defined in the current module. Why is this sufficient?
+Well if you have a pattern match
+
+  case expr of
+    P1 -> ...
+    P2 -> ...
+    P3 -> ...
+
+any COMPLETE pragma which mentions a conlike other than P1, P2 or P3
+will not be of any use in verifying that the pattern match is
+exhaustive. So as we have certainly read the interface files that
+define P1, P2 and P3, we will have loaded all non-orphan COMPLETE
+pragmas that could be relevant to this pattern match.
+
+For now we simply disallow orphan COMPLETE pragmas, as the added
+complexity of supporting them properly doesn't seem worthwhile.
+-}
+
+ppr_sig_bndrs :: [Located RdrName] -> SDoc
+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
+
+okHsSig :: HsSigCtxt -> LSig a -> Bool
+okHsSig ctxt (L _ sig)
+  = case (sig, ctxt) of
+     (ClassOpSig {}, ClsDeclCtxt {})  -> True
+     (ClassOpSig {}, InstDeclCtxt {}) -> True
+     (ClassOpSig {}, _)               -> False
+
+     (TypeSig {}, ClsDeclCtxt {})  -> False
+     (TypeSig {}, InstDeclCtxt {}) -> False
+     (TypeSig {}, _)               -> True
+
+     (PatSynSig {}, TopSigCtxt{}) -> True
+     (PatSynSig {}, _)            -> False
+
+     (FixSig {}, InstDeclCtxt {}) -> False
+     (FixSig {}, _)               -> True
+
+     (IdSig {}, TopSigCtxt {})   -> True
+     (IdSig {}, InstDeclCtxt {}) -> True
+     (IdSig {}, _)               -> False
+
+     (InlineSig {}, HsBootCtxt {}) -> False
+     (InlineSig {}, _)             -> True
+
+     (SpecSig {}, TopSigCtxt {})    -> True
+     (SpecSig {}, LocalBindCtxt {}) -> True
+     (SpecSig {}, InstDeclCtxt {})  -> True
+     (SpecSig {}, _)                -> False
+
+     (SpecInstSig {}, InstDeclCtxt {}) -> True
+     (SpecInstSig {}, _)               -> False
+
+     (MinimalSig {}, ClsDeclCtxt {}) -> True
+     (MinimalSig {}, _)              -> False
+
+     (SCCFunSig {}, HsBootCtxt {}) -> False
+     (SCCFunSig {}, _)             -> True
+
+     (CompleteMatchSig {}, TopSigCtxt {} ) -> True
+     (CompleteMatchSig {}, _)              -> False
+
+     (XSig _, _) -> panic "okHsSig"
+
+-------------------
+findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
+-- Check for duplicates on RdrName version,
+-- because renamed version has unboundName for
+-- not-in-scope binders, which gives bogus dup-sig errors
+-- NB: in a class decl, a 'generic' sig is not considered
+--     equal to an ordinary sig, so we allow, say
+--           class C a where
+--             op :: a -> a
+--             default op :: Eq a => a -> a
+findDupSigs sigs
+  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
+  where
+    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
+    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]
+    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]
+    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]
+    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]
+    expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]
+    expand_sig _ = []
+
+    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2
+    mtch (FixSig {})           (FixSig {})         = True
+    mtch (InlineSig {})        (InlineSig {})      = True
+    mtch (TypeSig {})          (TypeSig {})        = True
+    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
+    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True
+    mtch (SCCFunSig{})         (SCCFunSig{})       = True
+    mtch _ _ = False
+
+-- Warn about multiple MINIMAL signatures
+checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
+checkDupMinimalSigs sigs
+  = case filter isMinimalLSig sigs of
+      minSigs@(_:_:_) -> dupMinimalSigErr minSigs
+      _ -> return ()
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Match}
+*                                                                      *
+************************************************************************
+-}
+
+rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
+             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+             -> MatchGroup GhcPs (Located (body GhcPs))
+             -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
+rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
+  = do { empty_case_ok <- xoptM LangExt.EmptyCase
+       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
+       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
+       ; return (mkMatchGroup origin new_ms, ms_fvs) }
+rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"
+
+rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> LMatch GhcPs (Located (body GhcPs))
+        -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
+rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
+
+rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
+         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+         -> Match GhcPs (Located (body GhcPs))
+         -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
+  = do  { -- Note that there are no local fixity decls for matches
+        ; rnPats ctxt pats      $ \ pats' -> do
+        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
+        ; let mf' = case (ctxt, mf) of
+                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
+                                            -> mf { mc_fun = L lf funid }
+                      _                     -> ctxt
+        ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'
+                        , m_grhss = grhss'}, grhss_fvs ) }}
+rnMatch' _ _ (XMatch _) = panic "rnMatch'"
+
+emptyCaseErr :: HsMatchContext Name -> SDoc
+emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
+                       2 (text "Use EmptyCase to allow this")
+  where
+    pp_ctxt = case ctxt of
+                CaseAlt    -> text "case expression"
+                LambdaExpr -> text "\\case expression"
+                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Guarded right-hand sides (GRHSs)}
+*                                                                      *
+************************************************************************
+-}
+
+rnGRHSs :: HsMatchContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> GRHSs GhcPs (Located (body GhcPs))
+        -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
+  = rnLocalBindsAndThen binds   $ \ binds' _ -> do
+    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
+    return (GRHSs noExt grhss' (L l binds'), fvGRHSs)
+rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"
+
+rnGRHS :: HsMatchContext Name
+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+       -> LGRHS GhcPs (Located (body GhcPs))
+       -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
+rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
+
+rnGRHS' :: HsMatchContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> GRHS GhcPs (Located (body GhcPs))
+        -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
+rnGRHS' ctxt rnBody (GRHS _ guards rhs)
+  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards
+        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
+                                    rnBody rhs
+
+        ; unless (pattern_guards_allowed || is_standard_guard guards')
+                 (addWarn NoReason (nonStdGuardErr guards'))
+
+        ; return (GRHS noExt guards' rhs', fvs) }
+  where
+        -- Standard Haskell 1.4 guards are just a single boolean
+        -- expression, rather than a list of qualifiers as in the
+        -- Glasgow extension
+    is_standard_guard []                  = True
+    is_standard_guard [L _ (BodyStmt {})] = True
+    is_standard_guard _                   = False
+rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"
+
+{-
+*********************************************************
+*                                                       *
+        Source-code fixity declarations
+*                                                       *
+*********************************************************
+-}
+
+rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
+-- Rename a fixity decl, so we can put
+-- the renamed decl in the renamed syntax tree
+-- Errors if the thing being fixed is not defined locally.
+rnSrcFixityDecl sig_ctxt = rn_decl
+  where
+    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
+        -- GHC extension: look up both the tycon and data con
+        -- for con-like things; hence returning a list
+        -- If neither are in scope, report an error; otherwise
+        -- return a fixity sig for each (slightly odd)
+    rn_decl (FixitySig _ fnames fixity)
+      = do names <- concatMapM lookup_one fnames
+           return (FixitySig noExt names fixity)
+    rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"
+
+    lookup_one :: Located RdrName -> RnM [Located Name]
+    lookup_one (L name_loc rdr_name)
+      = setSrcSpan name_loc $
+                    -- This lookup will fail if the name is not defined in the
+                    -- same binding group as this fixity declaration.
+        do names <- lookupLocalTcNames sig_ctxt what rdr_name
+           return [ L name_loc name | (_, name) <- names ]
+    what = text "fixity signature"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
+dupSigDeclErr pairs@((L loc name, sig) :| _)
+  = addErrAt loc $
+    vcat [ text "Duplicate" <+> what_it_is
+           <> text "s for" <+> quotes (ppr name)
+         , text "at" <+> vcat (map ppr $ sort
+                                       $ map (getLoc . fst)
+                                       $ toList pairs)
+         ]
+  where
+    what_it_is = hsSigDoc sig
+
+misplacedSigErr :: LSig GhcRn -> RnM ()
+misplacedSigErr (L loc sig)
+  = addErrAt loc $
+    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
+
+defaultSigErr :: Sig GhcPs -> SDoc
+defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
+                              2 (ppr sig)
+                         , text "Use DefaultSignatures to enable default signatures" ]
+
+bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
+bindsInHsBootFile mbinds
+  = hang (text "Bindings in hs-boot files are not allowed")
+       2 (ppr mbinds)
+
+nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc
+nonStdGuardErr guards
+  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
+       4 (interpp'SP guards)
+
+unusedPatBindWarn :: HsBind GhcRn -> SDoc
+unusedPatBindWarn bind
+  = hang (text "This pattern-binding binds no variables:")
+       2 (ppr bind)
+
+dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
+dupMinimalSigErr sigs@(L loc _ : _)
+  = addErrAt loc $
+    vcat [ text "Multiple minimal complete definitions"
+         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)
+         , text "Combine alternative minimal complete definitions with `|'" ]
+dupMinimalSigErr [] = panic "dupMinimalSigErr"
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnEnv.hs
@@ -0,0 +1,1686 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-2006
+
+RnEnv contains functions which convert RdrNames into Names.
+
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}
+
+module RnEnv (
+        newTopSrcBinder,
+        lookupLocatedTopBndrRn, lookupTopBndrRn,
+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
+        lookupLocalOccRn_maybe, lookupInfoOccRn,
+        lookupLocalOccThLvl_maybe, lookupLocalOccRn,
+        lookupTypeOccRn,
+        lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
+
+        ChildLookupResult(..),
+        lookupSubBndrOcc_helper,
+        combineChildLookupResult, -- Called by lookupChildrenExport
+
+        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
+        lookupSigCtxtOccRn,
+
+        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
+        lookupConstructorFields,
+
+        lookupGreAvailRn,
+
+        -- Rebindable Syntax
+        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,
+        lookupIfThenElse,
+
+        -- Constructing usage information
+        addUsedGRE, addUsedGREs, addUsedDataCons,
+
+
+
+        dataTcOccs, --TODO: Move this somewhere, into utils?
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe )
+import IfaceEnv
+import HsSyn
+import RdrName
+import HscTypes
+import TcEnv
+import TcRnMonad
+import RdrHsSyn         ( filterCTuple, setRdrNameSpace )
+import TysWiredIn
+import Name
+import NameSet
+import NameEnv
+import Avail
+import Module
+import ConLike
+import DataCon
+import TyCon
+import ErrUtils         ( MsgDoc )
+import PrelNames        ( rOOT_MAIN )
+import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))
+import SrcLoc
+import Outputable
+import Util
+import Maybes
+import DynFlags
+import FastString
+import Control.Monad
+import ListSetOps       ( minusList )
+import qualified GHC.LanguageExtensions as LangExt
+import RnUnbound
+import RnUtils
+import qualified Data.Semigroup as Semi
+import Data.Either      ( partitionEithers )
+import Data.List        (find)
+
+{-
+*********************************************************
+*                                                      *
+                Source-code binders
+*                                                      *
+*********************************************************
+
+Note [Signature lazy interface loading]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC's lazy interface loading can be a bit confusing, so this Note is an
+empirical description of what happens in one interesting case. When
+compiling a signature module against an its implementation, we do NOT
+load interface files associated with its names until after the type
+checking phase.  For example:
+
+    module ASig where
+        data T
+        f :: T -> T
+
+Suppose we compile this with -sig-of "A is ASig":
+
+    module B where
+        data T = T
+        f T = T
+
+    module A(module B) where
+        import B
+
+During type checking, we'll load A.hi because we need to know what the
+RdrEnv for the module is, but we DO NOT load the interface for B.hi!
+It's wholly unnecessary: our local definition 'data T' in ASig is all
+the information we need to finish type checking.  This is contrast to
+type checking of ordinary Haskell files, in which we would not have the
+local definition "data T" and would need to consult B.hi immediately.
+(Also, this situation never occurs for hs-boot files, since you're not
+allowed to reexport from another module.)
+
+After type checking, we then check that the types we provided are
+consistent with the backing implementation (in checkHiBootOrHsigIface).
+At this point, B.hi is loaded, because we need something to compare
+against.
+
+I discovered this behavior when trying to figure out why type class
+instances for Data.Map weren't in the EPS when I was type checking a
+test very much like ASig (sigof02dm): the associated interface hadn't
+been loaded yet!  (The larger issue is a moot point, since an instance
+declared in a signature can never be a duplicate.)
+
+This behavior might change in the future.  Consider this
+alternate module B:
+
+    module B where
+        {-# DEPRECATED T, f "Don't use" #-}
+        data T = T
+        f T = T
+
+One might conceivably want to report deprecation warnings when compiling
+ASig with -sig-of B, in which case we need to look at B.hi to find the
+deprecation warnings during renaming.  At the moment, you don't get any
+warning until you use the identifier further downstream.  This would
+require adjusting addUsedGRE so that during signature compilation,
+we do not report deprecation warnings for LocalDef.  See also
+Note [Handling of deprecations]
+-}
+
+newTopSrcBinder :: Located RdrName -> RnM Name
+newTopSrcBinder (L loc rdr_name)
+  | Just name <- isExact_maybe rdr_name
+  =     -- This is here to catch
+        --   (a) Exact-name binders created by Template Haskell
+        --   (b) The PrelBase defn of (say) [] and similar, for which
+        --       the parser reads the special syntax and returns an Exact RdrName
+        -- We are at a binding site for the name, so check first that it
+        -- the current module is the correct one; otherwise GHC can get
+        -- very confused indeed. This test rejects code like
+        --      data T = (,) Int Int
+        -- unless we are in GHC.Tup
+    if isExternalName name then
+      do { this_mod <- getModule
+         ; unless (this_mod == nameModule name)
+                  (addErrAt loc (badOrigBinding rdr_name))
+         ; return name }
+    else   -- See Note [Binders in Template Haskell] in Convert.hs
+      do { this_mod <- getModule
+         ; externaliseName this_mod name }
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do  { this_mod <- getModule
+        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+                 (addErrAt loc (badOrigBinding rdr_name))
+        -- When reading External Core we get Orig names as binders,
+        -- but they should agree with the module gotten from the monad
+        --
+        -- We can get built-in syntax showing up here too, sadly.  If you type
+        --      data T = (,,,)
+        -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon
+        -- uses setRdrNameSpace to make it into a data constructors.  At that point
+        -- the nice Exact name for the TyCon gets swizzled to an Orig name.
+        -- Hence the badOrigBinding error message.
+        --
+        -- Except for the ":Main.main = ..." definition inserted into
+        -- the Main module; ugh!
+
+        -- Because of this latter case, we call newGlobalBinder with a module from
+        -- the RdrName, not from the environment.  In principle, it'd be fine to
+        -- have an arbitrary mixture of external core definitions in a single module,
+        -- (apart from module-initialisation issues, perhaps).
+        ; newGlobalBinder rdr_mod rdr_occ loc }
+
+  | otherwise
+  = do  { when (isQual rdr_name)
+                 (addErrAt loc (badQualBndrErr rdr_name))
+                -- Binders should not be qualified; if they are, and with a different
+                -- module name, we get a confusing "M.T is not in scope" error later
+
+        ; stage <- getStage
+        ; if isBrackStage stage then
+                -- We are inside a TH bracket, so make an *Internal* name
+                -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
+             do { uniq <- newUnique
+                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+          else
+             do { this_mod <- getModule
+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)
+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
+        }
+
+{-
+*********************************************************
+*                                                      *
+        Source code occurrences
+*                                                      *
+*********************************************************
+
+Looking up a name in the RnEnv.
+
+Note [Type and class operator definitions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to reject all of these unless we have -XTypeOperators (#3265)
+   data a :*: b  = ...
+   class a :*: b where ...
+   data (:*:) a b  = ....
+   class (:*:) a b where ...
+The latter two mean that we are not just looking for a
+*syntactically-infix* declaration, but one that uses an operator
+OccName.  We use OccName.isSymOcc to detect that case, which isn't
+terribly efficient, but there seems to be no better way.
+-}
+
+-- Can be made to not be exposed
+-- Only used unwrapped in rnAnnProvenance
+lookupTopBndrRn :: RdrName -> RnM Name
+lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
+                       case nopt of
+                         Just n' -> return n'
+                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)
+                                       unboundName WL_LocalTop n
+
+lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
+
+lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',
+-- and there may be several imported 'f's too, which must not confuse us.
+-- For example, this is OK:
+--      import Foo( f )
+--      infix 9 f       -- The 'f' here does not need to be qualified
+--      f x = x         -- Nor here, of course
+-- So we have to filter out the non-local ones.
+--
+-- A separate function (importsFromLocalDecls) reports duplicate top level
+-- decls, so here it's safe just to choose an arbitrary one.
+--
+-- There should never be a qualified name in a binding position in Haskell,
+-- but there can be if we have read in an external-Core file.
+-- The Haskell parser checks for the illegal qualified name in Haskell
+-- source files, so we don't need to do so here.
+
+lookupTopBndrRn_maybe rdr_name =
+  lookupExactOrOrig rdr_name Just $
+    do  {  -- Check for operators in type or class declarations
+           -- See Note [Type and class operator definitions]
+          let occ = rdrNameOcc rdr_name
+        ; when (isTcOcc occ && isSymOcc occ)
+               (do { op_ok <- xoptM LangExt.TypeOperators
+                   ; unless op_ok (addErr (opDeclErr rdr_name)) })
+
+        ; env <- getGlobalRdrEnv
+        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of
+            [gre] -> return (Just (gre_name gre))
+            _     -> return Nothing  -- Ambiguous (can't happen) or unbound
+    }
+
+-----------------------------------------------
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This adds an error if the name cannot be found.
+lookupExactOcc :: Name -> RnM Name
+lookupExactOcc name
+  = do { result <- lookupExactOcc_either name
+       ; case result of
+           Left err -> do { addErr err
+                          ; return name }
+           Right name' -> return name' }
+
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This never adds an error, but it may return one.
+lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)
+-- See Note [Looking up Exact RdrNames]
+lookupExactOcc_either name
+  | Just thing <- wiredInNameTyThing_maybe name
+  , Just tycon <- case thing of
+                    ATyCon tc                 -> Just tc
+                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)
+                    _                         -> Nothing
+  , isTupleTyCon tycon
+  = do { checkTupSize (tyConArity tycon)
+       ; return (Right name) }
+
+  | isExternalName name
+  = return (Right name)
+
+  | otherwise
+  = do { env <- getGlobalRdrEnv
+       ; let -- See Note [Splicing Exact names]
+             main_occ =  nameOccName name
+             demoted_occs = case demoteOccName main_occ of
+                              Just occ -> [occ]
+                              Nothing  -> []
+             gres = [ gre | occ <- main_occ : demoted_occs
+                          , gre <- lookupGlobalRdrEnv env occ
+                          , gre_name gre == name ]
+       ; case gres of
+           [gre] -> return (Right (gre_name gre))
+
+           []    -> -- See Note [Splicing Exact names]
+                    do { lcl_env <- getLocalRdrEnv
+                       ; if name `inLocalRdrEnvScope` lcl_env
+                         then return (Right name)
+                         else
+                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+                            ; th_topnames <- readTcRef th_topnames_var
+                            ; if name `elemNameSet` th_topnames
+                              then return (Right name)
+                              else return (Left exact_nm_err)
+                            }
+                       }
+           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]
+       }
+  where
+    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
+                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "
+                              , text "perhaps via newName, but did not bind it"
+                              , text "If that's it, then -ddump-splices might be useful" ])
+
+sameNameErr :: [GlobalRdrElt] -> MsgDoc
+sameNameErr [] = panic "addSameNameErr: empty list"
+sameNameErr gres@(_ : _)
+  = hang (text "Same exact name in multiple name-spaces:")
+       2 (vcat (map pp_one sorted_names) $$ th_hint)
+  where
+    sorted_names = sortWith nameSrcLoc (map gre_name gres)
+    pp_one name
+      = hang (pprNameSpace (occNameSpace (getOccName name))
+              <+> quotes (ppr name) <> comma)
+           2 (text "declared at:" <+> ppr (nameSrcLoc name))
+
+    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"
+                   , text "perhaps via newName, in different name-spaces."
+                   , text "If that's it, then -ddump-splices might be useful" ]
+
+
+-----------------------------------------------
+lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name
+-- This is called on the method name on the left-hand side of an
+-- instance declaration binding. eg.  instance Functor T where
+--                                       fmap = ...
+--                                       ^^^^ called on this
+-- Regardless of how many unqualified fmaps are in scope, we want
+-- the one that comes from the Functor class.
+--
+-- Furthermore, note that we take no account of whether the
+-- name is only in scope qualified.  I.e. even if method op is
+-- in scope as M.op, we still allow plain 'op' on the LHS of
+-- an instance decl
+--
+-- The "what" parameter says "method" or "associated type",
+-- depending on what we are looking up
+lookupInstDeclBndr cls what rdr
+  = do { when (isQual rdr)
+              (addErr (badQualBndrErr rdr))
+                -- In an instance decl you aren't allowed
+                -- to use a qualified name for the method
+                -- (Although it'd make perfect sense.)
+       ; mb_name <- lookupSubBndrOcc
+                          False -- False => we don't give deprecated
+                                -- warnings when a deprecated class
+                                -- method is defined. We only warn
+                                -- when it's used
+                          cls doc rdr
+       ; case mb_name of
+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }
+           Right nm -> return nm }
+  where
+    doc = what <+> text "of class" <+> quotes (ppr cls)
+
+-----------------------------------------------
+lookupFamInstName :: Maybe Name -> Located RdrName
+                  -> RnM (Located Name)
+-- Used for TyData and TySynonym family instances only,
+-- See Note [Family instance binders]
+lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f RnBinds.rnMethodBind
+  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr
+lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*
+  = lookupLocatedOccRn tc_rdr
+
+-----------------------------------------------
+lookupConstructorFields :: Name -> RnM [FieldLabel]
+-- Look up the fields of a given constructor
+--   *  For constructors from this module, use the record field env,
+--      which is itself gathered from the (as yet un-typechecked)
+--      data type decls
+--
+--    * For constructors from imported modules, use the *type* environment
+--      since imported modles are already compiled, the info is conveniently
+--      right there
+
+lookupConstructorFields con_name
+  = do  { this_mod <- getModule
+        ; if nameIsLocalOrFrom this_mod con_name then
+          do { field_env <- getRecFieldEnv
+             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)
+             ; return (lookupNameEnv field_env con_name `orElse` []) }
+          else
+          do { con <- tcLookupConLike con_name
+             ; traceTc "lookupCF 2" (ppr con)
+             ; return (conLikeFieldLabels con) } }
+
+
+-- In CPS style as `RnM r` is monadic
+lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r
+lookupExactOrOrig rdr_name res k
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = res <$> lookupExactOcc n
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = res <$> lookupOrig rdr_mod rdr_occ
+  | otherwise = k
+
+
+
+-----------------------------------------------
+-- | Look up an occurrence of a field in record construction or pattern
+-- matching (but not update).  When the -XDisambiguateRecordFields
+-- flag is on, take account of the data constructor name to
+-- disambiguate which field to use.
+--
+-- See Note [DisambiguateRecordFields].
+lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual
+                                -- Just con => use data con to disambiguate
+                  -> RdrName
+                  -> RnM Name
+lookupRecFieldOcc mb_con rdr_name
+  | Just con <- mb_con
+  , isUnboundName con  -- Avoid error cascade
+  = return (mkUnboundNameRdr rdr_name)
+  | Just con <- mb_con
+  = do { flds <- lookupConstructorFields con
+       ; env <- getGlobalRdrEnv
+       ; let lbl      = occNameFS (rdrNameOcc rdr_name)
+             mb_field = do fl <- find ((== lbl) . flLabel) flds
+                           -- We have the label, now check it is in
+                           -- scope (with the correct qualifier if
+                           -- there is one, hence calling pickGREs).
+                           gre <- lookupGRE_FieldLabel env fl
+                           guard (not (isQual rdr_name
+                                         && null (pickGREs rdr_name [gre])))
+                           return (fl, gre)
+       ; case mb_field of
+           Just (fl, gre) -> do { addUsedGRE True gre
+                                ; return (flSelector fl) }
+           Nothing        -> lookupGlobalOccRn rdr_name }
+             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+  | otherwise
+  -- This use of Global is right as we are looking up a selector which
+  -- can only be defined at the top level.
+  = lookupGlobalOccRn rdr_name
+
+{- Note [DisambiguateRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are looking up record fields in record construction or pattern
+matching, we can take advantage of the data constructor name to
+resolve fields that would otherwise be ambiguous (provided the
+-XDisambiguateRecordFields flag is on).
+
+For example, consider:
+
+   data S = MkS { x :: Int }
+   data T = MkT { x :: Int }
+
+   e = MkS { x = 3 }
+
+When we are renaming the occurrence of `x` in `e`, instead of looking
+`x` up directly (and finding both fields), lookupRecFieldOcc will
+search the fields of `MkS` to find the only possible `x` the user can
+mean.
+
+Of course, we still have to check the field is in scope, using
+lookupGRE_FieldLabel.  The handling of qualified imports is slightly
+subtle: the occurrence may be unqualified even if the field is
+imported only qualified (but if the occurrence is qualified, the
+qualifier must be correct). For example:
+
+   module A where
+     data S = MkS { x :: Int }
+     data T = MkT { x :: Int }
+
+   module B where
+     import qualified A (S(..))
+     import A (T(MkT))
+
+     e1 = MkT   { x = 3 }   -- x not in scope, so fail
+     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail
+     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)
+
+In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,
+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard
+will fail because the field RdrName `B.x` is qualified and pickGREs
+rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the
+GRE for `A.x` and the guard will succeed because the field RdrName `x`
+is unqualified.
+
+
+Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whenever we fail to find the field or it is not in scope, mb_field
+will be False, and we fall back on looking it up normally using
+lookupGlobalOccRn.  We don't report an error immediately because the
+actual problem might be located elsewhere.  For example (#9975):
+
+   data Test = Test { x :: Int }
+   pattern Test wat = Test { x = wat }
+
+Here there are multiple declarations of Test (as a data constructor
+and as a pattern synonym), which will be reported as an error.  We
+shouldn't also report an error about the occurrence of `x` in the
+pattern synonym RHS.  However, if the pattern synonym gets added to
+the environment first, we will try and fail to find `x` amongst the
+(nonexistent) fields of the pattern synonym.
+
+Alternatively, the scope check can fail due to Template Haskell.
+Consider (#12130):
+
+   module Foo where
+     import M
+     b = $(funny)
+
+   module M(funny) where
+     data T = MkT { x :: Int }
+     funny :: Q Exp
+     funny = [| MkT { x = 3 } |]
+
+When we splice, `MkT` is not lexically in scope, so
+lookupGRE_FieldLabel will fail.  But there is no need for
+disambiguation anyway, because `x` is an original name, and
+lookupGlobalOccRn will find it.
+-}
+
+
+
+-- | Used in export lists to lookup the children.
+lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName
+                        -> RnM ChildLookupResult
+lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
+  | isUnboundName parent
+    -- Avoid an error cascade
+  = return (FoundName NoParent (mkUnboundNameRdr rdr_name))
+
+  | otherwise = do
+  gre_env <- getGlobalRdrEnv
+
+  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)
+  -- Disambiguate the lookup based on the parent information.
+  -- The remaining GREs are things that we *could* export here, note that
+  -- this includes things which have `NoParent`. Those are sorted in
+  -- `checkPatSynParent`.
+  traceRn "parent" (ppr parent)
+  traceRn "lookupExportChild original_gres:" (ppr original_gres)
+  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)
+  case picked_gres original_gres of
+    NoOccurrence ->
+      noMatchingParentErr original_gres
+    UniqueOccurrence g ->
+      if must_have_parent then noMatchingParentErr original_gres
+                          else checkFld g
+    DisambiguatedOccurrence g ->
+      checkFld g
+    AmbiguousOccurrence gres ->
+      mkNameClashErr gres
+    where
+        -- Convert into FieldLabel if necessary
+        checkFld :: GlobalRdrElt -> RnM ChildLookupResult
+        checkFld g@GRE{gre_name, gre_par} = do
+          addUsedGRE warn_if_deprec g
+          return $ case gre_par of
+            FldParent _ mfs ->
+              FoundFL  (fldParentToFieldLabel gre_name mfs)
+            _ -> FoundName gre_par gre_name
+
+        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel
+        fldParentToFieldLabel name mfs =
+          case mfs of
+            Nothing ->
+              let fs = occNameFS (nameOccName name)
+              in FieldLabel fs False name
+            Just fs -> FieldLabel fs True name
+
+        -- Called when we find no matching GREs after disambiguation but
+        -- there are three situations where this happens.
+        -- 1. There were none to begin with.
+        -- 2. None of the matching ones were the parent but
+        --  a. They were from an overloaded record field so we can report
+        --     a better error
+        --  b. The original lookup was actually ambiguous.
+        --     For example, the case where overloading is off and two
+        --     record fields are in scope from different record
+        --     constructors, neither of which is the parent.
+        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult
+        noMatchingParentErr original_gres = do
+          overload_ok <- xoptM LangExt.DuplicateRecordFields
+          case original_gres of
+            [] ->  return NameNotFound
+            [g] -> return $ IncorrectParent parent
+                              (gre_name g) (ppr $ gre_name g)
+                              [p | Just p <- [getParent g]]
+            gss@(g:_:_) ->
+              if all isRecFldGRE gss && overload_ok
+                then return $
+                      IncorrectParent parent
+                        (gre_name g)
+                        (ppr $ expectJust "noMatchingParentErr" (greLabel g))
+                        [p | x <- gss, Just p <- [getParent x]]
+                else mkNameClashErr gss
+
+        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult
+        mkNameClashErr gres = do
+          addNameClashErrRn rdr_name gres
+          return (FoundName (gre_par (head gres)) (gre_name (head gres)))
+
+        getParent :: GlobalRdrElt -> Maybe Name
+        getParent (GRE { gre_par = p } ) =
+          case p of
+            ParentIs cur_parent -> Just cur_parent
+            FldParent { par_is = cur_parent } -> Just cur_parent
+            NoParent -> Nothing
+
+        picked_gres :: [GlobalRdrElt] -> DisambigInfo
+        -- For Unqual, find GREs that are in scope qualified or unqualified
+        -- For Qual,   find GREs that are in scope with that qualification
+        picked_gres gres
+          | isUnqual rdr_name
+          = mconcat (map right_parent gres)
+          | otherwise
+          = mconcat (map right_parent (pickGREs rdr_name gres))
+
+        right_parent :: GlobalRdrElt -> DisambigInfo
+        right_parent p
+          = case getParent p of
+               Just cur_parent
+                  | parent == cur_parent -> DisambiguatedOccurrence p
+                  | otherwise            -> NoOccurrence
+               Nothing                   -> UniqueOccurrence p
+
+
+-- This domain specific datatype is used to record why we decided it was
+-- possible that a GRE could be exported with a parent.
+data DisambigInfo
+       = NoOccurrence
+          -- The GRE could never be exported. It has the wrong parent.
+       | UniqueOccurrence GlobalRdrElt
+          -- The GRE has no parent. It could be a pattern synonym.
+       | DisambiguatedOccurrence GlobalRdrElt
+          -- The parent of the GRE is the correct parent
+       | AmbiguousOccurrence [GlobalRdrElt]
+          -- For example, two normal identifiers with the same name are in
+          -- scope. They will both be resolved to "UniqueOccurrence" and the
+          -- monoid will combine them to this failing case.
+
+instance Outputable DisambigInfo where
+  ppr NoOccurrence = text "NoOccurence"
+  ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre
+  ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre
+  ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres
+
+instance Semi.Semigroup DisambigInfo where
+  -- This is the key line: We prefer disambiguated occurrences to other
+  -- names.
+  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
+  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
+
+  NoOccurrence <> m = m
+  m <> NoOccurrence = m
+  UniqueOccurrence g <> UniqueOccurrence g'
+    = AmbiguousOccurrence [g, g']
+  UniqueOccurrence g <> AmbiguousOccurrence gs
+    = AmbiguousOccurrence (g:gs)
+  AmbiguousOccurrence gs <> UniqueOccurrence g'
+    = AmbiguousOccurrence (g':gs)
+  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'
+    = AmbiguousOccurrence (gs ++ gs')
+
+instance Monoid DisambigInfo where
+  mempty = NoOccurrence
+  mappend = (Semi.<>)
+
+-- Lookup SubBndrOcc can never be ambiguous
+--
+-- Records the result of looking up a child.
+data ChildLookupResult
+      = NameNotFound                --  We couldn't find a suitable name
+      | IncorrectParent Name        -- Parent
+                        Name        -- Name of thing we were looking for
+                        SDoc        -- How to print the name
+                        [Name]      -- List of possible parents
+      | FoundName Parent Name       --  We resolved to a normal name
+      | FoundFL FieldLabel          --  We resolved to a FL
+
+-- | Specialised version of msum for RnM ChildLookupResult
+combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult
+combineChildLookupResult [] = return NameNotFound
+combineChildLookupResult (x:xs) = do
+  res <- x
+  case res of
+    NameNotFound -> combineChildLookupResult xs
+    _ -> return res
+
+instance Outputable ChildLookupResult where
+  ppr NameNotFound = text "NameNotFound"
+  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n
+  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls
+  ppr (IncorrectParent p n td ns) = text "IncorrectParent"
+                                  <+> hsep [ppr p, ppr n, td, ppr ns]
+
+lookupSubBndrOcc :: Bool
+                 -> Name     -- Parent
+                 -> SDoc
+                 -> RdrName
+                 -> RnM (Either MsgDoc Name)
+-- Find all the things the rdr-name maps to
+-- and pick the one with the right parent namep
+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
+  res <-
+    lookupExactOrOrig rdr_name (FoundName NoParent) $
+      -- This happens for built-in classes, see mod052 for example
+      lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name
+  case res of
+    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))
+    FoundName _p n -> return (Right n)
+    FoundFL fl  ->  return (Right (flSelector fl))
+    IncorrectParent {}
+         -- See [Mismatched class methods and associated type families]
+         -- in TcInstDecls.
+      -> return $ Left (unknownSubordinateErr doc rdr_name)
+
+{-
+Note [Family instance binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data family F a
+  data instance F T = X1 | X2
+
+The 'data instance' decl has an *occurrence* of F (and T), and *binds*
+X1 and X2.  (This is unlike a normal data type declaration which would
+bind F too.)  So we want an AvailTC F [X1,X2].
+
+Now consider a similar pair:
+  class C a where
+    data G a
+  instance C S where
+    data G S = Y1 | Y2
+
+The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
+
+But there is a small complication: in an instance decl, we don't use
+qualified names on the LHS; instead we use the class to disambiguate.
+Thus:
+  module M where
+    import Blib( G )
+    class C a where
+      data G a
+    instance C S where
+      data G S = Y1 | Y2
+Even though there are two G's in scope (M.G and Blib.G), the occurrence
+of 'G' in the 'instance C S' decl is unambiguous, because C has only
+one associated type called G. This is exactly what happens for methods,
+and it is only consistent to do the same thing for types. That's the
+role of the function lookupTcdName; the (Maybe Name) give the class of
+the encloseing instance decl, if any.
+
+Note [Looking up Exact RdrNames]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exact RdrNames are generated by Template Haskell.  See Note [Binders
+in Template Haskell] in Convert.
+
+For data types and classes have Exact system Names in the binding
+positions for constructors, TyCons etc.  For example
+    [d| data T = MkT Int |]
+when we splice in and Convert to HsSyn RdrName, we'll get
+    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...
+These System names are generated by Convert.thRdrName
+
+But, constructors and the like need External Names, not System Names!
+So we do the following
+
+ * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a
+   non-External Name, and make an External name for it. This is
+   the name that goes in the GlobalRdrEnv
+
+ * When looking up an occurrence of an Exact name, done in
+   RnEnv.lookupExactOcc, we find the Name with the right unique in the
+   GlobalRdrEnv, and use the one from the envt -- it will be an
+   External Name in the case of the data type/constructor above.
+
+ * Exact names are also use for purely local binders generated
+   by TH, such as    \x_33. x_33
+   Both binder and occurrence are Exact RdrNames.  The occurrence
+   gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and
+   misses, because lookupLocalRdrEnv always returns Nothing for
+   an Exact Name.  Now we fall through to lookupExactOcc, which
+   will find the Name is not in the GlobalRdrEnv, so we just use
+   the Exact supplied Name.
+
+Note [Splicing Exact names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the splice $(do { x <- newName "x"; return (VarE x) })
+This will generate a (HsExpr RdrName) term that mentions the
+Exact RdrName "x_56" (or whatever), but does not bind it.  So
+when looking such Exact names we want to check that it's in scope,
+otherwise the type checker will get confused.  To do this we need to
+keep track of all the Names in scope, and the LocalRdrEnv does just that;
+we consult it with RdrName.inLocalRdrEnvScope.
+
+There is another wrinkle.  With TH and -XDataKinds, consider
+   $( [d| data Nat = Zero
+          data T = MkT (Proxy 'Zero)  |] )
+After splicing, but before renaming we get this:
+   data Nat_77{tc} = Zero_78{d}
+   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )
+The occurrence of 'Zero in the data type for T has the right unique,
+but it has a TcClsName name-space in its OccName.  (This is set by
+the ctxt_ns argument of Convert.thRdrName.)  When we check that is
+in scope in the GlobalRdrEnv, we need to look up the DataName namespace
+too.  (An alternative would be to make the GlobalRdrEnv also have
+a Name -> GRE mapping.)
+
+Note [Template Haskell ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The GlobalRdrEnv invariant says that if
+  occ -> [gre1, ..., gren]
+then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).
+This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).
+
+So how can we get multiple gres in lookupExactOcc_maybe?  Because in
+TH we might use the same TH NameU in two different name spaces.
+eg (#7241):
+   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])
+Here we generate a type constructor and data constructor with the same
+unique, but different name spaces.
+
+It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would
+mean looking up the OccName in every name-space, just in case, and that
+seems a bit brutal.  So it's just done here on lookup.  But we might
+need to revisit that choice.
+
+Note [Usage for sub-bndrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you have this
+   import qualified M( C( f ) )
+   instance M.C T where
+     f x = x
+then is the qualified import M.f used?  Obviously yes.
+But the RdrName used in the instance decl is unqualified.  In effect,
+we fill in the qualification by looking for f's whose class is M.C
+But when adding to the UsedRdrNames we must make that qualification
+explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".
+
+So we make up a suitable (fake) RdrName.  But be careful
+   import qualified M
+   import M( C(f) )
+   instance C T where
+     f x = x
+Here we want to record a use of 'f', not of 'M.f', otherwise
+we'll miss the fact that the qualified import is redundant.
+
+--------------------------------------------------
+--              Occurrences
+--------------------------------------------------
+-}
+
+
+lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
+lookupLocatedOccRn = wrapLocM lookupOccRn
+
+lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Just look in the local environment
+lookupLocalOccRn_maybe rdr_name
+  = do { local_env <- getLocalRdrEnv
+       ; return (lookupLocalRdrEnv local_env rdr_name) }
+
+lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
+-- Just look in the local environment
+lookupLocalOccThLvl_maybe name
+  = do { lcl_env <- getLclEnv
+       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
+
+-- lookupOccRn looks up an occurrence of a RdrName
+lookupOccRn :: RdrName -> RnM Name
+lookupOccRn rdr_name
+  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case mb_name of
+           Just name -> return name
+           Nothing   -> reportUnboundName rdr_name }
+
+-- Only used in one place, to rename pattern synonym binders.
+-- See Note [Renaming pattern synonym variables] in RnBinds
+lookupLocalOccRn :: RdrName -> RnM Name
+lookupLocalOccRn rdr_name
+  = do { mb_name <- lookupLocalOccRn_maybe rdr_name
+       ; case mb_name of
+           Just name -> return name
+           Nothing   -> unboundName WL_LocalOnly rdr_name }
+
+-- lookupPromotedOccRn looks up an optionally promoted RdrName.
+lookupTypeOccRn :: RdrName -> RnM Name
+-- see Note [Demotion]
+lookupTypeOccRn rdr_name
+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]
+  = badVarInType rdr_name
+  | otherwise
+  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case mb_name of
+             Just name -> return name
+             Nothing   -> lookup_demoted rdr_name }
+
+lookup_demoted :: RdrName -> RnM Name
+lookup_demoted rdr_name
+  | Just demoted_rdr <- demoteRdrName rdr_name
+    -- Maybe it's the name of a *data* constructor
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; star_is_type <- xoptM LangExt.StarIsType
+       ; let star_info = starInfo star_is_type rdr_name
+       ; if data_kinds
+            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
+                    ; case mb_demoted_name of
+                        Nothing -> unboundNameX WL_Any rdr_name star_info
+                        Just demoted_name ->
+                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $
+                               addWarn
+                                 (Reason Opt_WarnUntickedPromotedConstructors)
+                                 (untickedPromConstrWarn demoted_name)
+                             ; return demoted_name } }
+            else do { -- We need to check if a data constructor of this name is
+                      -- in scope to give good error messages. However, we do
+                      -- not want to give an additional error if the data
+                      -- constructor happens to be out of scope! See #13947.
+                      mb_demoted_name <- discardErrs $
+                                         lookupOccRn_maybe demoted_rdr
+                    ; let suggestion | isJust mb_demoted_name = suggest_dk
+                                     | otherwise = star_info
+                    ; unboundNameX WL_Any rdr_name suggestion } }
+
+  | otherwise
+  = reportUnboundName rdr_name
+
+  where
+    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"
+    untickedPromConstrWarn name =
+      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot
+      $$
+      hsep [ text "Use"
+           , quotes (char '\'' <> ppr name)
+           , text "instead of"
+           , quotes (ppr name) <> dot ]
+
+badVarInType :: RdrName -> RnM Name
+badVarInType rdr_name
+  = do { addErr (text "Illegal promoted term variable in a type:"
+                 <+> ppr rdr_name)
+       ; return (mkUnboundNameRdr rdr_name) }
+
+{- Note [Promoted variables in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#12686):
+   x = True
+   data Bad = Bad 'x
+
+The parser treats the quote in 'x as saying "use the term
+namespace", so we'll get (Bad x{v}), with 'x' in the
+VarName namespace.  If we don't test for this, the renamer
+will happily rename it to the x bound at top level, and then
+the typecheck falls over because it doesn't have 'x' in scope
+when kind-checking.
+
+Note [Demotion]
+~~~~~~~~~~~~~~~
+When the user writes:
+  data Nat = Zero | Succ Nat
+  foo :: f Zero -> Int
+
+'Zero' in the type signature of 'foo' is parsed as:
+  HsTyVar ("Zero", TcClsName)
+
+When the renamer hits this occurrence of 'Zero' it's going to realise
+that it's not in scope. But because it is renaming a type, it knows
+that 'Zero' might be a promoted data constructor, so it will demote
+its namespace to DataName and do a second lookup.
+
+The final result (after the renamer) will be:
+  HsTyVar ("Zero", DataName)
+-}
+
+lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName
+                   -> RnM (Maybe r)
+lookupOccRnX_maybe globalLookup wrapper rdr_name
+  = runMaybeT . msum . map MaybeT $
+      [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name
+      , globalLookup rdr_name ]
+
+lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
+lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id
+
+lookupOccRn_overloaded :: Bool -> RdrName
+                       -> RnM (Maybe (Either Name [Name]))
+lookupOccRn_overloaded overload_ok
+  = lookupOccRnX_maybe global_lookup Left
+      where
+        global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))
+        global_lookup n =
+          runMaybeT . msum . map MaybeT $
+            [ lookupGlobalOccRn_overloaded overload_ok n
+            , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]
+
+
+
+lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Looks up a RdrName occurrence in the top-level
+--   environment, including using lookupQualifiedNameGHCi
+--   for the GHCi case
+-- No filter function; does not report an error on failure
+-- Uses addUsedRdrName to record use and deprecations
+lookupGlobalOccRn_maybe rdr_name =
+  lookupExactOrOrig rdr_name Just $
+    runMaybeT . msum . map MaybeT $
+      [ fmap gre_name <$> lookupGreRn_maybe rdr_name
+      , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]
+                      -- This test is not expensive,
+                      -- and only happens for failed lookups
+
+lookupGlobalOccRn :: RdrName -> RnM Name
+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
+-- environment.  Adds an error message if the RdrName is not in scope.
+-- You usually want to use "lookupOccRn" which also looks in the local
+-- environment.
+lookupGlobalOccRn rdr_name
+  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name
+       ; case mb_name of
+           Just n  -> return n
+           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
+                         ; unboundName WL_Global rdr_name } }
+
+lookupInfoOccRn :: RdrName -> RnM [Name]
+-- lookupInfoOccRn is intended for use in GHCi's ":info" command
+-- It finds all the GREs that RdrName could mean, not complaining
+-- about ambiguity, but rather returning them all
+-- C.f. #9881
+lookupInfoOccRn rdr_name =
+  lookupExactOrOrig rdr_name (:[]) $
+    do { rdr_env <- getGlobalRdrEnv
+       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)
+       ; qual_ns <- lookupQualifiedNameGHCi rdr_name
+       ; return (ns ++ (qual_ns `minusList` ns)) }
+
+-- | Like 'lookupOccRn_maybe', but with a more informative result if
+-- the 'RdrName' happens to be a record selector:
+--
+--   * Nothing         -> name not in scope (no error reported)
+--   * Just (Left x)   -> name uniquely refers to x,
+--                        or there is a name clash (reported)
+--   * Just (Right xs) -> name refers to one or more record selectors;
+--                        if overload_ok was False, this list will be
+--                        a singleton.
+
+lookupGlobalOccRn_overloaded :: Bool -> RdrName
+                             -> RnM (Maybe (Either Name [Name]))
+lookupGlobalOccRn_overloaded overload_ok rdr_name =
+  lookupExactOrOrig rdr_name (Just . Left) $
+     do  { res <- lookupGreRn_helper rdr_name
+         ; case res of
+                GreNotFound  -> return Nothing
+                OneNameMatch gre -> do
+                  let wrapper = if isRecFldGRE gre then Right . (:[]) else Left
+                  return $ Just (wrapper (gre_name gre))
+                MultipleNames gres  | all isRecFldGRE gres && overload_ok ->
+                  -- Don't record usage for ambiguous selectors
+                  -- until we know which is meant
+                  return $ Just (Right (map gre_name gres))
+                MultipleNames gres  -> do
+                  addNameClashErrRn rdr_name gres
+                  return (Just (Left (gre_name (head gres)))) }
+
+
+--------------------------------------------------
+--      Lookup in the Global RdrEnv of the module
+--------------------------------------------------
+
+data GreLookupResult = GreNotFound
+                     | OneNameMatch GlobalRdrElt
+                     | MultipleNames [GlobalRdrElt]
+
+lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
+-- Look up the RdrName in the GlobalRdrEnv
+--   Exactly one binding: records it as "used", return (Just gre)
+--   No bindings:         return Nothing
+--   Many bindings:       report "ambiguous", return an arbitrary (Just gre)
+-- Uses addUsedRdrName to record use and deprecations
+lookupGreRn_maybe rdr_name
+  = do
+      res <- lookupGreRn_helper rdr_name
+      case res of
+        OneNameMatch gre ->  return $ Just gre
+        MultipleNames gres -> do
+          traceRn "lookupGreRn_maybe:NameClash" (ppr gres)
+          addNameClashErrRn rdr_name gres
+          return $ Just (head gres)
+        GreNotFound -> return Nothing
+
+{-
+
+Note [ Unbound vs Ambiguous Names ]
+
+lookupGreRn_maybe deals with failures in two different ways. If a name
+is unbound then we return a `Nothing` but if the name is ambiguous
+then we raise an error and return a dummy name.
+
+The reason for this is that when we call `lookupGreRn_maybe` we are
+speculatively looking for whatever we are looking up. If we don't find it,
+then we might have been looking for the wrong thing and can keep trying.
+On the other hand, if we find a clash then there is no way to recover as
+we found the thing we were looking for but can no longer resolve which
+the correct one is.
+
+One example of this is in `lookupTypeOccRn` which first looks in the type
+constructor namespace before looking in the data constructor namespace to
+deal with `DataKinds`.
+
+There is however, as always, one exception to this scheme. If we find
+an ambiguous occurence of a record selector and DuplicateRecordFields
+is enabled then we defer the selection until the typechecker.
+
+-}
+
+
+
+
+-- Internal Function
+lookupGreRn_helper :: RdrName -> RnM GreLookupResult
+lookupGreRn_helper rdr_name
+  = do  { env <- getGlobalRdrEnv
+        ; case lookupGRE_RdrName rdr_name env of
+            []    -> return GreNotFound
+            [gre] -> do { addUsedGRE True gre
+                        ; return (OneNameMatch gre) }
+            gres  -> return (MultipleNames gres) }
+
+lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
+-- Used in export lists
+-- If not found or ambiguous, add error message, and fake with UnboundName
+-- Uses addUsedRdrName to record use and deprecations
+lookupGreAvailRn rdr_name
+  = do
+      mb_gre <- lookupGreRn_helper rdr_name
+      case mb_gre of
+        GreNotFound ->
+          do
+            traceRn "lookupGreAvailRn" (ppr rdr_name)
+            name <- unboundName WL_Global rdr_name
+            return (name, avail name)
+        MultipleNames gres ->
+          do
+            addNameClashErrRn rdr_name gres
+            let unbound_name = mkUnboundNameRdr rdr_name
+            return (unbound_name, avail unbound_name)
+                        -- Returning an unbound name here prevents an error
+                        -- cascade
+        OneNameMatch gre ->
+          return (gre_name gre, availFromGRE gre)
+
+
+{-
+*********************************************************
+*                                                      *
+                Deprecations
+*                                                      *
+*********************************************************
+
+Note [Handling of deprecations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* We report deprecations at each *occurrence* of the deprecated thing
+  (see #5867)
+
+* We do not report deprecations for locally-defined names. For a
+  start, we may be exporting a deprecated thing. Also we may use a
+  deprecated thing in the defn of another deprecated things.  We may
+  even use a deprecated thing in the defn of a non-deprecated thing,
+  when changing a module's interface.
+
+* addUsedGREs: we do not report deprecations for sub-binders:
+     - the ".." completion for records
+     - the ".." in an export item 'T(..)'
+     - the things exported by a module export 'module M'
+-}
+
+addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
+-- Remember use of in-scope data constructors (#7969)
+addUsedDataCons rdr_env tycon
+  = addUsedGREs [ gre
+                | dc <- tyConDataCons tycon
+                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
+
+addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()
+-- Called for both local and imported things
+-- Add usage *and* warn if deprecated
+addUsedGRE warn_if_deprec gre
+  = do { when warn_if_deprec (warnIfDeprecated gre)
+       ; unless (isLocalGRE gre) $
+         do { env <- getGblEnv
+            ; traceRn "addUsedGRE" (ppr gre)
+            ; updMutVar (tcg_used_gres env) (gre :) } }
+
+addUsedGREs :: [GlobalRdrElt] -> RnM ()
+-- Record uses of any *imported* GREs
+-- Used for recording used sub-bndrs
+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]
+addUsedGREs gres
+  | null imp_gres = return ()
+  | otherwise     = do { env <- getGblEnv
+                       ; traceRn "addUsedGREs" (ppr imp_gres)
+                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }
+  where
+    imp_gres = filterOut isLocalGRE gres
+
+warnIfDeprecated :: GlobalRdrElt -> RnM ()
+warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
+  | (imp_spec : _) <- iss
+  = do { dflags <- getDynFlags
+       ; this_mod <- getModule
+       ; when (wopt Opt_WarnWarningsDeprecations dflags &&
+               not (nameIsLocalOrFrom this_mod name)) $
+                   -- See Note [Handling of deprecations]
+         do { iface <- loadInterfaceForName doc name
+            ; case lookupImpDeprec iface gre of
+                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
+                                   (mk_msg imp_spec txt)
+                Nothing  -> return () } }
+  | otherwise
+  = return ()
+  where
+    occ = greOccName gre
+    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
+
+    mk_msg imp_spec txt
+      = sep [ sep [ text "In the use of"
+                    <+> pprNonVarNameSpace (occNameSpace occ)
+                    <+> quotes (ppr occ)
+                  , parens imp_msg <> colon ]
+            , pprWarningTxtForMsg txt ]
+      where
+        imp_mod  = importSpecModule imp_spec
+        imp_msg  = text "imported from" <+> ppr imp_mod <> extra
+        extra | imp_mod == moduleName name_mod = Outputable.empty
+              | otherwise = text ", but defined in" <+> ppr name_mod
+
+lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
+lookupImpDeprec iface gre
+  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,
+    case gre_par gre of                      -- or its parent, is warn'd
+       ParentIs  p              -> mi_warn_fn iface (nameOccName p)
+       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
+       NoParent                 -> Nothing
+
+{-
+Note [Used names with interface not loaded]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's (just) possible to find a used
+Name whose interface hasn't been loaded:
+
+a) It might be a WiredInName; in that case we may not load
+   its interface (although we could).
+
+b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
+   These are seen as "used" by the renamer (if -XRebindableSyntax)
+   is on), but the typechecker may discard their uses
+   if in fact the in-scope fromRational is GHC.Read.fromRational,
+   (see tcPat.tcOverloadedLit), and the typechecker sees that the type
+   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
+   In that obscure case it won't force the interface in.
+
+In both cases we simply don't permit deprecations;
+this is, after all, wired-in stuff.
+
+
+*********************************************************
+*                                                      *
+                GHCi support
+*                                                      *
+*********************************************************
+
+A qualified name on the command line can refer to any module at
+all: we try to load the interface if we don't already have it, just
+as if there was an "import qualified M" declaration for every
+module.
+
+For example, writing `Data.List.sort` will load the interface file for
+`Data.List` as if the user had written `import qualified Data.List`.
+
+If we fail we just return Nothing, rather than bleating
+about "attempting to use module ‘D’ (./D.hs) which is not loaded"
+which is what loadSrcInterface does.
+
+It is enabled by default and disabled by the flag
+`-fno-implicit-import-qualified`.
+
+Note [Safe Haskell and GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We DON'T do this Safe Haskell as we need to check imports. We can
+and should instead check the qualified import but at the moment
+this requires some refactoring so leave as a TODO
+-}
+
+
+
+lookupQualifiedNameGHCi :: RdrName -> RnM [Name]
+lookupQualifiedNameGHCi rdr_name
+  = -- We want to behave as we would for a source file import here,
+    -- and respect hiddenness of modules/packages, hence loadSrcInterface.
+    do { dflags  <- getDynFlags
+       ; is_ghci <- getIsGHCi
+       ; go_for_it dflags is_ghci }
+
+  where
+    go_for_it dflags is_ghci
+      | Just (mod,occ) <- isQual_maybe rdr_name
+      , is_ghci
+      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour
+      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]
+      = do { res <- loadSrcInterface_maybe doc mod False Nothing
+           ; case res of
+                Succeeded iface
+                  -> return [ name
+                            | avail <- mi_exports iface
+                            , name  <- availNames avail
+                            , nameOccName name == occ ]
+
+                _ -> -- Either we couldn't load the interface, or
+                     -- we could but we didn't find the name in it
+                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)
+                        ; return [] } }
+
+      | otherwise
+      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)
+           ; return [] }
+
+    doc = text "Need to find" <+> ppr rdr_name
+
+{-
+Note [Looking up signature names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupSigOccRn is used for type signatures and pragmas
+Is this valid?
+  module A
+        import M( f )
+        f :: Int -> Int
+        f x = x
+It's clear that the 'f' in the signature must refer to A.f
+The Haskell98 report does not stipulate this, but it will!
+So we must treat the 'f' in the signature in the same way
+as the binding occurrence of 'f', using lookupBndrRn
+
+However, consider this case:
+        import M( f )
+        f :: Int -> Int
+        g x = x
+We don't want to say 'f' is out of scope; instead, we want to
+return the imported 'f', so that later on the renamer will
+correctly report "misplaced type sig".
+
+Note [Signatures for top level things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+data HsSigCtxt = ... | TopSigCtxt NameSet | ....
+
+* The NameSet says what is bound in this group of bindings.
+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:
+       f x = x
+       $( ...some TH splice... )
+       f :: Int -> Int
+  When we encounter the signature for 'f', the binding for 'f'
+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the
+  signature is mis-placed
+
+* For type signatures the NameSet should be the names bound by the
+  value bindings; for fixity declarations, the NameSet should also
+  include class sigs and record selectors
+
+      infix 3 `f`          -- Yes, ok
+      f :: C a => a -> a   -- No, not ok
+      class C a where
+        f :: a -> a
+-}
+
+data HsSigCtxt
+  = TopSigCtxt NameSet       -- At top level, binding these names
+                             -- See Note [Signatures for top level things]
+  | LocalBindCtxt NameSet    -- In a local binding, binding these names
+  | ClsDeclCtxt   Name       -- Class decl for this class
+  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method
+                             -- bindings are for these methods
+  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names
+  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types
+                             -- in the group
+
+instance Outputable HsSigCtxt where
+    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns
+    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns
+    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n
+    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns
+    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns
+    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns
+
+lookupSigOccRn :: HsSigCtxt
+               -> Sig GhcPs
+               -> Located RdrName -> RnM (Located Name)
+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
+
+-- | Lookup a name in relation to the names in a 'HsSigCtxt'
+lookupSigCtxtOccRn :: HsSigCtxt
+                   -> SDoc         -- ^ description of thing we're looking up,
+                                   -- like "type family"
+                   -> Located RdrName -> RnM (Located Name)
+lookupSigCtxtOccRn ctxt what
+  = wrapLocM $ \ rdr_name ->
+    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
+       ; case mb_name of
+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
+           Right name -> return name }
+
+lookupBindGroupOcc :: HsSigCtxt
+                   -> SDoc
+                   -> RdrName -> RnM (Either MsgDoc Name)
+-- Looks up the RdrName, expecting it to resolve to one of the
+-- bound names passed in.  If not, return an appropriate error message
+--
+-- See Note [Looking up signature names]
+lookupBindGroupOcc ctxt what rdr_name
+  | Just n <- isExact_maybe rdr_name
+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;
+                              -- see Note [dataTcOccs and Exact Names]
+      -- Maybe we should check the side conditions
+      -- but it's a pain, and Exact things only show
+      -- up when you know what you are doing
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do { n' <- lookupOrig rdr_mod rdr_occ
+       ; return (Right n') }
+
+  | otherwise
+  = case ctxt of
+      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)
+      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)
+      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
+      LocalBindCtxt ns -> lookup_group ns
+      ClsDeclCtxt  cls -> lookup_cls_op cls
+      InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)
+  where
+    lookup_cls_op cls
+      = lookupSubBndrOcc True cls doc rdr_name
+      where
+        doc = text "method of class" <+> quotes (ppr cls)
+
+    lookup_top keep_me
+      = do { env <- getGlobalRdrEnv
+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
+           ; let candidates_msg = candidates $ map gre_name
+                                             $ filter isLocalGRE
+                                             $ globalRdrEnvElts env
+           ; case filter (keep_me . gre_name) all_gres of
+               [] | null all_gres -> bale_out_with candidates_msg
+                  | otherwise     -> bale_out_with local_msg
+               (gre:_)            -> return (Right (gre_name gre)) }
+
+    lookup_group bound_names  -- Look in the local envt (not top level)
+      = do { mname <- lookupLocalOccRn_maybe rdr_name
+           ; env <- getLocalRdrEnv
+           ; let candidates_msg = candidates $ localRdrEnvElts env
+           ; case mname of
+               Just n
+                 | n `elemNameSet` bound_names -> return (Right n)
+                 | otherwise                   -> bale_out_with local_msg
+               Nothing                         -> bale_out_with candidates_msg }
+
+    bale_out_with msg
+        = return (Left (sep [ text "The" <+> what
+                                <+> text "for" <+> quotes (ppr rdr_name)
+                           , nest 2 $ text "lacks an accompanying binding"]
+                       $$ nest 2 msg))
+
+    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")
+                           <+> quotes (ppr rdr_name) <+> text "is declared"
+
+    -- Identify all similar names and produce a message listing them
+    candidates :: [Name] -> MsgDoc
+    candidates names_in_scope
+      = case similar_names of
+          []  -> Outputable.empty
+          [n] -> text "Perhaps you meant" <+> pp_item n
+          _   -> sep [ text "Perhaps you meant one of these:"
+                     , nest 2 (pprWithCommas pp_item similar_names) ]
+      where
+        similar_names
+          = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)
+                        $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))
+                              names_in_scope
+
+        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x)
+
+
+---------------
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
+-- GHC extension: look up both the tycon and data con or variable.
+-- Used for top-level fixity signatures and deprecations.
+-- Complain if neither is in scope.
+-- See Note [Fixity signature lookup]
+lookupLocalTcNames ctxt what rdr_name
+  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
+       ; let (errs, names) = partitionEithers mb_gres
+       ; when (null names) $ addErr (head errs) -- Bleat about one only
+       ; return names }
+  where
+    lookup rdr = do { this_mod <- getModule
+                    ; nameEither <- lookupBindGroupOcc ctxt what rdr
+                    ; return (guard_builtin_syntax this_mod rdr nameEither) }
+
+    -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233
+    guard_builtin_syntax this_mod rdr (Right name)
+      | Just _ <- isBuiltInOcc_maybe (occName rdr)
+      , this_mod /= nameModule name
+      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])
+      | otherwise
+      = Right (rdr, name)
+    guard_builtin_syntax _ _ (Left err) = Left err
+
+dataTcOccs :: RdrName -> [RdrName]
+-- Return both the given name and the same name promoted to the TcClsName
+-- namespace.  This is useful when we aren't sure which we are looking at.
+-- See also Note [dataTcOccs and Exact Names]
+dataTcOccs rdr_name
+  | isDataOcc occ || isVarOcc occ
+  = [rdr_name, rdr_name_tc]
+  | otherwise
+  = [rdr_name]
+  where
+    occ = rdrNameOcc rdr_name
+    rdr_name_tc = setRdrNameSpace rdr_name tcName
+
+{-
+Note [dataTcOccs and Exact Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exact RdrNames can occur in code generated by Template Haskell, and generally
+those references are, well, exact. However, the TH `Name` type isn't expressive
+enough to always track the correct namespace information, so we sometimes get
+the right Unique but wrong namespace. Thus, we still have to do the double-lookup
+for Exact RdrNames.
+
+There is also an awkward situation for built-in syntax. Example in GHCi
+   :info []
+This parses as the Exact RdrName for nilDataCon, but we also want
+the list type constructor.
+
+Note that setRdrNameSpace on an Exact name requires the Name to be External,
+which it always is for built in syntax.
+-}
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Rebindable names
+        Dealing with rebindable syntax is driven by the
+        Opt_RebindableSyntax dynamic flag.
+
+        In "deriving" code we don't want to use rebindable syntax
+        so we switch off the flag locally
+
+*                                                                      *
+************************************************************************
+
+Haskell 98 says that when you say "3" you get the "fromInteger" from the
+Standard Prelude, regardless of what is in scope.   However, to experiment
+with having a language that is less coupled to the standard prelude, we're
+trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"
+happens to be in scope.  Then you can
+        import Prelude ()
+        import MyPrelude as Prelude
+to get the desired effect.
+
+At the moment this just happens for
+  * fromInteger, fromRational on literals (in expressions and patterns)
+  * negate (in expressions)
+  * minus  (arising from n+k patterns)
+  * "do" notation
+
+We store the relevant Name in the HsSyn tree, in
+  * HsIntegral/HsFractional/HsIsString
+  * NegApp
+  * NPlusKPat
+  * HsDo
+respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,
+fromRationalName etc), but the renamer changes this to the appropriate user
+name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.
+
+We treat the original (standard) names as free-vars too, because the type checker
+checks the type of the user thing against the type of the standard thing.
+-}
+
+lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
+-- Different to lookupSyntaxName because in the non-rebindable
+-- case we desugar directly rather than calling an existing function
+-- Hence the (Maybe (SyntaxExpr GhcRn)) return type
+lookupIfThenElse
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on
+         then return (Nothing, emptyFVs)
+         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
+                 ; return ( Just (mkRnSyntaxExpr ite)
+                          , unitFV ite ) } }
+
+lookupSyntaxName' :: Name          -- ^ The standard name
+                  -> RnM Name      -- ^ Possibly a non-standard name
+lookupSyntaxName' std_name
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on then
+           return std_name
+         else
+            -- Get the similarly named thing from the local environment
+           lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
+
+lookupSyntaxName :: Name                             -- The standard name
+                 -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
+                                                     -- name
+lookupSyntaxName std_name
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on then
+           return (mkRnSyntaxExpr std_name, emptyFVs)
+         else
+            -- Get the similarly named thing from the local environment
+           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }
+
+lookupSyntaxNames :: [Name]                         -- Standard names
+     -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames
+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs
+lookupSyntaxNames std_names
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on then
+             return (map (HsVar noExt . noLoc) std_names, emptyFVs)
+        else
+          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
+             ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }
+
+-- Error messages
+
+
+opDeclErr :: RdrName -> SDoc
+opDeclErr n
+  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
+       2 (text "Use TypeOperators to declare operators in type and declarations")
+
+badOrigBinding :: RdrName -> SDoc
+badOrigBinding name
+  | Just _ <- isBuiltInOcc_maybe occ
+  = text "Illegal binding of built-in syntax:" <+> ppr occ
+    -- Use an OccName here because we don't want to print Prelude.(,)
+  | otherwise
+  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"
+    <+> ppr name
+    -- This can happen when one tries to use a Template Haskell splice to
+    -- define a top-level identifier with an already existing name, e.g.,
+    --
+    --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])
+    --
+    -- (See #13968.)
+  where
+    occ = rdrNameOcc $ filterCTuple name
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnExpr.hs
@@ -0,0 +1,2141 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnExpr]{Renaming of expressions}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnExpr (
+        rnLExpr, rnExpr, rnStmts
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)
+import HsSyn
+import TcEnv            ( isBrackStage )
+import TcRnMonad
+import Module           ( getModule )
+import RnEnv
+import RnFixity
+import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames
+                        , bindLocalNames
+                        , mapMaybeFvRn, mapFvRn
+                        , warnUnusedLocalBinds, typeAppErr
+                        , checkUnusedRecordWildcard )
+import RnUnbound        ( reportUnboundName )
+import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
+import RnTypes
+import RnPat
+import DynFlags
+import PrelNames
+
+import BasicTypes
+import Name
+import NameSet
+import RdrName
+import UniqSet
+import Data.List
+import Util
+import ListSetOps       ( removeDups )
+import ErrUtils
+import Outputable
+import SrcLoc
+import FastString
+import Control.Monad
+import TysWiredIn       ( nilDataConName )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Ord
+import Data.Array
+import qualified Data.List.NonEmpty as NE
+
+import Unique           ( mkVarOccUnique )
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Expressions}
+*                                                                      *
+************************************************************************
+-}
+
+rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
+rnExprs ls = rnExprs' ls emptyUniqSet
+ where
+  rnExprs' [] acc = return ([], acc)
+  rnExprs' (expr:exprs) acc =
+   do { (expr', fvExpr) <- rnLExpr expr
+        -- Now we do a "seq" on the free vars because typically it's small
+        -- or empty, especially in very long lists of constants
+      ; let  acc' = acc `plusFV` fvExpr
+      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
+      ; return (expr':exprs', fvExprs) }
+
+-- Variables. We look up the variable and return the resulting name.
+
+rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
+rnLExpr = wrapLocFstM rnExpr
+
+rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+
+finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
+-- Separated from rnExpr because it's also used
+-- when renaming infix expressions
+finishHsVar (L l name)
+ = do { this_mod <- getModule
+      ; when (nameIsLocalOrFrom this_mod name) $
+        checkThLocalName name
+      ; return (HsVar noExt (L l name), unitFV name) }
+
+rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
+rnUnboundVar v
+ = do { if isUnqual v
+        then -- Treat this as a "hole"
+             -- Do not fail right now; instead, return HsUnboundVar
+             -- and let the type checker report the error
+             do { let occ = rdrNameOcc v
+                ; uv <- if startsWithUnderscore occ
+                        then return (TrueExprHole occ)
+                        else OutOfScope occ <$> getGlobalRdrEnv
+                ; return (HsUnboundVar noExt uv, emptyFVs) }
+
+        else -- Fail immediately (qualified name)
+             do { n <- reportUnboundName v
+                ; return (HsVar noExt (noLoc n), emptyFVs) } }
+
+rnExpr (HsVar _ (L l v))
+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
+       ; case mb_name of {
+           Nothing -> rnUnboundVar v ;
+           Just (Left name)
+              | name == nilDataConName -- Treat [] as an ExplicitList, so that
+                                       -- OverloadedLists works correctly
+              -> rnExpr (ExplicitList noExt Nothing [])
+
+              | otherwise
+              -> finishHsVar (L l name) ;
+            Just (Right [s]) ->
+              return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;
+           Just (Right fs@(_:_:_)) ->
+              return ( HsRecFld noExt (Ambiguous noExt (L l v))
+                     , mkFVs fs);
+           Just (Right [])         -> panic "runExpr/HsVar" } }
+
+rnExpr (HsIPVar x v)
+  = return (HsIPVar x v, emptyFVs)
+
+rnExpr (HsUnboundVar x v)
+  = return (HsUnboundVar x v, emptyFVs)
+
+rnExpr (HsOverLabel x _ v)
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if rebindable_on
+         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
+                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
+         else return (HsOverLabel x Nothing v, emptyFVs) }
+
+rnExpr (HsLit x lit@(HsString src s))
+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
+       ; if opt_OverloadedStrings then
+            rnExpr (HsOverLit x (mkHsIsString src s))
+         else do {
+            ; rnLit lit
+            ; return (HsLit x (convertLit lit), emptyFVs) } }
+
+rnExpr (HsLit x lit)
+  = do { rnLit lit
+       ; return (HsLit x(convertLit lit), emptyFVs) }
+
+rnExpr (HsOverLit x lit)
+  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
+       ; case mb_neg of
+              Nothing -> return (HsOverLit x lit', fvs)
+              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))
+                                 , fvs ) }
+
+rnExpr (HsApp x fun arg)
+  = do { (fun',fvFun) <- rnLExpr fun
+       ; (arg',fvArg) <- rnLExpr arg
+       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
+
+rnExpr (HsAppType x fun arg)
+  = do { type_app <- xoptM LangExt.TypeApplications
+       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
+       ; (fun',fvFun) <- rnLExpr fun
+       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
+       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
+
+rnExpr (OpApp _ e1 op e2)
+  = do  { (e1', fv_e1) <- rnLExpr e1
+        ; (e2', fv_e2) <- rnLExpr e2
+        ; (op', fv_op) <- rnLExpr op
+
+        -- Deal with fixity
+        -- When renaming code synthesised from "deriving" declarations
+        -- we used to avoid fixity stuff, but we can't easily tell any
+        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
+        -- should prevent bad things happening.
+        ; fixity <- case op' of
+              L _ (HsVar _ (L _ n)) -> lookupFixityRn n
+              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f
+              _ -> return (Fixity NoSourceText minPrecedence InfixL)
+                   -- c.f. lookupFixity for unbound
+
+        ; final_e <- mkOpAppRn e1' op' fixity e2'
+        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
+
+rnExpr (NegApp _ e _)
+  = do { (e', fv_e)         <- rnLExpr e
+       ; (neg_name, fv_neg) <- lookupSyntaxName negateName
+       ; final_e            <- mkNegAppRn e' neg_name
+       ; return (final_e, fv_e `plusFV` fv_neg) }
+
+------------------------------------------
+-- Template Haskell extensions
+-- Don't ifdef-GHCI them because we want to fail gracefully
+-- (not with an rnExpr crash) in a stage-1 compiler.
+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
+
+rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
+
+---------------------------------------------
+--      Sections
+-- See Note [Parsing sections] in Parser.y
+rnExpr (HsPar x (L loc (section@(SectionL {}))))
+  = do  { (section', fvs) <- rnSection section
+        ; return (HsPar x (L loc section'), fvs) }
+
+rnExpr (HsPar x (L loc (section@(SectionR {}))))
+  = do  { (section', fvs) <- rnSection section
+        ; return (HsPar x (L loc section'), fvs) }
+
+rnExpr (HsPar x e)
+  = do  { (e', fvs_e) <- rnLExpr e
+        ; return (HsPar x e', fvs_e) }
+
+rnExpr expr@(SectionL {})
+  = do  { addErr (sectionErr expr); rnSection expr }
+rnExpr expr@(SectionR {})
+  = do  { addErr (sectionErr expr); rnSection expr }
+
+---------------------------------------------
+rnExpr (HsCoreAnn x src ann expr)
+  = do { (expr', fvs_expr) <- rnLExpr expr
+       ; return (HsCoreAnn x src ann expr', fvs_expr) }
+
+rnExpr (HsSCC x src lbl expr)
+  = do { (expr', fvs_expr) <- rnLExpr expr
+       ; return (HsSCC x src lbl expr', fvs_expr) }
+rnExpr (HsTickPragma x src info srcInfo expr)
+  = do { (expr', fvs_expr) <- rnLExpr expr
+       ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
+
+rnExpr (HsLam x matches)
+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
+       ; return (HsLam x matches', fvMatch) }
+
+rnExpr (HsLamCase x matches)
+  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
+       ; return (HsLamCase x matches', fvs_ms) }
+
+rnExpr (HsCase x expr matches)
+  = do { (new_expr, e_fvs) <- rnLExpr expr
+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
+       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+
+rnExpr (HsLet x (L l binds) expr)
+  = rnLocalBindsAndThen binds $ \binds' _ -> do
+      { (expr',fvExpr) <- rnLExpr expr
+      ; return (HsLet x (L l binds') expr', fvExpr) }
+
+rnExpr (HsDo x do_or_lc (L l stmts))
+  = do  { ((stmts', _), fvs) <-
+           rnStmtsWithPostProcessing do_or_lc rnLExpr
+             postProcessStmtsForApplicativeDo stmts
+             (\ _ -> return ((), emptyFVs))
+        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
+
+rnExpr (ExplicitList x _  exps)
+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
+        ; (exps', fvs) <- rnExprs exps
+        ; if opt_OverloadedLists
+           then do {
+            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
+            ; return (ExplicitList x (Just from_list_n_name) exps'
+                     , fvs `plusFV` fvs') }
+           else
+            return  (ExplicitList x Nothing exps', fvs) }
+
+rnExpr (ExplicitTuple x tup_args boxity)
+  = do { checkTupleSection tup_args
+       ; checkTupSize (length tup_args)
+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
+       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
+  where
+    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e
+                                      ; return (L l (Present x e'), fvs) }
+    rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
+                                        , emptyFVs)
+    rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
+
+rnExpr (ExplicitSum x alt arity expr)
+  = do { (expr', fvs) <- rnLExpr expr
+       ; return (ExplicitSum x alt arity expr', fvs) }
+
+rnExpr (RecordCon { rcon_con_name = con_id
+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
+       ; return (RecordCon { rcon_ext = noExt
+                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }
+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
+  where
+    mk_hs_var l n = HsVar noExt (L l n)
+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
+
+rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
+  = do  { (expr', fvExpr) <- rnLExpr expr
+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
+        ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'
+                            , rupd_flds = rbinds' }
+                 , fvExpr `plusFV` fvRbinds) }
+
+rnExpr (ExprWithTySig _ expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty
+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
+                             rnLExpr expr
+        ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }
+
+rnExpr (HsIf x _ p b1 b2)
+  = do { (p', fvP) <- rnLExpr p
+       ; (b1', fvB1) <- rnLExpr b1
+       ; (b2', fvB2) <- rnLExpr b2
+       ; (mb_ite, fvITE) <- lookupIfThenElse
+       ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+
+rnExpr (HsMultiIf x alts)
+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
+       -- ; return (HsMultiIf ty alts', fvs) }
+       ; return (HsMultiIf x alts', fvs) }
+
+rnExpr (ArithSeq x _ seq)
+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
+       ; (new_seq, fvs) <- rnArithSeq seq
+       ; if opt_OverloadedLists
+           then do {
+            ; (from_list_name, fvs') <- lookupSyntaxName fromListName
+            ; return (ArithSeq x (Just from_list_name) new_seq
+                     , fvs `plusFV` fvs') }
+           else
+            return (ArithSeq x Nothing new_seq, fvs) }
+
+{-
+************************************************************************
+*                                                                      *
+        Static values
+*                                                                      *
+************************************************************************
+
+For the static form we check that it is not used in splices.
+We also collect the free variables of the term which come from
+this module. See Note [Grand plan for static forms] in StaticPtrTable.
+-}
+
+rnExpr e@(HsStatic _ expr) = do
+    -- Normally, you wouldn't be able to construct a static expression without
+    -- first enabling -XStaticPointers in the first place, since that extension
+    -- is what makes the parser treat `static` as a keyword. But this is not a
+    -- sufficient safeguard, as one can construct static expressions by another
+    -- mechanism: Template Haskell (see #14204). To ensure that GHC is
+    -- absolutely prepared to cope with static forms, we check for
+    -- -XStaticPointers here as well.
+    unlessXOptM LangExt.StaticPointers $
+      addErr $ hang (text "Illegal static expression:" <+> ppr e)
+                  2 (text "Use StaticPointers to enable this extension")
+    (expr',fvExpr) <- rnLExpr expr
+    stage <- getStage
+    case stage of
+      Splice _ -> addErr $ sep
+             [ text "static forms cannot be used in splices:"
+             , nest 2 $ ppr e
+             ]
+      _ -> return ()
+    mod <- getModule
+    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
+    return (HsStatic fvExpr' expr', fvExpr)
+
+{-
+************************************************************************
+*                                                                      *
+        Arrow notation
+*                                                                      *
+************************************************************************
+-}
+
+rnExpr (HsProc x pat body)
+  = newArrowScope $
+    rnPat ProcExpr pat $ \ pat' -> do
+      { (body',fvBody) <- rnCmdTop body
+      ; return (HsProc x pat' body', fvBody) }
+
+rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
+        -- HsWrap
+
+----------------------
+-- See Note [Parsing sections] in Parser.y
+rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnSection section@(SectionR x op expr)
+  = do  { (op', fvs_op)     <- rnLExpr op
+        ; (expr', fvs_expr) <- rnLExpr expr
+        ; checkSectionPrec InfixR section op' expr'
+        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }
+
+rnSection section@(SectionL x expr op)
+  = do  { (expr', fvs_expr) <- rnLExpr expr
+        ; (op', fvs_op)     <- rnLExpr op
+        ; checkSectionPrec InfixL section op' expr'
+        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
+
+rnSection other = pprPanic "rnSection" (ppr other)
+
+{-
+************************************************************************
+*                                                                      *
+        Arrow commands
+*                                                                      *
+************************************************************************
+-}
+
+rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
+rnCmdArgs [] = return ([], emptyFVs)
+rnCmdArgs (arg:args)
+  = do { (arg',fvArg) <- rnCmdTop arg
+       ; (args',fvArgs) <- rnCmdArgs args
+       ; return (arg':args', fvArg `plusFV` fvArgs) }
+
+rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
+rnCmdTop = wrapLocFstM rnCmdTop'
+ where
+  rnCmdTop' (HsCmdTop _ cmd)
+   = do { (cmd', fvCmd) <- rnLCmd cmd
+        ; let cmd_names = [arrAName, composeAName, firstAName] ++
+                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))
+        -- Generate the rebindable syntax for the monad
+        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
+
+        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
+                  fvCmd `plusFV` cmd_fvs) }
+  rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
+
+rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
+rnLCmd = wrapLocFstM rnCmd
+
+rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
+
+rnCmd (HsCmdArrApp x arrow arg ho rtl)
+  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
+       ; (arg',fvArg) <- rnLExpr arg
+       ; return (HsCmdArrApp x arrow' arg' ho rtl,
+                 fvArrow `plusFV` fvArg) }
+  where
+    select_arrow_scope tc = case ho of
+        HsHigherOrderApp -> tc
+        HsFirstOrderApp  -> escapeArrowScope tc
+        -- See Note [Escaping the arrow scope] in TcRnTypes
+        -- Before renaming 'arrow', use the environment of the enclosing
+        -- proc for the (-<) case.
+        -- Local bindings, inside the enclosing proc, are not in scope
+        -- inside 'arrow'.  In the higher-order case (-<<), they are.
+
+-- infix form
+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
+  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
+       ; let L _ (HsVar _ (L _ op_name)) = op'
+       ; (arg1',fv_arg1) <- rnCmdTop arg1
+       ; (arg2',fv_arg2) <- rnCmdTop arg2
+        -- Deal with fixity
+       ; fixity <- lookupFixityRn op_name
+       ; final_e <- mkOpFormRn arg1' op' fixity arg2'
+       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
+
+rnCmd (HsCmdArrForm x op f fixity cmds)
+  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
+       ; (cmds',fvCmds) <- rnCmdArgs cmds
+       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }
+
+rnCmd (HsCmdApp x fun arg)
+  = do { (fun',fvFun) <- rnLCmd  fun
+       ; (arg',fvArg) <- rnLExpr arg
+       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
+
+rnCmd (HsCmdLam x matches)
+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
+       ; return (HsCmdLam x matches', fvMatch) }
+
+rnCmd (HsCmdPar x e)
+  = do  { (e', fvs_e) <- rnLCmd e
+        ; return (HsCmdPar x e', fvs_e) }
+
+rnCmd (HsCmdCase x expr matches)
+  = do { (new_expr, e_fvs) <- rnLExpr expr
+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
+       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+
+rnCmd (HsCmdIf x _ p b1 b2)
+  = do { (p', fvP) <- rnLExpr p
+       ; (b1', fvB1) <- rnLCmd b1
+       ; (b2', fvB2) <- rnLCmd b2
+       ; (mb_ite, fvITE) <- lookupIfThenElse
+       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
+
+rnCmd (HsCmdLet x (L l binds) cmd)
+  = rnLocalBindsAndThen binds $ \ binds' _ -> do
+      { (cmd',fvExpr) <- rnLCmd cmd
+      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }
+
+rnCmd (HsCmdDo x (L l stmts))
+  = do  { ((stmts', _), fvs) <-
+            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
+        ; return ( HsCmdDo x (L l stmts'), fvs ) }
+
+rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(XCmd {})      = pprPanic "rnCmd" (ppr cmd)
+
+---------------------------------------------------
+type CmdNeeds = FreeVars        -- Only inhabitants are
+                                --      appAName, choiceAName, loopAName
+
+-- find what methods the Cmd needs (loop, choice, apply)
+methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
+methodNamesLCmd = methodNamesCmd . unLoc
+
+methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
+
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
+  = emptyFVs
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
+  = unitFV appAName
+methodNamesCmd (HsCmdArrForm {}) = emptyFVs
+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
+
+methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c
+
+methodNamesCmd (HsCmdIf _ _ _ c1 c2)
+  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
+
+methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c
+methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c
+methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match
+
+methodNamesCmd (HsCmdCase _ _ matches)
+  = methodNamesMatch matches `addOneFV` choiceAName
+
+methodNamesCmd (XCmd {}) = panic "methodNamesCmd"
+
+--methodNamesCmd _ = emptyFVs
+   -- Other forms can't occur in commands, but it's not convenient
+   -- to error here so we just do what's convenient.
+   -- The type checker will complain later
+
+---------------------------------------------------
+methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
+methodNamesMatch (MG { mg_alts = L _ ms })
+  = plusFVs (map do_one ms)
+ where
+    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
+    do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"
+methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"
+
+-------------------------------------------------
+-- gaw 2004
+methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"
+
+-------------------------------------------------
+
+methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"
+
+---------------------------------------------------
+methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
+
+---------------------------------------------------
+methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
+methodNamesLStmt = methodNamesStmt . unLoc
+
+methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
+methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd
+methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd
+methodNamesStmt (RecStmt { recS_stmts = stmts }) =
+  methodNamesStmts stmts `addOneFV` loopAName
+methodNamesStmt (LetStmt {})                   = emptyFVs
+methodNamesStmt (ParStmt {})                   = emptyFVs
+methodNamesStmt (TransStmt {})                 = emptyFVs
+methodNamesStmt ApplicativeStmt{}              = emptyFVs
+   -- ParStmt and TransStmt can't occur in commands, but it's not
+   -- convenient to error here so we just do what's convenient
+methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"
+
+{-
+************************************************************************
+*                                                                      *
+        Arithmetic sequences
+*                                                                      *
+************************************************************************
+-}
+
+rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
+rnArithSeq (From expr)
+ = do { (expr', fvExpr) <- rnLExpr expr
+      ; return (From expr', fvExpr) }
+
+rnArithSeq (FromThen expr1 expr2)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+      ; (expr2', fvExpr2) <- rnLExpr expr2
+      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
+
+rnArithSeq (FromTo expr1 expr2)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+      ; (expr2', fvExpr2) <- rnLExpr expr2
+      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
+
+rnArithSeq (FromThenTo expr1 expr2 expr3)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+      ; (expr2', fvExpr2) <- rnLExpr expr2
+      ; (expr3', fvExpr3) <- rnLExpr expr3
+      ; return (FromThenTo expr1' expr2' expr3',
+                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@Stmt@s: in @do@ expressions}
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Both ApplicativeDo and RecursiveDo need to create tuples not
+present in the source text.
+
+For ApplicativeDo we create:
+
+  (a,b,c) <- (\c b a -> (a,b,c)) <$>
+
+For RecursiveDo we create:
+
+  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
+
+The order of the components in those tuples needs to be stable
+across recompilations, otherwise they can get optimized differently
+and we end up with incompatible binaries.
+To get a stable order we use nameSetElemsStable.
+See Note [Deterministic UniqFM] to learn more about nondeterminism.
+-}
+
+-- | Rename some Stmts
+rnStmts :: Outputable (body GhcPs)
+        => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+           -- ^ How to rename the body of each statement (e.g. rnLExpr)
+        -> [LStmt GhcPs (Located (body GhcPs))]
+           -- ^ Statements
+        -> ([Name] -> RnM (thing, FreeVars))
+           -- ^ if these statements scope over something, this renames it
+           -- and returns the result.
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
+rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
+
+-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
+rnStmtsWithPostProcessing
+        :: Outputable (body GhcPs)
+        => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+           -- ^ How to rename the body of each statement (e.g. rnLExpr)
+        -> (HsStmtContext Name
+              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
+           -- ^ postprocess the statements
+        -> [LStmt GhcPs (Located (body GhcPs))]
+           -- ^ Statements
+        -> ([Name] -> RnM (thing, FreeVars))
+           -- ^ if these statements scope over something, this renames it
+           -- and returns the result.
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
+rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
+ = do { ((stmts', thing), fvs) <-
+          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
+      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
+      ; return ((pp_stmts, thing), fvs `plusFV` fvs')
+      }
+
+-- | maybe rearrange statements according to the ApplicativeDo transformation
+postProcessStmtsForApplicativeDo
+  :: HsStmtContext Name
+  -> [(ExprLStmt GhcRn, FreeVars)]
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
+postProcessStmtsForApplicativeDo ctxt stmts
+  = do {
+       -- rearrange the statements using ApplicativeStmt if
+       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
+       -- to each Stmt body.
+         ado_is_on <- xoptM LangExt.ApplicativeDo
+       ; let is_do_expr | DoExpr <- ctxt = True
+                        | otherwise = False
+       -- don't apply the transformation inside TH brackets, because
+       -- DsMeta does not handle ApplicativeDo.
+       ; in_th_bracket <- isBrackStage <$> getStage
+       ; if ado_is_on && is_do_expr && not in_th_bracket
+            then do { traceRn "ppsfa" (ppr stmts)
+                    ; rearrangeForApplicativeDo ctxt stmts }
+            else noPostProcessStmts ctxt stmts }
+
+-- | strip the FreeVars annotations from statements
+noPostProcessStmts
+  :: HsStmtContext Name
+  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
+noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
+
+
+rnStmtsWithFreeVars :: Outputable (body GhcPs)
+        => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> [LStmt GhcPs (Located (body GhcPs))]
+        -> ([Name] -> RnM (thing, FreeVars))
+        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
+               , FreeVars)
+-- Each Stmt body is annotated with its FreeVars, so that
+-- we can rearrange statements for ApplicativeDo.
+--
+-- Variables bound by the Stmts, and mentioned in thing_inside,
+-- do not appear in the result FreeVars
+
+rnStmtsWithFreeVars ctxt _ [] thing_inside
+  = do { checkEmptyStmts ctxt
+       ; (thing, fvs) <- thing_inside []
+       ; return (([], thing), fvs) }
+
+rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo
+  = -- Behave like do { rec { ...all but last... }; last }
+    do { ((stmts1, (stmts2, thing)), fvs)
+           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
+              do { last_stmt' <- checkLastStmt MDoExpr last_stmt
+                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
+        ; return (((stmts1 ++ stmts2), thing), fvs) }
+  where
+    Just (all_but_last, last_stmt) = snocView stmts
+
+rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
+  | null lstmts
+  = setSrcSpan loc $
+    do { lstmt' <- checkLastStmt ctxt lstmt
+       ; rnStmt ctxt rnBody lstmt' thing_inside }
+
+  | otherwise
+  = do { ((stmts1, (stmts2, thing)), fvs)
+            <- setSrcSpan loc                         $
+               do { checkStmt ctxt lstmt
+                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
+                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->
+                    thing_inside (bndrs1 ++ bndrs2) }
+        ; return (((stmts1 ++ stmts2), thing), fvs) }
+
+----------------------
+
+{-
+Note [Failing pattern matches in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Many things desugar to HsStmts including monadic things like `do` and `mdo`
+statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
+exhaustive list). How we deal with pattern match failure is context-dependent.
+
+ * In the case of list comprehensions and pattern guards we don't need any 'fail'
+   function; the desugarer ignores the fail function field of 'BindStmt' entirely.
+ * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
+   expressions) we want pattern match failure to be desugared to the appropriate
+   'fail' function (either that of Monad or MonadFail, depending on whether
+   -XMonadFailDesugaring is enabled.)
+
+At one point we failed to make this distinction, leading to #11216.
+-}
+
+rnStmt :: Outputable (body GhcPs)
+       => HsStmtContext Name
+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+          -- ^ How to rename the body of the statement
+       -> LStmt GhcPs (Located (body GhcPs))
+          -- ^ The statement
+       -> ([Name] -> RnM (thing, FreeVars))
+          -- ^ Rename the stuff that this statement scopes over
+       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
+              , FreeVars)
+-- Variables bound by the Stmt, and mentioned in thing_inside,
+-- do not appear in the result FreeVars
+
+rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
+  = do  { (body', fv_expr) <- rnBody body
+        ; (ret_op, fvs1) <- if isMonadCompContext ctxt
+                            then lookupStmtName ctxt returnMName
+                            else return (noSyntaxExpr, emptyFVs)
+                            -- The 'return' in a LastStmt is used only
+                            -- for MonadComp; and we don't want to report
+                            -- "non in scope: return" in other cases
+                            -- #15607
+
+        ; (thing,  fvs3) <- thing_inside []
+        ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]
+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
+  = do  { (body', fv_expr) <- rnBody body
+        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName
+
+        ; (guard_op, fvs2) <- if isComprehensionContext ctxt
+                              then lookupStmtName ctxt guardMName
+                              else return (noSyntaxExpr, emptyFVs)
+                              -- Only list/monad comprehensions use 'guard'
+                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
+                              -- Here "gd" is a guard
+
+        ; (thing, fvs3)    <- thing_inside []
+        ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]
+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+
+rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
+  = do  { (body', fv_expr) <- rnBody body
+                -- The binders do not scope over the expression
+        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
+
+        ; (fail_op, fvs2) <- monadFailOp pat ctxt
+
+        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
+        { (thing, fvs3) <- thing_inside (collectPatBinders pat')
+        ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)
+                     , fv_expr )]
+                  , thing),
+                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
+       -- fv_expr shouldn't really be filtered by the rnPatsAndThen
+        -- but it does not matter because the names are unique
+
+rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
+  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
+        { (thing, fvs) <- thing_inside (collectLocalBinders binds')
+        ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)
+                 , fvs) }  }
+
+rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
+  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
+        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName
+        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName
+        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op
+                                                , recS_mfix_fn = mfix_op
+                                                , recS_bind_fn = bind_op }
+
+        -- Step1: Bring all the binders of the mdo into scope
+        -- (Remember that this also removes the binders from the
+        -- finally-returned free-vars.)
+        -- And rename each individual stmt, making a
+        -- singleton segment.  At this stage the FwdRefs field
+        -- isn't finished: it's empty for all except a BindStmt
+        -- for which it's the fwd refs within the bind itself
+        -- (This set may not be empty, because we're in a recursive
+        -- context.)
+        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do
+        { let bndrs = nameSetElemsStable $
+                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))
+                              emptyNameSet
+                              segs
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+        ; (thing, fvs_later) <- thing_inside bndrs
+        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
+        -- We aren't going to try to group RecStmts with
+        -- ApplicativeDo, so attaching empty FVs is fine.
+        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
+                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
+
+rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
+  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName
+        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
+        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
+        ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)
+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+
+rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
+                              , trS_using = using })) thing_inside
+  = do { -- Rename the 'using' expression in the context before the transform is begun
+         (using', fvs1) <- rnLExpr using
+
+         -- Rename the stmts and the 'by' expression
+         -- Keep track of the variables mentioned in the 'by' expression
+       ; ((stmts', (by', used_bndrs, thing)), fvs2)
+             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
+                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
+                   ; (thing, fvs_thing) <- thing_inside bndrs
+                   ; let fvs = fvs_by `plusFV` fvs_thing
+                         used_bndrs = filter (`elemNameSet` fvs) bndrs
+                         -- The paper (Fig 5) has a bug here; we must treat any free variable
+                         -- of the "thing inside", **or of the by-expression**, as used
+                   ; return ((by', used_bndrs, thing), fvs) }
+
+       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
+       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName
+       ; (fmap_op,   fvs5) <- case form of
+                                ThenForm -> return (noExpr, emptyFVs)
+                                _        -> lookupStmtNamePoly ctxt fmapName
+
+       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3
+                             `plusFV` fvs4 `plusFV` fvs5
+             bndr_map = used_bndrs `zip` used_bndrs
+             -- See Note [TransStmt binder map] in HsExpr
+
+       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
+       ; return (([(L loc (TransStmt { trS_ext = noExt
+                                    , trS_stmts = stmts', trS_bndrs = bndr_map
+                                    , trS_by = by', trS_using = using', trS_form = form
+                                    , trS_ret = return_op, trS_bind = bind_op
+                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
+
+rnStmt _ _ (L _ ApplicativeStmt{}) _ =
+  panic "rnStmt: ApplicativeStmt"
+
+rnStmt _ _ (L _ XStmtLR{}) _ =
+  panic "rnStmt: XStmtLR"
+
+rnParallelStmts :: forall thing. HsStmtContext Name
+                -> SyntaxExpr GhcRn
+                -> [ParStmtBlock GhcPs GhcPs]
+                -> ([Name] -> RnM (thing, FreeVars))
+                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
+-- Note [Renaming parallel Stmts]
+rnParallelStmts ctxt return_op segs thing_inside
+  = do { orig_lcl_env <- getLocalRdrEnv
+       ; rn_segs orig_lcl_env [] segs }
+  where
+    rn_segs :: LocalRdrEnv
+            -> [Name] -> [ParStmtBlock GhcPs GhcPs]
+            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
+    rn_segs _ bndrs_so_far []
+      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
+           ; mapM_ dupErr dups
+           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
+           ; return (([], thing), fvs) }
+
+    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
+      = do { ((stmts', (used_bndrs, segs', thing)), fvs)
+                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
+                       setLocalRdrEnv env       $ do
+                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
+                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
+                       ; return ((used_bndrs, segs', thing), fvs) }
+
+           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
+           ; return ((seg':segs', thing), fvs) }
+    rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
+
+    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
+    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
+                    <+> quotes (ppr (NE.head vs)))
+
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+-- Like lookupSyntaxName, but respects contexts
+lookupStmtName ctxt n
+  | rebindableContext ctxt
+  = lookupSyntaxName n
+  | otherwise
+  = return (mkRnSyntaxExpr n, emptyFVs)
+
+lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupStmtNamePoly ctxt name
+  | rebindableContext ctxt
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if rebindable_on
+         then do { fm <- lookupOccRn (nameRdrName name)
+                 ; return (HsVar noExt (noLoc fm), unitFV fm) }
+         else not_rebindable }
+  | otherwise
+  = not_rebindable
+  where
+    not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
+
+-- | Is this a context where we respect RebindableSyntax?
+-- but ListComp are never rebindable
+-- Neither is ArrowExpr, which has its own desugarer in DsArrows
+rebindableContext :: HsStmtContext Name -> Bool
+rebindableContext ctxt = case ctxt of
+  ListComp        -> False
+  ArrowExpr       -> False
+  PatGuard {}     -> False
+
+  DoExpr          -> True
+  MDoExpr         -> True
+  MonadComp       -> True
+  GhciStmtCtxt    -> True   -- I suppose?
+
+  ParStmtCtxt   c -> rebindableContext c     -- Look inside to
+  TransStmtCtxt c -> rebindableContext c     -- the parent context
+
+{-
+Note [Renaming parallel Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Renaming parallel statements is painful.  Given, say
+     [ a+c | a <- as, bs <- bss
+           | c <- bs, a <- ds ]
+Note that
+  (a) In order to report "Defined but not used" about 'bs', we must
+      rename each group of Stmts with a thing_inside whose FreeVars
+      include at least {a,c}
+
+  (b) We want to report that 'a' is illegally bound in both branches
+
+  (c) The 'bs' in the second group must obviously not be captured by
+      the binding in the first group
+
+To satisfy (a) we nest the segements.
+To satisfy (b) we check for duplicates just before thing_inside.
+To satisfy (c) we reset the LocalRdrEnv each time.
+
+************************************************************************
+*                                                                      *
+\subsubsection{mdo expressions}
+*                                                                      *
+************************************************************************
+-}
+
+type FwdRefs = NameSet
+type Segment stmts = (Defs,
+                      Uses,     -- May include defs
+                      FwdRefs,  -- A subset of uses that are
+                                --   (a) used before they are bound in this segment, or
+                                --   (b) used here, and bound in subsequent segments
+                      stmts)    -- Either Stmt or [Stmt]
+
+
+-- wrapper that does both the left- and right-hand sides
+rnRecStmtsAndThen :: Outputable (body GhcPs) =>
+                     (Located (body GhcPs)
+                  -> RnM (Located (body GhcRn), FreeVars))
+                  -> [LStmt GhcPs (Located (body GhcPs))]
+                         -- assumes that the FreeVars returned includes
+                         -- the FreeVars of the Segments
+                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
+                      -> RnM (a, FreeVars))
+                  -> RnM (a, FreeVars)
+rnRecStmtsAndThen rnBody s cont
+  = do  { -- (A) Make the mini fixity env for all of the stmts
+          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
+
+          -- (B) Do the LHSes
+        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
+
+          --    ...bring them and their fixities into scope
+        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
+              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
+              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
+              implicit_uses = mkNameSet $ concatMap snd $ rec_uses
+        ; bindLocalNamesFV bound_names $
+          addLocalFixities fix_env bound_names $ do
+
+          -- (C) do the right-hand-sides and thing-inside
+        { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
+        ; (res, fvs) <- cont segs
+        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
+                rec_uses
+        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
+        ; return (res, fvs) }}
+
+-- get all the fixity decls in any Let stmt
+collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
+collectRecStmtsFixities l =
+    foldr (\ s -> \acc -> case s of
+            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
+              foldr (\ sig -> \ acc -> case sig of
+                                         (L loc (FixSig _ s)) -> (L loc s) : acc
+                                         _ -> acc) acc sigs
+            _ -> acc) [] l
+
+-- left-hand sides
+
+rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
+                -> LStmt GhcPs body
+                   -- rename LHS, and return its FVs
+                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,
+                   -- so we don't bother to compute it accurately in the other cases
+                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
+
+rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
+  = return [(L loc (BodyStmt noExt body a b), emptyFVs)]
+
+rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
+  = return [(L loc (LastStmt noExt body noret a), emptyFVs)]
+
+rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
+  = do
+      -- should the ctxt be MDo instead?
+      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
+      return [(L loc (BindStmt noExt pat' body a b), fv_pat)]
+
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
+  = failWith (badIpBinds (text "an mdo expression") binds)
+
+rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))
+    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
+         return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),
+                 -- Warning: this is bogus; see function invariant
+                 emptyFVs
+                 )]
+
+-- XXX Do we need to do something with the return and mfix names?
+rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
+    = rn_rec_stmts_lhs fix_env stmts
+
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))
+  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))
+  = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
+rn_rec_stmt_lhs _ (L _ (XStmtLR _))
+  = panic "rn_rec_stmt XStmtLR"
+
+rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
+                 -> [LStmt GhcPs body]
+                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
+rn_rec_stmts_lhs fix_env stmts
+  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
+       ; let boundNames = collectLStmtsBinders (map fst ls)
+            -- First do error checking: we need to check for dups here because we
+            -- don't bind all of the variables from the Stmt at once
+            -- with bindLocatedLocals.
+       ; checkDupNames boundNames
+       ; return ls }
+
+
+-- right-hand-sides
+
+rn_rec_stmt :: (Outputable (body GhcPs)) =>
+               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+            -> [Name]
+            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
+            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
+        -- Rename a Stmt that is inside a RecStmt (or mdo)
+        -- Assumes all binders are already in scope
+        -- Turns each stmt into a singleton Stmt
+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
+  = do  { (body', fv_expr) <- rnBody body
+        ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
+        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
+                   L loc (LastStmt noExt body' noret ret_op))] }
+
+rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
+  = do { (body', fvs) <- rnBody body
+       ; (then_op, fvs1) <- lookupSyntaxName thenMName
+       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
+                 L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }
+
+rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
+  = do { (body', fv_expr) <- rnBody body
+       ; (bind_op, fvs1) <- lookupSyntaxName bindMName
+
+       ; (fail_op, fvs2) <- getMonadFailOp
+
+       ; let bndrs = mkNameSet (collectPatBinders pat')
+             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
+       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
+                  L loc (BindStmt noExt pat' body' bind_op fail_op))] }
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
+  = failWith (badIpBinds (text "an mdo expression") binds)
+
+rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
+  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
+           -- fixities and unused are handled above in rnRecStmtsAndThen
+       ; let fvs = allUses du_binds
+       ; return [(duDefs du_binds, fvs, emptyNameSet,
+                 L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }
+
+-- no RecStmt case because they get flattened above when doing the LHSes
+rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
+  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
+
+rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
+
+rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)
+  = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
+  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
+
+rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
+  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
+
+rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)
+  = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)
+
+rn_rec_stmts :: Outputable (body GhcPs) =>
+                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+             -> [Name]
+             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
+             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
+rn_rec_stmts rnBody bndrs stmts
+  = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
+       ; return (concat segs_s) }
+
+---------------------------------------------
+segmentRecStmts :: SrcSpan -> HsStmtContext Name
+                -> Stmt GhcRn body
+                -> [Segment (LStmt GhcRn body)] -> FreeVars
+                -> ([LStmt GhcRn body], FreeVars)
+
+segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
+  | null segs
+  = ([], fvs_later)
+
+  | MDoExpr <- ctxt
+  = segsToStmts empty_rec_stmt grouped_segs fvs_later
+               -- Step 4: Turn the segments into Stmts
+                --         Use RecStmt when and only when there are fwd refs
+                --         Also gather up the uses from the end towards the
+                --         start, so we can tell the RecStmt which things are
+                --         used 'after' the RecStmt
+
+  | otherwise
+  = ([ L loc $
+       empty_rec_stmt { recS_stmts = ss
+                      , recS_later_ids = nameSetElemsStable
+                                           (defs `intersectNameSet` fvs_later)
+                      , recS_rec_ids   = nameSetElemsStable
+                                           (defs `intersectNameSet` uses) }]
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+    , uses `plusFV` fvs_later)
+
+  where
+    (defs_s, uses_s, _, ss) = unzip4 segs
+    defs = plusFVs defs_s
+    uses = plusFVs uses_s
+
+                -- Step 2: Fill in the fwd refs.
+                --         The segments are all singletons, but their fwd-ref
+                --         field mentions all the things used by the segment
+                --         that are bound after their use
+    segs_w_fwd_refs = addFwdRefs segs
+
+                -- Step 3: Group together the segments to make bigger segments
+                --         Invariant: in the result, no segment uses a variable
+                --                    bound in a later segment
+    grouped_segs = glomSegments ctxt segs_w_fwd_refs
+
+----------------------------
+addFwdRefs :: [Segment a] -> [Segment a]
+-- So far the segments only have forward refs *within* the Stmt
+--      (which happens for bind:  x <- ...x...)
+-- This function adds the cross-seg fwd ref info
+
+addFwdRefs segs
+  = fst (foldr mk_seg ([], emptyNameSet) segs)
+  where
+    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
+        = (new_seg : segs, all_defs)
+        where
+          new_seg = (defs, uses, new_fwds, stmts)
+          all_defs = later_defs `unionNameSet` defs
+          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
+                -- Add the downstream fwd refs here
+
+{-
+Note [Segmenting mdo]
+~~~~~~~~~~~~~~~~~~~~~
+NB. June 7 2012: We only glom segments that appear in an explicit mdo;
+and leave those found in "do rec"'s intact.  See
+https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion
+leading to this design choice.  Hence the test in segmentRecStmts.
+
+Note [Glomming segments]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Glomming the singleton segments of an mdo into minimal recursive groups.
+
+At first I thought this was just strongly connected components, but
+there's an important constraint: the order of the stmts must not change.
+
+Consider
+     mdo { x <- ...y...
+           p <- z
+           y <- ...x...
+           q <- x
+           z <- y
+           r <- x }
+
+Here, the first stmt mention 'y', which is bound in the third.
+But that means that the innocent second stmt (p <- z) gets caught
+up in the recursion.  And that in turn means that the binding for
+'z' has to be included... and so on.
+
+Start at the tail { r <- x }
+Now add the next one { z <- y ; r <- x }
+Now add one more     { q <- x ; z <- y ; r <- x }
+Now one more... but this time we have to group a bunch into rec
+     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
+Now one more, which we can add on without a rec
+     { p <- z ;
+       rec { y <- ...x... ; q <- x ; z <- y } ;
+       r <- x }
+Finally we add the last one; since it mentions y we have to
+glom it together with the first two groups
+     { rec { x <- ...y...; p <- z ; y <- ...x... ;
+             q <- x ; z <- y } ;
+       r <- x }
+-}
+
+glomSegments :: HsStmtContext Name
+             -> [Segment (LStmt GhcRn body)]
+             -> [Segment [LStmt GhcRn body]]
+                                  -- Each segment has a non-empty list of Stmts
+-- See Note [Glomming segments]
+
+glomSegments _ [] = []
+glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
+        -- Actually stmts will always be a singleton
+  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
+  where
+    segs'            = glomSegments ctxt segs
+    (extras, others) = grab uses segs'
+    (ds, us, fs, ss) = unzip4 extras
+
+    seg_defs  = plusFVs ds `plusFV` defs
+    seg_uses  = plusFVs us `plusFV` uses
+    seg_fwds  = plusFVs fs `plusFV` fwds
+    seg_stmts = stmt : concat ss
+
+    grab :: NameSet             -- The client
+         -> [Segment a]
+         -> ([Segment a],       -- Needed by the 'client'
+             [Segment a])       -- Not needed by the client
+        -- The result is simply a split of the input
+    grab uses dus
+        = (reverse yeses, reverse noes)
+        where
+          (noes, yeses)           = span not_needed (reverse dus)
+          not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
+
+----------------------------------------------------
+segsToStmts :: Stmt GhcRn body
+                                  -- A RecStmt with the SyntaxOps filled in
+            -> [Segment [LStmt GhcRn body]]
+                                  -- Each Segment has a non-empty list of Stmts
+            -> FreeVars           -- Free vars used 'later'
+            -> ([LStmt GhcRn body], FreeVars)
+
+segsToStmts _ [] fvs_later = ([], fvs_later)
+segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
+  = ASSERT( not (null ss) )
+    (new_stmt : later_stmts, later_uses `plusFV` uses)
+  where
+    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
+    new_stmt | non_rec   = head ss
+             | otherwise = cL (getLoc (head ss)) rec_stmt
+    rec_stmt = empty_rec_stmt { recS_stmts     = ss
+                              , recS_later_ids = nameSetElemsStable used_later
+                              , recS_rec_ids   = nameSetElemsStable fwds }
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+    non_rec    = isSingleton ss && isEmptyNameSet fwds
+    used_later = defs `intersectNameSet` later_uses
+                                -- The ones needed after the RecStmt
+
+{-
+************************************************************************
+*                                                                      *
+ApplicativeDo
+*                                                                      *
+************************************************************************
+
+Note [ApplicativeDo]
+
+= Example =
+
+For a sequence of statements
+
+ do
+     x <- A
+     y <- B x
+     z <- C
+     return (f x y z)
+
+We want to transform this to
+
+  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
+
+It would be easy to notice that "y <- B x" and "z <- C" are
+independent and do something like this:
+
+ do
+     x <- A
+     (y,z) <- (,) <$> B x <*> C
+     return (f x y z)
+
+But this isn't enough! A and C were also independent, and this
+transformation loses the ability to do A and C in parallel.
+
+The algorithm works by first splitting the sequence of statements into
+independent "segments", and a separate "tail" (the final statement). In
+our example above, the segements would be
+
+     [ x <- A
+     , y <- B x ]
+
+     [ z <- C ]
+
+and the tail is:
+
+     return (f x y z)
+
+Then we take these segments and make an Applicative expression from them:
+
+     (\(x,y) z -> return (f x y z))
+       <$> do { x <- A; y <- B x; return (x,y) }
+       <*> C
+
+Finally, we recursively apply the transformation to each segment, to
+discover any nested parallelism.
+
+= Syntax & spec =
+
+  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
+
+  stmt ::= pat <- expr
+         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1
+         | ...                    -- other kinds of statement (e.g. let)
+
+  arg ::= pat <- expr
+        | {stmt_1; ..; stmt_n} {var_1..var_n}
+
+(note that in the actual implementation,the expr in a do statement is
+represented by a LastStmt as the final stmt, this is just a
+representational issue and may change later.)
+
+== Transformation to introduce applicative stmts ==
+
+ado {} tail = tail
+ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
+ado {one} tail = one : tail
+ado stmts tail
+  | n == 1 = ado before (ado after tail)
+    where (before,after) = split(stmts_1)
+  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
+  where
+    {stmts_1 .. stmts_n} = segments(stmts)
+
+segments(stmts) =
+  -- divide stmts into segments with no interdependencies
+
+mkArg({pat <- expr}) = (pat <- expr)
+mkArg({stmt_1; ...; stmt_n}) =
+  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
+
+split({stmt_1; ..; stmt_n) =
+  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
+  -- 1 <= i <= n
+  -- i is a good place to insert a bind
+
+== Desugaring for do ==
+
+dsDo {} expr = expr
+
+dsDo {pat <- rhs; stmts} expr =
+   rhs >>= \pat -> dsDo stmts expr
+
+dsDo {(arg_1 | ... | arg_n)} (return expr) =
+  (\argpat (arg_1) .. argpat(arg_n) -> expr)
+     <$> argexpr(arg_1)
+     <*> ...
+     <*> argexpr(arg_n)
+
+dsDo {(arg_1 | ... | arg_n); stmts} expr =
+  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
+     <$> argexpr(arg_1)
+     <*> ...
+     <*> argexpr(arg_n)
+
+-}
+
+-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
+-- 'pureName' due to @RebindableSyntax@.
+data MonadNames = MonadNames { return_name, pure_name :: Name }
+
+-- | rearrange a list of statements using ApplicativeDoStmt.  See
+-- Note [ApplicativeDo].
+rearrangeForApplicativeDo
+  :: HsStmtContext Name
+  -> [(ExprLStmt GhcRn, FreeVars)]
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
+
+rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
+rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
+rearrangeForApplicativeDo ctxt stmts0 = do
+  optimal_ado <- goptM Opt_OptimalApplicativeDo
+  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
+                | otherwise = mkStmtTreeHeuristic stmts
+  traceRn "rearrangeForADo" (ppr stmt_tree)
+  return_name <- lookupSyntaxName' returnMName
+  pure_name   <- lookupSyntaxName' pureAName
+  let monad_names = MonadNames { return_name = return_name
+                               , pure_name   = pure_name }
+  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
+  where
+    (stmts,(last,last_fvs)) = findLast stmts0
+    findLast [] = error "findLast"
+    findLast [last] = ([],last)
+    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
+
+-- | A tree of statements using a mixture of applicative and bind constructs.
+data StmtTree a
+  = StmtTreeOne a
+  | StmtTreeBind (StmtTree a) (StmtTree a)
+  | StmtTreeApplicative [StmtTree a]
+
+instance Outputable a => Outputable (StmtTree a) where
+  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)
+  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")
+                                            2 (sep [ppr x, ppr y]))
+  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
+                                            2 (vcat (map ppr xs)))
+
+flattenStmtTree :: StmtTree a -> [a]
+flattenStmtTree t = go t []
+ where
+  go (StmtTreeOne a) as = a : as
+  go (StmtTreeBind l r) as = go l (go r as)
+  go (StmtTreeApplicative ts) as = foldr go as ts
+
+type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
+type Cost = Int
+
+-- | Turn a sequence of statements into an ExprStmtTree using a
+-- heuristic algorithm.  /O(n^2)/
+mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
+mkStmtTreeHeuristic [one] = StmtTreeOne one
+mkStmtTreeHeuristic stmts =
+  case segments stmts of
+    [one] -> split one
+    segs -> StmtTreeApplicative (map split segs)
+ where
+  split [one] = StmtTreeOne one
+  split stmts =
+    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
+    where (before, after) = splitSegment stmts
+
+-- | Turn a sequence of statements into an ExprStmtTree optimally,
+-- using dynamic programming.  /O(n^3)/
+mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
+mkStmtTreeOptimal stmts =
+  ASSERT(not (null stmts)) -- the empty case is handled by the caller;
+                           -- we don't support empty StmtTrees.
+  fst (arr ! (0,n))
+  where
+    n = length stmts - 1
+    stmt_arr = listArray (0,n) stmts
+
+    -- lazy cache of optimal trees for subsequences of the input
+    arr :: Array (Int,Int) (ExprStmtTree, Cost)
+    arr = array ((0,0),(n,n))
+             [ ((lo,hi), tree lo hi)
+             | lo <- [0..n]
+             , hi <- [lo..n] ]
+
+    -- compute the optimal tree for the sequence [lo..hi]
+    tree lo hi
+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
+      | otherwise =
+         case segments [ stmt_arr ! i | i <- [lo..hi] ] of
+           [] -> panic "mkStmtTree"
+           [_one] -> split lo hi
+           segs -> (StmtTreeApplicative trees, maximum costs)
+             where
+               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
+               (trees,costs) = unzip (map (uncurry split) (tail bounds))
+
+    -- find the best place to split the segment [lo..hi]
+    split :: Int -> Int -> (ExprStmtTree, Cost)
+    split lo hi
+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
+      | otherwise = (StmtTreeBind before after, c1+c2)
+        where
+         -- As per the paper, for a sequence s1...sn, we want to find
+         -- the split with the minimum cost, where the cost is the
+         -- sum of the cost of the left and right subsequences.
+         --
+         -- As an optimisation (also in the paper) if the cost of
+         -- s1..s(n-1) is different from the cost of s2..sn, we know
+         -- that the optimal solution is the lower of the two.  Only
+         -- in the case that these two have the same cost do we need
+         -- to do the exhaustive search.
+         --
+         ((before,c1),(after,c2))
+           | hi - lo == 1
+           = ((StmtTreeOne (stmt_arr ! lo), 1),
+              (StmtTreeOne (stmt_arr ! hi), 1))
+           | left_cost < right_cost
+           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
+           | left_cost > right_cost
+           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
+           | otherwise = minimumBy (comparing cost) alternatives
+           where
+             (left, left_cost) = arr ! (lo,hi-1)
+             (right, right_cost) = arr ! (lo+1,hi)
+             cost ((_,c1),(_,c2)) = c1 + c2
+             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
+                            | k <- [lo .. hi-1] ]
+
+
+-- | Turn the ExprStmtTree back into a sequence of statements, using
+-- ApplicativeStmt where necessary.
+stmtTreeToStmts
+  :: MonadNames
+  -> HsStmtContext Name
+  -> ExprStmtTree
+  -> [ExprLStmt GhcRn]             -- ^ the "tail"
+  -> FreeVars                     -- ^ free variables of the tail
+  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,
+         , FreeVars )             -- , things we needed
+
+-- If we have a single bind, and we can do it without a join, transform
+-- to an ApplicativeStmt.  This corresponds to the rule
+--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs
+-- In the spec, but we do it here rather than in the desugarer,
+-- because we need the typechecker to typecheck the <$> form rather than
+-- the bind form, which would give rise to a Monad constraint.
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
+                tail _tail_fvs
+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
+  -- See Note [ApplicativeDo and strict patterns]
+  = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
+                tail _tail_fvs
+  | (False,tail') <- needJoin monad_names tail
+  = mkApplicativeStmt ctxt
+      [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'
+
+stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
+  return (s : tail, emptyNameSet)
+
+stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
+  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
+  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
+  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
+  return (stmts2, fvs1 `plusFV` fvs2)
+
+stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
+   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
+   let (stmts', fvss) = unzip pairs
+   let (need_join, tail') = needJoin monad_names tail
+   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
+   return (stmts, unionNameSets (fvs:fvss))
+ where
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
+     = return (ApplicativeArgOne noExt pat exp False, emptyFVs)
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
+     return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
+   stmtTreeArg ctxt tail_fvs tree = do
+     let stmts = flattenStmtTree tree
+         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
+                     `intersectNameSet` tail_fvs
+         pvars = nameSetElemsStable pvarset
+           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+         pat = mkBigLHsVarPatTup pvars
+         tup = mkBigLHsVarTup pvars
+     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
+     (mb_ret, fvs1) <-
+        if | L _ ApplicativeStmt{} <- last stmts' ->
+             return (unLoc tup, emptyNameSet)
+           | otherwise -> do
+             (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
+             return (HsApp noExt (noLoc ret) tup, fvs)
+     return ( ApplicativeArgMany noExt stmts' mb_ret pat
+            , fvs1 `plusFV` fvs2)
+
+
+-- | Divide a sequence of statements into segments, where no segment
+-- depends on any variables defined by a statement in another segment.
+segments
+  :: [(ExprLStmt GhcRn, FreeVars)]
+  -> [[(ExprLStmt GhcRn, FreeVars)]]
+segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
+  where
+    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
+
+    -- We would rather not have a segment that just has LetStmts in
+    -- it, so combine those with an adjacent segment where possible.
+    merge [] = []
+    merge (seg : segs)
+       = case rest of
+          [] -> [(seg,all_lets)]
+          ((s,s_lets):ss) | all_lets || s_lets
+               -> (seg ++ s, all_lets && s_lets) : ss
+          _otherwise -> (seg,all_lets) : rest
+      where
+        rest = merge segs
+        all_lets = all (isLetStmt . fst) seg
+
+    -- walk splits the statement sequence into segments, traversing
+    -- the sequence from the back to the front, and keeping track of
+    -- the set of free variables of the current segment.  Whenever
+    -- this set of free variables is empty, we have a complete segment.
+    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
+    walk [] = []
+    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
+      where (seg,rest) = chunter fvs' stmts
+            (_, fvs') = stmtRefs stmt fvs
+
+    chunter _ [] = ([], [])
+    chunter vars ((stmt,fvs) : rest)
+       | not (isEmptyNameSet vars)
+       || isStrictPatternBind stmt
+           -- See Note [ApplicativeDo and strict patterns]
+       = ((stmt,fvs) : chunk, rest')
+       where (chunk,rest') = chunter vars' rest
+             (pvars, evars) = stmtRefs stmt fvs
+             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
+    chunter _ rest = ([], rest)
+
+    stmtRefs stmt fvs
+      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
+      | otherwise      = (pvars, fvs')
+      where fvs' = fvs `intersectNameSet` allvars
+            pvars = mkNameSet (collectStmtBinders (unLoc stmt))
+
+    isStrictPatternBind :: ExprLStmt GhcRn -> Bool
+    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
+    isStrictPatternBind _ = False
+
+{-
+Note [ApplicativeDo and strict patterns]
+
+A strict pattern match is really a dependency.  For example,
+
+do
+  (x,y) <- A
+  z <- B
+  return C
+
+The pattern (_,_) must be matched strictly before we do B.  If we
+allowed this to be transformed into
+
+  (\(x,y) -> \z -> C) <$> A <*> B
+
+then it could be lazier than the standard desuraging using >>=.  See #13875
+for more examples.
+
+Thus, whenever we have a strict pattern match, we treat it as a
+dependency between that statement and the following one.  The
+dependency prevents those two statements from being performed "in
+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
+can do with the rest of the statements in the same "do" expression.
+-}
+
+isStrictPattern :: LPat (GhcPass p) -> Bool
+isStrictPattern lpat =
+  case unLoc lpat of
+    WildPat{}       -> False
+    VarPat{}        -> False
+    LazyPat{}       -> False
+    AsPat _ _ p     -> isStrictPattern p
+    ParPat _ p      -> isStrictPattern p
+    ViewPat _ _ p   -> isStrictPattern p
+    SigPat _ p _    -> isStrictPattern p
+    BangPat{}       -> True
+    ListPat{}       -> True
+    TuplePat{}      -> True
+    SumPat{}        -> True
+    ConPatIn{}      -> True
+    ConPatOut{}     -> True
+    LitPat{}        -> True
+    NPat{}          -> True
+    NPlusKPat{}     -> True
+    SplicePat{}     -> True
+    _otherwise -> panic "isStrictPattern"
+
+isLetStmt :: LStmt a b -> Bool
+isLetStmt (L _ LetStmt{}) = True
+isLetStmt _ = False
+
+-- | Find a "good" place to insert a bind in an indivisible segment.
+-- This is the only place where we use heuristics.  The current
+-- heuristic is to peel off the first group of independent statements
+-- and put the bind after those.
+splitSegment
+  :: [(ExprLStmt GhcRn, FreeVars)]
+  -> ( [(ExprLStmt GhcRn, FreeVars)]
+     , [(ExprLStmt GhcRn, FreeVars)] )
+splitSegment [one,two] = ([one],[two])
+  -- there is no choice when there are only two statements; this just saves
+  -- some work in a common case.
+splitSegment stmts
+  | Just (lets,binds,rest) <- slurpIndependentStmts stmts
+  =  if not (null lets)
+       then (lets, binds++rest)
+       else (lets++binds, rest)
+  | otherwise
+  = case stmts of
+      (x:xs) -> ([x],xs)
+      _other -> (stmts,[])
+
+slurpIndependentStmts
+   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts
+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts
+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )
+slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
+ where
+  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
+  -- in this group, then add it to the group. We have to be careful about
+  -- strict patterns though; splitSegments expects that if we return Just
+  -- then we have actually done some splitting. Otherwise it will go into
+  -- an infinite loop (#14163).
+  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
+    = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)
+         bndrs' rest
+    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
+  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
+  -- group, then move it to the beginning, so that it doesn't interfere with
+  -- grouping more BindStmts.
+  -- TODO: perhaps we shouldn't do this if there are any strict bindings,
+  -- because we might be moving evaluation earlier.
+  go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)
+    = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest
+  go _ []  _ _ = Nothing
+  go _ [_] _ _ = Nothing
+  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
+
+-- | Build an ApplicativeStmt, and strip the "return" from the tail
+-- if necessary.
+--
+-- For example, if we start with
+--   do x <- E1; y <- E2; return (f x y)
+-- then we get
+--   do (E1[x] | E2[y]); f x y
+--
+-- the LastStmt in this case has the return removed, but we set the
+-- flag on the LastStmt to indicate this, so that we can print out the
+-- original statement correctly in error messages.  It is easier to do
+-- it this way rather than try to ignore the return later in both the
+-- typechecker and the desugarer (I tried it that way first!).
+mkApplicativeStmt
+  :: HsStmtContext Name
+  -> [ApplicativeArg GhcRn]             -- ^ The args
+  -> Bool                               -- ^ True <=> need a join
+  -> [ExprLStmt GhcRn]        -- ^ The body statements
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
+mkApplicativeStmt ctxt args need_join body_stmts
+  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
+       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
+       ; (mb_join, fvs3) <-
+           if need_join then
+             do { (join_op, fvs) <- lookupStmtName ctxt joinMName
+                ; return (Just join_op, fvs) }
+           else
+             return (Nothing, emptyNameSet)
+       ; let applicative_stmt = noLoc $ ApplicativeStmt noExt
+               (zip (fmap_op : repeat ap_op) args)
+               mb_join
+       ; return ( applicative_stmt : body_stmts
+                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+
+-- | Given the statements following an ApplicativeStmt, determine whether
+-- we need a @join@ or not, and remove the @return@ if necessary.
+needJoin :: MonadNames
+         -> [ExprLStmt GhcRn]
+         -> (Bool, [ExprLStmt GhcRn])
+needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg
+needJoin monad_names  [L loc (LastStmt _ e _ t)]
+ | Just arg <- isReturnApp monad_names e =
+       (False, [L loc (LastStmt noExt arg True t)])
+needJoin _monad_names stmts = (True, stmts)
+
+-- | @Just e@, if the expression is @return e@ or @return $ e@,
+-- otherwise @Nothing@
+isReturnApp :: MonadNames
+            -> LHsExpr GhcRn
+            -> Maybe (LHsExpr GhcRn)
+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr
+isReturnApp monad_names (L _ e) = case e of
+  OpApp _ l op r | is_return l, is_dollar op -> Just r
+  HsApp _ f arg  | is_return f               -> Just arg
+  _otherwise -> Nothing
+ where
+  is_var f (L _ (HsPar _ e)) = is_var f e
+  is_var f (L _ (HsAppType _ e _)) = is_var f e
+  is_var f (L _ (HsVar _ (L _ r))) = f r
+       -- TODO: I don't know how to get this right for rebindable syntax
+  is_var _ _ = False
+
+  is_return = is_var (\n -> n == return_name monad_names
+                         || n == pure_name monad_names)
+  is_dollar = is_var (`hasKey` dollarIdKey)
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+checkEmptyStmts :: HsStmtContext Name -> RnM ()
+-- We've seen an empty sequence of Stmts... is that ok?
+checkEmptyStmts ctxt
+  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
+
+okEmpty :: HsStmtContext a -> Bool
+okEmpty (PatGuard {}) = True
+okEmpty _             = False
+
+emptyErr :: HsStmtContext Name -> SDoc
+emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"
+emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
+emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt
+
+----------------------
+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
+              -> LStmt GhcPs (Located (body GhcPs))
+              -> RnM (LStmt GhcPs (Located (body GhcPs)))
+checkLastStmt ctxt lstmt@(L loc stmt)
+  = case ctxt of
+      ListComp  -> check_comp
+      MonadComp -> check_comp
+      ArrowExpr -> check_do
+      DoExpr    -> check_do
+      MDoExpr   -> check_do
+      _         -> check_other
+  where
+    check_do    -- Expect BodyStmt, and change it to LastStmt
+      = case stmt of
+          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
+          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
+                                             -- LastStmt directly (unlike the parser)
+          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+    last_error = (text "The last statement in" <+> pprAStmtContext ctxt
+                  <+> text "must be an expression")
+
+    check_comp  -- Expect LastStmt; this should be enforced by the parser!
+      = case stmt of
+          LastStmt {} -> return lstmt
+          _           -> pprPanic "checkLastStmt" (ppr lstmt)
+
+    check_other -- Behave just as if this wasn't the last stmt
+      = do { checkStmt ctxt lstmt; return lstmt }
+
+-- Checking when a particular Stmt is ok
+checkStmt :: HsStmtContext Name
+          -> LStmt GhcPs (Located (body GhcPs))
+          -> RnM ()
+checkStmt ctxt (L _ stmt)
+  = do { dflags <- getDynFlags
+       ; case okStmt dflags ctxt stmt of
+           IsValid        -> return ()
+           NotValid extra -> addErr (msg $$ extra) }
+  where
+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
+             , text "in" <+> pprAStmtContext ctxt ]
+
+pprStmtCat :: Stmt a body -> SDoc
+pprStmtCat (TransStmt {})     = text "transform"
+pprStmtCat (LastStmt {})      = text "return expression"
+pprStmtCat (BodyStmt {})      = text "body"
+pprStmtCat (BindStmt {})      = text "binding"
+pprStmtCat (LetStmt {})       = text "let"
+pprStmtCat (RecStmt {})       = text "rec"
+pprStmtCat (ParStmt {})       = text "parallel"
+pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
+pprStmtCat (XStmtLR {})         = panic "pprStmtCat: XStmtLR"
+
+------------
+emptyInvalid :: Validity  -- Payload is the empty document
+emptyInvalid = NotValid Outputable.empty
+
+okStmt, okDoStmt, okCompStmt, okParStmt
+   :: DynFlags -> HsStmtContext Name
+   -> Stmt GhcPs (Located (body GhcPs)) -> Validity
+-- Return Nothing if OK, (Just extra) if not ok
+-- The "extra" is an SDoc that is appended to a generic error message
+
+okStmt dflags ctxt stmt
+  = case ctxt of
+      PatGuard {}        -> okPatGuardStmt stmt
+      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt
+      DoExpr             -> okDoStmt   dflags ctxt stmt
+      MDoExpr            -> okDoStmt   dflags ctxt stmt
+      ArrowExpr          -> okDoStmt   dflags ctxt stmt
+      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt
+      ListComp           -> okCompStmt dflags ctxt stmt
+      MonadComp          -> okCompStmt dflags ctxt stmt
+      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
+
+-------------
+okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
+okPatGuardStmt stmt
+  = case stmt of
+      BodyStmt {} -> IsValid
+      BindStmt {} -> IsValid
+      LetStmt {}  -> IsValid
+      _           -> emptyInvalid
+
+-------------
+okParStmt dflags ctxt stmt
+  = case stmt of
+      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid
+      _                              -> okStmt dflags ctxt stmt
+
+----------------
+okDoStmt dflags ctxt stmt
+  = case stmt of
+       RecStmt {}
+         | LangExt.RecursiveDo `xopt` dflags -> IsValid
+         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
+         | otherwise         -> NotValid (text "Use RecursiveDo")
+       BindStmt {} -> IsValid
+       LetStmt {}  -> IsValid
+       BodyStmt {} -> IsValid
+       _           -> emptyInvalid
+
+----------------
+okCompStmt dflags _ stmt
+  = case stmt of
+       BindStmt {} -> IsValid
+       LetStmt {}  -> IsValid
+       BodyStmt {} -> IsValid
+       ParStmt {}
+         | LangExt.ParallelListComp `xopt` dflags -> IsValid
+         | otherwise -> NotValid (text "Use ParallelListComp")
+       TransStmt {}
+         | LangExt.TransformListComp `xopt` dflags -> IsValid
+         | otherwise -> NotValid (text "Use TransformListComp")
+       RecStmt {}  -> emptyInvalid
+       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
+       ApplicativeStmt {} -> emptyInvalid
+       XStmtLR{} -> panic "okCompStmt"
+
+---------
+checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
+checkTupleSection args
+  = do  { tuple_section <- xoptM LangExt.TupleSections
+        ; checkErr (all tupArgPresent args || tuple_section) msg }
+  where
+    msg = text "Illegal tuple section: use TupleSections"
+
+---------
+sectionErr :: HsExpr GhcPs -> SDoc
+sectionErr expr
+  = hang (text "A section must be enclosed in parentheses")
+       2 (text "thus:" <+> (parens (ppr expr)))
+
+badIpBinds :: Outputable a => SDoc -> a -> SDoc
+badIpBinds what binds
+  = hang (text "Implicit-parameter bindings illegal in" <+> what)
+         2 (ppr binds)
+
+---------
+
+monadFailOp :: LPat GhcPs
+            -> HsStmtContext Name
+            -> RnM (SyntaxExpr GhcRn, FreeVars)
+monadFailOp pat ctxt
+  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
+  -- we should not need to fail.
+  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)
+
+  -- For non-monadic contexts (e.g. guard patterns, list
+  -- comprehensions, etc.) we should not need to fail.  See Note
+  -- [Failing pattern matches in Stmts]
+  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)
+
+  | otherwise = getMonadFailOp
+
+{-
+Note [Monad fail : Rebindable syntax, overloaded strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given the code
+  foo x = do { Just y <- x; return y }
+
+we expect it to desugar as
+  foo x = x >>= \r -> case r of
+                        Just y  -> return y
+                        Nothing -> fail "Pattern match error"
+
+But with RebindableSyntax and OverloadedStrings, we really want
+it to desugar thus:
+  foo x = x >>= \r -> case r of
+                        Just y  -> return y
+                        Nothing -> fail (fromString "Patterm match error")
+
+So, in this case, we synthesize the function
+  \x -> fail (fromString x)
+
+(rather than plain 'fail') for the 'fail' operation. This is done in
+'getMonadFailOp'.
+-}
+getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp
+ = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
+      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+      }
+  where
+    reallyGetMonadFailOp rebindableSyntax overloadedStrings
+      | rebindableSyntax && overloadedStrings = do
+        (failExpr, failFvs) <- lookupSyntaxName failMName
+        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
+        let arg_lit = fsLit "arg"
+            arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit
+            arg_syn_expr = mkRnSyntaxExpr arg_name
+        let body :: LHsExpr GhcRn =
+              nlHsApp (noLoc $ syn_expr failExpr)
+                      (nlHsApp (noLoc $ syn_expr fromStringExpr)
+                                (noLoc $ syn_expr arg_syn_expr))
+        let failAfterFromStringExpr :: HsExpr GhcRn =
+              unLoc $ mkHsLam [noLoc $ VarPat noExt $ noLoc arg_name] body
+        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
+              mkSyntaxExpr failAfterFromStringExpr
+        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
+      | otherwise = lookupSyntaxName failMName
diff --git a/compiler/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnExpr.hs-boot
@@ -0,0 +1,17 @@
+module RnExpr where
+import Name
+import HsSyn
+import NameSet     ( FreeVars )
+import TcRnTypes
+import SrcLoc      ( Located )
+import Outputable  ( Outputable )
+
+rnLExpr :: LHsExpr GhcPs
+        -> RnM (LHsExpr GhcRn, FreeVars)
+
+rnStmts :: --forall thing body.
+           Outputable (body GhcPs) => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> [LStmt GhcPs (Located (body GhcPs))]
+        -> ([Name] -> RnM (thing, FreeVars))
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnFixity.hs
@@ -0,0 +1,214 @@
+{-# LANGUAGE ViewPatterns #-}
+
+{-
+
+This module contains code which maintains and manipulates the
+fixity environment during renaming.
+
+-}
+module RnFixity ( MiniFixityEnv,
+                  addLocalFixities,
+  lookupFixityRn, lookupFixityRn_help,
+  lookupFieldFixityRn, lookupTyFixityRn ) where
+
+import GhcPrelude
+
+import LoadIface
+import HsSyn
+import RdrName
+import HscTypes
+import TcRnMonad
+import Name
+import NameEnv
+import Module
+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,
+                          defaultFixity, SourceText(..) )
+import SrcLoc
+import Outputable
+import Maybes
+import Data.List
+import Data.Function    ( on )
+import RnUnbound
+
+{-
+*********************************************************
+*                                                      *
+                Fixities
+*                                                      *
+*********************************************************
+
+Note [Fixity signature lookup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A fixity declaration like
+
+    infixr 2 ?
+
+can refer to a value-level operator, e.g.:
+
+    (?) :: String -> String -> String
+
+or a type-level operator, like:
+
+    data (?) a b = A a | B b
+
+so we extend the lookup of the reader name '?' to the TcClsName namespace, as
+well as the original namespace.
+
+The extended lookup is also used in other places, like resolution of
+deprecation declarations, and lookup of names in GHCi.
+-}
+
+--------------------------------
+type MiniFixityEnv = FastStringEnv (Located Fixity)
+        -- Mini fixity env for the names we're about
+        -- to bind, in a single binding group
+        --
+        -- It is keyed by the *FastString*, not the *OccName*, because
+        -- the single fixity decl       infix 3 T
+        -- affects both the data constructor T and the type constrctor T
+        --
+        -- We keep the location so that if we find
+        -- a duplicate, we can report it sensibly
+
+--------------------------------
+-- Used for nested fixity decls to bind names along with their fixities.
+-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
+
+addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
+addLocalFixities mini_fix_env names thing_inside
+  = extendFixityEnv (mapMaybe find_fixity names) thing_inside
+  where
+    find_fixity name
+      = case lookupFsEnv mini_fix_env (occNameFS occ) of
+          Just lfix -> Just (name, FixItem occ (unLoc lfix))
+          Nothing   -> Nothing
+      where
+        occ = nameOccName name
+
+{-
+--------------------------------
+lookupFixity is a bit strange.
+
+* Nested local fixity decls are put in the local fixity env, which we
+  find with getFixtyEnv
+
+* Imported fixities are found in the PIT
+
+* Top-level fixity decls in this module may be for Names that are
+    either  Global         (constructors, class operations)
+    or      Local/Exported (everything else)
+  (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+  We put them all in the local fixity environment
+-}
+
+lookupFixityRn :: Name -> RnM Fixity
+lookupFixityRn name = lookupFixityRn' name (nameOccName name)
+
+lookupFixityRn' :: Name -> OccName -> RnM Fixity
+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
+
+-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
+-- in a local environment or from an interface file. Otherwise, it returns
+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
+-- user-supplied fixity declarations).
+lookupFixityRn_help :: Name
+                    -> RnM (Bool, Fixity)
+lookupFixityRn_help name =
+    lookupFixityRn_help' name (nameOccName name)
+
+lookupFixityRn_help' :: Name
+                     -> OccName
+                     -> RnM (Bool, Fixity)
+lookupFixityRn_help' name occ
+  | isUnboundName name
+  = return (False, Fixity NoSourceText minPrecedence InfixL)
+    -- Minimise errors from ubound names; eg
+    --    a>0 `foo` b>0
+    -- where 'foo' is not in scope, should not give an error (#7937)
+
+  | otherwise
+  = do { local_fix_env <- getFixityEnv
+       ; case lookupNameEnv local_fix_env name of {
+           Just (FixItem _ fix) -> return (True, fix) ;
+           Nothing ->
+
+    do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name
+               -- Local (and interactive) names are all in the
+               -- fixity env, and don't have entries in the HPT
+         then return (False, defaultFixity)
+         else lookup_imported } } }
+  where
+    lookup_imported
+      -- For imported names, we have to get their fixities by doing a
+      -- loadInterfaceForName, and consulting the Ifaces that comes back
+      -- from that, because the interface file for the Name might not
+      -- have been loaded yet.  Why not?  Suppose you import module A,
+      -- which exports a function 'f', thus;
+      --        module CurrentModule where
+      --          import A( f )
+      --        module A( f ) where
+      --          import B( f )
+      -- Then B isn't loaded right away (after all, it's possible that
+      -- nothing from B will be used).  When we come across a use of
+      -- 'f', we need to know its fixity, and it's then, and only
+      -- then, that we load B.hi.  That is what's happening here.
+      --
+      -- loadInterfaceForName will find B.hi even if B is a hidden module,
+      -- and that's what we want.
+      = do { iface <- loadInterfaceForName doc name
+           ; let mb_fix = mi_fix_fn iface occ
+           ; let msg = case mb_fix of
+                            Nothing ->
+                                  text "looking up name" <+> ppr name
+                              <+> text "in iface, but found no fixity for it."
+                              <+> text "Using default fixity instead."
+                            Just f ->
+                                  text "looking up name in iface and found:"
+                              <+> vcat [ppr name, ppr f]
+           ; traceRn "lookupFixityRn_either:" msg
+           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }
+
+    doc = text "Checking fixity for" <+> ppr name
+
+---------------
+lookupTyFixityRn :: Located Name -> RnM Fixity
+lookupTyFixityRn = lookupFixityRn . unLoc
+
+-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
+-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
+-- the field label, which might be different to the 'OccName' of the selector
+-- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are
+-- multiple possible selectors with different fixities, generate an error.
+lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
+lookupFieldFixityRn (Unambiguous n lrdr)
+  = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))
+lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)
+  where
+    get_ambiguous_fixity :: RdrName -> RnM Fixity
+    get_ambiguous_fixity rdr_name = do
+      traceRn "get_ambiguous_fixity" (ppr rdr_name)
+      rdr_env <- getGlobalRdrEnv
+      let elts =  lookupGRE_RdrName rdr_name rdr_env
+
+      fixities <- groupBy ((==) `on` snd) . zip elts
+                  <$> mapM lookup_gre_fixity elts
+
+      case fixities of
+        -- There should always be at least one fixity.
+        -- Something's very wrong if there are no fixity candidates, so panic
+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
+        [ (_, fix):_ ] -> return fix
+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
+                  >> return (Fixity NoSourceText minPrecedence InfixL)
+
+    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
+
+    ambiguous_fixity_err rn ambigs
+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
+             , hang (text "Conflicts: ") 2 . vcat .
+               map format_ambig $ concat ambigs ]
+
+    format_ambig (elt, fix) = hang (ppr fix)
+                                 2 (pprNameProvenance elt)
+lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"
diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnHsDoc.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import HsSyn
+import SrcLoc
+
+
+rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
+rnMbLHsDoc mb_doc = case mb_doc of
+  Just doc -> do
+    doc' <- rnLHsDoc doc
+    return (Just doc')
+  Nothing -> return Nothing
+
+rnLHsDoc :: LHsDocString -> RnM LHsDocString
+rnLHsDoc (dL->L pos doc) = do
+  doc' <- rnHsDoc doc
+  return (cL pos doc')
+
+rnHsDoc :: HsDocString -> RnM HsDocString
+rnHsDoc = pure
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnNames.hs
@@ -0,0 +1,1781 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnNames]{Extracting imported and top-level names in scope}
+-}
+
+{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module RnNames (
+        rnImports, getLocalNonValBinders, newRecordSelector,
+        extendGlobalRdrEnvRn,
+        gresFromAvails,
+        calculateAvails,
+        reportUnusedNames,
+        checkConName,
+        mkChildEnv,
+        findChildren,
+        dodgyMsg,
+        dodgyMsgInsert,
+        findImportUsage,
+        getMinimalImports,
+        printMinimalImports,
+        ImportDeclUsage
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import HsSyn
+import TcEnv
+import RnEnv
+import RnFixity
+import RnUtils          ( warnUnusedTopBinds, mkFieldEnv )
+import LoadIface        ( loadSrcInterface )
+import TcRnMonad
+import PrelNames
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import FieldLabel
+import HscTypes
+import RdrName
+import RdrHsSyn        ( setRdrNameSpace )
+import Outputable
+import Maybes
+import SrcLoc
+import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )
+import Util
+import FastString
+import FastStringEnv
+import Id
+import Type
+import PatSyn
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Either      ( partitionEithers, isRight, rights )
+import Data.Map         ( Map )
+import qualified Data.Map as Map
+import Data.Ord         ( comparing )
+import Data.List        ( partition, (\\), find, sortBy )
+import qualified Data.Set as S
+import System.FilePath  ((</>))
+
+import System.IO
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{rnImports}
+*                                                                      *
+************************************************************************
+
+Note [Tracking Trust Transitively]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we import a package as well as checking that the direct imports are safe
+according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]
+we must also check that these rules hold transitively for all dependent modules
+and packages. Doing this without caching any trust information would be very
+slow as we would need to touch all packages and interface files a module depends
+on. To avoid this we make use of the property that if a modules Safe Haskell
+mode changes, this triggers a recompilation from that module in the dependcy
+graph. So we can just worry mostly about direct imports.
+
+There is one trust property that can change for a package though without
+recompliation being triggered: package trust. So we must check that all
+packages a module tranitively depends on to be trusted are still trusted when
+we are compiling this module (as due to recompilation avoidance some modules
+below may not be considered trusted any more without recompilation being
+triggered).
+
+We handle this by augmenting the existing transitive list of packages a module M
+depends on with a bool for each package that says if it must be trusted when the
+module M is being checked for trust. This list of trust required packages for a
+single import is gathered in the rnImportDecl function and stored in an
+ImportAvails data structure. The union of these trust required packages for all
+imports is done by the rnImports function using the combine function which calls
+the plusImportAvails function that is a union operation for the ImportAvails
+type. This gives us in an ImportAvails structure all packages required to be
+trusted for the module we are currently compiling. Checking that these packages
+are still trusted (and that direct imports are trusted) is done in
+HscMain.checkSafeImports.
+
+See the note below, [Trust Own Package] for a corner case in this method and
+how its handled.
+
+
+Note [Trust Own Package]
+~~~~~~~~~~~~~~~~~~~~~~~~
+There is a corner case of package trust checking that the usual transitive check
+doesn't cover. (For how the usual check operates see the Note [Tracking Trust
+Transitively] below). The case is when you import a -XSafe module M and M
+imports a -XTrustworthy module N. If N resides in a different package than M,
+then the usual check works as M will record a package dependency on N's package
+and mark it as required to be trusted. If N resides in the same package as M
+though, then importing M should require its own package be trusted due to N
+(since M is -XSafe so doesn't create this requirement by itself). The usual
+check fails as a module doesn't record a package dependency of its own package.
+So instead we now have a bool field in a modules interface file that simply
+states if the module requires its own package to be trusted. This field avoids
+us having to load all interface files that the module depends on to see if one
+is trustworthy.
+
+
+Note [Trust Transitive Property]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+So there is an interesting design question in regards to transitive trust
+checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
+of modules and packages, some packages it requires to be trusted as its using
+-XTrustworthy modules from them. Now if I have a module A that doesn't use safe
+haskell at all and simply imports B, should A inherit all the trust
+requirements from B? Should A now also require that a package p is trusted since
+B required it?
+
+We currently say no but saying yes also makes sense. The difference is, if a
+module M that doesn't use Safe Haskell imports a module N that does, should all
+the trusted package requirements be dropped since M didn't declare that it cares
+about Safe Haskell (so -XSafe is more strongly associated with the module doing
+the importing) or should it be done still since the author of the module N that
+uses Safe Haskell said they cared (so -XSafe is more strongly associated with
+the module that was compiled that used it).
+
+Going with yes is a simpler semantics we think and harder for the user to stuff
+up but it does mean that Safe Haskell will affect users who don't care about
+Safe Haskell as they might grab a package from Cabal which uses safe haskell (say
+network) and that packages imports -XTrustworthy modules from another package
+(say bytestring), so requires that package is trusted. The user may now get
+compilation errors in code that doesn't do anything with Safe Haskell simply
+because they are using the network package. They will have to call 'ghc-pkg
+trust network' to get everything working. Due to this invasive nature of going
+with yes we have gone with no for now.
+-}
+
+-- | Process Import Decls.  See 'rnImportDecl' for a description of what
+-- the return types represent.
+-- Note: Do the non SOURCE ones first, so that we get a helpful warning
+-- for SOURCE ones that are unnecessary
+rnImports :: [LImportDecl GhcPs]
+          -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
+rnImports imports = do
+    tcg_env <- getGblEnv
+    -- NB: want an identity module here, because it's OK for a signature
+    -- module to import from its implementor
+    let this_mod = tcg_mod tcg_env
+    let (source, ordinary) = partition is_source_import imports
+        is_source_import d = ideclSource (unLoc d)
+    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
+    stuff2 <- mapAndReportM (rnImportDecl this_mod) source
+    -- Safe Haskell: See Note [Tracking Trust Transitively]
+    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)
+    return (decls, rdr_env, imp_avails, hpc_usage)
+
+  where
+    -- See Note [Combining ImportAvails]
+    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
+            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
+    combine ss =
+      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr
+            plus
+            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)
+            ss
+      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },
+            hpc_usage)
+
+    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)
+         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)
+      = ( decl:decls,
+          gbl_env1 `plusGlobalRdrEnv` gbl_env2,
+          imp_avails1' `plusImportAvails` imp_avails2,
+          hpc_usage1 || hpc_usage2,
+          extendModuleSetList finsts_set new_finsts )
+      where
+      imp_avails1' = imp_avails1 { imp_finsts = [] }
+      new_finsts = imp_finsts imp_avails1
+
+{-
+Note [Combining ImportAvails]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+imp_finsts in ImportAvails is a list of family instance modules
+transitively depended on by an import. imp_finsts for a currently
+compiled module is a union of all the imp_finsts of imports.
+Computing the union of two lists of size N is O(N^2) and if we
+do it to M imports we end up with O(M*N^2). That can get very
+expensive for bigger module hierarchies.
+
+Union can be optimized to O(N log N) if we use a Set.
+imp_finsts is converted back and forth between dep_finsts, so
+changing a type of imp_finsts means either paying for the conversions
+or changing the type of dep_finsts as well.
+
+I've measured that the conversions would cost 20% of allocations on my
+test case, so that can be ruled out.
+
+Changing the type of dep_finsts forces checkFamInsts to
+get the module lists in non-deterministic order. If we wanted to restore
+the deterministic order, we'd have to sort there, which is an additional
+cost. As far as I can tell, using a non-deterministic order is fine there,
+but that's a brittle nonlocal property which I'd like to avoid.
+
+Additionally, dep_finsts is read from an interface file, so its "natural"
+type is a list. Which makes it a natural type for imp_finsts.
+
+Since rnImports.combine is really the only place that would benefit from
+it being a Set, it makes sense to optimize the hot loop in rnImports.combine
+without changing the representation.
+
+So here's what we do: instead of naively merging ImportAvails with
+plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts
+and compute the union on the side using Sets. When we're done, we can
+convert it back to a list. One nice side effect of this approach is that
+if there's a lot of overlap in the imp_finsts of imports, the
+Set doesn't really need to grow and we don't need to allocate.
+
+Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in
+23s before, and 11s after.
+-}
+
+
+
+-- | Given a located import declaration @decl@ from @this_mod@,
+-- calculate the following pieces of information:
+--
+--  1. An updated 'LImportDecl', where all unresolved 'RdrName' in
+--     the entity lists have been resolved into 'Name's,
+--
+--  2. A 'GlobalRdrEnv' representing the new identifiers that were
+--     brought into scope (taking into account module qualification
+--     and hiding),
+--
+--  3. 'ImportAvails' summarizing the identifiers that were imported
+--     by this declaration, and
+--
+--  4. A boolean 'AnyHpcUsage' which is true if the imported module
+--     used HPC.
+rnImportDecl  :: Module -> LImportDecl GhcPs
+             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
+rnImportDecl this_mod
+             (L loc decl@(ImportDecl { ideclExt = noExt
+                                     , ideclName = loc_imp_mod_name
+                                     , ideclPkgQual = mb_pkg
+                                     , ideclSource = want_boot, ideclSafe = mod_safe
+                                     , ideclQualified = qual_style, ideclImplicit = implicit
+                                     , ideclAs = as_mod, ideclHiding = imp_details }))
+  = setSrcSpan loc $ do
+
+    when (isJust mb_pkg) $ do
+        pkg_imports <- xoptM LangExt.PackageImports
+        when (not pkg_imports) $ addErr packageImportErr
+
+    let qual_only = isImportDeclQualified qual_style
+
+    -- If there's an error in loadInterface, (e.g. interface
+    -- file not found) we get lots of spurious errors from 'filterImports'
+    let imp_mod_name = unLoc loc_imp_mod_name
+        doc = ppr imp_mod_name <+> text "is directly imported"
+
+    -- Check for self-import, which confuses the typechecker (#9032)
+    -- ghc --make rejects self-import cycles already, but batch-mode may not
+    -- at least not until TcIface.tcHiBootIface, which is too late to avoid
+    -- typechecker crashes.  (Indirect self imports are not caught until
+    -- TcIface, see #10337 tracking how to make this error better.)
+    --
+    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this
+    -- caused bug #10182: in one-shot mode, we should never load an hs-boot
+    -- file for the module we are compiling into the EPS.  In principle,
+    -- it should be possible to support this mode of use, but we would have to
+    -- extend Provenance to support a local definition in a qualified location.
+    -- For now, we don't support it, but see #10336
+    when (imp_mod_name == moduleName this_mod &&
+          (case mb_pkg of  -- If we have import "<pkg>" M, then we should
+                           -- check that "<pkg>" is "this" (which is magic)
+                           -- or the name of this_mod's package.  Yurgh!
+                           -- c.f. GHC.findModule, and #9997
+             Nothing         -> True
+             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||
+                            fsToUnitId pkg_fs == moduleUnitId this_mod))
+         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))
+
+    -- Check for a missing import list (Opt_WarnMissingImportList also
+    -- checks for T(..) items but that is done in checkDodgyImport below)
+    case imp_details of
+        Just (False, _) -> return () -- Explicit import list
+        _  | implicit   -> return () -- Do not bleat for implicit imports
+           | qual_only  -> return ()
+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $
+                           addWarn (Reason Opt_WarnMissingImportList)
+                                   (missingImportListWarn imp_mod_name)
+
+    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
+
+    -- Compiler sanity check: if the import didn't say
+    -- {-# SOURCE #-} we should not get a hi-boot file
+    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do
+
+    -- Issue a user warning for a redundant {- SOURCE -} import
+    -- NB that we arrange to read all the ordinary imports before
+    -- any of the {- SOURCE -} imports.
+    --
+    -- in --make and GHCi, the compilation manager checks for this,
+    -- and indeed we shouldn't do it here because the existence of
+    -- the non-boot module depends on the compilation order, which
+    -- is not deterministic.  The hs-boot test can show this up.
+    dflags <- getDynFlags
+    warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
+           (warnRedundantSourceImport imp_mod_name)
+    when (mod_safe && not (safeImportsOn dflags)) $
+        addErr (text "safe import can't be used as Safe Haskell isn't on!"
+                $+$ ptext (sLit $ "please enable Safe Haskell through either "
+                                   ++ "Safe, Trustworthy or Unsafe"))
+
+    let
+        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
+        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
+                                  is_dloc = loc, is_as = qual_mod_name }
+
+    -- filter the imports according to the import declaration
+    (new_imp_details, gres) <- filterImports iface imp_spec imp_details
+
+    -- for certain error messages, we’d like to know what could be imported
+    -- here, if everything were imported
+    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing
+
+    let gbl_env = mkGlobalRdrEnv gres
+
+        is_hiding | Just (True,_) <- imp_details = True
+                  | otherwise                    = False
+
+        -- should the import be safe?
+        mod_safe' = mod_safe
+                    || (not implicit && safeDirectImpsReq dflags)
+                    || (implicit && safeImplicitImpsReq dflags)
+
+    let imv = ImportedModsVal
+            { imv_name        = qual_mod_name
+            , imv_span        = loc
+            , imv_is_safe     = mod_safe'
+            , imv_is_hiding   = is_hiding
+            , imv_all_exports = potential_gres
+            , imv_qualified   = qual_only
+            }
+        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)
+
+    -- Complain if we import a deprecated module
+    whenWOptM Opt_WarnWarningsDeprecations (
+       case (mi_warns iface) of
+          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
+                                (moduleWarn imp_mod_name txt)
+          _           -> return ()
+     )
+
+    let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'
+                                   , ideclHiding = new_imp_details })
+
+    return (new_imp_decl, gbl_env, imports, mi_hpc iface)
+rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"
+
+-- | Calculate the 'ImportAvails' induced by an import of a particular
+-- interface, but without 'imp_mods'.
+calculateAvails :: DynFlags
+                -> ModIface
+                -> IsSafeImport
+                -> IsBootInterface
+                -> ImportedBy
+                -> ImportAvails
+calculateAvails dflags iface mod_safe' want_boot imported_by =
+  let imp_mod    = mi_module iface
+      imp_sem_mod= mi_semantic_module iface
+      orph_iface = mi_orphan iface
+      has_finsts = mi_finsts iface
+      deps       = mi_deps iface
+      trust      = getSafeMode $ mi_trust iface
+      trust_pkg  = mi_trust_pkg iface
+
+      -- If the module exports anything defined in this module, just
+      -- ignore it.  Reason: otherwise it looks as if there are two
+      -- local definition sites for the thing, and an error gets
+      -- reported.  Easiest thing is just to filter them out up
+      -- front. This situation only arises if a module imports
+      -- itself, or another module that imported it.  (Necessarily,
+      -- this invoves a loop.)
+      --
+      -- We do this *after* filterImports, so that if you say
+      --      module A where
+      --         import B( AType )
+      --         type AType = ...
+      --
+      --      module B( AType ) where
+      --         import {-# SOURCE #-} A( AType )
+      --
+      -- then you won't get a 'B does not export AType' message.
+
+
+      -- Compute new transitive dependencies
+      --
+      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module
+      -- itself, but we DO need to include this module in 'imp_orphs' and
+      -- 'imp_finsts' if it defines an orphan or instance family; thus the
+      -- orph_iface/has_iface tests.
+
+      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+                             imp_sem_mod : dep_orphs deps
+              | otherwise  = dep_orphs deps
+
+      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+                            imp_sem_mod : dep_finsts deps
+             | otherwise  = dep_finsts deps
+
+      pkg = moduleUnitId (mi_module iface)
+      ipkg = toInstalledUnitId pkg
+
+      -- Does this import mean we now require our own pkg
+      -- to be trusted? See Note [Trust Own Package]
+      ptrust = trust == Sf_Trustworthy || trust_pkg
+
+      (dependent_mods, dependent_pkgs, pkg_trust_req)
+         | pkg == thisPackage dflags =
+            -- Imported module is from the home package
+            -- Take its dependent modules and add imp_mod itself
+            -- Take its dependent packages unchanged
+            --
+            -- NB: (dep_mods deps) might include a hi-boot file
+            -- for the module being compiled, CM. Do *not* filter
+            -- this out (as we used to), because when we've
+            -- finished dealing with the direct imports we want to
+            -- know if any of them depended on CM.hi-boot, in
+            -- which case we should do the hi-boot consistency
+            -- check.  See LoadIface.loadHiBootInterface
+            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)
+
+         | otherwise =
+            -- Imported module is from another package
+            -- Dump the dependent modules
+            -- Add the package imp_mod comes from to the dependent packages
+            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))
+                   , ppr ipkg <+> ppr (dep_pkgs deps) )
+            ([], (ipkg, False) : dep_pkgs deps, False)
+
+  in ImportAvails {
+          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],
+          imp_orphs      = orphans,
+          imp_finsts     = finsts,
+          imp_dep_mods   = mkModDeps dependent_mods,
+          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,
+          -- Add in the imported modules trusted package
+          -- requirements. ONLY do this though if we import the
+          -- module as a safe import.
+          -- See Note [Tracking Trust Transitively]
+          -- and Note [Trust Transitive Property]
+          imp_trust_pkgs = if mod_safe'
+                               then S.fromList . map fst $ filter snd dependent_pkgs
+                               else S.empty,
+          -- Do we require our own pkg to be trusted?
+          -- See Note [Trust Own Package]
+          imp_trust_own_pkg = pkg_trust_req
+     }
+
+
+warnRedundantSourceImport :: ModuleName -> SDoc
+warnRedundantSourceImport mod_name
+  = text "Unnecessary {-# SOURCE #-} in the import of module"
+          <+> quotes (ppr mod_name)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{importsFromLocalDecls}
+*                                                                      *
+************************************************************************
+
+From the top-level declarations of this module produce
+        * the lexical environment
+        * the ImportAvails
+created by its bindings.
+
+Note [Top-level Names in Template Haskell decl quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also: Note [Interactively-bound Ids in GHCi] in HscTypes
+          Note [Looking up Exact RdrNames] in RnEnv
+
+Consider a Template Haskell declaration quotation like this:
+      module M where
+        f x = h [d| f = 3 |]
+When renaming the declarations inside [d| ...|], we treat the
+top level binders specially in two ways
+
+1.  We give them an Internal Name, not (as usual) an External one.
+    This is done by RnEnv.newTopSrcBinder.
+
+2.  We make them *shadow* the outer bindings.
+    See Note [GlobalRdrEnv shadowing]
+
+3. We find out whether we are inside a [d| ... |] by testing the TH
+   stage. This is a slight hack, because the stage field was really
+   meant for the type checker, and here we are not interested in the
+   fields of Brack, hence the error thunks in thRnBrack.
+-}
+
+extendGlobalRdrEnvRn :: [AvailInfo]
+                     -> MiniFixityEnv
+                     -> RnM (TcGblEnv, TcLclEnv)
+-- Updates both the GlobalRdrEnv and the FixityEnv
+-- We return a new TcLclEnv only because we might have to
+-- delete some bindings from it;
+-- see Note [Top-level Names in Template Haskell decl quotes]
+
+extendGlobalRdrEnvRn avails new_fixities
+  = do  { (gbl_env, lcl_env) <- getEnvs
+        ; stage <- getStage
+        ; isGHCi <- getIsGHCi
+        ; let rdr_env  = tcg_rdr_env gbl_env
+              fix_env  = tcg_fix_env gbl_env
+              th_bndrs = tcl_th_bndrs lcl_env
+              th_lvl   = thLevel stage
+
+              -- Delete new_occs from global and local envs
+              -- If we are in a TemplateHaskell decl bracket,
+              --    we are going to shadow them
+              -- See Note [GlobalRdrEnv shadowing]
+              inBracket = isBrackStage stage
+
+              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
+                           -- See Note [GlobalRdrEnv shadowing]
+
+              lcl_env2 | inBracket = lcl_env_TH
+                       | otherwise = lcl_env
+
+              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]
+              want_shadowing = isGHCi || inBracket
+              rdr_env1 | want_shadowing = shadowNames rdr_env new_names
+                       | otherwise      = rdr_env
+
+              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
+                                                       [ (n, (TopLevel, th_lvl))
+                                                       | n <- new_names ] }
+
+        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
+
+        ; let fix_env' = foldl' extend_fix_env fix_env new_gres
+              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
+
+        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
+        ; return (gbl_env', lcl_env3) }
+  where
+    new_names = concatMap availNames avails
+    new_occs  = map nameOccName new_names
+
+    -- If there is a fixity decl for the gre, add it to the fixity env
+    extend_fix_env fix_env gre
+      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
+      = extendNameEnv fix_env name (FixItem occ fi)
+      | otherwise
+      = fix_env
+      where
+        name = gre_name gre
+        occ  = greOccName gre
+
+    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails
+    new_gres = concatMap localGREsFromAvail avails
+
+    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv
+    -- Extend the GlobalRdrEnv with a LocalDef GRE
+    -- If there is already a LocalDef GRE with the same OccName,
+    --    report an error and discard the new GRE
+    -- This establishes INVARIANT 1 of GlobalRdrEnvs
+    add_gre env gre
+      | not (null dups)    -- Same OccName defined twice
+      = do { addDupDeclErr (gre : dups); return env }
+
+      | otherwise
+      = return (extendGlobalRdrEnv env gre)
+      where
+        name = gre_name gre
+        occ  = nameOccName name
+        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)
+
+
+{- *********************************************************************
+*                                                                      *
+    getLocalDeclBindersd@ returns the names for an HsDecl
+             It's used for source code.
+
+        *** See Note [The Naming story] in HsDecls ****
+*                                                                      *
+********************************************************************* -}
+
+getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs
+    -> RnM ((TcGblEnv, TcLclEnv), NameSet)
+-- Get all the top-level binders bound the group *except*
+-- for value bindings, which are treated separately
+-- Specifically we return AvailInfo for
+--      * type decls (incl constructors and record selectors)
+--      * class decls (including class ops)
+--      * associated types
+--      * foreign imports
+--      * value signatures (in hs-boot files only)
+
+getLocalNonValBinders fixity_env
+     (HsGroup { hs_valds  = binds,
+                hs_tyclds = tycl_decls,
+                hs_fords  = foreign_decls })
+  = do  { -- Process all type/class decls *except* family instances
+        ; let inst_decls = tycl_decls >>= group_instds
+        ; overload_ok <- xoptM LangExt.DuplicateRecordFields
+        ; (tc_avails, tc_fldss)
+            <- fmap unzip $ mapM (new_tc overload_ok)
+                                 (tyClGroupTyClDecls tycl_decls)
+        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
+        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
+        ; setEnvs envs $ do {
+            -- Bring these things into scope first
+            -- See Note [Looking up family names in family instances]
+
+          -- Process all family instances
+          -- to bring new data constructors into scope
+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)
+                                                   inst_decls
+
+          -- Finish off with value binders:
+          --    foreign decls and pattern synonyms for an ordinary module
+          --    type sigs in case of a hs-boot file only
+        ; is_boot <- tcIsHsBootOrSig
+        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs
+                        | otherwise = for_hs_bndrs
+        ; val_avails <- mapM new_simple val_bndrs
+
+        ; let avails    = concat nti_availss ++ val_avails
+              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
+                          availsToNameSetWithSelectors tc_avails
+              flds      = concat nti_fldss ++ concat tc_fldss
+        ; traceRn "getLocalNonValBinders 2" (ppr avails)
+        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
+
+        -- Extend tcg_field_env with new fields (this used to be the
+        -- work of extendRecordFieldEnv)
+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
+              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)
+
+        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
+        ; return (envs, new_bndrs) } }
+  where
+    ValBinds _ _val_binds val_sigs = binds
+
+    for_hs_bndrs :: [Located RdrName]
+    for_hs_bndrs = hsForeignDeclsBinders foreign_decls
+
+    -- In a hs-boot file, the value binders come from the
+    --  *signatures*, and there should be no foreign binders
+    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
+                        | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
+
+      -- the SrcSpan attached to the input should be the span of the
+      -- declaration, not just the name
+    new_simple :: Located RdrName -> RnM AvailInfo
+    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
+                            ; return (avail nm) }
+
+    new_tc :: Bool -> LTyClDecl GhcPs
+           -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_tc overload_ok tc_decl -- NOT for type/data instances
+        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
+             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
+             ; let fld_env = case unLoc tc_decl of
+                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
+                     _                            -> []
+             ; return (AvailTC main_name names flds', fld_env) }
+
+
+    -- Calculate the mapping from constructor names to fields, which
+    -- will go in tcg_field_env. It's convenient to do this here where
+    -- we are working with a single datatype definition.
+    mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]
+               -> [(Name, [FieldLabel])]
+    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
+      where
+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
+                                       , con_args = RecCon cdflds }))
+            = [( find_con_name rdr
+               , concatMap find_con_decl_flds (unLoc cdflds) )]
+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs
+                                        , con_args = RecCon flds }))
+            = [ ( find_con_name rdr
+                 , concatMap find_con_decl_flds (unLoc flds))
+              | L _ rdr <- rdrs ]
+
+        find_con_flds _ = []
+
+        find_con_name rdr
+          = expectJust "getLocalNonValBinders/find_con_name" $
+              find (\ n -> nameOccName n == rdrNameOcc rdr) names
+        find_con_decl_flds (L _ x)
+          = map find_con_decl_fld (cd_fld_names x)
+
+        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))
+          = expectJust "getLocalNonValBinders/find_con_decl_fld" $
+              find (\ fl -> flLabel fl == lbl) flds
+          where lbl = occNameFS (rdrNameOcc rdr)
+        find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"
+
+    new_assoc :: Bool -> LInstDecl GhcPs
+              -> RnM ([AvailInfo], [(Name, [FieldLabel])])
+    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
+      -- type instances don't bind new names
+
+    new_assoc overload_ok (L _ (DataFamInstD _ d))
+      = do { (avail, flds) <- new_di overload_ok Nothing d
+           ; return ([avail], flds) }
+    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
+                                                      , cid_datafam_insts = adts })))
+      = do -- First, attempt to grab the name of the class from the instance.
+           -- This step could fail if the instance is not headed by a class,
+           -- such as in the following examples:
+           --
+           -- (1) The class is headed by a bang pattern, such as in
+           --     `instance !Show Int` (#3811c)
+           -- (2) The class is headed by a type variable, such as in
+           --     `instance c` (#16385)
+           --
+           -- If looking up the class name fails, then mb_cls_nm will
+           -- be Nothing.
+           mb_cls_nm <- runMaybeT $ do
+             -- See (1) above
+             L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty
+             -- See (2) above
+             MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr
+           -- Assuming the previous step succeeded, process any associated data
+           -- family instances. If the previous step failed, bail out.
+           case mb_cls_nm of
+             Nothing -> pure ([], [])
+             Just cls_nm -> do
+               (avails, fldss)
+                 <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
+               pure (avails, concat fldss)
+    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"
+    new_assoc _ (L _ (XInstDecl _))                 = panic "new_assoc"
+
+    new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
+                                     HsIB { hsib_body = ti_decl }})
+        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
+             ; let (bndrs, flds) = hsDataFamInstBinders dfid
+             ; sub_names <- mapM newTopSrcBinder bndrs
+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
+             ; let avail    = AvailTC (unLoc main_name) sub_names flds'
+                                  -- main_name is not bound here!
+                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
+             ; return (avail, fld_env) }
+    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"
+
+    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
+getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"
+
+newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
+newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
+newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"
+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
+  = do { selName <- newTopSrcBinder $ L loc $ field
+       ; return $ qualFieldLbl { flSelector = selName } }
+  where
+    fieldOccName = occNameFS $ rdrNameOcc fld
+    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok
+    field | isExact fld = fld
+              -- use an Exact RdrName as is to preserve the bindings
+              -- of an already renamer-resolved field and its use
+              -- sites. This is needed to correctly support record
+              -- selectors in Template Haskell. See Note [Binders in
+              -- Template Haskell] in Convert.hs and Note [Looking up
+              -- Exact RdrNames] in RnEnv.hs.
+          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)
+
+{-
+Note [Looking up family names in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  module M where
+    type family T a :: *
+    type instance M.T Int = Bool
+
+We might think that we can simply use 'lookupOccRn' when processing the type
+instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in
+the *same* HsGroup as the type instance declaration.  Hence, as we are
+currently collecting the binders declared in that HsGroup, these binders will
+not have been added to the global environment yet.
+
+Solution is simple: process the type family declarations first, extend
+the environment, and then process the type instances.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Filtering imports}
+*                                                                      *
+************************************************************************
+
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
+
+Note [Dealing with imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For import M( ies ), we take the mi_exports of M, and make
+   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)
+One entry for each Name that M exports; the AvailInfo is the
+AvailInfo exported from M that exports that Name.
+
+The situation is made more complicated by associated types. E.g.
+   module M where
+     class    C a    where { data T a }
+     instance C Int  where { data T Int = T1 | T2 }
+     instance C Bool where { data T Int = T3 }
+Then M's export_avails are (recall the AvailTC invariant from Avails.hs)
+  C(C,T), T(T,T1,T2,T3)
+Notice that T appears *twice*, once as a child and once as a parent. From
+this list we construct a raw list including
+   T -> (T, T( T1, T2, T3 ), Nothing)
+   T -> (C, C( C, T ),       Nothing)
+and we combine these (in function 'combine' in 'imp_occ_env' in
+'filterImports') to get
+   T  -> (T,  T(T,T1,T2,T3), Just C)
+
+So the overall imp_occ_env is
+   C  -> (C,  C(C,T),        Nothing)
+   T  -> (T,  T(T,T1,T2,T3), Just C)
+   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3
+
+If we say
+   import M( T(T1,T2) )
+then we get *two* Avails:  C(T), T(T1,T2)
+
+Note that the imp_occ_env will have entries for data constructors too,
+although we never look up data constructors.
+-}
+
+filterImports
+    :: ModIface
+    -> ImpDeclSpec                     -- The span for the entire import decl
+    -> Maybe (Bool, Located [LIE GhcPs])    -- Import spec; True => hiding
+    -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names
+            [GlobalRdrElt])                   -- Same again, but in GRE form
+filterImports iface decl_spec Nothing
+  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))
+  where
+    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
+
+
+filterImports iface decl_spec (Just (want_hiding, L l import_items))
+  = do  -- check for errors, convert RdrNames to Names
+        items1 <- mapM lookup_lie import_items
+
+        let items2 :: [(LIE GhcRn, AvailInfo)]
+            items2 = concat items1
+                -- NB the AvailInfo may have duplicates, and several items
+                --    for the same parent; e.g N(x) and N(y)
+
+            names  = availsToNameSetWithSelectors (map snd items2)
+            keep n = not (n `elemNameSet` names)
+            pruned_avails = filterAvails keep all_avails
+            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
+
+            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails
+                 | otherwise   = concatMap (gresFromIE decl_spec) items2
+
+        return (Just (want_hiding, L l (map fst items2)), gres)
+  where
+    all_avails = mi_exports iface
+
+        -- See Note [Dealing with imports]
+    imp_occ_env :: OccEnv (Name,    -- the name
+                           AvailInfo,   -- the export item providing the name
+                           Maybe Name)  -- the parent of associated types
+    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))
+                                     | a <- all_avails
+                                     , (n, occ) <- availNamesWithOccs a]
+      where
+        -- See Note [Dealing with imports]
+        -- 'combine' is only called for associated data types which appear
+        -- twice in the all_avails. In the example, we combine
+        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)
+        -- NB: the AvailTC can have fields as well as data constructors (#12127)
+        combine (name1, a1@(AvailTC p1 _ _), mp1)
+                (name2, a2@(AvailTC p2 _ _), mp2)
+          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2
+                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )
+            if p1 == name1 then (name1, a1, Just p2)
+                           else (name1, a2, Just p1)
+        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
+
+    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
+    lookup_name ie rdr
+       | isQual rdr              = failLookupWith (QualImportError rdr)
+       | Just succ <- mb_success = return succ
+       | otherwise               = failLookupWith (BadImport ie)
+      where
+        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
+
+    lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]
+    lookup_lie (L loc ieRdr)
+        = do (stuff, warns) <- setSrcSpan loc $
+                               liftM (fromMaybe ([],[])) $
+                               run_lookup (lookup_ie ieRdr)
+             mapM_ emit_warning warns
+             return [ (L loc ie, avail) | (ie,avail) <- stuff ]
+        where
+            -- Warn when importing T(..) if T was exported abstractly
+            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $
+              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
+            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
+              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $
+              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))
+
+            run_lookup :: IELookupM a -> TcRn (Maybe a)
+            run_lookup m = case m of
+              Failed err -> addErr (lookup_err_msg err) >> return Nothing
+              Succeeded a -> return (Just a)
+
+            lookup_err_msg err = case err of
+              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails
+              IllegalImport -> illegalImportItemErr
+              QualImportError rdr -> qualImportItemErr rdr
+
+        -- For each import item, we convert its RdrNames to Names,
+        -- and at the same time construct an AvailInfo corresponding
+        -- to what is actually imported by this item.
+        -- Returns Nothing on error.
+        -- We return a list here, because in the case of an import
+        -- item like C, if we are hiding, then C refers to *both* a
+        -- type/class and a data constructor.  Moreover, when we import
+        -- data constructors of an associated family, we need separate
+        -- AvailInfos for the data constructors and the family (as they have
+        -- different parents).  See Note [Dealing with imports]
+    lookup_ie :: IE GhcPs
+              -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
+    lookup_ie ie = handle_bad_import $ do
+      case ie of
+        IEVar _ (L l n) -> do
+            (name, avail, _) <- lookup_name ie $ ieWrappedName n
+            return ([(IEVar noExt (L l (replaceWrappedName n name)),
+                                                  trimAvail avail name)], [])
+
+        IEThingAll _ (L l tc) -> do
+            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc
+            let warns = case avail of
+                          Avail {}                     -- e.g. f(..)
+                            -> [DodgyImport $ ieWrappedName tc]
+
+                          AvailTC _ subs fs
+                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
+                            -> [DodgyImport $ ieWrappedName tc]
+
+                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )
+                            -> [MissingImportList]
+
+                            | otherwise
+                            -> []
+
+                renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))
+                sub_avails = case avail of
+                               Avail {}              -> []
+                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
+            case mb_parent of
+              Nothing     -> return ([(renamed_ie, avail)], warns)
+                             -- non-associated ty/cls
+              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
+                             -- associated type
+
+        IEThingAbs _ (L l tc')
+            | want_hiding   -- hiding ( C )
+                       -- Here the 'C' can be a data constructor
+                       --  *or* a type/class, or even both
+            -> let tc = ieWrappedName tc'
+                   tc_name = lookup_name ie tc
+                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
+               in
+               case catIELookupM [ tc_name, dc_name ] of
+                 []    -> failLookupWith (BadImport ie)
+                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])
+            | otherwise
+            -> do nameAvail <- lookup_name ie (ieWrappedName tc')
+                  return ([mkIEThingAbs tc' l nameAvail]
+                         , [])
+
+        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
+          ASSERT2(null rdr_fs, ppr rdr_fs) do
+           (name, avail, mb_parent)
+               <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)
+
+           let (ns,subflds) = case avail of
+                                AvailTC _ ns' subflds' -> (ns',subflds')
+                                Avail _                -> panic "filterImports"
+
+           -- Look up the children in the sub-names of the parent
+           let subnames = case ns of   -- The tc is first in ns,
+                            [] -> []   -- if it is there at all
+                                       -- See the AvailTC Invariant in Avail.hs
+                            (n1:ns1) | n1 == name -> ns1
+                                     | otherwise  -> ns
+           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
+
+             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))
+                                -- We are trying to import T( a,b,c,d ), and failed
+                                -- to find 'b' and 'd'.  So we make up an import item
+                                -- to report as failing, namely T( b, d ).
+                                -- c.f. #15412
+
+             Succeeded (childnames, childflds) ->
+               case mb_parent of
+                 -- non-associated ty/cls
+                 Nothing
+                   -> return ([(IEThingWith noExt (L l name') wc childnames'
+                                                                 childflds,
+                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
+                              [])
+                   where name' = replaceWrappedName rdr_tc name
+                         childnames' = map to_ie_post_rn childnames
+                         -- childnames' = postrn_ies childnames
+                 -- associated ty
+                 Just parent
+                   -> return ([(IEThingWith noExt (L l name') wc childnames'
+                                                           childflds,
+                                AvailTC name (map unLoc childnames) (map unLoc childflds)),
+                               (IEThingWith noExt (L l name') wc childnames'
+                                                           childflds,
+                                AvailTC parent [name] [])],
+                              [])
+                   where name' = replaceWrappedName rdr_tc name
+                         childnames' = map to_ie_post_rn childnames
+
+        _other -> failLookupWith IllegalImport
+        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
+        -- all errors.
+
+      where
+        mkIEThingAbs tc l (n, av, Nothing    )
+          = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)
+        mkIEThingAbs tc l (n, _,  Just parent)
+          = (IEThingAbs noExt (L l (replaceWrappedName tc n))
+             , AvailTC parent [n] [])
+
+        handle_bad_import m = catchIELookup m $ \err -> case err of
+          BadImport ie | want_hiding -> return ([], [BadImportW ie])
+          _                          -> failLookupWith err
+
+type IELookupM = MaybeErr IELookupError
+
+data IELookupWarning
+  = BadImportW (IE GhcPs)
+  | MissingImportList
+  | DodgyImport RdrName
+  -- NB. use the RdrName for reporting a "dodgy" import
+
+data IELookupError
+  = QualImportError RdrName
+  | BadImport (IE GhcPs)
+  | IllegalImport
+
+failLookupWith :: IELookupError -> IELookupM a
+failLookupWith err = Failed err
+
+catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a
+catchIELookup m h = case m of
+  Succeeded r -> return r
+  Failed err  -> h err
+
+catIELookupM :: [IELookupM a] -> [a]
+catIELookupM ms = [ a | Succeeded a <- ms ]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Import/Export Utils}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
+gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]
+gresFromIE decl_spec (L loc ie, avail)
+  = gresFromAvail prov_fn avail
+  where
+    is_explicit = case ie of
+                    IEThingAll _ name -> \n -> n == lieWrappedName name
+                    _                 -> \_ -> True
+    prov_fn name
+      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
+      where
+        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
+
+
+{-
+Note [Children for duplicate record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the module
+
+    {-# LANGUAGE DuplicateRecordFields #-}
+    module M (F(foo, MkFInt, MkFBool)) where
+      data family F a
+      data instance F Int = MkFInt { foo :: Int }
+      data instance F Bool = MkFBool { foo :: Bool }
+
+The `foo` in the export list refers to *both* selectors! For this
+reason, lookupChildren builds an environment that maps the FastString
+to a list of items, rather than a single item.
+-}
+
+mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
+mkChildEnv gres = foldr add emptyNameEnv gres
+  where
+    add gre env = case gre_par gre of
+        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre
+        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre
+        NoParent       -> env
+
+findChildren :: NameEnv [a] -> Name -> [a]
+findChildren env n = lookupNameEnv env n `orElse` []
+
+lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]
+               -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed
+                           ([Located Name], [Located FieldLabel])
+-- (lookupChildren all_kids rdr_items) maps each rdr_item to its
+-- corresponding Name all_kids, if the former exists
+-- The matching is done by FastString, not OccName, so that
+--    Cls( meth, AssocTy )
+-- will correctly find AssocTy among the all_kids of Cls, even though
+-- the RdrName for AssocTy may have a (bogus) DataName namespace
+-- (Really the rdr_items should be FastStrings in the first place.)
+lookupChildren all_kids rdr_items
+  | null fails
+  = Succeeded (fmap concat (partitionEithers oks))
+       -- This 'fmap concat' trickily applies concat to the /second/ component
+       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])
+  | otherwise
+  = Failed fails
+  where
+    mb_xs = map doOne rdr_items
+    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
+    oks   = [ ok      | Succeeded ok   <- mb_xs ]
+    oks :: [Either (Located Name) [Located FieldLabel]]
+
+    doOne item@(L l r)
+       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
+           Just [Left n]            -> Succeeded (Left (L l n))
+           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))
+           _                        -> Failed    item
+
+    -- See Note [Children for duplicate record fields]
+    kid_env = extendFsEnvList_C (++) emptyFsEnv
+              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+
+
+
+-------------------------------
+
+{-
+*********************************************************
+*                                                       *
+\subsection{Unused names}
+*                                                       *
+*********************************************************
+-}
+
+reportUnusedNames :: Maybe (Located [LIE GhcPs])  -- Export list
+                  -> TcGblEnv -> RnM ()
+reportUnusedNames _export_decls gbl_env
+  = do  { traceRn "RUN" (ppr (tcg_dus gbl_env))
+        ; warnUnusedImportDecls gbl_env
+        ; warnUnusedTopBinds unused_locals
+        ; warnMissingSignatures gbl_env }
+  where
+    used_names :: NameSet
+    used_names = findUses (tcg_dus gbl_env) emptyNameSet
+    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used
+    -- Hence findUses
+
+    -- Collect the defined names from the in-scope environment
+    defined_names :: [GlobalRdrElt]
+    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)
+
+    -- Note that defined_and_used, defined_but_not_used
+    -- are both [GRE]; that's why we need defined_and_used
+    -- rather than just used_names
+    _defined_and_used, defined_but_not_used :: [GlobalRdrElt]
+    (_defined_and_used, defined_but_not_used)
+        = partition (gre_is_used used_names) defined_names
+
+    kids_env = mkChildEnv defined_names
+    -- This is done in mkExports too; duplicated work
+
+    gre_is_used :: NameSet -> GlobalRdrElt -> Bool
+    gre_is_used used_names (GRE {gre_name = name})
+        = name `elemNameSet` used_names
+          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)
+                -- A use of C implies a use of T,
+                -- if C was brought into scope by T(..) or T(C)
+
+    -- Filter out the ones that are
+    --  (a) defined in this module, and
+    --  (b) not defined by a 'deriving' clause
+    -- The latter have an Internal Name, so we can filter them out easily
+    unused_locals :: [GlobalRdrElt]
+    unused_locals = filter is_unused_local defined_but_not_used
+    is_unused_local :: GlobalRdrElt -> Bool
+    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)
+
+{- *********************************************************************
+*                                                                      *
+              Missing signatures
+*                                                                      *
+********************************************************************* -}
+
+-- | Warn the user about top level binders that lack type signatures.
+-- Called /after/ type inference, so that we can report the
+-- inferred type of the function
+warnMissingSignatures :: TcGblEnv -> RnM ()
+warnMissingSignatures gbl_env
+  = do { let exports = availsToNameSet (tcg_exports gbl_env)
+             sig_ns  = tcg_sigs gbl_env
+               -- We use sig_ns to exclude top-level bindings that are generated by GHC
+             binds    = collectHsBindsBinders $ tcg_binds gbl_env
+             pat_syns = tcg_patsyns gbl_env
+
+         -- Warn about missing signatures
+         -- Do this only when we have a type to offer
+       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures
+       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures
+       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures
+
+       ; let add_sig_warns
+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures
+               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures
+               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures
+               | otherwise          = return ()
+
+             add_warns flag
+                = when warn_pat_syns
+                       (mapM_ add_pat_syn_warn pat_syns) >>
+                  when (warn_missing_sigs || warn_only_exported)
+                       (mapM_ add_bind_warn binds)
+                where
+                  add_pat_syn_warn p
+                    = add_warn name $
+                      hang (text "Pattern synonym with no type signature:")
+                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)
+                    where
+                      name  = patSynName p
+                      pp_ty = pprPatSynType p
+
+                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()
+                  add_bind_warn id
+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?
+                         ; let name    = idName id
+                               (_, ty) = tidyOpenType env (idType id)
+                               ty_msg  = pprSigmaType ty
+                         ; add_warn name $
+                           hang (text "Top-level binding with no type signature:")
+                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }
+
+                  add_warn name msg
+                    = when (name `elemNameSet` sig_ns && export_check name)
+                           (addWarnAt (Reason flag) (getSrcSpan name) msg)
+
+                  export_check name
+                    = not warn_only_exported || name `elemNameSet` exports
+
+       ; add_sig_warns }
+
+
+{-
+*********************************************************
+*                                                       *
+\subsection{Unused imports}
+*                                                       *
+*********************************************************
+
+This code finds which import declarations are unused.  The
+specification and implementation notes are here:
+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports
+
+See also Note [Choosing the best import declaration] in RdrName
+-}
+
+type ImportDeclUsage
+   = ( LImportDecl GhcRn   -- The import declaration
+     , [GlobalRdrElt]      -- What *is* used (normalised)
+     , [Name] )            -- What is imported but *not* used
+
+warnUnusedImportDecls :: TcGblEnv -> RnM ()
+warnUnusedImportDecls gbl_env
+  = do { uses <- readMutVar (tcg_used_gres gbl_env)
+       ; let user_imports = filterOut
+                              (ideclImplicit . unLoc)
+                              (tcg_rn_imports gbl_env)
+                -- This whole function deals only with *user* imports
+                -- both for warning about unnecessary ones, and for
+                -- deciding the minimal ones
+             rdr_env = tcg_rdr_env gbl_env
+             fld_env = mkFieldEnv rdr_env
+
+       ; let usage :: [ImportDeclUsage]
+             usage = findImportUsage user_imports uses
+
+       ; traceRn "warnUnusedImportDecls" $
+                       (vcat [ text "Uses:" <+> ppr uses
+                             , text "Import usage" <+> ppr usage])
+
+       ; whenWOptM Opt_WarnUnusedImports $
+         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
+
+       ; whenGOptM Opt_D_dump_minimal_imports $
+         printMinimalImports usage }
+
+findImportUsage :: [LImportDecl GhcRn]
+                -> [GlobalRdrElt]
+                -> [ImportDeclUsage]
+
+findImportUsage imports used_gres
+  = map unused_decl imports
+  where
+    import_usage :: ImportMap
+    import_usage = mkImportMap used_gres
+
+    unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
+      = (decl, used_gres, nameSetElemsStable unused_imps)
+      where
+        used_gres = Map.lookup (srcSpanEnd loc) import_usage
+                               -- srcSpanEnd: see Note [The ImportMap]
+                    `orElse` []
+
+        used_names   = mkNameSet (map      gre_name        used_gres)
+        used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)
+
+        unused_imps   -- Not trivial; see eg #7454
+          = case imps of
+              Just (False, L _ imp_ies) ->
+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies
+              _other -> emptyNameSet -- No explicit import list => no unused-name list
+
+        add_unused :: IE GhcRn -> NameSet -> NameSet
+        add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc
+        add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc
+        add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc
+        add_unused (IEThingWith _ p wc ns fs) acc =
+          add_wc_all (add_unused_with pn xs acc)
+          where pn = lieWrappedName p
+                xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs
+                add_wc_all = case wc of
+                            NoIEWildcard -> id
+                            IEWildcard _ -> add_unused_all pn
+        add_unused _ acc = acc
+
+        add_unused_name n acc
+          | n `elemNameSet` used_names = acc
+          | otherwise                  = acc `extendNameSet` n
+        add_unused_all n acc
+          | n `elemNameSet` used_names   = acc
+          | n `elemNameSet` used_parents = acc
+          | otherwise                    = acc `extendNameSet` n
+        add_unused_with p ns acc
+          | all (`elemNameSet` acc1) ns = add_unused_name p acc1
+          | otherwise = acc1
+          where
+            acc1 = foldr add_unused_name acc ns
+       -- If you use 'signum' from Num, then the user may well have
+       -- imported Num(signum).  We don't want to complain that
+       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.
+    unused_decl (L _ (XImportDecl _)) = panic "unused_decl"
+
+
+{- Note [The ImportMap]
+~~~~~~~~~~~~~~~~~~~~~~~
+The ImportMap is a short-lived intermediate data structure records, for
+each import declaration, what stuff brought into scope by that
+declaration is actually used in the module.
+
+The SrcLoc is the location of the END of a particular 'import'
+declaration.  Why *END*?  Because we don't want to get confused
+by the implicit Prelude import. Consider (#7476) the module
+    import Foo( foo )
+    main = print foo
+There is an implicit 'import Prelude(print)', and it gets a SrcSpan
+of line 1:1 (just the point, not a span). If we use the *START* of
+the SrcSpan to identify the import decl, we'll confuse the implicit
+import Prelude with the explicit 'import Foo'.  So we use the END.
+It's just a cheap hack; we could equally well use the Span too.
+
+The [GlobalRdrElt] are the things imported from that decl.
+-}
+
+type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]
+     -- If loc :-> gres, then
+     --   'loc' = the end loc of the bestImport of each GRE in 'gres'
+
+mkImportMap :: [GlobalRdrElt] -> ImportMap
+-- For each of a list of used GREs, find all the import decls that brought
+-- it into scope; choose one of them (bestImport), and record
+-- the RdrName in that import decl's entry in the ImportMap
+mkImportMap gres
+  = foldr add_one Map.empty gres
+  where
+    add_one gre@(GRE { gre_imp = imp_specs }) imp_map
+       = Map.insertWith add decl_loc [gre] imp_map
+       where
+          best_imp_spec = bestImport imp_specs
+          decl_loc      = srcSpanEnd (is_dloc (is_decl best_imp_spec))
+                        -- For srcSpanEnd see Note [The ImportMap]
+          add _ gres = gre : gres
+
+warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)
+                 -> ImportDeclUsage -> RnM ()
+warnUnusedImport flag fld_env (L loc decl, used, unused)
+
+  -- Do not warn for 'import M()'
+  | Just (False,L _ []) <- ideclHiding decl
+  = return ()
+
+  -- Note [Do not warn about Prelude hiding]
+  | Just (True, L _ hides) <- ideclHiding decl
+  , not (null hides)
+  , pRELUDE_NAME == unLoc (ideclName decl)
+  = return ()
+
+  -- Nothing used; drop entire declaration
+  | null used
+  = addWarnAt (Reason flag) loc msg1
+
+  -- Everything imported is used; nop
+  | null unused
+  = return ()
+
+  -- Some imports are unused
+  | otherwise
+  = addWarnAt (Reason flag) loc  msg2
+
+  where
+    msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant
+                , nest 2 (text "except perhaps to import instances from"
+                                   <+> quotes pp_mod)
+                , text "To import instances alone, use:"
+                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]
+    msg2 = sep [ pp_herald <+> quotes sort_unused
+               , text "from module" <+> quotes pp_mod <+> is_redundant]
+    pp_herald  = text "The" <+> pp_qual <+> text "import of"
+    pp_qual
+      | isImportDeclQualified (ideclQualified decl)= text "qualified"
+      | otherwise                                  = Outputable.empty
+    pp_mod       = ppr (unLoc (ideclName decl))
+    is_redundant = text "is redundant"
+
+    -- In warning message, pretty-print identifiers unqualified unconditionally
+    -- to improve the consistent for ambiguous/unambiguous identifiers.
+    -- See trac#14881.
+    ppr_possible_field n = case lookupNameEnv fld_env n of
+                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)
+                               Nothing  -> pprNameUnqualified n
+
+    -- Print unused names in a deterministic (lexicographic) order
+    sort_unused :: SDoc
+    sort_unused = pprWithCommas ppr_possible_field $
+                  sortBy (comparing nameOccName) unused
+
+{-
+Note [Do not warn about Prelude hiding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not warn about
+   import Prelude hiding( x, y )
+because even if nothing else from Prelude is used, it may be essential to hide
+x,y to avoid name-shadowing warnings.  Example (#9061)
+   import Prelude hiding( log )
+   f x = log where log = ()
+
+
+
+Note [Printing minimal imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To print the minimal imports we walk over the user-supplied import
+decls, and simply trim their import lists.  NB that
+
+  * We do *not* change the 'qualified' or 'as' parts!
+
+  * We do not disard a decl altogether; we might need instances
+    from it.  Instead we just trim to an empty import list
+-}
+
+getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
+getMinimalImports = mapM mk_minimal
+  where
+    mk_minimal (L l decl, used_gres, unused)
+      | null unused
+      , Just (False, _) <- ideclHiding decl
+      = return (L l decl)
+      | otherwise
+      = do { let ImportDecl { ideclName    = L _ mod_name
+                            , ideclSource  = is_boot
+                            , ideclPkgQual = mb_pkg } = decl
+           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)
+           ; let used_avails = gresToAvailInfo used_gres
+                 lies = map (L l) (concatMap (to_ie iface) used_avails)
+           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }
+      where
+        doc = text "Compute minimal imports for" <+> ppr decl
+
+    to_ie :: ModIface -> AvailInfo -> [IE GhcRn]
+    -- The main trick here is that if we're importing all the constructors
+    -- we want to say "T(..)", but if we're importing only a subset we want
+    -- to say "T(A,B,C)".  So we have to find out what the module exports.
+    to_ie _ (Avail n)
+       = [IEVar noExt (to_ie_post_rn $ noLoc n)]
+    to_ie _ (AvailTC n [m] [])
+       | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]
+    to_ie iface (AvailTC n ns fs)
+      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface
+                 , x == n
+                 , x `elem` xs    -- Note [Partial export]
+                 ] of
+           [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]
+                | otherwise   ->
+                   [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
+                                (map noLoc fs)]
+                                          -- Note [Overloaded field import]
+           _other | all_non_overloaded fs
+                           -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns
+                                 ++ map flSelector fs
+                  | otherwise ->
+                      [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
+                                (map noLoc fs)]
+        where
+
+          fld_lbls = map flLabel fs
+
+          all_used (avail_occs, avail_flds)
+              = all (`elem` ns) avail_occs
+                    && all (`elem` fld_lbls) (map flLabel avail_flds)
+
+          all_non_overloaded = all (not . flIsOverloaded)
+
+printMinimalImports :: [ImportDeclUsage] -> RnM ()
+-- See Note [Printing minimal imports]
+printMinimalImports imports_w_usage
+  = do { imports' <- getMinimalImports imports_w_usage
+       ; this_mod <- getModule
+       ; dflags   <- getDynFlags
+       ; liftIO $
+         do { h <- openFile (mkFilename dflags this_mod) WriteMode
+            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
+              -- The neverQualify is important.  We are printing Names
+              -- but they are in the context of an 'import' decl, and
+              -- we never qualify things inside there
+              -- E.g.   import Blag( f, b )
+              -- not    import Blag( Blag.f, Blag.g )!
+       }
+  where
+    mkFilename dflags this_mod
+      | Just d <- dumpDir dflags = d </> basefn
+      | otherwise                = basefn
+      where
+        basefn = moduleNameString (moduleName this_mod) ++ ".imports"
+
+
+to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
+to_ie_post_rn_var (L l n)
+  | isDataOcc $ occName n = L l (IEPattern (L l n))
+  | otherwise             = L l (IEName    (L l n))
+
+
+to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name
+to_ie_post_rn (L l n)
+  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))
+  | otherwise                   = L l (IEName (L l n))
+  where occ = occName n
+
+{-
+Note [Partial export]
+~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   module A( op ) where
+     class C a where
+       op :: a -> a
+
+   module B where
+   import A
+   f = ..op...
+
+Then the minimal import for module B is
+   import A( op )
+not
+   import A( C( op ) )
+which we would usually generate if C was exported from B.  Hence
+the (x `elem` xs) test when deciding what to generate.
+
+
+Note [Overloaded field import]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On the other hand, if we have
+
+    {-# LANGUAGE DuplicateRecordFields #-}
+    module A where
+      data T = MkT { foo :: Int }
+
+    module B where
+      import A
+      f = ...foo...
+
+then the minimal import for module B must be
+    import A ( T(foo) )
+because when DuplicateRecordFields is enabled, field selectors are
+not in scope without their enclosing datatype.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+qualImportItemErr :: RdrName -> SDoc
+qualImportItemErr rdr
+  = hang (text "Illegal qualified name in import item:")
+       2 (ppr rdr)
+
+badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc
+badImportItemErrStd iface decl_spec ie
+  = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,
+         text "does not export", quotes (ppr ie)]
+  where
+    source_import | mi_boot iface = text "(hi-boot interface)"
+                  | otherwise     = Outputable.empty
+
+badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs
+                        -> SDoc
+badImportItemErrDataCon dataType_occ iface decl_spec ie
+  = vcat [ text "In module"
+             <+> quotes (ppr (is_mod decl_spec))
+             <+> source_import <> colon
+         , nest 2 $ quotes datacon
+             <+> text "is a data constructor of"
+             <+> quotes dataType
+         , text "To import it use"
+         , nest 2 $ text "import"
+             <+> ppr (is_mod decl_spec)
+             <> parens_sp (dataType <> parens_sp datacon)
+         , text "or"
+         , nest 2 $ text "import"
+             <+> ppr (is_mod decl_spec)
+             <> parens_sp (dataType <> text "(..)")
+         ]
+  where
+    datacon_occ = rdrNameOcc $ ieName ie
+    datacon = parenSymOcc datacon_occ (ppr datacon_occ)
+    dataType = parenSymOcc dataType_occ (ppr dataType_occ)
+    source_import | mi_boot iface = text "(hi-boot interface)"
+                  | otherwise     = Outputable.empty
+    parens_sp d = parens (space <> d <> space)  -- T( f,g )
+
+badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc
+badImportItemErr iface decl_spec ie avails
+  = case find checkIfDataCon avails of
+      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
+      Nothing  -> badImportItemErrStd iface decl_spec ie
+  where
+    checkIfDataCon (AvailTC _ ns _) =
+      case find (\n -> importedFS == nameOccNameFS n) ns of
+        Just n  -> isDataConName n
+        Nothing -> False
+    checkIfDataCon _ = False
+    availOccName = nameOccName . availName
+    nameOccNameFS = occNameFS . nameOccName
+    importedFS = occNameFS . rdrNameOcc $ ieName ie
+
+illegalImportItemErr :: SDoc
+illegalImportItemErr = text "Illegal import item"
+
+dodgyImportWarn :: RdrName -> SDoc
+dodgyImportWarn item
+  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)
+
+dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
+dodgyMsg kind tc ie
+  = sep [ text "The" <+> kind <+> ptext (sLit "item")
+                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))
+                     <+> quotes (ppr ie)
+                <+> text "suggests that",
+          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
+          text "but it has none" ]
+
+dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
+dodgyMsgInsert tc = IEThingAll noExt ii
+  where
+    ii :: LIEWrappedName (IdP (GhcPass p))
+    ii = noLoc (IEName $ noLoc tc)
+
+
+addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
+addDupDeclErr [] = panic "addDupDeclErr: empty list"
+addDupDeclErr gres@(gre : _)
+  = addErrAt (getSrcSpan (last sorted_names)) $
+    -- Report the error at the later location
+    vcat [text "Multiple declarations of" <+>
+             quotes (ppr (nameOccName name)),
+             -- NB. print the OccName, not the Name, because the
+             -- latter might not be in scope in the RdrEnv and so will
+             -- be printed qualified.
+          text "Declared at:" <+>
+                   vcat (map (ppr . nameSrcLoc) sorted_names)]
+  where
+    name = gre_name gre
+    sorted_names = sortWith nameSrcLoc (map gre_name gres)
+
+
+
+missingImportListWarn :: ModuleName -> SDoc
+missingImportListWarn mod
+  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")
+
+missingImportListItem :: IE GhcPs -> SDoc
+missingImportListItem ie
+  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")
+
+moduleWarn :: ModuleName -> WarningTxt -> SDoc
+moduleWarn mod (WarningTxt _ txt)
+  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),
+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
+moduleWarn mod (DeprecatedTxt _ txt)
+  = sep [ text "Module" <+> quotes (ppr mod)
+                                <+> text "is deprecated:",
+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
+
+packageImportErr :: SDoc
+packageImportErr
+  = text "Package-qualified imports are not enabled; use PackageImports"
+
+-- This data decl will parse OK
+--      data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+--      data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName :: RdrName -> TcRn ()
+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+
+badDataCon :: RdrName -> SDoc
+badDataCon name
+   = hsep [text "Illegal data constructor name", quotes (ppr name)]
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnPat.hs
@@ -0,0 +1,901 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnPat]{Renaming of patterns}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnPat (-- main entry points
+              rnPat, rnPats, rnBindPat, rnPatAndThen,
+
+              NameMaker, applyNameMaker,     -- a utility for making names:
+              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
+                                             --   sometimes we want to make top (qualified) names.
+              isTopRecNameMaker,
+
+              rnHsRecFields, HsRecFieldContext(..),
+              rnHsRecUpdFields,
+
+              -- CpsRn monad
+              CpsRn, liftCps,
+
+              -- Literals
+              rnLit, rnOverLit,
+
+             -- Pattern Error messages that are also used elsewhere
+             checkTupSize, patSigErr
+             ) where
+
+-- ENH: thin imports to only what is necessary for patterns
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnExpr ( rnLExpr )
+import {-# SOURCE #-} RnSplice ( rnSplicePat )
+
+#include "HsVersions.h"
+
+import HsSyn
+import TcRnMonad
+import TcHsSyn             ( hsOverLitName )
+import RnEnv
+import RnFixity
+import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames
+                           , warnUnusedMatches, newLocalBndrRn
+                           , checkUnusedRecordWildcard
+                           , checkDupNames, checkDupAndShadowedNames
+                           , checkTupSize , unknownSubordinateErr )
+import RnTypes
+import PrelNames
+import Name
+import NameSet
+import RdrName
+import BasicTypes
+import Util
+import ListSetOps          ( removeDups )
+import Outputable
+import SrcLoc
+import Literal             ( inCharRange )
+import TysWiredIn          ( nilDataCon )
+import DataCon
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad       ( when, liftM, ap, guard )
+import qualified Data.List.NonEmpty as NE
+import Data.Ratio
+
+{-
+*********************************************************
+*                                                      *
+        The CpsRn Monad
+*                                                      *
+*********************************************************
+
+Note [CpsRn monad]
+~~~~~~~~~~~~~~~~~~
+The CpsRn monad uses continuation-passing style to support this
+style of programming:
+
+        do { ...
+           ; ns <- bindNames rs
+           ; ...blah... }
+
+   where rs::[RdrName], ns::[Name]
+
+The idea is that '...blah...'
+  a) sees the bindings of ns
+  b) returns the free variables it mentions
+     so that bindNames can report unused ones
+
+In particular,
+    mapM rnPatAndThen [p1, p2, p3]
+has a *left-to-right* scoping: it makes the binders in
+p1 scope over p2,p3.
+-}
+
+newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
+                                            -> RnM (r, FreeVars) }
+        -- See Note [CpsRn monad]
+
+instance Functor CpsRn where
+    fmap = liftM
+
+instance Applicative CpsRn where
+    pure x = CpsRn (\k -> k x)
+    (<*>) = ap
+
+instance Monad CpsRn where
+  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
+
+runCps :: CpsRn a -> RnM (a, FreeVars)
+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
+
+liftCps :: RnM a -> CpsRn a
+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
+
+liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
+                                     ; (r,fvs2) <- k v
+                                     ; return (r, fvs1 `plusFV` fvs2) })
+
+wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>
+                  (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b
+-- Set the location, and also wrap it around the value returned
+wrapSrcSpanCps fn (dL->L loc a)
+  = CpsRn (\k -> setSrcSpan loc $
+                 unCpsRn (fn a) $ \v ->
+                 k (cL loc v))
+
+lookupConCps :: Located RdrName -> CpsRn (Located Name)
+lookupConCps con_rdr
+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
+                    ; (r, fvs) <- k con_name
+                    ; return (r, addOneFV fvs (unLoc con_name)) })
+    -- We add the constructor name to the free vars
+    -- See Note [Patterns are uses]
+
+{-
+Note [Patterns are uses]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  module Foo( f, g ) where
+  data T = T1 | T2
+
+  f T1 = True
+  f T2 = False
+
+  g _ = T1
+
+Arguably we should report T2 as unused, even though it appears in a
+pattern, because it never occurs in a constructed position.  See
+#7336.
+However, implementing this in the face of pattern synonyms would be
+less straightforward, since given two pattern synonyms
+
+  pattern P1 <- P2
+  pattern P2 <- ()
+
+we need to observe the dependency between P1 and P2 so that type
+checking can be done in the correct order (just like for value
+bindings). Dependencies between bindings is analyzed in the renamer,
+where we don't know yet whether P2 is a constructor or a pattern
+synonym. So for now, we do report conid occurrences in patterns as
+uses.
+
+*********************************************************
+*                                                      *
+        Name makers
+*                                                      *
+*********************************************************
+
+Externally abstract type of name makers,
+which is how you go from a RdrName to a Name
+-}
+
+data NameMaker
+  = LamMk       -- Lambdas
+      Bool      -- True <=> report unused bindings
+                --   (even if True, the warning only comes out
+                --    if -Wunused-matches is on)
+
+  | LetMk       -- Let bindings, incl top level
+                -- Do *not* check for unused bindings
+      TopLevelFlag
+      MiniFixityEnv
+
+topRecNameMaker :: MiniFixityEnv -> NameMaker
+topRecNameMaker fix_env = LetMk TopLevel fix_env
+
+isTopRecNameMaker :: NameMaker -> Bool
+isTopRecNameMaker (LetMk TopLevel _) = True
+isTopRecNameMaker _ = False
+
+localRecNameMaker :: MiniFixityEnv -> NameMaker
+localRecNameMaker fix_env = LetMk NotTopLevel fix_env
+
+matchNameMaker :: HsMatchContext a -> NameMaker
+matchNameMaker ctxt = LamMk report_unused
+  where
+    -- Do not report unused names in interactive contexts
+    -- i.e. when you type 'x <- e' at the GHCi prompt
+    report_unused = case ctxt of
+                      StmtCtxt GhciStmtCtxt -> False
+                      -- also, don't warn in pattern quotes, as there
+                      -- is no RHS where the variables can be used!
+                      ThPatQuote            -> False
+                      _                     -> True
+
+rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
+
+newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
+newPatLName name_maker rdr_name@(dL->L loc _)
+  = do { name <- newPatName name_maker rdr_name
+       ; return (cL loc name) }
+
+newPatName :: NameMaker -> Located RdrName -> CpsRn Name
+newPatName (LamMk report_unused) rdr_name
+  = CpsRn (\ thing_inside ->
+        do { name <- newLocalBndrRn rdr_name
+           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
+           ; when report_unused $ warnUnusedMatches [name] fvs
+           ; return (res, name `delFV` fvs) })
+
+newPatName (LetMk is_top fix_env) rdr_name
+  = CpsRn (\ thing_inside ->
+        do { name <- case is_top of
+                       NotTopLevel -> newLocalBndrRn rdr_name
+                       TopLevel    -> newTopSrcBinder rdr_name
+           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here
+                                        -- See Note [View pattern usage]
+             addLocalFixities fix_env [name] $
+             thing_inside name })
+
+    -- Note: the bindLocalNames is somewhat suspicious
+    --       because it binds a top-level name as a local name.
+    --       however, this binding seems to work, and it only exists for
+    --       the duration of the patterns and the continuation;
+    --       then the top-level name is added to the global env
+    --       before going on to the RHSes (see RnSource.hs).
+
+{-
+Note [View pattern usage]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  let (r, (r -> x)) = x in ...
+Here the pattern binds 'r', and then uses it *only* in the view pattern.
+We want to "see" this use, and in let-bindings we collect all uses and
+report unused variables at the binding level. So we must use bindLocalNames
+here, *not* bindLocalNameFV.  #3943.
+
+
+Note [Don't report shadowing for pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is one special context where a pattern doesn't introduce any new binders -
+pattern synonym declarations. Therefore we don't check to see if pattern
+variables shadow existing identifiers as they are never bound to anything
+and have no scope.
+
+Without this check, there would be quite a cryptic warning that the `x`
+in the RHS of the pattern synonym declaration shadowed the top level `x`.
+
+```
+x :: ()
+x = ()
+
+pattern P x = Just x
+```
+
+See #12615 for some more examples.
+
+*********************************************************
+*                                                      *
+        External entry points
+*                                                      *
+*********************************************************
+
+There are various entry points to renaming patterns, depending on
+ (1) whether the names created should be top-level names or local names
+ (2) whether the scope of the names is entirely given in a continuation
+     (e.g., in a case or lambda, but not in a let or at the top-level,
+      because of the way mutually recursive bindings are handled)
+ (3) whether the a type signature in the pattern can bind
+        lexically-scoped type variables (for unpacking existential
+        type vars in data constructors)
+ (4) whether we do duplicate and unused variable checking
+ (5) whether there are fixity declarations associated with the names
+     bound by the patterns that need to be brought into scope with them.
+
+ Rather than burdening the clients of this module with all of these choices,
+ we export the three points in this design space that we actually need:
+-}
+
+-- ----------- Entry point 1: rnPats -------------------
+-- Binds local names; the scope of the bindings is entirely in the thing_inside
+--   * allows type sigs to bind type vars
+--   * local namemaker
+--   * unused and duplicate checking
+--   * no fixities
+rnPats :: HsMatchContext Name -- for error messages
+       -> [LPat GhcPs]
+       -> ([LPat GhcRn] -> RnM (a, FreeVars))
+       -> RnM (a, FreeVars)
+rnPats ctxt pats thing_inside
+  = do  { envs_before <- getRdrEnvs
+
+          -- (1) rename the patterns, bringing into scope all of the term variables
+          -- (2) then do the thing inside.
+        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
+        { -- Check for duplicated and shadowed names
+          -- Must do this *after* renaming the patterns
+          -- See Note [Collect binders only after renaming] in HsUtils
+          -- Because we don't bind the vars all at once, we can't
+          --    check incrementally for duplicates;
+          -- Nor can we check incrementally for shadowing, else we'll
+          --    complain *twice* about duplicates e.g. f (x,x) = ...
+          --
+          -- See note [Don't report shadowing for pattern synonyms]
+        ; let bndrs = collectPatsBinders pats'
+        ; addErrCtxt doc_pat $
+          if isPatSynCtxt ctxt
+             then checkDupNames bndrs
+             else checkDupAndShadowedNames envs_before bndrs
+        ; thing_inside pats' } }
+  where
+    doc_pat = text "In" <+> pprMatchContext ctxt
+
+rnPat :: HsMatchContext Name -- for error messages
+      -> LPat GhcPs
+      -> (LPat GhcRn -> RnM (a, FreeVars))
+      -> RnM (a, FreeVars)     -- Variables bound by pattern do not
+                               -- appear in the result FreeVars
+rnPat ctxt pat thing_inside
+  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
+
+applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
+                           ; return n }
+
+-- ----------- Entry point 2: rnBindPat -------------------
+-- Binds local names; in a recursive scope that involves other bound vars
+--      e.g let { (x, Just y) = e1; ... } in ...
+--   * does NOT allows type sig to bind type vars
+--   * local namemaker
+--   * no unused and duplicate checking
+--   * fixities might be coming in
+rnBindPat :: NameMaker
+          -> LPat GhcPs
+          -> RnM (LPat GhcRn, FreeVars)
+   -- Returned FreeVars are the free variables of the pattern,
+   -- of course excluding variables bound by this pattern
+
+rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
+
+{-
+*********************************************************
+*                                                      *
+        The main event
+*                                                      *
+*********************************************************
+-}
+
+-- ----------- Entry point 3: rnLPatAndThen -------------------
+-- General version: parametrized by how you make new names
+
+rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
+  -- Despite the map, the monad ensures that each pattern binds
+  -- variables that may be mentioned in subsequent patterns in the list
+
+--------------------
+-- The workhorse
+rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
+
+rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
+rnPatAndThen _  (WildPat _)   = return (WildPat noExt)
+rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (ParPat x pat') }
+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (LazyPat x pat') }
+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (BangPat x pat') }
+rnPatAndThen mk (VarPat x (dL->L l rdr))
+    = do { loc <- liftCps getSrcSpanM
+         ; name <- newPatName mk (cL loc rdr)
+         ; return (VarPat x (cL l name)) }
+     -- we need to bind pattern variables for view pattern expressions
+     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
+
+rnPatAndThen mk (SigPat x pat sig)
+  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
+  -- important to rename its type signature _before_ renaming the rest of the
+  -- pattern, so that type variables are first bound by the _outermost_ pattern
+  -- type signature they occur in. This keeps the type checker happy when
+  -- pattern type signatures happen to be nested (#7827)
+  --
+  -- f ((Just (x :: a) :: Maybe a)
+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here
+  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
+  = do { sig' <- rnHsSigCps sig
+       ; pat' <- rnLPatAndThen mk pat
+       ; return (SigPat x pat' sig' ) }
+
+rnPatAndThen mk (LitPat x lit)
+  | HsString src s <- lit
+  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
+       ; if ovlStr
+         then rnPatAndThen mk
+                           (mkNPat (noLoc (mkHsIsString src s))
+                                      Nothing)
+         else normal_lit }
+  | otherwise = normal_lit
+  where
+    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
+
+rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)
+  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
+       ; mb_neg' -- See Note [Negative zero]
+           <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
+                                ; return (Just neg, fvs) }
+                  positive = return (Nothing, emptyFVs)
+              in liftCpsFV $ case (mb_neg , mb_neg') of
+                                  (Nothing, Just _ ) -> negative
+                                  (Just _ , Nothing) -> negative
+                                  (Nothing, Nothing) -> positive
+                                  (Just _ , Just _ ) -> positive
+       ; eq' <- liftCpsFV $ lookupSyntaxName eqName
+       ; return (NPat x (cL l lit') mb_neg' eq') }
+
+rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )
+  = do { new_name <- newPatName mk rdr
+       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
+                                                -- We skip negateName as
+                                                -- negative zero doesn't make
+                                                -- sense in n + k patterns
+       ; minus <- liftCpsFV $ lookupSyntaxName minusName
+       ; ge    <- liftCpsFV $ lookupSyntaxName geName
+       ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)
+                             (cL l lit') lit' ge minus) }
+                -- The Report says that n+k patterns must be in Integral
+
+rnPatAndThen mk (AsPat x rdr pat)
+  = do { new_name <- newPatLName mk rdr
+       ; pat' <- rnLPatAndThen mk pat
+       ; return (AsPat x new_name pat') }
+
+rnPatAndThen mk p@(ViewPat x expr pat)
+  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
+                      ; checkErr vp_flag (badViewPat p) }
+         -- Because of the way we're arranging the recursive calls,
+         -- this will be in the right context
+       ; expr' <- liftCpsFV $ rnLExpr expr
+       ; pat' <- rnLPatAndThen mk pat
+       -- Note: at this point the PreTcType in ty can only be a placeHolder
+       -- ; return (ViewPat expr' pat' ty) }
+       ; return (ViewPat x expr' pat') }
+
+rnPatAndThen mk (ConPatIn con stuff)
+   -- rnConPatAndThen takes care of reconstructing the pattern
+   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
+  = case unLoc con == nameRdrName (dataConName nilDataCon) of
+      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
+                    ; if ol_flag then rnPatAndThen mk (ListPat noExt [])
+                                 else rnConPatAndThen mk con stuff}
+      False   -> rnConPatAndThen mk con stuff
+
+rnPatAndThen mk (ListPat _ pats)
+  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
+       ; pats' <- rnLPatsAndThen mk pats
+       ; case opt_OverloadedLists of
+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
+                     ; return (ListPat (Just to_list_name) pats')}
+          False -> return (ListPat Nothing pats') }
+
+rnPatAndThen mk (TuplePat x pats boxed)
+  = do { liftCps $ checkTupSize (length pats)
+       ; pats' <- rnLPatsAndThen mk pats
+       ; return (TuplePat x pats' boxed) }
+
+rnPatAndThen mk (SumPat x pat alt arity)
+  = do { pat <- rnLPatAndThen mk pat
+       ; return (SumPat x pat alt arity)
+       }
+
+-- If a splice has been run already, just rename the result.
+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
+  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
+
+rnPatAndThen mk (SplicePat _ splice)
+  = do { eith <- liftCpsFV $ rnSplicePat splice
+       ; case eith of   -- See Note [rnSplicePat] in RnSplice
+           Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed
+           Right already_renamed -> return already_renamed }
+
+rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
+
+
+--------------------
+rnConPatAndThen :: NameMaker
+                -> Located RdrName    -- the constructor
+                -> HsConPatDetails GhcPs
+                -> CpsRn (Pat GhcRn)
+
+rnConPatAndThen mk con (PrefixCon pats)
+  = do  { con' <- lookupConCps con
+        ; pats' <- rnLPatsAndThen mk pats
+        ; return (ConPatIn con' (PrefixCon pats')) }
+
+rnConPatAndThen mk con (InfixCon pat1 pat2)
+  = do  { con' <- lookupConCps con
+        ; pat1' <- rnLPatAndThen mk pat1
+        ; pat2' <- rnLPatAndThen mk pat2
+        ; fixity <- liftCps $ lookupFixityRn (unLoc con')
+        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
+
+rnConPatAndThen mk con (RecCon rpats)
+  = do  { con' <- lookupConCps con
+        ; rpats' <- rnHsRecPatsAndThen mk con' rpats
+        ; return (ConPatIn con' (RecCon rpats')) }
+
+checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
+checkUnusedRecordWildcardCps loc dotdot_names =
+  CpsRn (\thing -> do
+                    (r, fvs) <- thing ()
+                    checkUnusedRecordWildcard loc fvs dotdot_names
+                    return (r, fvs) )
+--------------------
+rnHsRecPatsAndThen :: NameMaker
+                   -> Located Name      -- Constructor
+                   -> HsRecFields GhcPs (LPat GhcPs)
+                   -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
+rnHsRecPatsAndThen mk (dL->L _ con)
+     hs_rec_fields@(HsRecFields { rec_dotdot = dd })
+  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
+                                            hs_rec_fields
+       ; flds' <- mapM rn_field (flds `zip` [1..])
+       ; check_unused_wildcard (implicit_binders flds' <$> dd)
+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
+  where
+    mkVarPat l n = VarPat noExt (cL l n)
+    rn_field (dL->L l fld, n') =
+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
+         ; return (cL l (fld { hsRecFieldArg = arg' })) }
+
+    loc = maybe noSrcSpan getLoc dd
+
+    -- Get the arguments of the implicit binders
+    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats
+      where
+        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)
+
+    -- Don't warn for let P{..} = ... in ...
+    check_unused_wildcard = case mk of
+                              LetMk{} -> const (return ())
+                              LamMk{} -> checkUnusedRecordWildcardCps loc
+
+        -- Suppress unused-match reporting for fields introduced by ".."
+    nested_mk Nothing  mk                    _  = mk
+    nested_mk (Just _) mk@(LetMk {})         _  = mk
+    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
+      = LamMk (report_unused && (n' <= n))
+
+{-
+************************************************************************
+*                                                                      *
+        Record fields
+*                                                                      *
+************************************************************************
+-}
+
+data HsRecFieldContext
+  = HsRecFieldCon Name
+  | HsRecFieldPat Name
+  | HsRecFieldUpd
+
+rnHsRecFields
+    :: forall arg. HasSrcSpan arg =>
+       HsRecFieldContext
+    -> (SrcSpan -> RdrName -> SrcSpanLess arg)
+         -- When punning, use this to build a new field
+    -> HsRecFields GhcPs arg
+    -> RnM ([LHsRecField GhcRn arg], FreeVars)
+
+-- This surprisingly complicated pass
+--   a) looks up the field name (possibly using disambiguation)
+--   b) fills in puns and dot-dot stuff
+-- When we've finished, we've renamed the LHS, but not the RHS,
+-- of each x=e binding
+--
+-- This is used for record construction and pattern-matching, but not updates.
+
+rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
+  = do { pun_ok      <- xoptM LangExt.RecordPuns
+       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
+       ; let parent = guard disambig_ok >> mb_con
+       ; flds1  <- mapM (rn_fld pun_ok parent) flds
+       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
+       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
+       ; let all_flds | null dotdot_flds = flds1
+                      | otherwise        = flds1 ++ dotdot_flds
+       ; return (all_flds, mkFVs (getFieldIds all_flds)) }
+  where
+    mb_con = case ctxt of
+                HsRecFieldCon con  -> Just con
+                HsRecFieldPat con  -> Just con
+                _ {- update -}     -> Nothing
+
+    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg
+           -> RnM (LHsRecField GhcRn arg)
+    rn_fld pun_ok parent (dL->L l
+                           (HsRecField
+                              { hsRecFieldLbl =
+                                  (dL->L loc (FieldOcc _ (dL->L ll lbl)))
+                              , hsRecFieldArg = arg
+                              , hsRecPun      = pun }))
+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
+           ; arg' <- if pun
+                     then do { checkErr pun_ok (badPun (cL loc lbl))
+                               -- Discard any module qualifier (#11662)
+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
+                             ; return (cL loc (mk_arg loc arg_rdr)) }
+                     else return arg
+           ; return (cL l (HsRecField
+                             { hsRecFieldLbl = (cL loc (FieldOcc
+                                                          sel (cL ll lbl)))
+                             , hsRecFieldArg = arg'
+                             , hsRecPun      = pun })) }
+    rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))
+      = panic "rnHsRecFields"
+    rn_fld _ _ _ = panic "rn_fld: Impossible Match"
+                                -- due to #15884
+
+
+    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in HsPat
+              -> Maybe Name -- The constructor (Nothing for an
+                                --    out of scope constructor)
+              -> [LHsRecField GhcRn arg] -- Explicit fields
+              -> RnM ([LHsRecField GhcRn arg])   -- Field Labels we need to fill in
+    rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match
+      | not (isUnboundName con) -- This test is because if the constructor
+                                -- isn't in scope the constructor lookup will add
+                                -- an error but still return an unbound name. We
+                                -- don't want that to screw up the dot-dot fill-in stuff.
+      = ASSERT( flds `lengthIs` n )
+        do { dd_flag <- xoptM LangExt.RecordWildCards
+           ; checkErr dd_flag (needFlagDotDot ctxt)
+           ; (rdr_env, lcl_env) <- getRdrEnvs
+           ; con_fields <- lookupConstructorFields con
+           ; when (null con_fields) (addErr (badDotDotCon con))
+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
+
+                   -- For constructor uses (but not patterns)
+                   -- the arg should be in scope locally;
+                   -- i.e. not top level or imported
+                   -- Eg.  data R = R { x,y :: Int }
+                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
+                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
+
+                 (dot_dot_fields, dot_dot_gres)
+                        = unzip [ (fl, gre)
+                                | fl <- con_fields
+                                , let lbl = mkVarOccFS (flLabel fl)
+                                , not (lbl `elemOccSet` present_flds)
+                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
+                                              -- Check selector is in scope
+                                , case ctxt of
+                                    HsRecFieldCon {} -> arg_in_scope lbl
+                                    _other           -> True ]
+
+           ; addUsedGREs dot_dot_gres
+           ; return [ cL loc (HsRecField
+                        { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
+                        , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
+                        , hsRecPun      = False })
+                    | fl <- dot_dot_fields
+                    , let sel     = flSelector fl
+                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }
+
+    rn_dotdot _dotdot _mb_con _flds
+      = return []
+      -- _dotdot = Nothing => No ".." at all
+      -- _mb_con = Nothing => Record update
+      -- _mb_con = Just unbound => Out of scope data constructor
+
+    dup_flds :: [NE.NonEmpty RdrName]
+        -- Each list represents a RdrName that occurred more than once
+        -- (the list contains all occurrences)
+        -- Each list in dup_fields is non-empty
+    (_, dup_flds) = removeDups compare (getFieldLbls flds)
+
+
+-- NB: Consider this:
+--      module Foo where { data R = R { fld :: Int } }
+--      module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
+
+rnHsRecUpdFields
+    :: [LHsRecUpdField GhcPs]
+    -> RnM ([LHsRecUpdField GhcRn], FreeVars)
+rnHsRecUpdFields flds
+  = do { pun_ok        <- xoptM LangExt.RecordPuns
+       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields
+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
+       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
+
+       -- Check for an empty record update  e {}
+       -- NB: don't complain about e { .. }, because rn_dotdot has done that already
+       ; when (null flds) $ addErr emptyUpdateErr
+
+       ; return (flds1, plusFVs fvss) }
+  where
+    doc = text "constructor field name"
+
+    rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs
+           -> RnM (LHsRecUpdField GhcRn, FreeVars)
+    rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f
+                                                   , hsRecFieldArg = arg
+                                                   , hsRecPun      = pun }))
+      = do { let lbl = rdrNameAmbiguousFieldOcc f
+           ; sel <- setSrcSpan loc $
+                      -- Defer renaming of overloaded fields to the typechecker
+                      -- See Note [Disambiguating record fields] in TcExpr
+                      if overload_ok
+                          then do { mb <- lookupGlobalOccRn_overloaded
+                                            overload_ok lbl
+                                  ; case mb of
+                                      Nothing ->
+                                        do { addErr
+                                               (unknownSubordinateErr doc lbl)
+                                           ; return (Right []) }
+                                      Just r  -> return r }
+                          else fmap Left $ lookupGlobalOccRn lbl
+           ; arg' <- if pun
+                     then do { checkErr pun_ok (badPun (cL loc lbl))
+                               -- Discard any module qualifier (#11662)
+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
+                             ; return (cL loc (HsVar noExt (cL loc arg_rdr))) }
+                     else return arg
+           ; (arg'', fvs) <- rnLExpr arg'
+
+           ; let fvs' = case sel of
+                          Left sel_name -> fvs `addOneFV` sel_name
+                          Right [sel_name] -> fvs `addOneFV` sel_name
+                          Right _       -> fvs
+                 lbl' = case sel of
+                          Left sel_name ->
+                                     cL loc (Unambiguous sel_name  (cL loc lbl))
+                          Right [sel_name] ->
+                                     cL loc (Unambiguous sel_name  (cL loc lbl))
+                          Right _ -> cL loc (Ambiguous   noExt     (cL loc lbl))
+
+           ; return (cL l (HsRecField { hsRecFieldLbl = lbl'
+                                      , hsRecFieldArg = arg''
+                                      , hsRecPun      = pun }), fvs') }
+
+    dup_flds :: [NE.NonEmpty RdrName]
+        -- Each list represents a RdrName that occurred more than once
+        -- (the list contains all occurrences)
+        -- Each list in dup_fields is non-empty
+    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
+
+
+
+getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
+
+getFieldLbls :: [LHsRecField id arg] -> [RdrName]
+getFieldLbls flds
+  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+
+getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+
+needFlagDotDot :: HsRecFieldContext -> SDoc
+needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
+                            text "Use RecordWildCards to permit this"]
+
+badDotDotCon :: Name -> SDoc
+badDotDotCon con
+  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
+         , nest 2 (text "The constructor has no labelled fields") ]
+
+emptyUpdateErr :: SDoc
+emptyUpdateErr = text "Empty record update"
+
+badPun :: Located RdrName -> SDoc
+badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
+                   text "Use NamedFieldPuns to permit this"]
+
+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
+dupFieldErr ctxt dups
+  = hsep [text "duplicate field name",
+          quotes (ppr (NE.head dups)),
+          text "in record", pprRFC ctxt]
+
+pprRFC :: HsRecFieldContext -> SDoc
+pprRFC (HsRecFieldCon {}) = text "construction"
+pprRFC (HsRecFieldPat {}) = text "pattern"
+pprRFC (HsRecFieldUpd {}) = text "update"
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Literals}
+*                                                                      *
+************************************************************************
+
+When literals occur we have to make sure
+that the types and classes they involve
+are made available.
+-}
+
+rnLit :: HsLit p -> RnM ()
+rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit _ = return ()
+
+-- Turn a Fractional-looking literal which happens to be an integer into an
+-- Integer-looking literal.
+generalizeOverLitVal :: OverLitVal -> OverLitVal
+generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
+    | denominator val == 1 = HsIntegral (IL { il_text=src
+                                            , il_neg=neg
+                                            , il_value=numerator val})
+generalizeOverLitVal lit = lit
+
+isNegativeZeroOverLit :: HsOverLit t -> Bool
+isNegativeZeroOverLit lit
+ = case ol_val lit of
+        HsIntegral i   -> 0 == il_value i && il_neg i
+        HsFractional f -> 0 == fl_value f && fl_neg f
+        _              -> False
+
+{-
+Note [Negative zero]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There were problems with negative zero in conjunction with Negative Literals
+extension. Numeric literal value is contained in Integer and Rational types
+inside IntegralLit and FractionalLit. These types cannot represent negative
+zero value. So we had to add explicit field 'neg' which would hold information
+about literal sign. Here in rnOverLit we use it to detect negative zeroes and
+in this case return not only literal itself but also negateName so that users
+can apply it explicitly. In this case it stays negative zero.  #13211
+-}
+
+rnOverLit :: HsOverLit t ->
+             RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
+rnOverLit origLit
+  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals
+        ; let { lit@(OverLit {ol_val=val})
+            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
+            | otherwise       = origLit
+          }
+        ; let std_name = hsOverLitName val
+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
+            <- lookupSyntaxName std_name
+        ; let rebindable = case from_thing_name of
+                                HsVar _ lv -> (unLoc lv) /= std_name
+                                _          -> panic "rnOverLit"
+        ; let lit' = lit { ol_witness = from_thing_name
+                         , ol_ext = rebindable }
+        ; if isNegativeZeroOverLit lit'
+          then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
+                      <- lookupSyntaxName negateName
+                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
+                                  , fvs1 `plusFV` fvs2) }
+          else return ((lit', Nothing), fvs1) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+patSigErr :: Outputable a => a -> SDoc
+patSigErr ty
+  =  (text "Illegal signature in pattern:" <+> ppr ty)
+        $$ nest 4 (text "Use ScopedTypeVariables to permit it")
+
+bogusCharError :: Char -> SDoc
+bogusCharError c
+  = text "character literal out of range: '\\" <> char c  <> char '\''
+
+badViewPat :: Pat GhcPs -> SDoc
+badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
+                       text "Use ViewPatterns to enable view patterns"]
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnSource.hs
@@ -0,0 +1,2374 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnSource]{Main pass of renamer}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnSource (
+        rnSrcDecls, addTcgDUs, findSplice
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnExpr( rnLExpr )
+import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
+
+import HsSyn
+import FieldLabel
+import RdrName
+import RnTypes
+import RnBinds
+import RnEnv
+import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames
+                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
+                        , checkShadowedRdrNames, warnUnusedTypePatterns
+                        , extendTyVarEnvFVRn, newLocalBndrsRn
+                        , withHsDocContext )
+import RnUnbound        ( mkUnboundName, notInScopeErr )
+import RnNames
+import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
+import TcAnnotations    ( annCtxt )
+import TcRnMonad
+
+import ForeignCall      ( CCallTarget(..) )
+import Module
+import HscTypes         ( Warnings(..), plusWarns )
+import PrelNames        ( applicativeClassName, pureAName, thenAName
+                        , monadClassName, returnMName, thenMName
+                        , semigroupClassName, sappendName
+                        , monoidClassName, mappendName
+                        )
+import Name
+import NameSet
+import NameEnv
+import Avail
+import Outputable
+import Bag
+import BasicTypes       ( pprRuleName )
+import FastString
+import SrcLoc
+import DynFlags
+import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )
+import HscTypes         ( HscEnv, hsc_dflags )
+import ListSetOps       ( findDupsEq, removeDups, equivClasses )
+import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)
+                        , stronglyConnCompFromEdgedVerticesUniq )
+import UniqSet
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Control.Arrow ( first )
+import Data.List ( mapAccumL )
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Maybe ( isNothing, fromMaybe )
+import qualified Data.Set as Set ( difference, fromList, toList, null )
+
+{- | @rnSourceDecl@ "renames" declarations.
+It simultaneously performs dependency analysis and precedence parsing.
+It also does the following error checks:
+
+* Checks that tyvars are used properly. This includes checking
+  for undefined tyvars, and tyvars in contexts that are ambiguous.
+  (Some of this checking has now been moved to module @TcMonoType@,
+  since we don't have functional dependency information at this point.)
+
+* Checks that all variable occurrences are defined.
+
+* Checks the @(..)@ etc constraints in the export list.
+
+Brings the binders of the group into scope in the appropriate places;
+does NOT assume that anything is in scope already
+-}
+rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
+-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
+rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
+                            hs_splcds  = splice_decls,
+                            hs_tyclds  = tycl_decls,
+                            hs_derivds = deriv_decls,
+                            hs_fixds   = fix_decls,
+                            hs_warnds  = warn_decls,
+                            hs_annds   = ann_decls,
+                            hs_fords   = foreign_decls,
+                            hs_defds   = default_decls,
+                            hs_ruleds  = rule_decls,
+                            hs_docs    = docs })
+ = do {
+   -- (A) Process the fixity declarations, creating a mapping from
+   --     FastStrings to FixItems.
+   --     Also checks for duplicates.
+   local_fix_env <- makeMiniFixityEnv fix_decls ;
+
+   -- (B) Bring top level binders (and their fixities) into scope,
+   --     *except* for the value bindings, which get done in step (D)
+   --     with collectHsIdBinders. However *do* include
+   --
+   --        * Class ops, data constructors, and record fields,
+   --          because they do not have value declarations.
+   --
+   --        * For hs-boot files, include the value signatures
+   --          Again, they have no value declarations
+   --
+   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
+
+
+   setEnvs tc_envs $ do {
+
+   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+
+   -- (D1) Bring pattern synonyms into scope.
+   --      Need to do this before (D2) because rnTopBindsLHS
+   --      looks up those pattern synonyms (#9889)
+
+   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
+
+   -- (D2) Rename the left-hand sides of the value bindings.
+   --     This depends on everything from (B) being in scope.
+   --     It uses the fixity env from (A) to bind fixities for view patterns.
+   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
+
+   -- Bind the LHSes (and their fixities) in the global rdr environment
+   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
+                                                    -- They are already in scope
+   traceRn "rnSrcDecls" (ppr id_bndrs) ;
+   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
+   setEnvs tc_envs $ do {
+
+   --  Now everything is in scope, as the remaining renaming assumes.
+
+   -- (E) Rename type and class decls
+   --     (note that value LHSes need to be in scope for default methods)
+   --
+   -- You might think that we could build proper def/use information
+   -- for type and class declarations, but they can be involved
+   -- in mutual recursion across modules, and we only do the SCC
+   -- analysis for them in the type checker.
+   -- So we content ourselves with gathering uses only; that
+   -- means we'll only report a declaration as unused if it isn't
+   -- mentioned at all.  Ah well.
+   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
+
+   -- (F) Rename Value declarations right-hand sides
+   traceRn "Start rnmono" empty ;
+   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
+   is_boot <- tcIsHsBootOrSig ;
+   (rn_val_decls, bind_dus) <- if is_boot
+    -- For an hs-boot, use tc_bndrs (which collects how we're renamed
+    -- signatures), since val_bndr_set is empty (there are no x = ...
+    -- bindings in an hs-boot.)
+    then rnTopBindsBoot tc_bndrs new_lhs
+    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
+   traceRn "finish rnmono" (ppr rn_val_decls) ;
+
+   -- (G) Rename Fixity and deprecations
+
+   -- Rename fixity declarations and error if we try to
+   -- fix something from another module (duplicates were checked in (A))
+   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
+   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
+                        fix_decls ;
+
+   -- Rename deprec decls;
+   -- check for duplicates and ensure that deprecated things are defined locally
+   -- at the moment, we don't keep these around past renaming
+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
+
+   -- (H) Rename Everything else
+
+   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
+                                   rnList rnHsRuleDecls rule_decls ;
+                           -- Inside RULES, scoped type variables are on
+   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
+   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;
+   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
+   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
+   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;
+      -- Haddock docs; no free vars
+   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
+
+   last_tcg_env <- getGblEnv ;
+   -- (I) Compute the results and return
+   let {rn_group = HsGroup { hs_ext     = noExt,
+                             hs_valds   = rn_val_decls,
+                             hs_splcds  = rn_splice_decls,
+                             hs_tyclds  = rn_tycl_decls,
+                             hs_derivds = rn_deriv_decls,
+                             hs_fixds   = rn_fix_decls,
+                             hs_warnds  = [], -- warns are returned in the tcg_env
+                                             -- (see below) not in the HsGroup
+                             hs_fords  = rn_foreign_decls,
+                             hs_annds  = rn_ann_decls,
+                             hs_defds  = rn_default_decls,
+                             hs_ruleds = rn_rule_decls,
+                             hs_docs   = rn_docs } ;
+
+        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
+        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+                              src_fvs5, src_fvs6, src_fvs7] ;
+                -- It is tiresome to gather the binders from type and class decls
+
+        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
+                -- Instance decls may have occurrences of things bound in bind_dus
+                -- so we must put other_fvs last
+
+        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
+                        in -- we return the deprecs in the env, not in the HsGroup above
+                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
+       } ;
+   traceRn "finish rnSrc" (ppr rn_group) ;
+   traceRn "finish Dus" (ppr src_dus ) ;
+   return (final_tcg_env, rn_group)
+                    }}}}
+rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"
+
+addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
+-- This function could be defined lower down in the module hierarchy,
+-- but there doesn't seem anywhere very logical to put it.
+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
+
+rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
+rnList f xs = mapFvRn (wrapLocFstM f) xs
+
+{-
+*********************************************************
+*                                                       *
+        HsDoc stuff
+*                                                       *
+*********************************************************
+-}
+
+rnDocDecl :: DocDecl -> RnM DocDecl
+rnDocDecl (DocCommentNext doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocGroup lev rn_doc)
+
+{-
+*********************************************************
+*                                                       *
+        Source-code deprecations declarations
+*                                                       *
+*********************************************************
+
+Check that the deprecated names are defined, are defined locally, and
+that there are no duplicate deprecations.
+
+It's only imported deprecations, dealt with in RnIfaces, that we
+gather them together.
+-}
+
+-- checks that the deprecations are defined locally, and that there are no duplicates
+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
+rnSrcWarnDecls _ []
+  = return NoWarnings
+
+rnSrcWarnDecls bndr_set decls'
+  = do { -- check for duplicates
+       ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups
+                          in addErrAt loc (dupWarnDecl lrdr' rdr))
+               warn_rdr_dups
+       ; pairs_s <- mapM (addLocM rn_deprec) decls
+       ; return (WarnSome ((concat pairs_s))) }
+ where
+   decls = concatMap (wd_warnings . unLoc) decls'
+
+   sig_ctxt = TopSigCtxt bndr_set
+
+   rn_deprec (Warning _ rdr_names txt)
+       -- ensures that the names are defined locally
+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
+                                rdr_names
+          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
+   rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"
+
+   what = text "deprecation"
+
+   warn_rdr_dups = findDupRdrNames
+                   $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls
+
+findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
+findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+
+-- look for duplicates among the OccNames;
+-- we check that the names are defined above
+-- invt: the lists returned by findDupsEq always have at least two elements
+
+dupWarnDecl :: Located RdrName -> RdrName -> SDoc
+-- Located RdrName -> DeprecDecl RdrName -> SDoc
+dupWarnDecl d rdr_name
+  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
+          text "also at " <+> ppr (getLoc d)]
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Annotation declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
+rnAnnDecl ann@(HsAnnotation _ s provenance expr)
+  = addErrCtxt (annCtxt ann) $
+    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
+       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
+                              rnLExpr expr
+       ; return (HsAnnotation noExt s provenance' expr',
+                 provenance_fvs `plusFV` expr_fvs) }
+rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"
+
+rnAnnProvenance :: AnnProvenance RdrName
+                -> RnM (AnnProvenance Name, FreeVars)
+rnAnnProvenance provenance = do
+    provenance' <- traverse lookupTopBndrRn provenance
+    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Default declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
+rnDefaultDecl (DefaultDecl _ tys)
+  = do { (tys', fvs) <- rnLHsTypes doc_str tys
+       ; return (DefaultDecl noExt tys', fvs) }
+  where
+    doc_str = DefaultDeclCtx
+rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Foreign declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
+  = do { topEnv :: HscEnv <- getTopEnv
+       ; name' <- lookupLocatedTopBndrRn name
+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+
+        -- Mark any PackageTarget style imports as coming from the current package
+       ; let unitId = thisPackage $ hsc_dflags topEnv
+             spec'      = patchForeignImport unitId spec
+
+       ; return (ForeignImport { fd_i_ext = noExt
+                               , fd_name = name', fd_sig_ty = ty'
+                               , fd_fi = spec' }, fvs) }
+
+rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
+  = do { name' <- lookupLocatedOccRn name
+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+       ; return (ForeignExport { fd_e_ext = noExt
+                               , fd_name = name', fd_sig_ty = ty'
+                               , fd_fe = spec }
+                , fvs `addOneFV` unLoc name') }
+        -- NB: a foreign export is an *occurrence site* for name, so
+        --     we add it to the free-variable list.  It might, for example,
+        --     be imported from another module
+
+rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"
+
+-- | For Windows DLLs we need to know what packages imported symbols are from
+--      to generate correct calls. Imported symbols are tagged with the current
+--      package, so if they get inlined across a package boundary we'll still
+--      know where they're from.
+--
+patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
+patchForeignImport unitId (CImport cconv safety fs spec src)
+        = CImport cconv safety fs (patchCImportSpec unitId spec) src
+
+patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
+patchCImportSpec unitId spec
+ = case spec of
+        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget
+        _                       -> spec
+
+patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
+patchCCallTarget unitId callTarget =
+  case callTarget of
+  StaticTarget src label Nothing isFun
+                              -> StaticTarget src label (Just unitId) isFun
+  _                           -> callTarget
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Instance declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
+  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi
+       ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
+
+rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
+  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi
+       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
+
+rnSrcInstDecl (ClsInstD { cid_inst = cid })
+  = do { traceRn "rnSrcIstDecl {" (ppr cid)
+       ; (cid', fvs) <- rnClsInstDecl cid
+       ; traceRn "rnSrcIstDecl end }" empty
+       ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }
+
+rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
+
+-- | Warn about non-canonical typeclass instance declarations
+--
+-- A "non-canonical" instance definition can occur for instances of a
+-- class which redundantly defines an operation its superclass
+-- provides as well (c.f. `return`/`pure`). In such cases, a canonical
+-- instance is one where the subclass inherits its method
+-- implementation from its superclass instance (usually the subclass
+-- has a default method implementation to that effect). Consequently,
+-- a non-canonical instance occurs when this is not the case.
+--
+-- See also descriptions of 'checkCanonicalMonadInstances' and
+-- 'checkCanonicalMonoidInstances'
+checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
+checkCanonicalInstances cls poly_ty mbinds = do
+    whenWOptM Opt_WarnNonCanonicalMonadInstances
+        checkCanonicalMonadInstances
+
+    whenWOptM Opt_WarnNonCanonicalMonoidInstances
+        checkCanonicalMonoidInstances
+
+  where
+    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
+    -- declarations. Specifically, the following conditions are verified:
+    --
+    -- In 'Monad' instances declarations:
+    --
+    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)
+    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
+    --
+    -- In 'Applicative' instance declarations:
+    --
+    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
+    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
+    --
+    checkCanonicalMonadInstances
+      | cls == applicativeClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == pureAName, isAliasMG mg == Just returnMName
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
+
+                      | name == thenAName, isAliasMG mg == Just thenMName
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
+
+                  _ -> return ()
+
+      | cls == monadClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == returnMName, isAliasMG mg /= Just pureAName
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
+
+                      | name == thenMName, isAliasMG mg /= Just thenAName
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
+    -- | Check whether Monoid(mappend) is defined in terms of
+    -- Semigroup((<>)) (and not the other way round). Specifically,
+    -- the following conditions are verified:
+    --
+    -- In 'Monoid' instances declarations:
+    --
+    --  * If 'mappend' is overridden it must be canonical
+    --    (i.e. @mappend = (<>)@)
+    --
+    -- In 'Semigroup' instance declarations:
+    --
+    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
+    --
+    checkCanonicalMonoidInstances
+      | cls == semigroupClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id      = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == sappendName, isAliasMG mg == Just mappendName
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
+
+                  _ -> return ()
+
+      | cls == monoidClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == mappendName, isAliasMG mg /= Just sappendName
+                      -> addWarnNonCanonicalMethod2NoDefault
+                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
+    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
+    -- binding, and return @Just rhsName@ if this is the case
+    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
+    isAliasMG MG {mg_alts = (dL->L _
+                             [dL->L _ (Match { m_pats = []
+                                             , m_grhss = grhss })])}
+        | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss
+        , EmptyLocalBinds _ <- unLoc lbinds
+        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)
+    isAliasMG _ = Nothing
+
+    -- got "lhs = rhs" but expected something different
+    addWarnNonCanonicalMethod1 flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
+                         quotes (text (lhs ++ " = " ++ rhs)) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Move definition from" <+>
+                         quotes (text rhs) <+>
+                         text "to" <+> quotes (text lhs)
+                       ]
+
+    -- expected "lhs = rhs" but got something else
+    addWarnNonCanonicalMethod2 flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
+                         quotes (text lhs) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Either remove definition for" <+>
+                         quotes (text lhs) <+> text "or define as" <+>
+                         quotes (text (lhs ++ " = " ++ rhs))
+                       ]
+
+    -- like above, but method has no default impl
+    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
+                         quotes (text lhs) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Define as" <+>
+                         quotes (text (lhs ++ " = " ++ rhs))
+                       ]
+
+    -- stolen from TcInstDcls
+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+    instDeclCtxt1 hs_inst_ty
+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+    inst_decl_ctxt :: SDoc -> SDoc
+    inst_decl_ctxt doc = hang (text "in the instance declaration for")
+                         2 (quotes doc <> text ".")
+
+
+rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
+                           , cid_sigs = uprags, cid_tyfam_insts = ats
+                           , cid_overlap_mode = oflag
+                           , cid_datafam_insts = adts })
+  = do { (inst_ty', inst_fvs)
+           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty
+       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+       ; cls <-
+           case hsTyGetAppHead_maybe head_ty' of
+             Just (dL->L _ cls) -> pure cls
+             Nothing -> do
+               -- The instance is malformed. We'd still like
+               -- to make *some* progress (rather than failing outright), so
+               -- we report an error and continue for as long as we can.
+               -- Importantly, this error should be thrown before we reach the
+               -- typechecker, lest we encounter different errors that are
+               -- hopelessly confusing (such as the one in #16114).
+               addErrAt (getLoc (hsSigType inst_ty)) $
+                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))
+                    2 (vcat [ text "Class instances must be of the form"
+                            , nest 2 $ text "context => C ty_1 ... ty_n"
+                            , text "where" <+> quotes (char 'C')
+                              <+> text "is a class"
+                            ])
+               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
+
+          -- Rename the bindings
+          -- The typechecker (not the renamer) checks that all
+          -- the bindings are for the right class
+          -- (Slightly strangely) when scoped type variables are on, the
+          -- forall-d tyvars scope over the method bindings too
+       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
+
+       ; checkCanonicalInstances cls inst_ty' mbinds'
+
+       -- Rename the associated types, and type signatures
+       -- Both need to have the instance type variables in scope
+       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
+       ; ((ats', adts'), more_fvs)
+             <- extendTyVarEnvFVRn ktv_names $
+                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
+                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
+
+       ; let all_fvs = meth_fvs `plusFV` more_fvs
+                                `plusFV` inst_fvs
+       ; return (ClsInstDecl { cid_ext = noExt
+                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
+                             , cid_sigs = uprags', cid_tyfam_insts = ats'
+                             , cid_overlap_mode = oflag
+                             , cid_datafam_insts = adts' },
+                 all_fvs) }
+             -- We return the renamed associated data type declarations so
+             -- that they can be entered into the list of type declarations
+             -- for the binding group, but we also keep a copy in the instance.
+             -- The latter is needed for well-formedness checks in the type
+             -- checker (eg, to ensure that all ATs of the instance actually
+             -- receive a declaration).
+             -- NB: Even the copies in the instance declaration carry copies of
+             --     the instance context after renaming.  This is a bit
+             --     strange, but should not matter (and it would be more work
+             --     to remove the context).
+rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
+
+rnFamInstEqn :: HsDocContext
+             -> AssocTyFamInfo
+             -> [Located RdrName]    -- Kind variables from the equation's RHS
+             -> FamInstEqn GhcPs rhs
+             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
+rnFamInstEqn doc atfi rhs_kvars
+    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                               , feqn_bndrs  = mb_bndrs
+                               , feqn_pats   = pats
+                               , feqn_fixity = fixity
+                               , feqn_rhs    = payload }}) rn_payload
+  = do { let mb_cls = case atfi of
+                        NonAssocTyFamEqn     -> Nothing
+                        AssocTyFamDeflt cls  -> Just cls
+                        AssocTyFamInst cls _ -> Just cls
+       ; tycon'   <- lookupFamInstName mb_cls tycon
+       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
+             -- Use the "...Dups" form because it's needed
+             -- below to report unsed binder on the LHS
+
+         -- Implicitly bound variables, empty if we have an explicit 'forall' according
+         -- to the "forall-or-nothing" rule.
+       ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups
+                      | otherwise = []
+       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars
+
+       ; let bndrs = fromMaybe [] mb_bndrs
+             bnd_vars = map hsLTyVarLocName bndrs
+             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars
+             -- Make sure to filter out the kind variables that were explicitly
+             -- bound in the type patterns.
+       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
+
+         -- all names not bound in an explict forall
+       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
+
+             -- All the free vars of the family patterns
+             -- with a sensible binding location
+       ; ((bndrs', pats', payload'), fvs)
+              <- bindLocalNamesFV all_imp_var_names $
+                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+                                   Nothing bndrs $ \bndrs' ->
+                 -- Note: If we pass mb_cls instead of Nothing here,
+                 --  bindLHsTyVarBndrs will use class variables for any names
+                 --  the user meant to bring in scope here. This is an explicit
+                 --  forall, so we want fresh names, not class variables.
+                 --  Thus: always pass Nothing
+                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
+                    ; (payload', rhs_fvs) <- rn_payload doc payload
+
+                       -- Report unused binders on the LHS
+                       -- See Note [Unused type variables in family instances]
+                    ; let groups :: [NonEmpty (Located RdrName)]
+                          groups = equivClasses cmpLocated $
+                                   pat_kity_vars_with_dups
+                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
+                                     [ tv | (tv :| (_:_)) <- groups ]
+                          -- Add to the used variables
+                          --  a) any variables that appear *more than once* on the LHS
+                          --     e.g.   F a Int a = Bool
+                          --  b) for associated instances, the variables
+                          --     of the instance decl.  See
+                          --     Note [Unused type variables in family instances]
+                    ; let nms_used = extendNameSetList rhs_fvs $
+                                        inst_tvs ++ nms_dups
+                          inst_tvs = case atfi of
+                                       NonAssocTyFamEqn          -> []
+                                       AssocTyFamDeflt _         -> []
+                                       AssocTyFamInst _ inst_tvs -> inst_tvs
+                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
+                    ; warnUnusedTypePatterns all_nms nms_used
+
+                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+
+       ; let all_fvs  = fvs `addOneFV` unLoc tycon'
+            -- type instance => use, hence addOneFV
+
+       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
+                      , hsib_body
+                          = FamEqn { feqn_ext    = noExt
+                                   , feqn_tycon  = tycon'
+                                   , feqn_bndrs  = bndrs' <$ mb_bndrs
+                                   , feqn_pats   = pats'
+                                   , feqn_fixity = fixity
+                                   , feqn_rhs    = payload' } },
+                 all_fvs) }
+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
+rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
+
+rnTyFamInstDecl :: AssocTyFamInfo
+                -> TyFamInstDecl GhcPs
+                -> RnM (TyFamInstDecl GhcRn, FreeVars)
+rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })
+  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn
+       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
+
+-- | Tracks whether we are renaming:
+--
+-- 1. A type family equation that is not associated
+--    with a parent type class ('NonAssocTyFamEqn')
+--
+-- 2. An associated type family default delcaration ('AssocTyFamDeflt')
+--
+-- 3. An associated type family instance declaration ('AssocTyFamInst')
+data AssocTyFamInfo
+  = NonAssocTyFamEqn
+  | AssocTyFamDeflt Name   -- Name of the parent class
+  | AssocTyFamInst  Name   -- Name of the parent class
+                    [Name] -- Names of the tyvars of the parent instance decl
+
+-- | Tracks whether we are renaming an equation in a closed type family
+-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
+data ClosedTyFamInfo
+  = NotClosedTyFam
+  | ClosedTyFam (Located RdrName) Name
+                -- The names (RdrName and Name) of the closed type family
+
+rnTyFamInstEqn :: AssocTyFamInfo
+               -> ClosedTyFamInfo
+               -> TyFamInstEqn GhcPs
+               -> RnM (TyFamInstEqn GhcRn, FreeVars)
+rnTyFamInstEqn atfi ctf_info
+    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+                                   , feqn_rhs   = rhs }})
+  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
+       ; (eqn'@(HsIB { hsib_body =
+                       FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)
+           <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
+       ; case ctf_info of
+           NotClosedTyFam -> pure ()
+           ClosedTyFam fam_rdr_name fam_name ->
+             checkTc (fam_name == tycon') $
+             withHsDocContext (TyFamilyCtx fam_rdr_name) $
+             wrongTyFamName fam_name tycon'
+       ; pure (eqn', fvs) }
+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
+rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
+
+rnTyFamDefltDecl :: Name
+                 -> TyFamDefltDecl GhcPs
+                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)
+rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)
+
+rnDataFamInstDecl :: AssocTyFamInfo
+                  -> DataFamInstDecl GhcPs
+                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
+                         FamEqn { feqn_tycon = tycon
+                                , feqn_rhs   = rhs }})})
+  = do { let rhs_kvs = extractDataDefnKindVars rhs
+       ; (eqn', fvs) <-
+           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn
+       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "rnDataFamInstDecl"
+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "rnDataFamInstDecl"
+
+-- Renaming of the associated types in instances.
+
+-- Rename associated type family decl in class
+rnATDecls :: Name      -- Class
+          -> [LFamilyDecl GhcPs]
+          -> RnM ([LFamilyDecl GhcRn], FreeVars)
+rnATDecls cls at_decls
+  = rnList (rnFamDecl (Just cls)) at_decls
+
+rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames
+                  decl GhcPs ->               -- an instance. rnTyFamInstDecl
+                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
+              -> Name      -- Class
+              -> [Name]
+              -> [Located (decl GhcPs)]
+              -> RnM ([Located (decl GhcRn)], FreeVars)
+-- Used for data and type family defaults in a class decl
+-- and the family instance declarations in an instance
+--
+-- NB: We allow duplicate associated-type decls;
+--     See Note [Associated type instances] in TcInstDcls
+rnATInstDecls rnFun cls tv_ns at_insts
+  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts
+    -- See Note [Renaming associated types]
+
+{- Note [Wildcards in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Wild cards can be used in type/data family instance declarations to indicate
+that the name of a type variable doesn't matter. Each wild card will be
+replaced with a new unique type variable. For instance:
+
+    type family F a b :: *
+    type instance F Int _ = Int
+
+is the same as
+
+    type family F a b :: *
+    type instance F Int b = Int
+
+This is implemented as follows: Unnamed wildcards remain unchanged after
+the renamer, and then given fresh meta-variables during typechecking, and
+it is handled pretty much the same way as the ones in partial type signatures.
+We however don't want to emit hole constraints on wildcards in family
+instances, so we turn on PartialTypeSignatures and turn off warning flag to
+let typechecker know this.
+See related Note [Wildcards in visible kind application] in TcHsType.hs
+
+Note [Unused type variables in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the flag -fwarn-unused-type-patterns is on, the compiler reports
+warnings about unused type variables in type-family instances. A
+tpye variable is considered used (i.e. cannot be turned into a wildcard)
+when
+
+ * it occurs on the RHS of the family instance
+   e.g.   type instance F a b = a    -- a is used on the RHS
+
+ * it occurs multiple times in the patterns on the LHS
+   e.g.   type instance F a a = Int  -- a appears more than once on LHS
+
+ * it is one of the instance-decl variables, for associated types
+   e.g.   instance C (a,b) where
+            type T (a,b) = a
+   Here the type pattern in the type instance must be the same as that
+   for the class instance, so
+            type T (a,_) = a
+   would be rejected.  So we should not complain about an unused variable b
+
+As usual, the warnings are not reported for type variables with names
+beginning with an underscore.
+
+Extra-constraints wild cards are not supported in type/data family
+instance declarations.
+
+Relevant tickets: #3699, #10586, #10982 and #11451.
+
+Note [Renaming associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check that the RHS of the decl mentions only type variables that are explicitly
+bound on the LHS.  For example, this is not ok
+   class C a b where
+      type F a x :: *
+   instance C (p,q) r where
+      type F (p,q) x = (x, r)   -- BAD: mentions 'r'
+c.f. #5515
+
+Kind variables, on the other hand, are allowed to be implicitly or explicitly
+bound. As examples, this (#9574) is acceptable:
+   class Funct f where
+      type Codomain f :: *
+   instance Funct ('KProxy :: KProxy o) where
+      -- o is implicitly bound by the kind signature
+      -- of the LHS type pattern ('KProxy)
+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
+And this (#14131) is also acceptable:
+    data family Nat :: k -> k -> *
+    -- k is implicitly bound by an invisible kind pattern
+    newtype instance Nat :: (k -> *) -> (k -> *) -> * where
+      Nat :: (forall xx. f xx -> g xx) -> Nat f g
+We could choose to disallow this, but then associated type families would not
+be able to be as expressive as top-level type synonyms. For example, this type
+synonym definition is allowed:
+    type T = (Nothing :: Maybe a)
+So for parity with type synonyms, we also allow:
+    type family   T :: Maybe a
+    type instance T = (Nothing :: Maybe a)
+
+All this applies only for *instance* declarations.  In *class*
+declarations there is no RHS to worry about, and the class variables
+can all be in scope (#5862):
+    class Category (x :: k -> k -> *) where
+      type Ob x :: k -> Constraint
+      id :: Ob x a => x a a
+      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
+Here 'k' is in scope in the kind signature, just like 'x'.
+
+Although type family equations can bind type variables with explicit foralls,
+it need not be the case that all variables that appear on the RHS must be bound
+by a forall. For instance, the following is acceptable:
+
+   class C a where
+     type T a b
+   instance C (Maybe a) where
+     type forall b. T (Maybe a) b = Either a b
+
+Even though `a` is not bound by the forall, this is still accepted because `a`
+was previously bound by the `instance C (Maybe a)` part. (see #16116).
+
+In each case, the function which detects improperly bound variables on the RHS
+is TcValidity.checkValidFamPats.
+-}
+
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Stand-alone deriving declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
+rnSrcDerivDecl (DerivDecl _ ty mds overlap)
+  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
+       ; unless standalone_deriv_ok (addErr standaloneDerivErr)
+       ; (mds', ty', fvs)
+           <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
+              rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
+              rnHsSigWcType BindUnlessForall DerivDeclCtx ty
+       ; warnNoDerivStrat mds' loc
+       ; return (DerivDecl noExt ty' mds' overlap, fvs) }
+  where
+    loc = getLoc $ hsib_body $ hswc_body ty
+rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"
+
+standaloneDerivErr :: SDoc
+standaloneDerivErr
+  = hang (text "Illegal standalone deriving declaration")
+       2 (text "Use StandaloneDeriving to enable this extension")
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Rules}
+*                                                      *
+*********************************************************
+-}
+
+rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
+rnHsRuleDecls (HsRules { rds_src = src
+                       , rds_rules = rules })
+  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
+       ; return (HsRules { rds_ext = noExt
+                         , rds_src = src
+                         , rds_rules = rn_rules }, fvs) }
+rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
+
+rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
+rnHsRuleDecl (HsRule { rd_name = rule_name
+                     , rd_act  = act
+                     , rd_tyvs = tyvs
+                     , rd_tmvs = tmvs
+                     , rd_lhs  = lhs
+                     , rd_rhs  = rhs })
+  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
+       ; checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
+       ; names <- newLocalBndrsRn rdr_names_w_loc
+       ; let doc = RuleCtx (snd $ unLoc rule_name)
+       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->
+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
+    do { (lhs', fv_lhs') <- rnLExpr lhs
+       ; (rhs', fv_rhs') <- rnLExpr rhs
+       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
+       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'
+                        , rd_name = rule_name
+                        , rd_act  = act
+                        , rd_tyvs = tyvs'
+                        , rd_tmvs = tmvs'
+                        , rd_lhs  = lhs'
+                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
+  where
+    get_var (RuleBndrSig _ v _) = v
+    get_var (RuleBndr _ v)      = v
+    get_var (XRuleBndr _)       = panic "rnHsRuleDecl"
+    in_rule = text "in the rule" <+> pprFullRuleName rule_name
+rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
+
+bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
+               -> [LRuleBndr GhcPs] -> [Name]
+               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
+               -> RnM (a, FreeVars)
+bindRuleTmVars doc tyvs vars names thing_inside
+  = go vars names $ \ vars' ->
+    bindLocalNamesFV names (thing_inside vars')
+  where
+    go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside
+      = go vars ns $ \ vars' ->
+        thing_inside (cL l (RuleBndr noExt (cL loc n)) : vars')
+
+    go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars)
+       (n : ns) thing_inside
+      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->
+        go vars ns $ \ vars' ->
+        thing_inside (cL l (RuleBndrSig noExt (cL loc n) bsig') : vars')
+
+    go [] [] thing_inside = thing_inside []
+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
+
+    bind_free_tvs = case tyvs of Nothing -> AlwaysBind
+                                 Just _  -> NeverBind
+
+bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
+               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))
+               -> RnM (b, FreeVars)
+bindRuleTyVars doc in_doc (Just bndrs) thing_inside
+  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing
+
+{-
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS.  Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.
+
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
+
+But there are legitimate non-trivial args ei, like sections and
+lambdas.  So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+-}
+
+checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
+checkValidRule rule_name ids lhs' fv_lhs'
+  = do  {       -- Check for the form of the LHS
+          case (validRuleLhs ids lhs') of
+                Nothing  -> return ()
+                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+                -- Check that LHS vars are all bound
+        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
+
+validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
+-- Nothing => OK
+-- Just e  => Not ok, and e is the offending sub-expression
+validRuleLhs foralls lhs
+  = checkl lhs
+  where
+    checkl = check . unLoc
+
+    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1
+                                                      `mplus` checkl_e e2
+    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2
+    check (HsAppType _ e _)               = checkl e
+    check (HsVar _ lv)
+      | (unLoc lv) `notElem` foralls      = Nothing
+    check other                           = Just other  -- Failure
+
+        -- Check an argument
+    checkl_e _ = Nothing
+    -- Was (check_e e); see Note [Rule LHS validity checking]
+
+{-      Commented out; see Note [Rule LHS validity checking] above
+    check_e (HsVar v)     = Nothing
+    check_e (HsPar e)     = checkl_e e
+    check_e (HsLit e)     = Nothing
+    check_e (HsOverLit e) = Nothing
+
+    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
+    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
+    check_e (NegApp e _)         = checkl_e e
+    check_e (ExplicitList _ es)  = checkl_es es
+    check_e other                = Just other   -- Fails
+
+    checkl_es es = foldr (mplus . checkl_e) Nothing es
+-}
+
+badRuleVar :: FastString -> Name -> SDoc
+badRuleVar name var
+  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
+         text "Forall'd variable" <+> quotes (ppr var) <+>
+                text "does not appear on left hand side"]
+
+badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
+badRuleLhsErr name lhs bad_e
+  = sep [text "Rule" <+> pprRuleName name <> colon,
+         nest 2 (vcat [err,
+                       text "in left-hand side:" <+> ppr lhs])]
+    $$
+    text "LHS must be of form (f e1 .. en) where f is not forall'd"
+  where
+    err = case bad_e of
+            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv))
+            _                 -> text "Illegal expression:" <+> ppr bad_e
+
+{- **************************************************************
+         *                                                      *
+      Renaming type, class, instance and role declarations
+*                                                               *
+*****************************************************************
+
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.
+
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.
+
+Note [Dependency analysis of type, class, and instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyClGroup represents a strongly connected components of
+type/class/instance decls, together with the role annotations for the
+type/class declarations.  The renamer uses strongly connected
+comoponent analysis to build these groups.  We do this for a number of
+reasons:
+
+* Improve kind error messages. Consider
+
+     data T f a = MkT f a
+     data S f a = MkS f (T f a)
+
+  This has a kind error, but the error message is better if you
+  check T first, (fixing its kind) and *then* S.  If you do kind
+  inference together, you might get an error reported in S, which
+  is jolly confusing.  See #4875
+
+
+* Increase kind polymorphism.  See TcTyClsDecls
+  Note [Grouping of type and class declarations]
+
+Why do the instance declarations participate?  At least two reasons
+
+* Consider (#11348)
+
+     type family F a
+     type instance F Int = Bool
+
+     data R = MkR (F Int)
+
+     type Foo = 'MkR 'True
+
+  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't
+  know that unless we've looked at the type instance declaration for F
+  before kind-checking Foo.
+
+* Another example is this (#3990).
+
+     data family Complex a
+     data instance Complex Double = CD {-# UNPACK #-} !Double
+                                       {-# UNPACK #-} !Double
+
+     data T = T {-# UNPACK #-} !(Complex Double)
+
+  Here, to generate the right kind of unpacked implementation for T,
+  we must have access to the 'data instance' declaration.
+
+* Things become more complicated when we introduce transitive
+  dependencies through imported definitions, like in this scenario:
+
+      A.hs
+        type family Closed (t :: Type) :: Type where
+          Closed t = Open t
+
+        type family Open (t :: Type) :: Type
+
+      B.hs
+        data Q where
+          Q :: Closed Bool -> Q
+
+        type instance Open Int = Bool
+
+        type S = 'Q 'True
+
+  Somehow, we must ensure that the instance Open Int = Bool is checked before
+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,
+  we have no idea that Closed depends upon Open!
+
+  To accomodate for these situations, we ensure that an instance is checked
+  before every @TyClDecl@ on which it does not depend. That's to say, instances
+  are checked as early as possible in @tcTyAndClassDecls@.
+
+------------------------------------
+So much for WHY.  What about HOW?  It's pretty easy:
+
+(1) Rename the type/class, instance, and role declarations
+    individually
+
+(2) Do strongly-connected component analysis of the type/class decls,
+    We'll make a TyClGroup for each SCC
+
+    In this step we treat a reference to a (promoted) data constructor
+    K as a dependency on its parent type.  Thus
+        data T = K1 | K2
+        data S = MkS (Proxy 'K1)
+    Here S depends on 'K1 and hence on its parent T.
+
+    In this step we ignore instances; see
+    Note [No dependencies on data instances]
+
+(3) Attach roles to the appropriate SCC
+
+(4) Attach instances to the appropriate SCC.
+    We add an instance decl to SCC when:
+      all its free types/classes are bound in this SCC or earlier ones
+
+(5) We make an initial TyClGroup, with empty group_tyclds, for any
+    (orphan) instances that affect only imported types/classes
+
+Steps (3) and (4) are done by the (mapAccumL mk_group) call.
+
+Note [No dependencies on data instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   data family D a
+   data instance D Int = D1
+   data S = MkS (Proxy 'D1)
+
+Here the declaration of S depends on the /data instance/ declaration
+for 'D Int'.  That makes things a lot more complicated, especially
+if the data instance is an associated type of an enclosing class instance.
+(And the class instance might have several associated type instances
+with different dependency structure!)
+
+Ugh.  For now we simply don't allow promotion of data constructors for
+data instances.  See Note [AFamDataCon: not promoting data family
+constructors] in TcEnv
+-}
+
+
+rnTyClDecls :: [TyClGroup GhcPs]
+            -> RnM ([TyClGroup GhcRn], FreeVars)
+-- Rename the declarations and do dependency analysis on them
+rnTyClDecls tycl_ds
+  = do { -- Rename the type/class, instance, and role declaraations
+         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
+                             (tyClGroupTyClDecls tycl_ds)
+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
+
+       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
+       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
+
+       -- Do SCC analysis on the type/class decls
+       ; rdr_env <- getGlobalRdrEnv
+       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
+             role_annot_env = mkRoleAnnotEnv role_annots
+
+             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
+             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
+
+             first_group
+               | null init_inst_ds = []
+               | otherwise = [TyClGroup { group_ext    = noExt
+                                        , group_tyclds = []
+                                        , group_roles  = []
+                                        , group_instds = init_inst_ds }]
+
+             ((final_inst_ds, orphan_roles), groups)
+                = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
+
+
+             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
+                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)
+
+             all_groups = first_group ++ groups
+
+       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map
+                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )
+         mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
+
+       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
+       ; return (all_groups, all_fvs) }
+  where
+    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
+             -> SCC (LTyClDecl GhcRn)
+             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
+                , TyClGroup GhcRn )
+    mk_group (inst_map, role_env) scc
+      = ((inst_map', role_env'), group)
+      where
+        tycl_ds              = flattenSCC scc
+        bndrs                = map (tcdName . unLoc) tycl_ds
+        (inst_ds, inst_map') = getInsts      bndrs inst_map
+        (roles,   role_env') = getRoleAnnots bndrs role_env
+        group = TyClGroup { group_ext    = noExt
+                          , group_tyclds = tycl_ds
+                          , group_roles  = roles
+                          , group_instds = inst_ds }
+
+
+depAnalTyClDecls :: GlobalRdrEnv
+                 -> [(LTyClDecl GhcRn, FreeVars)]
+                 -> [SCC (LTyClDecl GhcRn)]
+-- See Note [Dependency analysis of type, class, and instance decls]
+depAnalTyClDecls rdr_env ds_w_fvs
+  = stronglyConnCompFromEdgedVerticesUniq edges
+  where
+    edges :: [ Node Name (LTyClDecl GhcRn) ]
+    edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
+            | (d, fvs) <- ds_w_fvs ]
+            -- It's OK to use nonDetEltsUFM here as
+            -- stronglyConnCompFromEdgedVertices is still deterministic
+            -- even if the edges are in nondeterministic order as explained
+            -- in Note [Deterministic SCC] in Digraph.
+
+toParents :: GlobalRdrEnv -> NameSet -> NameSet
+toParents rdr_env ns
+  = nonDetFoldUniqSet add emptyNameSet ns
+  -- It's OK to use nonDetFoldUFM because we immediately forget the
+  -- ordering by creating a set
+  where
+    add n s = extendNameSet s (getParent rdr_env n)
+
+getParent :: GlobalRdrEnv -> Name -> Name
+getParent rdr_env n
+  = case lookupGRE_Name rdr_env n of
+      Just gre -> case gre_par gre of
+                    ParentIs  { par_is = p } -> p
+                    FldParent { par_is = p } -> p
+                    _                        -> n
+      Nothing -> n
+
+
+{- ******************************************************
+*                                                       *
+       Role annotations
+*                                                       *
+****************************************************** -}
+
+-- | Renames role annotations, returning them as the values in a NameEnv
+-- and checks for duplicate role annotations.
+-- It is quite convenient to do both of these in the same place.
+-- See also Note [Role annotations in the renamer]
+rnRoleAnnots :: NameSet
+             -> [LRoleAnnotDecl GhcPs]
+             -> RnM [LRoleAnnotDecl GhcRn]
+rnRoleAnnots tc_names role_annots
+  = do {  -- Check for duplicates *before* renaming, to avoid
+          -- lumping together all the unboundNames
+         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
+             role_annots_cmp (dL->L _ annot1) (dL->L _ annot2)
+               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
+       ; mapM_ dupRoleAnnotErr dup_annots
+       ; mapM (wrapLocM rn_role_annot1) no_dups }
+  where
+    rn_role_annot1 (RoleAnnotDecl _ tycon roles)
+      = do {  -- the name is an *occurrence*, but look it up only in the
+              -- decls defined in this group (see #10263)
+             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
+                                          (text "role annotation")
+                                          tycon
+           ; return $ RoleAnnotDecl noExt tycon' roles }
+    rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"
+
+dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
+dupRoleAnnotErr list
+  = addErrAt loc $
+    hang (text "Duplicate role annotations for" <+>
+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
+       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
+    where
+      sorted_list = NE.sortBy cmp_annot list
+      ((dL->L loc first_decl) :| _) = sorted_list
+
+      pp_role_annot (dL->L loc decl) = hang (ppr decl)
+                                      4 (text "-- written at" <+> ppr loc)
+
+      cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2
+
+orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()
+orphanRoleAnnotErr (dL->L loc decl)
+  = addErrAt loc $
+    hang (text "Role annotation for a type previously declared:")
+       2 (ppr decl) $$
+    parens (text "The role annotation must be given where" <+>
+            quotes (ppr $ roleAnnotDeclName decl) <+>
+            text "is declared.")
+
+
+{- Note [Role annotations in the renamer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must ensure that a type's role annotation is put in the same group as the
+proper type declaration. This is because role annotations are needed during
+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
+type, if any. Then, this map can be used to add the role annotations to the
+groups after dependency analysis.
+
+This process checks for duplicate role annotations, where we must be careful
+to do the check *before* renaming to avoid calling all unbound names duplicates
+of one another.
+
+The renaming process, as usual, might identify and report errors for unbound
+names. We exclude the annotations for unbound names in the annotation
+environment to avoid spurious errors for orphaned annotations.
+
+We then (in rnTyClDecls) do a check for orphan role annotations (role
+annotations without an accompanying type decl). The check works by folding
+over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
+out the relevant role declarations for each group, as well as diminishing the
+annotation environment. After the fold is complete, anything left over in the
+name environment must be an orphan, and errors are generated.
+
+An earlier version of this algorithm short-cut the orphan check by renaming
+only with names declared in this module. But, this check is insufficient in
+the case of staged module compilation (Template Haskell, GHCi).
+See #8485. With the new lookup process (which includes types declared in other
+modules), we get better error messages, too.
+-}
+
+
+{- ******************************************************
+*                                                       *
+       Dependency info for instances
+*                                                       *
+****************************************************** -}
+
+----------------------------------------------------------
+-- | 'InstDeclFreeVarsMap is an association of an
+--   @InstDecl@ with @FreeVars@. The @FreeVars@ are
+--   the tycon names that are both
+--     a) free in the instance declaration
+--     b) bound by this group of type/class/instance decls
+type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
+
+-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
+--   @FreeVars@ which are *not* the binders of a @TyClDecl@.
+mkInstDeclFreeVarsMap :: GlobalRdrEnv
+                      -> NameSet
+                      -> [(LInstDecl GhcRn, FreeVars)]
+                      -> InstDeclFreeVarsMap
+mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
+  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
+    | (inst_decl, fvs) <- inst_ds_fvs ]
+
+-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
+--   @InstDeclFreeVarsMap@ with these entries removed.
+-- We call (getInsts tcs instd_map) when we've completed the declarations
+-- for 'tcs'.  The call returns (inst_decls, instd_map'), where
+--   inst_decls are the instance declarations all of
+--              whose free vars are now defined
+--   instd_map' is the inst-decl map with 'tcs' removed from
+--               the free-var set
+getInsts :: [Name] -> InstDeclFreeVarsMap
+         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
+getInsts bndrs inst_decl_map
+  = partitionWith pick_me inst_decl_map
+  where
+    pick_me :: (LInstDecl GhcRn, FreeVars)
+            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
+    pick_me (decl, fvs)
+      | isEmptyNameSet depleted_fvs = Left decl
+      | otherwise                   = Right (decl, depleted_fvs)
+      where
+        depleted_fvs = delFVs bndrs fvs
+
+{- ******************************************************
+*                                                       *
+         Renaming a type or class declaration
+*                                                       *
+****************************************************** -}
+
+rnTyClDecl :: TyClDecl GhcPs
+           -> RnM (TyClDecl GhcRn, FreeVars)
+
+-- All flavours of type family declarations ("type family", "newtype family",
+-- and "data family"), both top level and (for an associated type)
+-- in a class decl
+rnTyClDecl (FamDecl { tcdFam = decl })
+  = do { (decl', fvs) <- rnFamDecl Nothing decl
+       ; return (FamDecl noExt decl', fvs) }
+
+rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
+                      tcdFixity = fixity, tcdRhs = rhs })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; let kvs = extractHsTyRdrTyVarsKindVars rhs
+             doc = TySynCtx tycon
+       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
+    do { (rhs', fvs) <- rnTySyn doc rhs
+       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
+                         , tcdFixity = fixity
+                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
+
+-- "data", "newtype" declarations
+-- both top level and (for an associated type) in an instance decl
+rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
+                       tcdFixity = fixity, tcdDataDefn = defn })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; let kvs = extractDataDefnKindVars defn
+             doc = TyDataCtx tycon
+       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
+    do { (defn', fvs) <- rnDataDefn doc defn
+          -- See Note [Complete user-supplied kind signatures] in HsDecls
+       ; cusks_enabled <- xoptM LangExt.CUSKs
+       ; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs
+             rn_info = DataDeclRn { tcdDataCusk = cusk
+                                  , tcdFVs      = fvs }
+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
+       ; return (DataDecl { tcdLName    = tycon'
+                          , tcdTyVars   = tyvars'
+                          , tcdFixity   = fixity
+                          , tcdDataDefn = defn'
+                          , tcdDExt     = rn_info }, fvs) } }
+
+rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
+                        tcdTyVars = tyvars, tcdFixity = fixity,
+                        tcdFDs = fds, tcdSigs = sigs,
+                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+                        tcdDocs = docs})
+  = do  { lcls' <- lookupLocatedTopBndrRn lcls
+        ; let cls' = unLoc lcls'
+              kvs = []  -- No scoped kind vars except those in
+                        -- kind signatures on the tyvars
+
+        -- Tyvars scope over superclass context and method signatures
+        ; ((tyvars', context', fds', ats'), stuff_fvs)
+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
+                  -- Checks for distinct tyvars
+             { (context', cxt_fvs) <- rnContext cls_doc context
+             ; fds'  <- rnFds fds
+                         -- The fundeps have no free variables
+             ; (ats', fv_ats) <- rnATDecls cls' ats
+             ; let fvs = cxt_fvs     `plusFV`
+                         fv_ats
+             ; return ((tyvars', context', fds', ats'), fvs) }
+
+        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs
+
+        -- No need to check for duplicate associated type decls
+        -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+        -- Check the signatures
+        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
+        ; let sig_rdr_names_w_locs =
+                [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs
+                    , op <- ops]
+        ; checkDupRdrNames sig_rdr_names_w_locs
+                -- Typechecker is responsible for checking that we only
+                -- give default-method bindings for things in this class.
+                -- The renamer *could* check this for class decls, but can't
+                -- for instance decls.
+
+        -- The newLocals call is tiresome: given a generic class decl
+        --      class C a where
+        --        op :: a -> a
+        --        op {| x+y |} (Inl a) = ...
+        --        op {| x+y |} (Inr b) = ...
+        --        op {| a*b |} (a*b)   = ...
+        -- we want to name both "x" tyvars with the same unique, so that they are
+        -- easy to group together in the typechecker.
+        ; (mbinds', sigs', meth_fvs)
+            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
+                -- No need to check for duplicate method signatures
+                -- since that is done by RnNames.extendGlobalRdrEnvRn
+                -- and the methods are already in scope
+
+  -- Haddock docs
+        ; docs' <- mapM (wrapLocM rnDocDecl) docs
+
+        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
+        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
+                              tcdTyVars = tyvars', tcdFixity = fixity,
+                              tcdFDs = fds', tcdSigs = sigs',
+                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
+                              tcdDocs = docs', tcdCExt = all_fvs },
+                  all_fvs ) }
+  where
+    cls_doc  = ClassDeclCtx lcls
+
+rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
+
+-- "type" and "type instance" declarations
+rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
+rnTySyn doc rhs = rnLHsType doc rhs
+
+rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
+           -> RnM (HsDataDefn GhcRn, FreeVars)
+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                           , dd_ctxt = context, dd_cons = condecls
+                           , dd_kindSig = m_sig, dd_derivs = derivs })
+  = do  { checkTc (h98_style || null (unLoc context))
+                  (badGadtStupidTheta doc)
+
+        ; (m_sig', sig_fvs) <- case m_sig of
+             Just sig -> first Just <$> rnLHsKind doc sig
+             Nothing  -> return (Nothing, emptyFVs)
+        ; (context', fvs1) <- rnContext doc context
+        ; (derivs',  fvs3) <- rn_derivs derivs
+
+        -- For the constructor declarations, drop the LocalRdrEnv
+        -- in the GADT case, where the type variables in the declaration
+        -- do not scope over the constructor signatures
+        -- data T a where { T1 :: forall b. b-> b }
+        ; let { zap_lcl_env | h98_style = \ thing -> thing
+                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
+        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
+           -- No need to check for duplicate constructor decls
+           -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
+                        con_fvs `plusFV` sig_fvs
+        ; return ( HsDataDefn { dd_ext = noExt
+                              , dd_ND = new_or_data, dd_cType = cType
+                              , dd_ctxt = context', dd_kindSig = m_sig'
+                              , dd_cons = condecls'
+                              , dd_derivs = derivs' }
+                 , all_fvs )
+        }
+  where
+    h98_style = case condecls of  -- Note [Stupid theta]
+                     (dL->L _ (ConDeclGADT {})) : _  -> False
+                     _                               -> True
+
+    rn_derivs (dL->L loc ds)
+      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
+           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
+               multipleDerivClausesErr
+           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
+           ; return (cL loc ds', fvs) }
+rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"
+
+warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
+                 -> SrcSpan
+                 -> RnM ()
+warnNoDerivStrat mds loc
+  = do { dyn_flags <- getDynFlags
+       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $
+           case mds of
+             Nothing -> addWarnAt
+               (Reason Opt_WarnMissingDerivingStrategies)
+               loc
+               (if xopt LangExt.DerivingStrategies dyn_flags
+                 then no_strat_warning
+                 else no_strat_warning $+$ deriv_strat_nenabled
+               )
+             _ -> pure ()
+       }
+  where
+    no_strat_warning :: SDoc
+    no_strat_warning = text "No deriving strategy specified. Did you want stock"
+                       <> text ", newtype, or anyclass?"
+    deriv_strat_nenabled :: SDoc
+    deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."
+
+rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
+                    -> RnM (LHsDerivingClause GhcRn, FreeVars)
+rnLHsDerivingClause doc
+                (dL->L loc (HsDerivingClause
+                              { deriv_clause_ext = noExt
+                              , deriv_clause_strategy = dcs
+                              , deriv_clause_tys = (dL->L loc' dct) }))
+  = do { (dcs', dct', fvs)
+           <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->
+              mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct
+       ; warnNoDerivStrat dcs' loc
+       ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExt
+                                         , deriv_clause_strategy = dcs'
+                                         , deriv_clause_tys = cL loc' dct' })
+              , fvs ) }
+  where
+    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
+                -> RnM (LHsSigType GhcRn, FreeVars)
+    rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) =
+      rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $
+      rnHsSigType doc deriv_ty
+    rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"
+rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _))
+  = panic "rnLHsDerivingClause"
+rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"
+                                -- due to #15884
+
+rnLDerivStrategy :: forall a.
+                    HsDocContext
+                 -> Maybe (LDerivStrategy GhcPs)
+                 -> ([Name]   -- The tyvars bound by the via type
+                      -> SDoc -- The pretty-printed via type (used for
+                              -- error message reporting)
+                      -> RnM (a, FreeVars))
+                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
+rnLDerivStrategy doc mds thing_inside
+  = case mds of
+      Nothing -> boring_case Nothing
+      Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds
+                    pure (Just ds', thing, fvs)
+  where
+    rn_deriv_strat :: LDerivStrategy GhcPs
+                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)
+    rn_deriv_strat (dL->L loc ds) = do
+      let extNeeded :: LangExt.Extension
+          extNeeded
+            | ViaStrategy{} <- ds
+            = LangExt.DerivingVia
+            | otherwise
+            = LangExt.DerivingStrategies
+
+      unlessXOptM extNeeded $
+        failWith $ illegalDerivStrategyErr ds
+
+      case ds of
+        StockStrategy    -> boring_case (cL loc StockStrategy)
+        AnyclassStrategy -> boring_case (cL loc AnyclassStrategy)
+        NewtypeStrategy  -> boring_case (cL loc NewtypeStrategy)
+        ViaStrategy via_ty ->
+          do (via_ty', fvs1) <- rnHsSigType doc via_ty
+             let HsIB { hsib_ext  = via_imp_tvs
+                      , hsib_body = via_body } = via_ty'
+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
+                 via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs
+                 via_tvs = via_imp_tvs ++ via_exp_tvs
+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
+                              thing_inside via_tvs (ppr via_ty')
+             pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)
+
+    boring_case :: mds
+                -> RnM (mds, a, FreeVars)
+    boring_case mds = do
+      (thing, fvs) <- thing_inside [] empty
+      pure (mds, thing, fvs)
+
+-- | Errors if a @via@ type binds any floating type variables.
+-- See @Note [Floating `via` type variables]@
+rnAndReportFloatingViaTvs
+  :: forall a. Outputable a
+  => [Name]  -- ^ The bound type variables from a @via@ type.
+  -> SrcSpan -- ^ The source span (for error reporting only).
+  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).
+  -> String  -- ^ A description of what the @via@ type scopes over
+             --   (for error reporting only).
+  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
+  -> RnM (a, FreeVars)
+rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside
+  = do (thing, thing_fvs) <- thing_inside
+       setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names
+       pure (thing, thing_fvs)
+  where
+    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
+    report_floating_via_tv thing used_names tv_name
+      = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat
+          [ text "Type variable" <+> quotes (ppr tv_name) <+>
+            text "is bound in the" <+> quotes (text "via") <+>
+            text "type" <+> quotes ppr_via_ty
+          , text "but is not mentioned in the derived" <+>
+            text via_scope_desc <+> quotes (ppr thing) <>
+            text ", which is illegal" ]
+
+{-
+Note [Floating `via` type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine the following `deriving via` clause:
+
+    data Quux
+      deriving Eq via (Const a Quux)
+
+This should be rejected. Why? Because it would generate the following instance:
+
+    instance Eq Quux where
+      (==) = coerce @(Quux         -> Quux         -> Bool)
+                    @(Const a Quux -> Const a Quux -> Bool)
+                    (==) :: Const a Quux -> Const a Quux -> Bool
+
+This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
+problem is that `a` is never used anywhere in the derived class `Eq`. Since
+`a` is bound but has no use sites, we refer to it as "floating".
+
+We use the rnAndReportFloatingViaTvs function to check that any type renamed
+within the context of the `via` deriving strategy actually uses all bound
+`via` type variables, and if it doesn't, it throws an error.
+-}
+
+badGadtStupidTheta :: HsDocContext -> SDoc
+badGadtStupidTheta _
+  = vcat [text "No context is allowed on a GADT-style data declaration",
+          text "(You can put a context on each constructor, though.)"]
+
+illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
+illegalDerivStrategyErr ds
+  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
+         , text enableStrategy ]
+
+  where
+    enableStrategy :: String
+    enableStrategy
+      | ViaStrategy{} <- ds
+      = "Use DerivingVia to enable this extension"
+      | otherwise
+      = "Use DerivingStrategies to enable this extension"
+
+multipleDerivClausesErr :: SDoc
+multipleDerivClausesErr
+  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
+         , text "Use DerivingStrategies to allow this" ]
+
+rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
+                        --             inside an *class decl* for cls
+                        --             used for associated types
+          -> FamilyDecl GhcPs
+          -> RnM (FamilyDecl GhcRn, FreeVars)
+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
+                             , fdFixity = fixity
+                             , fdInfo = info, fdResultSig = res_sig
+                             , fdInjectivityAnn = injectivity })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; ((tyvars', res_sig', injectivity'), fv1) <-
+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
+            do { let rn_sig = rnFamResultSig doc
+               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
+               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
+                                          injectivity
+               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
+       ; (info', fv2) <- rn_info tycon' info
+       ; return (FamilyDecl { fdExt = noExt
+                            , fdLName = tycon', fdTyVars = tyvars'
+                            , fdFixity = fixity
+                            , fdInfo = info', fdResultSig = res_sig'
+                            , fdInjectivityAnn = injectivity' }
+                , fv1 `plusFV` fv2) }
+  where
+     doc = TyFamilyCtx tycon
+     kvs = extractRdrKindSigVars res_sig
+
+     ----------------------
+     rn_info :: Located Name
+             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
+     rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))
+       = do { (eqns', fvs)
+                <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))
+                                          -- no class context
+                          eqns
+            ; return (ClosedTypeFamily (Just eqns'), fvs) }
+     rn_info _ (ClosedTypeFamily Nothing)
+       = return (ClosedTypeFamily Nothing, emptyFVs)
+     rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
+     rn_info _ DataFamily     = return (DataFamily, emptyFVs)
+rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
+
+rnFamResultSig :: HsDocContext
+               -> FamilyResultSig GhcPs
+               -> RnM (FamilyResultSig GhcRn, FreeVars)
+rnFamResultSig _ (NoSig _)
+   = return (NoSig noExt, emptyFVs)
+rnFamResultSig doc (KindSig _ kind)
+   = do { (rndKind, ftvs) <- rnLHsKind doc kind
+        ;  return (KindSig noExt rndKind, ftvs) }
+rnFamResultSig doc (TyVarSig _ tvbndr)
+   = do { -- `TyVarSig` tells us that user named the result of a type family by
+          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
+          -- be sure that the supplied result name is not identical to an
+          -- already in-scope type variable from an enclosing class.
+          --
+          --  Example of disallowed declaration:
+          --         class C a b where
+          --            type F b = a | a -> b
+          rdr_env <- getLocalRdrEnv
+       ;  let resName = hsLTyVarName tvbndr
+       ;  when (resName `elemLocalRdrEnv` rdr_env) $
+          addErrAt (getLoc tvbndr) $
+                     (hsep [ text "Type variable", quotes (ppr resName) <> comma
+                           , text "naming a type family result,"
+                           ] $$
+                      text "shadows an already bound type variable")
+
+       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
+                                      -- scoping checks that are irrelevant here
+                          tvbndr $ \ tvbndr' ->
+         return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }
+rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"
+
+-- Note [Renaming injectivity annotation]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During renaming of injectivity annotation we have to make several checks to
+-- make sure that it is well-formed.  At the moment injectivity annotation
+-- consists of a single injectivity condition, so the terms "injectivity
+-- annotation" and "injectivity condition" might be used interchangeably.  See
+-- Note [Injectivity annotation] for a detailed discussion of currently allowed
+-- injectivity annotations.
+--
+-- Checking LHS is simple because the only type variable allowed on the LHS of
+-- injectivity condition is the variable naming the result in type family head.
+-- Example of disallowed annotation:
+--
+--     type family Foo a b = r | b -> a
+--
+-- Verifying RHS of injectivity consists of checking that:
+--
+--  1. only variables defined in type family head appear on the RHS (kind
+--     variables are also allowed).  Example of disallowed annotation:
+--
+--        type family Foo a = r | r -> b
+--
+--  2. for associated types the result variable does not shadow any of type
+--     class variables. Example of disallowed annotation:
+--
+--        class Foo a b where
+--           type F a = b | b -> a
+--
+-- Breaking any of these assumptions results in an error.
+
+-- | Rename injectivity annotation. Note that injectivity annotation is just the
+-- part after the "|".  Everything that appears before it is renamed in
+-- rnFamDecl.
+rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in
+                                               --   type family head
+                 -> LFamilyResultSig GhcRn     -- ^ Result signature
+                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation
+                 -> RnM (LInjectivityAnn GhcRn)
+rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv))
+                 (dL->L srcSpan (InjectivityAnn injFrom injTo))
+ = do
+   { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
+          <- askNoErrs $
+             bindLocalNames [hsLTyVarName resTv] $
+             -- The return type variable scopes over the injectivity annotation
+             -- e.g.   type family F a = (r::*) | r -> a
+             do { injFrom' <- rnLTyVar injFrom
+                ; injTo'   <- mapM rnLTyVar injTo
+                ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') }
+
+   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs
+         resName  = hsLTyVarName resTv
+         -- See Note [Renaming injectivity annotation]
+         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
+         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
+
+   -- if renaming of type variables ended with errors (eg. there were
+   -- not-in-scope variables) don't check the validity of injectivity
+   -- annotation. This gives better error messages.
+   ; when (noRnErrors && not lhsValid) $
+        addErrAt (getLoc injFrom)
+              ( vcat [ text $ "Incorrect type variable on the LHS of "
+                           ++ "injectivity condition"
+              , nest 5
+              ( vcat [ text "Expected :" <+> ppr resName
+                     , text "Actual   :" <+> ppr injFrom ])])
+
+   ; when (noRnErrors && not (Set.null rhsValid)) $
+      do { let errorVars = Set.toList rhsValid
+         ; addErrAt srcSpan $ ( hsep
+                        [ text "Unknown type variable" <> plural errorVars
+                        , text "on the RHS of injectivity condition:"
+                        , interpp'SP errorVars ] ) }
+
+   ; return injDecl' }
+
+-- We can only hit this case when the user writes injectivity annotation without
+-- naming the result:
+--
+--   type family F a | result -> a
+--   type family F a :: * | result -> a
+--
+-- So we rename injectivity annotation like we normally would except that
+-- this time we expect "result" to be reported not in scope by rnLTyVar.
+rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) =
+   setSrcSpan srcSpan $ do
+   (injDecl', _) <- askNoErrs $ do
+     injFrom' <- rnLTyVar injFrom
+     injTo'   <- mapM rnLTyVar injTo
+     return $ cL srcSpan (InjectivityAnn injFrom' injTo')
+   return $ injDecl'
+
+{-
+Note [Stupid theta]
+~~~~~~~~~~~~~~~~~~~
+#3850 complains about a regression wrt 6.10 for
+     data Show a => T a
+There is no reason not to allow the stupid theta if there are no data
+constructors.  It's still stupid, but does no harm, and I don't want
+to cause programs to break unnecessarily (notably HList).  So if there
+are no data constructors we allow h98_style = True
+-}
+
+
+{- *****************************************************
+*                                                      *
+     Support code for type/data declarations
+*                                                      *
+***************************************************** -}
+
+---------------
+wrongTyFamName :: Name -> Name -> SDoc
+wrongTyFamName fam_tc_name eqn_tc_name
+  = hang (text "Mismatched type name in type family instance.")
+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name
+               , text "  Actual:" <+> ppr eqn_tc_name ])
+
+-----------------
+rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
+
+rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                           , con_mb_cxt = mcxt, con_args = args
+                           , con_doc = mb_doc })
+  = do  { _        <- addLocM checkConName name
+        ; new_name <- lookupLocatedTopBndrRn name
+        ; mb_doc'  <- rnMbLHsDoc mb_doc
+
+        -- We bind no implicit binders here; this is just like
+        -- a nested HsForAllTy.  E.g. consider
+        --         data T a = forall (b::k). MkT (...)
+        -- The 'k' will already be in scope from the bindHsQTyVars
+        -- for the data decl itself. So we'll get
+        --         data T {k} a = ...
+        -- And indeed we may later discover (a::k).  But that's the
+        -- scoping we get.  So no implicit binders at the existential forall
+
+        ; let ctxt = ConDeclCtx [new_name]
+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+                            Nothing ex_tvs $ \ new_ex_tvs ->
+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+        ; let all_fvs  = fvs1 `plusFV` fvs2
+        ; traceRn "rnConDecl" (ppr name <+> vcat
+             [ text "ex_tvs:" <+> ppr ex_tvs
+             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
+
+        ; return (decl { con_ext = noExt
+                       , con_name = new_name, con_ex_tvs = new_ex_tvs
+                       , con_mb_cxt = new_context, con_args = new_args
+                       , con_doc = mb_doc' },
+                  all_fvs) }}
+
+rnConDecl decl@(ConDeclGADT { con_names   = names
+                            , con_forall  = (dL->L _ explicit_forall)
+                            , con_qvars   = qtvs
+                            , con_mb_cxt  = mcxt
+                            , con_args    = args
+                            , con_res_ty  = res_ty
+                            , con_doc = mb_doc })
+  = do  { mapM_ (addLocM checkConName) names
+        ; new_names <- mapM lookupLocatedTopBndrRn names
+        ; mb_doc'   <- rnMbLHsDoc mb_doc
+
+        ; let explicit_tkvs = hsQTvExplicit qtvs
+              theta         = hsConDeclTheta mcxt
+              arg_tys       = hsConDeclArgTys args
+
+          -- We must ensure that we extract the free tkvs in left-to-right
+          -- order of their appearance in the constructor type.
+          -- That order governs the order the implicitly-quantified type
+          -- variable, and hence the order needed for visible type application
+          -- See #14808.
+              free_tkvs = extractHsTvBndrs explicit_tkvs $
+                          extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
+
+              ctxt    = ConDeclCtx new_names
+              mb_ctxt = Just (inHsDocContext ctxt)
+
+        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
+        ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->
+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+
+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+              (args', res_ty')
+                  = case args of
+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)
+                      RecCon {}    -> (new_args, new_res_ty)
+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
+                                   -> ASSERT( null as )
+                                      -- See Note [GADT abstract syntax] in HsDecls
+                                      (PrefixCon arg_tys, final_res_ty)
+
+              new_qtvs =  HsQTvs { hsq_ext = implicit_tkvs
+                                 , hsq_explicit  = explicit_tkvs }
+
+        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
+        ; return (decl { con_g_ext = noExt, con_names = new_names
+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+                       , con_args = args', con_res_ty = res_ty'
+                       , con_doc = mb_doc' },
+                  all_fvs) } }
+
+rnConDecl (XConDecl _) = panic "rnConDecl"
+
+
+rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
+rnMbContext _    Nothing    = return (Nothing, emptyFVs)
+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
+                                ; return (Just ctx',fvs) }
+
+rnConDeclDetails
+   :: Name
+   -> HsDocContext
+   -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
+   -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
+           FreeVars)
+rnConDeclDetails _ doc (PrefixCon tys)
+  = do { (new_tys, fvs) <- rnLHsTypes doc tys
+       ; return (PrefixCon new_tys, fvs) }
+
+rnConDeclDetails _ doc (InfixCon ty1 ty2)
+  = do { (new_ty1, fvs1) <- rnLHsType doc ty1
+       ; (new_ty2, fvs2) <- rnLHsType doc ty2
+       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
+
+rnConDeclDetails con doc (RecCon (dL->L l fields))
+  = do  { fls <- lookupConstructorFields con
+        ; (new_fields, fvs) <- rnConDeclFields doc fls fields
+                -- No need to check for duplicate fields
+                -- since that is done by RnNames.extendGlobalRdrEnvRn
+        ; return (RecCon (cL l new_fields), fvs) }
+
+-------------------------------------------------
+
+-- | Brings pattern synonym names and also pattern synonym selectors
+-- from record pattern synonyms into scope.
+extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
+                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
+extendPatSynEnv val_decls local_fix_env thing = do {
+     names_with_fls <- new_ps val_decls
+   ; let pat_syn_bndrs = concat [ name: map flSelector fields
+                                | (name, fields) <- names_with_fls ]
+   ; let avails = map avail pat_syn_bndrs
+   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
+
+   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
+         final_gbl_env = gbl_env { tcg_field_env = field_env' }
+   ; 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 _ = panic "new_ps"
+
+    new_ps' :: LHsBindLR GhcPs GhcPs
+            -> [(Name, [FieldLabel])]
+            -> TcM [(Name, [FieldLabel])]
+    new_ps' bind names
+      | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n)
+                                           , psb_args = RecCon as }))) <- bind
+      = do
+          bnd_name <- newTopSrcBinder (cL bind_loc n)
+          let rnames = map recordPatSynSelectorId as
+              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
+              mkFieldOcc (dL->L l name) = cL l (FieldOcc noExt (cL l name))
+              field_occs =  map mkFieldOcc rnames
+          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs
+          return ((bnd_name, flds): names)
+      | (dL->L bind_loc (PatSynBind _
+                          (PSB { psb_id = (dL->L _ n)}))) <- bind
+      = do
+        bnd_name <- newTopSrcBinder (cL bind_loc n)
+        return ((bnd_name, []): names)
+      | otherwise
+      = return names
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Support code to rename types}
+*                                                      *
+*********************************************************
+-}
+
+rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
+rnFds fds
+  = mapM (wrapLocM rn_fds) fds
+  where
+    rn_fds (tys1, tys2)
+      = do { tys1' <- rnHsTyVars tys1
+           ; tys2' <- rnHsTyVars tys2
+           ; return (tys1', tys2') }
+
+rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
+rnHsTyVars tvs  = mapM rnHsTyVar tvs
+
+rnHsTyVar :: Located RdrName -> RnM (Located Name)
+rnHsTyVar (dL->L l tyvar) = do
+  tyvar' <- lookupOccRn tyvar
+  return (cL l tyvar')
+
+{-
+*********************************************************
+*                                                      *
+        findSplice
+*                                                      *
+*********************************************************
+
+This code marches down the declarations, looking for the first
+Template Haskell splice.  As it does so it
+        a) groups the declarations into a HsGroup
+        b) runs any top-level quasi-quotes
+-}
+
+findSplice :: [LHsDecl GhcPs]
+           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
+findSplice ds = addl emptyRdrGroup ds
+
+addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
+     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
+-- This stuff reverses the declarations (again) but it doesn't matter
+addl gp []           = return (gp, Nothing)
+addl gp ((dL->L l d) : ds) = add gp l d ds
+
+
+add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
+    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
+
+-- #10047: Declaration QuasiQuoters are expanded immediately, without
+--         causing a group split
+add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds
+  = do { (ds', _) <- rnTopSpliceDecls qq
+       ; addl gp (ds' ++ ds)
+       }
+
+add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
+  = do { -- We've found a top-level splice.  If it is an *implicit* one
+         -- (i.e. a naked top level expression)
+         case flag of
+           ExplicitSplice -> return ()
+           ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
+                                ; unless th_on $ setSrcSpan loc $
+                                  failWith badImplicitSplice }
+
+       ; return (gp, Just (splice, ds)) }
+  where
+    badImplicitSplice = text "Parse error: module header, import declaration"
+                     $$ text "or top-level declaration expected."
+                     -- The compiler should suggest the above, and not using
+                     -- TemplateHaskell since the former suggestion is more
+                     -- relevant to the larger base of users.
+                     -- See #12146 for discussion.
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
+  | isClassDecl d
+  = let fsigs = [ cL l f
+                | (dL->L l (FixSig _ f)) <- tcdSigs d ] in
+    addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds
+  | otherwise
+  = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
+  = addl (gp {hs_fixds = cL l f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
+  = addl (gp {hs_valds = add_sig (cL l d) ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds
+  = addl (gp { hs_valds = add_bind (cL l d) ts }) ds
+
+-- Role annotations: added to the TyClGroup
+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
+  = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds
+
+-- NB instance declarations go into TyClGroups. We throw them into the first
+-- group, just as we do for the TyClD case. The renamer will go on to group
+-- and order them later.
+add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds
+  = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds
+  = addl (gp { hs_derivds = cL l d : ts }) ds
+add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds
+  = addl (gp { hs_defds = cL l d : ts }) ds
+add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds
+  = addl (gp { hs_fords = cL l d : ts }) ds
+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds
+  = addl (gp { hs_warnds = cL l d : ts }) ds
+add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds
+  = addl (gp { hs_annds = cL l d : ts }) ds
+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds
+  = addl (gp { hs_ruleds = cL l d : ts }) ds
+add gp l (DocD _ d) ds
+  = addl (gp { hs_docs = (cL l d) : (hs_docs gp) })  ds
+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
+add (HsGroup {}) _ (XHsDecl _)                 _ = panic "RnSource.add"
+add (XHsGroup _) _ _                           _ = panic "RnSource.add"
+
+add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+          -> [TyClGroup (GhcPass p)]
+add_tycld d []       = [TyClGroup { group_ext    = noExt
+                                  , group_tyclds = [d]
+                                  , group_roles  = []
+                                  , group_instds = []
+                                  }
+                       ]
+add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
+  = ds { group_tyclds = d : tyclds } : dss
+add_tycld _ (XTyClGroup _: _) = panic "add_tycld"
+
+add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+          -> [TyClGroup (GhcPass p)]
+add_instd d []       = [TyClGroup { group_ext    = noExt
+                                  , group_tyclds = []
+                                  , group_roles  = []
+                                  , group_instds = [d]
+                                  }
+                       ]
+add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
+  = ds { group_instds = d : instds } : dss
+add_instd _ (XTyClGroup _: _) = panic "add_instd"
+
+add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+               -> [TyClGroup (GhcPass p)]
+add_role_annot d [] = [TyClGroup { group_ext    = noExt
+                                 , group_tyclds = []
+                                 , group_roles  = [d]
+                                 , group_instds = []
+                                 }
+                      ]
+add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
+  = tycls { group_roles = d : roles } : rest
+add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"
+
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
+add_bind _ (XValBindsLR {})     = panic "RdrHsSyn:add_bind"
+
+add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
+add_sig _ (XValBindsLR {})     = panic "RdrHsSyn:add_sig"
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnSplice.hs
@@ -0,0 +1,904 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnSplice (
+        rnTopSpliceDecls,
+        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
+        rnBracket,
+        checkThLocalName
+        , traceSplice, SpliceInfo(..)
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Name
+import NameSet
+import HsSyn
+import RdrName
+import TcRnMonad
+
+import RnEnv
+import RnUtils          ( HsDocContext(..), newLocalBndrRn )
+import RnUnbound        ( isUnboundName )
+import RnSource         ( rnSrcDecls, findSplice )
+import RnPat            ( rnPat )
+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )
+import Outputable
+import Module
+import SrcLoc
+import RnTypes          ( rnLHsType )
+
+import Control.Monad    ( unless, when )
+
+import {-# SOURCE #-} RnExpr   ( rnLExpr )
+
+import TcEnv            ( checkWellStaged )
+import THNames          ( liftName )
+
+import DynFlags
+import FastString
+import ErrUtils         ( dumpIfSet_dyn_printer )
+import TcEnv            ( tcMetaTy )
+import Hooks
+import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
+                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
+
+import {-# SOURCE #-} TcExpr   ( tcPolyExpr )
+import {-# SOURCE #-} TcSplice
+    ( runMetaD
+    , runMetaE
+    , runMetaP
+    , runMetaT
+    , tcTopSpliceExpr
+    )
+
+import TcHsSyn
+
+import GHCi.RemoteTypes ( ForeignRef )
+import qualified Language.Haskell.TH as TH (Q)
+
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+************************************************************************
+*                                                                      *
+        Template Haskell brackets
+*                                                                      *
+************************************************************************
+-}
+
+rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnBracket e br_body
+  = addErrCtxt (quotationCtxtDoc br_body) $
+    do { -- Check that -XTemplateHaskellQuotes is enabled and available
+         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
+       ; unless thQuotesEnabled $
+           failWith ( vcat
+                      [ text "Syntax error on" <+> ppr e
+                      , text ("Perhaps you intended to use TemplateHaskell"
+                              ++ " or TemplateHaskellQuotes") ] )
+
+         -- Check for nested brackets
+       ; cur_stage <- getStage
+       ; case cur_stage of
+           { Splice Typed   -> checkTc (isTypedBracket br_body)
+                                       illegalUntypedBracket
+           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
+                                       illegalTypedBracket
+           ; RunSplice _    ->
+               -- See Note [RunSplice ThLevel] in "TcRnTypes".
+               pprPanic "rnBracket: Renaming bracket when running a splice"
+                        (ppr e)
+           ; Comp           -> return ()
+           ; Brack {}       -> failWithTc illegalBracket
+           }
+
+         -- Brackets are desugared to code that mentions the TH package
+       ; recordThUse
+
+       ; case isTypedBracket br_body of
+            True  -> do { traceRn "Renaming typed TH bracket" empty
+                        ; (body', fvs_e) <-
+                          setStage (Brack cur_stage RnPendingTyped) $
+                                   rn_bracket cur_stage br_body
+                        ; return (HsBracket noExt body', fvs_e) }
+
+            False -> do { traceRn "Renaming untyped TH bracket" empty
+                        ; ps_var <- newMutVar []
+                        ; (body', fvs_e) <-
+                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+                                   rn_bracket cur_stage br_body
+                        ; pendings <- readMutVar ps_var
+                        ; return (HsRnBracketOut noExt body' pendings, fvs_e) }
+       }
+
+rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
+rn_bracket outer_stage br@(VarBr x flg rdr_name)
+  = do { name <- lookupOccRn rdr_name
+       ; this_mod <- getModule
+
+       ; when (flg && nameIsLocalOrFrom this_mod name) $
+             -- Type variables can be quoted in TH. See #5721.
+                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
+                    ; case mb_bind_lvl of
+                        { Nothing -> return ()      -- Can happen for data constructors,
+                                                    -- but nothing needs to be done for them
+
+                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]
+                             | isTopLevel top_lvl
+                             -> when (isExternalName name) (keepAlive name)
+                             | otherwise
+                             -> do { traceRn "rn_bracket VarBr"
+                                      (ppr name <+> ppr bind_lvl
+                                                <+> ppr outer_stage)
+                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)
+                                             (quotedNameStageErr br) }
+                        }
+                    }
+       ; return (VarBr x flg name, unitFV name) }
+
+rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
+                            ; return (ExpBr x e', fvs) }
+
+rn_bracket _ (PatBr x p)
+  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
+
+rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+                              ; return (TypBr x t', fvs) }
+
+rn_bracket _ (DecBrL x decls)
+  = do { group <- groupDecls decls
+       ; gbl_env  <- getGblEnv
+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
+                          -- The emptyDUs is so that we just collect uses for this
+                          -- group alone in the call to rnSrcDecls below
+       ; (tcg_env, group') <- setGblEnv new_gbl_env $
+                              rnSrcDecls group
+
+              -- Discard the tcg_env; it contains only extra info about fixity
+        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
+                   ppr (duUses (tcg_dus tcg_env)))
+        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
+  where
+    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
+    groupDecls decls
+      = do { (group, mb_splice) <- findSplice decls
+           ; case mb_splice of
+           { Nothing -> return group
+           ; Just (splice, rest) ->
+               do { group' <- groupDecls rest
+                  ; let group'' = appendGroups group group'
+                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
+                  }
+           }}
+
+rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
+
+rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
+                               ; return (TExpBr x e', fvs) }
+
+rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"
+
+quotationCtxtDoc :: HsBracket GhcPs -> SDoc
+quotationCtxtDoc br_body
+  = hang (text "In the Template Haskell quotation")
+         2 (ppr br_body)
+
+illegalBracket :: SDoc
+illegalBracket =
+    text "Template Haskell brackets cannot be nested" <+>
+    text "(without intervening splices)"
+
+illegalTypedBracket :: SDoc
+illegalTypedBracket =
+    text "Typed brackets may only appear in typed splices."
+
+illegalUntypedBracket :: SDoc
+illegalUntypedBracket =
+    text "Untyped brackets may only appear in untyped splices."
+
+quotedNameStageErr :: HsBracket GhcPs -> SDoc
+quotedNameStageErr br
+  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
+        , text "must be used at the same stage at which it is bound" ]
+
+
+{-
+*********************************************************
+*                                                      *
+                Splices
+*                                                      *
+*********************************************************
+
+Note [Free variables of typed splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider renaming this:
+        f = ...
+        h = ...$(thing "f")...
+
+where the splice is a *typed* splice.  The splice can expand into
+literally anything, so when we do dependency analysis we must assume
+that it might mention 'f'.  So we simply treat all locally-defined
+names as mentioned by any splice.  This is terribly brutal, but I
+don't see what else to do.  For example, it'll mean that every
+locally-defined thing will appear to be used, so no unused-binding
+warnings.  But if we miss the dependency, then we might typecheck 'h'
+before 'f', and that will crash the type checker because 'f' isn't in
+scope.
+
+Currently, I'm not treating a splice as also mentioning every import,
+which is a bit inconsistent -- but there are a lot of them.  We might
+thereby get some bogus unused-import warnings, but we won't crash the
+type checker.  Not very satisfactory really.
+
+Note [Renamer errors]
+~~~~~~~~~~~~~~~~~~~~~
+It's important to wrap renamer calls in checkNoErrs, because the
+renamer does not fail for out of scope variables etc. Instead it
+returns a bogus term/type, so that it can report more than one error.
+We don't want the type checker to see these bogus unbound variables.
+-}
+
+rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))
+                                            -- Outside brackets, run splice
+            -> (HsSplice GhcRn -> (PendingRnSplice, a))
+                                            -- Inside brackets, make it pending
+            -> HsSplice GhcPs
+            -> RnM (a, FreeVars)
+rnSpliceGen run_splice pend_splice splice
+  = addErrCtxt (spliceCtxt splice) $ do
+    { stage <- getStage
+    ; case stage of
+        Brack pop_stage RnPendingTyped
+          -> do { checkTc is_typed_splice illegalUntypedSplice
+                ; (splice', fvs) <- setStage pop_stage $
+                                    rnSplice splice
+                ; let (_pending_splice, result) = pend_splice splice'
+                ; return (result, fvs) }
+
+        Brack pop_stage (RnPendingUntyped ps_var)
+          -> do { checkTc (not is_typed_splice) illegalTypedSplice
+                ; (splice', fvs) <- setStage pop_stage $
+                                    rnSplice splice
+                ; let (pending_splice, result) = pend_splice splice'
+                ; ps <- readMutVar ps_var
+                ; writeMutVar ps_var (pending_splice : ps)
+                ; return (result, fvs) }
+
+        _ ->  do { (splice', fvs1) <- checkNoErrs $
+                                      setStage (Splice splice_type) $
+                                      rnSplice splice
+                   -- checkNoErrs: don't attempt to run the splice if
+                   -- renaming it failed; otherwise we get a cascade of
+                   -- errors from e.g. unbound variables
+                 ; (result, fvs2) <- run_splice splice'
+                 ; return (result, fvs1 `plusFV` fvs2) } }
+   where
+     is_typed_splice = isTypedSplice splice
+     splice_type = if is_typed_splice
+                   then Typed
+                   else Untyped
+
+------------------
+
+-- | Returns the result of running a splice and the modFinalizers collected
+-- during the execution.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+runRnSplice :: UntypedSpliceFlavour
+            -> (LHsExpr GhcTc -> TcRn res)
+            -> (res -> SDoc)    -- How to pretty-print res
+                                -- Usually just ppr, but not for [Decl]
+            -> HsSplice GhcRn   -- Always untyped
+            -> TcRn (res, [ForeignRef (TH.Q ())])
+runRnSplice flavour run_meta ppr_res splice
+  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
+
+       ; let the_expr = case splice' of
+                HsUntypedSplice _ _ _ e   ->  e
+                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
+                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)
+                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)
+                HsSplicedT {}             -> pprPanic "runRnSplice" (ppr splice)
+                XSplice {}                -> pprPanic "runRnSplice" (ppr splice)
+
+             -- Typecheck the expression
+       ; meta_exp_ty   <- tcMetaTy meta_ty_name
+       ; zonked_q_expr <- zonkTopLExpr =<<
+                            tcTopSpliceExpr Untyped
+                              (tcPolyExpr the_expr meta_exp_ty)
+
+             -- Run the expression
+       ; mod_finalizers_ref <- newTcRef []
+       ; result <- setStage (RunSplice mod_finalizers_ref) $
+                     run_meta zonked_q_expr
+       ; mod_finalizers <- readTcRef mod_finalizers_ref
+       ; traceSplice (SpliceInfo { spliceDescription = what
+                                 , spliceIsDecl      = is_decl
+                                 , spliceSource      = Just the_expr
+                                 , spliceGenerated   = ppr_res result })
+
+       ; return (result, mod_finalizers) }
+
+  where
+    meta_ty_name = case flavour of
+                       UntypedExpSplice  -> expQTyConName
+                       UntypedPatSplice  -> patQTyConName
+                       UntypedTypeSplice -> typeQTyConName
+                       UntypedDeclSplice -> decsQTyConName
+    what = case flavour of
+                  UntypedExpSplice  -> "expression"
+                  UntypedPatSplice  -> "pattern"
+                  UntypedTypeSplice -> "type"
+                  UntypedDeclSplice -> "declarations"
+    is_decl = case flavour of
+                 UntypedDeclSplice -> True
+                 _                 -> False
+
+------------------
+makePending :: UntypedSpliceFlavour
+            -> HsSplice GhcRn
+            -> PendingRnSplice
+makePending flavour (HsUntypedSplice _ _ n e)
+  = PendingRnSplice flavour n e
+makePending flavour (HsQuasiQuote _ n quoter q_span quote)
+  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
+makePending _ splice@(HsTypedSplice {})
+  = pprPanic "makePending" (ppr splice)
+makePending _ splice@(HsSpliced {})
+  = pprPanic "makePending" (ppr splice)
+makePending _ splice@(HsSplicedT {})
+  = pprPanic "makePending" (ppr splice)
+makePending _ splice@(XSplice {})
+  = pprPanic "makePending" (ppr splice)
+
+------------------
+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
+                 -> LHsExpr GhcRn
+-- Return the expression (quoter "...quote...")
+-- which is what we must run in a quasi-quote
+mkQuasiQuoteExpr flavour quoter q_span quote
+  = cL q_span $ HsApp noExt (cL q_span
+              $ HsApp noExt (cL q_span (HsVar noExt (cL q_span quote_selector)))
+                            quoterExpr)
+                     quoteExpr
+  where
+    quoterExpr = cL q_span $! HsVar noExt $! (cL q_span quoter)
+    quoteExpr  = cL q_span $! HsLit noExt $! HsString NoSourceText quote
+    quote_selector = case flavour of
+                       UntypedExpSplice  -> quoteExpName
+                       UntypedPatSplice  -> quotePatName
+                       UntypedTypeSplice -> quoteTypeName
+                       UntypedDeclSplice -> quoteDecName
+
+---------------------
+rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
+-- Not exported...used for all
+rnSplice (HsTypedSplice x hasParen splice_name expr)
+  = do  { checkTH expr "Template Haskell typed splice"
+        ; loc  <- getSrcSpanM
+        ; n' <- newLocalBndrRn (cL loc splice_name)
+        ; (expr', fvs) <- rnLExpr expr
+        ; return (HsTypedSplice x hasParen n' expr', fvs) }
+
+rnSplice (HsUntypedSplice x hasParen splice_name expr)
+  = do  { checkTH expr "Template Haskell untyped splice"
+        ; loc  <- getSrcSpanM
+        ; n' <- newLocalBndrRn (cL loc splice_name)
+        ; (expr', fvs) <- rnLExpr expr
+        ; return (HsUntypedSplice x hasParen n' expr', fvs) }
+
+rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
+  = do  { checkTH quoter "Template Haskell quasi-quote"
+        ; loc  <- getSrcSpanM
+        ; splice_name' <- newLocalBndrRn (cL loc splice_name)
+
+          -- Rename the quoter; akin to the HsVar case of rnExpr
+        ; quoter' <- lookupOccRn quoter
+        ; this_mod <- getModule
+        ; when (nameIsLocalOrFrom this_mod quoter') $
+          checkThLocalName quoter'
+
+        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote
+                                                             , unitFV quoter') }
+
+rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(XSplice {})   = pprPanic "rnSplice" (ppr splice)
+
+---------------------
+rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnSpliceExpr splice
+  = rnSpliceGen run_expr_splice pend_expr_splice splice
+  where
+    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
+    pend_expr_splice rn_splice
+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)
+
+    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
+    run_expr_splice rn_splice
+      | isTypedSplice rn_splice   -- Run it later, in the type checker
+      = do {  -- Ugh!  See Note [Splices] above
+             traceRn "rnSpliceExpr: typed expression splice" empty
+           ; lcl_rdr <- getLocalRdrEnv
+           ; gbl_rdr <- getGlobalRdrEnv
+           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
+                                                     , isLocalGRE gre]
+                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
+
+           ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }
+
+      | otherwise  -- Run it here, see Note [Running splices in the Renamer]
+      = do { traceRn "rnSpliceExpr: untyped expression splice" empty
+           ; (rn_expr, mod_finalizers) <-
+                runRnSplice UntypedExpSplice runMetaE ppr rn_splice
+           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( HsPar noExt $ HsSpliceE noExt
+                            . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                            . HsSplicedExpr <$>
+                            lexpr3
+                    , fvs)
+           }
+
+{- Note [Running splices in the Renamer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Splices used to be run in the typechecker, which led to (#4364). Since the
+renamer must decide which expressions depend on which others, and it cannot
+reliably do this for arbitrary splices, we used to conservatively say that
+splices depend on all other expressions in scope. Unfortunately, this led to
+the problem of cyclic type declarations seen in (#4364). Instead, by
+running splices in the renamer, we side-step the problem of determining
+dependencies: by the time the dependency analysis happens, any splices have
+already been run, and expression dependencies can be determined as usual.
+
+However, see (#9813), for an example where we would like to run splices
+*after* performing dependency analysis (that is, after renaming). It would be
+desirable to typecheck "non-splicy" expressions (those expressions that do not
+contain splices directly or via dependence on an expression that does) before
+"splicy" expressions, such that types/expressions within the same declaration
+group would be available to `reify` calls, for example consider the following:
+
+> module M where
+>   data D = C
+>   f = 1
+>   g = $(mapM reify ['f, 'D, ''C] ...)
+
+Compilation of this example fails since D/C/f are not in the type environment
+and thus cannot be reified as they have not been typechecked by the time the
+splice is renamed and thus run.
+
+These requirements are at odds: we do not want to run splices in the renamer as
+we wish to first determine dependencies and typecheck certain expressions,
+making them available to reify, but cannot accurately determine dependencies
+without running splices in the renamer!
+
+Indeed, the conclusion of (#9813) was that it is not worth the complexity
+to try and
+ a) implement and maintain the code for renaming/typechecking non-splicy
+    expressions before splicy expressions,
+ b) explain to TH users which expressions are/not available to reify at any
+    given point.
+
+-}
+
+{- Note [Delaying modFinalizers in untyped splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When splices run in the renamer, 'reify' does not have access to the local
+type environment (#11832, [1]).
+
+For instance, in
+
+> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])
+
+'reify' cannot find @x@, because the local type environment is not yet
+populated. To address this, we allow 'reify' execution to be deferred with
+'addModFinalizer'.
+
+> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)
+                    [| return () |]
+                )
+
+The finalizer is run with the local type environment when type checking is
+complete.
+
+Since the local type environment is not available in the renamer, we annotate
+the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where
+@e@ is the result of splicing and @finalizers@ are the finalizers that have been
+collected during evaluation of the splice [3]. In our example,
+
+> HsLet
+>   (x = e)
+>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]
+>                          (HsSplicedExpr $ return ())
+>   )
+
+When the typechecker finds the annotation, it inserts the finalizers in the
+global environment and exposes the current local environment to them [4, 5, 6].
+
+> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]
+
+References:
+
+[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify
+[2] 'rnSpliceExpr'
+[3] 'TcSplice.qAddModFinalizer'
+[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
+[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))
+[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))
+
+-}
+
+----------------------
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType splice
+  = rnSpliceGen run_type_splice pend_type_splice splice
+  where
+    pend_type_splice rn_splice
+       = ( makePending UntypedTypeSplice rn_splice
+         , HsSpliceTy noExt rn_splice)
+
+    run_type_splice rn_splice
+      = do { traceRn "rnSpliceType: untyped type splice" empty
+           ; (hs_ty2, mod_finalizers) <-
+                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
+           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
+                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }
+                                    -- checkNoErrs: see Note [Renamer errors]
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( HsParTy noExt $ HsSpliceTy noExt
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                              . HsSplicedTy <$>
+                              hs_ty3
+                    , fvs
+                    ) }
+              -- Wrap the result of the splice in parens so that we don't
+              -- lose the outermost location set by runQuasiQuote (#7918)
+
+{- Note [Partial Type Splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Partial Type Signatures are partially supported in TH type splices: only
+anonymous wild cards are allowed.
+
+  -- ToDo: SLPJ says: I don't understand all this
+
+Normally, named wild cards are collected before renaming a (partial) type
+signature. However, TH type splices are run during renaming, i.e. after the
+initial traversal, leading to out of scope errors for named wild cards. We
+can't just extend the initial traversal to collect the named wild cards in TH
+type splices, as we'd need to expand them, which is supposed to happen only
+once, during renaming.
+
+Similarly, the extra-constraints wild card is handled right before renaming
+too, and is therefore also not supported in a TH type splice. Another reason
+to forbid extra-constraints wild cards in TH type splices is that a single
+signature can contain many TH type splices, whereas it mustn't contain more
+than one extra-constraints wild card. Enforcing would this be hard the way
+things are currently organised.
+
+Anonymous wild cards pose no problem, because they start out without names and
+are given names during renaming. These names are collected right after
+renaming. The names generated for anonymous wild cards in TH type splices will
+thus be collected as well.
+
+For more details about renaming wild cards, see RnTypes.rnHsSigWcType
+
+Note that partial type signatures are fully supported in TH declaration
+splices, e.g.:
+
+     [d| foo :: _ => _
+         foo x y = x == y |]
+
+This is because in this case, the partial type signature can be treated as a
+whole signature, instead of as an arbitrary type.
+
+-}
+
+
+----------------------
+-- | Rename a splice pattern. See Note [rnSplicePat]
+rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
+                                       , FreeVars)
+rnSplicePat splice
+  = rnSpliceGen run_pat_splice pend_pat_splice splice
+  where
+    pend_pat_splice :: HsSplice GhcRn ->
+                       (PendingRnSplice, Either b (Pat GhcRn))
+    pend_pat_splice rn_splice
+      = (makePending UntypedPatSplice rn_splice
+        , Right (SplicePat noExt rn_splice))
+
+    run_pat_splice :: HsSplice GhcRn ->
+                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
+    run_pat_splice rn_splice
+      = do { traceRn "rnSplicePat: untyped pattern splice" empty
+           ; (pat, mod_finalizers) <-
+                runRnSplice UntypedPatSplice runMetaP ppr rn_splice
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( Left $ ParPat noExt $ ((SplicePat noExt)
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                              . HsSplicedPat)  `onHasSrcSpan`
+                              pat
+                    , emptyFVs
+                    ) }
+              -- Wrap the result of the quasi-quoter in parens so that we don't
+              -- lose the outermost location set by runQuasiQuote (#7918)
+
+----------------------
+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
+rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg)
+  = rnSpliceGen run_decl_splice pend_decl_splice splice
+  where
+    pend_decl_splice rn_splice
+       = ( makePending UntypedDeclSplice rn_splice
+         , SpliceDecl noExt (cL loc rn_splice) flg)
+
+    run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
+rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"
+
+rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
+-- Declaration splice at the very top level of the module
+rnTopSpliceDecls splice
+   = do  { (rn_splice, fvs) <- checkNoErrs $
+                               setStage (Splice Untyped) $
+                               rnSplice splice
+           -- As always, be sure to checkNoErrs above lest we end up with
+           -- holes making it to typechecking, hence #12584.
+           --
+           -- Note that we cannot call checkNoErrs for the whole duration
+           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes
+           -- the local environment to temporarily contain a new
+           -- reference to store errors, and add_mod_finalizers would
+           -- cause this reference to be stored after checkNoErrs finishes.
+           -- This is checked by test TH_finalizer.
+         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
+         ; (decls, mod_finalizers) <- checkNoErrs $
+               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
+         ; add_mod_finalizers_now mod_finalizers
+         ; return (decls,fvs) }
+   where
+     ppr_decls :: [LHsDecl GhcPs] -> SDoc
+     ppr_decls ds = vcat (map ppr ds)
+
+     -- Adds finalizers to the global environment instead of delaying them
+     -- to the type checker.
+     --
+     -- Declaration splices do not have an interesting local environment so
+     -- there is no point in delaying them.
+     --
+     -- See Note [Delaying modFinalizers in untyped splices].
+     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
+     add_mod_finalizers_now []             = return ()
+     add_mod_finalizers_now mod_finalizers = do
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       env <- getLclEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         (env, ThModFinalizers mod_finalizers) : fins
+
+
+{-
+Note [rnSplicePat]
+~~~~~~~~~~~~~~~~~~
+Renaming a pattern splice is a bit tricky, because we need the variables
+bound in the pattern to be in scope in the RHS of the pattern. This scope
+management is effectively done by using continuation-passing style in
+RnPat, through the CpsRn monad. We don't wish to be in that monad here
+(it would create import cycles and generally conflict with renaming other
+splices), so we really want to return a (Pat RdrName) -- the result of
+running the splice -- which can then be further renamed in RnPat, in
+the CpsRn monad.
+
+The problem is that if we're renaming a splice within a bracket, we
+*don't* want to run the splice now. We really do just want to rename
+it to an HsSplice Name. Of course, then we can't know what variables
+are bound within the splice. So we accept any unbound variables and
+rename them again when the bracket is spliced in.  If a variable is brought
+into scope by a pattern splice all is fine.  If it is not then an error is
+reported.
+
+In any case, when we're done in rnSplicePat, we'll either have a
+Pat RdrName (the result of running a top-level splice) or a Pat Name
+(the renamed nested splice). Thus, the awkward return type of
+rnSplicePat.
+-}
+
+spliceCtxt :: HsSplice GhcPs -> SDoc
+spliceCtxt splice
+  = hang (text "In the" <+> what) 2 (ppr splice)
+  where
+    what = case splice of
+             HsUntypedSplice {} -> text "untyped splice:"
+             HsTypedSplice   {} -> text "typed splice:"
+             HsQuasiQuote    {} -> text "quasi-quotation:"
+             HsSpliced       {} -> text "spliced expression:"
+             HsSplicedT      {} -> text "spliced expression:"
+             XSplice         {} -> text "spliced expression:"
+
+-- | The splice data to be logged
+data SpliceInfo
+  = SpliceInfo
+    { spliceDescription  :: String
+    , spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls
+                                                  --        added by addTopDecls
+    , spliceIsDecl       :: Bool    -- True <=> put the generate code in a file
+                                    --          when -dth-dec-file is on
+    , spliceGenerated    :: SDoc
+    }
+        -- Note that 'spliceSource' is *renamed* but not *typechecked*
+        -- Reason (a) less typechecking crap
+        --        (b) data constructors after type checking have been
+        --            changed to their *wrappers*, and that makes them
+        --            print always fully qualified
+
+-- | outputs splice information for 2 flags which have different output formats:
+-- `-ddump-splices` and `-dth-dec-file`
+traceSplice :: SpliceInfo -> TcM ()
+traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
+                        , spliceGenerated = gen, spliceIsDecl = is_decl })
+  = do { loc <- case mb_src of
+                   Nothing           -> getSrcSpanM
+                   Just (dL->L loc _) -> return loc
+       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
+
+       ; when is_decl $  -- Raw material for -dth-dec-file
+         do { dflags <- getDynFlags
+            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
+                                             (spliceCodeDoc loc) } }
+  where
+    -- `-ddump-splices`
+    spliceDebugDoc :: SrcSpan -> SDoc
+    spliceDebugDoc loc
+      = let code = case mb_src of
+                     Nothing -> ending
+                     Just e  -> nest 2 (ppr e) : ending
+            ending = [ text "======>", nest 2 gen ]
+        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
+               2 (sep code)
+
+    -- `-dth-dec-file`
+    spliceCodeDoc :: SrcSpan -> SDoc
+    spliceCodeDoc loc
+      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
+             , gen ]
+
+illegalTypedSplice :: SDoc
+illegalTypedSplice = text "Typed splices may not appear in untyped brackets"
+
+illegalUntypedSplice :: SDoc
+illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"
+
+checkThLocalName :: Name -> RnM ()
+checkThLocalName name
+  | isUnboundName name   -- Do not report two errors for
+  = return ()            --   $(not_in_scope args)
+
+  | otherwise
+  = do  { traceRn "checkThLocalName" (ppr name)
+        ; mb_local_use <- getStageAndBindLevel name
+        ; case mb_local_use of {
+             Nothing -> return () ;  -- Not a locally-bound thing
+             Just (top_lvl, bind_lvl, use_stage) ->
+    do  { let use_lvl = thLevel use_stage
+        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
+                                               <+> ppr use_stage
+                                               <+> ppr use_lvl)
+        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
+
+--------------------------------------
+checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
+                       -> Name -> TcM ()
+-- We are inside brackets, and (use_lvl > bind_lvl)
+-- Now we must check whether there's a cross-stage lift to do
+-- Examples   \x -> [| x |]
+--            [| map |]
+--
+-- This code is similar to checkCrossStageLifting in TcExpr, but
+-- this is only run on *untyped* brackets.
+
+checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
+  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets
+  , use_lvl > bind_lvl                               -- Cross-stage condition
+  = check_cross_stage_lifting top_lvl name ps_var
+  | otherwise
+  = return ()
+
+check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
+check_cross_stage_lifting top_lvl name ps_var
+  | isTopLevel top_lvl
+        -- Top-level identifiers in this module,
+        -- (which have External Names)
+        -- are just like the imported case:
+        -- no need for the 'lifting' treatment
+        -- E.g.  this is fine:
+        --   f x = x
+        --   g y = [| f 3 |]
+  = when (isExternalName name) (keepAlive name)
+    -- See Note [Keeping things alive for Template Haskell]
+
+  | otherwise
+  =     -- Nested identifiers, such as 'x' in
+        -- E.g. \x -> [| h x |]
+        -- We must behave as if the reference to x was
+        --      h $(lift x)
+        -- We use 'x' itself as the SplicePointName, used by
+        -- the desugarer to stitch it all back together.
+        -- If 'x' occurs many times we may get many identical
+        -- bindings of the same SplicePointName, but that doesn't
+        -- matter, although it's a mite untidy.
+    do  { traceRn "checkCrossStageLifting" (ppr name)
+
+          -- Construct the (lift x) expression
+        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)
+              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
+
+          -- Update the pending splices
+        ; ps <- readMutVar ps_var
+        ; writeMutVar ps_var (pend_splice : ps) }
+
+{-
+Note [Keeping things alive for Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f x = x+1
+  g y = [| f 3 |]
+
+Here 'f' is referred to from inside the bracket, which turns into data
+and mentions only f's *name*, not 'f' itself. So we need some other
+way to keep 'f' alive, lest it get dropped as dead code.  That's what
+keepAlive does. It puts it in the keep-alive set, which subsequently
+ensures that 'f' stays as a top level binding.
+
+This must be done by the renamer, not the type checker (as of old),
+because the type checker doesn't typecheck the body of untyped
+brackets (#8540).
+
+A thing can have a bind_lvl of outerLevel, but have an internal name:
+   foo = [d| op = 3
+             bop = op + 1 |]
+Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
+bound inside a bracket.  That is because we don't even even record
+binding levels for top-level things; the binding levels are in the
+LocalRdrEnv.
+
+So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
+cross-stage thing, but it isn't really.  And in fact we never need
+to do anything here for top-level bound things, so all is fine, if
+a bit hacky.
+
+For these chaps (which have Internal Names) we don't want to put
+them in the keep-alive set.
+
+Note [Quoting names]
+~~~~~~~~~~~~~~~~~~~~
+A quoted name 'n is a bit like a quoted expression [| n |], except that we
+have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing
+the use-level to account for the brackets, the cases are:
+
+        bind > use                      Error
+        bind = use+1                    OK
+        bind < use
+                Imported things         OK
+                Top-level things        OK
+                Non-top-level           Error
+
+where 'use' is the binding level of the 'n quote. (So inside the implied
+bracket the level would be use+1.)
+
+Examples:
+
+  f 'map        -- OK; also for top-level defns of this module
+
+  \x. f 'x      -- Not ok (bind = 1, use = 1)
+                -- (whereas \x. f [| x |] might have been ok, by
+                --                               cross-stage lifting
+
+  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
+
+  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)
+-}
diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnSplice.hs-boot
@@ -0,0 +1,14 @@
+module RnSplice where
+
+import GhcPrelude
+import HsSyn
+import TcRnMonad
+import NameSet
+
+
+rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)
+rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
+                                          , FreeVars )
+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
+
+rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnTypes.hs
@@ -0,0 +1,1779 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnSource]{Main pass of renamer}
+-}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module RnTypes (
+        -- Type related stuff
+        rnHsType, rnLHsType, rnLHsTypes, rnContext,
+        rnHsKind, rnLHsKind, rnLHsTypeArgs,
+        rnHsSigType, rnHsWcType,
+        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
+        newTyVarNameRn,
+        rnConDeclFields,
+        rnLTyVar,
+
+        -- Precence related stuff
+        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+        checkPrecMatch, checkSectionPrec,
+
+        -- Binding related stuff
+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
+        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
+        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
+        extractHsTysRdrTyVarsDups,
+        extractRdrKindSigVars, extractDataDefnKindVars,
+        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
+        nubL, elemRdr
+  ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnSplice( rnSpliceType )
+
+import DynFlags
+import HsSyn
+import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
+import RnEnv
+import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn
+                        , pprHsDocContext, bindLocalNamesFV, typeAppErr
+                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
+import RnFixity         ( lookupFieldFixityRn, lookupFixityRn
+                        , lookupTyFixityRn )
+import TcRnMonad
+import RdrName
+import PrelNames
+import TysPrim          ( funTyConName )
+import Name
+import SrcLoc
+import NameSet
+import FieldLabel
+
+import Util
+import ListSetOps       ( deleteBys )
+import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
+                          Fixity(..), FixityDirection(..), LexicalFixity(..) )
+import Outputable
+import FastString
+import Maybes
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List          ( nubBy, partition, (\\) )
+import Control.Monad      ( unless, when )
+
+#include "HsVersions.h"
+
+{-
+These type renamers are in a separate module, rather than in (say) RnSource,
+to break several loop.
+
+*********************************************************
+*                                                       *
+           HsSigWcType (i.e with wildcards)
+*                                                       *
+*********************************************************
+-}
+
+data HsSigWcTypeScoping = AlwaysBind
+                          -- ^ Always bind any free tyvars of the given type,
+                          --   regardless of whether we have a forall at the top
+                        | BindUnlessForall
+                          -- ^ Unless there's forall at the top, do the same
+                          --   thing as 'AlwaysBind'
+                        | NeverBind
+                          -- ^ Never bind any free tyvars
+
+rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+              -> RnM (LHsSigWcType GhcRn, FreeVars)
+rnHsSigWcType scoping doc sig_ty
+  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
+    return (sig_ty', emptyFVs)
+
+rnHsSigWcTypeScoped :: HsSigWcTypeScoping
+                       -- AlwaysBind: for pattern type sigs and rules we /do/ want
+                       --             to bring those type variables into scope, even
+                       --             if there's a forall at the top which usually
+                       --             stops that happening
+                       -- e.g  \ (x :: forall a. a-> b) -> e
+                       -- Here we do bring 'b' into scope
+                    -> HsDocContext -> LHsSigWcType GhcPs
+                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
+                    -> RnM (a, FreeVars)
+-- Used for
+--   - Signatures on binders in a RULE
+--   - Pattern type signatures
+-- Wildcards are allowed
+-- type signatures on binders only allowed with ScopedTypeVariables
+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
+  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
+       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
+       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
+       }
+
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
+                  -> RnM (a, FreeVars)
+-- rn_hs_sig_wc_type is used for source-language type signatures
+rn_hs_sig_wc_type scoping ctxt
+                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
+                  thing_inside
+  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
+       ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
+       ; let nwc_rdrs = nubL nwc_rdrs'
+             bind_free_tvs = case scoping of
+                               AlwaysBind       -> True
+                               BindUnlessForall -> not (isLHsForAllTy hs_ty)
+                               NeverBind        -> False
+       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
+    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
+             ib_ty'  = HsIB { hsib_ext = vars
+                            , hsib_body = hs_ty' }
+       ; (res, fvs2) <- thing_inside sig_ty'
+       ; return (res, fvs1 `plusFV` fvs2) } }
+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
+  = panic "rn_hs_sig_wc_type"
+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
+  = panic "rn_hs_sig_wc_type"
+
+rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
+rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
+  = do { free_vars <- extractFilteredRdrTyVars hs_ty
+       ; (nwc_rdrs, _) <- partition_nwcs free_vars
+       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
+       ; return (sig_ty', fvs) }
+rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
+
+rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
+         -> RnM ([Name], LHsType GhcRn, FreeVars)
+rnWcBody ctxt nwc_rdrs hs_ty
+  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
+       ; let env = RTKE { rtke_level = TypeLevel
+                        , rtke_what  = RnTypeBody
+                        , rtke_nwcs  = mkNameSet nwcs
+                        , rtke_ctxt  = ctxt }
+       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
+                          rn_lty env hs_ty
+       ; return (nwcs, hs_ty', fvs) }
+  where
+    rn_lty env (dL->L loc hs_ty)
+      = setSrcSpan loc $
+        do { (hs_ty', fvs) <- rn_ty env hs_ty
+           ; return (cL loc hs_ty', fvs) }
+
+    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
+    -- A lot of faff just to allow the extra-constraints wildcard to appear
+    rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs
+                                , hst_body = hs_body })
+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
+        do { (hs_body', fvs) <- rn_lty env hs_body
+           ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExt
+                                , hst_bndrs = tvs', hst_body = hs_body' }
+                    , fvs) }
+
+    rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt
+                        , hst_body = hs_ty })
+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
+      , (dL->L lx (HsWildCardTy _))  <- ignoreParens hs_ctxt_last
+      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
+           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1
+           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]
+           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
+           ; return (HsQualTy { hst_xqual = noExt
+                              , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }
+                    , fvs1 `plusFV` fvs2) }
+
+      | otherwise
+      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
+           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty
+           ; return (HsQualTy { hst_xqual = noExt
+                              , hst_ctxt = cL cx hs_ctxt'
+                              , hst_body = hs_ty' }
+                    , fvs1 `plusFV` fvs2) }
+
+    rn_ty env hs_ty = rnHsTyKi env hs_ty
+
+    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
+
+
+checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
+-- Rename the extra-constraint spot in a type signature
+--    (blah, _) => type
+-- Check that extra-constraints are allowed at all, and
+-- if so that it's an anonymous wildcard
+checkExtraConstraintWildCard env hs_ctxt
+  = checkWildCard env mb_bad
+  where
+    mb_bad | not (extraConstraintWildCardsAllowed env)
+           = Just base_msg
+             -- Currently, we do not allow wildcards in their full glory in
+             -- standalone deriving declarations. We only allow a single
+             -- extra-constraints wildcard à la:
+             --
+             --   deriving instance _ => Eq (Foo a)
+             --
+             -- i.e., we don't support things like
+             --
+             --   deriving instance (Eq a, _) => Eq (Foo a)
+           | DerivDeclCtx {} <- rtke_ctxt env
+           , not (null hs_ctxt)
+           = Just deriv_decl_msg
+           | otherwise
+           = Nothing
+
+    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
+                   <+> text "not allowed"
+
+    deriv_decl_msg
+      = hang base_msg
+           2 (vcat [ text "except as the sole constraint"
+                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
+
+extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
+extraConstraintWildCardsAllowed env
+  = case rtke_ctxt env of
+      TypeSigCtx {}       -> True
+      ExprWithTySigCtx {} -> True
+      DerivDeclCtx {}     -> True
+      _                   -> False
+
+-- | Finds free type and kind variables in a type,
+--     without duplicates, and
+--     without variables that are already in scope in LocalRdrEnv
+--   NB: this includes named wildcards, which look like perfectly
+--       ordinary type variables at this point
+extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
+extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty)
+
+-- | Finds free type and kind variables in a type,
+--     with duplicates, but
+--     without variables that are already in scope in LocalRdrEnv
+--   NB: this includes named wildcards, which look like perfectly
+--       ordinary type variables at this point
+extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
+extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)
+
+-- | When the NamedWildCards extension is enabled, partition_nwcs
+-- removes type variables that start with an underscore from the
+-- FreeKiTyVars in the argument and returns them in a separate list.
+-- When the extension is disabled, the function returns the argument
+-- and empty list.  See Note [Renaming named wild cards]
+partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)
+partition_nwcs free_vars
+  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards
+       ; return $
+           if wildcards_enabled
+           then partition is_wildcard free_vars
+           else ([], free_vars) }
+  where
+     is_wildcard :: Located RdrName -> Bool
+     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
+
+{- Note [Renaming named wild cards]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Identifiers starting with an underscore are always parsed as type variables.
+It is only here in the renamer that we give the special treatment.
+See Note [The wildcard story for types] in HsTypes.
+
+It's easy!  When we collect the implicitly bound type variables, ready
+to bring them into scope, and NamedWildCards is on, we partition the
+variables into the ones that start with an underscore (the named
+wildcards) and the rest. Then we just add them to the hswc_wcs field
+of the HsWildCardBndrs structure, and we are done.
+
+
+*********************************************************
+*                                                       *
+           HsSigtype (i.e. no wildcards)
+*                                                       *
+****************************************************** -}
+
+rnHsSigType :: HsDocContext -> LHsSigType GhcPs
+            -> RnM (LHsSigType GhcRn, FreeVars)
+-- Used for source-language type signatures
+-- that cannot have wildcards
+rnHsSigType ctx (HsIB { hsib_body = hs_ty })
+  = do { traceRn "rnHsSigType" (ppr hs_ty)
+       ; vars <- extractFilteredRdrTyVarsDups hs_ty
+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
+    do { (body', fvs) <- rnLHsType ctx hs_ty
+       ; return ( HsIB { hsib_ext = vars
+                       , hsib_body = body' }
+                , fvs ) } }
+rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
+
+rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
+                           -- E.g.  f :: forall a. a->b
+                           --  we do not want to bring 'b' into scope, hence False
+                           -- But   f :: a -> b
+                           --  we want to bring both 'a' and 'b' into scope
+                -> FreeKiTyVarsWithDups
+                                   -- Free vars of hs_ty (excluding wildcards)
+                                   -- May have duplicates, which is
+                                   -- checked here
+                -> ([Name] -> RnM (a, FreeVars))
+                -> RnM (a, FreeVars)
+rnImplicitBndrs bind_free_tvs
+                fvs_with_dups
+                thing_inside
+  = do { let fvs = nubL fvs_with_dups
+             real_fvs | bind_free_tvs = fvs
+                      | otherwise     = []
+
+       ; traceRn "rnImplicitBndrs" $
+         vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ]
+
+       ; loc <- getSrcSpanM
+       ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs
+
+       ; bindLocalNamesFV vars $
+         thing_inside vars }
+
+{- ******************************************************
+*                                                       *
+           LHsType and HsType
+*                                                       *
+****************************************************** -}
+
+{-
+rnHsType is here because we call it from loadInstDecl, and I didn't
+want a gratuitous knot.
+
+Note [Context quantification]
+-----------------------------
+Variables in type signatures are implicitly quantified
+when (1) they are in a type signature not beginning
+with "forall" or (2) in any qualified type T => R.
+We are phasing out (2) since it leads to inconsistencies
+(#4426):
+
+data A = A (a -> a)           is an error
+data A = A (Eq a => a -> a)   binds "a"
+data A = A (Eq a => a -> b)   binds "a" and "b"
+data A = A (() => a -> b)     binds "a" and "b"
+f :: forall a. a -> b         is an error
+f :: forall a. () => a -> b   is an error
+f :: forall a. a -> (() => b) binds "a" and "b"
+
+This situation is now considered to be an error. See rnHsTyKi for case
+HsForAllTy Qualified.
+
+Note [QualTy in kinds]
+~~~~~~~~~~~~~~~~~~~~~~
+I was wondering whether QualTy could occur only at TypeLevel.  But no,
+we can have a qualified type in a kind too. Here is an example:
+
+  type family F a where
+    F Bool = Nat
+    F Nat  = Type
+
+  type family G a where
+    G Type = Type -> Type
+    G ()   = Nat
+
+  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where
+    MkX :: X 'True '()
+
+See that k1 becomes Bool and k2 becomes (), so the equality is
+satisfied. If I write MkX :: X 'True 'False, compilation fails with a
+suitable message:
+
+  MkX :: X 'True '()
+    • Couldn't match kind ‘G Bool’ with ‘Nat’
+      Expected kind: G Bool
+        Actual kind: F Bool
+
+However: in a kind, the constraints in the QualTy must all be
+equalities; or at least, any kinds with a class constraint are
+uninhabited.
+-}
+
+data RnTyKiEnv
+  = RTKE { rtke_ctxt  :: HsDocContext
+         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?
+         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?
+         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards
+    }
+
+data RnTyKiWhat = RnTypeBody
+                | RnTopConstraint   -- Top-level context of HsSigWcTypes
+                | RnConstraint      -- All other constraints
+
+instance Outputable RnTyKiEnv where
+  ppr (RTKE { rtke_level = lev, rtke_what = what
+            , rtke_nwcs = wcs, rtke_ctxt = ctxt })
+    = text "RTKE"
+      <+> braces (sep [ ppr lev, ppr what, ppr wcs
+                      , pprHsDocContext ctxt ])
+
+instance Outputable RnTyKiWhat where
+  ppr RnTypeBody      = text "RnTypeBody"
+  ppr RnTopConstraint = text "RnTopConstraint"
+  ppr RnConstraint    = text "RnConstraint"
+
+mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
+mkTyKiEnv cxt level what
+ = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
+        , rtke_what = what, rtke_ctxt = cxt }
+
+isRnKindLevel :: RnTyKiEnv -> Bool
+isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
+isRnKindLevel _                                 = False
+
+--------------
+rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
+rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
+
+rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
+
+rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
+
+rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
+rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
+
+rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
+rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
+
+-- renaming a type only, not a kind
+rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
+                -> RnM (LHsTypeArg GhcRn, FreeVars)
+rnLHsTypeArg ctxt (HsValArg ty)
+   = do { (tys_rn, fvs) <- rnLHsType ctxt ty
+        ; return (HsValArg tys_rn, fvs) }
+rnLHsTypeArg ctxt (HsTypeArg l ki)
+   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki
+        ; return (HsTypeArg l kis_rn, fvs) }
+rnLHsTypeArg _ (HsArgPar sp)
+   = return (HsArgPar sp, emptyFVs)
+
+rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
+                 -> RnM ([LHsTypeArg GhcRn], FreeVars)
+rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args
+
+--------------
+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
+              -> RnM (LHsContext GhcRn, FreeVars)
+rnTyKiContext env (dL->L loc cxt)
+  = do { traceRn "rncontext" (ppr cxt)
+       ; let env' = env { rtke_what = RnConstraint }
+       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
+       ; return (cL loc cxt', fvs) }
+
+rnContext :: HsDocContext -> LHsContext GhcPs
+          -> RnM (LHsContext GhcRn, FreeVars)
+rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
+
+--------------
+rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
+rnLHsTyKi env (dL->L loc ty)
+  = setSrcSpan loc $
+    do { (ty', fvs) <- rnHsTyKi env ty
+       ; return (cL loc ty', fvs) }
+
+rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
+
+rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars
+                            , hst_body = tau })
+  = do { checkPolyKinds env ty
+       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
+                           Nothing tyvars $ \ tyvars' ->
+    do { (tau',  fvs) <- rnLHsTyKi env tau
+       ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExt
+                             , hst_bndrs = tyvars' , hst_body =  tau' }
+                , fvs) } }
+
+rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
+  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]
+       ; (ctxt', fvs1) <- rnTyKiContext env lctxt
+       ; (tau',  fvs2) <- rnLHsTyKi env tau
+       ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+                          , hst_body =  tau' }
+                , fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name))
+  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
+         unlessXOptM LangExt.PolyKinds $ addErr $
+         withHsDocContext (rtke_ctxt env) $
+         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
+              , text "Perhaps you intended to use PolyKinds" ]
+           -- Any type variable at the kind level is illegal without the use
+           -- of PolyKinds (see #14710)
+       ; name <- rnTyVar env rdr_name
+       ; return (HsTyVar noExt ip (cL loc name), unitFV name) }
+
+rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
+  = setSrcSpan (getLoc l_op) $
+    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op
+        ; fix   <- lookupTyFixityRn l_op'
+        ; (ty1', fvs2) <- rnLHsTyKi env ty1
+        ; (ty2', fvs3) <- rnLHsTyKi env ty2
+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
+                               (unLoc l_op') fix ty1' ty2'
+        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
+
+rnHsTyKi env (HsParTy _ ty)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsParTy noExt ty', fvs) }
+
+rnHsTyKi env (HsBangTy _ b ty)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsBangTy noExt b ty', fvs) }
+
+rnHsTyKi env ty@(HsRecTy _ flds)
+  = do { let ctxt = rtke_ctxt env
+       ; fls          <- get_fields ctxt
+       ; (flds', fvs) <- rnConDeclFields ctxt fls flds
+       ; return (HsRecTy noExt flds', fvs) }
+  where
+    get_fields (ConDeclCtx names)
+      = concatMapM (lookupConstructorFields . unLoc) names
+    get_fields _
+      = do { addErr (hang (text "Record syntax is illegal here:")
+                                   2 (ppr ty))
+           ; return [] }
+
+rnHsTyKi env (HsFunTy _ ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
+        -- Might find a for-all as the arg of a function type
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
+        -- Or as the result.  This happens when reading Prelude.hi
+        -- when we find return :: forall m. Monad m -> forall a. a -> m a
+
+        -- Check for fixity rearrangements
+       ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
+       ; return (res_ty, fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env listTy@(HsListTy _ ty)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env listTy))
+       ; (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsListTy noExt ty', fvs) }
+
+rnHsTyKi env t@(HsKindSig _ ty k)
+  = do { checkPolyKinds env t
+       ; kind_sigs_ok <- xoptM LangExt.KindSignatures
+       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
+       ; (ty', fvs1) <- rnLHsTyKi env ty
+       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
+       ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
+
+-- Unboxed tuples are allowed to have poly-typed arguments.  These
+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env tupleTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsTupleTy noExt tup_con tys', fvs) }
+
+rnHsTyKi env sumTy@(HsSumTy _ tys)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env sumTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsSumTy noExt tys', fvs) }
+
+-- Ensure that a type-level integer is nonnegative (#8306, #8412)
+rnHsTyKi env tyLit@(HsTyLit _ t)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; unless data_kinds (addErr (dataKindsErr env tyLit))
+       ; when (negLit t) (addErr negLitErr)
+       ; checkPolyKinds env tyLit
+       ; return (HsTyLit noExt t, emptyFVs) }
+  where
+    negLit (HsStrTy _ _) = False
+    negLit (HsNumTy _ i) = i < 0
+    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
+
+rnHsTyKi env (HsAppTy _ ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
+       ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env (HsAppKindTy l ty k)
+  = do { kind_app <- xoptM LangExt.TypeApplications
+       ; unless kind_app (addErr (typeAppErr "kind" k))
+       ; (ty', fvs1) <- rnLHsTyKi env ty
+       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
+       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env t@(HsIParamTy _ n ty)
+  = do { notInKinds env t
+       ; (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsIParamTy noExt n ty', fvs) }
+
+rnHsTyKi _ (HsStarTy _ isUni)
+  = return (HsStarTy noExt isUni, emptyFVs)
+
+rnHsTyKi _ (HsSpliceTy _ sp)
+  = rnSpliceType sp
+
+rnHsTyKi env (HsDocTy _ ty haddock_doc)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
+       ; haddock_doc' <- rnLHsDoc haddock_doc
+       ; return (HsDocTy noExt ty' haddock_doc', fvs) }
+
+rnHsTyKi _ (XHsType (NHsCoreTy ty))
+  = return (XHsType (NHsCoreTy ty), emptyFVs)
+    -- The emptyFVs probably isn't quite right
+    -- but I don't think it matters
+
+rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
+  = do { checkPolyKinds env ty
+       ; data_kinds <- xoptM LangExt.DataKinds
+       ; unless data_kinds (addErr (dataKindsErr env ty))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsExplicitListTy noExt ip tys', fvs) }
+
+rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
+  = do { checkPolyKinds env ty
+       ; data_kinds <- xoptM LangExt.DataKinds
+       ; unless data_kinds (addErr (dataKindsErr env ty))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsExplicitTupleTy noExt tys', fvs) }
+
+rnHsTyKi env (HsWildCardTy _)
+  = do { checkAnonWildCard env
+       ; return (HsWildCardTy noExt, emptyFVs) }
+
+--------------
+rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
+rnTyVar env rdr_name
+  = do { name <- lookupTypeOccRn rdr_name
+       ; checkNamedWildCard env name
+       ; return name }
+
+rnLTyVar :: Located RdrName -> RnM (Located Name)
+-- Called externally; does not deal with wildards
+rnLTyVar (dL->L loc rdr_name)
+  = do { tyvar <- lookupTypeOccRn rdr_name
+       ; return (cL loc tyvar) }
+
+--------------
+rnHsTyOp :: Outputable a
+         => RnTyKiEnv -> a -> Located RdrName
+         -> RnM (Located Name, FreeVars)
+rnHsTyOp env overall_ty (dL->L loc op)
+  = do { ops_ok <- xoptM LangExt.TypeOperators
+       ; op' <- rnTyVar env op
+       ; unless (ops_ok || op' `hasKey` eqTyConKey) $
+           addErr (opTyErr op overall_ty)
+       ; let l_op' = cL loc op'
+       ; return (l_op', unitFV op') }
+
+--------------
+notAllowed :: SDoc -> SDoc
+notAllowed doc
+  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
+
+checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
+checkWildCard env (Just doc)
+  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
+checkWildCard _ Nothing
+  = return ()
+
+checkAnonWildCard :: RnTyKiEnv -> RnM ()
+-- Report an error if an anonymous wildcard is illegal here
+checkAnonWildCard env
+  = checkWildCard env mb_bad
+  where
+    mb_bad :: Maybe SDoc
+    mb_bad | not (wildCardsAllowed env)
+           = Just (notAllowed pprAnonWildCard)
+           | otherwise
+           = case rtke_what env of
+               RnTypeBody      -> Nothing
+               RnConstraint    -> Just constraint_msg
+               RnTopConstraint -> Just constraint_msg
+
+    constraint_msg = hang
+                         (notAllowed pprAnonWildCard <+> text "in a constraint")
+                        2 hint_msg
+    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
+                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
+
+checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
+-- Report an error if a named wildcard is illegal here
+checkNamedWildCard env name
+  = checkWildCard env mb_bad
+  where
+    mb_bad | not (name `elemNameSet` rtke_nwcs env)
+           = Nothing  -- Not a wildcard
+           | not (wildCardsAllowed env)
+           = Just (notAllowed (ppr name))
+           | otherwise
+           = case rtke_what env of
+               RnTypeBody      -> Nothing   -- Allowed
+               RnTopConstraint -> Nothing   -- Allowed
+               RnConstraint    -> Just constraint_msg
+    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
+
+wildCardsAllowed :: RnTyKiEnv -> Bool
+-- ^ In what contexts are wildcards permitted
+wildCardsAllowed env
+   = case rtke_ctxt env of
+       TypeSigCtx {}       -> True
+       TypBrCtx {}         -> True   -- Template Haskell quoted type
+       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice
+       ExprWithTySigCtx {} -> True
+       PatCtx {}           -> True
+       RuleCtx {}          -> True
+       FamPatCtx {}        -> True   -- Not named wildcards though
+       GHCiCtx {}          -> True
+       HsTypeCtx {}        -> True
+       _                   -> False
+
+
+
+---------------
+-- | Ensures either that we're in a type or that -XPolyKinds is set
+checkPolyKinds :: Outputable ty
+                => RnTyKiEnv
+                -> ty      -- ^ type
+                -> RnM ()
+checkPolyKinds env ty
+  | isRnKindLevel env
+  = do { polykinds <- xoptM LangExt.PolyKinds
+       ; unless polykinds $
+         addErr (text "Illegal kind:" <+> ppr ty $$
+                 text "Did you mean to enable PolyKinds?") }
+checkPolyKinds _ _ = return ()
+
+notInKinds :: Outputable ty
+           => RnTyKiEnv
+           -> ty
+           -> RnM ()
+notInKinds env ty
+  | isRnKindLevel env
+  = addErr (text "Illegal kind:" <+> ppr ty)
+notInKinds _ _ = return ()
+
+{- *****************************************************
+*                                                      *
+          Binding type variables
+*                                                      *
+***************************************************** -}
+
+bindSigTyVarsFV :: [Name]
+                -> RnM (a, FreeVars)
+                -> RnM (a, FreeVars)
+-- Used just before renaming the defn of a function
+-- with a separate type signature, to bring its tyvars into scope
+-- With no -XScopedTypeVariables, this is a no-op
+bindSigTyVarsFV tvs thing_inside
+  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
+        ; if not scoped_tyvars then
+                thing_inside
+          else
+                bindLocalNamesFV tvs thing_inside }
+
+-- | Simply bring a bunch of RdrNames into scope. No checking for
+-- validity, at all. The binding location is taken from the location
+-- on each name.
+bindLRdrNames :: [Located RdrName]
+              -> ([Name] -> RnM (a, FreeVars))
+              -> RnM (a, FreeVars)
+bindLRdrNames rdrs thing_inside
+  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
+       ; bindLocalNamesFV var_names $
+         thing_inside var_names }
+
+---------------
+bindHsQTyVars :: forall a b.
+                 HsDocContext
+              -> Maybe SDoc         -- Just d => check for unused tvs
+                                    --   d is a phrase like "in the type ..."
+              -> Maybe a            -- Just _  => an associated type decl
+              -> [Located RdrName]  -- Kind variables from scope, no dups
+              -> (LHsQTyVars GhcPs)
+              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
+                  -- The Bool is True <=> all kind variables used in the
+                  -- kind signature are bound on the left.  Reason:
+                  -- the last clause of Note [CUSKs: Complete user-supplied
+                  -- kind signatures] in HsDecls
+              -> RnM (b, FreeVars)
+
+-- See Note [bindHsQTyVars examples]
+-- (a) Bring kind variables into scope
+--     both (i)  passed in body_kv_occs
+--     and  (ii) mentioned in the kinds of hsq_bndrs
+-- (b) Bring type variables into scope
+--
+bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
+  = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
+             bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
+
+       ; let -- See Note [bindHsQTyVars examples] for what
+             -- all these various things are doing
+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]
+             bndrs        = map hsLTyVarLocName hs_tv_bndrs
+             kv_occs      = nubL (bndr_kv_occs ++ body_kv_occs)
+                                 -- Make sure to list the binder kvs before the
+                                 -- body kvs, as mandated by
+                                 -- Note [Ordering of implicit variables]
+             implicit_kvs = filter_occs bndrs kv_occs
+             del          = deleteBys eqLocated
+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
+
+       ; traceRn "checkMixedVars3" $
+           vcat [ text "kv_occs" <+> ppr kv_occs
+                , text "bndrs"   <+> ppr hs_tv_bndrs
+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs
+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
+                ]
+
+       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
+
+       ; bindLocalNamesFV implicit_kv_nms                     $
+         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
+    do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
+       ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
+                              , hsq_explicit  = rn_bndrs })
+                      all_bound_on_lhs } }
+
+  where
+    filter_occs :: [Located RdrName]   -- Bound here
+                -> [Located RdrName]   -- Potential implicit binders
+                -> [Located RdrName]   -- Final implicit binders
+    -- Filter out any potential implicit binders that are either
+    -- already in scope, or are explicitly bound in the same HsQTyVars
+    filter_occs bndrs occs
+      = filterOut is_in_scope occs
+      where
+        is_in_scope locc = locc `elemRdr` bndrs
+
+{- Note [bindHsQTyVars examples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   data T k (a::k1) (b::k) :: k2 -> k1 -> *
+
+Then:
+  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
+  bndrs       = [k,a,b]
+
+  bndr_kv_occs = [k,k1], kind variables free in kind signatures
+                         of hs_tv_bndrs
+
+  body_kv_occs = [k2,k1], kind variables free in the
+                          result kind signature
+
+  implicit_kvs = [k1,k2], kind variables free in kind signatures
+                          of hs_tv_bndrs, and not bound by bndrs
+
+* We want to quantify add implicit bindings for implicit_kvs
+
+* If implicit_body_kvs is non-empty, then there is a kind variable
+  mentioned in the kind signature that is not bound "on the left".
+  That's one of the rules for a CUSK, so we pass that info on
+  as the second argument to thing_inside.
+
+* Order is not important in these lists.  All we are doing is
+  bring Names into scope.
+
+Finally, you may wonder why filter_occs removes in-scope variables
+from bndr/body_kv_occs.  How can anything be in scope?  Answer:
+HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
+ConDecls
+   data T a = forall (b::k). MkT a b
+The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
+ConDecl.  Hence the local RdrEnv may be non-empty and we must filter
+out 'a' from the free vars.  (Mind you, in this situation all the
+implicit kind variables are bound at the data type level, so there
+are none to bind in the ConDecl, so there are no implicitly bound
+variables at all.
+
+Note [Kind variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  data T (a :: k) k = ...
+we report "k is out of scope" for (a::k).  Reason: k is not brought
+into scope until the explicit k-binding that follows.  It would be
+terribly confusing to bring into scope an /implicit/ k for a's kind
+and a distinct, shadowing explicit k that follows, something like
+  data T {k1} (a :: k1) k = ...
+
+So the rule is:
+
+   the implicit binders never include any
+   of the explicit binders in the group
+
+Note that in the denerate case
+  data T (a :: a) = blah
+we get a complaint the second 'a' is not in scope.
+
+That applies to foralls too: e.g.
+   forall (a :: k) k . blah
+
+But if the foralls are split, we treat the two groups separately:
+   forall (a :: k). forall k. blah
+Here we bring into scope an implicit k, which is later shadowed
+by the explicit k.
+
+In implementation terms
+
+* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
+  the binders {a,k}, and so end with no implicit binders.  Then we
+  rename the binders left-to-right, and hence see that 'k' is out of
+  scope in the kind of 'a'.
+
+* Similarly in extract_hs_tv_bndrs
+
+Note [Variables used as both types and kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We bind the type variables tvs, and kvs is the set of free variables of the
+kinds in the scope of the binding. Here is one typical example:
+
+   forall a b. a -> (b::k) -> (c::a)
+
+Here, tvs will be {a,b}, and kvs {k,a}.
+
+We must make sure that kvs includes all of variables in the kinds of type
+variable bindings. For instance:
+
+   forall k (a :: k). Proxy a
+
+If we only look in the body of the `forall` type, we will mistakenly conclude
+that kvs is {}. But in fact, the type variable `k` is also used as a kind
+variable in (a :: k), later in the binding. (This mistake lead to #14710.)
+So tvs is {k,a} and kvs is {k}.
+
+NB: we do this only at the binding site of 'tvs'.
+-}
+
+bindLHsTyVarBndrs :: HsDocContext
+                  -> Maybe SDoc            -- Just d => check for unused tvs
+                                           --   d is a phrase like "in the type ..."
+                  -> Maybe a               -- Just _  => an associated type decl
+                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars
+                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
+                  -> RnM (b, FreeVars)
+bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
+  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
+       ; checkDupRdrNames tv_names_w_loc
+       ; go tv_bndrs thing_inside }
+  where
+    tv_names_w_loc = map hsLTyVarLocName tv_bndrs
+
+    go []     thing_inside = thing_inside []
+    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
+                             do { (res, fvs) <- go bs $ \ bs' ->
+                                                thing_inside (b' : bs')
+                                ; warn_unused b' fvs
+                                ; return (res, fvs) }
+
+    warn_unused tv_bndr fvs = case mb_in_doc of
+      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
+      Nothing     -> return ()
+
+bindLHsTyVarBndr :: HsDocContext
+                 -> Maybe a   -- associated class
+                 -> LHsTyVarBndr GhcPs
+                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
+                 -> RnM (b, FreeVars)
+bindLHsTyVarBndr _doc mb_assoc (dL->L loc
+                                 (UserTyVar x
+                                    lrdr@(dL->L lv _))) thing_inside
+  = do { nm <- newTyVarNameRn mb_assoc lrdr
+       ; bindLocalNamesFV [nm] $
+         thing_inside (cL loc (UserTyVar x (cL lv nm))) }
+
+bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind))
+                 thing_inside
+  = do { sig_ok <- xoptM LangExt.KindSignatures
+           ; unless sig_ok (badKindSigErr doc kind)
+           ; (kind', fvs1) <- rnLHsKind doc kind
+           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
+           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]
+               $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))
+           ; return (b, fvs1 `plusFV` fvs2) }
+
+bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
+bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"
+                             -- due to #15884
+
+newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
+newTyVarNameRn mb_assoc (dL->L loc rdr)
+  = do { rdr_env <- getLocalRdrEnv
+       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
+           (Just _, Just n) -> return n
+              -- Use the same Name as the parent class decl
+
+           _                -> newLocalBndrRn (cL loc rdr) }
+{-
+*********************************************************
+*                                                       *
+        ConDeclField
+*                                                       *
+*********************************************************
+
+When renaming a ConDeclField, we have to find the FieldLabel
+associated with each field.  But we already have all the FieldLabels
+available (since they were brought into scope by
+RnNames.getLocalNonValBinders), so we just take the list as an
+argument, build a map and look them up.
+-}
+
+rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
+                -> RnM ([LConDeclField GhcRn], FreeVars)
+-- Also called from RnSource
+-- No wildcards can appear in record fields
+rnConDeclFields ctxt fls fields
+   = mapFvRn (rnField fl_env env) fields
+  where
+    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody
+    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
+
+rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
+        -> RnM (LConDeclField GhcRn, FreeVars)
+rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc))
+  = do { let new_names = map (fmap lookupField) names
+       ; (new_ty, fvs) <- rnLHsTyKi env ty
+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
+       ; return (cL l (ConDeclField noExt new_names new_ty new_haddock_doc)
+                , fvs) }
+  where
+    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
+    lookupField (FieldOcc _ (dL->L lr rdr)) =
+        FieldOcc (flSelector fl) (cL lr rdr)
+      where
+        lbl = occNameFS $ rdrNameOcc rdr
+        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl
+    lookupField (XFieldOcc{}) = panic "rnField"
+rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField"
+rnField _ _ _ = panic "rnField: Impossible Match"
+                             -- due to #15884
+
+{-
+************************************************************************
+*                                                                      *
+        Fixities and precedence parsing
+*                                                                      *
+************************************************************************
+
+@mkOpAppRn@ deals with operator fixities.  The argument expressions
+are assumed to be already correctly arranged.  It needs the fixities
+recorded in the OpApp nodes, because fixity info applies to the things
+the programmer actually wrote, so you can't find it out from the Name.
+
+Furthermore, the second argument is guaranteed not to be another
+operator application.  Why? Because the parser parses all
+operator applications left-associatively, EXCEPT negation, which
+we need to handle specially.
+Infix types are read in a *right-associative* way, so that
+        a `op` b `op` c
+is always read in as
+        a `op` (b `op` c)
+
+mkHsOpTyRn rearranges where necessary.  The two arguments
+have already been renamed and rearranged.  It's made rather tiresome
+by the presence of ->, which is a separate syntactic construct.
+-}
+
+---------------
+-- Building (ty1 `op1` (ty21 `op2` ty22))
+mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
+           -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
+           -> RnM (HsType GhcRn)
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExt ty21 op2 ty22))
+  = do  { fix2 <- lookupTyFixityRn op2
+        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
+                      (\t1 t2 -> HsOpTy noExt t1 op2 t2)
+                      (unLoc op2) fix2 ty21 ty22 loc2 }
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))
+  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
+                (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2
+
+mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
+  = return (mk1 ty1 ty2)
+
+---------------
+mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
+            -> Name -> Fixity -> LHsType GhcRn
+            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
+            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
+            -> RnM (HsType GhcRn)
+mk_hs_op_ty mk1 op1 fix1 ty1
+            mk2 op2 fix2 ty21 ty22 loc2
+  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)
+                         ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) }
+  | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22)))
+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
+                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
+                         ; return (mk2 (noLoc new_ty) ty22) }
+  where
+    (nofix_error, associate_right) = compareFixity fix1 fix2
+
+
+---------------------------
+mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged
+          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity
+          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might
+                                       -- be a NegApp)
+          -> RnM (HsExpr GhcRn)
+
+-- (e11 `op1` e12) `op2` e2
+mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
+  | nofix_error
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (OpApp fix2 e1 op2 e2)
+
+  | associate_right = do
+    new_e <- mkOpAppRn e12 op2 fix2 e2
+    return (OpApp fix1 e11 op1 (cL loc' new_e))
+  where
+    loc'= combineLocs e12 e2
+    (nofix_error, associate_right) = compareFixity fix1 fix2
+
+---------------------------
+--      (- neg_arg) `op` e2
+mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
+  | nofix_error
+  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
+       return (OpApp fix2 e1 op2 e2)
+
+  | associate_right
+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
+       return (NegApp noExt (cL loc' new_e) neg_name)
+  where
+    loc' = combineLocs neg_arg e2
+    (nofix_error, associate_right) = compareFixity negateFixity fix2
+
+---------------------------
+--      e1 `op` - neg_arg
+mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right
+  | not associate_right                        -- We *want* right association
+  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
+       return (OpApp fix1 e1 op1 e2)
+  where
+    (_, associate_right) = compareFixity fix1 negateFixity
+
+---------------------------
+--      Default case
+mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
+  = ASSERT2( right_op_ok fix (unLoc e2),
+             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
+    )
+    return (OpApp fix e1 op e2)
+
+----------------------------
+
+-- | Name of an operator in an operator application or section
+data OpName = NormalOp Name         -- ^ A normal identifier
+            | NegateOp              -- ^ Prefix negation
+            | UnboundOp UnboundVar  -- ^ An unbound indentifier
+            | RecFldOp (AmbiguousFieldOcc GhcRn)
+              -- ^ A (possibly ambiguous) record field occurrence
+
+instance Outputable OpName where
+  ppr (NormalOp n)   = ppr n
+  ppr NegateOp       = ppr negateName
+  ppr (UnboundOp uv) = ppr uv
+  ppr (RecFldOp fld) = ppr fld
+
+get_op :: LHsExpr GhcRn -> OpName
+-- An unbound name could be either HsVar or HsUnboundVar
+-- See RnExpr.rnUnboundVar
+get_op (dL->L _ (HsVar _ n))         = NormalOp (unLoc n)
+get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv
+get_op (dL->L _ (HsRecFld _ fld))    = RecFldOp fld
+get_op other                         = pprPanic "get_op" (ppr other)
+
+-- Parser left-associates everything, but
+-- derived instances may have correctly-associated things to
+-- in the right operand.  So we just check that the right operand is OK
+right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
+right_op_ok fix1 (OpApp fix2 _ _ _)
+  = not error_please && associate_right
+  where
+    (error_please, associate_right) = compareFixity fix1 fix2
+right_op_ok _ _
+  = True
+
+-- Parser initially makes negation bind more tightly than any other operator
+-- And "deriving" code should respect this (use HsPar if not)
+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
+           -> RnM (HsExpr (GhcPass id))
+mkNegAppRn neg_arg neg_name
+  = ASSERT( not_op_app (unLoc neg_arg) )
+    return (NegApp noExt neg_arg neg_name)
+
+not_op_app :: HsExpr id -> Bool
+not_op_app (OpApp {}) = False
+not_op_app _          = True
+
+---------------------------
+mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
+          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity
+          -> LHsCmdTop GhcRn             -- Right operand (not an infix)
+          -> RnM (HsCmd GhcRn)
+
+-- (e11 `op1` e12) `op2` e2
+mkOpFormRn a1@(dL->L loc
+                    (HsCmdTop _
+                     (dL->L _ (HsCmdArrForm x op1 f (Just fix1)
+                        [a11,a12]))))
+        op2 fix2 a2
+  | nofix_error
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
+
+  | associate_right
+  = do new_c <- mkOpFormRn a12 op2 fix2 a2
+       return (HsCmdArrForm noExt op1 f (Just fix1)
+               [a11, cL loc (HsCmdTop [] (cL loc new_c))])
+        -- TODO: locs are wrong
+  where
+    (nofix_error, associate_right) = compareFixity fix1 fix2
+
+--      Default case
+mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
+  = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
+
+
+--------------------------------------
+mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
+             -> RnM (Pat GhcRn)
+
+mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2
+  = do  { fix1 <- lookupFixityRn (unLoc op1)
+        ; let (nofix_error, associate_right) = compareFixity fix1 fix2
+
+        ; if nofix_error then do
+                { precParseErr (NormalOp (unLoc op1),fix1)
+                               (NormalOp (unLoc op2),fix2)
+                ; return (ConPatIn op2 (InfixCon p1 p2)) }
+
+          else if associate_right then do
+                { new_p <- mkConOpPatRn op2 fix2 p12 p2
+                ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }
+                -- XXX loc right?
+          else return (ConPatIn op2 (InfixCon p1 p2)) }
+
+mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
+  = ASSERT( not_op_pat (unLoc p2) )
+    return (ConPatIn op (InfixCon p1 p2))
+
+not_op_pat :: Pat GhcRn -> Bool
+not_op_pat (ConPatIn _ (InfixCon _ _)) = False
+not_op_pat _                           = True
+
+--------------------------------------
+checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
+  -- Check precedence of a function binding written infix
+  --   eg  a `op` b `C` c = ...
+  -- See comments with rnExpr (OpApp ...) about "deriving"
+
+checkPrecMatch op (MG { mg_alts = (dL->L _ ms) })
+  = mapM_ check ms
+  where
+    check (dL->L _ (Match { m_pats = (dL->L l1 p1)
+                                   : (dL->L l2 p2)
+                                   : _ }))
+      = setSrcSpan (combineSrcSpans l1 l2) $
+        do checkPrec op p1 False
+           checkPrec op p2 True
+
+    check _ = return ()
+        -- This can happen.  Consider
+        --      a `op` True = ...
+        --      op          = ...
+        -- The infix flag comes from the first binding of the group
+        -- but the second eqn has no args (an error, but not discovered
+        -- until the type checker).  So we don't want to crash on the
+        -- second eqn.
+checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
+
+checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
+checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
+    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op
+    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
+    let
+        inf_ok = op1_prec > op_prec ||
+                 (op1_prec == op_prec &&
+                  (op1_dir == InfixR && op_dir == InfixR && right ||
+                   op1_dir == InfixL && op_dir == InfixL && not right))
+
+        info  = (NormalOp op,          op_fix)
+        info1 = (NormalOp (unLoc op1), op1_fix)
+        (infol, infor) = if right then (info, info1) else (info1, info)
+    unless inf_ok (precParseErr infol infor)
+
+checkPrec _ _ _
+  = return ()
+
+-- Check precedence of (arg op) or (op arg) respectively
+-- If arg is itself an operator application, then either
+--   (a) its precedence must be higher than that of op
+--   (b) its precedency & associativity must be the same as that of op
+checkSectionPrec :: FixityDirection -> HsExpr GhcPs
+        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
+checkSectionPrec direction section op arg
+  = case unLoc arg of
+        OpApp fix _ op' _ -> go_for_it (get_op op') fix
+        NegApp _ _ _      -> go_for_it NegateOp     negateFixity
+        _                 -> return ()
+  where
+    op_name = get_op op
+    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
+          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
+          unless (op_prec < arg_prec
+                  || (op_prec == arg_prec && direction == assoc))
+                 (sectionPrecErr (get_op op, op_fix)
+                                 (arg_op, arg_fix) section)
+
+-- | Look up the fixity for an operator name.  Be careful to use
+-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields
+-- (see #13132).
+lookupFixityOp :: OpName -> RnM Fixity
+lookupFixityOp (NormalOp n)  = lookupFixityRn n
+lookupFixityOp NegateOp      = lookupFixityRn negateName
+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))
+lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f
+
+
+-- Precedence-related error messages
+
+precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
+precParseErr op1@(n1,_) op2@(n2,_)
+  | is_unbound n1 || is_unbound n2
+  = return ()     -- Avoid error cascade
+  | otherwise
+  = addErr $ hang (text "Precedence parsing error")
+      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
+               ppr_opfix op2,
+               text "in the same infix expression"])
+
+sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
+sectionPrecErr op@(n1,_) arg_op@(n2,_) section
+  | is_unbound n1 || is_unbound n2
+  = return ()     -- Avoid error cascade
+  | otherwise
+  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
+         nest 4 (sep [text "must have lower precedence than that of the operand,",
+                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),
+         nest 4 (text "in the section:" <+> quotes (ppr section))]
+
+is_unbound :: OpName -> Bool
+is_unbound (NormalOp n) = isUnboundName n
+is_unbound UnboundOp{}  = True
+is_unbound _            = False
+
+ppr_opfix :: (OpName, Fixity) -> SDoc
+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
+   where
+     pp_op | NegateOp <- op = text "prefix `-'"
+           | otherwise      = quotes (ppr op)
+
+
+{- *****************************************************
+*                                                      *
+                 Errors
+*                                                      *
+***************************************************** -}
+
+unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
+unexpectedTypeSigErr ty
+  = hang (text "Illegal type signature:" <+> quotes (ppr ty))
+       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
+
+badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
+badKindSigErr doc (dL->L loc ty)
+  = setSrcSpan loc $ addErr $
+    withHsDocContext doc $
+    hang (text "Illegal kind signature:" <+> quotes (ppr ty))
+       2 (text "Perhaps you intended to use KindSignatures")
+
+dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
+dataKindsErr env thing
+  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
+       2 (text "Perhaps you intended to use DataKinds")
+  where
+    pp_what | isRnKindLevel env = text "kind"
+            | otherwise          = text "type"
+
+inTypeDoc :: HsType GhcPs -> SDoc
+inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
+
+warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
+warnUnusedForAll in_doc (dL->L loc tv) used_names
+  = whenWOptM Opt_WarnUnusedForalls $
+    unless (hsTyVarName tv `elemNameSet` used_names) $
+    addWarnAt (Reason Opt_WarnUnusedForalls) loc $
+    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
+         , in_doc ]
+
+opTyErr :: Outputable a => RdrName -> a -> SDoc
+opTyErr op overall_ty
+  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
+         2 (text "Use TypeOperators to allow operators in types")
+
+{-
+************************************************************************
+*                                                                      *
+      Finding the free type variables of a (HsType RdrName)
+*                                                                      *
+************************************************************************
+
+
+Note [Kind and type-variable binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a type signature we may implicitly bind type/kind variables. For example:
+  *   f :: a -> a
+      f = ...
+    Here we need to find the free type variables of (a -> a),
+    so that we know what to quantify
+
+  *   class C (a :: k) where ...
+    This binds 'k' in ..., as well as 'a'
+
+  *   f (x :: a -> [a]) = ....
+    Here we bind 'a' in ....
+
+  *   f (x :: T a -> T (b :: k)) = ...
+    Here we bind both 'a' and the kind variable 'k'
+
+  *   type instance F (T (a :: Maybe k)) = ...a...k...
+    Here we want to constrain the kind of 'a', and bind 'k'.
+
+To do that, we need to walk over a type and find its free type/kind variables.
+We preserve the left-to-right order of each variable occurrence.
+See Note [Ordering of implicit variables].
+
+Clients of this code can remove duplicates with nubL.
+
+Note [Ordering of implicit variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the advent of -XTypeApplications, GHC makes promises about the ordering
+of implicit variable quantification. Specifically, we offer that implicitly
+quantified variables (such as those in const :: a -> b -> a, without a `forall`)
+will occur in left-to-right order of first occurrence. Here are a few examples:
+
+  const :: a -> b -> a       -- forall a b. ...
+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included
+
+  type a <-< b = b -> a
+  g :: a <-< b               -- forall a b. ...  type synonyms matter
+
+  class Functor f where
+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...
+    -- The f is quantified by the class, so only a and b are considered in fmap
+
+This simple story is complicated by the possibility of dependency: all variables
+must come after any variables mentioned in their kinds.
+
+  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...
+
+The k comes first because a depends on k, even though the k appears later than
+the a in the code. Thus, GHC does ScopedSort on the variables.
+See Note [ScopedSort] in Type.
+
+Implicitly bound variables are collected by any function which returns a
+FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
+includes the `extract-` family of functions (extractHsTysRdrTyVarsDups,
+extractHsTyVarBndrsKVs, etc.).
+These functions thus promise to keep left-to-right ordering.
+
+Note [Implicit quantification in type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We typically bind type/kind variables implicitly when they are in a kind
+annotation on the LHS, for example:
+
+  data Proxy (a :: k) = Proxy
+  type KindOf (a :: k) = k
+
+Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and
+we want to implicitly quantify over it.  This is easy: just extract all free
+variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs
+
+By contrast, on the RHS we can't simply collect *all* free variables. Which of
+the following are allowed?
+
+  type TySyn1 = a :: Type
+  type TySyn2 = 'Nothing :: Maybe a
+  type TySyn3 = 'Just ('Nothing :: Maybe a)
+  type TySyn4 = 'Left a :: Either Type a
+
+After some design deliberations (see non-taken alternatives below), the answer
+is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.
+We implicitly quantify over free variables of the outermost kind signature, if
+one exists:
+
+  * In TySyn1, the outermost kind signature is (:: Type), and it does not have
+    any free variables.
+  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a
+    free variable 'a', which we implicitly quantify over.
+  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature
+    is hidden inside 'Just.
+  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains
+    a free variable 'a', which we implicitly quantify over. That is why we can
+    also use it to the left of the double colon: 'Left a
+
+The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type
+synonyms and type family instances.
+
+This is something of a stopgap solution until we can explicitly bind invisible
+type/kind variables:
+
+  type TySyn3 :: forall a. Maybe a
+  type TySyn3 @a = 'Just ('Nothing :: Maybe a)
+
+Note [Implicit quantification in type synonyms: non-taken alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Alternative I: No quantification
+--------------------------------
+We could offer no implicit quantification on the RHS, accepting none of the
+TySyn<N> examples. The user would have to bind the variables explicitly:
+
+  type TySyn1 a = a :: Type
+  type TySyn2 a = 'Nothing :: Maybe a
+  type TySyn3 a = 'Just ('Nothing :: Maybe a)
+  type TySyn4 a = 'Left a :: Either Type a
+
+However, this would mean that one would have to specify 'a' at call sites every
+time, which could be undesired.
+
+Alternative II: Indiscriminate quantification
+---------------------------------------------
+We could implicitly quantify over all free variables on the RHS just like we do
+on the LHS. Then we would infer the following kinds:
+
+  TySyn1 :: forall {a}. Type
+  TySyn2 :: forall {a}. Maybe a
+  TySyn3 :: forall {a}. Maybe (Maybe a)
+  TySyn4 :: forall {a}. Either Type a
+
+This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable
+is free-floating, not fixed by anything.
+
+Alternative III: reportFloatingKvs
+----------------------------------
+We could augment Alternative II by hunting down free-floating variables during
+type checking. While viable, this would mean we'd end up accepting this:
+
+  data Prox k (a :: k)
+  type T = Prox k
+
+-}
+
+-- See Note [Kind and type-variable binders]
+-- These lists are guaranteed to preserve left-to-right ordering of
+-- the types the variables were extracted from. See also
+-- Note [Ordering of implicit variables].
+type FreeKiTyVars = [Located RdrName]
+
+-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
+type FreeKiTyVarsWithDups = FreeKiTyVars
+
+-- | A 'FreeKiTyVars' list that contains no duplicate variables.
+type FreeKiTyVarsNoDups   = FreeKiTyVars
+
+filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
+filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)
+
+filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
+filterInScopeM vars
+  = do { rdr_env <- getLocalRdrEnv
+       ; return (filterInScope rdr_env vars) }
+
+inScope :: LocalRdrEnv -> RdrName -> Bool
+inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
+
+extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyarg (HsValArg ty) acc = extract_lty ty acc
+extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
+extract_tyarg (HsArgPar _) acc = acc
+
+extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyargs args acc = foldr extract_tyarg acc args
+
+extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
+extractHsTyArgRdrKiTyVarsDup args
+  = extract_tyargs args []
+
+-- | 'extractHsTyRdrTyVars' finds the type/kind variables
+--                          of a HsType/HsKind.
+-- It's used when making the @forall@s explicit.
+-- When the same name occurs multiple times in the types, only the first
+-- occurrence is returned.
+-- See Note [Kind and type-variable binders]
+extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
+extractHsTyRdrTyVars ty
+  = nubL (extractHsTyRdrTyVarsDups ty)
+
+-- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables
+--                              of a HsType/HsKind.
+-- It's used when making the @forall@s explicit.
+-- When the same name occurs multiple times in the types, all occurrences
+-- are returned.
+extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
+extractHsTyRdrTyVarsDups ty
+  = extract_lty ty []
+
+-- | Extracts the free type/kind variables from the kind signature of a HsType.
+--   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.
+-- When the same name occurs multiple times in the type, only the first
+-- occurrence is returned, and the left-to-right order of variables is
+-- preserved.
+-- See Note [Kind and type-variable binders] and
+--     Note [Ordering of implicit variables] and
+--     Note [Implicit quantification in type synonyms].
+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
+extractHsTyRdrTyVarsKindVars (unLoc -> ty) =
+  case ty of
+    HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty
+    HsKindSig _ _ ki -> extractHsTyRdrTyVars ki
+    _ -> []
+
+-- | Extracts free type and kind variables from types in a list.
+-- When the same name occurs multiple times in the types, all occurrences
+-- are returned.
+extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
+extractHsTysRdrTyVarsDups tys
+  = extract_ltys tys []
+
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+--     However duplicates are removed
+--     E.g. given  [k1, a:k1, b:k2]
+--          the function returns [k1,k2], even though k1 is bound here
+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups
+extractHsTyVarBndrsKVs tv_bndrs
+  = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)
+
+-- Returns the free kind variables in a type family result signature, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
+extractRdrKindSigVars (dL->L _ resultSig)
+  | KindSig _ k                              <- resultSig = extractHsTyRdrTyVars k
+  | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k
+  | otherwise =  []
+
+-- Get type/kind variables mentioned in the kind signature, preserving
+-- left-to-right order and without duplicates:
+--
+--  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]
+--  * data T a (b :: k1)                             -- result: []
+--
+-- See Note [Ordering of implicit variables].
+extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVarsNoDups
+extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
+  = maybe [] extractHsTyRdrTyVars ksig
+extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
+
+extract_lctxt :: LHsContext GhcPs
+              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_lctxt ctxt = extract_ltys (unLoc ctxt)
+
+extract_ltys :: [LHsType GhcPs]
+             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_ltys tys acc = foldr extract_lty acc tys
+
+extract_lty :: LHsType GhcPs
+            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_lty (dL->L _ ty) acc
+  = case ty of
+      HsTyVar _ _  ltv            -> extract_tv ltv acc
+      HsBangTy _ _ ty             -> extract_lty ty acc
+      HsRecTy _ flds              -> foldr (extract_lty
+                                            . cd_fld_type . unLoc) acc
+                                           flds
+      HsAppTy _ ty1 ty2           -> extract_lty ty1 $
+                                     extract_lty ty2 acc
+      HsAppKindTy _ ty k          -> extract_lty ty $
+                                     extract_lty k acc
+      HsListTy _ ty               -> extract_lty ty acc
+      HsTupleTy _ _ tys           -> extract_ltys tys acc
+      HsSumTy _ tys               -> extract_ltys tys acc
+      HsFunTy _ ty1 ty2           -> extract_lty ty1 $
+                                     extract_lty ty2 acc
+      HsIParamTy _ _ ty           -> extract_lty ty acc
+      HsOpTy _ ty1 tv ty2         -> extract_tv tv $
+                                     extract_lty ty1 $
+                                     extract_lty ty2 acc
+      HsParTy _ ty                -> extract_lty ty acc
+      HsSpliceTy {}               -> acc  -- Type splices mention no tvs
+      HsDocTy _ ty _              -> extract_lty ty acc
+      HsExplicitListTy _ _ tys    -> extract_ltys tys acc
+      HsExplicitTupleTy _ tys     -> extract_ltys tys acc
+      HsTyLit _ _                 -> acc
+      HsStarTy _ _                -> acc
+      HsKindSig _ ty ki           -> extract_lty ty $
+                                     extract_lty ki acc
+      HsForAllTy { hst_bndrs = tvs, hst_body = ty }
+                                  -> extract_hs_tv_bndrs tvs acc $
+                                     extract_lty ty []
+      HsQualTy { hst_ctxt = ctxt, hst_body = ty }
+                                  -> extract_lctxt ctxt $
+                                     extract_lty ty acc
+      XHsType {}                  -> acc
+      -- We deal with these separately in rnLHsTypeWithWildCards
+      HsWildCardTy {}             -> acc
+
+extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+                 -> FreeKiTyVarsWithDups           -- Free in body
+                 -> FreeKiTyVarsWithDups       -- Free in result
+extractHsTvBndrs tv_bndrs body_fvs
+  = extract_hs_tv_bndrs tv_bndrs [] body_fvs
+
+extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
+                    -> FreeKiTyVarsWithDups  -- Accumulator
+                    -> FreeKiTyVarsWithDups  -- Free in body
+                    -> FreeKiTyVarsWithDups
+-- In (forall (a :: Maybe e). a -> b) we have
+--     'a' is bound by the forall
+--     'b' is a free type variable
+--     'e' is a free kind variable
+extract_hs_tv_bndrs tv_bndrs acc_vars body_vars
+  | null tv_bndrs = body_vars ++ acc_vars
+  | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars
+    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.
+    -- See Note [Kind variable scoping]
+  where
+    bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
+    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
+
+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+--     Duplicates are /not/ removed
+--     E.g. given  [k1, a:k1, b:k2]
+--          the function returns [k1,k2], even though k1 is bound here
+extract_hs_tv_bndrs_kvs tv_bndrs =
+    foldr extract_lty []
+          [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs]
+
+extract_tv :: Located RdrName
+           -> [Located RdrName] -> [Located RdrName]
+extract_tv tv acc =
+  if isRdrTyVar (unLoc tv) then tv:acc else acc
+
+-- Deletes duplicates in a list of Located things.
+--
+-- Importantly, this function is stable with respect to the original ordering
+-- of things in the list. This is important, as it is a property that GHC
+-- relies on to maintain the left-to-right ordering of implicitly quantified
+-- type variables.
+-- See Note [Ordering of implicit variables].
+nubL :: Eq a => [Located a] -> [Located a]
+nubL = nubBy eqLocated
+
+elemRdr :: Located RdrName -> [Located RdrName] -> Bool
+elemRdr x = any (eqLocated x)
diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnUnbound.hs
@@ -0,0 +1,381 @@
+{-
+
+This module contains helper functions for reporting and creating
+unbound variables.
+
+-}
+module RnUnbound ( mkUnboundName
+                 , mkUnboundNameRdr
+                 , isUnboundName
+                 , reportUnboundName
+                 , unknownNameSuggestions
+                 , WhereLooking(..)
+                 , unboundName
+                 , unboundNameX
+                 , notInScopeErr ) where
+
+import GhcPrelude
+
+import RdrName
+import HscTypes
+import TcRnMonad
+import Name
+import Module
+import SrcLoc
+import Outputable
+import PrelNames ( mkUnboundName, isUnboundName, getUnique)
+import Util
+import Maybes
+import DynFlags
+import FastString
+import Data.List
+import Data.Function ( on )
+import UniqDFM (udfmToList)
+
+{-
+************************************************************************
+*                                                                      *
+               What to do when a lookup fails
+*                                                                      *
+************************************************************************
+-}
+
+data WhereLooking = WL_Any        -- Any binding
+                  | WL_Global     -- Any top-level binding (local or imported)
+                  | WL_LocalTop   -- Any top-level binding in this module
+                  | WL_LocalOnly
+                        -- Only local bindings
+                        -- (pattern synonyms declaractions,
+                        -- see Note [Renaming pattern synonym variables])
+
+mkUnboundNameRdr :: RdrName -> Name
+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
+
+reportUnboundName :: RdrName -> RnM Name
+reportUnboundName rdr = unboundName WL_Any rdr
+
+unboundName :: WhereLooking -> RdrName -> RnM Name
+unboundName wl rdr = unboundNameX wl rdr Outputable.empty
+
+unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
+unboundNameX where_look rdr_name extra
+  = do  { dflags <- getDynFlags
+        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
+              err = notInScopeErr rdr_name $$ extra
+        ; if not show_helpful_errors
+          then addErr err
+          else do { local_env  <- getLocalRdrEnv
+                  ; global_env <- getGlobalRdrEnv
+                  ; impInfo <- getImports
+                  ; currmod <- getModule
+                  ; hpt <- getHpt
+                  ; let suggestions = unknownNameSuggestions_ where_look
+                          dflags hpt currmod global_env local_env impInfo
+                          rdr_name
+                  ; addErr (err $$ suggestions) }
+        ; return (mkUnboundNameRdr rdr_name) }
+
+notInScopeErr :: RdrName -> SDoc
+notInScopeErr rdr_name
+  = hang (text "Not in scope:")
+       2 (what <+> quotes (ppr rdr_name))
+  where
+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+
+type HowInScope = Either SrcSpan ImpDeclSpec
+     -- Left loc    =>  locally bound at loc
+     -- Right ispec =>  imported as specified by ispec
+
+
+-- | Called from the typechecker (TcErrors) when we find an unbound variable
+unknownNameSuggestions :: DynFlags
+                       -> HomePackageTable -> Module
+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
+                       -> RdrName -> SDoc
+unknownNameSuggestions = unknownNameSuggestions_ WL_Any
+
+unknownNameSuggestions_ :: WhereLooking -> DynFlags
+                       -> HomePackageTable -> Module
+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
+                       -> RdrName -> SDoc
+unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env
+                          imports tried_rdr_name =
+    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
+    importSuggestions where_look global_env hpt
+                      curr_mod imports tried_rdr_name $$
+    extensionSuggestions tried_rdr_name
+
+
+similarNameSuggestions :: WhereLooking -> DynFlags
+                        -> GlobalRdrEnv -> LocalRdrEnv
+                        -> RdrName -> SDoc
+similarNameSuggestions where_look dflags global_env
+                        local_env tried_rdr_name
+  = case suggest of
+      []  -> Outputable.empty
+      [p] -> perhaps <+> pp_item p
+      ps  -> sep [ perhaps <+> text "one of these:"
+                 , nest 2 (pprWithCommas pp_item ps) ]
+  where
+    all_possibilities :: [(String, (RdrName, HowInScope))]
+    all_possibilities
+       =  [ (showPpr dflags r, (r, Left loc))
+          | (r,loc) <- local_possibilities local_env ]
+       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
+
+    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
+    perhaps = text "Perhaps you meant"
+
+    pp_item :: (RdrName, HowInScope) -> SDoc
+    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined
+        where loc' = case loc of
+                     UnhelpfulSpan l -> parens (ppr l)
+                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))
+    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported
+                              parens (text "imported from" <+> ppr (is_mod is))
+
+    pp_ns :: RdrName -> SDoc
+    pp_ns rdr | ns /= tried_ns = pprNameSpace ns
+              | otherwise      = Outputable.empty
+      where ns = rdrNameSpace rdr
+
+    tried_occ     = rdrNameOcc tried_rdr_name
+    tried_is_sym  = isSymOcc tried_occ
+    tried_ns      = occNameSpace tried_occ
+    tried_is_qual = isQual tried_rdr_name
+
+    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns
+                           && isSymOcc occ == tried_is_sym
+        -- Treat operator and non-operators as non-matching
+        -- This heuristic avoids things like
+        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)
+
+    local_ok = case where_look of { WL_Any -> True
+                                  ; WL_LocalOnly -> True
+                                  ; _ -> False }
+    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
+    local_possibilities env
+      | tried_is_qual = []
+      | not local_ok  = []
+      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)
+                        | name <- localRdrEnvElts env
+                        , let occ = nameOccName name
+                        , correct_name_space occ]
+
+    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
+    global_possibilities global_env
+      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))
+                        | gre <- globalRdrEnvElts global_env
+                        , isGreOk where_look gre
+                        , let name = gre_name gre
+                              occ  = nameOccName name
+                        , correct_name_space occ
+                        , (mod, how) <- qualsInScope gre
+                        , let rdr_qual = mkRdrQual mod occ ]
+
+      | otherwise = [ (rdr_unqual, pair)
+                    | gre <- globalRdrEnvElts global_env
+                    , isGreOk where_look gre
+                    , let name = gre_name gre
+                          occ  = nameOccName name
+                          rdr_unqual = mkRdrUnqual occ
+                    , correct_name_space occ
+                    , pair <- case (unquals_in_scope gre, quals_only gre) of
+                                (how:_, _)    -> [ (rdr_unqual, how) ]
+                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]
+                                ([],    [])   -> [] ]
+
+              -- Note [Only-quals]
+              -- The second alternative returns those names with the same
+              -- OccName as the one we tried, but live in *qualified* imports
+              -- e.g. if you have:
+              --
+              -- > import qualified Data.Map as Map
+              -- > foo :: Map
+              --
+              -- then we suggest @Map.Map@.
+
+    --------------------
+    unquals_in_scope :: GlobalRdrElt -> [HowInScope]
+    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
+      | lcl       = [ Left (nameSrcSpan n) ]
+      | otherwise = [ Right ispec
+                    | i <- is, let ispec = is_decl i
+                    , not (is_qual ispec) ]
+
+
+    --------------------
+    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]
+    -- Ones for which *only* the qualified version is in scope
+    quals_only (GRE { gre_name = n, gre_imp = is })
+      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)
+        | i <- is, let ispec = is_decl i, is_qual ispec ]
+
+-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.
+importSuggestions :: WhereLooking
+                  -> GlobalRdrEnv
+                  -> HomePackageTable -> Module
+                  -> ImportAvails -> RdrName -> SDoc
+importSuggestions where_look global_env hpt currMod imports rdr_name
+  | WL_LocalOnly <- where_look                 = Outputable.empty
+  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty
+  | null interesting_imports
+  , Just name <- mod_name
+  , show_not_imported_line name
+  = hsep
+      [ text "No module named"
+      , quotes (ppr name)
+      , text "is imported."
+      ]
+  | is_qualified
+  , null helpful_imports
+  , [(mod,_)] <- interesting_imports
+  = hsep
+      [ text "Module"
+      , quotes (ppr mod)
+      , text "does not export"
+      , quotes (ppr occ_name) <> dot
+      ]
+  | is_qualified
+  , null helpful_imports
+  , not (null interesting_imports)
+  , mods <- map fst interesting_imports
+  = hsep
+      [ text "Neither"
+      , quotedListWithNor (map ppr mods)
+      , text "exports"
+      , quotes (ppr occ_name) <> dot
+      ]
+  | [(mod,imv)] <- helpful_imports_non_hiding
+  = fsep
+      [ text "Perhaps you want to add"
+      , quotes (ppr occ_name)
+      , text "to the import list"
+      , text "in the import of"
+      , quotes (ppr mod)
+      , parens (ppr (imv_span imv)) <> dot
+      ]
+  | not (null helpful_imports_non_hiding)
+  = fsep
+      [ text "Perhaps you want to add"
+      , quotes (ppr occ_name)
+      , text "to one of these import lists:"
+      ]
+    $$
+    nest 2 (vcat
+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
+        | (mod,imv) <- helpful_imports_non_hiding
+        ])
+  | [(mod,imv)] <- helpful_imports_hiding
+  = fsep
+      [ text "Perhaps you want to remove"
+      , quotes (ppr occ_name)
+      , text "from the explicit hiding list"
+      , text "in the import of"
+      , quotes (ppr mod)
+      , parens (ppr (imv_span imv)) <> dot
+      ]
+  | not (null helpful_imports_hiding)
+  = fsep
+      [ text "Perhaps you want to remove"
+      , quotes (ppr occ_name)
+      , text "from the hiding clauses"
+      , text "in one of these imports:"
+      ]
+    $$
+    nest 2 (vcat
+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
+        | (mod,imv) <- helpful_imports_hiding
+        ])
+  | otherwise
+  = Outputable.empty
+ where
+  is_qualified = isQual rdr_name
+  (mod_name, occ_name) = case rdr_name of
+    Unqual occ_name        -> (Nothing, occ_name)
+    Qual mod_name occ_name -> (Just mod_name, occ_name)
+    _                      -> error "importSuggestions: dead code"
+
+
+  -- What import statements provide "Mod" at all
+  -- or, if this is an unqualified name, are not qualified imports
+  interesting_imports = [ (mod, imp)
+    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
+    , Just imp <- return $ pick (importedByUser mod_imports)
+    ]
+
+  -- We want to keep only one for each original module; preferably one with an
+  -- explicit import list (for no particularly good reason)
+  pick :: [ImportedModsVal] -> Maybe ImportedModsVal
+  pick = listToMaybe . sortBy (compare `on` prefer) . filter select
+    where select imv = case mod_name of Just name -> imv_name imv == name
+                                        Nothing   -> not (imv_qualified imv)
+          prefer imv = (imv_is_hiding imv, imv_span imv)
+
+  -- Which of these would export a 'foo'
+  -- (all of these are restricted imports, because if they were not, we
+  -- wouldn't have an out-of-scope error in the first place)
+  helpful_imports = filter helpful interesting_imports
+    where helpful (_,imv)
+            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name
+
+  -- Which of these do that because of an explicit hiding list resp. an
+  -- explicit import list
+  (helpful_imports_hiding, helpful_imports_non_hiding)
+    = partition (imv_is_hiding . snd) helpful_imports
+
+  -- See note [When to show/hide the module-not-imported line]
+  show_not_imported_line :: ModuleName -> Bool                    -- #15611
+  show_not_imported_line modnam
+      | modnam `elem` globMods                = False    -- #14225     -- 1
+      | moduleName currMod == modnam          = False                  -- 2.1
+      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2
+      | otherwise                             = True
+    where
+      hpt_uniques = map fst (udfmToList hpt)
+      is_last_loaded_mod _ []         = False
+      is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam
+      globMods = nub [ mod
+                     | gre <- globalRdrEnvElts global_env
+                     , isGreOk where_look gre
+                     , (mod, _) <- qualsInScope gre
+                     ]
+
+extensionSuggestions :: RdrName -> SDoc
+extensionSuggestions rdrName
+  | rdrName == mkUnqual varName (fsLit "mdo") ||
+    rdrName == mkUnqual varName (fsLit "rec")
+      = text "Perhaps you meant to use RecursiveDo"
+  | otherwise = Outputable.empty
+
+qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
+-- Ones for which the qualified version is in scope
+qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }
+      | lcl = case nameModule_maybe n of
+                Nothing -> []
+                Just m  -> [(moduleName m, Left (nameSrcSpan n))]
+      | otherwise = [ (is_as ispec, Right ispec)
+                    | i <- is, let ispec = is_decl i ]
+
+isGreOk :: WhereLooking -> GlobalRdrElt -> Bool
+isGreOk where_look = case where_look of
+                         WL_LocalTop  -> isLocalGRE
+                         WL_LocalOnly -> const False
+                         _            -> const True
+
+{- Note [When to show/hide the module-not-imported line]           -- #15611
+For the error message:
+    Not in scope X.Y
+    Module X does not export Y
+    No module named ‘X’ is imported:
+there are 2 cases, where we hide the last "no module is imported" line:
+1. If the module X has been imported.
+2. If the module X is the current module. There are 2 subcases:
+   2.1 If the unknown module name is in a input source file,
+       then we can use the getModule function to get the current module name.
+       (See test T15611a)
+   2.2 If the unknown module name has been entered by the user in GHCi,
+       then the getModule function returns something like "interactive:Ghci1",
+       and we have to check the current module in the last added entry of
+       the HomePackageTable. (See test T15611b)
+-}
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnUtils.hs
@@ -0,0 +1,512 @@
+{-
+
+This module contains miscellaneous functions related to renaming.
+
+-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module RnUtils (
+        checkDupRdrNames, checkShadowedRdrNames,
+        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
+        checkTupSize,
+        addFvRn, mapFvRn, mapMaybeFvRn,
+        warnUnusedMatches, warnUnusedTypePatterns,
+        warnUnusedTopBinds, warnUnusedLocalBinds,
+        checkUnusedRecordWildcard,
+        mkFieldEnv,
+        unknownSubordinateErr, badQualBndrErr, typeAppErr,
+        HsDocContext(..), pprHsDocContext,
+        inHsDocContext, withHsDocContext,
+
+        newLocalBndrRn, newLocalBndrsRn,
+
+        bindLocalNames, bindLocalNamesFV,
+
+        addNameClashErrRn, extendTyVarEnvFVRn
+
+)
+
+where
+
+
+import GhcPrelude
+
+import HsSyn
+import RdrName
+import HscTypes
+import TcEnv
+import TcRnMonad
+import Name
+import NameSet
+import NameEnv
+import DataCon
+import SrcLoc
+import Outputable
+import Util
+import BasicTypes       ( TopLevelFlag(..) )
+import ListSetOps       ( removeDups )
+import DynFlags
+import FastString
+import Control.Monad
+import Data.List
+import Constants        ( mAX_TUPLE_SIZE )
+import qualified Data.List.NonEmpty as NE
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Binding}
+*                                                      *
+*********************************************************
+-}
+
+newLocalBndrRn :: Located RdrName -> RnM Name
+-- Used for non-top-level binders.  These should
+-- never be qualified.
+newLocalBndrRn (dL->L loc rdr_name)
+  | Just name <- isExact_maybe rdr_name
+  = return name -- This happens in code generated by Template Haskell
+                -- See Note [Binders in Template Haskell] in Convert.hs
+  | otherwise
+  = do { unless (isUnqual rdr_name)
+                (addErrAt loc (badQualBndrErr rdr_name))
+       ; uniq <- newUnique
+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+
+newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
+newLocalBndrsRn = mapM newLocalBndrRn
+
+bindLocalNames :: [Name] -> RnM a -> RnM a
+bindLocalNames names enclosed_scope
+  = do { lcl_env <- getLclEnv
+       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)
+             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
+                           [ (n, (NotTopLevel, th_level)) | n <- names ]
+             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names
+       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
+                            , tcl_rdr      = rdr_env' })
+                    enclosed_scope }
+
+bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+bindLocalNamesFV names enclosed_scope
+  = do  { (result, fvs) <- bindLocalNames names enclosed_scope
+        ; return (result, delFVs names fvs) }
+
+-------------------------------------
+
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
+
+-------------------------------------
+checkDupRdrNames :: [Located RdrName] -> RnM ()
+-- Check for duplicated names in a binding group
+checkDupRdrNames rdr_names_w_loc
+  = mapM_ (dupNamesErr getLoc) dups
+  where
+    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
+
+checkDupNames :: [Name] -> RnM ()
+-- Check for duplicated names in a binding group
+checkDupNames names = check_dup_names (filterOut isSystemName names)
+                -- See Note [Binders in Template Haskell] in Convert
+
+check_dup_names :: [Name] -> RnM ()
+check_dup_names names
+  = mapM_ (dupNamesErr nameSrcSpan) dups
+  where
+    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
+
+---------------------
+checkShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkShadowedRdrNames loc_rdr_names
+  = do { envs <- getRdrEnvs
+       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }
+  where
+    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
+                -- See Note [Binders in Template Haskell] in Convert
+    get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr)
+
+checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
+checkDupAndShadowedNames envs names
+  = do { check_dup_names filtered_names
+       ; checkShadowedOccs envs get_loc_occ filtered_names }
+  where
+    filtered_names = filterOut isSystemName names
+                -- See Note [Binders in Template Haskell] in Convert
+    get_loc_occ name = (nameSrcSpan name, nameOccName name)
+
+-------------------------------------
+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
+                  -> (a -> (SrcSpan, OccName))
+                  -> [a] -> RnM ()
+checkShadowedOccs (global_env,local_env) get_loc_occ ns
+  = whenWOptM Opt_WarnNameShadowing $
+    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
+        ; mapM_ check_shadow ns }
+  where
+    check_shadow n
+        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"
+                                                -- See #3262
+        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
+        | otherwise = do { gres' <- filterM is_shadowed_gre gres
+                         ; complain (map pprNameProvenance gres') }
+        where
+          (loc,occ) = get_loc_occ n
+          mb_local  = lookupLocalRdrOcc local_env occ
+          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env
+                -- Make an Unqualified RdrName and look that up, so that
+                -- we don't find any GREs that are in scope qualified-only
+
+          complain []      = return ()
+          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
+                                       loc
+                                       (shadowedNameWarn occ pp_locs)
+
+    is_shadowed_gre :: GlobalRdrElt -> RnM Bool
+        -- Returns False for record selectors that are shadowed, when
+        -- punning or wild-cards are on (cf #2723)
+    is_shadowed_gre gre | isRecFldGRE gre
+        = do { dflags <- getDynFlags
+             ; return $ not (xopt LangExt.RecordPuns dflags
+                             || xopt LangExt.RecordWildCards dflags) }
+    is_shadowed_gre _other = return True
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Free variable manipulation}
+*                                                                      *
+************************************************************************
+-}
+
+-- A useful utility
+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
+                               ; return (res, fvs1 `plusFV` fvs2) }
+
+mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
+mapFvRn f xs = do stuff <- mapM f xs
+                  case unzip stuff of
+                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)
+
+mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Envt utility functions}
+*                                                                      *
+************************************************************************
+-}
+
+warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
+warnUnusedTopBinds gres
+    = whenWOptM Opt_WarnUnusedTopBinds
+    $ do env <- getGblEnv
+         let isBoot = tcg_src env == HsBootFile
+         let noParent gre = case gre_par gre of
+                            NoParent -> True
+                            _        -> False
+             -- Don't warn about unused bindings with parents in
+             -- .hs-boot files, as you are sometimes required to give
+             -- unused bindings (trac #3449).
+             -- HOWEVER, in a signature file, you are never obligated to put a
+             -- definition in the main text.  Thus, if you define something
+             -- and forget to export it, we really DO want to warn.
+             gres' = if isBoot then filter noParent gres
+                               else                 gres
+         warnUnusedGREs gres'
+
+
+-- | Checks to see if we need to warn for -Wunused-record-wildcards or
+-- -Wredundant-record-wildcards
+checkUnusedRecordWildcard :: SrcSpan
+                          -> FreeVars
+                          -> Maybe [Name]
+                          -> RnM ()
+checkUnusedRecordWildcard _ _ Nothing    = return ()
+checkUnusedRecordWildcard loc _ (Just [])  = do
+  -- Add a new warning if the .. pattern binds no variables
+  setSrcSpan loc $ warnRedundantRecordWildcard
+checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
+  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
+
+
+-- | Produce a warning when the `..` pattern binds no new
+-- variables.
+--
+-- @
+--   data P = P { x :: Int }
+--
+--   foo (P{x, ..}) = x
+-- @
+--
+-- The `..` here doesn't bind any variables as `x` is already bound.
+warnRedundantRecordWildcard :: RnM ()
+warnRedundantRecordWildcard =
+  whenWOptM Opt_WarnRedundantRecordWildcards
+            (addWarn (Reason Opt_WarnRedundantRecordWildcards)
+                     redundantWildcardWarning)
+
+
+-- | Produce a warning when no variables bound by a `..` pattern are used.
+--
+-- @
+--   data P = P { x :: Int }
+--
+--   foo (P{..}) = ()
+-- @
+--
+-- The `..` pattern binds `x` but it is not used in the RHS so we issue
+-- a warning.
+warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
+warnUnusedRecordWildcard ns used_names = do
+  let used = filter (`elemNameSet` used_names) ns
+  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
+  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)
+    unusedRecordWildcardWarning
+
+
+
+warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
+  :: [Name] -> FreeVars -> RnM ()
+warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds
+warnUnusedMatches      = check_unused Opt_WarnUnusedMatches
+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
+
+check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
+check_unused flag bound_names used_names
+  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
+                                               bound_names))
+
+-------------------------
+--      Helpers
+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
+warnUnusedGREs gres = mapM_ warnUnusedGRE gres
+
+warnUnused :: WarningFlag -> [Name] -> RnM ()
+warnUnused flag names = do
+    fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+    mapM_ (warnUnused1 flag fld_env) names
+
+warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
+warnUnused1 flag fld_env name
+  = when (reportable name occ) $
+    addUnusedWarning flag
+                     occ (nameSrcSpan name)
+                     (text $ "Defined but not used" ++ opt_str)
+  where
+    occ = case lookupNameEnv fld_env name of
+              Just (fl, _) -> mkVarOccFS fl
+              Nothing      -> nameOccName name
+    opt_str = case flag of
+                Opt_WarnUnusedTypePatterns -> " on the right hand side"
+                _ -> ""
+
+warnUnusedGRE :: GlobalRdrElt -> RnM ()
+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
+  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name
+  | otherwise = when (reportable name occ) (mapM_ warn is)
+  where
+    occ = greOccName gre
+    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
+        where
+           span = importSpecLoc spec
+           pp_mod = quotes (ppr (importSpecModule spec))
+           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
+
+-- | Make a map from selector names to field labels and parent tycon
+-- names, to be used when reporting unused record fields.
+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
+                               | gres <- occEnvElts rdr_env
+                               , gre <- gres
+                               , Just lbl <- [greLabel gre]
+                               ]
+
+-- | Should we report the fact that this 'Name' is unused? The
+-- 'OccName' may differ from 'nameOccName' due to
+-- DuplicateRecordFields.
+reportable :: Name -> OccName -> Bool
+reportable name occ
+  | isWiredInName name = False    -- Don't report unused wired-in names
+                                  -- Otherwise we get a zillion warnings
+                                  -- from Data.Tuple
+  | otherwise = not (startsWithUnderscore occ)
+
+addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning flag occ span msg
+  = addWarnAt (Reason flag) span $
+    sep [msg <> colon,
+         nest 2 $ pprNonVarNameSpace (occNameSpace occ)
+                        <+> quotes (ppr occ)]
+
+unusedRecordWildcardWarning :: SDoc
+unusedRecordWildcardWarning =
+  wildcardDoc $ text "No variables bound in the record wildcard match are used"
+
+redundantWildcardWarning :: SDoc
+redundantWildcardWarning =
+  wildcardDoc $ text "Record wildcard does not bind any new variables"
+
+wildcardDoc :: SDoc -> SDoc
+wildcardDoc herald =
+  herald
+    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"
+                                            <+> quotes (text ".."))
+
+addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
+addNameClashErrRn rdr_name gres
+  | all isLocalGRE gres && not (all isRecFldGRE gres)
+               -- If there are two or more *local* defns, we'll have reported
+  = return ()  -- that already, and we don't want an error cascade
+  | otherwise
+  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
+                 , text "It could refer to"
+                 , nest 3 (vcat (msg1 : msgs)) ])
+  where
+    (np1:nps) = gres
+    msg1 =  text "either" <+> ppr_gre np1
+    msgs = [text "    or" <+> ppr_gre np | np <- nps]
+    ppr_gre gre = sep [ pp_gre_name gre <> comma
+                      , pprNameProvenance gre]
+
+    -- When printing the name, take care to qualify it in the same
+    -- way as the provenance reported by pprNameProvenance, namely
+    -- the head of 'gre_imp'.  Otherwise we get confusing reports like
+    --   Ambiguous occurrence ‘null’
+    --   It could refer to either ‘T15487a.null’,
+    --                            imported from ‘Prelude’ at T15487.hs:1:8-13
+    --                     or ...
+    -- See #15487
+    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent
+                         , gre_lcl = lcl, gre_imp = iss })
+      | FldParent { par_lbl = Just lbl } <- parent
+      = text "the field" <+> quotes (ppr lbl)
+      | otherwise
+      = quotes (pp_qual <> dot <> ppr (nameOccName name))
+      where
+        pp_qual | lcl
+                = ppr (nameModule name)
+                | imp : _ <- iss  -- This 'imp' is the one that
+                                  -- pprNameProvenance chooses
+                , ImpDeclSpec { is_as = mod } <- is_decl imp
+                = ppr mod
+                | otherwise
+                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
+                  -- Invariant: either 'lcl' is True or 'iss' is non-empty
+
+shadowedNameWarn :: OccName -> [SDoc] -> SDoc
+shadowedNameWarn occ shadowed_locs
+  = sep [text "This binding for" <+> quotes (ppr occ)
+            <+> text "shadows the existing binding" <> plural shadowed_locs,
+         nest 2 (vcat shadowed_locs)]
+
+
+unknownSubordinateErr :: SDoc -> RdrName -> SDoc
+unknownSubordinateErr doc op    -- Doc is "method of class" or
+                                -- "field of constructor"
+  = quotes (ppr op) <+> text "is not a (visible)" <+> doc
+
+
+dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
+dupNamesErr get_loc names
+  = addErrAt big_loc $
+    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
+          locations]
+  where
+    locs      = map get_loc (NE.toList names)
+    big_loc   = foldr1 combineSrcSpans locs
+    locations = text "Bound at:" <+> vcat (map ppr (sort locs))
+
+badQualBndrErr :: RdrName -> SDoc
+badQualBndrErr rdr_name
+  = text "Qualified name in binding position:" <+> ppr rdr_name
+
+typeAppErr :: String -> LHsType GhcPs -> SDoc
+typeAppErr what (L _ k)
+  = hang (text "Illegal visible" <+> text what <+> text "application"
+            <+> quotes (char '@' <> ppr k))
+       2 (text "Perhaps you intended to use TypeApplications")
+
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+  | tup_size <= mAX_TUPLE_SIZE
+  = return ()
+  | otherwise
+  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
+                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
+                 nest 2 (text "Workaround: use nested tuples or define a data type")])
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Contexts for renaming errors}
+*                                                                      *
+************************************************************************
+-}
+
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+--          Merge TcType.UserTypeContext in to it.
+data HsDocContext
+  = TypeSigCtx SDoc
+  | PatCtx
+  | SpecInstSigCtx
+  | DefaultDeclCtx
+  | ForeignDeclCtx (Located RdrName)
+  | DerivDeclCtx
+  | RuleCtx FastString
+  | TyDataCtx (Located RdrName)
+  | TySynCtx (Located RdrName)
+  | TyFamilyCtx (Located RdrName)
+  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance
+  | ConDeclCtx [Located Name]
+  | ClassDeclCtx (Located RdrName)
+  | ExprWithTySigCtx
+  | TypBrCtx
+  | HsTypeCtx
+  | GHCiCtx
+  | SpliceTypeCtx (LHsType GhcPs)
+  | ClassInstanceCtx
+  | GenericCtx SDoc   -- Maybe we want to use this more!
+
+withHsDocContext :: HsDocContext -> SDoc -> SDoc
+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
+
+inHsDocContext :: HsDocContext -> SDoc
+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
+
+pprHsDocContext :: HsDocContext -> SDoc
+pprHsDocContext (GenericCtx doc)      = doc
+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc
+pprHsDocContext PatCtx                = text "a pattern type-signature"
+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"
+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"
+pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name
+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)
+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)
+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)
+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)
+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)
+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"
+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"
+pprHsDocContext HsTypeCtx             = text "a type argument"
+pprHsDocContext GHCiCtx               = text "GHCi input"
+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
+pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"
+
+pprHsDocContext (ForeignDeclCtx name)
+   = text "the foreign declaration for" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx [name])
+   = text "the definition of data constructor" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx names)
+   = text "the definition of data constructors" <+> interpp'SP names
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/CSE.hs
@@ -0,0 +1,701 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section{Common subexpression}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module CSE (cseProgram, cseOneExpr) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSubst
+import Var              ( Var )
+import VarEnv           ( elemInScopeSet, mkInScopeSet )
+import Id               ( Id, idType, isDeadBinder
+                        , idInlineActivation, setInlineActivation
+                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
+                        , isJoinId, isJoinId_maybe )
+import CoreUtils        ( mkAltExpr, eqExpr
+                        , exprIsTickedString
+                        , stripTicksE, stripTicksT, mkTicks )
+import CoreFVs          ( exprFreeVars )
+import Type             ( tyConAppArgs )
+import CoreSyn
+import Outputable
+import BasicTypes
+import CoreMap
+import Util             ( filterOut )
+import Data.List        ( mapAccumL )
+
+{-
+                        Simple common sub-expression
+                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we see
+        x1 = C a b
+        x2 = C x1 b
+we build up a reverse mapping:   C a b  -> x1
+                                 C x1 b -> x2
+and apply that to the rest of the program.
+
+When we then see
+        y1 = C a b
+        y2 = C y1 b
+we replace the C a b with x1.  But then we *dont* want to
+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
+so that a subsequent binding
+        y2 = C y1 b
+will get transformed to C x1 b, and then to x2.
+
+So we carry an extra var->var substitution which we apply *before* looking up in the
+reverse mapping.
+
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+We have to be careful about shadowing.
+For example, consider
+        f = \x -> let y = x+x in
+                      h = \x -> x+x
+                  in ...
+
+Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
+We can simply add clones to the substitution already described.
+
+
+Note [CSE for bindings]
+~~~~~~~~~~~~~~~~~~~~~~~
+Let-bindings have two cases, implemented by addBinding.
+
+* SUBSTITUTE: applies when the RHS is a variable
+
+     let x = y in ...(h x)....
+
+  Here we want to extend the /substitution/ with x -> y, so that the
+  (h x) in the body might CSE with an enclosing (let v = h y in ...).
+  NB: the substitution maps InIds, so we extend the substitution with
+      a binding for the original InId 'x'
+
+  How can we have a variable on the RHS? Doesn't the simplifier inline them?
+
+    - First, the original RHS might have been (g z) which has CSE'd
+      with an enclosing (let y = g z in ...).  This is super-important.
+      See #5996:
+         x1 = C a b
+         x2 = C x1 b
+         y1 = C a b
+         y2 = C y1 b
+      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
+      the substitution so that we can CSE the binding for y2.
+
+    - Second, we use addBinding for case expression scrutinees too;
+      see Note [CSE for case expressions]
+
+* EXTEND THE REVERSE MAPPING: applies in all other cases
+
+     let x = h y in ...(h y)...
+
+  Here we want to extend the /reverse mapping (cs_map)/ so that
+  we CSE the (h y) call to x.
+
+  Note that we use EXTEND even for a trivial expression, provided it
+  is not a variable or literal. In particular this /includes/ type
+  applications. This can be important (#13156); e.g.
+     case f @ Int of { r1 ->
+     case f @ Int of { r2 -> ...
+  Here we want to common-up the two uses of (f @ Int) so we can
+  remove one of the case expressions.
+
+  See also Note [Corner case for case expressions] for another
+  reason not to use SUBSTITUTE for all trivial expressions.
+
+Notice that
+  - The SUBSTITUTE situation extends the substitution (cs_subst)
+  - The EXTEND situation extends the reverse mapping (cs_map)
+
+Notice also that in the SUBSTITUTE case we leave behind a binding
+  x = y
+even though we /also/ carry a substitution x -> y.  Can we just drop
+the binding instead?  Well, not at top level! See SimplUtils
+Note [Top level and postInlineUnconditionally]; and in any case CSE
+applies only to the /bindings/ of the program, and we leave it to the
+simplifier to propate effects to the RULES.  Finally, it doesn't seem
+worth the effort to discard the nested bindings because the simplifier
+will do it next.
+
+Note [CSE for case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  case scrut_expr of x { ...alts... }
+This is very like a strict let-binding
+  let !x = scrut_expr in ...
+So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
+result all the stuff under Note [CSE for bindings] applies directly.
+
+For example:
+
+* Trivial scrutinee
+     f = \x -> case x of wild {
+                 (a:as) -> case a of wild1 {
+                             (p,q) -> ...(wild1:as)...
+
+  Here, (wild1:as) is morally the same as (a:as) and hence equal to
+  wild. But that's not quite obvious.  In the rest of the compiler we
+  want to keep it as (wild1:as), but for CSE purpose that's a bad
+  idea.
+
+  By using addBinding we add the binding (wild1 -> a) to the substitution,
+  which does exactly the right thing.
+
+  (Notice this is exactly backwards to what the simplifier does, which
+  is to try to replaces uses of 'a' with uses of 'wild1'.)
+
+  This is the main reason that addBinding is called with a trivial rhs.
+
+* Non-trivial scrutinee
+     case (f x) of y { pat -> ...let z = f x in ... }
+
+  By using addBinding we'll add (f x :-> y) to the cs_map, and
+  thereby CSE the inner (f x) to y.
+
+Note [CSE for INLINE and NOINLINE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are some subtle interactions of CSE with functions that the user
+has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
+Consider
+
+        yes :: Int  {-# NOINLINE yes #-}
+        yes = undefined
+
+        no :: Int   {-# NOINLINE no #-}
+        no = undefined
+
+        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}
+        foo m n = n
+
+        {-# RULES "foo/no" foo no = id #-}
+
+        bar :: Int -> Int
+        bar = foo yes
+
+We do not expect the rule to fire.  But if we do CSE, then we risk
+getting yes=no, and the rule does fire.  Actually, it won't because
+NOINLINE means that 'yes' will never be inlined, not even if we have
+yes=no.  So that's fine (now; perhaps in the olden days, yes=no would
+have substituted even if 'yes' was NOINLINE).
+
+But we do need to take care.  Consider
+
+        {-# NOINLINE bar #-}
+        bar = <rhs>     -- Same rhs as foo
+
+        foo = <rhs>
+
+If CSE produces
+        foo = bar
+then foo will never be inlined to <rhs> (when it should be, if <rhs>
+is small).  The conclusion here is this:
+
+   We should not add
+       <rhs> :-> bar
+  to the CSEnv if 'bar' has any constraints on when it can inline;
+  that is, if its 'activation' not always active.  Otherwise we
+  might replace <rhs> by 'bar', and then later be unable to see that it
+  really was <rhs>.
+
+An except to the rule is when the INLINE pragma is not from the user, e.g. from
+WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
+is then true.
+
+Note that we do not (currently) do CSE on the unfolding stored inside
+an Id, even if it is a 'stable' unfolding.  That means that when an
+unfolding happens, it is always faithful to what the stable unfolding
+originally was.
+
+Note [CSE for stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   {-# Unf = Stable (\pq. build blah) #-}
+   foo = x
+
+Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
+(Turns out that this actually happens for the enumFromTo method of
+the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's
+stable unfolding originates from an INLINE or INLINEABLE pragma on foo.
+Then we obviously do NOT want to extend the substitution with (foo->x),
+because we promised to inline foo as what the user wrote.  See similar
+SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
+
+Nor do we want to change the reverse mapping. Suppose we have
+
+   {-# Unf = Stable (\pq. build blah) #-}
+   foo = <expr>
+   bar = <expr>
+
+There could conceivably be merit in rewriting the RHS of bar:
+   bar = foo
+but now bar's inlining behaviour will change, and importing
+modules might see that.  So it seems dodgy and we don't do it.
+
+Stable unfoldings are also created during worker/wrapper when we decide
+that a function's definition is so small that it should always inline.
+In this case we still want to do CSE (#13340). Hence the use of
+isAnyInlinePragma rather than isStableUnfolding.
+
+Note [Corner case for case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is another reason that we do not use SUBSTITUTE for
+all trivial expressions. Consider
+   case x |> co of (y::Array# Int) { ... }
+
+We do not want to extend the substitution with (y -> x |> co); since y
+is of unlifted type, this would destroy the let/app invariant if (x |>
+co) was not ok-for-speculation.
+
+But surely (x |> co) is ok-for-speculation, becasue it's a trivial
+expression, and x's type is also unlifted, presumably.  Well, maybe
+not if you are using unsafe casts.  I actually found a case where we
+had
+   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
+
+Note [CSE for join points?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not be naive about join points in CSE:
+   join j = e in
+   if b then jump j else 1 + e
+The expression (1 + jump j) is not good (see Note [Invariants on join points] in
+CoreSyn). This seems to come up quite seldom, but it happens (first seen
+compiling ppHtml in Haddock.Backends.Xhtml).
+
+We could try and be careful by tracking which join points are still valid at
+each subexpression, but since join points aren't allocated or shared, there's
+less to gain by trying to CSE them. (#13219)
+
+Note [Look inside join-point binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Another way how CSE for joint points is tricky is
+
+  let join foo x = (x, 42)
+      join bar x = (x, 42)
+  in … jump foo 1 … jump bar 2 …
+
+naively, CSE would turn this into
+
+  let join foo x = (x, 42)
+      join bar = foo
+  in … jump foo 1 … jump bar 2 …
+
+but now bar is a join point that claims arity one, but its right-hand side
+is not a lambda, breaking the join-point invariant (this was #15002).
+
+So `cse_bind` must zoom past the lambdas of a join point (using
+`collectNBinders`) and resume searching for CSE opportunities only in
+the body of the join point.
+
+Note [CSE for recursive bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x ... f....
+  g = \y ... g ...
+where the "..." are identical.  Could we CSE them?  In full generality
+with mutual recursion it's quite hard; but for self-recursive bindings
+(which are very common) it's rather easy:
+
+* Maintain a separate cs_rec_map, that maps
+      (\f. (\x. ...f...) ) -> f
+  Note the \f in the domain of the mapping!
+
+* When we come across the binding for 'g', look up (\g. (\y. ...g...))
+  Bingo we get a hit.  So we can replace the 'g' binding with
+     g = f
+
+We can't use cs_map for this, because the key isn't an expression of
+the program; it's a kind of synthetic key for recursive bindings.
+
+
+************************************************************************
+*                                                                      *
+\section{Common subexpression}
+*                                                                      *
+************************************************************************
+-}
+
+cseProgram :: CoreProgram -> CoreProgram
+cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
+
+cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
+cseBind toplevel env (NonRec b e)
+  = (env2, NonRec b2 e2)
+  where
+    (env1, b1)       = addBinder env b
+    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1
+
+cseBind toplevel env (Rec [(in_id, rhs)])
+  | noCSE in_id
+  = (env1, Rec [(out_id, rhs')])
+
+  -- See Note [CSE for recursive bindings]
+  | Just previous <- lookupCSRecEnv env out_id rhs''
+  , let previous' = mkTicks ticks previous
+        out_id'   = delayInlining toplevel out_id
+  = -- We have a hit in the recursive-binding cache
+    (extendCSSubst env1 in_id previous', NonRec out_id' previous')
+
+  | otherwise
+  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
+
+  where
+    (env1, [out_id]) = addRecBinders env [in_id]
+    rhs'  = cseExpr env1 rhs
+    rhs'' = stripTicksE tickishFloatable rhs'
+    ticks = stripTicksT tickishFloatable rhs'
+    id_expr'  = varToCoreExpr out_id
+    zapped_id = zapIdUsageInfo out_id
+
+cseBind toplevel env (Rec pairs)
+  = (env2, Rec pairs')
+  where
+    (env1, bndrs1) = addRecBinders env (map fst pairs)
+    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)
+
+    do_one env (pr, b1) = cse_bind toplevel env pr b1
+
+-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer
+-- to @in_id@ (@out_id@, created from addBinder or addRecBinders),
+-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)
+-- binding to the 'CSEnv', so that we attempt to CSE any expressions
+-- which are equal to @out_rhs@.
+cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
+cse_bind toplevel env (in_id, in_rhs) out_id
+  | isTopLevel toplevel, exprIsTickedString in_rhs
+      -- See Note [Take care with literal strings]
+  = (env', (out_id', in_rhs))
+
+  | Just arity <- isJoinId_maybe in_id
+      -- See Note [Look inside join-point binders]
+  = let (params, in_body) = collectNBinders arity in_rhs
+        (env', params') = addBinders env params
+        out_body = tryForCSE env' in_body
+    in (env, (out_id, mkLams params' out_body))
+
+  | otherwise
+  = (env', (out_id'', out_rhs))
+  where
+    (env', out_id') = addBinding env in_id out_id out_rhs
+    (cse_done, out_rhs) = try_for_cse env in_rhs
+    out_id'' | cse_done  = delayInlining toplevel out_id'
+             | otherwise = out_id'
+
+delayInlining :: TopLevelFlag -> Id -> Id
+-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already
+delayInlining top_lvl bndr
+  | isTopLevel top_lvl
+  , isAlwaysActive (idInlineActivation bndr)
+  = bndr `setInlineActivation` activeAfterInitial
+  | otherwise
+  = bndr
+
+addBinding :: CSEnv                      -- Includes InId->OutId cloning
+           -> InVar                      -- Could be a let-bound type
+           -> OutId -> OutExpr           -- Processed binding
+           -> (CSEnv, OutId)             -- Final env, final bndr
+-- Extend the CSE env with a mapping [rhs -> out-id]
+-- unless we can instead just substitute [in-id -> rhs]
+--
+-- It's possible for the binder to be a type variable (see
+-- Note [Type-let] in CoreSyn), in which case we can just substitute.
+addBinding env in_id out_id rhs'
+  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)
+  | noCSE in_id      = (env,                              out_id)
+  | use_subst        = (extendCSSubst env in_id rhs',     out_id)
+  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)
+  where
+    id_expr'  = varToCoreExpr out_id
+    zapped_id = zapIdUsageInfo out_id
+       -- Putting the Id into the cs_map makes it possible that
+       -- it'll become shared more than it is now, which would
+       -- invalidate (the usage part of) its demand info.
+       --    This caused #100218.
+       -- Easiest thing is to zap the usage info; subsequently
+       -- performing late demand-analysis will restore it.  Don't zap
+       -- the strictness info; it's not necessary to do so, and losing
+       -- it is bad for performance if you don't do late demand
+       -- analysis
+
+    -- Should we use SUBSTITUTE or EXTEND?
+    -- See Note [CSE for bindings]
+    use_subst = case rhs' of
+                   Var {} -> True
+                   _      -> False
+
+-- | Given a binder `let x = e`, this function
+-- determines whether we should add `e -> x` to the cs_map
+noCSE :: InId -> Bool
+noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
+            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
+             -- See Note [CSE for INLINE and NOINLINE]
+         || isAnyInlinePragma (idInlinePragma id)
+             -- See Note [CSE for stable unfoldings]
+         || isJoinId id
+             -- See Note [CSE for join points?]
+
+
+{- Note [Take care with literal strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this example:
+
+  x = "foo"#
+  y = "foo"#
+  ...x...y...x...y....
+
+We would normally turn this into:
+
+  x = "foo"#
+  y = x
+  ...x...x...x...x....
+
+But this breaks an invariant of Core, namely that the RHS of a top-level binding
+of type Addr# must be a string literal, not another variable. See Note
+[CoreSyn top-level string literals] in CoreSyn.
+
+For this reason, we special case top-level bindings to literal strings and leave
+the original RHS unmodified. This produces:
+
+  x = "foo"#
+  y = "foo"#
+  ...x...x...x...x....
+
+Now 'y' will be discarded as dead code, and we are done.
+
+The net effect is that for the y-binding we want to
+  - Use SUBSTITUTE, by extending the substitution with  y :-> x
+  - but leave the original binding for y undisturbed
+
+This is done by cse_bind.  I got it wrong the first time (#13367).
+
+Note [Delay inlining after CSE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (#15445) we have
+   f,g :: Num a => a -> a
+   f x = ...f (x-1).....
+   g y = ...g (y-1) ....
+
+and we make some specialisations of 'g', either automatically, or via
+a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of
+'f' and 'g' are identical, so we get
+   f x = ...f (x-1)...
+   g = f
+   {-# RULES g @Int _ = $sg #-}
+
+Now there is terrible danger that, in an importing module, we'll inline
+'g' before we have a chance to run its specialisation!
+
+Solution: during CSE, when adding a top-level
+  g = f
+binding after a "hit" in the CSE cache, add a NOINLINE[2] activation
+to it, to ensure it's not inlined right away.
+
+Why top level only?  Because for nested bindings we are already past
+phase 2 and will never return there.
+-}
+
+tryForCSE :: CSEnv -> InExpr -> OutExpr
+tryForCSE env expr = snd (try_for_cse env expr)
+
+try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)
+-- (False, e') => We did not CSE the entire expression,
+--                but we might have CSE'd some sub-expressions,
+--                yielding e'
+--
+-- (True, te') => We CSE'd the entire expression,
+--                yielding the trivial expression te'
+try_for_cse env expr
+  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)
+  | otherwise                        = (False, expr')
+    -- The varToCoreExpr is needed if we have
+    --   case e of xco { ...case e of yco { ... } ... }
+    -- Then CSE will substitute yco -> xco;
+    -- but these are /coercion/ variables
+  where
+    expr'  = cseExpr env expr
+    expr'' = stripTicksE tickishFloatable expr'
+    ticks  = stripTicksT tickishFloatable expr'
+    -- We don't want to lose the source notes when a common sub
+    -- expression gets eliminated. Hence we push all (!) of them on
+    -- top of the replaced sub-expression. This is probably not too
+    -- useful in practice, but upholds our semantics.
+
+-- | Runs CSE on a single expression.
+--
+-- This entry point is not used in the compiler itself, but is provided
+-- as a convenient entry point for users of the GHC API.
+cseOneExpr :: InExpr -> OutExpr
+cseOneExpr e = cseExpr env e
+  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
+
+cseExpr :: CSEnv -> InExpr -> OutExpr
+cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)
+cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)
+cseExpr _   (Lit lit)             = Lit lit
+cseExpr env (Var v)               = lookupSubst env v
+cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
+cseExpr env (Tick t e)            = Tick t (cseExpr env e)
+cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
+cseExpr env (Lam b e)             = let (env', b') = addBinder env b
+                                    in Lam b' (cseExpr env' e)
+cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind
+                                    in Let bind' (cseExpr env' e)
+cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
+
+cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
+cseCase env scrut bndr ty alts
+  = Case scrut1 bndr3 ty' $
+    combineAlts alt_env (map cse_alt alts)
+  where
+    ty' = substTy (csEnvSubst env) ty
+    scrut1 = tryForCSE env scrut
+
+    bndr1 = zapIdOccInfo bndr
+      -- Zapping the OccInfo is needed because the extendCSEnv
+      -- in cse_alt may mean that a dead case binder
+      -- becomes alive, and Lint rejects that
+    (env1, bndr2)    = addBinder env bndr1
+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
+         -- addBinding: see Note [CSE for case expressions]
+
+    con_target :: OutExpr
+    con_target = lookupSubst alt_env bndr
+
+    arg_tys :: [OutType]
+    arg_tys = tyConAppArgs (idType bndr3)
+
+    -- Given case x of { K y z -> ...K y z... }
+    -- CSE K y z into x...
+    cse_alt (DataAlt con, args, rhs)
+        | not (null args)
+                -- ... but don't try CSE if there are no args; it just increases the number
+                -- of live vars.  E.g.
+                --      case x of { True -> ....True.... }
+                -- Don't replace True by x!
+                -- Hence the 'null args', which also deal with literals and DEFAULT
+        = (DataAlt con, args', tryForCSE new_env rhs)
+        where
+          (env', args') = addBinders alt_env args
+          new_env       = extendCSEnv env' con_expr con_target
+          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
+
+    cse_alt (con, args, rhs)
+        = (con, args', tryForCSE env' rhs)
+        where
+          (env', args') = addBinders alt_env args
+
+combineAlts :: CSEnv -> [InAlt] -> [InAlt]
+-- See Note [Combine case alternatives]
+combineAlts env ((_,bndrs1,rhs1) : rest_alts)
+  | all isDeadBinder bndrs1
+  = (DEFAULT, [], rhs1) : filtered_alts
+  where
+    in_scope = substInScope (csEnvSubst env)
+    filtered_alts = filterOut identical rest_alts
+    identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs
+    ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)
+
+combineAlts _ alts = alts  -- Default case
+
+{- Note [Combine case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+combineAlts is just a more heavyweight version of the use of
+combineIdenticalAlts in SimplUtils.prepareAlts.  The basic idea is
+to transform
+
+    DEFAULT -> e1
+    K x     -> e1
+    W y z   -> e2
+===>
+   DEFAULT -> e1
+   W y z   -> e2
+
+In the simplifier we use cheapEqExpr, because it is called a lot.
+But here in CSE we use the full eqExpr.  After all, two alternatives usually
+differ near the root, so it probably isn't expensive to compare the full
+alternative.  It seems like the same kind of thing that CSE is supposed
+to be doing, which is why I put it here.
+
+I acutally saw some examples in the wild, where some inlining made e1 too
+big for cheapEqExpr to catch it.
+
+
+************************************************************************
+*                                                                      *
+\section{The CSE envt}
+*                                                                      *
+************************************************************************
+-}
+
+data CSEnv
+  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs
+            -- The substitution variables to
+            -- /trivial/ OutExprs, not arbitrary expressions
+
+       , cs_map   :: CoreMap OutExpr   -- The reverse mapping
+            -- Maps a OutExpr to a /trivial/ OutExpr
+            -- The key of cs_map is stripped of all Ticks
+
+       , cs_rec_map :: CoreMap OutExpr
+            -- See Note [CSE for recursive bindings]
+       }
+
+emptyCSEnv :: CSEnv
+emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
+                , cs_subst = emptySubst }
+
+lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
+lookupCSEnv (CS { cs_map = csmap }) expr
+  = lookupCoreMap csmap expr
+
+extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
+extendCSEnv cse expr triv_expr
+  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
+  where
+    sexpr = stripTicksE tickishFloatable expr
+
+extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
+-- See Note [CSE for recursive bindings]
+extendCSRecEnv cse bndr expr triv_expr
+  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }
+
+lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr
+-- See Note [CSE for recursive bindings]
+lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr
+  = lookupCoreMap csmap (Lam bndr expr)
+
+csEnvSubst :: CSEnv -> Subst
+csEnvSubst = cs_subst
+
+lookupSubst :: CSEnv -> Id -> OutExpr
+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
+
+extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv
+extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
+
+-- | Add clones to the substitution to deal with shadowing.  See
+-- Note [Shadowing] for more details.  You should call this whenever
+-- you go under a binder.
+addBinder :: CSEnv -> Var -> (CSEnv, Var)
+addBinder cse v = (cse { cs_subst = sub' }, v')
+                where
+                  (sub', v') = substBndr (cs_subst cse) v
+
+addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
+addBinders cse vs = (cse { cs_subst = sub' }, vs')
+                where
+                  (sub', vs') = substBndrs (cs_subst cse) vs
+
+addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
+addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
+                where
+                  (sub', vs') = substRecBndrs (cs_subst cse) vs
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/CallArity.hs
@@ -0,0 +1,763 @@
+--
+-- Copyright (c) 2014 Joachim Breitner
+--
+
+module CallArity
+    ( callArityAnalProgram
+    , callArityRHS -- for testing
+    ) where
+
+import GhcPrelude
+
+import VarSet
+import VarEnv
+import DynFlags ( DynFlags )
+
+import BasicTypes
+import CoreSyn
+import Id
+import CoreArity ( typeArity )
+import CoreUtils ( exprIsCheap, exprIsTrivial )
+import UnVarGraph
+import Demand
+import Util
+
+import Control.Arrow ( first, second )
+
+
+{-
+%************************************************************************
+%*                                                                      *
+              Call Arity Analysis
+%*                                                                      *
+%************************************************************************
+
+Note [Call Arity: The goal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The goal of this analysis is to find out if we can eta-expand a local function,
+based on how it is being called. The motivating example is this code,
+which comes up when we implement foldl using foldr, and do list fusion:
+
+    let go = \x -> let d = case ... of
+                              False -> go (x+1)
+                              True  -> id
+                   in \z -> d (x + z)
+    in go 1 0
+
+If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of
+partial function applications, which would be bad.
+
+The function `go` has a type of arity two, but only one lambda is manifest.
+Furthermore, an analysis that only looks at the RHS of go cannot be sufficient
+to eta-expand go: If `go` is ever called with one argument (and the result used
+multiple times), we would be doing the work in `...` multiple times.
+
+So `callArityAnalProgram` looks at the whole let expression to figure out if
+all calls are nice, i.e. have a high enough arity. It then stores the result in
+the `calledArity` field of the `IdInfo` of `go`, which the next simplifier
+phase will eta-expand.
+
+The specification of the `calledArity` field is:
+
+    No work will be lost if you eta-expand me to the arity in `calledArity`.
+
+What we want to know for a variable
+-----------------------------------
+
+For every let-bound variable we'd like to know:
+  1. A lower bound on the arity of all calls to the variable, and
+  2. whether the variable is being called at most once or possible multiple
+     times.
+
+It is always ok to lower the arity, or pretend that there are multiple calls.
+In particular, "Minimum arity 0 and possible called multiple times" is always
+correct.
+
+
+What we want to know from an expression
+---------------------------------------
+
+In order to obtain that information for variables, we analyze expression and
+obtain bits of information:
+
+ I.  The arity analysis:
+     For every variable, whether it is absent, or called,
+     and if called, which what arity.
+
+ II. The Co-Called analysis:
+     For every two variables, whether there is a possibility that both are being
+     called.
+     We obtain as a special case: For every variables, whether there is a
+     possibility that it is being called twice.
+
+For efficiency reasons, we gather this information only for a set of
+*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.
+
+The two analysis are not completely independent, as a higher arity can improve
+the information about what variables are being called once or multiple times.
+
+Note [Analysis I: The arity analysis]
+------------------------------------
+
+The arity analysis is quite straight forward: The information about an
+expression is an
+    VarEnv Arity
+where absent variables are bound to Nothing and otherwise to a lower bound to
+their arity.
+
+When we analyze an expression, we analyze it with a given context arity.
+Lambdas decrease and applications increase the incoming arity. Analysizing a
+variable will put that arity in the environment. In lets or cases all the
+results from the various subexpressions are lubed, which takes the point-wise
+minimum (considering Nothing an infinity).
+
+
+Note [Analysis II: The Co-Called analysis]
+------------------------------------------
+
+The second part is more sophisticated. For reasons explained below, it is not
+sufficient to simply know how often an expression evaluates a variable. Instead
+we need to know which variables are possibly called together.
+
+The data structure here is an undirected graph of variables, which is provided
+by the abstract
+    UnVarGraph
+
+It is safe to return a larger graph, i.e. one with more edges. The worst case
+(i.e. the least useful and always correct result) is the complete graph on all
+free variables, which means that anything can be called together with anything
+(including itself).
+
+Notation for the following:
+C(e)  is the co-called result for e.
+G₁∪G₂ is the union of two graphs
+fv    is the set of free variables (conveniently the domain of the arity analysis result)
+S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }
+S²    is the complete graph on the set of variables S, S² = S×S
+C'(e) is a variant for bound expression:
+      If e is called at most once, or it is and stays a thunk (after the analysis),
+      it is simply C(e). Otherwise, the expression can be called multiple times
+      and we return (fv e)²
+
+The interesting cases of the analysis:
+ * Var v:
+   No other variables are being called.
+   Return {} (the empty graph)
+ * Lambda v e, under arity 0:
+   This means that e can be evaluated many times and we cannot get
+   any useful co-call information.
+   Return (fv e)²
+ * Case alternatives alt₁,alt₂,...:
+   Only one can be execuded, so
+   Return (alt₁ ∪ alt₂ ∪...)
+ * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:
+   We get the results from both sides, with the argument evaluated at most once.
+   Additionally, anything called by e₁ can possibly be called with anything
+   from e₂.
+   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)
+ * App e₁ x:
+   As this is already in A-normal form, CorePrep will not separately lambda
+   bind (and hence share) x. So we conservatively assume multiple calls to x here
+   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}
+ * Let v = rhs in body:
+   In addition to the results from the subexpressions, add all co-calls from
+   everything that the body calls together with v to everthing that is called
+   by v.
+   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}
+ * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body
+   Tricky.
+   We assume that it is really mutually recursive, i.e. that every variable
+   calls one of the others, and that this is strongly connected (otherwise we
+   return an over-approximation, so that's ok), see note [Recursion and fixpointing].
+
+   Let V = {v₁,...vₙ}.
+   Assume that the vs have been analysed with an incoming demand and
+   cardinality consistent with the final result (this is the fixed-pointing).
+   Again we can use the results from all subexpressions.
+   In addition, for every variable vᵢ, we need to find out what it is called
+   with (call this set Sᵢ). There are two cases:
+    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,
+      and collect every variable that is called together with any variable from V:
+      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
+    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to
+      exclude it from this set:
+      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
+   Finally, combine all this:
+   Return: C(body) ∪
+           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪
+           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)
+
+Using the result: Eta-Expansion
+-------------------------------
+
+We use the result of these two analyses to decide whether we can eta-expand the
+rhs of a let-bound variable.
+
+If the variable is already a function (exprIsCheap), and all calls to the
+variables have a higher arity than the current manifest arity (i.e. the number
+of lambdas), expand.
+
+If the variable is a thunk we must be careful: Eta-Expansion will prevent
+sharing of work, so this is only safe if there is at most one call to the
+function. Therefore, we check whether {v,v} ∈ G.
+
+    Example:
+
+        let n = case .. of .. -- A thunk!
+        in n 0 + n 1
+
+    vs.
+
+        let n = case .. of ..
+        in case .. of T -> n 0
+                      F -> n 1
+
+    We are only allowed to eta-expand `n` if it is going to be called at most
+    once in the body of the outer let. So we need to know, for each variable
+    individually, that it is going to be called at most once.
+
+
+Why the co-call graph?
+----------------------
+
+Why is it not sufficient to simply remember which variables are called once and
+which are called multiple times? It would be in the previous example, but consider
+
+        let n = case .. of ..
+        in case .. of
+            True -> let go = \y -> case .. of
+                                     True -> go (y + n 1)
+                                     False > n
+                    in go 1
+            False -> n
+
+vs.
+
+        let n = case .. of ..
+        in case .. of
+            True -> let go = \y -> case .. of
+                                     True -> go (y+1)
+                                     False > n
+                    in go 1
+            False -> n
+
+In both cases, the body and the rhs of the inner let call n at most once.
+But only in the second case that holds for the whole expression! The
+crucial difference is that in the first case, the rhs of `go` can call
+*both* `go` and `n`, and hence can call `n` multiple times as it recurses,
+while in the second case find out that `go` and `n` are not called together.
+
+
+Why co-call information for functions?
+--------------------------------------
+
+Although for eta-expansion we need the information only for thunks, we still
+need to know whether functions are being called once or multiple times, and
+together with what other functions.
+
+    Example:
+
+        let n = case .. of ..
+            f x = n (x+1)
+        in f 1 + f 2
+
+    vs.
+
+        let n = case .. of ..
+            f x = n (x+1)
+        in case .. of T -> f 0
+                      F -> f 1
+
+    Here, the body of f calls n exactly once, but f itself is being called
+    multiple times, so eta-expansion is not allowed.
+
+
+Note [Analysis type signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The work-hourse of the analysis is the function `callArityAnal`, with the
+following type:
+
+    type CallArityRes = (UnVarGraph, VarEnv Arity)
+    callArityAnal ::
+        Arity ->  -- The arity this expression is called with
+        VarSet -> -- The set of interesting variables
+        CoreExpr ->  -- The expression to analyse
+        (CallArityRes, CoreExpr)
+
+and the following specification:
+
+  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr
+
+                            <=>
+
+  Assume the expression `expr` is being passed `arity` arguments. Then it holds that
+    * The domain of `callArityEnv` is a subset of `interestingIds`.
+    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`
+      is absent, i.e. not called at all.
+    * Every call from `expr` to a variable bound to n in `callArityEnv` has at
+      least n value arguments.
+    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,
+      then in no execution of `expr` both are being called.
+  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.
+
+
+Note [Which variables are interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The analysis would quickly become prohibitive expensive if we would analyse all
+variables; for most variables we simply do not care about how often they are
+called, i.e. variables bound in a pattern match. So interesting are variables that are
+ * top-level or let bound
+ * and possibly functions (typeArity > 0)
+
+Note [Taking boring variables into account]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+If we decide that the variable bound in `let x = e1 in e2` is not interesting,
+the analysis of `e2` will not report anything about `x`. To ensure that
+`callArityBind` does still do the right thing we have to take that into account
+everytime we would be lookup up `x` in the analysis result of `e2`.
+  * Instead of calling lookupCallArityRes, we return (0, True), indicating
+    that this variable might be called many times with no arguments.
+  * Instead of checking `calledWith x`, we assume that everything can be called
+    with it.
+  * In the recursive case, when calclulating the `cross_calls`, if there is
+    any boring variable in the recursive group, we ignore all co-call-results
+    and directly go to a very conservative assumption.
+
+The last point has the nice side effect that the relatively expensive
+integration of co-call results in a recursive groups is often skipped. This
+helped to avoid the compile time blowup in some real-world code with large
+recursive groups (#10293).
+
+Note [Recursion and fixpointing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For a mutually recursive let, we begin by
+ 1. analysing the body, using the same incoming arity as for the whole expression.
+ 2. Then we iterate, memoizing for each of the bound variables the last
+    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.
+ 3. We combine the analysis result from the body and the memoized results for
+    the arguments (if already present).
+ 4. For each variable, we find out the incoming arity and whether it is called
+    once, based on the current analysis result. If this differs from the
+    memoized results, we re-analyse the rhs and update the memoized table.
+ 5. If nothing had to be reanalyzed, we are done.
+    Otherwise, repeat from step 3.
+
+
+Note [Thunks in recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We never eta-expand a thunk in a recursive group, on the grounds that if it is
+part of a recursive group, then it will be called multiple times.
+
+This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not
+t1) in the following code:
+
+  let go x = t1
+      t1 = if ... then t2 else ...
+      t2 = if ... then go 1 else ...
+  in go 0
+
+Detecting this would require finding out what variables are only ever called
+from thunks. While this is certainly possible, we yet have to see this to be
+relevant in the wild.
+
+
+Note [Analysing top-level binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We can eta-expand top-level-binds if they are not exported, as we see all calls
+to them. The plan is as follows: Treat the top-level binds as nested lets around
+a body representing “all external calls”, which returns a pessimistic
+CallArityRes (the co-call graph is the complete graph, all arityies 0).
+
+Note [Trimming arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the Call Arity papers, we are working on an untyped lambda calculus with no
+other id annotations, where eta-expansion is always possible. But this is not
+the case for Core!
+ 1. We need to ensure the invariant
+      callArity e <= typeArity (exprType e)
+    for the same reasons that exprArity needs this invariant (see Note
+    [exprArity invariant] in CoreArity).
+
+    If we are not doing that, a too-high arity annotation will be stored with
+    the id, confusing the simplifier later on.
+
+ 2. Eta-expanding a right hand side might invalidate existing annotations. In
+    particular, if an id has a strictness annotation of <...><...>b, then
+    passing two arguments to it will definitely bottom out, so the simplifier
+    will throw away additional parameters. This conflicts with Call Arity! So
+    we ensure that we never eta-expand such a value beyond the number of
+    arguments mentioned in the strictness signature.
+    See #10176 for a real-world-example.
+
+Note [What is a thunk]
+~~~~~~~~~~~~~~~~~~~~~~
+
+Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a
+thunk, not eta-expanded, to avoid losing any sharing. This is also how the
+published papers on Call Arity describe it.
+
+In practice, there are thunks that do a just little work, such as
+pattern-matching on a variable, and the benefits of eta-expansion likely
+outweigh the cost of doing that repeatedly. Therefore, this implementation of
+Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.
+
+Note [Call Arity and Join Points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The Call Arity analysis does not care about join points, and treats them just
+like normal functions. This is ok.
+
+The analysis *could* make use of the fact that join points are always evaluated
+in the same context as the join-binding they are defined in and are always
+one-shot, and handle join points separately, as suggested in
+https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870.
+This *might* be more efficient (for example, join points would not have to be
+considered interesting variables), but it would also add redundant code. So for
+now we do not do that.
+
+The simplifier never eta-expands join points (it instead pushes extra arguments from
+an eta-expanded context into the join point’s RHS), so the call arity
+annotation on join points is not actually used. As it would be equally valid
+(though less efficient) to eta-expand join points, this is the simplifier's
+choice, and hence Call Arity sets the call arity for join points as well.
+-}
+
+-- Main entry point
+
+callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
+callArityAnalProgram _dflags binds = binds'
+  where
+    (_, binds') = callArityTopLvl [] emptyVarSet binds
+
+-- See Note [Analysing top-level-binds]
+callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
+callArityTopLvl exported _ []
+    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])
+      , [] )
+callArityTopLvl exported int1 (b:bs)
+    = (ae2, b':bs')
+  where
+    int2 = bindersOf b
+    exported' = filter isExportedId int2 ++ exported
+    int' = int1 `addInterestingBinds` b
+    (ae1, bs') = callArityTopLvl exported' int' bs
+    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b
+
+
+callArityRHS :: CoreExpr -> CoreExpr
+callArityRHS = snd . callArityAnal 0 emptyVarSet
+
+-- The main analysis function. See Note [Analysis type signature]
+callArityAnal ::
+    Arity ->  -- The arity this expression is called with
+    VarSet -> -- The set of interesting variables
+    CoreExpr ->  -- The expression to analyse
+    (CallArityRes, CoreExpr)
+        -- How this expression uses its interesting variables
+        -- and the expression with IdInfo updated
+
+-- The trivial base cases
+callArityAnal _     _   e@(Lit _)
+    = (emptyArityRes, e)
+callArityAnal _     _   e@(Type _)
+    = (emptyArityRes, e)
+callArityAnal _     _   e@(Coercion _)
+    = (emptyArityRes, e)
+-- The transparent cases
+callArityAnal arity int (Tick t e)
+    = second (Tick t) $ callArityAnal arity int e
+callArityAnal arity int (Cast e co)
+    = second (\e -> Cast e co) $ callArityAnal arity int e
+
+-- The interesting case: Variables, Lambdas, Lets, Applications, Cases
+callArityAnal arity int e@(Var v)
+    | v `elemVarSet` int
+    = (unitArityRes v arity, e)
+    | otherwise
+    = (emptyArityRes, e)
+
+-- Non-value lambdas are ignored
+callArityAnal arity int (Lam v e) | not (isId v)
+    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e
+
+-- We have a lambda that may be called multiple times, so its free variables
+-- can all be co-called.
+callArityAnal 0     int (Lam v e)
+    = (ae', Lam v e')
+  where
+    (ae, e') = callArityAnal 0 (int `delVarSet` v) e
+    ae' = calledMultipleTimes ae
+-- We have a lambda that we are calling. decrease arity.
+callArityAnal arity int (Lam v e)
+    = (ae, Lam v e')
+  where
+    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e
+
+-- Application. Increase arity for the called expression, nothing to know about
+-- the second
+callArityAnal arity int (App e (Type t))
+    = second (\e -> App e (Type t)) $ callArityAnal arity int e
+callArityAnal arity int (App e1 e2)
+    = (final_ae, App e1' e2')
+  where
+    (ae1, e1') = callArityAnal (arity + 1) int e1
+    (ae2, e2') = callArityAnal 0           int e2
+    -- If the argument is trivial (e.g. a variable), then it will _not_ be
+    -- let-bound in the Core to STG transformation (CorePrep actually),
+    -- so no sharing will happen here, and we have to assume many calls.
+    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2
+         | otherwise        = ae2
+    final_ae = ae1 `both` ae2'
+
+-- Case expression.
+callArityAnal arity int (Case scrut bndr ty alts)
+    = -- pprTrace "callArityAnal:Case"
+      --          (vcat [ppr scrut, ppr final_ae])
+      (final_ae, Case scrut' bndr ty alts')
+  where
+    (alt_aes, alts') = unzip $ map go alts
+    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e
+                        in  (ae, (dc, bndrs, e'))
+    alt_ae = lubRess alt_aes
+    (scrut_ae, scrut') = callArityAnal 0 int scrut
+    final_ae = scrut_ae `both` alt_ae
+
+-- For lets, use callArityBind
+callArityAnal arity int (Let bind e)
+  = -- pprTrace "callArityAnal:Let"
+    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
+    (final_ae, Let bind' e')
+  where
+    int_body = int `addInterestingBinds` bind
+    (ae_body, e') = callArityAnal arity int_body e
+    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind
+
+-- Which bindings should we look at?
+-- See Note [Which variables are interesting]
+isInteresting :: Var -> Bool
+isInteresting v = not $ null (typeArity (idType v))
+
+interestingBinds :: CoreBind -> [Var]
+interestingBinds = filter isInteresting . bindersOf
+
+boringBinds :: CoreBind -> VarSet
+boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf
+
+addInterestingBinds :: VarSet -> CoreBind -> VarSet
+addInterestingBinds int bind
+    = int `delVarSetList`    bindersOf bind -- Possible shadowing
+          `extendVarSetList` interestingBinds bind
+
+-- Used for both local and top-level binds
+-- Second argument is the demand from the body
+callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
+-- Non-recursive let
+callArityBind boring_vars ae_body int (NonRec v rhs)
+  | otherwise
+  = -- pprTrace "callArityBind:NonRec"
+    --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
+    (final_ae, NonRec v' rhs')
+  where
+    is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
+    -- If v is boring, we will not find it in ae_body, but always assume (0, False)
+    boring = v `elemVarSet` boring_vars
+
+    (arity, called_once)
+        | boring    = (0, False) -- See Note [Taking boring variables into account]
+        | otherwise = lookupCallArityRes ae_body v
+    safe_arity | called_once = arity
+               | is_thunk    = 0      -- A thunk! Do not eta-expand
+               | otherwise   = arity
+
+    -- See Note [Trimming arity]
+    trimmed_arity = trimArity v safe_arity
+
+    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs
+
+
+    ae_rhs'| called_once     = ae_rhs
+           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
+           | otherwise       = calledMultipleTimes ae_rhs
+
+    called_by_v = domRes ae_rhs'
+    called_with_v
+        | boring    = domRes ae_body
+        | otherwise = calledWith ae_body v `delUnVarSet` v
+    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body
+
+    v' = v `setIdCallArity` trimmed_arity
+
+
+-- Recursive let. See Note [Recursion and fixpointing]
+callArityBind boring_vars ae_body int b@(Rec binds)
+  = -- (if length binds > 300 then
+    -- pprTrace "callArityBind:Rec"
+    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $
+    (final_ae, Rec binds')
+  where
+    -- See Note [Taking boring variables into account]
+    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]
+
+    int_body = int `addInterestingBinds` b
+    (ae_rhs, binds') = fix initial_binds
+    final_ae = bindersOf b `resDelList` ae_rhs
+
+    initial_binds = [(i,Nothing,e) | (i,e) <- binds]
+
+    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])
+    fix ann_binds
+        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $
+          any_change
+        = fix ann_binds'
+        | otherwise
+        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')
+      where
+        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]
+        ae = callArityRecEnv any_boring aes_old ae_body
+
+        rerun (i, mbLastRun, rhs)
+            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)
+            -- No call to this yet, so do nothing
+            = (False, (i, Nothing, rhs))
+
+            | Just (old_called_once, old_arity, _) <- mbLastRun
+            , called_once == old_called_once
+            , new_arity == old_arity
+            -- No change, no need to re-analyze
+            = (False, (i, mbLastRun, rhs))
+
+            | otherwise
+            -- We previously analyzed this with a different arity (or not at all)
+            = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
+
+                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]
+                             | otherwise   = new_arity
+
+                  -- See Note [Trimming arity]
+                  trimmed_arity = trimArity i safe_arity
+
+                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs
+
+                  ae_rhs' | called_once     = ae_rhs
+                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
+                          | otherwise       = calledMultipleTimes ae_rhs
+
+                  i' = i `setIdCallArity` trimmed_arity
+
+              in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))
+          where
+            -- See Note [Taking boring variables into account]
+            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)
+                                     | otherwise                  = lookupCallArityRes ae i
+
+        (changes, ann_binds') = unzip $ map rerun ann_binds
+        any_change = or changes
+
+-- Combining the results from body and rhs, (mutually) recursive case
+-- See Note [Analysis II: The Co-Called analysis]
+callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes
+callArityRecEnv any_boring ae_rhss ae_body
+    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $
+      ae_new
+  where
+    vars = map fst ae_rhss
+
+    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body
+
+    cross_calls
+        -- See Note [Taking boring variables into account]
+        | any_boring               = completeGraph (domRes ae_combined)
+        -- Also, calculating cross_calls is expensive. Simply be conservative
+        -- if the mutually recursive group becomes too large.
+        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)
+        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss
+    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
+      where
+        is_thunk = idCallArity v == 0
+        -- What rhs are relevant as happening before (or after) calling v?
+        --    If v is a thunk, everything from all the _other_ variables
+        --    If v is not a thunk, everything can happen.
+        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body
+                    | otherwise = ae_combined
+        -- What do we want to know from these?
+        -- Which calls can happen next to any recursive call.
+        called_with_v
+            = unionUnVarSets $ map (calledWith ae_before_v) vars
+        called_by_v = domRes ae_rhs
+
+    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined
+
+-- See Note [Trimming arity]
+trimArity :: Id -> Arity -> Arity
+trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
+  where
+    max_arity_by_type = length (typeArity (idType v))
+    max_arity_by_strsig
+        | isBotRes result_info = length demands
+        | otherwise = a
+
+    (demands, result_info) = splitStrictSig (idStrictness v)
+
+---------------------------------------
+-- Functions related to CallArityRes --
+---------------------------------------
+
+-- Result type for the two analyses.
+-- See Note [Analysis I: The arity analysis]
+-- and Note [Analysis II: The Co-Called analysis]
+type CallArityRes = (UnVarGraph, VarEnv Arity)
+
+emptyArityRes :: CallArityRes
+emptyArityRes = (emptyUnVarGraph, emptyVarEnv)
+
+unitArityRes :: Var -> Arity -> CallArityRes
+unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)
+
+resDelList :: [Var] -> CallArityRes -> CallArityRes
+resDelList vs ae = foldr resDel ae vs
+
+resDel :: Var -> CallArityRes -> CallArityRes
+resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)
+
+domRes :: CallArityRes -> UnVarSet
+domRes (_, ae) = varEnvDom ae
+
+-- In the result, find out the minimum arity and whether the variable is called
+-- at most once.
+lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
+lookupCallArityRes (g, ae) v
+    = case lookupVarEnv ae v of
+        Just a -> (a, not (g `hasLoopAt` v))
+        Nothing -> (0, False)
+
+calledWith :: CallArityRes -> Var -> UnVarSet
+calledWith (g, _) v = neighbors g v
+
+addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
+addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)
+
+-- Replaces the co-call graph by a complete graph (i.e. no information)
+calledMultipleTimes :: CallArityRes -> CallArityRes
+calledMultipleTimes res = first (const (completeGraph (domRes res))) res
+
+-- Used for application and cases
+both :: CallArityRes -> CallArityRes -> CallArityRes
+both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2
+
+-- Used when combining results from alternative cases; take the minimum
+lubRes :: CallArityRes -> CallArityRes -> CallArityRes
+lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)
+
+lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
+lubArityEnv = plusVarEnv_C min
+
+lubRess :: [CallArityRes] -> CallArityRes
+lubRess = foldl' lubRes emptyArityRes
diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/Exitify.hs
@@ -0,0 +1,499 @@
+module Exitify ( exitifyProgram ) where
+
+{-
+Note [Exitification]
+~~~~~~~~~~~~~~~~~~~~
+
+This module implements Exitification. The goal is to pull as much code out of
+recursive functions as possible, as the simplifier is better at inlining into
+call-sites that are not in recursive functions.
+
+Example:
+
+  let t = foo bar
+  joinrec go 0     x y = t (x*x)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+We’d like to inline `t`, but that does not happen: Because t is a thunk and is
+used in a recursive function, doing so might lose sharing in general. In
+this case, however, `t` is on the _exit path_ of `go`, so called at most once.
+How do we make this clearly visible to the simplifier?
+
+A code path (i.e., an expression in a tail-recursive position) in a recursive
+function is an exit path if it does not contain a recursive call. We can bind
+this expression outside the recursive function, as a join-point.
+
+Example result:
+
+  let t = foo bar
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+Now `t` is no longer in a recursive function, and good things happen!
+-}
+
+import GhcPrelude
+import Var
+import Id
+import IdInfo
+import CoreSyn
+import CoreUtils
+import State
+import Unique
+import VarSet
+import VarEnv
+import CoreFVs
+import FastString
+import Type
+import Util( mapSnd )
+
+import Data.Bifunctor
+import Control.Monad
+
+-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.
+-- The really interesting function is exitifyRec
+exitifyProgram :: CoreProgram -> CoreProgram
+exitifyProgram binds = map goTopLvl binds
+  where
+    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)
+    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)
+      -- Top-level bindings are never join points
+
+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds
+
+    go :: InScopeSet -> CoreExpr -> CoreExpr
+    go _    e@(Var{})       = e
+    go _    e@(Lit {})      = e
+    go _    e@(Type {})     = e
+    go _    e@(Coercion {}) = e
+    go in_scope (Cast e' c) = Cast (go in_scope e') c
+    go in_scope (Tick t e') = Tick t (go in_scope e')
+    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)
+
+    go in_scope (Lam v e')
+      = Lam v (go in_scope' e')
+      where in_scope' = in_scope `extendInScopeSet` v
+
+    go in_scope (Case scrut bndr ty alts)
+      = Case (go in_scope scrut) bndr ty (map go_alt alts)
+      where
+        in_scope1 = in_scope `extendInScopeSet` bndr
+        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)
+           where in_scope' = in_scope1 `extendInScopeSetList` pats
+
+    go in_scope (Let (NonRec bndr rhs) body)
+      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)
+      where
+        in_scope' = in_scope `extendInScopeSet` bndr
+
+    go in_scope (Let (Rec pairs) body)
+      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
+      | otherwise   = Let (Rec pairs') body'
+      where
+        is_join_rec = any (isJoinId . fst) pairs
+        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)
+        pairs'      = mapSnd (go in_scope') pairs
+        body'       = go in_scope' body
+
+
+-- | State Monad used inside `exitify`
+type ExitifyM =  State [(JoinId, CoreExpr)]
+
+-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
+--   join-points outside the joinrec.
+exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
+exitifyRec in_scope pairs
+  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
+  where
+    -- We need the set of free variables of many subexpressions here, so
+    -- annotate the AST with them
+    -- see Note [Calculating free variables]
+    ann_pairs = map (second freeVars) pairs
+
+    -- Which are the recursive calls?
+    recursive_calls = mkVarSet $ map fst pairs
+
+    (pairs',exits) = (`runState` []) $ do
+        forM ann_pairs $ \(x,rhs) -> do
+            -- go past the lambdas of the join point
+            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
+            body' <- go args body
+            let rhs' = mkLams args body'
+            return (x, rhs')
+
+    ---------------------
+    -- 'go' is the main working function.
+    -- It goes through the RHS (tail-call positions only),
+    -- checks if there are no more recursive calls, if so, abstracts over
+    -- variables bound on the way and lifts it out as a join point.
+    --
+    -- ExitifyM is a state monad to keep track of floated binds
+    go :: [Var]           -- ^ Variables that are in-scope here, but
+                          -- not in scope at the joinrec; that is,
+                          -- we must potentially abstract over them.
+                          -- Invariant: they are kept in dependency order
+       -> CoreExprWithFVs -- ^ Current expression in tail position
+       -> ExitifyM CoreExpr
+
+    -- We first look at the expression (no matter what it shape is)
+    -- and determine if we can turn it into a exit join point
+    go captured ann_e
+        | -- An exit expression has no recursive calls
+          let fvs = dVarSetToVarSet (freeVarsOf ann_e)
+        , disjointVarSet fvs recursive_calls
+        = go_exit captured (deAnnotate ann_e) fvs
+
+    -- We could not turn it into a exit joint point. So now recurse
+    -- into all expression where eligible exit join points might sit,
+    -- i.e. into all tail-call positions:
+
+    -- Case right hand sides are in tail-call position
+    go captured (_, AnnCase scrut bndr ty alts) = do
+        alts' <- forM alts $ \(dc, pats, rhs) -> do
+            rhs' <- go (captured ++ [bndr] ++ pats) rhs
+            return (dc, pats, rhs')
+        return $ Case (deAnnotate scrut) bndr ty alts'
+
+    go captured (_, AnnLet ann_bind body)
+        -- join point, RHS and body are in tail-call position
+        | AnnNonRec j rhs <- ann_bind
+        , Just join_arity <- isJoinId_maybe j
+        = do let (params, join_body) = collectNAnnBndrs join_arity rhs
+             join_body' <- go (captured ++ params) join_body
+             let rhs' = mkLams params join_body'
+             body' <- go (captured ++ [j]) body
+             return $ Let (NonRec j rhs') body'
+
+        -- rec join point, RHSs and body are in tail-call position
+        | AnnRec pairs <- ann_bind
+        , isJoinId (fst (head pairs))
+        = do let js = map fst pairs
+             pairs' <- forM pairs $ \(j,rhs) -> do
+                 let join_arity = idJoinArity j
+                     (params, join_body) = collectNAnnBndrs join_arity rhs
+                 join_body' <- go (captured ++ js ++ params) join_body
+                 let rhs' = mkLams params join_body'
+                 return (j, rhs')
+             body' <- go (captured ++ js) body
+             return $ Let (Rec pairs') body'
+
+        -- normal Let, only the body is in tail-call position
+        | otherwise
+        = do body' <- go (captured ++ bindersOf bind ) body
+             return $ Let bind body'
+      where bind = deAnnBind ann_bind
+
+    -- Cannot be turned into an exit join point, but also has no
+    -- tail-call subexpression. Nothing to do here.
+    go _ ann_e = return (deAnnotate ann_e)
+
+    ---------------------
+    go_exit :: [Var]      -- Variables captured locally
+            -> CoreExpr   -- An exit expression
+            -> VarSet     -- Free vars of the expression
+            -> ExitifyM CoreExpr
+    -- go_exit deals with a tail expression that is floatable
+    -- out as an exit point; that is, it mentions no recursive calls
+    go_exit captured e fvs
+      -- Do not touch an expression that is already a join jump where all arguments
+      -- are captured variables. See Note [Idempotency]
+      -- But _do_ float join jumps with interesting arguments.
+      -- See Note [Jumps can be interesting]
+      | (Var f, args) <- collectArgs e
+      , isJoinId f
+      , all isCapturedVarArg args
+      = return e
+
+      -- Do not touch a boring expression (see Note [Interesting expression])
+      | not is_interesting
+      = return e
+
+      -- Cannot float out if local join points are used, as
+      -- we cannot abstract over them
+      | captures_join_points
+      = return e
+
+      -- We have something to float out!
+      | otherwise
+      = do { -- Assemble the RHS of the exit join point
+             let rhs   = mkLams abs_vars e
+                 avoid = in_scope `extendInScopeSetList` captured
+             -- Remember this binding under a suitable name
+           ; v <- addExit avoid (length abs_vars) rhs
+             -- And jump to it from here
+           ; return $ mkVarApps (Var v) abs_vars }
+
+      where
+        -- Used to detect exit expressoins that are already proper exit jumps
+        isCapturedVarArg (Var v) = v `elem` captured
+        isCapturedVarArg _ = False
+
+        -- An interesting exit expression has free, non-imported
+        -- variables from outside the recursive group
+        -- See Note [Interesting expression]
+        is_interesting = anyVarSet isLocalId $
+                         fvs `minusVarSet` mkVarSet captured
+
+        -- The arguments of this exit join point
+        -- See Note [Picking arguments to abstract over]
+        abs_vars = snd $ foldr pick (fvs, []) captured
+          where
+            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)
+                               | otherwise           = (fvs',               acc)
+
+        -- We are going to abstract over these variables, so we must
+        -- zap any IdInfo they have; see #15005
+        -- cf. SetLevels.abstractVars
+        zap v | isId v = setIdInfo v vanillaIdInfo
+              | otherwise = v
+
+        -- We cannot abstract over join points
+        captures_join_points = any isJoinId abs_vars
+
+
+-- Picks a new unique, which is disjoint from
+--  * the free variables of the whole joinrec
+--  * any bound variables (captured)
+--  * any exit join points created so far.
+mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId
+mkExitJoinId in_scope ty join_arity = do
+    fs <- get
+    let avoid = in_scope `extendInScopeSetList` (map fst fs)
+                         `extendInScopeSet` exit_id_tmpl -- just cosmetics
+    return (uniqAway avoid exit_id_tmpl)
+  where
+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty
+                    `asJoinId` join_arity
+
+addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope join_arity rhs = do
+    -- Pick a suitable name
+    let ty = exprType rhs
+    v <- mkExitJoinId in_scope ty join_arity
+    fs <- get
+    put ((v,rhs):fs)
+    return v
+
+{-
+Note [Interesting expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want this to happen:
+
+  joinrec go 0     x y = x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = x
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+because the floated exit path (`x`) is simply a parameter of `go`; there are
+not useful interactions exposed this way.
+
+Neither do we want this to happen
+
+  joinrec go 0     x y = x+x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = x+x
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+where the floated expression `x+x` is a bit more complicated, but still not
+intersting.
+
+Expressions are interesting when they move an occurrence of a variable outside
+the recursive `go` that can benefit from being obviously called once, for example:
+ * a local thunk that can then be inlined (see example in note [Exitification])
+ * the parameter of a function, where the demand analyzer then can then
+   see that it is called at most once, and hence improve the function’s
+   strictness signature
+
+So we only hoist an exit expression out if it mentiones at least one free,
+non-imported variable.
+
+Note [Jumps can be interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A jump to a join point can be interesting, if its arguments contain free
+non-exported variables (z in the following example):
+
+  joinrec go 0     x y = jump j (x+z)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x y = jump j (x+z)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+
+
+The join point itself can be interesting, even if none if its
+arguments have free variables free in the joinrec.  For example
+
+  join j p = case p of (x,y) -> x+y
+  joinrec go 0     x y = jump j (x,y)
+          go (n-1) x y = jump go (n-1) (x+y) y
+  in …
+
+Here, `j` would not be inlined because we do not inline something that looks
+like an exit join point (see Note [Do not inline exit join points]). But
+if we exitify the 'jump j (x,y)' we get
+
+  join j p = case p of (x,y) -> x+y
+  join exit x y = jump j (x,y)
+  joinrec go 0     x y = jump exit x y
+          go (n-1) x y = jump go (n-1) (x+y) y
+  in …
+
+and now 'j' can inline, and we get rid of the pair. Here's another
+example (assume `g` to be an imported function that, on its own,
+does not make this interesting):
+
+  join j y = map f y
+  joinrec go 0     x y = jump j (map g x)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+Again, `j` would not be inlined because we do not inline something that looks
+like an exit join point (see Note [Do not inline exit join points]).
+
+But after exitification we have
+
+  join j y = map f y
+  join exit x = jump j (map g x)
+  joinrec go 0     x y = jump j (map g x)
+              go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+and now we can inline `j` and this will allow `map/map` to fire.
+
+
+Note [Idempotency]
+~~~~~~~~~~~~~~~~~~
+
+We do not want this to happen, where we replace the floated expression with
+essentially the same expression:
+
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = t (x*x)
+  join exit' x = jump exit x
+  joinrec go 0     x y = jump exit' x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+So when the RHS is a join jump, and all of its arguments are captured variables,
+then we leave it in place.
+
+Note that `jump exit x` in this example looks interesting, as `exit` is a free
+variable. Therefore, idempotency does not simply follow from floating only
+interesting expressions.
+
+Note [Calculating free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have two options where to annotate the tree with free variables:
+
+ A) The whole tree.
+ B) Each individual joinrec as we come across it.
+
+Downside of A: We pay the price on the whole module, even outside any joinrecs.
+Downside of B: We pay the price per joinrec, possibly multiple times when
+joinrecs are nested.
+
+Further downside of A: If the exitify function returns annotated expressions,
+it would have to ensure that the annotations are correct.
+
+We therefore choose B, and calculate the free variables in `exitify`.
+
+
+Note [Do not inline exit join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+
+  let t = foo bar
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+we do not want the simplifier to simply inline `exit` back in (which it happily
+would).
+
+To prevent this, we need to recognize exit join points, and then disable
+inlining.
+
+Exit join points, recognizeable using `isExitJoinId` are join points with an
+occurence in a recursive group, and can be recognized (after the occurence
+analyzer ran!) using `isExitJoinId`.
+This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
+because the lambdas of a non-recursive join point are not considered for
+`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked
+occ_in_lam, because `j2` is called only once.
+
+  join j1 x = x+1
+  join j2 y = join j1 (y+2)
+
+To prevent inlining, we check for isExitJoinId
+* In `preInlineUnconditionally` directly.
+* In `simplLetUnfolding` we simply give exit join points no unfolding, which
+  prevents inlining in `postInlineUnconditionally` and call sites.
+
+Note [Placement of the exitification pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I (Joachim) experimented with multiple positions for the Exitification pass in
+the Core2Core pipeline:
+
+ A) Before the `simpl_phases`
+ B) Between the `simpl_phases` and the "main" simplifier pass
+ C) After demand_analyser
+ D) Before the final simplification phase
+
+Here is the table (this is without inlining join exit points in the final
+simplifier run):
+
+        Program |                       Allocs                      |                      Instrs
+                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log
+----------------|---------------------------------------------------|-------------------------------------------------
+ fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%
+          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%
+            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%
+           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%
+   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%
+            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%
+         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%
+  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%
+----------------|---------------------------------------------------|-------------------------------------------------
+            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%
+            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%
+ Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%
+
+Position A is disqualified, as it does not get rid of the allocations in
+fannkuch-redux.
+Position A and B are disqualified because it increases instructions in k-nucleotide.
+Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.
+
+Assuming we have a budget of _one_ run of Exitification, then C wins (but we
+could get more from running it multiple times, as seen in fish).
+
+Note [Picking arguments to abstract over]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When we create an exit join point, so we need to abstract over those of its
+free variables that are be out-of-scope at the destination of the exit join
+point. So we go through the list `captured` and pick those that are actually
+free variables of the join point.
+
+We do not just `filter (`elemVarSet` fvs) captured`, as there might be
+shadowing, and `captured` may contain multiple variables with the same Unique. I
+these cases we want to abstract only over the last occurence, hence the `foldr`
+(with emphasis on the `r`). This is #15110.
+
+-}
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/FloatIn.hs
@@ -0,0 +1,771 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+************************************************************************
+*                                                                      *
+\section[FloatIn]{Floating Inwards pass}
+*                                                                      *
+************************************************************************
+
+The main purpose of @floatInwards@ is floating into branches of a
+case, so that we don't allocate things, save them on the stack, and
+then discover that they aren't needed in the chosen branch.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fprof-auto #-}
+
+module FloatIn ( floatInwards ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import MkCore hiding    ( wrapFloats )
+import HscTypes         ( ModGuts(..) )
+import CoreUtils
+import CoreFVs
+import CoreMonad        ( CoreM )
+import Id               ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )
+import Var
+import Type
+import VarSet
+import Util
+import DynFlags
+import Outputable
+-- import Data.List        ( mapAccumL )
+import BasicTypes       ( RecFlag(..), isRec )
+
+{-
+Top-level interface function, @floatInwards@.  Note that we do not
+actually float any bindings downwards from the top-level.
+-}
+
+floatInwards :: ModGuts -> CoreM ModGuts
+floatInwards pgm@(ModGuts { mg_binds = binds })
+  = do { dflags <- getDynFlags
+       ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }
+  where
+    fi_top_bind dflags (NonRec binder rhs)
+      = NonRec binder (fiExpr dflags [] (freeVars rhs))
+    fi_top_bind dflags (Rec pairs)
+      = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Mail from Andr\'e [edited]}
+*                                                                      *
+************************************************************************
+
+{\em Will wrote: What??? I thought the idea was to float as far
+inwards as possible, no matter what.  This is dropping all bindings
+every time it sees a lambda of any kind.  Help! }
+
+You are assuming we DO DO full laziness AFTER floating inwards!  We
+have to [not float inside lambdas] if we don't.
+
+If we indeed do full laziness after the floating inwards (we could
+check the compilation flags for that) then I agree we could be more
+aggressive and do float inwards past lambdas.
+
+Actually we are not doing a proper full laziness (see below), which
+was another reason for not floating inwards past a lambda.
+
+This can easily be fixed.  The problem is that we float lets outwards,
+but there are a few expressions which are not let bound, like case
+scrutinees and case alternatives.  After floating inwards the
+simplifier could decide to inline the let and the laziness would be
+lost, e.g.
+
+\begin{verbatim}
+let a = expensive             ==> \b -> case expensive of ...
+in \ b -> case a of ...
+\end{verbatim}
+The fix is
+\begin{enumerate}
+\item
+to let bind the algebraic case scrutinees (done, I think) and
+the case alternatives (except the ones with an
+unboxed type)(not done, I think). This is best done in the
+SetLevels.hs module, which tags things with their level numbers.
+\item
+do the full laziness pass (floating lets outwards).
+\item
+simplify. The simplifier inlines the (trivial) lets that were
+ created but were not floated outwards.
+\end{enumerate}
+
+With the fix I think Will's suggestion that we can gain even more from
+strictness by floating inwards past lambdas makes sense.
+
+We still gain even without going past lambdas, as things may be
+strict in the (new) context of a branch (where it was floated to) or
+of a let rhs, e.g.
+\begin{verbatim}
+let a = something            case x of
+in case x of                   alt1 -> case something of a -> a + a
+     alt1 -> a + a      ==>    alt2 -> b
+     alt2 -> b
+
+let a = something           let b = case something of a -> a + a
+in let b = a + a        ==> in (b,b)
+in (b,b)
+\end{verbatim}
+Also, even if a is not found to be strict in the new context and is
+still left as a let, if the branch is not taken (or b is not entered)
+the closure for a is not built.
+
+************************************************************************
+*                                                                      *
+\subsection{Main floating-inwards code}
+*                                                                      *
+************************************************************************
+-}
+
+type FreeVarSet  = DIdSet
+type BoundVarSet = DIdSet
+
+data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
+        -- The FreeVarSet is the free variables of the binding.  In the case
+        -- of recursive bindings, the set doesn't include the bound
+        -- variables.
+
+type FloatInBinds = [FloatInBind]
+        -- In reverse dependency order (innermost binder first)
+
+fiExpr :: DynFlags
+       -> FloatInBinds      -- Binds we're trying to drop
+                            -- as far "inwards" as possible
+       -> CoreExprWithFVs   -- Input expr
+       -> CoreExpr          -- Result
+
+fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)
+                                       -- See Note [Dead bindings]
+fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty
+fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
+fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
+fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))
+  = wrapFloats (drop_here ++ co_drop) $
+    Cast (fiExpr dflags e_drop expr) co
+  where
+    [drop_here, e_drop, co_drop]
+      = sepBindsByDropPoint dflags False
+          [freeVarsOf expr, freeVarsOfAnn co_ann]
+          to_drop
+
+{-
+Applications: we do float inside applications, mainly because we
+need to get at all the arguments.  The next simplifier run will
+pull out any silly ones.
+-}
+
+fiExpr dflags to_drop ann_expr@(_,AnnApp {})
+  = wrapFloats drop_here $ wrapFloats extra_drop $
+    mkTicks ticks $
+    mkApps (fiExpr dflags fun_drop ann_fun)
+           (zipWith (fiExpr dflags) arg_drops ann_args)
+  where
+    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
+    fun_ty  = exprType (deAnnotate ann_fun)
+    fun_fvs = freeVarsOf ann_fun
+    arg_fvs = map freeVarsOf ann_args
+
+    (drop_here : extra_drop : fun_drop : arg_drops)
+       = sepBindsByDropPoint dflags False
+                             (extra_fvs : fun_fvs : arg_fvs)
+                             to_drop
+         -- Shortcut behaviour: if to_drop is empty,
+         -- sepBindsByDropPoint returns a suitable bunch of empty
+         -- lists without evaluating extra_fvs, and hence without
+         -- peering into each argument
+
+    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
+    extra_fvs0 = case ann_fun of
+                   (_, AnnVar _) -> fun_fvs
+                   _             -> emptyDVarSet
+          -- Don't float the binding for f into f x y z; see Note [Join points]
+          -- for why we *can't* do it when f is a join point. (If f isn't a
+          -- join point, floating it in isn't especially harmful but it's
+          -- useless since the simplifier will immediately float it back out.)
+
+    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
+    add_arg (fun_ty, extra_fvs) (_, AnnType ty)
+      = (piResultTy fun_ty ty, extra_fvs)
+
+    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
+      | noFloatIntoArg arg arg_ty
+      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)
+      | otherwise
+      = (res_ty, extra_fvs)
+      where
+       (arg_ty, res_ty) = splitFunTy fun_ty
+
+{- Note [Dead bindings]
+~~~~~~~~~~~~~~~~~~~~~~~
+At a literal we won't usually have any floated bindings; the
+only way that can happen is if the binding wrapped the literal
+/in the original input program/.  e.g.
+   case x of { DEFAULT -> 1# }
+But, while this may be unusual it is not actually wrong, and it did
+once happen (#15696).
+
+Note [Do not destroy the let/app invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Watch out for
+   f (x +# y)
+We don't want to float bindings into here
+   f (case ... of { x -> x +# y })
+because that might destroy the let/app invariant, which requires
+unlifted function arguments to be ok-for-speculation.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+Generally, we don't need to worry about join points - there are places we're
+not allowed to float them, but since they can't have occurrences in those
+places, we're not tempted.
+
+We do need to be careful about jumps, however:
+
+  joinrec j x y z = ... in
+  jump j a b c
+
+Previous versions often floated the definition of a recursive function into its
+only non-recursive occurrence. But for a join point, this is a disaster:
+
+  (joinrec j x y z = ... in
+  jump j) a b c -- wrong!
+
+Every jump must be exact, so the jump to j must have three arguments. Hence
+we're careful not to float into the target of a jump (though we can float into
+the arguments just fine).
+
+Note [Floating in past a lambda group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* We must be careful about floating inside a value lambda.
+  That risks losing laziness.
+  The float-out pass might rescue us, but then again it might not.
+
+* We must be careful about type lambdas too.  At one time we did, and
+  there is no risk of duplicating work thereby, but we do need to be
+  careful.  In particular, here is a bad case (it happened in the
+  cichelli benchmark:
+        let v = ...
+        in let f = /\t -> \a -> ...
+           ==>
+        let f = /\t -> let v = ... in \a -> ...
+  This is bad as now f is an updatable closure (update PAP)
+  and has arity 0.
+
+* Hack alert!  We only float in through one-shot lambdas,
+  not (as you might guess) through lone big lambdas.
+  Reason: we float *out* past big lambdas (see the test in the Lam
+  case of FloatOut.floatExpr) and we don't want to float straight
+  back in again.
+
+  It *is* important to float into one-shot lambdas, however;
+  see the remarks with noFloatIntoRhs.
+
+So we treat lambda in groups, using the following rule:
+
+ Float in if (a) there is at least one Id,
+         and (b) there are no non-one-shot Ids
+
+ Otherwise drop all the bindings outside the group.
+
+This is what the 'go' function in the AnnLam case is doing.
+
+(Join points are handled similarly: a join point is considered one-shot iff
+it's non-recursive, so we float only into non-recursive join points.)
+
+Urk! if all are tyvars, and we don't float in, we may miss an
+      opportunity to float inside a nested case branch
+
+
+Note [Floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We could, in principle, have a coercion binding like
+   case f x of co { DEFAULT -> e1 e2 }
+It's not common to have a function that returns a coercion, but nothing
+in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2
+/only in a type/.  E.g. suppose e1 was
+  let (x :: Int |> co) = blah in blah2
+
+
+But, with coercions appearing in types, there is a complication: we
+might be floating in a "strict let" -- that is, a case. Case expressions
+mention their return type. We absolutely can't float a coercion binding
+inward to the point that the type of the expression it's about to wrap
+mentions the coercion. So we include the union of the sets of free variables
+of the types of all the drop points involved. If any of the floaters
+bind a coercion variable mentioned in any of the types, that binder must
+be dropped right away.
+
+-}
+
+fiExpr dflags to_drop lam@(_, AnnLam _ _)
+  | noFloatIntoLam bndrs       -- Dump it all here
+     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088
+  = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))
+
+  | otherwise           -- Float inside
+  = mkLams bndrs (fiExpr dflags to_drop body)
+
+  where
+    (bndrs, body) = collectAnnBndrs lam
+
+{-
+We don't float lets inwards past an SCC.
+        ToDo: keep info on current cc, and when passing
+        one, if it is not the same, annotate all lets in binds with current
+        cc, change current cc to the new one and float binds into expr.
+-}
+
+fiExpr dflags to_drop (_, AnnTick tickish expr)
+  | tickish `tickishScopesLike` SoftScope
+  = Tick tickish (fiExpr dflags to_drop expr)
+
+  | otherwise -- Wimp out for now - we could push values in
+  = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))
+
+{-
+For @Lets@, the possible ``drop points'' for the \tr{to_drop}
+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
+or~(b2), in each of the RHSs of the pairs of a @Rec@.
+
+Note that we do {\em weird things} with this let's binding.  Consider:
+\begin{verbatim}
+let
+    w = ...
+in {
+    let v = ... w ...
+    in ... v .. w ...
+}
+\end{verbatim}
+Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
+body of the inner let, we could panic and leave \tr{w}'s binding where
+it is.  But \tr{v} is floatable further into the body of the inner let, and
+{\em then} \tr{w} will also be only in the body of that inner let.
+
+So: rather than drop \tr{w}'s binding here, we add it onto the list of
+things to drop in the outer let's body, and let nature take its
+course.
+
+Note [extra_fvs (1): avoid floating into RHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider let x=\y....t... in body.  We do not necessarily want to float
+a binding for t into the RHS, because it'll immediately be floated out
+again.  (It won't go inside the lambda else we risk losing work.)
+In letrec, we need to be more careful still. We don't want to transform
+        let x# = y# +# 1#
+        in
+        letrec f = \z. ...x#...f...
+        in ...
+into
+        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
+because now we can't float the let out again, because a letrec
+can't have unboxed bindings.
+
+So we make "extra_fvs" which is the rhs_fvs of such bindings, and
+arrange to dump bindings that bind extra_fvs before the entire let.
+
+Note [extra_fvs (2): free variables of rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  let x{rule mentioning y} = rhs in body
+Here y is not free in rhs or body; but we still want to dump bindings
+that bind y outside the let.  So we augment extra_fvs with the
+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
+idFreeVars.
+-}
+
+fiExpr dflags to_drop (_,AnnLet bind body)
+  = fiExpr dflags (after ++ new_float : before) body
+           -- to_drop is in reverse dependency order
+  where
+    (before, new_float, after) = fiBind dflags to_drop bind body_fvs
+    body_fvs    = freeVarsOf body
+
+{- Note [Floating primops]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We try to float-in a case expression over an unlifted type.  The
+motivating example was #5658: in particular, this change allows
+array indexing operations, which have a single DEFAULT alternative
+without any binders, to be floated inward.
+
+SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
+scalars also need to be floated inward, but unpacks have a single non-DEFAULT
+alternative that binds the elements of the tuple. We now therefore also support
+floating in cases with a single alternative that may bind values.
+
+But there are wrinkles
+
+* Which unlifted cases do we float? See PrimOp.hs
+  Note [PrimOp can_fail and has_side_effects] which explains:
+   - We can float-in can_fail primops, but we can't float them out.
+   - But we can float a has_side_effects primop, but NOT inside a lambda,
+     so for now we don't float them at all.
+  Hence exprOkForSideEffects
+
+* Because we can float can-fail primops (array indexing, division) inwards
+  but not outwards, we must be careful not to transform
+     case a /# b of r -> f (F# r)
+  ===>
+    f (case a /# b of r -> F# r)
+  because that creates a new thunk that wasn't there before.  And
+  because it can't be floated out (can_fail), the thunk will stay
+  there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)
+
+  Solution: only float cases into the branches of other cases, and
+  not into the arguments of an application, or the RHS of a let. This
+  is somewhat conservative, but it's simple.  And it still hits the
+  cases like #5658.   This is implemented in sepBindsByJoinPoint;
+  if is_case is False we dump all floating cases right here.
+
+* #14511 is another example of why we want to restrict float-in
+  of case-expressions.  Consider
+     case indexArray# a n of (# r #) -> writeArray# ma i (f r)
+  Now, floating that indexing operation into the (f r) thunk will
+  not create any new thunks, but it will keep the array 'a' alive
+  for much longer than the programmer expected.
+
+  So again, not floating a case into a let or argument seems like
+  the Right Thing
+
+For @Case@, the possible drop points for the 'to_drop'
+bindings are:
+  (a) inside the scrutinee
+  (b) inside one of the alternatives/default (default FVs always /first/!).
+
+-}
+
+fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
+  | isUnliftedType (idType case_bndr)
+  , exprOkForSideEffects (deAnnotate scrut)
+      -- See Note [Floating primops]
+  = wrapFloats shared_binds $
+    fiExpr dflags (case_float : rhs_binds) rhs
+  where
+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
+                    (FloatCase scrut' case_bndr con alt_bndrs)
+    scrut'     = fiExpr dflags scrut_binds scrut
+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
+    scrut_fvs  = freeVarsOf scrut
+
+    [shared_binds, scrut_binds, rhs_binds]
+       = sepBindsByDropPoint dflags False
+           [scrut_fvs, rhs_fvs]
+           to_drop
+
+fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
+  = wrapFloats drop_here1 $
+    wrapFloats drop_here2 $
+    Case (fiExpr dflags scrut_drops scrut) case_bndr ty
+         (zipWith fi_alt alts_drops_s alts)
+  where
+        -- Float into the scrut and alts-considered-together just like App
+    [drop_here1, scrut_drops, alts_drops]
+       = sepBindsByDropPoint dflags False
+           [scrut_fvs, all_alts_fvs]
+           to_drop
+
+        -- Float into the alts with the is_case flag set
+    (drop_here2 : alts_drops_s)
+      | [ _ ] <- alts = [] : [alts_drops]
+      | otherwise     = sepBindsByDropPoint dflags True alts_fvs alts_drops
+
+    scrut_fvs    = freeVarsOf scrut
+    alts_fvs     = map alt_fvs alts
+    all_alts_fvs = unionDVarSets alts_fvs
+    alt_fvs (_con, args, rhs)
+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
+           -- Delete case_bndr and args from free vars of rhs
+           -- to get free vars of alt
+
+    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)
+
+------------------
+fiBind :: DynFlags
+       -> FloatInBinds      -- Binds we're trying to drop
+                            -- as far "inwards" as possible
+       -> CoreBindWithFVs   -- Input binding
+       -> DVarSet           -- Free in scope of binding
+       -> ( FloatInBinds    -- Land these before
+          , FloatInBind     -- The binding itself
+          , FloatInBinds)   -- Land these after
+
+fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
+  = ( extra_binds ++ shared_binds          -- Land these before
+                                           -- See Note [extra_fvs (1,2)]
+    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself
+          (FloatLet (NonRec id rhs'))
+    , body_binds )                         -- Land these after
+
+  where
+    body_fvs2 = body_fvs `delDVarSet` id
+
+    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]
+    extra_fvs | noFloatIntoRhs NonRecursive id rhs
+              = rule_fvs `unionDVarSet` rhs_fvs
+              | otherwise
+              = rule_fvs
+        -- See Note [extra_fvs (1): avoid floating into RHS]
+        -- No point in floating in only to float straight out again
+        -- We *can't* float into ok-for-speculation unlifted RHSs
+        -- But do float into join points
+
+    [shared_binds, extra_binds, rhs_binds, body_binds]
+        = sepBindsByDropPoint dflags False
+            [extra_fvs, rhs_fvs, body_fvs2]
+            to_drop
+
+        -- Push rhs_binds into the right hand side of the binding
+    rhs'     = fiRhs dflags rhs_binds id ann_rhs
+    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
+                        -- Don't forget the rule_fvs; the binding mentions them!
+
+fiBind dflags to_drop (AnnRec bindings) body_fvs
+  = ( extra_binds ++ shared_binds
+    , FB (mkDVarSet ids) rhs_fvs'
+         (FloatLet (Rec (fi_bind rhss_binds bindings)))
+    , body_binds )
+  where
+    (ids, rhss) = unzip bindings
+    rhss_fvs = map freeVarsOf rhss
+
+        -- See Note [extra_fvs (1,2)]
+    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
+    extra_fvs = rule_fvs `unionDVarSet`
+                unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
+                              , noFloatIntoRhs Recursive bndr rhs ]
+
+    (shared_binds:extra_binds:body_binds:rhss_binds)
+        = sepBindsByDropPoint dflags False
+            (extra_fvs:body_fvs:rhss_fvs)
+            to_drop
+
+    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
+               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
+               rule_fvs         -- Don't forget the rule variables!
+
+    -- Push rhs_binds into the right hand side of the binding
+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss
+            -> [(Id, CoreExprWithFVs)]
+            -> [(Id, CoreExpr)]
+
+    fi_bind to_drops pairs
+      = [ (binder, fiRhs dflags to_drop binder rhs)
+        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
+
+------------------
+fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
+fiRhs dflags to_drop bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  , let (bndrs, body) = collectNAnnBndrs join_arity rhs
+  = mkLams bndrs (fiExpr dflags to_drop body)
+  | otherwise
+  = fiExpr dflags to_drop rhs
+
+------------------
+noFloatIntoLam :: [Var] -> Bool
+noFloatIntoLam bndrs = any bad bndrs
+  where
+    bad b = isId b && not (isOneShotBndr b)
+    -- Don't float inside a non-one-shot lambda
+
+noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
+-- ^ True if it's a bad idea to float bindings into this RHS
+noFloatIntoRhs is_rec bndr rhs
+  | isJoinId bndr
+  = isRec is_rec -- Joins are one-shot iff non-recursive
+
+  | otherwise
+  = noFloatIntoArg rhs (idType bndr)
+
+noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool
+noFloatIntoArg expr expr_ty
+  | isUnliftedType expr_ty
+  = True  -- See Note [Do not destroy the let/app invariant]
+
+   | AnnLam bndr e <- expr
+   , (bndrs, _) <- collectAnnBndrs e
+   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)
+   || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)
+      -- See Note [noFloatInto considerations] wrinkle 2
+
+  | otherwise  -- Note [noFloatInto considerations] wrinkle 2
+  = exprIsTrivial deann_expr || exprIsHNF deann_expr
+  where
+    deann_expr = deAnnotate' expr
+
+{- Note [noFloatInto considerations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When do we want to float bindings into
+   - noFloatIntoRHs: the RHS of a let-binding
+   - noFloatIntoArg: the argument of a function application
+
+Definitely don't float in if it has unlifted type; that
+would destroy the let/app invariant.
+
+* Wrinkle 1: do not float in if
+     (a) any non-one-shot value lambdas
+  or (b) all type lambdas
+  In both cases we'll float straight back out again
+  NB: Must line up with fiExpr (AnnLam...); see #7088
+
+  (a) is important: we /must/ float into a one-shot lambda group
+  (which includes join points). This makes a big difference
+  for things like
+     f x# = let x = I# x#
+            in let j = \() -> ...x...
+               in if <condition> then normal-path else j ()
+  If x is used only in the error case join point, j, we must float the
+  boxing constructor into it, else we box it every time which is very
+  bad news indeed.
+
+* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
+  back out again... not tragic, but a waste of time.
+
+  For function arguments we will still end up with this
+  in-then-out stuff; consider
+    letrec x = e in f x
+  Here x is not a HNF, so we'll produce
+    f (letrec x = e in x)
+  which is OK... it's not that common, and we'll end up
+  floating out again, in CorePrep if not earlier.
+  Still, we use exprIsTrivial to catch this case (sigh)
+
+
+************************************************************************
+*                                                                      *
+\subsection{@sepBindsByDropPoint@}
+*                                                                      *
+************************************************************************
+
+This is the crucial function.  The idea is: We have a wad of bindings
+that we'd like to distribute inside a collection of {\em drop points};
+insides the alternatives of a \tr{case} would be one example of some
+drop points; the RHS and body of a non-recursive \tr{let} binding
+would be another (2-element) collection.
+
+So: We're given a list of sets-of-free-variables, one per drop point,
+and a list of floating-inwards bindings.  If a binding can go into
+only one drop point (without suddenly making something out-of-scope),
+in it goes.  If a binding is used inside {\em multiple} drop points,
+then it has to go in a you-must-drop-it-above-all-these-drop-points
+point.
+
+We have to maintain the order on these drop-point-related lists.
+-}
+
+-- pprFIB :: FloatInBinds -> SDoc
+-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
+
+sepBindsByDropPoint
+    :: DynFlags
+    -> Bool                -- True <=> is case expression
+    -> [FreeVarSet]        -- One set of FVs per drop point
+                           -- Always at least two long!
+    -> FloatInBinds        -- Candidate floaters
+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated
+                           -- inside any drop point; the rest correspond
+                           -- one-to-one with the input list of FV sets
+
+-- Every input floater is returned somewhere in the result;
+-- none are dropped, not even ones which don't seem to be
+-- free in *any* of the drop-point fvs.  Why?  Because, for example,
+-- a binding (let x = E in B) might have a specialised version of
+-- x (say x') stored inside x, but x' isn't free in E or B.
+
+type DropBox = (FreeVarSet, FloatInBinds)
+
+sepBindsByDropPoint dflags is_case drop_pts floaters
+  | null floaters  -- Shortcut common case
+  = [] : [[] | _ <- drop_pts]
+
+  | otherwise
+  = ASSERT( drop_pts `lengthAtLeast` 2 )
+    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
+  where
+    n_alts = length drop_pts
+
+    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
+        -- The *first* one in the argument list is the drop_here set
+        -- The FloatInBinds in the lists are in the reverse of
+        -- the normal FloatInBinds order; that is, they are the right way round!
+
+    go [] drop_boxes = map (reverse . snd) drop_boxes
+
+    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
+        = go binds new_boxes
+        where
+          -- "here" means the group of bindings dropped at the top of the fork
+
+          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
+                                        | (fvs, _) <- drop_boxes]
+
+          drop_here = used_here || cant_push
+
+          n_used_alts = count id used_in_flags -- returns number of Trues in list.
+
+          cant_push
+            | is_case   = n_used_alts == n_alts   -- Used in all, don't push
+                                                  -- Remember n_alts > 1
+                          || (n_used_alts > 1 && not (floatIsDupable dflags bind))
+                             -- floatIsDupable: see Note [Duplicating floats]
+
+            | otherwise = floatIsCase bind || n_used_alts > 1
+                             -- floatIsCase: see Note [Floating primops]
+
+          new_boxes | drop_here = (insert here_box : fork_boxes)
+                    | otherwise = (here_box : new_fork_boxes)
+
+          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
+                                        fork_boxes used_in_flags
+
+          insert :: DropBox -> DropBox
+          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)
+
+          insert_maybe box True  = insert box
+          insert_maybe box False = box
+
+    go _ _ = panic "sepBindsByDropPoint/go"
+
+
+{- Note [Duplicating floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For case expressions we duplicate the binding if it is reasonably
+small, and if it is not used in all the RHSs This is good for
+situations like
+     let x = I# y in
+     case e of
+       C -> error x
+       D -> error x
+       E -> ...not mentioning x...
+
+If the thing is used in all RHSs there is nothing gained,
+so we don't duplicate then.
+-}
+
+floatedBindsFVs :: FloatInBinds -> FreeVarSet
+floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
+
+fbFVs :: FloatInBind -> DVarSet
+fbFVs (FB _ fvs _) = fvs
+
+wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
+-- Remember FloatInBinds is in *reverse* dependency order
+wrapFloats []               e = e
+wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
+
+floatIsDupable :: DynFlags -> FloatBind -> Bool
+floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut
+floatIsDupable dflags (FloatLet (Rec prs))    = all (exprIsDupable dflags . snd) prs
+floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
+
+floatIsCase :: FloatBind -> Bool
+floatIsCase (FloatCase {}) = True
+floatIsCase (FloatLet {})  = False
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/FloatOut.hs
@@ -0,0 +1,755 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[FloatOut]{Float bindings outwards (towards the top level)}
+
+``Long-distance'' floating of bindings towards the top level.
+-}
+
+{-# LANGUAGE CPP #-}
+
+module FloatOut ( floatOutwards ) where
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils
+import MkCore
+import CoreArity        ( etaExpand )
+import CoreMonad        ( FloatOutSwitches(..) )
+
+import DynFlags
+import ErrUtils         ( dumpIfSet_dyn )
+import Id               ( Id, idArity, idType, isBottomingId,
+                          isJoinId, isJoinId_maybe )
+import SetLevels
+import UniqSupply       ( UniqSupply )
+import Bag
+import Util
+import Maybes
+import Outputable
+import Type
+import qualified Data.IntMap as M
+
+import Data.List        ( partition )
+
+#include "HsVersions.h"
+
+{-
+        -----------------
+        Overall game plan
+        -----------------
+
+The Big Main Idea is:
+
+        To float out sub-expressions that can thereby get outside
+        a non-one-shot value lambda, and hence may be shared.
+
+
+To achieve this we may need to do two things:
+
+   a) Let-bind the sub-expression:
+
+        f (g x)  ==>  let lvl = f (g x) in lvl
+
+      Now we can float the binding for 'lvl'.
+
+   b) More than that, we may need to abstract wrt a type variable
+
+        \x -> ... /\a -> let v = ...a... in ....
+
+      Here the binding for v mentions 'a' but not 'x'.  So we
+      abstract wrt 'a', to give this binding for 'v':
+
+            vp = /\a -> ...a...
+            v  = vp a
+
+      Now the binding for vp can float out unimpeded.
+      I can't remember why this case seemed important enough to
+      deal with, but I certainly found cases where important floats
+      didn't happen if we did not abstract wrt tyvars.
+
+With this in mind we can also achieve another goal: lambda lifting.
+We can make an arbitrary (function) binding float to top level by
+abstracting wrt *all* local variables, not just type variables, leaving
+a binding that can be floated right to top level.  Whether or not this
+happens is controlled by a flag.
+
+
+Random comments
+~~~~~~~~~~~~~~~
+
+At the moment we never float a binding out to between two adjacent
+lambdas.  For example:
+
+@
+        \x y -> let t = x+x in ...
+===>
+        \x -> let t = x+x in \y -> ...
+@
+Reason: this is less efficient in the case where the original lambda
+is never partially applied.
+
+But there's a case I've seen where this might not be true.  Consider:
+@
+elEm2 x ys
+  = elem' x ys
+  where
+    elem' _ []  = False
+    elem' x (y:ys)      = x==y || elem' x ys
+@
+It turns out that this generates a subexpression of the form
+@
+        \deq x ys -> let eq = eqFromEqDict deq in ...
+@
+which might usefully be separated to
+@
+        \deq -> let eq = eqFromEqDict deq in \xy -> ...
+@
+Well, maybe.  We don't do this at the moment.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+Every occurrence of a join point must be a tail call (see Note [Invariants on
+join points] in CoreSyn), so we must be careful with how far we float them. The
+mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]
+in SetLevels. For us, the significance is that a binder might be marked to be
+dropped at the nearest boundary between tail calls and non-tail calls. For
+example:
+
+  (< join j = ... in
+     let x = < ... > in
+     case < ... > of
+       A -> ...
+       B -> ...
+   >) < ... > < ... >
+
+Here the join ceilings are marked with angle brackets. Either side of an
+application is a join ceiling, as is the scrutinee position of a case
+expression or the RHS of a let binding (but not a join point).
+
+Why do we *want* do float join points at all? After all, they're never
+allocated, so there's no sharing to be gained by floating them. However, the
+other benefit of floating is making RHSes small, and this can have a significant
+impact. In particular, stream fusion has been known to produce nested loops like
+this:
+
+  joinrec j1 x1 =
+    joinrec j2 x2 =
+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
+      in jump j3 x2
+    in jump j2 x1
+  in jump j1 x
+
+(Assume x1 and x2 do *not* occur free in j3.)
+
+Here j1 and j2 are wholly superfluous---each of them merely forwards its
+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make
+everything one big mutual recursion:
+
+  joinrec j1 x1 = jump j2 x1
+          j2 x2 = jump j3 x2
+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
+  in jump j1 x
+
+Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.
+Without floating, we're stuck with three loops instead of one.
+
+************************************************************************
+*                                                                      *
+\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
+*                                                                      *
+************************************************************************
+-}
+
+floatOutwards :: FloatOutSwitches
+              -> DynFlags
+              -> UniqSupply
+              -> CoreProgram -> IO CoreProgram
+
+floatOutwards float_sws dflags us pgm
+  = do {
+        let { annotated_w_levels = setLevels float_sws pgm us ;
+              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)
+            } ;
+
+        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
+                  (vcat (map ppr annotated_w_levels));
+
+        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
+
+        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
+                (hcat [ int tlets,  text " Lets floated to top level; ",
+                        int ntlets, text " Lets floated elsewhere; from ",
+                        int lams,   text " Lambda groups"]);
+
+        return (bagToList (unionManyBags binds_s'))
+    }
+
+floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)
+floatTopBind bind
+  = case (floatBind bind) of { (fs, floats, bind') ->
+    let float_bag = flattenTopFloats floats
+    in case bind' of
+      -- bind' can't have unlifted values or join points, so can only be one
+      -- value bind, rec or non-rec (see comment on floatBind)
+      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
+      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)
+      _            -> pprPanic "floatTopBind" (ppr bind') }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[FloatOut-Bind]{Floating in a binding (the business end)}
+*                                                                      *
+************************************************************************
+-}
+
+floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])
+  -- Returns a list with either
+  --   * A single non-recursive binding (value or join point), or
+  --   * The following, in order:
+  --     * Zero or more non-rec unlifted bindings
+  --     * One or both of:
+  --       * A recursive group of join binds
+  --       * A recursive group of value binds
+  -- See Note [Floating out of Rec rhss] for why things get arranged this way.
+floatBind (NonRec (TB var _) rhs)
+  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->
+
+        -- A tiresome hack:
+        -- see Note [Bottoming floats: eta expansion] in SetLevels
+    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
+              | otherwise         = rhs'
+
+    in (fs, rhs_floats, [NonRec var rhs'']) }
+
+floatBind (Rec pairs)
+  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
+    let (new_ul_pairss, new_other_pairss) = unzip new_pairs
+        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)
+                                                      (concat new_other_pairss)
+        -- Can't put the join points and the values in the same rec group
+        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]
+                      | null new_l_pairs    = [ Rec new_join_pairs ]
+                      | otherwise           = [ Rec new_l_pairs
+                                              , Rec new_join_pairs ]
+        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]
+    in
+    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }
+  where
+    do_pair :: (LevelledBndr, LevelledExpr)
+            -> (FloatStats, FloatBinds,
+                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings
+                 [(Id,CoreExpr)])) -- Join points and lifted value bindings
+    do_pair (TB name spec, rhs)
+      | isTopLvl dest_lvl  -- See Note [floatBind for top level]
+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
+        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)
+                                                [(name, rhs')]))}
+      | otherwise         -- Note [Floating out of Rec rhss]
+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
+        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->
+        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->
+        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in
+        (fs, rhs_floats', (ul_pairs, pairs')) }}}
+      where
+        dest_lvl = floatSpecLevel spec
+
+splitRecFloats :: Bag FloatBind
+               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
+                   [(Id,CoreExpr)], -- Join points and lifted value bindings
+                   Bag FloatBind)   -- A tail of further bindings
+-- The "tail" begins with a case
+-- See Note [Floating out of Rec rhss]
+splitRecFloats fs
+  = go [] [] (bagToList fs)
+  where
+    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)
+                                               , not (isJoinId b)
+                                               = go ((b,r):ul_prs) prs fs
+                                               | otherwise
+                                               = go ul_prs ((b,r):prs) fs
+    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs
+    go ul_prs prs fs                           = (reverse ul_prs, prs,
+                                                  listToBag fs)
+                                                   -- Order only matters for
+                                                   -- non-rec
+
+installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr
+-- Note [Floating out of Rec rhss]
+installUnderLambdas floats e
+  | isEmptyBag floats = e
+  | otherwise         = go e
+  where
+    go (Lam b e)                 = Lam b (go e)
+    go e                         = install floats e
+
+---------------
+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
+floatList _ [] = (zeroStats, emptyFloats, [])
+floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->
+                     case floatList f as of { (fs_as, binds_as, bs) ->
+                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}
+
+{-
+Note [Floating out of Rec rhss]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   Rec { f<1,0> = \xy. body }
+From the body we may get some floats. The ones with level <1,0> must
+stay here, since they may mention f.  Ideally we'd like to make them
+part of the Rec block pairs -- but we can't if there are any
+FloatCases involved.
+
+Nor is it a good idea to dump them in the rhs, but outside the lambda
+    f = case x of I# y -> \xy. body
+because now f's arity might get worse, which is Not Good. (And if
+there's an SCC around the RHS it might not get better again.
+See #5342.)
+
+So, gruesomely, we split the floats into
+ * the outer FloatLets, which can join the Rec, and
+ * an inner batch starting in a FloatCase, which are then
+   pushed *inside* the lambdas.
+This loses full-laziness the rare situation where there is a
+FloatCase and a Rec interacting.
+
+If there are unlifted FloatLets (that *aren't* join points) among the floats,
+we can't add them to the recursive group without angering Core Lint, but since
+they must be ok-for-speculation, they can't actually be making any recursive
+calls, so we can safely pull them out and keep them non-recursive.
+
+(Why is something getting floated to <1,0> that doesn't make a recursive call?
+The case that came up in testing was that f *and* the unlifted binding were
+getting floated *to the same place*:
+
+  \x<2,0> ->
+    ... <3,0>
+    letrec { f<F<2,0>> =
+      ... let x'<F<2,0>> = x +# 1# in ...
+    } in ...
+
+Everything gets labeled "float to <2,0>" because it all depends on x, but this
+makes f and x' look mutually recursive when they're not.
+
+The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the
+wip/join-points branch.
+
+TODO: This can probably be solved somehow in SetLevels. The difference between
+"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very
+important.)
+
+Note [floatBind for top level]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus
+         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }
+The binding for bar will be in the "tops" part of the floating binds,
+and thus not partioned by floatBody.
+
+We could perhaps get rid of the 'tops' component of the floating binds,
+but this case works just as well.
+
+
+************************************************************************
+
+\subsection[FloatOut-Expr]{Floating in expressions}
+*                                                                      *
+************************************************************************
+-}
+
+floatBody :: Level
+          -> LevelledExpr
+          -> (FloatStats, FloatBinds, CoreExpr)
+
+floatBody lvl arg       -- Used rec rhss, and case-alternative rhss
+  = case (floatExpr arg) of { (fsa, floats, arg') ->
+    case (partitionByLevel lvl floats) of { (floats', heres) ->
+        -- Dump bindings are bound here
+    (fsa, floats', install heres arg') }}
+
+-----------------
+
+{- Note [Floating past breakpoints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We used to disallow floating out of breakpoint ticks (see #10052). However, I
+think this is too restrictive.
+
+Consider the case of an expression scoped over by a breakpoint tick,
+
+  tick<...> (let x = ... in f x)
+
+In this case it is completely legal to float out x, despite the fact that
+breakpoint ticks are scoped,
+
+  let x = ... in (tick<...>  f x)
+
+The reason here is that we know that the breakpoint will still be hit when the
+expression is entered since the tick still scopes over the RHS.
+
+-}
+
+floatExpr :: LevelledExpr
+          -> (FloatStats, FloatBinds, CoreExpr)
+floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)
+floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)
+floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)
+floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)
+
+floatExpr (App e a)
+  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->
+    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->
+    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
+
+floatExpr lam@(Lam (TB _ lam_spec) _)
+  = let (bndrs_w_lvls, body) = collectBinders lam
+        bndrs                = [b | TB b _ <- bndrs_w_lvls]
+        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)
+        -- All the binders have the same level
+        -- See SetLevels.lvlLamBndrs
+        -- Use asJoinCeilLvl to make this the join ceiling
+    in
+    case (floatBody bndr_lvl body) of { (fs, floats, body') ->
+    (add_to_stats fs floats, floats, mkLams bndrs body') }
+
+floatExpr (Tick tickish expr)
+  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Tick tickish expr') }
+
+  | not (tickishCounts tickish) || tickishCanSplit tickish
+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
+    let -- Annotate bindings floated outwards past an scc expression
+        -- with the cc.  We mark that cc as "duplicated", though.
+        annotated_defns = wrapTick (mkNoCount tickish) floating_defns
+    in
+    (fs, annotated_defns, Tick tickish expr') }
+
+  -- Note [Floating past breakpoints]
+  | Breakpoint{} <- tickish
+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Tick tickish expr') }
+
+  | otherwise
+  = pprPanic "floatExpr tick" (ppr tickish)
+
+floatExpr (Cast expr co)
+  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Cast expr' co) }
+
+floatExpr (Let bind body)
+  = case bind_spec of
+      FloatMe dest_lvl
+        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
+           case (floatExpr body) of { (fse, body_floats, body') ->
+           let new_bind_floats = foldr plusFloats emptyFloats
+                                   (map (unitLetFloat dest_lvl) binds') in
+           ( add_stats fsb fse
+           , bind_floats `plusFloats` new_bind_floats
+                         `plusFloats` body_floats
+           , body') }}
+
+      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]
+        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->
+           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->
+           ( add_stats fsb fse
+           , bind_floats `plusFloats` body_floats
+           , foldr Let body' binds' ) }}
+  where
+    bind_spec = case bind of
+                 NonRec (TB _ s) _     -> s
+                 Rec ((TB _ s, _) : _) -> s
+                 Rec []                -> panic "floatExpr:rec"
+
+floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
+  = case case_spec of
+      FloatMe dest_lvl  -- Case expression moves
+        | [(con@(DataAlt {}), bndrs, rhs)] <- alts
+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
+           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->
+           let
+             float = unitCaseFloat dest_lvl scrut'
+                          case_bndr con [b | TB b _ <- bndrs]
+           in
+           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}
+        | otherwise
+        -> pprPanic "Floating multi-case" (ppr alts)
+
+      StayPut bind_lvl  -- Case expression stays put
+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
+           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->
+           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
+           }}
+  where
+    float_alt bind_lvl (con, bs, rhs)
+        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
+          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
+
+floatRhs :: CoreBndr
+         -> LevelledExpr
+         -> (FloatStats, FloatBinds, CoreExpr)
+floatRhs bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  , Just (bndrs, body) <- try_collect join_arity rhs []
+  = case bndrs of
+      []                -> floatExpr rhs
+      (TB _ lam_spec):_ ->
+        let lvl = floatSpecLevel lam_spec in
+        case floatBody lvl body of { (fs, floats, body') ->
+        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }
+  | otherwise
+  = atJoinCeiling $ floatExpr rhs
+  where
+    try_collect 0 expr      acc = Just (reverse acc, expr)
+    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)
+    try_collect _ _         _   = Nothing
+
+{-
+Note [Avoiding unnecessary floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we want to avoid floating a let unnecessarily, because
+it might worsen strictness:
+    let
+       x = ...(let y = e in y+y)....
+Here y is demanded.  If we float it outside the lazy 'x=..' then
+we'd have to zap its demand info, and it may never be restored.
+
+So at a 'let' we leave the binding right where the are unless
+the binding will escape a value lambda, e.g.
+
+(\x -> let y = fac 100 in y)
+
+That's what the partitionByMajorLevel does in the floatExpr (Let ...)
+case.
+
+Notice, though, that we must take care to drop any bindings
+from the body of the let that depend on the staying-put bindings.
+
+We used instead to do the partitionByMajorLevel on the RHS of an '=',
+in floatRhs.  But that was quite tiresome.  We needed to test for
+values or trival rhss, because (in particular) we don't want to insert
+new bindings between the "=" and the "\".  E.g.
+        f = \x -> let <bind> in <body>
+We do not want
+        f = let <bind> in \x -> <body>
+(a) The simplifier will immediately float it further out, so we may
+        as well do so right now; in general, keeping rhss as manifest
+        values is good
+(b) If a float-in pass follows immediately, it might add yet more
+        bindings just after the '='.  And some of them might (correctly)
+        be strict even though the 'let f' is lazy, because f, being a value,
+        gets its demand-info zapped by the simplifier.
+And even all that turned out to be very fragile, and broke
+altogether when profiling got in the way.
+
+So now we do the partition right at the (Let..) itself.
+
+************************************************************************
+*                                                                      *
+\subsection{Utility bits for floating stats}
+*                                                                      *
+************************************************************************
+
+I didn't implement this with unboxed numbers.  I don't want to be too
+strict in this stuff, as it is rarely turned on.  (WDP 95/09)
+-}
+
+data FloatStats
+  = FlS Int  -- Number of top-floats * lambda groups they've been past
+        Int  -- Number of non-top-floats * lambda groups they've been past
+        Int  -- Number of lambda (groups) seen
+
+get_stats :: FloatStats -> (Int, Int, Int)
+get_stats (FlS a b c) = (a, b, c)
+
+zeroStats :: FloatStats
+zeroStats = FlS 0 0 0
+
+sum_stats :: [FloatStats] -> FloatStats
+sum_stats xs = foldr add_stats zeroStats xs
+
+add_stats :: FloatStats -> FloatStats -> FloatStats
+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
+  = FlS (a1 + a2) (b1 + b2) (c1 + c2)
+
+add_to_stats :: FloatStats -> FloatBinds -> FloatStats
+add_to_stats (FlS a b c) (FB tops ceils others)
+  = FlS (a + lengthBag tops)
+        (b + lengthBag ceils + lengthBag (flattenMajor others))
+        (c + 1)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Utility bits for floating}
+*                                                                      *
+************************************************************************
+
+Note [Representation of FloatBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The FloatBinds types is somewhat important.  We can get very large numbers
+of floating bindings, often all destined for the top level.  A typical example
+is     x = [4,2,5,2,5, .... ]
+Then we get lots of small expressions like (fromInteger 4), which all get
+lifted to top level.
+
+The trouble is that
+  (a) we partition these floating bindings *at every binding site*
+  (b) SetLevels introduces a new bindings site for every float
+So we had better not look at each binding at each binding site!
+
+That is why MajorEnv is represented as a finite map.
+
+We keep the bindings destined for the *top* level separate, because
+we float them out even if they don't escape a *value* lambda; see
+partitionByMajorLevel.
+-}
+
+type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted
+type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level
+type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level
+
+data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level
+                      !(Bag FloatBind)          -- Destined for join ceiling
+                      !MajorEnv                 -- Other levels
+     -- See Note [Representation of FloatBinds]
+
+instance Outputable FloatBinds where
+  ppr (FB fbs ceils defs)
+      = text "FB" <+> (braces $ vcat
+           [ text "tops ="     <+> ppr fbs
+           , text "ceils ="    <+> ppr ceils
+           , text "non-tops =" <+> ppr defs ])
+
+flattenTopFloats :: FloatBinds -> Bag CoreBind
+flattenTopFloats (FB tops ceils defs)
+  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )
+    ASSERT2( isEmptyBag ceils, ppr ceils )
+    tops
+
+addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
+addTopFloatPairs float_bag prs
+  = foldrBag add prs float_bag
+  where
+    add (NonRec b r) prs  = (b,r):prs
+    add (Rec prs1)   prs2 = prs1 ++ prs2
+
+flattenMajor :: MajorEnv -> Bag FloatBind
+flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag
+
+flattenMinor :: MinorEnv -> Bag FloatBind
+flattenMinor = M.foldr unionBags emptyBag
+
+emptyFloats :: FloatBinds
+emptyFloats = FB emptyBag emptyBag M.empty
+
+unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
+unitCaseFloat (Level major minor t) e b con bs
+  | t == JoinCeilLvl
+  = FB emptyBag floats M.empty
+  | otherwise
+  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))
+  where
+    floats = unitBag (FloatCase e b con bs)
+
+unitLetFloat :: Level -> FloatLet -> FloatBinds
+unitLetFloat lvl@(Level major minor t) b
+  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty
+  | t == JoinCeilLvl = FB emptyBag floats M.empty
+  | otherwise        = FB emptyBag emptyBag (M.singleton major
+                                              (M.singleton minor floats))
+  where
+    floats = unitBag (FloatLet b)
+
+plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
+plusFloats (FB t1 c1 l1) (FB t2 c2 l2)
+  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)
+
+plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
+plusMajor = M.unionWith plusMinor
+
+plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
+plusMinor = M.unionWith unionBags
+
+install :: Bag FloatBind -> CoreExpr -> CoreExpr
+install defn_groups expr
+  = foldrBag wrapFloat expr defn_groups
+
+partitionByLevel
+        :: Level                -- Partitioning level
+        -> FloatBinds           -- Defns to be divided into 2 piles...
+        -> (FloatBinds,         -- Defns  with level strictly < partition level,
+            Bag FloatBind)      -- The rest
+
+{-
+--       ---- partitionByMajorLevel ----
+-- Float it if we escape a value lambda,
+--     *or* if we get to the top level
+--     *or* if it's a case-float and its minor level is < current
+--
+-- If we can get to the top level, say "yes" anyway. This means that
+--      x = f e
+-- transforms to
+--    lvl = e
+--    x = f lvl
+-- which is as it should be
+
+partitionByMajorLevel (Level major _) (FB tops defns)
+  = (FB tops outer, heres `unionBags` flattenMajor inner)
+  where
+    (outer, mb_heres, inner) = M.splitLookup major defns
+    heres = case mb_heres of
+               Nothing -> emptyBag
+               Just h  -> flattenMinor h
+-}
+
+partitionByLevel (Level major minor typ) (FB tops ceils defns)
+  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),
+     here_min `unionBags` here_ceil
+              `unionBags` flattenMinor inner_min
+              `unionBags` flattenMajor inner_maj)
+
+  where
+    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
+    (outer_min, mb_here_min, inner_min) = case mb_here_maj of
+                                            Nothing -> (M.empty, Nothing, M.empty)
+                                            Just min_defns -> M.splitLookup minor min_defns
+    here_min = mb_here_min `orElse` emptyBag
+    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)
+                        | otherwise          = (emptyBag, ceils)
+
+-- Like partitionByLevel, but instead split out the bindings that are marked
+-- to float to the nearest join ceiling (see Note [Join points])
+partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)
+partitionAtJoinCeiling (FB tops ceils defs)
+  = (FB tops emptyBag defs, ceils)
+
+-- Perform some action at a join ceiling, i.e., don't let join points float out
+-- (see Note [Join points])
+atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)
+              -> (FloatStats, FloatBinds, CoreExpr)
+atJoinCeiling (fs, floats, expr')
+  = (fs, floats', install ceils expr')
+  where
+    (floats', ceils) = partitionAtJoinCeiling floats
+
+wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
+wrapTick t (FB tops ceils defns)
+  = FB (mapBag wrap_bind tops) (wrap_defns ceils)
+       (M.map (M.map wrap_defns) defns)
+  where
+    wrap_defns = mapBag wrap_one
+
+    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)
+
+    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)
+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
+
+    maybe_tick e | exprIsHNF e = tickHNFArgs t e
+                 | otherwise   = mkTick t e
+      -- we don't need to wrap a tick around an HNF when we float it
+      -- outside a tick: that is an invariant of the tick semantics
+      -- Conversely, inlining of HNFs inside an SCC is allowed, and
+      -- indeed the HNF we're floating here might well be inlined back
+      -- again, and we don't want to end up with duplicate ticks.
diff --git a/compiler/simplCore/LiberateCase.hs b/compiler/simplCore/LiberateCase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/LiberateCase.hs
@@ -0,0 +1,442 @@
+{-
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
+-}
+
+{-# LANGUAGE CPP #-}
+module LiberateCase ( liberateCase ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import CoreSyn
+import CoreUnfold       ( couldBeSmallEnoughToInline )
+import TysWiredIn       ( unitDataConId )
+import Id
+import VarEnv
+import Util             ( notNull )
+
+{-
+The liberate-case transformation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This module walks over @Core@, and looks for @case@ on free variables.
+The criterion is:
+        if there is case on a free on the route to the recursive call,
+        then the recursive call is replaced with an unfolding.
+
+Example
+
+   f = \ t -> case v of
+                 V a b -> a : f t
+
+=> the inner f is replaced.
+
+   f = \ t -> case v of
+                 V a b -> a : (letrec
+                                f =  \ t -> case v of
+                                               V a b -> a : f t
+                               in f) t
+(note the NEED for shadowing)
+
+=> Simplify
+
+  f = \ t -> case v of
+                 V a b -> a : (letrec
+                                f = \ t -> a : f t
+                               in f t)
+
+Better code, because 'a' is  free inside the inner letrec, rather
+than needing projection from v.
+
+Note that this deals with *free variables*.  SpecConstr deals with
+*arguments* that are of known form.  E.g.
+
+        last []     = error
+        last (x:[]) = x
+        last (x:xs) = last xs
+
+
+Note [Scrutinee with cast]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+    f = \ t -> case (v `cast` co) of
+                 V a b -> a : f t
+
+Exactly the same optimisation (unrolling one call to f) will work here,
+despite the cast.  See mk_alt_env in the Case branch of libCase.
+
+
+To think about (Apr 94)
+~~~~~~~~~~~~~~
+Main worry: duplicating code excessively.  At the moment we duplicate
+the entire binding group once at each recursive call.  But there may
+be a group of recursive calls which share a common set of evaluated
+free variables, in which case the duplication is a plain waste.
+
+Another thing we could consider adding is some unfold-threshold thing,
+so that we'll only duplicate if the size of the group rhss isn't too
+big.
+
+Data types
+~~~~~~~~~~
+The ``level'' of a binder tells how many
+recursive defns lexically enclose the binding
+A recursive defn "encloses" its RHS, not its
+scope.  For example:
+\begin{verbatim}
+        letrec f = let g = ... in ...
+        in
+        let h = ...
+        in ...
+\end{verbatim}
+Here, the level of @f@ is zero, the level of @g@ is one,
+and the level of @h@ is zero (NB not one).
+
+
+************************************************************************
+*                                                                      *
+         Top-level code
+*                                                                      *
+************************************************************************
+-}
+
+liberateCase :: DynFlags -> CoreProgram -> CoreProgram
+liberateCase dflags binds = do_prog (initEnv dflags) binds
+  where
+    do_prog _   [] = []
+    do_prog env (bind:binds) = bind' : do_prog env' binds
+                             where
+                               (env', bind') = libCaseBind env bind
+
+{-
+************************************************************************
+*                                                                      *
+         Main payload
+*                                                                      *
+************************************************************************
+
+Bindings
+~~~~~~~~
+-}
+
+libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
+
+libCaseBind env (NonRec binder rhs)
+  = (addBinders env [binder], NonRec binder (libCase env rhs))
+
+libCaseBind env (Rec pairs)
+  = (env_body, Rec pairs')
+  where
+    binders = map fst pairs
+
+    env_body = addBinders env binders
+
+    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
+
+        -- We extend the rec-env by binding each Id to its rhs, first
+        -- processing the rhs with an *un-extended* environment, so
+        -- that the same process doesn't occur for ever!
+    env_rhs | is_dupable_bind = addRecBinds env dup_pairs
+            | otherwise       = env
+
+    dup_pairs = [ (localiseId binder, libCase env_body rhs)
+                | (binder, rhs) <- pairs ]
+        -- localiseID : see Note [Need to localiseId in libCaseBind]
+
+    is_dupable_bind = small_enough && all ok_pair pairs
+
+    -- Size: we are going to duplicate dup_pairs; to find their
+    --       size, build a fake binding (let { dup_pairs } in (),
+    --       and find the size of that
+    -- See Note [Small enough]
+    small_enough = case bombOutSize env of
+                      Nothing   -> True   -- Infinity
+                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $
+                                   Let (Rec dup_pairs) (Var unitDataConId)
+
+    ok_pair (id,_)
+        =  idArity id > 0          -- Note [Only functions!]
+        && not (isBottomingId id)  -- Note [Not bottoming ids]
+
+{- Note [Not bottoming Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not specialise error-functions (this is unusual, but I once saw it,
+(acually in Data.Typable.Internal)
+
+Note [Only functions!]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider the following code
+
+       f = g (case v of V a b -> a : t f)
+
+where g is expensive. If we aren't careful, liberate case will turn this into
+
+       f = g (case v of
+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
+                                in f)
+             )
+
+Yikes! We evaluate g twice. This leads to a O(2^n) explosion
+if g calls back to the same code recursively.
+
+Solution: make sure that we only do the liberate-case thing on *functions*
+
+Note [Small enough]
+~~~~~~~~~~~~~~~~~~~
+Consider
+  \fv. letrec
+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
+         g = \y. SMALL...f...
+
+Then we *can* in principle do liberate-case on 'g' (small RHS) but not
+for 'f' (too big).  But doing so is not profitable, because duplicating
+'g' at its call site in 'f' doesn't get rid of any cases.  So we just
+ask for the whole group to be small enough.
+
+Note [Need to localiseId in libCaseBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The call to localiseId is needed for two subtle reasons
+(a)  Reset the export flags on the binders so
+        that we don't get name clashes on exported things if the
+        local binding floats out to top level.  This is most unlikely
+        to happen, since the whole point concerns free variables.
+        But resetting the export flag is right regardless.
+
+(b)  Make the name an Internal one.  External Names should never be
+        nested; if it were floated to the top level, we'd get a name
+        clash at code generation time.
+
+Expressions
+~~~~~~~~~~~
+-}
+
+libCase :: LibCaseEnv
+        -> CoreExpr
+        -> CoreExpr
+
+libCase env (Var v)             = libCaseApp env v []
+libCase _   (Lit lit)           = Lit lit
+libCase _   (Type ty)           = Type ty
+libCase _   (Coercion co)       = Coercion co
+libCase env e@(App {})          | let (fun, args) = collectArgs e
+                                , Var v <- fun
+                                = libCaseApp env v args
+libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
+libCase env (Tick tickish body) = Tick tickish (libCase env body)
+libCase env (Cast e co)         = Cast (libCase env e) co
+
+libCase env (Lam binder body)
+  = Lam binder (libCase (addBinders env [binder]) body)
+
+libCase env (Let bind body)
+  = Let bind' (libCase env_body body)
+  where
+    (env_body, bind') = libCaseBind env bind
+
+libCase env (Case scrut bndr ty alts)
+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
+  where
+    env_alts = addBinders (mk_alt_env scrut) [bndr]
+    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]
+    mk_alt_env _               = env
+
+libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
+                         -> (AltCon, [CoreBndr], CoreExpr)
+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
+
+{-
+Ids
+~~~
+
+To unfold, we can't just wrap the id itself in its binding if it's a join point:
+
+  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!
+
+Every jump must provide all arguments, so we have to be careful to wrap the
+whole jump instead:
+
+  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right
+
+-}
+
+libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr
+libCaseApp env v args
+  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing
+  , notNull free_scruts                 -- with free vars scrutinised in RHS
+  = Let the_bind expr'
+
+  | otherwise
+  = expr'
+
+  where
+    rec_id_level = lookupLevel env v
+    free_scruts  = freeScruts env rec_id_level
+    expr'        = mkApps (Var v) (map (libCase env) args)
+
+freeScruts :: LibCaseEnv
+           -> LibCaseLevel      -- Level of the recursive Id
+           -> [Id]              -- Ids that are scrutinised between the binding
+                                -- of the recursive Id and here
+freeScruts env rec_bind_lvl
+  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env
+       , scrut_bind_lvl <= rec_bind_lvl
+       , scrut_at_lvl > rec_bind_lvl]
+        -- Note [When to specialise]
+        -- Note [Avoiding fruitless liberate-case]
+
+{-
+Note [When to specialise]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x. letrec g = \y. case x of
+                           True  -> ... (f a) ...
+                           False -> ... (g b) ...
+
+We get the following levels
+          f  0
+          x  1
+          g  1
+          y  2
+
+Then 'x' is being scrutinised at a deeper level than its binding, so
+it's added to lc_sruts:  [(x,1)]
+
+We do *not* want to specialise the call to 'f', because 'x' is not free
+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).
+
+We *do* want to specialise the call to 'g', because 'x' is free in g.
+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).
+
+Note [Avoiding fruitless liberate-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider also:
+  f = \x. case top_lvl_thing of
+                I# _ -> let g = \y. ... g ...
+                        in ...
+
+Here, top_lvl_thing is scrutinised at a level (1) deeper than its
+binding site (0).  Nevertheless, we do NOT want to specialise the call
+to 'g' because all the structure in its free variables is already
+visible at the definition site for g.  Hence, when considering specialising
+an occurrence of 'g', we want to check that there's a scruted-var v st
+
+   a) v's binding site is *outside* g
+   b) v's scrutinisation site is *inside* g
+
+
+************************************************************************
+*                                                                      *
+        Utility functions
+*                                                                      *
+************************************************************************
+-}
+
+addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
+addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
+  = env { lc_lvl_env = lvl_env' }
+  where
+    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
+
+addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,
+                             lc_rec_env = rec_env}) pairs
+  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }
+  where
+    lvl'     = lvl + 1
+    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
+    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
+
+addScrutedVar :: LibCaseEnv
+              -> Id             -- This Id is being scrutinised by a case expression
+              -> LibCaseEnv
+
+addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
+                                lc_scruts = scruts }) scrut_var
+  | bind_lvl < lvl
+  = env { lc_scruts = scruts' }
+        -- Add to scruts iff the scrut_var is being scrutinised at
+        -- a deeper level than its defn
+
+  | otherwise = env
+  where
+    scruts'  = (scrut_var, bind_lvl, lvl) : scruts
+    bind_lvl = case lookupVarEnv lvl_env scrut_var of
+                 Just lvl -> lvl
+                 Nothing  -> topLevel
+
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
+lookupRecId env id = lookupVarEnv (lc_rec_env env) id
+
+lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
+lookupLevel env id
+  = case lookupVarEnv (lc_lvl_env env) id of
+      Just lvl -> lvl
+      Nothing  -> topLevel
+
+{-
+************************************************************************
+*                                                                      *
+         The environment
+*                                                                      *
+************************************************************************
+-}
+
+type LibCaseLevel = Int
+
+topLevel :: LibCaseLevel
+topLevel = 0
+
+data LibCaseEnv
+  = LibCaseEnv {
+        lc_dflags :: DynFlags,
+
+        lc_lvl :: LibCaseLevel, -- Current level
+                -- The level is incremented when (and only when) going
+                -- inside the RHS of a (sufficiently small) recursive
+                -- function.
+
+        lc_lvl_env :: IdEnv LibCaseLevel,
+                -- Binds all non-top-level in-scope Ids (top-level and
+                -- imported things have a level of zero)
+
+        lc_rec_env :: IdEnv CoreBind,
+                -- Binds *only* recursively defined ids, to their own
+                -- binding group, and *only* in their own RHSs
+
+        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
+                -- Each of these Ids was scrutinised by an enclosing
+                -- case expression, at a level deeper than its binding
+                -- level.
+                --
+                -- The first LibCaseLevel is the *binding level* of
+                --   the scrutinised Id,
+                -- The second is the level *at which it was scrutinised*.
+                --   (see Note [Avoiding fruitless liberate-case])
+                -- The former is a bit redundant, since you could always
+                -- look it up in lc_lvl_env, but it's just cached here
+                --
+                -- The order is insignificant; it's a bag really
+                --
+                -- There's one element per scrutinisation;
+                --    in principle the same Id may appear multiple times,
+                --    although that'd be unusual:
+                --       case x of { (a,b) -> ....(case x of ...) .. }
+        }
+
+initEnv :: DynFlags -> LibCaseEnv
+initEnv dflags
+  = LibCaseEnv { lc_dflags = dflags,
+                 lc_lvl = 0,
+                 lc_lvl_env = emptyVarEnv,
+                 lc_rec_env = emptyVarEnv,
+                 lc_scruts = [] }
+
+-- Bomb-out size for deciding if
+-- potential liberatees are too big.
+-- (passed in from cmd-line args)
+bombOutSize :: LibCaseEnv -> Maybe Int
+bombOutSize = liberateCaseThreshold . lc_dflags
diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SAT.hs
@@ -0,0 +1,433 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+************************************************************************
+
+               Static Argument Transformation pass
+
+************************************************************************
+
+May be seen as removing invariants from loops:
+Arguments of recursive functions that do not change in recursive
+calls are removed from the recursion, which is done locally
+and only passes the arguments which effectively change.
+
+Example:
+map = /\ ab -> \f -> \xs -> case xs of
+                 []       -> []
+                 (a:b) -> f a : map f b
+
+as map is recursively called with the same argument f (unmodified)
+we transform it to
+
+map = /\ ab -> \f -> \xs -> let map' ys = case ys of
+                       []     -> []
+                       (a:b) -> f a : map' b
+                in map' xs
+
+Notice that for a compiler that uses lambda lifting this is
+useless as map' will be transformed back to what map was.
+
+We could possibly do the same for big lambdas, but we don't as
+they will eventually be removed in later stages of the compiler,
+therefore there is no penalty in keeping them.
+
+We only apply the SAT when the number of static args is > 2. This
+produces few bad cases.  See
+                should_transform
+in saTransform.
+
+Here are the headline nofib results:
+                  Size    Allocs   Runtime
+Min             +0.0%    -13.7%    -21.4%
+Max             +0.1%     +0.0%     +5.4%
+Geometric Mean  +0.0%     -0.2%     -6.9%
+
+The previous patch, to fix polymorphic floatout demand signatures, is
+essential to make this work well!
+-}
+
+{-# LANGUAGE CPP #-}
+module SAT ( doStaticArgs ) where
+
+import GhcPrelude
+
+import Var
+import CoreSyn
+import CoreUtils
+import Type
+import Coercion
+import Id
+import Name
+import VarEnv
+import UniqSupply
+import Util
+import UniqFM
+import VarSet
+import Unique
+import UniqSet
+import Outputable
+
+import Data.List
+import FastString
+
+#include "HsVersions.h"
+
+doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
+  where
+    sat_bind_threaded_us us bind =
+        let (us1, us2) = splitUniqSupply us
+        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))
+
+-- We don't bother to SAT recursive groups since it can lead
+-- to massive code expansion: see Andre Santos' thesis for details.
+-- This means we only apply the actual SAT to Rec groups of one element,
+-- but we want to recurse into the others anyway to discover other binds
+satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
+satBind (NonRec binder expr) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)
+satBind (Rec [(binder, rhs)]) interesting_ids = do
+    let interesting_ids' = interesting_ids `addOneToUniqSet` binder
+        (rhs_binders, rhs_body) = collectBinders rhs
+    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'
+    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)
+        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body
+
+        shadowing = binder `elementOfUniqSet` interesting_ids
+        sat_info_rhs'' = if shadowing
+                        then sat_info_rhs' `delFromUFM` binder -- For safety
+                        else sat_info_rhs'
+
+    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)
+                              rhs_binders rhs_body'
+    return (bind', sat_info_rhs'')
+satBind (Rec pairs) interesting_ids = do
+    let (binders, rhss) = unzip pairs
+    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss
+    let (rhss', sat_info_rhss') = unzip rhss_SATed
+    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
+
+data App = VarApp Id | TypeApp Type | CoApp Coercion
+data Staticness a = Static a | NotStatic
+
+type IdAppInfo = (Id, SATInfo)
+
+type SATInfo = [Staticness App]
+type IdSATInfo = IdEnv SATInfo
+emptyIdSATInfo :: IdSATInfo
+emptyIdSATInfo = emptyUFM
+
+{-
+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))
+  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)
+-}
+
+pprSATInfo :: SATInfo -> SDoc
+pprSATInfo staticness = hcat $ map pprStaticness staticness
+
+pprStaticness :: Staticness App -> SDoc
+pprStaticness (Static (VarApp _))  = text "SV"
+pprStaticness (Static (TypeApp _)) = text "ST"
+pprStaticness (Static (CoApp _))   = text "SC"
+pprStaticness NotStatic            = text "NS"
+
+
+mergeSATInfo :: SATInfo -> SATInfo -> SATInfo
+mergeSATInfo l r = zipWith mergeSA l r
+  where
+    mergeSA NotStatic _ = NotStatic
+    mergeSA _ NotStatic = NotStatic
+    mergeSA (Static (VarApp v)) (Static (VarApp v'))
+      | v == v'   = Static (VarApp v)
+      | otherwise = NotStatic
+    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))
+      | t `eqType` t' = Static (TypeApp t)
+      | otherwise     = NotStatic
+    mergeSA (Static (CoApp c)) (Static (CoApp c'))
+      | c `eqCoercion` c' = Static (CoApp c)
+      | otherwise             = NotStatic
+    mergeSA _ _  = pprPanic "mergeSATInfo" $
+                          text "Left:"
+                       <> pprSATInfo l <> text ", "
+                       <> text "Right:"
+                       <> pprSATInfo r
+
+mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo
+mergeIdSATInfo = plusUFM_C mergeSATInfo
+
+mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo
+mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo
+
+bindersToSATInfo :: [Id] -> SATInfo
+bindersToSATInfo vs = map (Static . binderToApp) vs
+    where binderToApp v | isId v    = VarApp v
+                        | isTyVar v = TypeApp $ mkTyVarTy v
+                        | otherwise = CoApp $ mkCoVarCo v
+
+finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
+finalizeApp Nothing id_sat_info = id_sat_info
+finalizeApp (Just (v, sat_info')) id_sat_info =
+    let sat_info'' = case lookupUFM id_sat_info v of
+                        Nothing -> sat_info'
+                        Just sat_info -> mergeSATInfo sat_info sat_info'
+    in extendVarEnv id_sat_info v sat_info''
+
+satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
+satTopLevelExpr expr interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (expr', finalizeApp expr_app sat_info_expr)
+
+satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
+satExpr var@(Var v) interesting_ids = do
+    let app_info = if v `elementOfUniqSet` interesting_ids
+                   then Just (v, [])
+                   else Nothing
+    return (var, emptyIdSATInfo, app_info)
+
+satExpr lit@(Lit _) _ = do
+    return (lit, emptyIdSATInfo, Nothing)
+
+satExpr (Lam binders body) interesting_ids = do
+    (body', sat_info, this_app) <- satExpr body interesting_ids
+    return (Lam binders body', finalizeApp this_app sat_info, Nothing)
+
+satExpr (App fn arg) interesting_ids = do
+    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids
+    let satRemainder = boring fn' sat_info_fn
+    case fn_app of
+        Nothing -> satRemainder Nothing
+        Just (fn_id, fn_app_info) ->
+            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
+            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
+            in case arg of
+                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)
+                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
+                Var v      -> satRemainderWithStaticness $ Static (VarApp v)
+                _          -> satRemainderWithStaticness $ NotStatic
+  where
+    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
+    boring fn' sat_info_fn app_info =
+        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids
+           let sat_info_arg' = finalizeApp arg_app sat_info_arg
+               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'
+           return (App fn' arg', sat_info, app_info)
+
+satExpr (Case expr bndr ty alts) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    let sat_info_expr' = finalizeApp expr_app sat_info_expr
+
+    zipped_alts' <- mapM satAlt alts
+    let (alts', sat_infos_alts) = unzip zipped_alts'
+    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)
+  where
+    satAlt (con, bndrs, expr) = do
+        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids
+        return ((con, bndrs, expr'), sat_info_expr)
+
+satExpr (Let bind body) interesting_ids = do
+    (body', sat_info_body, body_app) <- satExpr body interesting_ids
+    (bind', sat_info_bind) <- satBind bind interesting_ids
+    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)
+
+satExpr (Tick tickish expr) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (Tick tickish expr', sat_info_expr, expr_app)
+
+satExpr ty@(Type _) _ = do
+    return (ty, emptyIdSATInfo, Nothing)
+
+satExpr co@(Coercion _) _ = do
+    return (co, emptyIdSATInfo, Nothing)
+
+satExpr (Cast expr coercion) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (Cast expr' coercion, sat_info_expr, expr_app)
+
+{-
+************************************************************************
+
+                Static Argument Transformation Monad
+
+************************************************************************
+-}
+
+type SatM result = UniqSM result
+
+runSAT :: UniqSupply -> SatM a -> a
+runSAT = initUs_
+
+newUnique :: SatM Unique
+newUnique = getUniqueM
+
+{-
+************************************************************************
+
+                Static Argument Transformation Monad
+
+************************************************************************
+
+To do the transformation, the game plan is to:
+
+1. Create a small nonrecursive RHS that takes the
+   original arguments to the function but discards
+   the ones that are static and makes a call to the
+   SATed version with the remainder. We intend that
+   this will be inlined later, removing the overhead
+
+2. Bind this nonrecursive RHS over the original body
+   WITH THE SAME UNIQUE as the original body so that
+   any recursive calls to the original now go via
+   the small wrapper
+
+3. Rebind the original function to a new one which contains
+   our SATed function and just makes a call to it:
+   we call the thing making this call the local body
+
+Example: transform this
+
+    map :: forall a b. (a->b) -> [a] -> [b]
+    map = /\ab. \(f:a->b) (as:[a]) -> body[map]
+to
+    map :: forall a b. (a->b) -> [a] -> [b]
+    map = /\ab. \(f:a->b) (as:[a]) ->
+         letrec map' :: [a] -> [b]
+                    -- The "worker function
+                map' = \(as:[a]) ->
+                         let map :: forall a' b'. (a -> b) -> [a] -> [b]
+                                -- The "shadow function
+                             map = /\a'b'. \(f':(a->b) (as:[a]).
+                                   map' as
+                         in body[map]
+         in map' as
+
+Note [Shadow binding]
+~~~~~~~~~~~~~~~~~~~~~
+The calls to the inner map inside body[map] should get inlined
+by the local re-binding of 'map'.  We call this the "shadow binding".
+
+But we can't use the original binder 'map' unchanged, because
+it might be exported, in which case the shadow binding won't be
+discarded as dead code after it is inlined.
+
+So we use a hack: we make a new SysLocal binder with the *same* unique
+as binder.  (Another alternative would be to reset the export flag.)
+
+Note [Binder type capture]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that in the inner map (the "shadow function"), the static arguments
+are discarded -- it's as if they were underscores.  Instead, mentions
+of these arguments (notably in the types of dynamic arguments) are bound
+by the *outer* lambdas of the main function.  So we must make up fresh
+names for the static arguments so that they do not capture variables
+mentioned in the types of dynamic args.
+
+In the map example, the shadow function must clone the static type
+argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'
+is bound by the outer forall.  We clone f' too for consistency, but
+that doesn't matter either way because static Id arguments aren't
+mentioned in the shadow binding at all.
+
+If we don't we get something like this:
+
+[Exported]
+[Arity 3]
+GHC.Base.until =
+  \ (@ a_aiK)
+    (p_a6T :: a_aiK -> GHC.Types.Bool)
+    (f_a6V :: a_aiK -> a_aiK)
+    (x_a6X :: a_aiK) ->
+    letrec {
+      sat_worker_s1aU :: a_aiK -> a_aiK
+      []
+      sat_worker_s1aU =
+        \ (x_a6X :: a_aiK) ->
+          let {
+            sat_shadow_r17 :: forall a_a3O.
+                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O
+            []
+            sat_shadow_r17 =
+              \ (@ a_aiK)
+                (p_a6T :: a_aiK -> GHC.Types.Bool)
+                (f_a6V :: a_aiK -> a_aiK)
+                (x_a6X :: a_aiK) ->
+                sat_worker_s1aU x_a6X } in
+          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {
+            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);
+            GHC.Types.True -> x_a6X
+          }; } in
+    sat_worker_s1aU x_a6X
+
+Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK
+type argument. This is bad because it means the application sat_worker_s1aU x_a6X
+is not well typed.
+-}
+
+saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
+saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
+  | Just arg_staticness <- maybe_arg_staticness
+  , should_transform arg_staticness
+  = saTransform binder arg_staticness rhs_binders rhs_body
+  | otherwise
+  = return (Rec [(binder, mkLams rhs_binders rhs_body)])
+  where
+    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT
+      where
+        n_static_args = count isStaticValue staticness
+
+saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
+saTransform binder arg_staticness rhs_binders rhs_body
+  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness
+        ; uniq             <- newUnique
+        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }
+  where
+    -- Running example: foldr
+    -- foldr \alpha \beta c n xs = e, for some e
+    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]
+    -- rhs_binders = [\alpha, \beta, c, n, xs]
+    -- rhs_body = e
+
+    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)
+                                        -- Any extra args are assumed NotStatic
+
+    non_static_args :: [Var]
+            -- non_static_args = [xs]
+            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]
+    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]
+
+    clone (bndr, NotStatic) = return bndr
+    clone (bndr, _        ) = do { uniq <- newUnique
+                                 ; return (setVarUnique bndr uniq) }
+
+    -- new_rhs = \alpha beta c n xs ->
+    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->
+    --                                       sat_worker xs
+    --                                   in e
+    --           in sat_worker xs
+    mk_new_rhs uniq shadow_lam_bndrs
+        = mkLams rhs_binders $
+          Let (Rec [(rec_body_bndr, rec_body)])
+          local_body
+        where
+          local_body = mkVarApps (Var rec_body_bndr) non_static_args
+
+          rec_body = mkLams non_static_args $
+                     Let (NonRec shadow_bndr shadow_rhs) rhs_body
+
+            -- See Note [Binder type capture]
+          shadow_rhs = mkLams shadow_lam_bndrs local_body
+            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs
+
+          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body)
+            -- rec_body_bndr = sat_worker
+
+            -- See Note [Shadow binding]; make a SysLocal
+          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))
+                                   (idUnique binder)
+                                   (exprType shadow_rhs)
+
+isStaticValue :: Staticness App -> Bool
+isStaticValue (Static (VarApp _)) = True
+isStaticValue _                   = False
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SetLevels.hs
@@ -0,0 +1,1722 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section{SetLevels}
+
+                ***************************
+                        Overview
+                ***************************
+
+1. We attach binding levels to Core bindings, in preparation for floating
+   outwards (@FloatOut@).
+
+2. We also let-ify many expressions (notably case scrutinees), so they
+   will have a fighting chance of being floated sensible.
+
+3. Note [Need for cloning during float-out]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   We clone the binders of any floatable let-binding, so that when it is
+   floated out it will be unique. Example
+      (let x=2 in x) + (let x=3 in x)
+   we must clone before floating so we get
+      let x1=2 in
+      let x2=3 in
+      x1+x2
+
+   NOTE: this can't be done using the uniqAway idea, because the variable
+         must be unique in the whole program, not just its current scope,
+         because two variables in different scopes may float out to the
+         same top level place
+
+   NOTE: Very tiresomely, we must apply this substitution to
+         the rules stored inside a variable too.
+
+   We do *not* clone top-level bindings, because some of them must not change,
+   but we *do* clone bindings that are heading for the top level
+
+4. Note [Binder-swap during float-out]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   In the expression
+        case x of wild { p -> ...wild... }
+   we substitute x for wild in the RHS of the case alternatives:
+        case x of wild { p -> ...x... }
+   This means that a sub-expression involving x is not "trapped" inside the RHS.
+   And it's not inconvenient because we already have a substitution.
+
+  Note that this is EXACTLY BACKWARDS from the what the simplifier does.
+  The simplifier tries to get rid of occurrences of x, in favour of wild,
+  in the hope that there will only be one remaining occurrence of x, namely
+  the scrutinee of the case, and we can inline it.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+module SetLevels (
+        setLevels,
+
+        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
+        LevelledBind, LevelledExpr, LevelledBndr,
+        FloatSpec(..), floatSpecLevel,
+
+        incMinorLvl, ltMajLvl, ltLvl, isTopLvl
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreMonad        ( FloatOutSwitches(..) )
+import CoreUtils        ( exprType, exprIsHNF
+                        , exprOkForSpeculation
+                        , exprIsTopLevelBindable
+                        , isExprLevPoly
+                        , collectMakeStaticArgs
+                        )
+import CoreArity        ( exprBotStrictness_maybe )
+import CoreFVs          -- all of it
+import CoreSubst
+import MkCore           ( sortQuantVars )
+
+import Id
+import IdInfo
+import Var
+import VarSet
+import UniqSet          ( nonDetFoldUniqSet )
+import UniqDSet         ( getUniqDSet )
+import VarEnv
+import Literal          ( litIsTrivial )
+import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
+import Name             ( getOccName, mkSystemVarName )
+import OccName          ( occNameString )
+import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )
+import BasicTypes       ( Arity, RecFlag(..), isRec )
+import DataCon          ( dataConOrigResTy )
+import TysWiredIn
+import UniqSupply
+import Util
+import Outputable
+import FastString
+import UniqDFM
+import FV
+import Data.Maybe
+import MonadUtils       ( mapAccumLM )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Level numbers}
+*                                                                      *
+************************************************************************
+-}
+
+type LevelledExpr = TaggedExpr FloatSpec
+type LevelledBind = TaggedBind FloatSpec
+type LevelledBndr = TaggedBndr FloatSpec
+
+data Level = Level Int  -- Level number of enclosing lambdas
+                   Int  -- Number of big-lambda and/or case expressions and/or
+                        -- context boundaries between
+                        -- here and the nearest enclosing lambda
+                   LevelType -- Binder or join ceiling?
+data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)
+
+data FloatSpec
+  = FloatMe Level       -- Float to just inside the binding
+                        --    tagged with this level
+  | StayPut Level       -- Stay where it is; binding is
+                        --     tagged with this level
+
+floatSpecLevel :: FloatSpec -> Level
+floatSpecLevel (FloatMe l) = l
+floatSpecLevel (StayPut l) = l
+
+{-
+The {\em level number} on a (type-)lambda-bound variable is the
+nesting depth of the (type-)lambda which binds it.  The outermost lambda
+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
+
+On an expression, it's the maximum level number of its free
+(type-)variables.  On a let(rec)-bound variable, it's the level of its
+RHS.  On a case-bound variable, it's the number of enclosing lambdas.
+
+Top-level variables: level~0.  Those bound on the RHS of a top-level
+definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
+as ``subscripts'')...
+\begin{verbatim}
+a_0 = let  b_? = ...  in
+           x_1 = ... b ... in ...
+\end{verbatim}
+
+The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).
+That's meant to be the level number of the enclosing binder in the
+final (floated) program.  If the level number of a sub-expression is
+less than that of the context, then it might be worth let-binding the
+sub-expression so that it will indeed float.
+
+If you can float to level @Level 0 0@ worth doing so because then your
+allocation becomes static instead of dynamic.  We always start with
+context @Level 0 0@.
+
+
+Note [FloatOut inside INLINE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
+to say "don't float anything out of here".  That's exactly what we
+want for the body of an INLINE, where we don't want to float anything
+out at all.  See notes with lvlMFE below.
+
+But, check this out:
+
+-- At one time I tried the effect of not floating anything out of an InlineMe,
+-- but it sometimes works badly.  For example, consider PrelArr.done.  It
+-- has the form         __inline (\d. e)
+-- where e doesn't mention d.  If we float this to
+--      __inline (let x = e in \d. x)
+-- things are bad.  The inliner doesn't even inline it because it doesn't look
+-- like a head-normal form.  So it seems a lesser evil to let things float.
+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
+-- which discourages floating out.
+
+So the conclusion is: don't do any floating at all inside an InlineMe.
+(In the above example, don't float the {x=e} out of the \d.)
+
+One particular case is that of workers: we don't want to float the
+call to the worker outside the wrapper, otherwise the worker might get
+inlined into the floated expression, and an importing module won't see
+the worker at all.
+
+Note [Join ceiling]
+~~~~~~~~~~~~~~~~~~~
+Join points can't float very far; too far, and they can't remain join points
+So, suppose we have:
+
+  f x = (joinrec j y = ... x ... in jump j x) + 1
+
+One may be tempted to float j out to the top of f's RHS, but then the jump
+would not be a tail call. Thus we keep track of a level called the *join
+ceiling* past which join points are not allowed to float.
+
+The troublesome thing is that, unlike most levels to which something might
+float, there is not necessarily an identifier to which the join ceiling is
+attached. Fortunately, if something is to be floated to a join ceiling, it must
+be dropped at the *nearest* join ceiling. Thus each level is marked as to
+whether it is a join ceiling, so that FloatOut can tell which binders are being
+floated to the nearest join ceiling and which to a particular binder (or set of
+binders).
+-}
+
+instance Outputable FloatSpec where
+  ppr (FloatMe l) = char 'F' <> ppr l
+  ppr (StayPut l) = ppr l
+
+tOP_LEVEL :: Level
+tOP_LEVEL   = Level 0 0 BndrLvl
+
+incMajorLvl :: Level -> Level
+incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl
+
+incMinorLvl :: Level -> Level
+incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl
+
+asJoinCeilLvl :: Level -> Level
+asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl
+
+maxLvl :: Level -> Level -> Level
+maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)
+  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
+  | otherwise                                      = l2
+
+ltLvl :: Level -> Level -> Bool
+ltLvl (Level maj1 min1 _) (Level maj2 min2 _)
+  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
+
+ltMajLvl :: Level -> Level -> Bool
+    -- Tells if one level belongs to a difft *lambda* level to another
+ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2
+
+isTopLvl :: Level -> Bool
+isTopLvl (Level 0 0 _) = True
+isTopLvl _             = False
+
+isJoinCeilLvl :: Level -> Bool
+isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl
+
+instance Outputable Level where
+  ppr (Level maj min typ)
+    = hcat [ char '<', int maj, char ',', int min, char '>'
+           , ppWhen (typ == JoinCeilLvl) (char 'C') ]
+
+instance Eq Level where
+  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Main level-setting code}
+*                                                                      *
+************************************************************************
+-}
+
+setLevels :: FloatOutSwitches
+          -> CoreProgram
+          -> UniqSupply
+          -> [LevelledBind]
+
+setLevels float_lams binds us
+  = initLvl us (do_them init_env binds)
+  where
+    init_env = initialEnv float_lams
+
+    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]
+    do_them _ [] = return []
+    do_them env (b:bs)
+      = do { (lvld_bind, env') <- lvlTopBind env b
+           ; lvld_binds <- do_them env' bs
+           ; return (lvld_bind : lvld_binds) }
+
+lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
+lvlTopBind env (NonRec bndr rhs)
+  = do { rhs' <- lvl_top env NonRecursive bndr rhs
+       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]
+       ; return (NonRec bndr' rhs', env') }
+
+lvlTopBind env (Rec pairs)
+  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL
+                                               (map fst pairs)
+       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs
+       ; return (Rec (bndrs' `zip` rhss'), env') }
+
+lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr
+lvl_top env is_rec bndr rhs
+  = lvlRhs env is_rec
+           (isBottomingId bndr)
+           Nothing  -- Not a join point
+           (freeVars rhs)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Setting expression levels}
+*                                                                      *
+************************************************************************
+
+Note [Floating over-saturated applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see (f x y), and (f x) is a redex (ie f's arity is 1),
+we call (f x) an "over-saturated application"
+
+Should we float out an over-sat app, if can escape a value lambda?
+It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
+But we don't want to do it for class selectors, because the work saved
+is minimal, and the extra local thunks allocated cost money.
+
+Arguably we could float even class-op applications if they were going to
+top level -- but then they must be applied to a constant dictionary and
+will almost certainly be optimised away anyway.
+-}
+
+lvlExpr :: LevelEnv             -- Context
+        -> CoreExprWithFVs      -- Input expression
+        -> LvlM LevelledExpr    -- Result expression
+
+{-
+The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing
+binder.  Here's an example
+
+        v = \x -> ...\y -> let r = case (..x..) of
+                                        ..x..
+                           in ..
+
+When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's
+the level of @r@, even though it's inside a level-2 @\y@.  It's
+important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
+don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
+--- because it isn't a *maximal* free expression.
+
+If there were another lambda in @r@'s rhs, it would get level-2 as well.
+-}
+
+lvlExpr env (_, AnnType ty)     = return (Type (CoreSubst.substTy (le_subst env) ty))
+lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
+lvlExpr env (_, AnnVar v)       = return (lookupVar env v)
+lvlExpr _   (_, AnnLit lit)     = return (Lit lit)
+
+lvlExpr env (_, AnnCast expr (_, co)) = do
+    expr' <- lvlNonTailExpr env expr
+    return (Cast expr' (substCo (le_subst env) co))
+
+lvlExpr env (_, AnnTick tickish expr) = do
+    expr' <- lvlNonTailExpr env expr
+    let tickish' = substTickish (le_subst env) tickish
+    return (Tick tickish' expr')
+
+lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)
+
+-- We don't split adjacent lambdas.  That is, given
+--      \x y -> (x+1,y)
+-- we don't float to give
+--      \x -> let v = x+1 in \y -> (v,y)
+-- Why not?  Because partial applications are fairly rare, and splitting
+-- lambdas makes them more expensive.
+
+lvlExpr env expr@(_, AnnLam {})
+  = do { new_body <- lvlNonTailMFE new_env True body
+       ; return (mkLams new_bndrs new_body) }
+  where
+    (bndrs, body)        = collectAnnBndrs expr
+    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs
+    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
+        -- At one time we called a special version of collectBinders,
+        -- which ignored coercions, because we don't want to split
+        -- a lambda like this (\x -> coerce t (\s -> ...))
+        -- This used to happen quite a bit in state-transformer programs,
+        -- but not nearly so much now non-recursive newtypes are transparent.
+        -- [See SetLevels rev 1.50 for a version with this approach.]
+
+lvlExpr env (_, AnnLet bind body)
+  = do { (bind', new_env) <- lvlBind env bind
+       ; body' <- lvlExpr new_env body
+           -- No point in going via lvlMFE here.  If the binding is alive
+           -- (mentioned in body), and the whole let-expression doesn't
+           -- float, then neither will the body
+       ; return (Let bind' body') }
+
+lvlExpr env (_, AnnCase scrut case_bndr ty alts)
+  = do { scrut' <- lvlNonTailMFE env True scrut
+       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
+
+lvlNonTailExpr :: LevelEnv             -- Context
+               -> CoreExprWithFVs      -- Input expression
+               -> LvlM LevelledExpr    -- Result expression
+lvlNonTailExpr env expr
+  = lvlExpr (placeJoinCeiling env) expr
+
+-------------------------------------------
+lvlApp :: LevelEnv
+       -> CoreExprWithFVs
+       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
+        -> LvlM LevelledExpr                   -- Result expression
+lvlApp env orig_expr ((_,AnnVar fn), args)
+  | floatOverSat env   -- See Note [Floating over-saturated applications]
+  , arity > 0
+  , arity < n_val_args
+  , Nothing <- isClassOpId_maybe fn
+  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs
+        ; lapp'  <- lvlNonTailMFE env False lapp
+        ; return (foldl' App lapp' rargs') }
+
+  | otherwise
+  = do { (_, args') <- mapAccumLM lvl_arg stricts args
+            -- Take account of argument strictness; see
+            -- Note [Floating to the top]
+       ; return (foldl' App (lookupVar env fn) args') }
+  where
+    n_val_args = count (isValArg . deAnnotate) args
+    arity      = idArity fn
+
+    stricts :: [Demand]   -- True for strict /value/ arguments
+    stricts = case splitStrictSig (idStrictness fn) of
+                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args
+                            -> []
+                            | otherwise
+                            -> arg_ds
+
+    -- Separate out the PAP that we are floating from the extra
+    -- arguments, by traversing the spine until we have collected
+    -- (n_val_args - arity) value arguments.
+    (lapp, rargs) = left (n_val_args - arity) orig_expr []
+
+    left 0 e               rargs = (e, rargs)
+    left n (_, AnnApp f a) rargs
+       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
+       | otherwise               = left n     f (a:rargs)
+    left _ _ _                   = panic "SetLevels.lvlExpr.left"
+
+    is_val_arg :: CoreExprWithFVs -> Bool
+    is_val_arg (_, AnnType {}) = False
+    is_val_arg _               = True
+
+    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)
+    lvl_arg strs arg | (str1 : strs') <- strs
+                     , is_val_arg arg
+                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg
+                          ; return (strs', arg') }
+                     | otherwise
+                     = do { arg' <- lvlMFE env False arg
+                          ; return (strs, arg') }
+
+lvlApp env _ (fun, args)
+  =  -- No PAPs that we can float: just carry on with the
+     -- arguments and the function.
+     do { args' <- mapM (lvlNonTailMFE env False) args
+        ; fun'  <- lvlNonTailExpr env fun
+        ; return (foldl' App fun' args') }
+
+-------------------------------------------
+lvlCase :: LevelEnv             -- Level of in-scope names/tyvars
+        -> DVarSet              -- Free vars of input scrutinee
+        -> LevelledExpr         -- Processed scrutinee
+        -> Id -> Type           -- Case binder and result type
+        -> [CoreAltWithFVs]     -- Input alternatives
+        -> LvlM LevelledExpr    -- Result expression
+lvlCase env scrut_fvs scrut' case_bndr ty alts
+  -- See Note [Floating single-alternative cases]
+  | [(con@(DataAlt {}), bs, body)] <- alts
+  , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]
+  , not (isTopLvl dest_lvl)       -- Can't have top-level cases
+  , not (floatTopLvlOnly env)     -- Can float anywhere
+  =     -- Always float the case if possible
+        -- Unlike lets we don't insist that it escapes a value lambda
+    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
+       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
+       ; body' <- lvlMFE rhs_env True body
+       ; let alt' = (con, map (stayPut dest_lvl) bs', body')
+       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
+
+  | otherwise     -- Stays put
+  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
+             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
+       ; alts' <- mapM (lvl_alt alts_env) alts
+       ; return (Case scrut' case_bndr' ty' alts') }
+  where
+    ty' = substTy (le_subst env) ty
+
+    incd_lvl = incMinorLvl (le_ctxt_lvl env)
+    dest_lvl = maxFvLevel (const True) env scrut_fvs
+            -- Don't abstract over type variables, hence const True
+
+    lvl_alt alts_env (con, bs, rhs)
+      = do { rhs' <- lvlMFE new_env True rhs
+           ; return (con, bs', rhs') }
+      where
+        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
+
+{- Note [Floating single-alternative cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+  data T a = MkT !a
+  f :: T Int -> blah
+  f x vs = case x of { MkT y ->
+             let f vs = ...(case y of I# w -> e)...f..
+             in f vs
+
+Here we can float the (case y ...) out, because y is sure
+to be evaluated, to give
+  f x vs = case x of { MkT y ->
+           caes y of I# w ->
+             let f vs = ...(e)...f..
+             in f vs
+
+That saves unboxing it every time round the loop.  It's important in
+some DPH stuff where we really want to avoid that repeated unboxing in
+the inner loop.
+
+Things to note:
+
+ * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.
+
+     - exrpIsHNF catches the key case of an evaluated variable
+
+     - exprOkForSpeculation is /false/ of an evaluated variable;
+       See Note [exprOkForSpeculation and evaluated variables] in CoreUtils
+       So we'd actually miss the key case!
+
+     - Nothing is gained from the extra generality of exprOkForSpeculation
+       since we only consider floating a case whose single alternative
+       is a DataAlt   K a b -> rhs
+
+ * We can't float a case to top level
+
+ * It's worth doing this float even if we don't float
+   the case outside a value lambda.  Example
+     case x of {
+       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
+   If we floated the cases out we could eliminate one of them.
+
+ * We only do this with a single-alternative case
+
+Note [Check the output scrutinee for exprIsHNF]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+  case x of y {
+    A -> ....(case y of alts)....
+  }
+
+Because of the binder-swap, the inner case will get substituted to
+(case x of ..).  So when testing whether the scrutinee is in HNF we
+must be careful to test the *result* scrutinee ('x' in this case), not
+the *input* one 'y'.  The latter *is* in HNF here (because y is
+evaluated), but the former is not -- and indeed we can't float the
+inner case out, at least not unless x is also evaluated at its binding
+site.  See #5453.
+
+That's why we apply exprIsHNF to scrut' and not to scrut.
+
+See Note [Floating single-alternative cases] for why
+we use exprIsHNF in the first place.
+-}
+
+lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars
+              -> Bool                 -- True <=> strict context [body of case
+                                      --   or let]
+              -> CoreExprWithFVs      -- input expression
+              -> LvlM LevelledExpr    -- Result expression
+lvlNonTailMFE env strict_ctxt ann_expr
+  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr
+
+lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars
+        -> Bool                 -- True <=> strict context [body of case or let]
+        -> CoreExprWithFVs      -- input expression
+        -> LvlM LevelledExpr    -- Result expression
+-- lvlMFE is just like lvlExpr, except that it might let-bind
+-- the expression, so that it can itself be floated.
+
+lvlMFE env _ (_, AnnType ty)
+  = return (Type (CoreSubst.substTy (le_subst env) ty))
+
+-- No point in floating out an expression wrapped in a coercion or note
+-- If we do we'll transform  lvl = e |> co
+--                       to  lvl' = e; lvl = lvl' |> co
+-- and then inline lvl.  Better just to float out the payload.
+lvlMFE env strict_ctxt (_, AnnTick t e)
+  = do { e' <- lvlMFE env strict_ctxt e
+       ; let t' = substTickish (le_subst env) t
+       ; return (Tick t' e') }
+
+lvlMFE env strict_ctxt (_, AnnCast e (_, co))
+  = do  { e' <- lvlMFE env strict_ctxt e
+        ; return (Cast e' (substCo (le_subst env) co)) }
+
+lvlMFE env strict_ctxt e@(_, AnnCase {})
+  | strict_ctxt       -- Don't share cases in a strict context
+  = lvlExpr env e     -- See Note [Case MFEs]
+
+lvlMFE env strict_ctxt ann_expr
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float
+                               -- See Note [Free join points]
+  || isExprLevPoly expr
+         -- We can't let-bind levity polymorphic expressions
+         -- See Note [Levity polymorphism invariants] in CoreSyn
+  || notWorthFloating expr abs_vars
+  || not float_me
+  =     -- Don't float it out
+    lvlExpr env ann_expr
+
+  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty
+         -- No wrapping needed if the type is lifted, or is a literal string
+         -- or if we are wrapping it in one or more value lambdas
+  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
+                              (isJust mb_bot_str)
+                              join_arity_maybe
+                              ann_expr
+                  -- Treat the expr just like a right-hand side
+       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
+       ; let var2 = annotateBotStr var float_n_lams mb_bot_str
+       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
+                     (mkVarApps (Var var2) abs_vars)) }
+
+  -- OK, so the float has an unlifted type (not top-level bindable)
+  --     and no new value lambdas (float_is_new_lam is False)
+  -- Try for the boxing strategy
+  -- See Note [Floating MFEs of unlifted type]
+  | escapes_value_lam
+  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions
+                         -- See Note [Test cheapness with exprOkForSpeculation]
+  , Just (tc, _) <- splitTyConApp_maybe expr_ty
+  , Just dc <- boxingDataCon_maybe tc
+  , let dc_res_ty = dataConOrigResTy dc  -- No free type variables
+        [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]
+  = do { expr1 <- lvlExpr rhs_env ann_expr
+       ; let l1r       = incMinorLvlFrom rhs_env
+             float_rhs = mkLams abs_vars_w_lvls $
+                         Case expr1 (stayPut l1r ubx_bndr) dc_res_ty
+                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]
+
+       ; var <- newLvlVar float_rhs Nothing is_mk_static
+       ; let l1u      = incMinorLvlFrom env
+             use_expr = Case (mkVarApps (Var var) abs_vars)
+                             (stayPut l1u bx_bndr) expr_ty
+                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]
+       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
+                     use_expr) }
+
+  | otherwise          -- e.g. do not float unboxed tuples
+  = lvlExpr env ann_expr
+
+  where
+    expr         = deAnnotate ann_expr
+    expr_ty      = exprType expr
+    fvs          = freeVarsOf ann_expr
+    fvs_ty       = tyCoVarsOfType expr_ty
+    is_bot       = isBottomThunk mb_bot_str
+    is_function  = isFunction ann_expr
+    mb_bot_str   = exprBotStrictness_maybe expr
+                           -- See Note [Bottoming floats]
+                           -- esp Bottoming floats (2)
+    expr_ok_for_spec = exprOkForSpeculation expr
+    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False
+    abs_vars     = abstractVars dest_lvl env fvs
+
+    -- float_is_new_lam: the floated thing will be a new value lambda
+    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is
+    -- allocation saved.  The benefit is to get it to the top level
+    -- and hence out of the body of this function altogether, making
+    -- it smaller and more inlinable
+    float_is_new_lam = float_n_lams > 0
+    float_n_lams     = count isId abs_vars
+
+    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
+
+    join_arity_maybe = Nothing
+
+    is_mk_static = isJust (collectMakeStaticArgs expr)
+        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable
+
+        -- A decision to float entails let-binding this thing, and we only do
+        -- that if we'll escape a value lambda, or will go to the top level.
+    float_me = saves_work || saves_alloc || is_mk_static
+
+    -- We can save work if we can move a redex outside a value lambda
+    -- But if float_is_new_lam is True, then the redex is wrapped in a
+    -- a new lambda, so no work is saved
+    saves_work = escapes_value_lam && not float_is_new_lam
+
+    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
+                  -- See Note [Escaping a value lambda]
+
+    -- See Note [Floating to the top]
+    saves_alloc =  isTopLvl dest_lvl
+                && floatConsts env
+                && (not strict_ctxt || is_bot || exprIsHNF expr)
+
+isBottomThunk :: Maybe (Arity, s) -> Bool
+-- See Note [Bottoming floats] (2)
+isBottomThunk (Just (0, _)) = True   -- Zero arity
+isBottomThunk _             = False
+
+{- Note [Floating to the top]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are keen to float something to the top level, even if it does not
+escape a value lambda (and hence save work), for two reasons:
+
+  * Doing so makes the function smaller, by floating out
+    bottoming expressions, or integer or string literals.  That in
+    turn makes it easier to inline, with less duplication.
+
+  * (Minor) Doing so may turn a dynamic allocation (done by machine
+    instructions) into a static one. Minor because we are assuming
+    we are not escaping a value lambda.
+
+But do not so if:
+     - the context is a strict, and
+     - the expression is not a HNF, and
+     - the expression is not bottoming
+
+Exammples:
+
+* Bottoming
+      f x = case x of
+              0 -> error <big thing>
+              _ -> x+1
+  Here we want to float (error <big thing>) to top level, abstracting
+  over 'x', so as to make f's RHS smaller.
+
+* HNF
+      f = case y of
+            True  -> p:q
+            False -> blah
+  We may as well float the (p:q) so it becomes a static data structure.
+
+* Case scrutinee
+      f = case g True of ....
+  Don't float (g True) to top level; then we have the admin of a
+  top-level thunk to worry about, with zero gain.
+
+* Case alternative
+      h = case y of
+             True  -> g True
+             False -> False
+  Don't float (g True) to the top level
+
+* Arguments
+     t = f (g True)
+  If f is lazy, we /do/ float (g True) because then we can allocate
+  the thunk statically rather than dynamically.  But if f is strict
+  we don't (see the use of idStrictness in lvlApp).  It's not clear
+  if this test is worth the bother: it's only about CAFs!
+
+It's controlled by a flag (floatConsts), because doing this too
+early loses opportunities for RULES which (needless to say) are
+important in some nofib programs (gcd is an example).  [SPJ note:
+I think this is obselete; the flag seems always on.]
+
+Note [Floating join point bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Mostly we only float a join point if it can /stay/ a join point.  But
+there is one exception: if it can go to the top level (#13286).
+Consider
+  f x = joinrec j y n = <...j y' n'...>
+        in jump j x 0
+
+Here we may just as well produce
+  j y n = <....j y' n'...>
+  f x = j x 0
+
+and now there is a chance that 'f' will be inlined at its call sites.
+It shouldn't make a lot of difference, but thes tests
+  perf/should_run/MethSharing
+  simplCore/should_compile/spec-inline
+and one nofib program, all improve if you do float to top, because
+of the resulting inlining of f.  So ok, let's do it.
+
+Note [Free join points]
+~~~~~~~~~~~~~~~~~~~~~~~
+We never float a MFE that has a free join-point variable.  You mght think
+this can never occur.  After all, consider
+     join j x = ...
+     in ....(jump j x)....
+How might we ever want to float that (jump j x)?
+  * If it would escape a value lambda, thus
+        join j x = ... in (\y. ...(jump j x)... )
+    then 'j' isn't a valid join point in the first place.
+
+But consider
+     join j x = .... in
+     joinrec j2 y =  ...(jump j x)...(a+b)....
+
+Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.
+But it is emphatically /not/ good to float the (jump j x) out:
+ (a) 'j' will stop being a join point
+ (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no
+     work would be saved by floating it out of the \y.
+
+Even if we floated 'j' to top level, (b) would still hold.
+
+Bottom line: never float a MFE that has a free JoinId.
+
+Note [Floating MFEs of unlifted type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   case f x of (r::Int#) -> blah
+we'd like to float (f x). But it's not trivial because it has type
+Int#, and we don't want to evaluate it too early.  But we can instead
+float a boxed version
+   y = case f x of r -> I# r
+and replace the original (f x) with
+   case (case y of I# r -> r) of r -> blah
+
+Being able to float unboxed expressions is sometimes important; see
+#12603.  I'm not sure how /often/ it is important, but it's
+not hard to achieve.
+
+We only do it for a fixed collection of types for which we have a
+convenient boxing constructor (see boxingDataCon_maybe).  In
+particular we /don't/ do it for unboxed tuples; it's better to float
+the components of the tuple individually.
+
+I did experiment with a form of boxing that works for any type, namely
+wrapping in a function.  In our example
+
+   let y = case f x of r -> \v. f x
+   in case y void of r -> blah
+
+It works fine, but it's 50% slower (based on some crude benchmarking).
+I suppose we could do it for types not covered by boxingDataCon_maybe,
+but it's more code and I'll wait to see if anyone wants it.
+
+Note [Test cheapness with exprOkForSpeculation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't want to float very cheap expressions by boxing and unboxing.
+But we use exprOkForSpeculation for the test, not exprIsCheap.
+Why?  Because it's important /not/ to transform
+     f (a /# 3)
+to
+     f (case bx of I# a -> a /# 3)
+and float bx = I# (a /# 3), because the application of f no
+longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec
+due to a special hack that says division operators can't fail
+when the denominator is definitely non-zero.  And yet that
+same expression says False to exprIsCheap.  Simplest way to
+guarantee the let/app invariant is to use the same function!
+
+If an expression is okay for speculation, we could also float it out
+*without* boxing and unboxing, since evaluating it early is okay.
+However, it turned out to usually be better not to float such expressions,
+since they tend to be extremely cheap things like (x +# 1#). Even the
+cost of spilling the let-bound variable to the stack across a call may
+exceed the cost of recomputing such an expression. (And we can't float
+unlifted bindings to top-level.)
+
+We could try to do something smarter here, and float out expensive yet
+okay-for-speculation things, such as division by non-zero constants.
+But I suspect it's a narrow target.
+
+Note [Bottoming floats]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+        f = \x. g (error "urk")
+we'd like to float the call to error, to get
+        lvl = error "urk"
+        f = \x. g lvl
+
+But, as ever, we need to be careful:
+
+(1) We want to float a bottoming
+    expression even if it has free variables:
+        f = \x. g (let v = h x in error ("urk" ++ v))
+    Then we'd like to abstract over 'x' can float the whole arg of g:
+        lvl = \x. let v = h x in error ("urk" ++ v)
+        f = \x. g (lvl x)
+    To achieve this we pass is_bot to destLevel
+
+(2) We do not do this for lambdas that return
+    bottom.  Instead we treat the /body/ of such a function specially,
+    via point (1).  For example:
+        f = \x. ....(\y z. if x then error y else error z)....
+    ===>
+        lvl = \x z y. if b then error y else error z
+        f = \x. ...(\y z. lvl x z y)...
+    (There is no guarantee that we'll choose the perfect argument order.)
+
+(3) If we have a /binding/ that returns bottom, we want to float it to top
+    level, even if it has free vars (point (1)), and even it has lambdas.
+    Example:
+       ... let { v = \y. error (show x ++ show y) } in ...
+    We want to abstract over x and float the whole thing to top:
+       lvl = \xy. errror (show x ++ show y)
+       ...let {v = lvl x} in ...
+
+    Then of course we don't want to separately float the body (error ...)
+    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
+    argument.
+
+See Maessen's paper 1999 "Bottom extraction: factoring error handling out
+of functional programs" (unpublished I think).
+
+When we do this, we set the strictness and arity of the new bottoming
+Id, *immediately*, for three reasons:
+
+  * To prevent the abstracted thing being immediately inlined back in again
+    via preInlineUnconditionally.  The latter has a test for bottoming Ids
+    to stop inlining them, so we'd better make sure it *is* a bottoming Id!
+
+  * So that it's properly exposed as such in the interface file, even if
+    this is all happening after strictness analysis.
+
+  * In case we do CSE with the same expression that *is* marked bottom
+        lvl          = error "urk"
+          x{str=bot) = error "urk"
+    Here we don't want to replace 'x' with 'lvl', else we may get Lint
+    errors, e.g. via a case with empty alternatives:  (case x of {})
+    Lint complains unless the scrutinee of such a case is clearly bottom.
+
+    This was reported in #11290.   But since the whole bottoming-float
+    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure
+    that it'll nail all such cases.
+
+Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Tiresomely, though, the simplifier has an invariant that the manifest
+arity of the RHS should be the same as the arity; but we can't call
+etaExpand during SetLevels because it works over a decorated form of
+CoreExpr.  So we do the eta expansion later, in FloatOut.
+
+Note [Case MFEs]
+~~~~~~~~~~~~~~~~
+We don't float a case expression as an MFE from a strict context.  Why not?
+Because in doing so we share a tiny bit of computation (the switch) but
+in exchange we build a thunk, which is bad.  This case reduces allocation
+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
+Doesn't change any other allocation at all.
+
+We will make a separate decision for the scrutinee and alternatives.
+
+However this can have a knock-on effect for fusion: consider
+    \v -> foldr k z (case x of I# y -> build ..y..)
+Perhaps we can float the entire (case x of ...) out of the \v.  Then
+fusion will not happen, but we will get more sharing.  But if we don't
+float the case (as advocated here) we won't float the (build ...y..)
+either, so fusion will happen.  It can be a big effect, esp in some
+artificial benchmarks (e.g. integer, queens), but there is no perfect
+answer.
+
+-}
+
+annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id
+-- See Note [Bottoming floats] for why we want to add
+-- bottoming information right now
+--
+-- n_extra are the number of extra value arguments added during floating
+annotateBotStr id n_extra mb_str
+  = case mb_str of
+      Nothing           -> id
+      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)
+                              `setIdStrictness` (increaseStrictSigArity n_extra sig)
+
+notWorthFloating :: CoreExpr -> [Var] -> Bool
+-- Returns True if the expression would be replaced by
+-- something bigger than it is now.  For example:
+--   abs_vars = tvars only:  return True if e is trivial,
+--                           but False for anything bigger
+--   abs_vars = [x] (an Id): return True for trivial, or an application (f x)
+--                           but False for (f x x)
+--
+-- One big goal is that floating should be idempotent.  Eg if
+-- we replace e with (lvl79 x y) and then run FloatOut again, don't want
+-- to replace (lvl79 x y) with (lvl83 x y)!
+
+notWorthFloating e abs_vars
+  = go e (count isId abs_vars)
+  where
+    go (Var {}) n    = n >= 0
+    go (Lit lit) n   = ASSERT( n==0 )
+                       litIsTrivial lit   -- Note [Floating literals]
+    go (Tick t e) n  = not (tickishIsCode t) && go e n
+    go (Cast e _)  n = go e n
+    go (App e arg) n
+       | Type {}     <- arg = go e n
+       | Coercion {} <- arg = go e n
+       | n==0               = False
+       | is_triv arg        = go e (n-1)
+       | otherwise          = False
+    go _ _                  = False
+
+    is_triv (Lit {})              = True        -- Treat all literals as trivial
+    is_triv (Var {})              = True        -- (ie not worth floating)
+    is_triv (Cast e _)            = is_triv e
+    is_triv (App e (Type {}))     = is_triv e
+    is_triv (App e (Coercion {})) = is_triv e
+    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e
+    is_triv _                     = False
+
+{-
+Note [Floating literals]
+~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to float Integer literals, so that they get shared,
+rather than being allocated every time round the loop.
+Hence the litIsTrivial.
+
+Ditto literal strings (LitString), which we'd like to float to top
+level, which is now possible.
+
+
+Note [Escaping a value lambda]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to float even cheap expressions out of value lambdas,
+because that saves allocation.  Consider
+        f = \x.  .. (\y.e) ...
+Then we'd like to avoid allocating the (\y.e) every time we call f,
+(assuming e does not mention x). An example where this really makes a
+difference is simplrun009.
+
+Another reason it's good is because it makes SpecContr fire on functions.
+Consider
+        f = \x. ....(f (\y.e))....
+After floating we get
+        lvl = \y.e
+        f = \x. ....(f lvl)...
+and that is much easier for SpecConstr to generate a robust
+specialisation for.
+
+However, if we are wrapping the thing in extra value lambdas (in
+abs_vars), then nothing is saved.  E.g.
+        f = \xyz. ...(e1[y],e2)....
+If we float
+        lvl = \y. (e1[y],e2)
+        f = \xyz. ...(lvl y)...
+we have saved nothing: one pair will still be allocated for each
+call of 'f'.  Hence the (not float_is_lam) in float_me.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+
+The binding stuff works for top level too.
+-}
+
+lvlBind :: LevelEnv
+        -> CoreBindWithFVs
+        -> LvlM (LevelledBind, LevelEnv)
+
+lvlBind env (AnnNonRec bndr rhs)
+  | isTyVar bndr    -- Don't do anything for TyVar binders
+                    --   (simplifier gets rid of them pronto)
+  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
+                    -- so we will ignore this case for now
+  || not (profitableFloat env dest_lvl)
+  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
+          -- We can't float an unlifted binding to top level (except
+          -- literal strings), so we don't float it at all.  It's a
+          -- bit brutal, but unlifted bindings aren't expensive either
+
+  = -- No float
+    do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs
+       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)
+              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
+       ; return (NonRec bndr' rhs', env') }
+
+  -- Otherwise we are going to float
+  | null abs_vars
+  = do {  -- No type abstraction; clone existing binder
+         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
+                             is_bot mb_join_arity rhs
+       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
+       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
+
+  | otherwise
+  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc
+         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
+                             is_bot mb_join_arity rhs
+       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
+
+  where
+    bndr_ty    = idType bndr
+    ty_fvs     = tyCoVarsOfType bndr_ty
+    rhs_fvs    = freeVarsOf rhs
+    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr
+    abs_vars   = abstractVars dest_lvl env bind_fvs
+    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
+
+    deann_rhs  = deAnnotate rhs
+    mb_bot_str = exprBotStrictness_maybe deann_rhs
+    is_bot     = isJust mb_bot_str
+        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
+
+    n_extra    = count isId abs_vars
+    mb_join_arity = isJoinId_maybe bndr
+    is_join       = isJust mb_join_arity
+
+lvlBind env (AnnRec pairs)
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || not (profitableFloat env dest_lvl)
+  = do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
+             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
+       ; rhss' <- mapM lvl_rhs pairs
+       ; return (Rec (bndrs' `zip` rhss'), env') }
+
+  | null abs_vars
+  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
+       ; new_rhss <- mapM (do_rhs new_env) pairs
+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
+                , new_env) }
+
+-- ToDo: when enabling the floatLambda stuff,
+--       I think we want to stop doing this
+  | [(bndr,rhs)] <- pairs
+  , count isId abs_vars > 1
+  = do  -- Special case for self recursion where there are
+        -- several variables carried around: build a local loop:
+        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
+        -- This just makes the closures a bit smaller.  If we don't do
+        -- this, allocation rises significantly on some programs
+        --
+        -- We could elaborate it for the case where there are several
+        -- mutually recursive functions, but it's quite a bit more complicated
+        --
+        -- This all seems a bit ad hoc -- sigh
+    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
+        rhs_lvl = le_ctxt_lvl rhs_env
+
+    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
+    let
+        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs
+        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
+        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
+    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body
+    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+    return (Rec [(TB poly_bndr (FloatMe dest_lvl)
+                 , mkLams abs_vars_w_lvls $
+                   mkLams lam_bndrs2 $
+                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)
+                             , mkLams lam_bndrs2 new_rhs_body)])
+                       (mkVarApps (Var new_bndr) lam_bndrs1))]
+           , poly_env)
+
+  | otherwise  -- Non-null abs_vars
+  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs
+       ; new_rhss <- mapM (do_rhs new_env) pairs
+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
+                , new_env) }
+
+  where
+    (bndrs,rhss) = unzip pairs
+    is_join  = isJoinId (head bndrs)
+                -- bndrs is always non-empty and if one is a join they all are
+                -- Both are checked by Lint
+    is_fun   = all isFunction rhss
+    is_bot   = False  -- It's odd to have an unconditionally divergent
+                      -- function in a Rec, and we don't much care what
+                      -- happens to it.  False is simple!
+
+    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive
+                                        is_bot (get_join bndr)
+                                        rhs
+
+    get_join bndr | need_zap  = Nothing
+                  | otherwise = isJoinId_maybe bndr
+    need_zap = dest_lvl `ltLvl` joinCeilingLevel env
+
+        -- Finding the free vars of the binding group is annoying
+    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
+                `unionDVarSet`
+                (fvDVarSet $ unionsFV [ idFVs bndr
+                                      | (bndr, (_,_)) <- pairs]))
+               `delDVarSetList`
+                bndrs
+
+    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs
+    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
+    abs_vars = abstractVars dest_lvl env bind_fvs
+
+profitableFloat :: LevelEnv -> Level -> Bool
+profitableFloat env dest_lvl
+  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda
+  || isTopLvl dest_lvl                      -- Going all the way to top level
+
+
+----------------------------------------------------
+-- Three help functions for the type-abstraction case
+
+lvlRhs :: LevelEnv
+       -> RecFlag
+       -> Bool               -- Is this a bottoming function
+       -> Maybe JoinArity
+       -> CoreExprWithFVs
+       -> LvlM LevelledExpr
+lvlRhs env rec_flag is_bot mb_join_arity expr
+  = lvlFloatRhs [] (le_ctxt_lvl env) env
+                rec_flag is_bot mb_join_arity expr
+
+lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
+            -> Bool   -- Binding is for a bottoming function
+            -> Maybe JoinArity
+            -> CoreExprWithFVs
+            -> LvlM (Expr LevelledBndr)
+-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
+lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
+  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]
+                     && any isId bndrs
+                  then lvlMFE  body_env True body
+                  else lvlExpr body_env      body
+       ; return (mkLams bndrs' body') }
+  where
+    (bndrs, body)     | Just join_arity <- mb_join_arity
+                      = collectNAnnBndrs join_arity rhs
+                      | otherwise
+                      = collectAnnBndrs rhs
+    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs
+    all_bndrs         = abs_vars ++ bndrs1
+    (body_env, bndrs') | Just _ <- mb_join_arity
+                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs
+                      | otherwise
+                      = case lvlLamBndrs env1 dest_lvl all_bndrs of
+                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
+        -- The important thing here is that we call lvlLamBndrs on
+        -- all these binders at once (abs_vars and bndrs), so they
+        -- all get the same major level.  Otherwise we create stupid
+        -- let-bindings inside, joyfully thinking they can float; but
+        -- in the end they don't because we never float bindings in
+        -- between lambdas
+
+{- Note [Floating from a RHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When floating the RHS of a let-binding, we don't always want to apply
+lvlMFE to the body of a lambda, as we usually do, because the entire
+binding body is already going to the right place (dest_lvl).
+
+A particular example is the top level.  Consider
+   concat = /\ a -> foldr ..a.. (++) []
+We don't want to float the body of the lambda to get
+   lvl    = /\ a -> foldr ..a.. (++) []
+   concat = /\ a -> lvl a
+That would be stupid.
+
+Previously this was avoided in a much nastier way, by testing strict_ctxt
+in float_me in lvlMFE.  But that wasn't even right because it would fail
+to float out the error sub-expression in
+    f = \x. case x of
+              True  -> error ("blah" ++ show x)
+              False -> ...
+
+But we must be careful:
+
+* If we had
+    f = \x -> factorial 20
+  we /would/ want to float that (factorial 20) out!  Functions are treated
+  differently: see the use of isFunction in the calls to destLevel. If
+  there are only type lambdas, then destLevel will say "go to top, and
+  abstract over the free tyvars" and we don't want that here.
+
+* But if we had
+    f = \x -> error (...x....)
+  we would NOT want to float the bottoming expression out to give
+    lvl = \x -> error (...x...)
+    f = \x -> lvl x
+
+Conclusion: use lvlMFE if there are
+  * any value lambdas in the original function, and
+  * this is not a bottoming function (the is_bot argument)
+Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice
+(e.g. #13369).
+-}
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Deciding floatability}
+*                                                                      *
+************************************************************************
+-}
+
+substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
+substAndLvlBndrs is_rec env lvl bndrs
+  = lvlBndrs subst_env lvl subst_bndrs
+  where
+    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
+
+substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
+-- So named only to avoid the name clash with CoreSubst.substBndrs
+substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
+  = ( env { le_subst    = subst'
+          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }
+    , bndrs')
+  where
+    (subst', bndrs') = case is_rec of
+                         NonRecursive -> substBndrs    subst bndrs
+                         Recursive    -> substRecBndrs subst bndrs
+
+lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
+-- Compute the levels for the binders of a lambda group
+lvlLamBndrs env lvl bndrs
+  = lvlBndrs env new_lvl bndrs
+  where
+    new_lvl | any is_major bndrs = incMajorLvl lvl
+            | otherwise          = incMinorLvl lvl
+
+    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)
+       -- The "probably" part says "don't float things out of a
+       -- probable one-shot lambda"
+       -- See Note [Computing one-shot info] in Demand.hs
+
+lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
+             -> (LevelEnv, [LevelledBndr])
+lvlJoinBndrs env lvl rec bndrs
+  = lvlBndrs env new_lvl bndrs
+  where
+    new_lvl | isRec rec = incMajorLvl lvl
+            | otherwise = incMinorLvl lvl
+      -- Non-recursive join points are one-shot; recursive ones are not
+
+lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
+-- The binders returned are exactly the same as the ones passed,
+-- apart from applying the substitution, but they are now paired
+-- with a (StayPut level)
+--
+-- The returned envt has le_ctxt_lvl updated to the new_lvl
+--
+-- All the new binders get the same level, because
+-- any floating binding is either going to float past
+-- all or none.  We never separate binders.
+lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
+  = ( env { le_ctxt_lvl = new_lvl
+          , le_join_ceil = new_lvl
+          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }
+    , map (stayPut new_lvl) bndrs)
+
+stayPut :: Level -> OutVar -> LevelledBndr
+stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
+
+  -- Destination level is the max Id level of the expression
+  -- (We'll abstract the type variables, if any.)
+destLevel :: LevelEnv
+          -> DVarSet    -- Free vars of the term
+          -> TyCoVarSet -- Free in the /type/ of the term
+                        -- (a subset of the previous argument)
+          -> Bool   -- True <=> is function
+          -> Bool   -- True <=> is bottom
+          -> Bool   -- True <=> is a join point
+          -> Level
+-- INVARIANT: if is_join=True then result >= join_ceiling
+destLevel env fvs fvs_ty is_function is_bot is_join
+  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level
+                              -- See Note [Floating join point bindings]
+  = tOP_LEVEL
+
+  | is_join  -- Never float a join point past the join ceiling
+             -- See Note [Join points] in FloatOut
+  = if max_fv_id_level `ltLvl` join_ceiling
+    then join_ceiling
+    else max_fv_id_level
+
+  | is_bot              -- Send bottoming bindings to the top
+  = as_far_as_poss      -- regardless; see Note [Bottoming floats]
+                        -- Esp Bottoming floats (1)
+
+  | Just n_args <- floatLams env
+  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case
+  , is_function
+  , countFreeIds fvs <= n_args
+  = as_far_as_poss  -- Send functions to top level; see
+                    -- the comments with isFunction
+
+  | otherwise = max_fv_id_level
+  where
+    join_ceiling    = joinCeilingLevel env
+    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
+                                              -- tyvars will be abstracted
+
+    as_far_as_poss = maxFvLevel' isId env fvs_ty
+                     -- See Note [Floating and kind casts]
+
+{- Note [Floating and kind casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   case x of
+     K (co :: * ~# k) -> let v :: Int |> co
+                             v = e
+                         in blah
+
+Then, even if we are abstracting over Ids, or if e is bottom, we can't
+float v outside the 'co' binding.  Reason: if we did we'd get
+    v' :: forall k. (Int ~# Age) => Int |> co
+and now 'co' isn't in scope in that type. The underlying reason is
+that 'co' is a value-level thing and we can't abstract over that in a
+type (else we'd get a dependent type).  So if v's /type/ mentions 'co'
+we can't float it out beyond the binding site of 'co'.
+
+That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss
+is just tOP_LEVEL; but occasionally a coercion variable (which is an
+Id) mentioned in type prevents this.
+
+Example #14270 comment:15.
+-}
+
+
+isFunction :: CoreExprWithFVs -> Bool
+-- The idea here is that we want to float *functions* to
+-- the top level.  This saves no work, but
+--      (a) it can make the host function body a lot smaller,
+--              and hence inlinable.
+--      (b) it can also save allocation when the function is recursive:
+--          h = \x -> letrec f = \y -> ...f...y...x...
+--                    in f x
+--     becomes
+--          f = \x y -> ...(f x)...y...x...
+--          h = \x -> f x x
+--     No allocation for f now.
+-- We may only want to do this if there are sufficiently few free
+-- variables.  We certainly only want to do it for values, and not for
+-- constructors.  So the simple thing is just to look for lambdas
+isFunction (_, AnnLam b e) | isId b    = True
+                           | otherwise = isFunction e
+-- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious
+isFunction _                           = False
+
+countFreeIds :: DVarSet -> Int
+countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet
+  -- It's OK to use nonDetFoldUDFM here because we're just counting things.
+  where
+    add :: Var -> Int -> Int
+    add v n | isId v    = n+1
+            | otherwise = n
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Free-To-Level Monad}
+*                                                                      *
+************************************************************************
+-}
+
+data LevelEnv
+  = LE { le_switches :: FloatOutSwitches
+       , le_ctxt_lvl :: Level           -- The current level
+       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids
+       , le_join_ceil:: Level           -- Highest level to which joins float
+                                        -- Invariant: always >= le_ctxt_lvl
+
+       -- See Note [le_subst and le_env]
+       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids
+                                        -- The Id -> CoreExpr in the Subst is ignored
+                                        -- (since we want to substitute a LevelledExpr for
+                                        -- an Id via le_env) but we do use the Co/TyVar substs
+       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids
+    }
+
+{- Note [le_subst and le_env]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We clone let- and case-bound variables so that they are still distinct
+when floated out; hence the le_subst/le_env.  (see point 3 of the
+module overview comment).  We also use these envs when making a
+variable polymorphic because we want to float it out past a big
+lambda.
+
+The le_subst and le_env always implement the same mapping,
+     in_x :->  out_x a b
+where out_x is an OutVar, and a,b are its arguments (when
+we perform abstraction at the same time as floating).
+
+  le_subst maps to CoreExpr
+  le_env   maps to LevelledExpr
+
+Since the range is always a variable or application, there is never
+any difference between the two, but sadly the types differ.  The
+le_subst is used when substituting in a variable's IdInfo; the le_env
+when we find a Var.
+
+In addition the le_env records a [OutVar] of variables free in the
+OutExpr/LevelledExpr, just so we don't have to call freeVars
+repeatedly.  This list is always non-empty, and the first element is
+out_x
+
+The domain of the both envs is *pre-cloned* Ids, though
+
+The domain of the le_lvl_env is the *post-cloned* Ids
+-}
+
+initialEnv :: FloatOutSwitches -> LevelEnv
+initialEnv float_lams
+  = LE { le_switches = float_lams
+       , le_ctxt_lvl = tOP_LEVEL
+       , le_join_ceil = panic "initialEnv"
+       , le_lvl_env = emptyVarEnv
+       , le_subst = emptySubst
+       , le_env = emptyVarEnv }
+
+addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
+addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
+
+addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
+addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
+
+floatLams :: LevelEnv -> Maybe Int
+floatLams le = floatOutLambdas (le_switches le)
+
+floatConsts :: LevelEnv -> Bool
+floatConsts le = floatOutConstants (le_switches le)
+
+floatOverSat :: LevelEnv -> Bool
+floatOverSat le = floatOutOverSatApps (le_switches le)
+
+floatTopLvlOnly :: LevelEnv -> Bool
+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
+
+incMinorLvlFrom :: LevelEnv -> Level
+incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)
+
+-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can
+-- See Note [Binder-swap during float-out]
+extendCaseBndrEnv :: LevelEnv
+                  -> Id                 -- Pre-cloned case binder
+                  -> Expr LevelledBndr  -- Post-cloned scrutinee
+                  -> LevelEnv
+extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
+                  case_bndr (Var scrut_var)
+  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var
+       , le_env     = add_id id_env (case_bndr, scrut_var) }
+extendCaseBndrEnv env _ _ = env
+
+-- See Note [Join ceiling]
+placeJoinCeiling :: LevelEnv -> LevelEnv
+placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
+  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }
+  where
+    lvl' = asJoinCeilLvl (incMinorLvl lvl)
+
+maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
+maxFvLevel max_me env var_set
+  = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
+
+maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
+-- Same but for TyCoVarSet
+maxFvLevel' max_me env var_set
+  = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
+
+maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
+maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
+  = case lookupVarEnv id_env in_var of
+      Just (abs_vars, _) -> foldr max_out lvl abs_vars
+      Nothing            -> max_out in_var lvl
+  where
+    max_out out_var lvl
+        | max_me out_var = case lookupVarEnv lvl_env out_var of
+                                Just lvl' -> maxLvl lvl' lvl
+                                Nothing   -> lvl
+        | otherwise = lvl       -- Ignore some vars depending on max_me
+
+lookupVar :: LevelEnv -> Id -> LevelledExpr
+lookupVar le v = case lookupVarEnv (le_env le) v of
+                    Just (_, expr) -> expr
+                    _              -> Var v
+
+-- Level to which join points are allowed to float (boundary of current tail
+-- context). See Note [Join ceiling]
+joinCeilingLevel :: LevelEnv -> Level
+joinCeilingLevel = le_join_ceil
+
+abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
+        -- Find the variables in fvs, free vars of the target expression,
+        -- whose level is greater than the destination level
+        -- These are the ones we are going to abstract out
+        --
+        -- Note that to get reproducible builds, the variables need to be
+        -- abstracted in deterministic order, not dependent on the values of
+        -- Uniques. This is achieved by using DVarSets, deterministic free
+        -- variable computation and deterministic sort.
+        -- See Note [Unique Determinism] in Unique for explanation of why
+        -- Uniques are not deterministic.
+abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
+  =  -- NB: sortQuantVars might not put duplicates next to each other
+    map zap $ sortQuantVars $
+    filter abstract_me      $
+    dVarSetElems            $
+    closeOverKindsDSet      $
+    substDVarSet subst in_fvs
+        -- NB: it's important to call abstract_me only on the OutIds the
+        -- come from substDVarSet (not on fv, which is an InId)
+  where
+    abstract_me v = case lookupVarEnv lvl_env v of
+                        Just lvl -> dest_lvl `ltLvl` lvl
+                        Nothing  -> False
+
+        -- We are going to lambda-abstract, so nuke any IdInfo,
+        -- and add the tyvars of the Id (if necessary)
+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
+                           not (isEmptyRuleInfo (idSpecialisation v)),
+                           text "absVarsOf: discarding info on" <+> ppr v )
+                     setIdInfo v vanillaIdInfo
+          | otherwise = v
+
+type LvlM result = UniqSM result
+
+initLvl :: UniqSupply -> UniqSM a -> a
+initLvl = initUs_
+
+newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
+             -> LvlM (LevelEnv, [OutId])
+-- The envt is extended to bind the new bndrs to dest_lvl, but
+-- the le_ctxt_lvl is unaffected
+newPolyBndrs dest_lvl
+             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
+             abs_vars bndrs
+ = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.
+   do { uniqs <- getUniquesM
+      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
+            bndr_prs  = bndrs `zip` new_bndrs
+            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
+                       , le_subst   = foldl' add_subst subst   bndr_prs
+                       , le_env     = foldl' add_id    id_env  bndr_prs }
+      ; return (env', new_bndrs) }
+  where
+    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
+    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
+
+    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs
+                             transfer_join_info bndr $
+                             mkSysLocalOrCoVar (mkFastString str) uniq poly_ty
+                           where
+                             str     = "poly_" ++ occNameString (getOccName bndr)
+                             poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))
+
+    -- If we are floating a join point to top level, it stops being
+    -- a join point.  Otherwise it continues to be a join point,
+    -- but we may need to adjust its arity
+    dest_is_top = isTopLvl dest_lvl
+    transfer_join_info bndr new_bndr
+      | Just join_arity <- isJoinId_maybe bndr
+      , not dest_is_top
+      = new_bndr `asJoinId` join_arity + length abs_vars
+      | otherwise
+      = new_bndr
+
+newLvlVar :: LevelledExpr        -- The RHS of the new binding
+          -> Maybe JoinArity     -- Its join arity, if it is a join point
+          -> Bool                -- True <=> the RHS looks like (makeStatic ...)
+          -> LvlM Id
+newLvlVar lvld_rhs join_arity_maybe is_mk_static
+  = do { uniq <- getUniqueM
+       ; return (add_join_info (mk_id uniq rhs_ty))
+       }
+  where
+    add_join_info var = var `asJoinId_maybe` join_arity_maybe
+    de_tagged_rhs = deTagExpr lvld_rhs
+    rhs_ty        = exprType de_tagged_rhs
+
+    mk_id uniq rhs_ty
+      -- See Note [Grand plan for static forms] in StaticPtrTable.
+      | is_mk_static
+      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
+                            rhs_ty
+      | otherwise
+      = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty
+
+cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
+cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
+               new_lvl vs
+  = do { us <- getUniqueSupplyM
+       ; let (subst', vs') = cloneBndrs subst us vs
+             env' = env { le_ctxt_lvl  = new_lvl
+                        , le_join_ceil = new_lvl
+                        , le_lvl_env   = addLvls new_lvl lvl_env vs'
+                        , le_subst     = subst'
+                        , le_env       = foldl' add_id id_env (vs `zip` vs') }
+
+       ; return (env', vs') }
+
+cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
+             -> LvlM (LevelEnv, [OutVar])
+-- See Note [Need for cloning during float-out]
+-- Works for Ids bound by let(rec)
+-- The dest_lvl is attributed to the binders in the new env,
+-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env
+cloneLetVars is_rec
+          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
+          dest_lvl vs
+  = do { us <- getUniqueSupplyM
+       ; let vs1  = map zap vs
+                      -- See Note [Zapping the demand info]
+             (subst', vs2) = case is_rec of
+                               NonRecursive -> cloneBndrs      subst us vs1
+                               Recursive    -> cloneRecIdBndrs subst us vs1
+             prs  = vs `zip` vs2
+             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
+                        , le_subst   = subst'
+                        , le_env     = foldl' add_id id_env prs }
+
+       ; return (env', vs2) }
+  where
+    zap :: Var -> Var
+    zap v | isId v    = zap_join (zapIdDemandInfo v)
+          | otherwise = v
+
+    zap_join | isTopLvl dest_lvl = zapJoinId
+             | otherwise         = id
+
+add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
+add_id id_env (v, v1)
+  | isTyVar v = delVarEnv    id_env v
+  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
+
+{-
+Note [Zapping the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+VERY IMPORTANT: we must zap the demand info if the thing is going to
+float out, because it may be less demanded than at its original
+binding site.  Eg
+   f :: Int -> Int
+   f x = let v = 3*4 in v+x
+Here v is strict; but if we float v to top level, it isn't any more.
+
+Similarly, if we're floating a join point, it won't be one anymore, so we zap
+join point information as well.
+-}
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplCore.hs
@@ -0,0 +1,1030 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[SimplCore]{Driver for simplifying @Core@ programs}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SimplCore ( core2core, simplifyExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import CoreSyn
+import HscTypes
+import CSE              ( cseProgram )
+import Rules            ( mkRuleBase, unionRuleBase,
+                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,
+                          getRules )
+import PprCore          ( pprCoreBindings, pprCoreExpr )
+import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
+import IdInfo
+import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )
+import CoreUtils        ( mkTicks, stripTicksTop )
+import CoreLint         ( endPass, lintPassResult, dumpPassResult,
+                          lintAnnots )
+import Simplify         ( simplTopBinds, simplExpr, simplRules )
+import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )
+import SimplEnv
+import SimplMonad
+import CoreMonad
+import qualified ErrUtils as Err
+import FloatIn          ( floatInwards )
+import FloatOut         ( floatOutwards )
+import FamInstEnv
+import Id
+import ErrUtils         ( withTiming )
+import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
+import VarSet
+import VarEnv
+import LiberateCase     ( liberateCase )
+import SAT              ( doStaticArgs )
+import Specialise       ( specProgram)
+import SpecConstr       ( specConstrProgram)
+import DmdAnal          ( dmdAnalProgram )
+import CallArity        ( callArityAnalProgram )
+import Exitify          ( exitifyProgram )
+import WorkWrap         ( wwTopBinds )
+import SrcLoc
+import Util
+import Module
+import Plugins          ( withPlugins, installCoreToDos )
+import DynamicLoading  -- ( initializePlugins )
+
+import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
+import UniqFM
+import Outputable
+import Control.Monad
+import qualified GHC.LanguageExtensions as LangExt
+{-
+************************************************************************
+*                                                                      *
+\subsection{The driver for the simplifier}
+*                                                                      *
+************************************************************************
+-}
+
+core2core :: HscEnv -> ModGuts -> IO ModGuts
+core2core hsc_env guts@(ModGuts { mg_module  = mod
+                                , mg_loc     = loc
+                                , mg_deps    = deps
+                                , mg_rdr_env = rdr_env })
+  = do { us <- mkSplitUniqSupply 's'
+       -- make sure all plugins are loaded
+
+       ; let builtin_passes = getCoreToDo dflags
+             orph_mods = mkModuleSet (mod : dep_orphs deps)
+       ;
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
+                                    orph_mods print_unqual loc $
+                           do { hsc_env' <- getHscEnv
+                              ; dflags' <- liftIO $ initializePlugins hsc_env'
+                                                      (hsc_dflags hsc_env')
+                              ; all_passes <- withPlugins dflags'
+                                                installCoreToDos
+                                                builtin_passes
+                              ; runCorePasses all_passes guts }
+
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+             "Grand total simplifier statistics"
+             (pprSimplCount stats)
+
+       ; return guts2 }
+  where
+    dflags         = hsc_dflags hsc_env
+    home_pkg_rules = hptRules hsc_env (dep_mods deps)
+    hpt_rule_base  = mkRuleBase home_pkg_rules
+    print_unqual   = mkPrintUnqualified dflags rdr_env
+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
+    -- This is very convienent for the users of the monad (e.g. plugins do not have to
+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
+    -- would mean our cached value would go out of date.
+
+{-
+************************************************************************
+*                                                                      *
+           Generating the main optimisation pipeline
+*                                                                      *
+************************************************************************
+-}
+
+getCoreToDo :: DynFlags -> [CoreToDo]
+getCoreToDo dflags
+  = flatten_todos core_todo
+  where
+    opt_level     = optLevel           dflags
+    phases        = simplPhases        dflags
+    max_iter      = maxSimplIterations dflags
+    rule_check    = ruleCheck          dflags
+    call_arity    = gopt Opt_CallArity                    dflags
+    exitification = gopt Opt_Exitification                dflags
+    strictness    = gopt Opt_Strictness                   dflags
+    full_laziness = gopt Opt_FullLaziness                 dflags
+    do_specialise = gopt Opt_Specialise                   dflags
+    do_float_in   = gopt Opt_FloatIn                      dflags
+    cse           = gopt Opt_CSE                          dflags
+    spec_constr   = gopt Opt_SpecConstr                   dflags
+    liberate_case = gopt Opt_LiberateCase                 dflags
+    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
+    late_specialise = gopt Opt_LateSpecialise             dflags
+    static_args   = gopt Opt_StaticArgumentTransformation dflags
+    rules_on      = gopt Opt_EnableRewriteRules           dflags
+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
+    ww_on         = gopt Opt_WorkerWrapper                dflags
+    static_ptrs   = xopt LangExt.StaticPointers           dflags
+
+    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
+
+    maybe_strictness_before phase
+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
+
+    base_mode = SimplMode { sm_phase      = panic "base_mode"
+                          , sm_names      = []
+                          , sm_dflags     = dflags
+                          , sm_rules      = rules_on
+                          , sm_eta_expand = eta_expand_on
+                          , sm_inline     = True
+                          , sm_case_case  = True }
+
+    simpl_phase phase names iter
+      = CoreDoPasses
+      $   [ maybe_strictness_before phase
+          , CoreDoSimplify iter
+                (base_mode { sm_phase = Phase phase
+                           , sm_names = names })
+
+          , maybe_rule_check (Phase phase) ]
+
+    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
+                                | phase <- [phases, phases-1 .. 1] ]
+
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+    simpl_gently = CoreDoSimplify max_iter
+                       (base_mode { sm_phase = InitialPhase
+                                  , sm_names = ["Gentle"]
+                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
+                                  , sm_inline = True
+                                              -- See Note [Inline in InitialPhase]
+                                  , sm_case_case = False })
+                          -- Don't do case-of-case transformations.
+                          -- This makes full laziness work better
+
+    strictness_pass = if ww_on
+                       then [CoreDoStrictness,CoreDoWorkerWrapper]
+                       else [CoreDoStrictness]
+
+
+    -- New demand analyser
+    demand_analyser = (CoreDoPasses (
+                           strictness_pass ++
+                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]
+                           ))
+
+    -- Static forms are moved to the top level with the FloatOut pass.
+    -- See Note [Grand plan for static forms] in StaticPtrTable.
+    static_ptrs_float_outwards =
+      runWhen static_ptrs $ CoreDoPasses
+        [ simpl_gently -- Float Out can't handle type lets (sometimes created
+                       -- by simpleOptPgm via mkParallelBindings)
+        , CoreDoFloatOutwards FloatOutSwitches
+          { floatOutLambdas   = Just 0
+          , floatOutConstants = True
+          , floatOutOverSatApps = False
+          , floatToTopLevelOnly = True
+          }
+        ]
+
+    core_todo =
+     if opt_level == 0 then
+       [ static_ptrs_float_outwards,
+         CoreDoSimplify max_iter
+             (base_mode { sm_phase = Phase 0
+                        , sm_names = ["Non-opt simplification"] })
+       ]
+
+     else {- opt_level >= 1 -} [
+
+    -- We want to do the static argument transform before full laziness as it
+    -- may expose extra opportunities to float things outwards. However, to fix
+    -- up the output of the transformation we need at do at least one simplify
+    -- after this before anything else
+        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+        simpl_gently,
+
+        -- Specialisation is best done before full laziness
+        -- so that overloaded functions have all their dictionary lambdas manifest
+        runWhen do_specialise CoreDoSpecialising,
+
+        if full_laziness then
+           CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas   = Just 0,
+                                 floatOutConstants = True,
+                                 floatOutOverSatApps = False,
+                                 floatToTopLevelOnly = False }
+                -- Was: gentleFloatOutSwitches
+                --
+                -- I have no idea why, but not floating constants to
+                -- top level is very bad in some cases.
+                --
+                -- Notably: p_ident in spectral/rewrite
+                --          Changing from "gentle" to "constantsOnly"
+                --          improved rewrite's allocation by 19%, and
+                --          made 0.0% difference to any other nofib
+                --          benchmark
+                --
+                -- Not doing floatOutOverSatApps yet, we'll do
+                -- that later on when we've had a chance to get more
+                -- accurate arity information.  In fact it makes no
+                -- difference at all to performance if we do it here,
+                -- but maybe we save some unnecessary to-and-fro in
+                -- the simplifier.
+        else
+           -- Even with full laziness turned off, we still need to float static
+           -- forms to the top level. See Note [Grand plan for static forms] in
+           -- StaticPtrTable.
+           static_ptrs_float_outwards,
+
+        simpl_phases,
+
+                -- Phase 0: allow all Ids to be inlined now
+                -- This gets foldr inlined before strictness analysis
+
+                -- At least 3 iterations because otherwise we land up with
+                -- huge dead expressions because of an infelicity in the
+                -- simplifier.
+                --      let k = BIG in foldr k z xs
+                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
+                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
+                -- Don't stop now!
+        simpl_phase 0 ["main"] (max max_iter 3),
+
+        runWhen do_float_in CoreDoFloatInwards,
+            -- Run float-inwards immediately before the strictness analyser
+            -- Doing so pushes bindings nearer their use site and hence makes
+            -- them more likely to be strict. These bindings might only show
+            -- up after the inlining from simplification.  Example in fulsom,
+            -- Csg.calc, where an arg of timesDouble thereby becomes strict.
+
+        runWhen call_arity $ CoreDoPasses
+            [ CoreDoCallArity
+            , simpl_phase 0 ["post-call-arity"] max_iter
+            ],
+
+        runWhen strictness demand_analyser,
+
+        runWhen exitification CoreDoExitify,
+            -- See note [Placement of the exitification pass]
+
+        runWhen full_laziness $
+           CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas     = floatLamArgs dflags,
+                                 floatOutConstants   = True,
+                                 floatOutOverSatApps = True,
+                                 floatToTopLevelOnly = False },
+                -- nofib/spectral/hartel/wang doubles in speed if you
+                -- do full laziness late in the day.  It only happens
+                -- after fusion and other stuff, so the early pass doesn't
+                -- catch it.  For the record, the redex is
+                --        f_el22 (f_el21 r_midblock)
+
+
+        runWhen cse CoreCSE,
+                -- We want CSE to follow the final full-laziness pass, because it may
+                -- succeed in commoning up things floated out by full laziness.
+                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+        runWhen do_float_in CoreDoFloatInwards,
+
+        maybe_rule_check (Phase 0),
+
+                -- Case-liberation for -O2.  This should be after
+                -- strictness analysis and the simplification which follows it.
+        runWhen liberate_case (CoreDoPasses [
+            CoreLiberateCase,
+            simpl_phase 0 ["post-liberate-case"] max_iter
+            ]),         -- Run the simplifier after LiberateCase to vastly
+                        -- reduce the possibility of shadowing
+                        -- Reason: see Note [Shadowing] in SpecConstr.hs
+
+        runWhen spec_constr CoreDoSpecConstr,
+
+        maybe_rule_check (Phase 0),
+
+        runWhen late_specialise
+          (CoreDoPasses [ CoreDoSpecialising
+                        , simpl_phase 0 ["post-late-spec"] max_iter]),
+
+        -- LiberateCase can yield new CSE opportunities because it peels
+        -- off one layer of a recursive function (concretely, I saw this
+        -- in wheel-sieve1), and I'm guessing that SpecConstr can too
+        -- And CSE is a very cheap pass. So it seems worth doing here.
+        runWhen ((liberate_case || spec_constr) && cse) CoreCSE,
+
+        -- Final clean-up simplification:
+        simpl_phase 0 ["final"] max_iter,
+
+        runWhen late_dmd_anal $ CoreDoPasses (
+            strictness_pass ++
+            [simpl_phase 0 ["post-late-ww"] max_iter]
+          ),
+
+        -- Final run of the demand_analyser, ensures that one-shot thunks are
+        -- really really one-shot thunks. Only needed if the demand analyser
+        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal
+        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
+        -- can become /exponentially/ more expensive. See #11731, #12996.
+        runWhen (strictness || late_dmd_anal) CoreDoStrictness,
+
+        maybe_rule_check (Phase 0)
+     ]
+
+    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.
+    flatten_todos [] = []
+    flatten_todos (CoreDoNothing : rest) = flatten_todos rest
+    flatten_todos (CoreDoPasses passes : rest) =
+      flatten_todos passes ++ flatten_todos rest
+    flatten_todos (todo : rest) = todo : flatten_todos rest
+
+{- Note [Inline in InitialPhase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
+confusing for users because when they say INLINE they expect the function to inline
+right away.
+
+So now we do inlining immediately, even in the InitialPhase, assuming that the
+Id's Activation allows it.
+
+This is a surprisingly big deal. Compiler performance improved a lot
+when I made this change:
+
+   perf/compiler/T5837.run            T5837 [stat too good] (normal)
+   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)
+   perf/compiler/T12234.run           T12234 [stat too good] (optasm)
+   perf/compiler/T9020.run            T9020 [stat too good] (optasm)
+   perf/compiler/T3064.run            T3064 [stat too good] (normal)
+   perf/compiler/T9961.run            T9961 [stat too good] (normal)
+   perf/compiler/T13056.run           T13056 [stat too good] (optasm)
+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
+   perf/compiler/T783.run             T783 [stat too good] (normal)
+   perf/compiler/T12227.run           T12227 [stat too good] (normal)
+   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)
+   perf/compiler/T1969.run            T1969 [stat too good] (normal)
+   perf/compiler/T9872a.run           T9872a [stat too good] (normal)
+   perf/compiler/T9872c.run           T9872c [stat too good] (normal)
+   perf/compiler/T9872b.run           T9872b [stat too good] (normal)
+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
+
+Note [RULEs enabled in SimplGently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+RULES are enabled when doing "gentle" simplification.  Two reasons:
+
+  * We really want the class-op cancellation to happen:
+        op (df d1 d2) --> $cop3 d1 d2
+    because this breaks the mutual recursion between 'op' and 'df'
+
+  * I wanted the RULE
+        lift String ===> ...
+    to work in Template Haskell when simplifying
+    splices, so we get simpler code for literal strings
+
+But watch out: list fusion can prevent floating.  So use phase control
+to switch off those rules until after floating.
+
+************************************************************************
+*                                                                      *
+                  The CoreToDo interpreter
+*                                                                      *
+************************************************************************
+-}
+
+runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
+runCorePasses passes guts
+  = foldM do_pass guts passes
+  where
+    do_pass guts CoreDoNothing = return guts
+    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
+    do_pass guts pass
+       = withTiming getDynFlags
+                    (ppr pass <+> brackets (ppr mod))
+                    (const ()) $ do
+            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
+            ; endPass pass (mg_binds guts') (mg_rules guts')
+            ; return guts' }
+
+    mod = mg_module guts
+
+doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                       simplifyPgm pass
+
+doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
+                                       doPass cseProgram
+
+doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
+                                       doPassD liberateCase
+
+doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                       floatInwards
+
+doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
+                                       doPassDUM (floatOutwards f)
+
+doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
+                                       doPassU doStaticArgs
+
+doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
+                                       doPassD callArityAnalProgram
+
+doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}
+                                       doPass exitifyProgram
+
+doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
+                                       doPassDFM dmdAnalProgram
+
+doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                       doPassDFU wwTopBinds
+
+doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
+                                       specProgram
+
+doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
+                                       specConstrProgram
+
+doCorePass CoreDoPrintCore              = observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
+doCorePass CoreDoNothing                = return
+doCorePass (CoreDoPasses passes)        = runCorePasses passes
+
+#if defined(GHCI)
+doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
+#else
+doCorePass pass@CoreDoPluginPass {}  = pprPanic "doCorePass" (ppr pass)
+#endif
+
+doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Core pass combinators}
+*                                                                      *
+************************************************************************
+-}
+
+printCore :: DynFlags -> CoreProgram -> IO ()
+printCore dflags binds
+    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
+
+ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
+ruleCheckPass current_phase pat guts =
+    withTiming getDynFlags
+               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
+               (const ()) $ do
+    { rb <- getRuleBase
+    ; dflags <- getDynFlags
+    ; vis_orphs <- getVisibleOrphanMods
+    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
+                        ++ (mg_rules guts)
+    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
+                   (defaultDumpStyle dflags)
+                   (ruleCheckProgram current_phase pat
+                      rule_fn (mg_binds guts))
+    ; return guts }
+
+doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDUM do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    liftIO $ do_pass dflags us binds
+
+doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
+
+doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
+
+doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
+
+doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassU do_pass = doPassDU (const do_pass)
+
+doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFM do_pass guts = do
+    dflags <- getDynFlags
+    p_fam_env <- getPackageFamInstEnv
+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+    doPassM (liftIO . do_pass dflags fam_envs) guts
+
+doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFU do_pass guts = do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    p_fam_env <- getPackageFamInstEnv
+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+    doPass (do_pass dflags fam_envs us) guts
+
+-- Most passes return no stats and don't change rules: these combinators
+-- let us lift them to the full blown ModGuts+CoreM world
+doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
+doPassM bind_f guts = do
+    binds' <- bind_f (mg_binds guts)
+    return (guts { mg_binds = binds' })
+
+doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
+
+-- Observer passes just peek; don't modify the bindings at all
+observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
+observe do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    _ <- liftIO $ do_pass dflags binds
+    return binds
+
+{-
+************************************************************************
+*                                                                      *
+        Gentle simplification
+*                                                                      *
+************************************************************************
+-}
+
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+             -> CoreExpr
+             -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
+simplifyExpr dflags expr
+  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $
+    do  {
+        ; us <-  mkSplitUniqSupply 's'
+
+        ; let sz = exprSize expr
+
+        ; (expr', counts) <- initSmpl dflags emptyRuleEnv
+                               emptyFamInstEnvs us sz
+                               (simplExprGently (simplEnvForGHCi dflags) expr)
+
+        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
+                  "Simplifier statistics" (pprSimplCount counts)
+
+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+                        (pprCoreExpr expr')
+
+        ; return expr'
+        }
+
+simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+-- Simplifies an expression
+--      does occurrence analysis, then simplification
+--      and repeats (twice currently) because one pass
+--      alone leaves tons of crud.
+-- Used (a) for user expressions typed in at the interactive prompt
+--      (b) the LHS and RHS of a RULE
+--      (c) Template Haskell splices
+--
+-- The name 'Gently' suggests that the SimplMode is SimplGently,
+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
+-- enforce that; it just simplifies the expression twice
+
+-- It's important that simplExprGently does eta reduction; see
+-- Note [Simplifying the left-hand side of a RULE] above.  The
+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
+-- but only if -O is on.
+
+simplExprGently env expr = do
+    expr1 <- simplExpr env (occurAnalyseExpr expr)
+    simplExpr env (occurAnalyseExpr expr1)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The driver for the simplifier}
+*                                                                      *
+************************************************************************
+-}
+
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+  = do { hsc_env <- getHscEnv
+       ; us <- getUniqueSupplyM
+       ; rb <- getRuleBase
+       ; liftIOWithCount $
+         simplifyPgmIO pass hsc_env us rb guts }
+
+simplifyPgmIO :: CoreToDo
+              -> HscEnv
+              -> UniqSupply
+              -> RuleBase
+              -> ModGuts
+              -> IO (SimplCount, ModGuts)  -- New bindings
+
+simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
+              hsc_env us hpt_rule_base
+              guts@(ModGuts { mg_module = this_mod
+                            , mg_rdr_env = rdr_env
+                            , mg_deps = deps
+                            , mg_binds = binds, mg_rules = rules
+                            , mg_fam_inst_env = fam_inst_env })
+  = do { (termination_msg, it_count, counts_out, guts')
+           <- do_iteration us 1 [] binds rules
+
+        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&
+                                dopt Opt_D_dump_simpl_stats  dflags)
+                  "Simplifier statistics for following pass"
+                  (vcat [text termination_msg <+> text "after" <+> ppr it_count
+                                              <+> text "iterations",
+                         blankLine,
+                         pprSimplCount counts_out])
+
+        ; return (counts_out, guts')
+    }
+  where
+    dflags       = hsc_dflags hsc_env
+    print_unqual = mkPrintUnqualified dflags rdr_env
+    simpl_env    = mkSimplEnv mode
+    active_rule  = activeRule mode
+    active_unf   = activeUnfolding mode
+
+    do_iteration :: UniqSupply
+                 -> Int          -- Counts iterations
+                 -> [SimplCount] -- Counts from earlier iterations, reversed
+                 -> CoreProgram  -- Bindings in
+                 -> [CoreRule]   -- and orphan rules
+                 -> IO (String, Int, SimplCount, ModGuts)
+
+    do_iteration us iteration_no counts_so_far binds rules
+        -- iteration_no is the number of the iteration we are
+        -- about to begin, with '1' for the first
+      | iteration_no > max_iterations   -- Stop if we've run out of iterations
+      = WARN( debugIsOn && (max_iterations > 2)
+            , hang (text "Simplifier bailing out after" <+> int max_iterations
+                    <+> text "iterations"
+                    <+> (brackets $ hsep $ punctuate comma $
+                         map (int . simplCountN) (reverse counts_so_far)))
+                 2 (text "Size =" <+> ppr (coreBindsStats binds)))
+
+                -- Subtract 1 from iteration_no to get the
+                -- number of iterations we actually completed
+        return ( "Simplifier baled out", iteration_no - 1
+               , totalise counts_so_far
+               , guts { mg_binds = binds, mg_rules = rules } )
+
+      -- Try and force thunks off the binds; significantly reduces
+      -- space usage, especially with -O.  JRS, 000620.
+      | let sz = coreBindsSize binds
+      , () <- sz `seq` ()     -- Force it
+      = do {
+                -- Occurrence analysis
+           let { tagged_binds = {-# SCC "OccAnal" #-}
+                     occurAnalysePgm this_mod active_unf active_rule rules
+                                     binds
+               } ;
+           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+                     (pprCoreBindings tagged_binds);
+
+                -- Get any new rules, and extend the rule base
+                -- See Note [Overall plumbing for rules] in Rules.hs
+                -- We need to do this regularly, because simplification can
+                -- poke on IdInfo thunks, which in turn brings in new rules
+                -- behind the scenes.  Otherwise there's a danger we'll simply
+                -- miss the rules for Ids hidden inside imported inlinings
+           eps <- hscEPS hsc_env ;
+           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
+                ; rule_base2 = extendRuleBaseList rule_base1 rules
+                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
+                ; vis_orphs = this_mod : dep_orphs deps } ;
+
+                -- Simplify the program
+           ((binds1, rules1), counts1) <-
+             initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $
+               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
+                                      simplTopBinds simpl_env tagged_binds
+
+                      -- Apply the substitution to rules defined in this module
+                      -- for imported Ids.  Eg  RULE map my_f = blah
+                      -- If we have a substitution my_f :-> other_f, we'd better
+                      -- apply it to the rule to, or it'll never match
+                  ; rules1 <- simplRules env1 Nothing rules Nothing
+
+                  ; return (getTopFloatBinds floats, rules1) } ;
+
+                -- Stop if nothing happened; don't dump output
+                -- See Note [Which transformations are innocuous] in CoreMonad
+           if isZeroSimplCount counts1 then
+                return ( "Simplifier reached fixed point", iteration_no
+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks
+                       , guts { mg_binds = binds1, mg_rules = rules1 } )
+           else do {
+                -- Short out indirections
+                -- We do this *after* at least one run of the simplifier
+                -- because indirection-shorting uses the export flag on *occurrences*
+                -- and that isn't guaranteed to be ok until after the first run propagates
+                -- stuff from the binding site to its occurrences
+                --
+                -- ToDo: alas, this means that indirection-shorting does not happen at all
+                --       if the simplifier does nothing (not common, I know, but unsavoury)
+           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
+
+                -- Dump the result of this iteration
+           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
+           lintPassResult hsc_env pass binds2 ;
+
+                -- Loop
+           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
+           } }
+      | otherwise = panic "do_iteration"
+      where
+        (us1, us2) = splitUniqSupply us
+
+        -- Remember the counts_so_far are reversed
+        totalise :: [SimplCount] -> SimplCount
+        totalise = foldr (\c acc -> acc `plusSimplCount` c)
+                         (zeroSimplCount dflags)
+
+simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
+
+-------------------
+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
+dump_end_iteration dflags print_unqual iteration_no counts binds rules
+  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
+  where
+    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations
+            | otherwise                               = Nothing
+            -- Show details if Opt_D_dump_simpl_iterations is on
+
+    hdr = text "Simplifier iteration=" <> int iteration_no
+    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr
+                     , pprSimplCount counts
+                     , text "---- End of simplifier counts for" <+> hdr ]
+
+{-
+************************************************************************
+*                                                                      *
+                Shorting out indirections
+*                                                                      *
+************************************************************************
+
+If we have this:
+
+        x_local = <expression>
+        ...bindings...
+        x_exported = x_local
+
+where x_exported is exported, and x_local is not, then we replace it with this:
+
+        x_exported = <expression>
+        x_local = x_exported
+        ...bindings...
+
+Without this we never get rid of the x_exported = x_local thing.  This
+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
+makes strictness information propagate better.  This used to happen in
+the final phase, but it's tidier to do it here.
+
+Note [Messing up the exported Id's RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must be careful about discarding (obviously) or even merging the
+RULES on the exported Id. The example that went bad on me at one stage
+was this one:
+
+    iterate :: (a -> a) -> a -> [a]
+        [Exported]
+    iterate = iterateList
+
+    iterateFB c f x = x `c` iterateFB c f (f x)
+    iterateList f x =  x : iterateList f (f x)
+        [Not exported]
+
+    {-# RULES
+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
+    "iterateFB"                 iterateFB (:) = iterateList
+     #-}
+
+This got shorted out to:
+
+    iterateList :: (a -> a) -> a -> [a]
+    iterateList = iterate
+
+    iterateFB c f x = x `c` iterateFB c f (f x)
+    iterate f x =  x : iterate f (f x)
+
+    {-# RULES
+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
+    "iterateFB"                 iterateFB (:) = iterate
+     #-}
+
+And now we get an infinite loop in the rule system
+        iterate f x -> build (\cn -> iterateFB c f x)
+                    -> iterateFB (:) f x
+                    -> iterate f x
+
+Old "solution":
+        use rule switching-off pragmas to get rid
+        of iterateList in the first place
+
+But in principle the user *might* want rules that only apply to the Id
+he says.  And inline pragmas are similar
+   {-# NOINLINE f #-}
+   f = local
+   local = <stuff>
+Then we do not want to get rid of the NOINLINE.
+
+Hence hasShortableIdinfo.
+
+
+Note [Rules and indirection-zapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem: what if x_exported has a RULE that mentions something in ...bindings...?
+Then the things mentioned can be out of scope!  Solution
+ a) Make sure that in this pass the usage-info from x_exported is
+        available for ...bindings...
+ b) If there are any such RULES, rec-ify the entire top-level.
+    It'll get sorted out next time round
+
+Other remarks
+~~~~~~~~~~~~~
+If more than one exported thing is equal to a local thing (i.e., the
+local thing really is shared), then we do one only:
+\begin{verbatim}
+        x_local = ....
+        x_exported1 = x_local
+        x_exported2 = x_local
+==>
+        x_exported1 = ....
+
+        x_exported2 = x_exported1
+\end{verbatim}
+
+We rely on prior eta reduction to simplify things like
+\begin{verbatim}
+        x_exported = /\ tyvars -> x_local tyvars
+==>
+        x_exported = x_local
+\end{verbatim}
+Hence,there's a possibility of leaving unchanged something like this:
+\begin{verbatim}
+        x_local = ....
+        x_exported1 = x_local Int
+\end{verbatim}
+By the time we've thrown away the types in STG land this
+could be eliminated.  But I don't think it's very common
+and it's dangerous to do this fiddling in STG land
+because we might elminate a binding that's mentioned in the
+unfolding for something.
+
+Note [Indirection zapping and ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unfortunately this is another place where we need a special case for
+ticks. The following happens quite regularly:
+
+        x_local = <expression>
+        x_exported = tick<x> x_local
+
+Which we want to become:
+
+        x_exported =  tick<x> <expression>
+
+As it makes no sense to keep the tick and the expression on separate
+bindings. Note however that that this might increase the ticks scoping
+over the execution of x_local, so we can only do this for floatable
+ticks. More often than not, other references will be unfoldings of
+x_exported, and therefore carry the tick anyway.
+-}
+
+type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks
+
+shortOutIndirections :: CoreProgram -> CoreProgram
+shortOutIndirections binds
+  | isEmptyVarEnv ind_env = binds
+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
+  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
+  where
+    ind_env            = makeIndEnv binds
+    -- These exported Ids are the subjects  of the indirection-elimination
+    exp_ids            = map fst $ nonDetEltsUFM ind_env
+      -- It's OK to use nonDetEltsUFM here because we forget the ordering
+      -- by immediately converting to a set or check if all the elements
+      -- satisfy a predicate.
+    exp_id_set         = mkVarSet exp_ids
+    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids
+    binds'             = concatMap zap binds
+
+    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
+    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
+
+    zapPair (bndr, rhs)
+        | bndr `elemVarSet` exp_id_set
+        = []   -- Kill the exported-id binding
+
+        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr
+        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr
+        =      -- Turn a local-id binding into two bindings
+               --    exp_id = rhs; lcl_id = exp_id
+          [ (exp_id', mkTicks ticks rhs),
+            (lcl_id', Var exp_id') ]
+
+        | otherwise
+        = [(bndr,rhs)]
+
+makeIndEnv :: [CoreBind] -> IndEnv
+makeIndEnv binds
+  = foldl' add_bind emptyVarEnv binds
+  where
+    add_bind :: IndEnv -> CoreBind -> IndEnv
+    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)
+    add_bind env (Rec pairs)              = foldl' add_pair env pairs
+
+    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv
+    add_pair env (exported_id, exported)
+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported
+        , shortMeOut env exported_id local_id
+        = extendVarEnv env local_id (exported_id, ticks)
+    add_pair env _ = env
+
+-----------------
+shortMeOut :: IndEnv -> Id -> Id -> Bool
+shortMeOut ind_env exported_id local_id
+-- The if-then-else stuff is just so I can get a pprTrace to see
+-- how often I don't get shorting out because of IdInfo stuff
+  = if isExportedId exported_id &&              -- Only if this is exported
+
+       isLocalId local_id &&                    -- Only if this one is defined in this
+                                                --      module, so that we *can* change its
+                                                --      binding to be the exported thing!
+
+       not (isExportedId local_id) &&           -- Only if this one is not itself exported,
+                                                --      since the transformation will nuke it
+
+       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
+    then
+        if hasShortableIdInfo exported_id
+        then True       -- See Note [Messing up the exported Id's IdInfo]
+        else WARN( True, text "Not shorting out:" <+> ppr exported_id )
+             False
+    else
+        False
+
+-----------------
+hasShortableIdInfo :: Id -> Bool
+-- True if there is no user-attached IdInfo on exported_id,
+-- so we can safely discard it
+-- See Note [Messing up the exported Id's IdInfo]
+hasShortableIdInfo id
+  =  isEmptyRuleInfo (ruleInfo info)
+  && isDefaultInlinePragma (inlinePragInfo info)
+  && not (isStableUnfolding (unfoldingInfo info))
+  where
+     info = idInfo id
+
+-----------------
+{- Note [Transferring IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+     lcl_id = e; exp_id = lcl_id
+
+and lcl_id has useful IdInfo, we don't want to discard it by going
+     gbl_id = e; lcl_id = gbl_id
+
+Instead, transfer IdInfo from lcl_id to exp_id, specifically
+* (Stable) unfolding
+* Strictness
+* Rules
+* Inline pragma
+
+Overwriting, rather than merging, seems to work ok.
+
+We also zap the InlinePragma on the lcl_id. It might originally
+have had a NOINLINE, which we have now transferred; and we really
+want the lcl_id to inline now that its RHS is trivial!
+-}
+
+transferIdInfo :: Id -> Id -> (Id, Id)
+-- See Note [Transferring IdInfo]
+transferIdInfo exported_id local_id
+  = ( modifyIdInfo transfer exported_id
+    , local_id `setInlinePragma` defaultInlinePragma )
+  where
+    local_info = idInfo local_id
+    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info
+                                 `setUnfoldingInfo`     unfoldingInfo local_info
+                                 `setInlinePragInfo`    inlinePragInfo local_info
+                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info
+    new_info = setRuleInfoHead (idName exported_id)
+                               (ruleInfo local_info)
+        -- Remember to set the function-name field of the
+        -- rules as we transfer them from one function to another
diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplEnv.hs
@@ -0,0 +1,936 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplMonad]{The simplifier Monad}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SimplEnv (
+        -- * The simplifier mode
+        setMode, getMode, updMode, seDynFlags,
+
+        -- * Environments
+        SimplEnv(..), pprSimplEnv,   -- Temp not abstract
+        mkSimplEnv, extendIdSubst,
+        SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
+        zapSubstEnv, setSubstEnv,
+        getInScope, setInScopeFromE, setInScopeFromF,
+        setInScopeSet, modifyInScope, addNewInScopeIds,
+        getSimplRules,
+
+        -- * Substitution results
+        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
+
+        -- * Simplifying 'Id' binders
+        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
+        simplBinder, simplBinders,
+        substTy, substTyVar, getTCvSubst,
+        substCo, substCoVar,
+
+        -- * Floats
+        SimplFloats(..), emptyFloats, mkRecFloats,
+        mkFloatBind, addLetFloats, addJoinFloats, addFloats,
+        extendFloats, wrapFloats,
+        doFloatFromRhs, getTopFloatBinds,
+
+        -- * LetFloats
+        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
+        addLetFlts,  mapLetFloats,
+
+        -- * JoinFloats
+        JoinFloat, JoinFloats, emptyJoinFloats,
+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import SimplMonad
+import CoreMonad                ( SimplMode(..) )
+import CoreSyn
+import CoreUtils
+import Var
+import VarEnv
+import VarSet
+import OrdList
+import Id
+import MkCore                   ( mkWildValBinder )
+import DynFlags                 ( DynFlags )
+import TysWiredIn
+import qualified Type
+import Type hiding              ( substTy, substTyVar, substTyVarBndr )
+import qualified Coercion
+import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )
+import BasicTypes
+import MonadUtils
+import Outputable
+import Util
+import UniqFM                   ( pprUniqFM )
+
+import Data.List
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{The @SimplEnv@ type}
+*                                                                      *
+************************************************************************
+-}
+
+data SimplEnv
+  = SimplEnv {
+     ----------- Static part of the environment -----------
+     -- Static in the sense of lexically scoped,
+     -- wrt the original expression
+
+        seMode      :: SimplMode
+
+        -- The current substitution
+      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType
+      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion
+      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr
+
+     ----------- Dynamic part of the environment -----------
+     -- Dynamic in the sense of describing the setup where
+     -- the expression finally ends up
+
+        -- The current set of in-scope variables
+        -- They are all OutVars, and all bound in this module
+      , seInScope   :: InScopeSet       -- OutVars only
+    }
+
+data SimplFloats
+  = SimplFloats
+      { -- Ordinary let bindings
+        sfLetFloats  :: LetFloats
+                -- See Note [LetFloats]
+
+        -- Join points
+      , sfJoinFloats :: JoinFloats
+                -- Handled separately; they don't go very far
+                -- We consider these to be /inside/ sfLetFloats
+                -- because join points can refer to ordinary bindings,
+                -- but not vice versa
+
+        -- Includes all variables bound by sfLetFloats and
+        -- sfJoinFloats, plus at least whatever is in scope where
+        -- these bindings land up.
+      , sfInScope :: InScopeSet  -- All OutVars
+      }
+
+instance Outputable SimplFloats where
+  ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
+    = text "SimplFloats"
+      <+> braces (vcat [ text "lets: " <+> ppr lf
+                       , text "joins:" <+> ppr jf
+                       , text "in_scope:" <+> ppr is ])
+
+emptyFloats :: SimplEnv -> SimplFloats
+emptyFloats env
+  = SimplFloats { sfLetFloats  = emptyLetFloats
+                , sfJoinFloats = emptyJoinFloats
+                , sfInScope    = seInScope env }
+
+pprSimplEnv :: SimplEnv -> SDoc
+-- Used for debugging; selective
+pprSimplEnv env
+  = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
+          text "CvSubst:" <+> ppr (seCvSubst env),
+          text "IdSubst:" <+> id_subst_doc,
+          text "InScope:" <+> in_scope_vars_doc
+    ]
+  where
+   id_subst_doc = pprUniqFM ppr (seIdSubst env)
+   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))
+                                 (vcat . map ppr_one)
+   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
+             | otherwise = ppr v
+
+type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
+        -- See Note [Extending the Subst] in CoreSubst
+
+-- | A substitution result.
+data SimplSR
+  = DoneEx OutExpr (Maybe JoinArity)
+       -- If  x :-> DoneEx e ja   is in the SimplIdSubst
+       -- then replace occurrences of x by e
+       -- and  ja = Just a <=> x is a join-point of arity a
+       -- See Note [Join arity in SimplIdSubst]
+
+
+  | DoneId OutId
+       -- If  x :-> DoneId v   is in the SimplIdSubst
+       -- then replace occurrences of x by v
+       -- and  v is a join-point of arity a
+       --      <=> x is a join-point of arity a
+
+  | ContEx TvSubstEnv                 -- A suspended substitution
+           CvSubstEnv
+           SimplIdSubst
+           InExpr
+      -- If   x :-> ContEx tv cv id e   is in the SimplISubst
+      -- then replace occurrences of x by (subst (tv,cv,id) e)
+
+instance Outputable SimplSR where
+  ppr (DoneId v)    = text "DoneId" <+> ppr v
+  ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
+    where
+      pp_mj = case mj of
+                Nothing -> empty
+                Just n  -> parens (int n)
+
+  ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
+                                ppr (filter_env tv), ppr (filter_env id) -}]
+        -- where
+        -- fvs = exprFreeVars e
+        -- filter_env env = filterVarEnv_Directly keep env
+        -- keep uniq _ = uniq `elemUFM_Directly` fvs
+
+{-
+Note [SimplEnv invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+seInScope:
+        The in-scope part of Subst includes *all* in-scope TyVars and Ids
+        The elements of the set may have better IdInfo than the
+        occurrences of in-scope Ids, and (more important) they will
+        have a correctly-substituted type.  So we use a lookup in this
+        set to replace occurrences
+
+        The Ids in the InScopeSet are replete with their Rules,
+        and as we gather info about the unfolding of an Id, we replace
+        it in the in-scope set.
+
+        The in-scope set is actually a mapping OutVar -> OutVar, and
+        in case expressions we sometimes bind
+
+seIdSubst:
+        The substitution is *apply-once* only, because InIds and OutIds
+        can overlap.
+        For example, we generally omit mappings
+                a77 -> a77
+        from the substitution, when we decide not to clone a77, but it's quite
+        legitimate to put the mapping in the substitution anyway.
+
+        Furthermore, consider
+                let x = case k of I# x77 -> ... in
+                let y = case k of I# x77 -> ... in ...
+        and suppose the body is strict in both x and y.  Then the simplifier
+        will pull the first (case k) to the top; so the second (case k) will
+        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
+        other is an out-Id.
+
+        Of course, the substitution *must* applied! Things in its domain
+        simply aren't necessarily bound in the result.
+
+* substId adds a binding (DoneId new_id) to the substitution if
+        the Id's unique has changed
+
+  Note, though that the substitution isn't necessarily extended
+  if the type of the Id changes.  Why not?  Because of the next point:
+
+* We *always, always* finish by looking up in the in-scope set
+  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
+  Reason: so that we never finish up with a "old" Id in the result.
+  An old Id might point to an old unfolding and so on... which gives a space
+  leak.
+
+  [The DoneEx and DoneVar hits map to "new" stuff.]
+
+* It follows that substExpr must not do a no-op if the substitution is empty.
+  substType is free to do so, however.
+
+* When we come to a let-binding (say) we generate new IdInfo, including an
+  unfolding, attach it to the binder, and add this newly adorned binder to
+  the in-scope set.  So all subsequent occurrences of the binder will get
+  mapped to the full-adorned binder, which is also the one put in the
+  binding site.
+
+* The in-scope "set" usually maps x->x; we use it simply for its domain.
+  But sometimes we have two in-scope Ids that are synomyms, and should
+  map to the same target:  x->x, y->x.  Notably:
+        case y of x { ... }
+  That's why the "set" is actually a VarEnv Var
+
+Note [Join arity in SimplIdSubst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have to remember which incoming variables are join points: the occurrences
+may not be marked correctly yet, and we're in change of propagating the change if
+OccurAnal makes something a join point).
+
+Normally the in-scope set is where we keep the latest information, but
+the in-scope set tracks only OutVars; if a binding is unconditionally
+inlined (via DoneEx), it never makes it into the in-scope set, and we
+need to know at the occurrence site that the variable is a join point
+so that we know to drop the context. Thus we remember which join
+points we're substituting. -}
+
+mkSimplEnv :: SimplMode -> SimplEnv
+mkSimplEnv mode
+  = SimplEnv { seMode = mode
+             , seInScope = init_in_scope
+             , seTvSubst = emptyVarEnv
+             , seCvSubst = emptyVarEnv
+             , seIdSubst = emptyVarEnv }
+        -- The top level "enclosing CC" is "SUBSUMED".
+
+init_in_scope :: InScopeSet
+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
+              -- See Note [WildCard binders]
+
+{-
+Note [WildCard binders]
+~~~~~~~~~~~~~~~~~~~~~~~
+The program to be simplified may have wild binders
+    case e of wild { p -> ... }
+We want to *rename* them away, so that there are no
+occurrences of 'wild-id' (with wildCardKey).  The easy
+way to do that is to start of with a representative
+Id in the in-scope set
+
+There can be *occurrences* of wild-id.  For example,
+MkCore.mkCoreApp transforms
+   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }
+This is ok provided 'wild' isn't free in 'e', and that's the delicate
+thing. Generally, you want to run the simplifier to get rid of the
+wild-ids before doing much else.
+
+It's a very dark corner of GHC.  Maybe it should be cleaned up.
+-}
+
+getMode :: SimplEnv -> SimplMode
+getMode env = seMode env
+
+seDynFlags :: SimplEnv -> DynFlags
+seDynFlags env = sm_dflags (seMode env)
+
+setMode :: SimplMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
+
+updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
+updMode upd env = env { seMode = upd (seMode env) }
+
+---------------------
+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
+  = ASSERT2( isId var && not (isCoVar var), ppr var )
+    env { seIdSubst = extendVarEnv subst var res }
+
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
+  = ASSERT2( isTyVar var, ppr var $$ ppr res )
+    env {seTvSubst = extendVarEnv tsubst var res}
+
+extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
+extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
+  = ASSERT( isCoVar var )
+    env {seCvSubst = extendVarEnv csubst var co}
+
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = seInScope env
+
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env in_scope = env {seInScope = in_scope}
+
+setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
+-- See Note [Setting the right in-scope set]
+setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }
+
+setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
+setInScopeFromF env floats = env { seInScope = sfInScope floats }
+
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+        -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
+  = env { seInScope = in_scope `extendInScopeSetList` vs,
+          seIdSubst = id_subst `delVarEnvList` vs }
+        -- Why delete?  Consider
+        --      let x = a*b in (x, \x -> x+3)
+        -- We add [x |-> a*b] to the substitution, but we must
+        -- _delete_ it from the substitution when going inside
+        -- the (\x -> ...)!
+
+modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
+-- The variable should already be in scope, but
+-- replace the existing version with this new one
+-- which has more information
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v
+  = env {seInScope = extendInScopeSet in_scope v}
+
+{- Note [Setting the right in-scope set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  \x. (let x = e in b) arg[x]
+where the let shadows the lambda.  Really this means something like
+  \x1. (let x2 = e in b) arg[x1]
+
+- When we capture the 'arg' in an ApplyToVal continuation, we capture
+  the environment, which says what 'x' is bound to, namely x1
+
+- Then that continuation gets pushed under the let
+
+- Finally we simplify 'arg'.  We want
+     - the static, lexical environment bindig x :-> x1
+     - the in-scopeset from "here", under the 'let' which includes
+       both x1 and x2
+
+It's important to have the right in-scope set, else we may rename a
+variable to one that is already in scope.  So we must pick up the
+in-scope set from "here", but otherwise use the environment we
+captured along with 'arg'.  This transfer of in-scope set is done by
+setInScopeFromE.
+-}
+
+---------------------
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+
+setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
+
+mkContEx :: SimplEnv -> InExpr -> SimplSR
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{LetFloats}
+*                                                                      *
+************************************************************************
+
+Note [LetFloats]
+~~~~~~~~~~~~~~~~
+The LetFloats is a bunch of bindings, classified by a FloatFlag.
+
+* All of them satisfy the let/app invariant
+
+Examples
+
+  NonRec x (y:ys)       FltLifted
+  Rec [(x,rhs)]         FltLifted
+
+  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
+  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n
+
+  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge
+
+Can't happen:
+  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app
+  NonRec x# (f y)       -- Might diverge; does not satisfy let/app
+-}
+
+data LetFloats = LetFloats (OrdList OutBind) FloatFlag
+                 -- See Note [LetFloats]
+
+type JoinFloat  = OutBind
+type JoinFloats = OrdList JoinFloat
+
+data FloatFlag
+  = FltLifted   -- All bindings are lifted and lazy *or*
+                --     consist of a single primitive string literal
+                --  Hence ok to float to top level, or recursive
+
+  | FltOkSpec   -- All bindings are FltLifted *or*
+                --      strict (perhaps because unlifted,
+                --      perhaps because of a strict binder),
+                --        *and* ok-for-speculation
+                --  Hence ok to float out of the RHS
+                --  of a lazy non-recursive let binding
+                --  (but not to top level, or into a rec group)
+
+  | FltCareful  -- At least one binding is strict (or unlifted)
+                --      and not guaranteed cheap
+                --      Do not float these bindings out of a lazy let
+
+instance Outputable LetFloats where
+  ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)
+
+instance Outputable FloatFlag where
+  ppr FltLifted  = text "FltLifted"
+  ppr FltOkSpec  = text "FltOkSpec"
+  ppr FltCareful = text "FltCareful"
+
+andFF :: FloatFlag -> FloatFlag -> FloatFlag
+andFF FltCareful _          = FltCareful
+andFF FltOkSpec  FltCareful = FltCareful
+andFF FltOkSpec  _          = FltOkSpec
+andFF FltLifted  flt        = flt
+
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
+-- If you change this function look also at FloatIn.noFloatFromRhs
+doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
+  =  not (isNilOL fs) && want_to_float && can_float
+  where
+     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
+                     -- See Note [Float when cheap or expandable]
+     can_float = case ff of
+                   FltLifted  -> True
+                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str
+
+{-
+Note [Float when cheap or expandable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to float a let from a let if the residual RHS is
+   a) cheap, such as (\x. blah)
+   b) expandable, such as (f b) if f is CONLIKE
+But there are
+  - cheap things that are not expandable (eg \x. expensive)
+  - expandable things that are not cheap (eg (f b) where b is CONLIKE)
+so we must take the 'or' of the two.
+-}
+
+emptyLetFloats :: LetFloats
+emptyLetFloats = LetFloats nilOL FltLifted
+
+emptyJoinFloats :: JoinFloats
+emptyJoinFloats = nilOL
+
+unitLetFloat :: OutBind -> LetFloats
+-- This key function constructs a singleton float with the right form
+unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
+                    LetFloats (unitOL bind) (flag bind)
+  where
+    flag (Rec {})                = FltLifted
+    flag (NonRec bndr rhs)
+      | not (isStrictId bndr)    = FltLifted
+      | exprIsTickedString rhs   = FltLifted
+          -- String literals can be floated freely.
+          -- See Note [CoreSyn top-level string literals] in CoreSyn.
+      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
+      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
+                                   FltCareful
+      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
+
+unitJoinFloat :: OutBind -> JoinFloats
+unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))
+                     unitOL bind
+
+mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
+-- Make a singleton SimplFloats, and
+-- extend the incoming SimplEnv's in-scope set with its binders
+-- These binders may already be in the in-scope set,
+-- but may have by now been augmented with more IdInfo
+mkFloatBind env bind
+  = (floats, env { seInScope = in_scope' })
+  where
+    floats
+      | isJoinBind bind
+      = SimplFloats { sfLetFloats  = emptyLetFloats
+                    , sfJoinFloats = unitJoinFloat bind
+                    , sfInScope    = in_scope' }
+      | otherwise
+      = SimplFloats { sfLetFloats  = unitLetFloat bind
+                    , sfJoinFloats = emptyJoinFloats
+                    , sfInScope    = in_scope' }
+
+    in_scope' = seInScope env `extendInScopeSetBind` bind
+
+extendFloats :: SimplFloats -> OutBind -> SimplFloats
+-- Add this binding to the floats, and extend the in-scope env too
+extendFloats (SimplFloats { sfLetFloats  = floats
+                          , sfJoinFloats = jfloats
+                          , sfInScope    = in_scope })
+             bind
+  | isJoinBind bind
+  = SimplFloats { sfInScope    = in_scope'
+                , sfLetFloats  = floats
+                , sfJoinFloats = jfloats' }
+  | otherwise
+  = SimplFloats { sfInScope    = in_scope'
+                , sfLetFloats  = floats'
+                , sfJoinFloats = jfloats }
+  where
+    in_scope' = in_scope `extendInScopeSetBind` bind
+    floats'   = floats  `addLetFlts`  unitLetFloat bind
+    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind
+
+addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
+-- Add the let-floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addLetFloats floats let_floats@(LetFloats binds _)
+  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats
+           , sfInScope   = foldlOL extendInScopeSetBind
+                                   (sfInScope floats) binds }
+
+addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
+addJoinFloats floats join_floats
+  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats
+           , sfInScope    = foldlOL extendInScopeSetBind
+                                    (sfInScope floats) join_floats }
+
+extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
+extendInScopeSetBind in_scope bind
+  = extendInScopeSetList in_scope (bindersOf bind)
+
+addFloats :: SimplFloats -> SimplFloats -> SimplFloats
+-- Add both let-floats and join-floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })
+          (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })
+  = SimplFloats { sfLetFloats  = lf1 `addLetFlts` lf2
+                , sfJoinFloats = jf1 `addJoinFlts` jf2
+                , sfInScope    = in_scope }
+
+addLetFlts :: LetFloats -> LetFloats -> LetFloats
+addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)
+  = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)
+
+letFloatBinds :: LetFloats -> [CoreBind]
+letFloatBinds (LetFloats bs _) = fromOL bs
+
+addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
+addJoinFlts = appOL
+
+mkRecFloats :: SimplFloats -> SimplFloats
+-- Flattens the floats from env2 into a single Rec group,
+-- They must either all be lifted LetFloats or all JoinFloats
+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff
+                                , sfJoinFloats = jbs
+                                , sfInScope    = in_scope })
+  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
+    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
+    SimplFloats { sfLetFloats  = floats'
+                , sfJoinFloats = jfloats'
+                , sfInScope    = in_scope }
+  where
+    floats'  | isNilOL bs  = emptyLetFloats
+             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))
+    jfloats' | isNilOL jbs = emptyJoinFloats
+             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
+
+wrapFloats :: SimplFloats -> OutExpr -> OutExpr
+-- Wrap the floats around the expression; they should all
+-- satisfy the let/app invariant, so mkLets should do the job just fine
+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _
+                        , sfJoinFloats = jbs }) body
+  = foldrOL Let (wrapJoinFloats jbs body) bs
+     -- Note: Always safe to put the joins on the inside
+     -- since the values can't refer to them
+
+wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)
+-- Wrap the sfJoinFloats of the env around the expression,
+-- and take them out of the SimplEnv
+wrapJoinFloatsX floats body
+  = ( floats { sfJoinFloats = emptyJoinFloats }
+    , wrapJoinFloats (sfJoinFloats floats) body )
+
+wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
+-- Wrap the sfJoinFloats of the env around the expression,
+-- and take them out of the SimplEnv
+wrapJoinFloats join_floats body
+  = foldrOL Let body join_floats
+
+getTopFloatBinds :: SimplFloats -> [CoreBind]
+getTopFloatBinds (SimplFloats { sfLetFloats  = lbs
+                              , sfJoinFloats = jbs})
+  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings
+    letFloatBinds lbs
+
+mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
+mapLetFloats (LetFloats fs ff) fun
+   = LetFloats (mapOL app fs) ff
+   where
+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
+    app (Rec bs)     = Rec (map fun bs)
+
+{-
+************************************************************************
+*                                                                      *
+                Substitution of Vars
+*                                                                      *
+************************************************************************
+
+Note [Global Ids in the substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We look up even a global (eg imported) Id in the substitution. Consider
+   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
+The binder-swap in the occurrence analyser will add a binding
+for a LocalId version of g (with the same unique though):
+   case X.g_34 of b { (a,b) ->  let g_34 = b in
+                                ... case X.g_34 of { (p,q) -> ...} ... }
+So we want to look up the inner X.g_34 in the substitution, where we'll
+find that it has been substituted by b.  (Or conceivably cloned.)
+-}
+
+substId :: SimplEnv -> InId -> SimplSR
+-- Returns DoneEx only on a non-Var expression
+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
+  = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]
+        Nothing               -> DoneId (refineFromInScope in_scope v)
+        Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)
+        Just res              -> res    -- DoneEx non-var, or ContEx
+
+        -- Get the most up-to-date thing from the in-scope set
+        -- Even though it isn't in the substitution, it may be in
+        -- the in-scope set with better IdInfo
+
+refineFromInScope :: InScopeSet -> Var -> Var
+refineFromInScope in_scope v
+  | isLocalId v = case lookupInScope in_scope v of
+                  Just v' -> v'
+                  Nothing -> WARN( True, ppr v ) v  -- This is an error!
+  | otherwise = v
+
+lookupRecBndr :: SimplEnv -> InId -> OutId
+-- Look up an Id which has been put into the envt by simplRecBndrs,
+-- but where we have not yet done its RHS
+lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
+  = case lookupVarEnv ids v of
+        Just (DoneId v) -> v
+        Just _ -> pprPanic "lookupRecBndr" (ppr v)
+        Nothing -> refineFromInScope in_scope v
+
+{-
+************************************************************************
+*                                                                      *
+\section{Substituting an Id binder}
+*                                                                      *
+************************************************************************
+
+
+These functions are in the monad only so that they can be made strict via seq.
+
+Note [Return type for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   (join j :: Char -> Int -> Int) 77
+   (     j x = \y. y + ord x    )
+   (in case v of                )
+   (     A -> j 'x'             )
+   (     B -> j 'y'             )
+   (     C -> <blah>            )
+
+The simplifier pushes the "apply to 77" continuation inwards to give
+
+   join j :: Char -> Int
+        j x = (\y. y + ord x) 77
+   in case v of
+        A -> j 'x'
+        B -> j 'y'
+        C -> <blah> 77
+
+Notice that the "apply to 77" continuation went into the RHS of the
+join point.  And that meant that the return type of the join point
+changed!!
+
+That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr
+takes a (Just res_ty) argument so that it knows to do the type-changing
+thing.
+-}
+
+simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
+simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
+
+-------------
+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- Used for lambda and case-bound variables
+-- Clone Id if necessary, substitute type
+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
+-- The substitution is extended only if the variable is cloned, because
+-- we *don't* need to use it to track occurrence info.
+simplBinder env bndr
+  | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
+                        ; seqTyVar tv `seq` return (env', tv) }
+  | otherwise     = do  { let (env', id) = substIdBndr Nothing env bndr
+                        ; seqId id `seq` return (env', id) }
+
+---------------
+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- A non-recursive let binder
+simplNonRecBndr env id
+  = do  { let (env1, id1) = substIdBndr Nothing env id
+        ; seqId id1 `seq` return (env1, id1) }
+
+---------------
+simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr
+                    -> SimplM (SimplEnv, OutBndr)
+-- A non-recursive let binder for a join point;
+-- context being pushed inward may change the type
+-- See Note [Return type for join points]
+simplNonRecJoinBndr env res_ty id
+  = do  { let (env1, id1) = substIdBndr (Just res_ty) env id
+        ; seqId id1 `seq` return (env1, id1) }
+
+---------------
+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
+-- Recursive let binders
+simplRecBndrs env@(SimplEnv {}) ids
+  = ASSERT(all (not . isJoinId) ids)
+    do  { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids
+        ; seqIds ids1 `seq` return env1 }
+
+---------------
+simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv
+-- Recursive let binders for join points;
+-- context being pushed inward may change types
+-- See Note [Return type for join points]
+simplRecJoinBndrs env@(SimplEnv {}) res_ty ids
+  = ASSERT(all isJoinId ids)
+    do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids
+        ; seqIds ids1 `seq` return env1 }
+
+---------------
+substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+-- Might be a coercion variable
+substIdBndr new_res_ty env bndr
+  | isCoVar bndr  = substCoVarBndr env bndr
+  | otherwise     = substNonCoVarIdBndr new_res_ty env bndr
+
+---------------
+substNonCoVarIdBndr
+   :: Maybe OutType -- New result type, if a join binder
+                    -- See Note [Return type for join points]
+   -> SimplEnv
+   -> InBndr    -- Env and binder to transform
+   -> (SimplEnv, OutBndr)
+-- Clone Id if necessary, substitute its type
+-- Return an Id with its
+--      * Type substituted
+--      * UnfoldingInfo, Rules, WorkerInfo zapped
+--      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
+--      * Robust info, retained especially arity and demand info,
+--         so that they are available to occurrences that occur in an
+--         earlier binding of a letrec
+--
+-- For the robust info, see Note [Arity robustness]
+--
+-- Augment the substitution  if the unique changed
+-- Extend the in-scope set with the new Id
+--
+-- Similar to CoreSubst.substIdBndr, except that
+--      the type of id_subst differs
+--      all fragile info is zapped
+substNonCoVarIdBndr new_res_ty
+                    env@(SimplEnv { seInScope = in_scope
+                                  , seIdSubst = id_subst })
+                    old_id
+  = ASSERT2( not (isCoVar old_id), ppr old_id )
+    (env { seInScope = in_scope `extendInScopeSet` new_id,
+           seIdSubst = new_subst }, new_id)
+  where
+    id1    = uniqAway in_scope old_id
+    id2    = substIdType env id1
+
+    id3    | Just res_ty <- new_res_ty
+           = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)
+                             -- See Note [Return type for join points]
+           | otherwise
+           = id2
+
+    new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding
+                                        -- and fragile OccInfo
+
+        -- Extend the substitution if the unique has changed,
+        -- or there's some useful occurrence information
+        -- See the notes with substTyVarBndr for the delSubstEnv
+    new_subst | new_id /= old_id
+              = extendVarEnv id_subst old_id (DoneId new_id)
+              | otherwise
+              = delVarEnv id_subst old_id
+
+------------------------------------
+seqTyVar :: TyVar -> ()
+seqTyVar b = b `seq` ()
+
+seqId :: Id -> ()
+seqId id = seqType (idType id)  `seq`
+           idInfo id            `seq`
+           ()
+
+seqIds :: [Id] -> ()
+seqIds []       = ()
+seqIds (id:ids) = seqId id `seq` seqIds ids
+
+{-
+Note [Arity robustness]
+~~~~~~~~~~~~~~~~~~~~~~~
+We *do* transfer the arity from from the in_id of a let binding to the
+out_id.  This is important, so that the arity of an Id is visible in
+its own RHS.  For example:
+        f = \x. ....g (\y. f y)....
+We can eta-reduce the arg to g, because f is a value.  But that
+needs to be visible.
+
+This interacts with the 'state hack' too:
+        f :: Bool -> IO Int
+        f = \x. case x of
+                  True  -> f y
+                  False -> \s -> ...
+Can we eta-expand f?  Only if we see that f has arity 1, and then we
+take advantage of the 'state hack' on the result of
+(f y) :: State# -> (State#, Int) to expand the arity one more.
+
+There is a disadvantage though.  Making the arity visible in the RHS
+allows us to eta-reduce
+        f = \x -> f x
+to
+        f = f
+which technically is not sound.   This is very much a corner case, so
+I'm not worried about it.  Another idea is to ensure that f's arity
+never decreases; its arity started as 1, and we should never eta-reduce
+below that.
+
+
+Note [Robust OccInfo]
+~~~~~~~~~~~~~~~~~~~~~
+It's important that we *do* retain the loop-breaker OccInfo, because
+that's what stops the Id getting inlined infinitely, in the body of
+the letrec.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+                Impedance matching to type substitution
+*                                                                      *
+************************************************************************
+-}
+
+getTCvSubst :: SimplEnv -> TCvSubst
+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env
+                      , seCvSubst = cv_env })
+  = mkTCvSubst in_scope (tv_env, cv_env)
+
+substTy :: SimplEnv -> Type -> Type
+substTy env ty = Type.substTy (getTCvSubst env) ty
+
+substTyVar :: SimplEnv -> TyVar -> Type
+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
+
+substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
+substTyVarBndr env tv
+  = case Type.substTyVarBndr (getTCvSubst env) tv of
+        (TCvSubst in_scope' tv_env' cv_env', tv')
+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
+
+substCoVar :: SimplEnv -> CoVar -> Coercion
+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
+
+substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
+substCoVarBndr env cv
+  = case Coercion.substCoVarBndr (getTCvSubst env) cv of
+        (TCvSubst in_scope' tv_env' cv_env', cv')
+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
+
+substCo :: SimplEnv -> Coercion -> Coercion
+substCo env co = Coercion.substCo (getTCvSubst env) co
+
+------------------
+substIdType :: SimplEnv -> Id -> Id
+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
+  |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
+  || noFreeVarsOfType old_ty
+  = id
+  | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)
+                -- The tyCoVarsOfType is cheaper than it looks
+                -- because we cache the free tyvars of the type
+                -- in a Note in the id's type itself
+  where
+    old_ty = idType id
diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplMonad.hs
@@ -0,0 +1,251 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplMonad]{The simplifier Monad}
+-}
+
+module SimplMonad (
+        -- The monad
+        SimplM,
+        initSmpl, traceSmpl,
+        getSimplRules, getFamEnvs,
+
+        -- Unique supply
+        MonadUnique(..), newId, newJoinId,
+
+        -- Counting
+        SimplCount, tick, freeTick, checkedTick,
+        getSimplCount, zeroSimplCount, pprSimplCount,
+        plusSimplCount, isZeroSimplCount
+    ) where
+
+import GhcPrelude
+
+import Var              ( Var, isId, mkLocalVar )
+import Name             ( mkSystemVarName )
+import Id               ( Id, mkSysLocalOrCoVar )
+import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )
+import Type             ( Type, mkLamTypes )
+import FamInstEnv       ( FamInstEnv )
+import CoreSyn          ( RuleEnv(..) )
+import UniqSupply
+import DynFlags
+import CoreMonad
+import Outputable
+import FastString
+import MonadUtils
+import ErrUtils as Err
+import Panic (throwGhcExceptionIO, GhcException (..))
+import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )
+import Control.Monad       ( liftM, ap )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Monad plumbing}
+*                                                                      *
+************************************************************************
+
+For the simplifier monad, we want to {\em thread} a unique supply and a counter.
+(Command-line switches move around through the explicitly-passed SimplEnv.)
+-}
+
+newtype SimplM result
+  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
+                -> UniqSupply   -- We thread the unique supply because
+                                -- constantly splitting it is rather expensive
+                -> SimplCount
+                -> IO (result, UniqSupply, SimplCount)}
+  -- we only need IO here for dump output
+
+data SimplTopEnv
+  = STE { st_flags     :: DynFlags
+        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run
+        , st_rules     :: RuleEnv
+        , st_fams      :: (FamInstEnv, FamInstEnv) }
+
+initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
+         -> UniqSupply          -- No init count; set to 0
+         -> Int                 -- Size of the bindings, used to limit
+                                -- the number of ticks we allow
+         -> SimplM a
+         -> IO (a, SimplCount)
+
+initSmpl dflags rules fam_envs us size m
+  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
+       return (result, count)
+  where
+    env = STE { st_flags = dflags, st_rules = rules
+              , st_max_ticks = computeMaxTicks dflags size
+              , st_fams = fam_envs }
+
+computeMaxTicks :: DynFlags -> Int -> IntWithInf
+-- Compute the max simplifier ticks as
+--     (base-size + pgm-size) * magic-multiplier * tick-factor/100
+-- where
+--    magic-multiplier is a constant that gives reasonable results
+--    base-size is a constant to deal with size-zero programs
+computeMaxTicks dflags size
+  = treatZeroAsInf $
+    fromInteger ((toInteger (size + base_size)
+                  * toInteger (tick_factor * magic_multiplier))
+          `div` 100)
+  where
+    tick_factor      = simplTickFactor dflags
+    base_size        = 100
+    magic_multiplier = 40
+        -- MAGIC NUMBER, multiplies the simplTickFactor
+        -- We can afford to be generous; this is really
+        -- just checking for loops, and shouldn't usually fire
+        -- A figure of 20 was too small: see #5539.
+
+{-# INLINE thenSmpl #-}
+{-# INLINE thenSmpl_ #-}
+{-# INLINE returnSmpl #-}
+
+
+instance Functor SimplM where
+    fmap = liftM
+
+instance Applicative SimplM where
+    pure  = returnSmpl
+    (<*>) = ap
+    (*>)  = thenSmpl_
+
+instance Monad SimplM where
+   (>>)   = (*>)
+   (>>=)  = thenSmpl
+
+returnSmpl :: a -> SimplM a
+returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
+
+thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
+
+thenSmpl m k
+  = SM $ \st_env us0 sc0 -> do
+      (m_result, us1, sc1) <- unSM m st_env us0 sc0
+      unSM (k m_result) st_env us1 sc1
+
+thenSmpl_ m k
+  = SM $ \st_env us0 sc0 -> do
+      (_, us1, sc1) <- unSM m st_env us0 sc0
+      unSM k st_env us1 sc1
+
+-- TODO: this specializing is not allowed
+-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
+-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
+
+traceSmpl :: String -> SDoc -> SimplM ()
+traceSmpl herald doc
+  = do { dflags <- getDynFlags
+       ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"
+           (hang (text herald) 2 doc) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The unique supply}
+*                                                                      *
+************************************************************************
+-}
+
+instance MonadUnique SimplM where
+    getUniqueSupplyM
+       = SM (\_st_env us sc -> case splitUniqSupply us of
+                                (us1, us2) -> return (us1, us2, sc))
+
+    getUniqueM
+       = SM (\_st_env us sc -> case takeUniqFromSupply us of
+                                (u, us') -> return (u, us', sc))
+
+    getUniquesM
+        = SM (\_st_env us sc -> case splitUniqSupply us of
+                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))
+
+instance HasDynFlags SimplM where
+    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))
+
+instance MonadIO SimplM where
+    liftIO m = SM $ \_ us sc -> do
+      x <- m
+      return (x, us, sc)
+
+getSimplRules :: SimplM RuleEnv
+getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
+
+getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
+getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
+
+newId :: FastString -> Type -> SimplM Id
+newId fs ty = do uniq <- getUniqueM
+                 return (mkSysLocalOrCoVar fs uniq ty)
+
+newJoinId :: [Var] -> Type -> SimplM Id
+newJoinId bndrs body_ty
+  = do { uniq <- getUniqueM
+       ; let name       = mkSystemVarName uniq (fsLit "$j")
+             join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]
+             -- Note [idArity for join points] in SimplUtils
+             arity      = length (filter isId bndrs)
+             join_arity = length bndrs
+             details    = JoinId join_arity
+             id_info    = vanillaIdInfo `setArityInfo` arity
+--                                        `setOccInfo` strongLoopBreaker
+
+       ; return (mkLocalVar details name join_id_ty id_info) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Counting up what we've done}
+*                                                                      *
+************************************************************************
+-}
+
+getSimplCount :: SimplM SimplCount
+getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
+
+tick :: Tick -> SimplM ()
+tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
+                              in sc' `seq` return ((), us, sc'))
+
+checkedTick :: Tick -> SimplM ()
+-- Try to take a tick, but fail if too many
+checkedTick t
+  = SM (\st_env us sc ->
+           if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
+           then throwGhcExceptionIO $
+                  PprProgramError "Simplifier ticks exhausted" (msg sc)
+           else let sc' = doSimplTick (st_flags st_env) t sc
+                in sc' `seq` return ((), us, sc'))
+  where
+    msg sc = vcat
+      [ text "When trying" <+> ppr t
+      , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."
+      , space
+      , text "If you need to increase the limit substantially, please file a"
+      , text "bug report and indicate the factor you needed."
+      , space
+      , text "If GHC was unable to complete compilation even"
+               <+> text "with a very large factor"
+      , text "(a thousand or more), please consult the"
+                <+> doubleQuotes (text "Known bugs or infelicities")
+      , text "section in the Users Guide before filing a report. There are a"
+      , text "few situations unlikely to occur in practical programs for which"
+      , text "simplifier non-termination has been judged acceptable."
+      , space
+      , pp_details sc
+      , pprSimplCount sc ]
+    pp_details sc
+      | hasDetailedCounts sc = empty
+      | otherwise = text "To see detailed counts use -ddump-simpl-stats"
+
+
+freeTick :: Tick -> SimplM ()
+-- Record a tick, but don't add to the total tick count, which is
+-- used to decide when nothing further has happened
+freeTick t
+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
+                           in sc' `seq` return ((), us, sc'))
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplUtils.hs
@@ -0,0 +1,2326 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplUtils]{The simplifier utilities}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SimplUtils (
+        -- Rebuilding
+        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
+
+        -- Inlining,
+        preInlineUnconditionally, postInlineUnconditionally,
+        activeUnfolding, activeRule,
+        getUnfoldingInRuleMatch,
+        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
+
+        -- The continuation type
+        SimplCont(..), DupFlag(..), StaticEnv,
+        isSimplified, contIsStop,
+        contIsDupable, contResultType, contHoleType,
+        contIsTrivial, contArgs,
+        countArgs,
+        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
+        interestingCallContext,
+
+        -- ArgInfo
+        ArgInfo(..), ArgSpec(..), mkArgInfo,
+        addValArgTo, addCastTo, addTyArgTo,
+        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
+
+        abstractFloats,
+
+        -- Utilities
+        isExitJoinId
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import SimplEnv
+import CoreMonad        ( SimplMode(..), Tick(..) )
+import DynFlags
+import CoreSyn
+import qualified CoreSubst
+import PprCore
+import CoreFVs
+import CoreUtils
+import CoreArity
+import CoreUnfold
+import Name
+import Id
+import IdInfo
+import Var
+import Demand
+import SimplMonad
+import Type     hiding( substTy )
+import Coercion hiding( substCo )
+import DataCon          ( dataConWorkId, isNullaryRepDataCon )
+import VarSet
+import BasicTypes
+import Util
+import OrdList          ( isNilOL )
+import MonadUtils
+import Outputable
+import Pair
+import PrelRules
+import FastString       ( fsLit )
+
+import Control.Monad    ( when )
+import Data.List        ( sortBy )
+
+{-
+************************************************************************
+*                                                                      *
+                The SimplCont and DupFlag types
+*                                                                      *
+************************************************************************
+
+A SimplCont allows the simplifier to traverse the expression in a
+zipper-like fashion.  The SimplCont represents the rest of the expression,
+"above" the point of interest.
+
+You can also think of a SimplCont as an "evaluation context", using
+that term in the way it is used for operational semantics. This is the
+way I usually think of it, For example you'll often see a syntax for
+evaluation context looking like
+        C ::= []  |  C e   |  case C of alts  |  C `cast` co
+That's the kind of thing we are doing here, and I use that syntax in
+the comments.
+
+
+Key points:
+  * A SimplCont describes a *strict* context (just like
+    evaluation contexts do).  E.g. Just [] is not a SimplCont
+
+  * A SimplCont describes a context that *does not* bind
+    any variables.  E.g. \x. [] is not a SimplCont
+-}
+
+data SimplCont
+  = Stop                -- Stop[e] = e
+        OutType         -- Type of the <hole>
+        CallCtxt        -- Tells if there is something interesting about
+                        --          the context, and hence the inliner
+                        --          should be a bit keener (see interestingCallContext)
+                        -- Specifically:
+                        --     This is an argument of a function that has RULES
+                        --     Inlining the call might allow the rule to fire
+                        -- Never ValAppCxt (use ApplyToVal instead)
+                        -- or CaseCtxt (use Select instead)
+
+  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]
+        OutCoercion             -- The coercion simplified
+                                -- Invariant: never an identity coercion
+        SimplCont
+
+  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]
+      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]
+      , sc_arg  :: InExpr       -- The argument,
+      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]
+      , sc_cont :: SimplCont }
+
+  | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]
+      { sc_arg_ty  :: OutType     -- Argument type
+      , sc_hole_ty :: OutType     -- Type of the function, presumably (forall a. blah)
+                                  -- See Note [The hole type in ApplyToTy]
+      , sc_cont    :: SimplCont }
+
+  | Select             -- (Select alts K)[e] = K[ case e of alts ]
+      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]
+      , sc_bndr :: InId           -- case binder
+      , sc_alts :: [InAlt]        -- Alternatives
+      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]
+      , sc_cont :: SimplCont }
+
+  -- The two strict forms have no DupFlag, because we never duplicate them
+  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]
+                        --       or, equivalently,  = K[ (\x xs.b) e ]
+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]
+      , sc_bndr  :: InId
+      , sc_bndrs :: [InBndr]
+      , sc_body  :: InExpr
+      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]
+      , sc_cont  :: SimplCont }
+
+  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]
+      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup
+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc
+                               --     plus strictness flags for *further* args
+      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting
+      , sc_cont :: SimplCont }
+
+  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]
+        (Tickish Id)    -- Tick tickish <hole>
+        SimplCont
+
+type StaticEnv = SimplEnv       -- Just the static part is relevant
+
+data DupFlag = NoDup       -- Unsimplified, might be big
+             | Simplified  -- Simplified
+             | OkToDup     -- Simplified and small
+
+isSimplified :: DupFlag -> Bool
+isSimplified NoDup = False
+isSimplified _     = True       -- Invariant: the subst-env is empty
+
+perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type
+perhapsSubstTy dup env ty
+  | isSimplified dup = ty
+  | otherwise        = substTy env ty
+
+{- Note [StaticEnv invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pair up an InExpr or InAlts with a StaticEnv, which establishes the
+lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we
+use
+  - Its captured StaticEnv
+  - Overriding its InScopeSet with the larger one at the
+    simplification point.
+
+Why override the InScopeSet?  Example:
+      (let y = ey in f) ex
+By the time we simplify ex, 'y' will be in scope.
+
+However the InScopeSet in the StaticEnv is not irrelevant: it should
+include all the free vars of applying the substitution to the InExpr.
+Reason: contHoleType uses perhapsSubstTy to apply the substitution to
+the expression, and that (rightly) gives ASSERT failures if the InScopeSet
+isn't big enough.
+
+Note [DupFlag invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+In both (ApplyToVal dup _ env k)
+   and  (Select dup _ _ env k)
+the following invariants hold
+
+  (a) if dup = OkToDup, then continuation k is also ok-to-dup
+  (b) if dup = OkToDup or Simplified, the subst-env is empty
+      (and and hence no need to re-simplify)
+-}
+
+instance Outputable DupFlag where
+  ppr OkToDup    = text "ok"
+  ppr NoDup      = text "nodup"
+  ppr Simplified = text "simpl"
+
+instance Outputable SimplCont where
+  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty
+  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont
+  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont
+  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })
+    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
+    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
+                                        $$ ppr cont
+  ppr (StrictBind { sc_bndr = b, sc_cont = cont })
+    = (text "StrictBind" <+> ppr b) $$ ppr cont
+  ppr (StrictArg { sc_fun = ai, sc_cont = cont })
+    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont
+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
+    = (text "Select" <+> ppr dup <+> ppr bndr) $$
+       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
+
+
+{- Note [The hole type in ApplyToTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The sc_hole_ty field of ApplyToTy records the type of the "hole" in the
+continuation.  It is absolutely necessary to compute contHoleType, but it is
+not used for anything else (and hence may not be evaluated).
+
+Why is it necessary for contHoleType?  Consider the continuation
+     ApplyToType Int (Stop Int)
+corresponding to
+     (<hole> @Int) :: Int
+What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),
+and there is no way to know which, so we must record it.
+
+In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType
+for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably
+doesn't matter because we'll never compute them all.
+
+************************************************************************
+*                                                                      *
+                ArgInfo and ArgSpec
+*                                                                      *
+************************************************************************
+-}
+
+data ArgInfo
+  = ArgInfo {
+        ai_fun   :: OutId,      -- The function
+        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)
+
+        ai_type  :: OutType,    -- Type of (f a1 ... an)
+
+        ai_rules :: FunRules,   -- Rules for this function
+
+        ai_encl :: Bool,        -- Flag saying whether this function
+                                -- or an enclosing one has rules (recursively)
+                                --      True => be keener to inline in all args
+
+        ai_strs :: [Bool],      -- Strictness of remaining arguments
+                                --   Usually infinite, but if it is finite it guarantees
+                                --   that the function diverges after being given
+                                --   that number of args
+        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline
+                                --   Always infinite
+    }
+
+data ArgSpec
+  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal
+  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy
+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)
+  | CastBy OutCoercion                -- Cast by this; c.f. CastIt
+
+instance Outputable ArgSpec where
+  ppr (ValArg e)                 = text "ValArg" <+> ppr e
+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
+  ppr (CastBy c)                 = text "CastBy" <+> ppr c
+
+addValArgTo :: ArgInfo -> OutExpr -> ArgInfo
+addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai
+                        , ai_type = applyTypeToArg (ai_type ai) arg
+                        , ai_rules = decRules (ai_rules ai) }
+
+addTyArgTo :: ArgInfo -> OutType -> ArgInfo
+addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai
+                          , ai_type = piResultTy poly_fun_ty arg_ty
+                          , ai_rules = decRules (ai_rules ai) }
+  where
+    poly_fun_ty = ai_type ai
+    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }
+
+addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
+addCastTo ai co = ai { ai_args = CastBy co : ai_args ai
+                     , ai_type = pSnd (coercionKind co) }
+
+argInfoAppArgs :: [ArgSpec] -> [OutExpr]
+argInfoAppArgs []                              = []
+argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast
+argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as
+argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as
+
+pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
+pushSimplifiedArgs _env []           k = k
+pushSimplifiedArgs env  (arg : args) k
+  = case arg of
+      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
+               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
+      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }
+      CastBy c -> CastIt c rest
+  where
+    rest = pushSimplifiedArgs env args k
+           -- The env has an empty SubstEnv
+
+argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
+-- NB: the [ArgSpec] is reversed so that the first arg
+-- in the list is the last one in the application
+argInfoExpr fun rev_args
+  = go rev_args
+  where
+    go []                              = Var fun
+    go (ValArg a                 : as) = go as `App` a
+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty
+    go (CastBy co                : as) = mkCast (go as) co
+
+
+type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function
+     -- Nothing => No rules
+     -- Just (n, rules) => some rules, requiring at least n more type/value args
+
+decRules :: FunRules -> FunRules
+decRules (Just (n, rules)) = Just (n-1, rules)
+decRules Nothing           = Nothing
+
+mkFunRules :: [CoreRule] -> FunRules
+mkFunRules [] = Nothing
+mkFunRules rs = Just (n_required, rs)
+  where
+    n_required = maximum (map ruleArity rs)
+
+{-
+************************************************************************
+*                                                                      *
+                Functions on SimplCont
+*                                                                      *
+************************************************************************
+-}
+
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty BoringCtxt
+
+mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold
+mkRhsStop ty = Stop ty RhsCtxt
+
+mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
+mkLazyArgStop ty cci = Stop ty cci
+
+-------------------
+contIsRhsOrArg :: SimplCont -> Bool
+contIsRhsOrArg (Stop {})       = True
+contIsRhsOrArg (StrictBind {}) = True
+contIsRhsOrArg (StrictArg {})  = True
+contIsRhsOrArg _               = False
+
+contIsRhs :: SimplCont -> Bool
+contIsRhs (Stop _ RhsCtxt) = True
+contIsRhs _                = False
+
+-------------------
+contIsStop :: SimplCont -> Bool
+contIsStop (Stop {}) = True
+contIsStop _         = False
+
+contIsDupable :: SimplCont -> Bool
+contIsDupable (Stop {})                         = True
+contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k
+contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]
+contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...
+contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...
+contIsDupable (CastIt _ k)                      = contIsDupable k
+contIsDupable _                                 = False
+
+-------------------
+contIsTrivial :: SimplCont -> Bool
+contIsTrivial (Stop {})                                         = True
+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k
+contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k
+contIsTrivial (CastIt _ k)                                      = contIsTrivial k
+contIsTrivial _                                                 = False
+
+-------------------
+contResultType :: SimplCont -> OutType
+contResultType (Stop ty _)                  = ty
+contResultType (CastIt _ k)                 = contResultType k
+contResultType (StrictBind { sc_cont = k }) = contResultType k
+contResultType (StrictArg { sc_cont = k })  = contResultType k
+contResultType (Select { sc_cont = k })     = contResultType k
+contResultType (ApplyToTy  { sc_cont = k }) = contResultType k
+contResultType (ApplyToVal { sc_cont = k }) = contResultType k
+contResultType (TickIt _ k)                 = contResultType k
+
+contHoleType :: SimplCont -> OutType
+contHoleType (Stop ty _)                      = ty
+contHoleType (TickIt _ k)                     = contHoleType k
+contHoleType (CastIt co _)                    = pFst (coercionKind co)
+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
+  = perhapsSubstTy dup se (idType b)
+contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)
+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]
+contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })
+  = mkVisFunTy (perhapsSubstTy dup se (exprType e))
+               (contHoleType k)
+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
+  = perhapsSubstTy d se (idType b)
+
+-------------------
+countArgs :: SimplCont -> Int
+-- Count all arguments, including types, coercions, and other values
+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont
+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont
+countArgs _                               = 0
+
+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
+-- Summarises value args, discards type args and coercions
+-- The returned continuation of the call is only used to
+-- answer questions like "are you interesting?"
+contArgs cont
+  | lone cont = (True, [], cont)
+  | otherwise = go [] cont
+  where
+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold
+    lone (ApplyToVal {}) = False
+    lone (CastIt {})     = False
+    lone _               = True
+
+    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })
+                                        = go (is_interesting arg se : args) k
+    go args (ApplyToTy { sc_cont = k }) = go args k
+    go args (CastIt _ k)                = go args k
+    go args k                           = (False, reverse args, k)
+
+    is_interesting arg se = interestingArg se arg
+                   -- Do *not* use short-cutting substitution here
+                   -- because we want to get as much IdInfo as possible
+
+
+-------------------
+mkArgInfo :: SimplEnv
+          -> Id
+          -> [CoreRule] -- Rules for function
+          -> Int        -- Number of value args
+          -> SimplCont  -- Context of the call
+          -> ArgInfo
+
+mkArgInfo env fun rules n_val_args call_cont
+  | n_val_args < idArity fun            -- Note [Unsaturated functions]
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = fun_rules
+            , ai_encl = False
+            , ai_strs = vanilla_stricts
+            , ai_discs = vanilla_discounts }
+  | otherwise
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = fun_rules
+            , ai_encl  = interestingArgContext rules call_cont
+            , ai_strs  = arg_stricts
+            , ai_discs = arg_discounts }
+  where
+    fun_ty = idType fun
+
+    fun_rules = mkFunRules rules
+
+    vanilla_discounts, arg_discounts :: [Int]
+    vanilla_discounts = repeat 0
+    arg_discounts = case idUnfolding fun of
+                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}
+                              -> discounts ++ vanilla_discounts
+                        _     -> vanilla_discounts
+
+    vanilla_stricts, arg_stricts :: [Bool]
+    vanilla_stricts  = repeat False
+
+    arg_stricts
+      | not (sm_inline (seMode env))
+      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]
+      | otherwise
+      = add_type_str fun_ty $
+        case splitStrictSig (idStrictness fun) of
+          (demands, result_info)
+                | not (demands `lengthExceeds` n_val_args)
+                ->      -- Enough args, use the strictness given.
+                        -- For bottoming functions we used to pretend that the arg
+                        -- is lazy, so that we don't treat the arg as an
+                        -- interesting context.  This avoids substituting
+                        -- top-level bindings for (say) strings into
+                        -- calls to error.  But now we are more careful about
+                        -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
+                   if isBotRes result_info then
+                        map isStrictDmd demands         -- Finite => result is bottom
+                   else
+                        map isStrictDmd demands ++ vanilla_stricts
+               | otherwise
+               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
+                                <+> ppr n_val_args <+> ppr demands )
+                   vanilla_stricts      -- Not enough args, or no strictness
+
+    add_type_str :: Type -> [Bool] -> [Bool]
+    -- If the function arg types are strict, record that in the 'strictness bits'
+    -- No need to instantiate because unboxed types (which dominate the strict
+    --   types) can't instantiate type variables.
+    -- add_type_str is done repeatedly (for each call);
+    --   might be better once-for-all in the function
+    -- But beware primops/datacons with no strictness
+
+    add_type_str _ [] = []
+    add_type_str fun_ty all_strs@(str:strs)
+      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info
+      = (str || Just False == isLiftedType_maybe arg_ty)
+        : add_type_str fun_ty' strs
+          -- If the type is levity-polymorphic, we can't know whether it's
+          -- strict. isLiftedType_maybe will return Just False only when
+          -- we're sure the type is unlifted.
+
+      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
+      = add_type_str fun_ty' all_strs     -- Look through foralls
+
+      | otherwise
+      = all_strs
+
+{- Note [Unsaturated functions]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (test eyeball/inline4)
+        x = a:as
+        y = f x
+where f has arity 2.  Then we do not want to inline 'x', because
+it'll just be floated out again.  Even if f has lots of discounts
+on its first argument -- it must be saturated for these to kick in
+
+Note [Do not expose strictness if sm_inline=False]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#15163 showed a case in which we had
+
+  {-# INLINE [1] zip #-}
+  zip = undefined
+
+  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}
+
+If we expose zip's bottoming nature when simplifing the LHS of the
+RULE we get
+  {-# RULES "foo" forall as bs.
+                   stream (case zip of {}) = ..blah... #-}
+discarding the arguments to zip.  Usually this is fine, but on the
+LHS of a rule it's not, because 'as' and 'bs' are now not bound on
+the LHS.
+
+This is a pretty pathalogical example, so I'm not losing sleep over
+it, but the simplest solution was to check sm_inline; if it is False,
+which it is on the LHS of a rule (see updModeForRules), then don't
+make use of the strictness info for the function.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+        Interesting arguments
+*                                                                      *
+************************************************************************
+
+Note [Interesting call context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to avoid inlining an expression where there can't possibly be
+any gain, such as in an argument position.  Hence, if the continuation
+is interesting (eg. a case scrutinee, application etc.) then we
+inline, otherwise we don't.
+
+Previously some_benefit used to return True only if the variable was
+applied to some value arguments.  This didn't work:
+
+        let x = _coerce_ (T Int) Int (I# 3) in
+        case _coerce_ Int (T Int) x of
+                I# y -> ....
+
+we want to inline x, but can't see that it's a constructor in a case
+scrutinee position, and some_benefit is False.
+
+Another example:
+
+dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
+
+....  case dMonadST _@_ x0 of (a,b,c) -> ....
+
+we'd really like to inline dMonadST here, but we *don't* want to
+inline if the case expression is just
+
+        case x of y { DEFAULT -> ... }
+
+since we can just eliminate this case instead (x is in WHNF).  Similar
+applies when x is bound to a lambda expression.  Hence
+contIsInteresting looks for case expressions with just a single
+default case.
+
+Note [No case of case is boring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+   case f x of <alts>
+
+we'd usually treat the context as interesting, to encourage 'f' to
+inline.  But if case-of-case is off, it's really not so interesting
+after all, because we are unlikely to be able to push the case
+expression into the branches of any case in f's unfolding.  So, to
+reduce unnecessary code expansion, we just make the context look boring.
+This made a small compile-time perf improvement in perf/compiler/T6048,
+and it looks plausible to me.
+-}
+
+interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
+-- See Note [Interesting call context]
+interestingCallContext env cont
+  = interesting cont
+  where
+    interesting (Select {})
+       | sm_case_case (getMode env) = CaseCtxt
+       | otherwise                  = BoringCtxt
+       -- See Note [No case of case is boring]
+
+    interesting (ApplyToVal {}) = ValAppCtxt
+        -- Can happen if we have (f Int |> co) y
+        -- If f has an INLINE prag we need to give it some
+        -- motivation to inline. See Note [Cast then apply]
+        -- in CoreUnfold
+
+    interesting (StrictArg { sc_cci = cci }) = cci
+    interesting (StrictBind {})              = BoringCtxt
+    interesting (Stop _ cci)                 = cci
+    interesting (TickIt _ k)                 = interesting k
+    interesting (ApplyToTy { sc_cont = k })  = interesting k
+    interesting (CastIt _ k)                 = interesting k
+        -- If this call is the arg of a strict function, the context
+        -- is a bit interesting.  If we inline here, we may get useful
+        -- evaluation information to avoid repeated evals: e.g.
+        --      x + (y * z)
+        -- Here the contIsInteresting makes the '*' keener to inline,
+        -- which in turn exposes a constructor which makes the '+' inline.
+        -- Assuming that +,* aren't small enough to inline regardless.
+        --
+        -- It's also very important to inline in a strict context for things
+        -- like
+        --              foldr k z (f x)
+        -- Here, the context of (f x) is strict, and if f's unfolding is
+        -- a build it's *great* to inline it here.  So we must ensure that
+        -- the context for (f x) is not totally uninteresting.
+
+interestingArgContext :: [CoreRule] -> SimplCont -> Bool
+-- If the argument has form (f x y), where x,y are boring,
+-- and f is marked INLINE, then we don't want to inline f.
+-- But if the context of the argument is
+--      g (f x y)
+-- where g has rules, then we *do* want to inline f, in case it
+-- exposes a rule that might fire.  Similarly, if the context is
+--      h (g (f x x))
+-- where h has rules, then we do want to inline f; hence the
+-- call_cont argument to interestingArgContext
+--
+-- The ai-rules flag makes this happen; if it's
+-- set, the inliner gets just enough keener to inline f
+-- regardless of how boring f's arguments are, if it's marked INLINE
+--
+-- The alternative would be to *always* inline an INLINE function,
+-- regardless of how boring its context is; but that seems overkill
+-- For example, it'd mean that wrapper functions were always inlined
+--
+-- The call_cont passed to interestingArgContext is the context of
+-- the call itself, e.g. g <hole> in the example above
+interestingArgContext rules call_cont
+  = notNull rules || enclosing_fn_has_rules
+  where
+    enclosing_fn_has_rules = go call_cont
+
+    go (Select {})                  = False
+    go (ApplyToVal {})              = False  -- Shouldn't really happen
+    go (ApplyToTy  {})              = False  -- Ditto
+    go (StrictArg { sc_cci = cci }) = interesting cci
+    go (StrictBind {})              = False      -- ??
+    go (CastIt _ c)                 = go c
+    go (Stop _ cci)                 = interesting cci
+    go (TickIt _ c)                 = go c
+
+    interesting RuleArgCtxt = True
+    interesting _           = False
+
+
+{- Note [Interesting arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An argument is interesting if it deserves a discount for unfoldings
+with a discount in that argument position.  The idea is to avoid
+unfolding a function that is applied only to variables that have no
+unfolding (i.e. they are probably lambda bound): f x y z There is
+little point in inlining f here.
+
+Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But
+we must look through lets, eg (let x = e in C a b), because the let will
+float, exposing the value, if we inline.  That makes it different to
+exprIsHNF.
+
+Before 2009 we said it was interesting if the argument had *any* structure
+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.
+
+But we don't regard (f x y) as interesting, unless f is unsaturated.
+If it's saturated and f hasn't inlined, then it's probably not going
+to now!
+
+Note [Conlike is interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        f d = ...((*) d x y)...
+        ... f (df d')...
+where df is con-like. Then we'd really like to inline 'f' so that the
+rule for (*) (df d) can fire.  To do this
+  a) we give a discount for being an argument of a class-op (eg (*) d)
+  b) we say that a con-like argument (eg (df d)) is interesting
+-}
+
+interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
+-- See Note [Interesting arguments]
+interestingArg env e = go env 0 e
+  where
+    -- n is # value args to which the expression is applied
+    go env n (Var v)
+       = case substId env v of
+           DoneId v'            -> go_var n v'
+           DoneEx e _           -> go (zapSubstEnv env)             n e
+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
+
+    go _   _ (Lit {})          = ValueArg
+    go _   _ (Type _)          = TrivArg
+    go _   _ (Coercion _)      = TrivArg
+    go env n (App fn (Type _)) = go env n fn
+    go env n (App fn _)        = go env (n+1) fn
+    go env n (Tick _ a)        = go env n a
+    go env n (Cast e _)        = go env n e
+    go env n (Lam v e)
+       | isTyVar v             = go env n e
+       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv
+       | otherwise             = ValueArg
+    go _ _ (Case {})           = NonTrivArg
+    go env n (Let b e)         = case go env' n e of
+                                   ValueArg -> ValueArg
+                                   _        -> NonTrivArg
+                               where
+                                 env' = env `addNewInScopeIds` bindersOf b
+
+    go_var n v
+       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that
+                                        --    data constructors here
+       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding
+       | n > 0             = NonTrivArg -- Saturated or unknown call
+       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding
+                                        -- See Note [Conlike is interesting]
+       | otherwise         = TrivArg    -- n==0, no useful unfolding
+       where
+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)
+
+{-
+************************************************************************
+*                                                                      *
+                  SimplMode
+*                                                                      *
+************************************************************************
+
+The SimplMode controls several switches; see its definition in
+CoreMonad
+        sm_rules      :: Bool     -- Whether RULES are enabled
+        sm_inline     :: Bool     -- Whether inlining is enabled
+        sm_case_case  :: Bool     -- Whether case-of-case is enabled
+        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+-}
+
+simplEnvForGHCi :: DynFlags -> SimplEnv
+simplEnvForGHCi dflags
+  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]
+                           , sm_phase  = InitialPhase
+                           , sm_dflags = dflags
+                           , sm_rules  = rules_on
+                           , sm_inline = False
+                           , sm_eta_expand = eta_expand_on
+                           , sm_case_case  = True }
+  where
+    rules_on      = gopt Opt_EnableRewriteRules   dflags
+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
+   -- Do not do any inlining, in case we expose some unboxed
+   -- tuple stuff that confuses the bytecode interpreter
+
+updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
+-- See Note [Simplifying inside stable unfoldings]
+updModeForStableUnfoldings inline_rule_act current_mode
+  = current_mode { sm_phase      = phaseFromActivation inline_rule_act
+                 , sm_inline     = True
+                 , sm_eta_expand = False }
+                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]
+       -- For sm_rules, just inherit; sm_rules might be "off"
+       -- because of -fno-enable-rewrite-rules
+  where
+    phaseFromActivation (ActiveAfter _ n) = Phase n
+    phaseFromActivation _                 = InitialPhase
+
+updModeForRules :: SimplMode -> SimplMode
+-- See Note [Simplifying rules]
+updModeForRules current_mode
+  = current_mode { sm_phase      = InitialPhase
+                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]
+                 , sm_rules      = False
+                 , sm_eta_expand = False }
+
+{- Note [Simplifying rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When simplifying a rule LHS, refrain from /any/ inlining or applying
+of other RULES.
+
+Doing anything to the LHS is plain confusing, because it means that what the
+rule matches is not what the user wrote. c.f. #10595, and #10528.
+Moreover, inlining (or applying rules) on rule LHSs risks introducing
+Ticks into the LHS, which makes matching trickier. #10665, #10745.
+
+Doing this to either side confounds tools like HERMIT, which seek to reason
+about and apply the RULES as originally written. See #10829.
+
+Note [No eta expansion in stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have a stable unfolding
+
+  f :: Ord a => a -> IO ()
+  -- Unfolding template
+  --    = /\a \(d:Ord a) (x:a). bla
+
+we do not want to eta-expand to
+
+  f :: Ord a => a -> IO ()
+  -- Unfolding template
+  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co
+
+because not specialisation of the overloading doesn't work properly
+(see Note [Specialisation shape] in Specialise), #9509.
+
+So we disable eta-expansion in stable unfoldings.
+
+Note [Inlining in gentle mode]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Something is inlined if
+   (i)   the sm_inline flag is on, AND
+   (ii)  the thing has an INLINE pragma, AND
+   (iii) the thing is inlinable in the earliest phase.
+
+Example of why (iii) is important:
+  {-# INLINE [~1] g #-}
+  g = ...
+
+  {-# INLINE f #-}
+  f x = g (g x)
+
+If we were to inline g into f's inlining, then an importing module would
+never be able to do
+        f e --> g (g e) ---> RULE fires
+because the stable unfolding for f has had g inlined into it.
+
+On the other hand, it is bad not to do ANY inlining into an
+stable unfolding, because then recursive knots in instance declarations
+don't get unravelled.
+
+However, *sometimes* SimplGently must do no call-site inlining at all
+(hence sm_inline = False).  Before full laziness we must be careful
+not to inline wrappers, because doing so inhibits floating
+    e.g. ...(case f x of ...)...
+    ==> ...(case (case x of I# x# -> fw x#) of ...)...
+    ==> ...(case x of I# x# -> case fw x# of ...)...
+and now the redex (f x) isn't floatable any more.
+
+The no-inlining thing is also important for Template Haskell.  You might be
+compiling in one-shot mode with -O2; but when TH compiles a splice before
+running it, we don't want to use -O2.  Indeed, we don't want to inline
+anything, because the byte-code interpreter might get confused about
+unboxed tuples and suchlike.
+
+Note [Simplifying inside stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must take care with simplification inside stable unfoldings (which come from
+INLINE pragmas).
+
+First, consider the following example
+        let f = \pq -> BIG
+        in
+        let g = \y -> f y y
+            {-# INLINE g #-}
+        in ...g...g...g...g...g...
+Now, if that's the ONLY occurrence of f, it might be inlined inside g,
+and thence copied multiple times when g is inlined. HENCE we treat
+any occurrence in a stable unfolding as a multiple occurrence, not a single
+one; see OccurAnal.addRuleUsage.
+
+Second, we do want *do* to some modest rules/inlining stuff in stable
+unfoldings, partly to eliminate senseless crap, and partly to break
+the recursive knots generated by instance declarations.
+
+However, suppose we have
+        {-# INLINE <act> f #-}
+        f = <rhs>
+meaning "inline f in phases p where activation <act>(p) holds".
+Then what inlinings/rules can we apply to the copy of <rhs> captured in
+f's stable unfolding?  Our model is that literally <rhs> is substituted for
+f when it is inlined.  So our conservative plan (implemented by
+updModeForStableUnfoldings) is this:
+
+  -------------------------------------------------------------
+  When simplifying the RHS of a stable unfolding, set the phase
+  to the phase in which the stable unfolding first becomes active
+  -------------------------------------------------------------
+
+That ensures that
+
+  a) Rules/inlinings that *cease* being active before p will
+     not apply to the stable unfolding, consistent with it being
+     inlined in its *original* form in phase p.
+
+  b) Rules/inlinings that only become active *after* p will
+     not apply to the stable unfolding, again to be consistent with
+     inlining the *original* rhs in phase p.
+
+For example,
+        {-# INLINE f #-}
+        f x = ...g...
+
+        {-# NOINLINE [1] g #-}
+        g y = ...
+
+        {-# RULE h g = ... #-}
+Here we must not inline g into f's RHS, even when we get to phase 0,
+because when f is later inlined into some other module we want the
+rule for h to fire.
+
+Similarly, consider
+        {-# INLINE f #-}
+        f x = ...g...
+
+        g y = ...
+and suppose that there are auto-generated specialisations and a strictness
+wrapper for g.  The specialisations get activation AlwaysActive, and the
+strictness wrapper get activation (ActiveAfter 0).  So the strictness
+wrepper fails the test and won't be inlined into f's stable unfolding. That
+means f can inline, expose the specialised call to g, so the specialisation
+rules can fire.
+
+A note about wrappers
+~~~~~~~~~~~~~~~~~~~~~
+It's also important not to inline a worker back into a wrapper.
+A wrapper looks like
+        wraper = inline_me (\x -> ...worker... )
+Normally, the inline_me prevents the worker getting inlined into
+the wrapper (initially, the worker's only call site!).  But,
+if the wrapper is sure to be called, the strictness analyser will
+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+continuation.
+-}
+
+activeUnfolding :: SimplMode -> Id -> Bool
+activeUnfolding mode id
+  | isCompulsoryUnfolding (realIdUnfolding id)
+  = True   -- Even sm_inline can't override compulsory unfoldings
+  | otherwise
+  = isActive (sm_phase mode) (idInlineActivation id)
+  && sm_inline mode
+      -- `or` isStableUnfolding (realIdUnfolding id)
+      -- Inline things when
+      --  (a) they are active
+      --  (b) sm_inline says so, except that for stable unfoldings
+      --                         (ie pragmas) we inline anyway
+
+getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
+-- When matching in RULE, we want to "look through" an unfolding
+-- (to see a constructor) if *rules* are on, even if *inlinings*
+-- are not.  A notable example is DFuns, which really we want to
+-- match in rules like (op dfun) in gentle mode. Another example
+-- is 'otherwise' which we want exprIsConApp_maybe to be able to
+-- see very early on
+getUnfoldingInRuleMatch env
+  = (in_scope, id_unf)
+  where
+    in_scope = seInScope env
+    mode = getMode env
+    id_unf id | unf_is_active id = idUnfolding id
+              | otherwise        = NoUnfolding
+    unf_is_active id
+     | not (sm_rules mode) = -- active_unfolding_minimal id
+                             isStableUnfolding (realIdUnfolding id)
+        -- Do we even need to test this?  I think this InScopeEnv
+        -- is only consulted if activeRule returns True, which
+        -- never happens if sm_rules is False
+     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
+
+----------------------
+activeRule :: SimplMode -> Activation -> Bool
+-- Nothing => No rules at all
+activeRule mode
+  | not (sm_rules mode) = \_ -> False     -- Rewriting is off
+  | otherwise           = isActive (sm_phase mode)
+
+{-
+************************************************************************
+*                                                                      *
+                  preInlineUnconditionally
+*                                                                      *
+************************************************************************
+
+preInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~
+@preInlineUnconditionally@ examines a bndr to see if it is used just
+once in a completely safe way, so that it is safe to discard the
+binding inline its RHS at the (unique) usage site, REGARDLESS of how
+big the RHS might be.  If this is the case we don't simplify the RHS
+first, but just inline it un-simplified.
+
+This is much better than first simplifying a perhaps-huge RHS and then
+inlining and re-simplifying it.  Indeed, it can be at least quadratically
+better.  Consider
+
+        x1 = e1
+        x2 = e2[x1]
+        x3 = e3[x2]
+        ...etc...
+        xN = eN[xN-1]
+
+We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
+This can happen with cascades of functions too:
+
+        f1 = \x1.e1
+        f2 = \xs.e2[f1]
+        f3 = \xs.e3[f3]
+        ...etc...
+
+THE MAIN INVARIANT is this:
+
+        ----  preInlineUnconditionally invariant -----
+   IF preInlineUnconditionally chooses to inline x = <rhs>
+   THEN doing the inlining should not change the occurrence
+        info for the free vars of <rhs>
+        ----------------------------------------------
+
+For example, it's tempting to look at trivial binding like
+        x = y
+and inline it unconditionally.  But suppose x is used many times,
+but this is the unique occurrence of y.  Then inlining x would change
+y's occurrence info, which breaks the invariant.  It matters: y
+might have a BIG rhs, which will now be dup'd at every occurrenc of x.
+
+
+Even RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
+
+[Sept 01] Don't unconditionally inline a top-level thing, because that
+can simply make a static thing into something built dynamically.  E.g.
+        x = (a,b)
+        main = \s -> h x
+
+[Remember that we treat \s as a one-shot lambda.]  No point in
+inlining x unless there is something interesting about the call site.
+
+But watch out: if you aren't careful, some useful foldr/build fusion
+can be lost (most notably in spectral/hartel/parstof) because the
+foldr didn't see the build.  Doing the dynamic allocation isn't a big
+deal, in fact, but losing the fusion can be.  But the right thing here
+seems to be to do a callSiteInline based on the fact that there is
+something interesting about the call site (it's strict).  Hmm.  That
+seems a bit fragile.
+
+Conclusion: inline top level things gaily until Phase 0 (the last
+phase), at which point don't.
+
+Note [pre/postInlineUnconditionally in gentle mode]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even in gentle mode we want to do preInlineUnconditionally.  The
+reason is that too little clean-up happens if you don't inline
+use-once things.  Also a bit of inlining is *good* for full laziness;
+it can expose constant sub-expressions.  Example in
+spectral/mandel/Mandel.hs, where the mandelset function gets a useful
+let-float if you inline windowToViewport
+
+However, as usual for Gentle mode, do not inline things that are
+inactive in the initial stages.  See Note [Gentle mode].
+
+Note [Stable unfoldings and preInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
+Example
+
+   {-# INLINE f #-}
+   f :: Eq a => a -> a
+   f x = ...
+
+   fInt :: Int -> Int
+   fInt = f Int dEqInt
+
+   ...fInt...fInt...fInt...
+
+Here f occurs just once, in the RHS of fInt. But if we inline it there
+it might make fInt look big, and we'll lose the opportunity to inline f
+at each of fInt's call sites.  The INLINE pragma will only inline when
+the application is saturated for exactly this reason; and we don't
+want PreInlineUnconditionally to second-guess it.  A live example is
+#3736.
+    c.f. Note [Stable unfoldings and postInlineUnconditionally]
+
+NB: if the pragma is INLINEABLE, then we don't want to behave in
+this special way -- an INLINEABLE pragma just says to GHC "inline this
+if you like".  But if there is a unique occurrence, we want to inline
+the stable unfolding, not the RHS.
+
+Note [Top-level bottoming Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Don't inline top-level Ids that are bottoming, even if they are used just
+once, because FloatOut has gone to some trouble to extract them out.
+Inlining them won't make the program run faster!
+
+Note [Do not inline CoVars unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Coercion variables appear inside coercions, and the RHS of a let-binding
+is a term (not a coercion) so we can't necessarily inline the latter in
+the former.
+-}
+
+preInlineUnconditionally
+    :: SimplEnv -> TopLevelFlag -> InId
+    -> InExpr -> StaticEnv  -- These two go together
+    -> Maybe SimplEnv       -- Returned env has extended substitution
+-- Precondition: rhs satisfies the let/app invariant
+-- See Note [CoreSyn let/app invariant] in CoreSyn
+-- Reason: we don't want to inline single uses, or discard dead bindings,
+--         for unlifted, side-effect-ful bindings
+preInlineUnconditionally env top_lvl bndr rhs rhs_env
+  | not pre_inline_unconditionally           = Nothing
+  | not active                               = Nothing
+  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]
+  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]
+  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
+                                                       -- in module Exitify
+  | not (one_occ (idOccInfo bndr))           = Nothing
+  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)
+
+  -- Note [Stable unfoldings and preInlineUnconditionally]
+  | isInlinablePragma inline_prag
+  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)
+  | otherwise                                = Nothing
+  where
+    unf = idUnfolding bndr
+    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
+
+    one_occ IAmDead = True -- Happens in ((\x.1) v)
+    one_occ (OneOcc { occ_one_br = True      -- One textual occurrence
+                    , occ_in_lam = in_lam
+                    , occ_int_cxt = int_cxt })
+        | not in_lam = isNotTopLevel top_lvl || early_phase
+        | otherwise  = int_cxt && canInlineInLam rhs
+    one_occ _        = False
+
+    pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)
+    mode   = getMode env
+    active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)
+             -- See Note [pre/postInlineUnconditionally in gentle mode]
+    inline_prag = idInlinePragma bndr
+
+-- Be very careful before inlining inside a lambda, because (a) we must not
+-- invalidate occurrence information, and (b) we want to avoid pushing a
+-- single allocation (here) into multiple allocations (inside lambda).
+-- Inlining a *function* with a single *saturated* call would be ok, mind you.
+--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
+--      where
+--              is_cheap = exprIsCheap rhs
+--              ok = is_cheap && int_cxt
+
+        --      int_cxt         The context isn't totally boring
+        -- E.g. let f = \ab.BIG in \y. map f xs
+        --      Don't want to substitute for f, because then we allocate
+        --      its closure every time the \y is called
+        -- But: let f = \ab.BIG in \y. map (f y) xs
+        --      Now we do want to substitute for f, even though it's not
+        --      saturated, because we're going to allocate a closure for
+        --      (f y) every time round the loop anyhow.
+
+        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
+        -- so substituting rhs inside a lambda doesn't change the occ info.
+        -- Sadly, not quite the same as exprIsHNF.
+    canInlineInLam (Lit _)    = True
+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e
+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e
+    canInlineInLam _          = False
+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting
+      -- ticks around a Lam will disappear anyway.
+
+    early_phase = case sm_phase mode of
+                    Phase 0 -> False
+                    _       -> True
+-- If we don't have this early_phase test, consider
+--      x = length [1,2,3]
+-- The full laziness pass carefully floats all the cons cells to
+-- top level, and preInlineUnconditionally floats them all back in.
+-- Result is (a) static allocation replaced by dynamic allocation
+--           (b) many simplifier iterations because this tickles
+--               a related problem; only one inlining per pass
+--
+-- On the other hand, I have seen cases where top-level fusion is
+-- lost if we don't inline top level thing (e.g. string constants)
+-- Hence the test for phase zero (which is the phase for all the final
+-- simplifications).  Until phase zero we take no special notice of
+-- top level things, but then we become more leery about inlining
+-- them.
+
+{-
+************************************************************************
+*                                                                      *
+                  postInlineUnconditionally
+*                                                                      *
+************************************************************************
+
+postInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~~
+@postInlineUnconditionally@ decides whether to unconditionally inline
+a thing based on the form of its RHS; in particular if it has a
+trivial RHS.  If so, we can inline and discard the binding altogether.
+
+NB: a loop breaker has must_keep_binding = True and non-loop-breakers
+only have *forward* references. Hence, it's safe to discard the binding
+
+NOTE: This isn't our last opportunity to inline.  We're at the binding
+site right now, and we'll get another opportunity when we get to the
+occurrence(s)
+
+Note that we do this unconditional inlining only for trival RHSs.
+Don't inline even WHNFs inside lambdas; doing so may simply increase
+allocation when the function is called. This isn't the last chance; see
+NOTE above.
+
+NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
+Because we don't even want to inline them into the RHS of constructor
+arguments. See NOTE above
+
+NB: At one time even NOINLINE was ignored here: if the rhs is trivial
+it's best to inline it anyway.  We often get a=E; b=a from desugaring,
+with both a and b marked NOINLINE.  But that seems incompatible with
+our new view that inlining is like a RULE, so I'm sticking to the 'active'
+story for now.
+-}
+
+postInlineUnconditionally
+    :: SimplEnv -> TopLevelFlag
+    -> OutId            -- The binder (*not* a CoVar), including its unfolding
+    -> OccInfo          -- From the InId
+    -> OutExpr
+    -> Bool
+-- Precondition: rhs satisfies the let/app invariant
+-- See Note [CoreSyn let/app invariant] in CoreSyn
+-- Reason: we don't want to inline single uses, or discard dead bindings,
+--         for unlifted, side-effect-ful bindings
+postInlineUnconditionally env top_lvl bndr occ_info rhs
+  | not active                  = False
+  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
+                                        -- because it might be referred to "earlier"
+  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]
+  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]
+  | exprIsTrivial rhs           = True
+  | otherwise
+  = case occ_info of
+        -- The point of examining occ_info here is that for *non-values*
+        -- that occur outside a lambda, the call-site inliner won't have
+        -- a chance (because it doesn't know that the thing
+        -- only occurs once).   The pre-inliner won't have gotten
+        -- it either, if the thing occurs in more than one branch
+        -- So the main target is things like
+        --      let x = f y in
+        --      case v of
+        --         True  -> case x of ...
+        --         False -> case x of ...
+        -- This is very important in practice; e.g. wheel-seive1 doubles
+        -- in allocation if you miss this out
+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }
+               -- OneOcc => no code-duplication issue
+        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup
+                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
+                        --
+                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True
+                        -- Reason: doing so risks exponential behaviour.  We simplify a big
+                        --         expression, inline it, and simplify it again.  But if the
+                        --         very same thing happens in the big expression, we get
+                        --         exponential cost!
+                        -- PRINCIPLE: when we've already simplified an expression once,
+                        -- make sure that we only inline it if it's reasonably small.
+
+           && (not in_lam ||
+                        -- Outside a lambda, we want to be reasonably aggressive
+                        -- about inlining into multiple branches of case
+                        -- e.g. let x = <non-value>
+                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
+                        -- Inlining can be a big win if C3 is the hot-spot, even if
+                        -- the uses in C1, C2 are not 'interesting'
+                        -- An example that gets worse if you add int_cxt here is 'clausify'
+
+                (isCheapUnfolding unfolding && int_cxt))
+                        -- isCheap => acceptable work duplication; in_lam may be true
+                        -- int_cxt to prevent us inlining inside a lambda without some
+                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally
+
+      IAmDead -> True   -- This happens; for example, the case_bndr during case of
+                        -- known constructor:  case (a,b) of x { (p,q) -> ... }
+                        -- Here x isn't mentioned in the RHS, so we don't want to
+                        -- create the (dead) let-binding  let x = (a,b) in ...
+
+      _ -> False
+
+-- Here's an example that we don't handle well:
+--      let f = if b then Left (\x.BIG) else Right (\y.BIG)
+--      in \y. ....case f of {...} ....
+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
+-- But
+--  - We can't preInlineUnconditionally because that woud invalidate
+--    the occ info for b.
+--  - We can't postInlineUnconditionally because the RHS is big, and
+--    that risks exponential behaviour
+--  - We can't call-site inline, because the rhs is big
+-- Alas!
+
+  where
+    unfolding = idUnfolding bndr
+    dflags    = seDynFlags env
+    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
+        -- See Note [pre/postInlineUnconditionally in gentle mode]
+
+{-
+Note [Top level and postInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't do postInlineUnconditionally for top-level things (even for
+ones that are trivial):
+
+  * Doing so will inline top-level error expressions that have been
+    carefully floated out by FloatOut.  More generally, it might
+    replace static allocation with dynamic.
+
+  * Even for trivial expressions there's a problem.  Consider
+      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}
+      blah xs = reverse xs
+      ruggle = sort
+    In one simplifier pass we might fire the rule, getting
+      blah xs = ruggle xs
+    but in *that* simplifier pass we must not do postInlineUnconditionally
+    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'
+
+    If the rhs is trivial it'll be inlined by callSiteInline, and then
+    the binding will be dead and discarded by the next use of OccurAnal
+
+  * There is less point, because the main goal is to get rid of local
+    bindings used in multiple case branches.
+
+  * The inliner should inline trivial things at call sites anyway.
+
+  * The Id might be exported.  We could check for that separately,
+    but since we aren't going to postInlineUnconditionally /any/
+    top-level bindings, we don't need to test.
+
+Note [Stable unfoldings and postInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not do postInlineUnconditionally if the Id has a stable unfolding,
+otherwise we lose the unfolding.  Example
+
+     -- f has stable unfolding with rhs (e |> co)
+     --   where 'e' is big
+     f = e |> co
+
+Then there's a danger we'll optimise to
+
+     f' = e
+     f = f' |> co
+
+and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'
+won't inline because 'e' is too big.
+
+    c.f. Note [Stable unfoldings and preInlineUnconditionally]
+
+
+************************************************************************
+*                                                                      *
+        Rebuilding a lambda
+*                                                                      *
+************************************************************************
+-}
+
+mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
+-- mkLam tries three things
+--      a) eta reduction, if that gives a trivial expression
+--      b) eta expansion [only if there are some value lambdas]
+
+mkLam _env [] body _cont
+  = return body
+mkLam env bndrs body cont
+  = do { dflags <- getDynFlags
+       ; mkLam' dflags bndrs body }
+  where
+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
+    mkLam' dflags bndrs (Cast body co)
+      | not (any bad bndrs)
+        -- Note [Casts and lambdas]
+      = do { lam <- mkLam' dflags bndrs body
+           ; return (mkCast lam (mkPiCos Representational bndrs co)) }
+      where
+        co_vars  = tyCoVarsOfCo co
+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
+
+    mkLam' dflags bndrs body@(Lam {})
+      = mkLam' dflags (bndrs ++ bndrs1) body1
+      where
+        (bndrs1, body1) = collectBinders body
+
+    mkLam' dflags bndrs (Tick t expr)
+      | tickishFloatable t
+      = mkTick t <$> mkLam' dflags bndrs expr
+
+    mkLam' dflags bndrs body
+      | gopt Opt_DoEtaReduction dflags
+      , Just etad_lam <- tryEtaReduce bndrs body
+      = do { tick (EtaReduction (head bndrs))
+           ; return etad_lam }
+
+      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]
+      , sm_eta_expand (getMode env)
+      , any isRuntimeVar bndrs
+      , let body_arity = exprEtaExpandArity dflags body
+      , body_arity > 0
+      = do { tick (EtaExpansion (head bndrs))
+           ; let res = mkLams bndrs (etaExpand body_arity body)
+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)
+                                          , text "after" <+> ppr res])
+           ; return res }
+
+      | otherwise
+      = return (mkLams bndrs body)
+
+{-
+Note [Eta expanding lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we *do* want to eta-expand lambdas. Consider
+   f (\x -> case x of (a,b) -> \s -> blah)
+where 's' is a state token, and hence can be eta expanded.  This
+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather
+important function!
+
+The eta-expansion will never happen unless we do it now.  (Well, it's
+possible that CorePrep will do it, but CorePrep only has a half-baked
+eta-expander that can't deal with casts.  So it's much better to do it
+here.)
+
+However, when the lambda is let-bound, as the RHS of a let, we have a
+better eta-expander (in the form of tryEtaExpandRhs), so we don't
+bother to try expansion in mkLam in that case; hence the contIsRhs
+guard.
+
+NB: We check the SimplEnv (sm_eta_expand), not DynFlags.
+    See Note [No eta expansion in stable unfoldings]
+
+Note [Casts and lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        (\x. (\y. e) `cast` g1) `cast` g2
+There is a danger here that the two lambdas look separated, and the
+full laziness pass might float an expression to between the two.
+
+So this equation in mkLam' floats the g1 out, thus:
+        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)
+where x:tx.
+
+In general, this floats casts outside lambdas, where (I hope) they
+might meet and cancel with some other cast:
+        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)
+        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)
+        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)
+                          (if not (g `in` co))
+
+Notice that it works regardless of 'e'.  Originally it worked only
+if 'e' was itself a lambda, but in some cases that resulted in
+fruitless iteration in the simplifier.  A good example was when
+compiling Text.ParserCombinators.ReadPrec, where we had a definition
+like    (\x. Get `cast` g)
+where Get is a constructor with nonzero arity.  Then mkLam eta-expanded
+the Get, and the next iteration eta-reduced it, and then eta-expanded
+it again.
+
+Note also the side condition for the case of coercion binders.
+It does not make sense to transform
+        /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)
+because the latter is not well-kinded.
+
+************************************************************************
+*                                                                      *
+              Eta expansion
+*                                                                      *
+************************************************************************
+-}
+
+tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
+                -> SimplM (Arity, Bool, OutExpr)
+-- See Note [Eta-expanding at let bindings]
+-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
+--   (a) rhs' has manifest arity n
+--   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom
+tryEtaExpandRhs mode bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
+       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }
+         -- Note [Do not eta-expand join points]
+         -- But do return the correct arity and bottom-ness, because
+         -- these are used to set the bndr's IdInfo (#15517)
+         -- Note [idArity for join points]
+
+  | otherwise
+  = do { (new_arity, is_bot, new_rhs) <- try_expand
+
+       ; WARN( new_arity < old_id_arity,
+               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity
+                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
+                        -- Note [Arity decrease] in Simplify
+         return (new_arity, is_bot, new_rhs) }
+  where
+    try_expand
+      | exprIsTrivial rhs
+      = return (exprArity rhs, False, rhs)
+
+      | sm_eta_expand mode      -- Provided eta-expansion is on
+      , new_arity > old_arity   -- And the current manifest arity isn't enough
+      = do { tick (EtaExpansion bndr)
+           ; return (new_arity, is_bot, etaExpand new_arity rhs) }
+
+      | otherwise
+      = return (old_arity, is_bot && new_arity == old_arity, rhs)
+
+    dflags       = sm_dflags mode
+    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
+    old_id_arity = idArity bndr
+
+    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity
+    new_arity2 = idCallArity bndr
+    new_arity  = max new_arity1 new_arity2
+
+{-
+Note [Eta-expanding at let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We now eta expand at let-bindings, which is where the payoff comes.
+The most significant thing is that we can do a simple arity analysis
+(in CoreArity.findRhsArity), which we can't do for free-floating lambdas
+
+One useful consequence of not eta-expanding lambdas is this example:
+   genMap :: C a => ...
+   {-# INLINE genMap #-}
+   genMap f xs = ...
+
+   myMap :: D a => ...
+   {-# INLINE myMap #-}
+   myMap = genMap
+
+Notice that 'genMap' should only inline if applied to two arguments.
+In the stable unfolding for myMap we'll have the unfolding
+    (\d -> genMap Int (..d..))
+We do not want to eta-expand to
+    (\d f xs -> genMap Int (..d..) f xs)
+because then 'genMap' will inline, and it really shouldn't: at least
+as far as the programmer is concerned, it's not applied to two
+arguments!
+
+Note [Do not eta-expand join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point
+stands well to gain from its outer binding's eta-expansion, and eta-expanding a
+join point is fraught with issues like how to deal with a cast:
+
+    let join $j1 :: IO ()
+             $j1 = ...
+             $j2 :: Int -> IO ()
+             $j2 n = if n > 0 then $j1
+                              else ...
+
+    =>
+
+    let join $j1 :: IO ()
+             $j1 = (\eta -> ...)
+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+                                 ~  IO ()
+             $j2 :: Int -> IO ()
+             $j2 n = (\eta -> if n > 0 then $j1
+                                       else ...)
+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+                                 ~  IO ()
+
+The cast here can't be pushed inside the lambda (since it's not casting to a
+function type), so the lambda has to stay, but it can't because it contains a
+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather
+than try and detect this situation (and whatever other situations crop up!), we
+don't bother; again, any surrounding eta-expansion will improve these join
+points anyway, since an outer cast can *always* be pushed inside. By the time
+CorePrep comes around, the code is very likely to look more like this:
+
+    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())
+             $j1 = (...) eta
+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())
+             $j2 = if n > 0 then $j1
+                            else (...) eta
+
+Note [idArity for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because of Note [Do not eta-expand join points] we have it that the idArity
+of a join point is always (less than or) equal to the join arity.
+Essentially, for join points we set `idArity $j = count isId join_lam_bndrs`.
+It really can be less if there are type-level binders in join_lam_bndrs.
+
+Note [Do not eta-expand PAPs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have old_arity = manifestArity rhs, which meant that we
+would eta-expand even PAPs.  But this gives no particular advantage,
+and can lead to a massive blow-up in code size, exhibited by #9020.
+Suppose we have a PAP
+    foo :: IO ()
+    foo = returnIO ()
+Then we can eta-expand do
+    foo = (\eta. (returnIO () |> sym g) eta) |> g
+where
+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
+
+But there is really no point in doing this, and it generates masses of
+coercions and whatnot that eventually disappear again. For T9020, GHC
+allocated 6.6G beore, and 0.8G afterwards; and residency dropped from
+1.8G to 45M.
+
+But note that this won't eta-expand, say
+  f = \g -> map g
+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps
+strictness analysis will have less to bite on?
+
+
+************************************************************************
+*                                                                      *
+\subsection{Floating lets out of big lambdas}
+*                                                                      *
+************************************************************************
+
+Note [Floating and type abstraction]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+        x = /\a. C e1 e2
+We'd like to float this to
+        y1 = /\a. e1
+        y2 = /\a. e2
+        x  = /\a. C (y1 a) (y2 a)
+for the usual reasons: we want to inline x rather vigorously.
+
+You may think that this kind of thing is rare.  But in some programs it is
+common.  For example, if you do closure conversion you might get:
+
+        data a :-> b = forall e. (e -> a -> b) :$ e
+
+        f_cc :: forall a. a :-> a
+        f_cc = /\a. (\e. id a) :$ ()
+
+Now we really want to inline that f_cc thing so that the
+construction of the closure goes away.
+
+So I have elaborated simplLazyBind to understand right-hand sides that look
+like
+        /\ a1..an. body
+
+and treat them specially. The real work is done in SimplUtils.abstractFloats,
+but there is quite a bit of plumbing in simplLazyBind as well.
+
+The same transformation is good when there are lets in the body:
+
+        /\abc -> let(rec) x = e in b
+   ==>
+        let(rec) x' = /\abc -> let x = x' a b c in e
+        in
+        /\abc -> let x = x' a b c in b
+
+This is good because it can turn things like:
+
+        let f = /\a -> letrec g = ... g ... in g
+into
+        letrec g' = /\a -> ... g' a ...
+        in
+        let f = /\ a -> g' a
+
+which is better.  In effect, it means that big lambdas don't impede
+let-floating.
+
+This optimisation is CRUCIAL in eliminating the junk introduced by
+desugaring mutually recursive definitions.  Don't eliminate it lightly!
+
+[May 1999]  If we do this transformation *regardless* then we can
+end up with some pretty silly stuff.  For example,
+
+        let
+            st = /\ s -> let { x1=r1 ; x2=r2 } in ...
+        in ..
+becomes
+        let y1 = /\s -> r1
+            y2 = /\s -> r2
+            st = /\s -> ...[y1 s/x1, y2 s/x2]
+        in ..
+
+Unless the "..." is a WHNF there is really no point in doing this.
+Indeed it can make things worse.  Suppose x1 is used strictly,
+and is of the form
+
+        x1* = case f y of { (a,b) -> e }
+
+If we abstract this wrt the tyvar we then can't do the case inline
+as we would normally do.
+
+That's why the whole transformation is part of the same process that
+floats let-bindings and constructor arguments out of RHSs.  In particular,
+it is guarded by the doFloatFromRhs call in simplLazyBind.
+
+Note [Which type variables to abstract over]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Abstract only over the type variables free in the rhs wrt which the
+new binding is abstracted.  Note that
+
+  * The naive approach of abstracting wrt the
+    tyvars free in the Id's /type/ fails. Consider:
+        /\ a b -> let t :: (a,b) = (e1, e2)
+                      x :: a     = fst t
+                  in ...
+    Here, b isn't free in x's type, but we must nevertheless
+    abstract wrt b as well, because t's type mentions b.
+    Since t is floated too, we'd end up with the bogus:
+         poly_t = /\ a b -> (e1, e2)
+         poly_x = /\ a   -> fst (poly_t a *b*)
+
+  * We must do closeOverKinds.  Example (#10934):
+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...
+    Here we want to float 't', but we must remember to abstract over
+    'k' as well, even though it is not explicitly mentioned in the RHS,
+    otherwise we get
+       t = /\ (f:k->*) (a:k). AccFailure @ (f a)
+    which is obviously bogus.
+-}
+
+abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats
+              -> OutExpr -> SimplM ([OutBind], OutExpr)
+abstractFloats dflags top_lvl main_tvs floats body
+  = ASSERT( notNull body_floats )
+    ASSERT( isNilOL (sfJoinFloats floats) )
+    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+        ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
+  where
+    is_top_lvl  = isTopLevel top_lvl
+    main_tv_set = mkVarSet main_tvs
+    body_floats = letFloatBinds (sfLetFloats floats)
+    empty_subst = CoreSubst.mkEmptySubst (sfInScope floats)
+
+    abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
+    abstract subst (NonRec id rhs)
+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
+                 subst' = CoreSubst.extendIdSubst subst id poly_app
+           ; return (subst', NonRec poly_id2 poly_rhs) }
+      where
+        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
+
+        -- tvs_here: see Note [Which type variables to abstract over]
+        tvs_here = scopedSort $
+                   filter (`elemVarSet` main_tv_set) $
+                   closeOverKindsList $
+                   exprSomeFreeVarsList isTyVar rhs'
+
+    abstract subst (Rec prs)
+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
+            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
+                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
+                               | (poly_id, rhs) <- poly_ids `zip` rhss
+                               , let rhs' = CoreSubst.substExpr (text "abstract_floats")
+                                                                subst' rhs ]
+            ; return (subst', Rec poly_pairs) }
+       where
+         (ids,rhss) = unzip prs
+                -- For a recursive group, it's a bit of a pain to work out the minimal
+                -- set of tyvars over which to abstract:
+                --      /\ a b c.  let x = ...a... in
+                --                 letrec { p = ...x...q...
+                --                          q = .....p...b... } in
+                --                 ...
+                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
+                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
+                -- Since it's a pain, we just use the whole set, which is always safe
+                --
+                -- If you ever want to be more selective, remember this bizarre case too:
+                --      x::a = x
+                -- Here, we must abstract 'x' over 'a'.
+         tvs_here = scopedSort main_tvs
+
+    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
+    mk_poly1 tvs_here var
+      = do { uniq <- getUniqueM
+           ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
+                  poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course
+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs
+                              mkLocalIdOrCoVar poly_name poly_ty
+           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
+                -- In the olden days, it was crucial to copy the occInfo of the original var,
+                -- because we were looking at occurrence-analysed but as yet unsimplified code!
+                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
+                -- at already simplified code, so it doesn't matter
+                --
+                -- It's even right to retain single-occurrence or dead-var info:
+                -- Suppose we started with  /\a -> let x = E in B
+                -- where x occurs once in B. Then we transform to:
+                --      let x' = /\a -> E in /\a -> let x* = x' a in B
+                -- where x* has an INLINE prag on it.  Now, once x* is inlined,
+                -- the occurrences of x' will be just the occurrences originally
+                -- pinned on x.
+
+    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)
+    mk_poly2 poly_id tvs_here rhs
+      = (poly_id `setIdUnfolding` unf, poly_rhs)
+      where
+        poly_rhs = mkLams tvs_here rhs
+        unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs
+
+        -- We want the unfolding.  Consider
+        --      let
+        --            x = /\a. let y = ... in Just y
+        --      in body
+        -- Then we float the y-binding out (via abstractFloats and addPolyBind)
+        -- but 'x' may well then be inlined in 'body' in which case we'd like the
+        -- opportunity to inline 'y' too.
+
+{-
+Note [Abstract over coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
+type variable a.  Rather than sort this mess out, we simply bale out and abstract
+wrt all the type variables if any of them are coercion variables.
+
+
+Historical note: if you use let-bindings instead of a substitution, beware of this:
+
+                -- Suppose we start with:
+                --
+                --      x = /\ a -> let g = G in E
+                --
+                -- Then we'll float to get
+                --
+                --      x = let poly_g = /\ a -> G
+                --          in /\ a -> let g = poly_g a in E
+                --
+                -- But now the occurrence analyser will see just one occurrence
+                -- of poly_g, not inside a lambda, so the simplifier will
+                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
+                -- (I used to think that the "don't inline lone occurrences" stuff
+                --  would stop this happening, but since it's the *only* occurrence,
+                --  PreInlineUnconditionally kicks in first!)
+                --
+                -- Solution: put an INLINE note on g's RHS, so that poly_g seems
+                --           to appear many times.  (NB: mkInlineMe eliminates
+                --           such notes on trivial RHSs, so do it manually.)
+
+************************************************************************
+*                                                                      *
+                prepareAlts
+*                                                                      *
+************************************************************************
+
+prepareAlts tries these things:
+
+1.  Eliminate alternatives that cannot match, including the
+    DEFAULT alternative.
+
+2.  If the DEFAULT alternative can match only one possible constructor,
+    then make that constructor explicit.
+    e.g.
+        case e of x { DEFAULT -> rhs }
+     ===>
+        case e of x { (a,b) -> rhs }
+    where the type is a single constructor type.  This gives better code
+    when rhs also scrutinises x or e.
+
+3. Returns a list of the constructors that cannot holds in the
+   DEFAULT alternative (if there is one)
+
+Here "cannot match" includes knowledge from GADTs
+
+It's a good idea to do this stuff before simplifying the alternatives, to
+avoid simplifying alternatives we know can't happen, and to come up with
+the list of constructors that are handled, to put into the IdInfo of the
+case binder, for use when simplifying the alternatives.
+
+Eliminating the default alternative in (1) isn't so obvious, but it can
+happen:
+
+data Colour = Red | Green | Blue
+
+f x = case x of
+        Red -> ..
+        Green -> ..
+        DEFAULT -> h x
+
+h y = case y of
+        Blue -> ..
+        DEFAULT -> [ case y of ... ]
+
+If we inline h into f, the default case of the inlined h can't happen.
+If we don't notice this, we may end up filtering out *all* the cases
+of the inner case y, which give us nowhere to go!
+-}
+
+prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
+-- The returned alternatives can be empty, none are possible
+prepareAlts scrut case_bndr' alts
+  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')
+           -- Case binder is needed just for its type. Note that as an
+           --   OutId, it has maximum information; this is important.
+           --   Test simpl013 is an example
+  = do { us <- getUniquesM
+       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts
+             (yes2,  alts2)       = refineDefaultAlt us tc tys idcs1 alts1
+             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2
+             -- "idcs" stands for "impossible default data constructors"
+             -- i.e. the constructors that can't match the default case
+       ; when yes2 $ tick (FillInCaseDefault case_bndr')
+       ; when yes3 $ tick (AltMerge case_bndr')
+       ; return (idcs3, alts3) }
+
+  | otherwise  -- Not a data type, so nothing interesting happens
+  = return ([], alts)
+  where
+    imposs_cons = case scrut of
+                    Var v -> otherCons (idUnfolding v)
+                    _     -> []
+
+
+{-
+************************************************************************
+*                                                                      *
+                mkCase
+*                                                                      *
+************************************************************************
+
+mkCase tries these things
+
+* Note [Nerge nested cases]
+* Note [Eliminate identity case]
+* Note [Scrutinee constant folding]
+
+Note [Merge Nested Cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+       case e of b {             ==>   case e of b {
+         p1 -> rhs1                      p1 -> rhs1
+         ...                             ...
+         pm -> rhsm                      pm -> rhsm
+         _  -> case b of b' {            pn -> let b'=b in rhsn
+                     pn -> rhsn          ...
+                     ...                 po -> let b'=b in rhso
+                     po -> rhso          _  -> let b'=b in rhsd
+                     _  -> rhsd
+       }
+
+which merges two cases in one case when -- the default alternative of
+the outer case scrutises the same variable as the outer case. This
+transformation is called Case Merging.  It avoids that the same
+variable is scrutinised multiple times.
+
+Note [Eliminate Identity Case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        case e of               ===> e
+                True  -> True;
+                False -> False
+
+and similar friends.
+
+Note [Scrutinee Constant Folding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+     case x op# k# of _ {  ===> case x of _ {
+        a1# -> e1                  (a1# inv_op# k#) -> e1
+        a2# -> e2                  (a2# inv_op# k#) -> e2
+        ...                        ...
+        DEFAULT -> ed              DEFAULT -> ed
+
+     where (x op# k#) inv_op# k# == x
+
+And similarly for commuted arguments and for some unary operations.
+
+The purpose of this transformation is not only to avoid an arithmetic
+operation at runtime but to allow other transformations to apply in cascade.
+
+Example with the "Merge Nested Cases" optimization (from #12877):
+
+      main = case t of t0
+         0##     -> ...
+         DEFAULT -> case t0 `minusWord#` 1## of t1
+            0##    -> ...
+            DEFAUT -> case t1 `minusWord#` 1## of t2
+               0##     -> ...
+               DEFAULT -> case t2 `minusWord#` 1## of _
+                  0##     -> ...
+                  DEFAULT -> ...
+
+  becomes:
+
+      main = case t of _
+      0##     -> ...
+      1##     -> ...
+      2##     -> ...
+      3##     -> ...
+      DEFAULT -> ...
+
+There are some wrinkles
+
+* Do not apply caseRules if there is just a single DEFAULT alternative
+     case e +# 3# of b { DEFAULT -> rhs }
+  If we applied the transformation here we would (stupidly) get
+     case a of b' { DEFAULT -> let b = e +# 3# in rhs }
+  and now the process may repeat, because that let will really
+  be a case.
+
+* The type of the scrutinee might change.  E.g.
+        case tagToEnum (x :: Int#) of (b::Bool)
+          False -> e1
+          True -> e2
+  ==>
+        case x of (b'::Int#)
+          DEFAULT -> e1
+          1#      -> e2
+
+* The case binder may be used in the right hand sides, so we need
+  to make a local binding for it, if it is alive.  e.g.
+         case e +# 10# of b
+           DEFAULT -> blah...b...
+           44#     -> blah2...b...
+  ===>
+         case e of b'
+           DEFAULT -> let b = b' +# 10# in blah...b...
+           34#     -> let b = 44# in blah2...b...
+
+  Note that in the non-DEFAULT cases we know what to bind 'b' to,
+  whereas in the DEFAULT case we must reconstruct the original value.
+  But NB: we use b'; we do not duplicate 'e'.
+
+* In dataToTag we might need to make up some fake binders;
+  see Note [caseRules for dataToTag] in PrelRules
+-}
+
+mkCase, mkCase1, mkCase2, mkCase3
+   :: DynFlags
+   -> OutExpr -> OutId
+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order
+   -> SimplM OutExpr
+
+--------------------------------------------------
+--      1. Merge Nested Cases
+--------------------------------------------------
+
+mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
+  | gopt Opt_CaseMerge dflags
+  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)
+       <- stripTicksTop tickishFloatable deflt_rhs
+  , inner_scrut_var == outer_bndr
+  = do  { tick (CaseMerge outer_bndr)
+
+        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )
+                                          (con, args, wrap_rhs rhs)
+                -- Simplifier's no-shadowing invariant should ensure
+                -- that outer_bndr is not shadowed by the inner patterns
+              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
+                -- The let is OK even for unboxed binders,
+
+              wrapped_alts | isDeadBinder inner_bndr = inner_alts
+                           | otherwise               = map wrap_alt inner_alts
+
+              merged_alts = mergeAlts outer_alts wrapped_alts
+                -- NB: mergeAlts gives priority to the left
+                --      case x of
+                --        A -> e1
+                --        DEFAULT -> case x of
+                --                      A -> e2
+                --                      B -> e3
+                -- When we merge, we must ensure that e1 takes
+                -- precedence over e2 as the value for A!
+
+        ; fmap (mkTicks ticks) $
+          mkCase1 dflags scrut outer_bndr alts_ty merged_alts
+        }
+        -- Warning: don't call mkCase recursively!
+        -- Firstly, there's no point, because inner alts have already had
+        -- mkCase applied to them, so they won't have a case in their default
+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+        -- in munge_rhs may put a case into the DEFAULT branch!
+
+mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
+
+--------------------------------------------------
+--      2. Eliminate Identity Case
+--------------------------------------------------
+
+mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
+  | all identity_alt alts
+  = do { tick (CaseIdentity case_bndr)
+       ; return (mkTicks ticks $ re_cast scrut rhs1) }
+  where
+    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)
+    identity_alt (con, args, rhs) = check_eq rhs con args
+
+    check_eq (Cast rhs co) con args        -- See Note [RHS casts]
+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args
+    check_eq (Tick t e) alt args
+      = tickishFloatable t && check_eq e alt args
+
+    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'
+    check_eq (Var v) _ _  | v == case_bndr = True
+    check_eq (Var v)   (DataAlt con) args
+      | null arg_tys, null args            = v == dataConWorkId con
+                                             -- Optimisation only
+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $
+                                             mkConApp2 con arg_tys args
+    check_eq _          _             _    = False
+
+    arg_tys = tyConAppArgs (idType case_bndr)
+
+        -- Note [RHS casts]
+        -- ~~~~~~~~~~~~~~~~
+        -- We've seen this:
+        --      case e of x { _ -> x `cast` c }
+        -- And we definitely want to eliminate this case, to give
+        --      e `cast` c
+        -- So we throw away the cast from the RHS, and reconstruct
+        -- it at the other end.  All the RHS casts must be the same
+        -- if (all identity_alt alts) holds.
+        --
+        -- Don't worry about nested casts, because the simplifier combines them
+
+    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
+    re_cast scrut _             = scrut
+
+mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
+
+--------------------------------------------------
+--      2. Scrutinee Constant Folding
+--------------------------------------------------
+
+mkCase2 dflags scrut bndr alts_ty alts
+  | -- See Note [Scrutinee Constant Folding]
+    case alts of  -- Not if there is just a DEFAULT alternative
+      [(DEFAULT,_,_)] -> False
+      _               -> True
+  , gopt Opt_CaseFolding dflags
+  , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut
+  = do { bndr' <- newId (fsLit "lwild") (exprType scrut')
+
+       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts
+                  -- mapMaybeM: discard unreachable alternatives
+                  -- See Note [Unreachable caseRules alternatives]
+                  -- in PrelRules
+
+       ; mkCase3 dflags scrut' bndr' alts_ty $
+         add_default (re_sort alts')
+       }
+
+  | otherwise
+  = mkCase3 dflags scrut bndr alts_ty alts
+  where
+    -- We need to keep the correct association between the scrutinee and its
+    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with
+    -- "let bndr = ... in":
+    --
+    --     case v + 10 of y        =====> case v of y
+    --        20      -> e1                 10      -> let y = 20     in e1
+    --        DEFAULT -> e2                 DEFAULT -> let y = v + 10 in e2
+    --
+    -- Other transformations give: =====> case v of y'
+    --                                      10      -> let y = 20      in e1
+    --                                      DEFAULT -> let y = y' + 10 in e2
+    --
+    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,
+    -- to construct an expression equivalent to the original one, for use
+    -- in the DEFAULT case
+
+    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id
+           -> CoreAlt -> SimplM (Maybe CoreAlt)
+    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)
+      = case tx_con con of
+          Nothing   -> return Nothing
+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'
+                          ; return (Just (con', bs', rhs')) }
+      where
+        rhs' | isDeadBinder bndr = rhs
+             | otherwise         = bindNonRec bndr orig_val rhs
+
+        orig_val = case con of
+                      DEFAULT    -> mk_orig new_bndr
+                      LitAlt l   -> Lit l
+                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs
+
+    mk_new_bndrs new_bndr (DataAlt dc)
+      | not (isNullaryRepDataCon dc)
+      = -- For non-nullary data cons we must invent some fake binders
+        -- See Note [caseRules for dataToTag] in PrelRules
+        do { us <- getUniquesM
+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc
+                                        (tyConAppArgs (idType new_bndr))
+           ; return (ex_tvs ++ arg_ids) }
+    mk_new_bndrs _ _ = return []
+
+    re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to
+    re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#
+
+    add_default :: [CoreAlt] -> [CoreAlt]
+    -- See Note [Literal cases]
+    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts
+    add_default alts                          = alts
+
+{- Note [Literal cases]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  case tagToEnum (a ># b) of
+     False -> e1
+     True  -> e2
+
+then caseRules for TagToEnum will turn it into
+  case tagToEnum (a ># b) of
+     0# -> e1
+     1# -> e2
+
+Since the case is exhaustive (all cases are) we can convert it to
+  case tagToEnum (a ># b) of
+     DEFAULT -> e1
+     1#      -> e2
+
+This may generate sligthtly better code (although it should not, since
+all cases are exhaustive) and/or optimise better.  I'm not certain that
+it's necessary, but currenty we do make this change.  We do it here,
+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]
+in PrelRules)
+-}
+
+--------------------------------------------------
+--      Catch-all
+--------------------------------------------------
+mkCase3 _dflags scrut bndr alts_ty alts
+  = return (Case scrut bndr alts_ty alts)
+
+-- See Note [Exitification] and Note [Do not inline exit join points] in Exitify.hs
+-- This lives here (and not in Id) because occurrence info is only valid on
+-- InIds, so it's crucial that isExitJoinId is only called on freshly
+-- occ-analysed code. It's not a generic function you can call anywhere.
+isExitJoinId :: Var -> Bool
+isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id)
+
+{-
+Note [Dead binders]
+~~~~~~~~~~~~~~~~~~~~
+Note that dead-ness is maintained by the simplifier, so that it is
+accurate after simplification as well as before.
+
+
+Note [Cascading case merge]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case merging should cascade in one sweep, because it
+happens bottom-up
+
+      case e of a {
+        DEFAULT -> case a of b
+                      DEFAULT -> case b of c {
+                                     DEFAULT -> e
+                                     A -> ea
+                      B -> eb
+        C -> ec
+==>
+      case e of a {
+        DEFAULT -> case a of b
+                      DEFAULT -> let c = b in e
+                      A -> let c = b in ea
+                      B -> eb
+        C -> ec
+==>
+      case e of a {
+        DEFAULT -> let b = a in let c = b in e
+        A -> let b = a in let c = b in ea
+        B -> let b = a in eb
+        C -> ec
+
+
+However here's a tricky case that we still don't catch, and I don't
+see how to catch it in one pass:
+
+  case x of c1 { I# a1 ->
+  case a1 of c2 ->
+    0 -> ...
+    DEFAULT -> case x of c3 { I# a2 ->
+               case a2 of ...
+
+After occurrence analysis (and its binder-swap) we get this
+
+  case x of c1 { I# a1 ->
+  let x = c1 in         -- Binder-swap addition
+  case a1 of c2 ->
+    0 -> ...
+    DEFAULT -> case x of c3 { I# a2 ->
+               case a2 of ...
+
+When we simplify the inner case x, we'll see that
+x=c1=I# a1.  So we'll bind a2 to a1, and get
+
+  case x of c1 { I# a1 ->
+  case a1 of c2 ->
+    0 -> ...
+    DEFAULT -> case a1 of ...
+
+This is corect, but we can't do a case merge in this sweep
+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards
+without getting changed to c1=I# c2.
+
+I don't think this is worth fixing, even if I knew how. It'll
+all come out in the next pass anyway.
+-}
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/Simplify.hs
@@ -0,0 +1,3602 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[Simplify]{The main module of the simplifier}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module Simplify ( simplTopBinds, simplExpr, simplRules ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import SimplMonad
+import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )
+import SimplEnv
+import SimplUtils
+import OccurAnal        ( occurAnalyseExpr )
+import FamInstEnv       ( FamInstEnv )
+import Literal          ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
+import Id
+import MkId             ( seqId )
+import MkCore           ( FloatBind, mkImpossibleExpr, castBottomExpr )
+import qualified MkCore as MkCore
+import IdInfo
+import Name             ( mkSystemVarName, isExternalName, getOccFS )
+import Coercion hiding  ( substCo, substCoVar )
+import OptCoercion      ( optCoercion )
+import FamInstEnv       ( topNormaliseType_maybe )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
+                        , dataConRepArgTys, isUnboxedTupleCon
+                        , StrictnessMark (..) )
+import CoreMonad        ( Tick(..), SimplMode(..) )
+import CoreSyn
+import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd )
+import PprCore          ( pprCoreExpr )
+import CoreUnfold
+import CoreUtils
+import CoreOpt          ( pushCoTyArg, pushCoValArg
+                        , joinPointBinding_maybe, joinPointBindings_maybe )
+import Rules            ( mkRuleInfo, lookupRule, getRules )
+import Demand           ( mkClosedStrictSig, topDmd, botRes )
+import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
+                          RecFlag(..), Arity )
+import MonadUtils       ( mapAccumLM, liftIO )
+import Var              ( isTyCoVar )
+import Maybes           (  orElse )
+import Control.Monad
+import Outputable
+import FastString
+import Pair
+import Util
+import ErrUtils
+import Module          ( moduleName, pprModuleName )
+import PrimOp          ( PrimOp (SeqOp) )
+
+
+{-
+The guts of the simplifier is in this module, but the driver loop for
+the simplifier is in SimplCore.hs.
+
+Note [The big picture]
+~~~~~~~~~~~~~~~~~~~~~~
+The general shape of the simplifier is this:
+
+  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
+
+ * SimplEnv contains
+     - Simplifier mode (which includes DynFlags for convenience)
+     - Ambient substitution
+     - InScopeSet
+
+ * SimplFloats contains
+     - Let-floats (which includes ok-for-spec case-floats)
+     - Join floats
+     - InScopeSet (including all the floats)
+
+ * Expressions
+      simplExpr :: SimplEnv -> InExpr -> SimplCont
+                -> SimplM (SimplFloats, OutExpr)
+   The result of simplifying an /expression/ is (floats, expr)
+      - A bunch of floats (let bindings, join bindings)
+      - A simplified expression.
+   The overall result is effectively (let floats in expr)
+
+ * Bindings
+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
+   The result of simplifying a binding is
+     - A bunch of floats, the last of which is the simplified binding
+       There may be auxiliary bindings too; see prepareRhs
+     - An environment suitable for simplifying the scope of the binding
+
+   The floats may also be empty, if the binding is inlined unconditionally;
+   in that case the returned SimplEnv will have an augmented substitution.
+
+   The returned floats and env both have an in-scope set, and they are
+   guaranteed to be the same.
+
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more.   (Actually, it never did!)  The reason is
+documented with simplifyArgs.
+
+
+Eta expansion
+~~~~~~~~~~~~~~
+For eta expansion, we want to catch things like
+
+        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
+
+If the \x was on the RHS of a let, we'd eta expand to bring the two
+lambdas together.  And in general that's a good thing to do.  Perhaps
+we should eta expand wherever we find a (value) lambda?  Then the eta
+expansion at a let RHS can concentrate solely on the PAP case.
+
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+-- See Note [The big picture]
+simplTopBinds env0 binds0
+  = do  {       -- Put all the top-level binders into scope at the start
+                -- so that if a transformation rule has unexpectedly brought
+                -- anything into scope, then we don't get a complaint about that.
+                -- It's rather as if the top-level binders were imported.
+                -- See note [Glomming] in OccurAnal.
+        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
+        ; freeTick SimplifierDone
+        ; return (floats, env2) }
+  where
+        -- We need to track the zapped top-level binders, because
+        -- they should have their fragile IdInfo zapped (notably occurrence info)
+        -- That's why we run down binds and bndrs' simultaneously.
+        --
+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+    simpl_binds env []           = return (emptyFloats env, env)
+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind
+                                      ; (floats, env2) <- simpl_binds env1 binds
+                                      ; return (float `addFloats` floats, env2) }
+
+    simpl_bind env (Rec pairs)
+      = simplRecBind env TopLevel Nothing pairs
+    simpl_bind env (NonRec b r)
+      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing
+           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }
+
+{-
+************************************************************************
+*                                                                      *
+        Lazy bindings
+*                                                                      *
+************************************************************************
+
+simplRecBind is used for
+        * recursive bindings only
+-}
+
+simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont
+             -> [(InId, InExpr)]
+             -> SimplM (SimplFloats, SimplEnv)
+simplRecBind env0 top_lvl mb_cont pairs0
+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
+        ; (rec_floats, env1) <- go env_with_info triples
+        ; return (mkRecFloats rec_floats, env1) }
+  where
+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
+        -- Add the (substituted) rules to the binder
+    add_rules env (bndr, rhs)
+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont
+             ; return (env', (bndr, bndr', rhs)) }
+
+    go env [] = return (emptyFloats env, env)
+
+    go env ((old_bndr, new_bndr, rhs) : pairs)
+        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont
+                                                  old_bndr new_bndr rhs
+             ; (floats, env2) <- go env1 pairs
+             ; return (float `addFloats` floats, env2) }
+
+{-
+simplOrTopPair is used for
+        * recursive bindings (whether top level or not)
+        * top-level non-recursive bindings
+
+It assumes the binder has already been simplified, but not its IdInfo.
+-}
+
+simplRecOrTopPair :: SimplEnv
+                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont
+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs
+                  -> SimplM (SimplFloats, SimplEnv)
+
+simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs
+  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env
+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}
+    trace_bind "pre-inline-uncond" $
+    do { tick (PreInlineUnconditionally old_bndr)
+       ; return ( emptyFloats env, env' ) }
+
+  | Just cont <- mb_cont
+  = {-#SCC "simplRecOrTopPair-join" #-}
+    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )
+    trace_bind "join" $
+    simplJoinBind env cont old_bndr new_bndr rhs env
+
+  | otherwise
+  = {-#SCC "simplRecOrTopPair-normal" #-}
+    trace_bind "normal" $
+    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
+
+  where
+    dflags = seDynFlags env
+
+    -- trace_bind emits a trace for each top-level binding, which
+    -- helps to locate the tracing for inlining and rule firing
+    trace_bind what thing_inside
+      | not (dopt Opt_D_verbose_core2core dflags)
+      = thing_inside
+      | otherwise
+      = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside
+
+--------------------------
+simplLazyBind :: SimplEnv
+              -> TopLevelFlag -> RecFlag
+              -> InId -> OutId          -- Binder, both pre-and post simpl
+                                        -- Not a JoinId
+                                        -- The OutId has IdInfo, except arity, unfolding
+                                        -- Ids only, no TyVars
+              -> InExpr -> SimplEnv     -- The RHS and its environment
+              -> SimplM (SimplFloats, SimplEnv)
+-- Precondition: not a JoinId
+-- Precondition: rhs obeys the let/app invariant
+-- NOT used for JoinIds
+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+  = ASSERT( isId bndr )
+    ASSERT2( not (isJoinId bndr), ppr bndr )
+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+    do  { let   rhs_env     = rhs_se `setInScopeFromE` env
+                (tvs, body) = case collectTyAndValBinders rhs of
+                                (tvs, [], body)
+                                  | surely_not_lam body -> (tvs, body)
+                                _                       -> ([], rhs)
+
+                surely_not_lam (Lam {})     = False
+                surely_not_lam (Tick t e)
+                  | not (tickishFloatable t) = surely_not_lam e
+                   -- eta-reduction could float
+                surely_not_lam _            = True
+                        -- Do not do the "abstract tyvar" thing if there's
+                        -- a lambda inside, because it defeats eta-reduction
+                        --    f = /\a. \x. g a x
+                        -- should eta-reduce.
+
+
+        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs
+                -- See Note [Floating and type abstraction] in SimplUtils
+
+        -- Simplify the RHS
+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont
+
+              -- Never float join-floats out of a non-join let-binding
+              -- So wrap the body in the join-floats right now
+              -- Hence: body_floats1 consists only of let-floats
+        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0
+
+        -- ANF-ise a constructor or PAP rhs
+        -- We get at most one float per argument here
+        ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl
+                                            (getOccFS bndr1) (idInfo bndr1) body1
+        ; let body_floats2 = body_floats1 `addLetFloats` let_floats
+
+        ; (rhs_floats, rhs')
+            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)
+                then                    -- No floating, revert to body1
+                     {-#SCC "simplLazyBind-no-floating" #-}
+                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont
+                        ; return (emptyFloats env, rhs') }
+
+                else if null tvs then   -- Simple floating
+                     {-#SCC "simplLazyBind-simple-floating" #-}
+                     do { tick LetFloatFromLet
+                        ; return (body_floats2, body2) }
+
+                else                    -- Do type-abstraction first
+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}
+                     do { tick LetFloatFromLet
+                        ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl
+                                                                tvs' body_floats2 body2
+                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds
+                        ; rhs' <- mkLam env tvs' body3 rhs_cont
+                        ; return (floats, rhs') }
+
+        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
+                                             top_lvl Nothing bndr bndr1 rhs'
+        ; return (rhs_floats `addFloats` bind_float, env2) }
+
+--------------------------
+simplJoinBind :: SimplEnv
+              -> SimplCont
+              -> InId -> OutId          -- Binder, both pre-and post simpl
+                                        -- The OutId has IdInfo, except arity,
+                                        --   unfolding
+              -> InExpr -> SimplEnv     -- The right hand side and its env
+              -> SimplM (SimplFloats, SimplEnv)
+simplJoinBind env cont old_bndr new_bndr rhs rhs_se
+  = do  { let rhs_env = rhs_se `setInScopeFromE` env
+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont
+        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }
+
+--------------------------
+simplNonRecX :: SimplEnv
+             -> InId            -- Old binder; not a JoinId
+             -> OutExpr         -- Simplified RHS
+             -> SimplM (SimplFloats, SimplEnv)
+-- A specialised variant of simplNonRec used when the RHS is already
+-- simplified, notably in knownCon.  It uses case-binding where necessary.
+--
+-- Precondition: rhs satisfies the let/app invariant
+
+simplNonRecX env bndr new_rhs
+  | ASSERT2( not (isJoinId bndr), ppr bndr )
+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid
+                                         --  creating the binding c = (a,b)
+
+  | Coercion co <- new_rhs
+  = return (emptyFloats env, extendCvSubst env bndr co)
+
+  | otherwise
+  = do  { (env', bndr') <- simplBinder env bndr
+        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
+                -- simplNonRecX is only used for NotTopLevel things
+
+--------------------------
+completeNonRecX :: TopLevelFlag -> SimplEnv
+                -> Bool
+                -> InId                 -- Old binder; not a JoinId
+                -> OutId                -- New binder
+                -> OutExpr              -- Simplified RHS
+                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats
+-- Precondition: rhs satisfies the let/app invariant
+--               See Note [CoreSyn let/app invariant] in CoreSyn
+
+completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
+  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )
+    do  { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr)
+                                             (idInfo new_bndr) new_rhs
+        ; let floats = emptyFloats env `addLetFloats` prepd_floats
+        ; (rhs_floats, rhs2) <-
+                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1
+                then    -- Add the floats to the main env
+                     do { tick LetFloatFromLet
+                        ; return (floats, rhs1) }
+                else    -- Do not float; wrap the floats around the RHS
+                     return (emptyFloats env, wrapFloats floats rhs1)
+
+        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
+                                             NotTopLevel Nothing
+                                             old_bndr new_bndr rhs2
+        ; return (rhs_floats `addFloats` bind_float, env2) }
+
+
+{- *********************************************************************
+*                                                                      *
+           prepareRhs, makeTrivial
+*                                                                      *
+************************************************************************
+
+Note [prepareRhs]
+~~~~~~~~~~~~~~~~~
+prepareRhs takes a putative RHS, checks whether it's a PAP or
+constructor application and, if so, converts it to ANF, so that the
+resulting thing can be inlined more easily.  Thus
+        x = (f a, g b)
+becomes
+        t1 = f a
+        t2 = g b
+        x = (t1,t2)
+
+We also want to deal well cases like this
+        v = (f e1 `cast` co) e2
+Here we want to make e1,e2 trivial and get
+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
+That's what the 'go' loop in prepareRhs does
+-}
+
+prepareRhs :: SimplMode -> TopLevelFlag
+           -> FastString   -- Base for any new variables
+           -> IdInfo       -- IdInfo for the LHS of this binding
+           -> OutExpr
+           -> SimplM (LetFloats, OutExpr)
+-- Transforms a RHS into a better RHS by adding floats
+-- e.g        x = Just e
+-- becomes    a = e
+--            x = Just a
+-- See Note [prepareRhs]
+prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]
+  | Pair ty1 _ty2 <- coercionKind co         -- Do *not* do this if rhs has an unlifted type
+  , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]
+  = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs
+        ; return (floats, Cast rhs' co) }
+  where
+    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
+                                   `setDemandInfo`     demandInfo info
+
+prepareRhs mode top_lvl occ _ rhs0
+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0
+        ; return (floats, rhs1) }
+  where
+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
+    go n_val_args (Cast rhs co)
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; return (is_exp, floats, Cast rhs' co) }
+    go n_val_args (App fun (Type ty))
+        = do { (is_exp, floats, rhs') <- go n_val_args fun
+             ; return (is_exp, floats, App rhs' (Type ty)) }
+    go n_val_args (App fun arg)
+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
+             ; case is_exp of
+                False -> return (False, emptyLetFloats, App fun arg)
+                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg
+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }
+    go n_val_args (Var fun)
+        = return (is_exp, emptyLetFloats, Var fun)
+        where
+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
+                        -- See Note [CONLIKE pragma] in BasicTypes
+                        -- The definition of is_exp should match that in
+                        -- OccurAnal.occAnalApp
+
+    go n_val_args (Tick t rhs)
+        -- We want to be able to float bindings past this
+        -- tick. Non-scoping ticks don't care.
+        | tickishScoped t == NoScope
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; return (is_exp, floats, Tick t rhs') }
+
+        -- On the other hand, for scoping ticks we need to be able to
+        -- copy them on the floats, which in turn is only allowed if
+        -- we can obtain non-counting ticks.
+        | (not (tickishCounts t) || tickishCanSplit t)
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
+                   floats' = mapLetFloats floats tickIt
+             ; return (is_exp, floats', Tick t rhs') }
+
+    go _ other
+        = return (False, emptyLetFloats, other)
+
+{-
+Note [Float coercions]
+~~~~~~~~~~~~~~~~~~~~~~
+When we find the binding
+        x = e `cast` co
+we'd like to transform it to
+        x' = e
+        x = x `cast` co         -- A trivial binding
+There's a chance that e will be a constructor application or function, or something
+like that, so moving the coercion to the usage site may well cancel the coercions
+and lead to further optimisation.  Example:
+
+     data family T a :: *
+     data instance T Int = T Int
+
+     foo :: Int -> Int -> Int
+     foo m n = ...
+        where
+          x = T m
+          go 0 = 0
+          go n = case x of { T m -> go (n-m) }
+                -- This case should optimise
+
+Note [Preserve strictness when floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the Note [Float coercions] transformation, keep the strictness info.
+Eg
+        f = e `cast` co    -- f has strictness SSL
+When we transform to
+        f' = e             -- f' also has strictness SSL
+        f = f' `cast` co   -- f still has strictness SSL
+
+Its not wrong to drop it on the floor, but better to keep it.
+
+Note [Float coercions (unlifted)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+BUT don't do [Float coercions] if 'e' has an unlifted type.
+This *can* happen:
+
+     foo :: Int = (error (# Int,Int #) "urk")
+                  `cast` CoUnsafe (# Int,Int #) Int
+
+If do the makeTrivial thing to the error call, we'll get
+    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
+But 'v' isn't in scope!
+
+These strange casts can happen as a result of case-of-case
+        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
+                (# p,q #) -> p+q
+-}
+
+makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)
+makeTrivialArg mode (ValArg e)
+  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e
+       ; return (floats, ValArg e') }
+makeTrivialArg _ arg
+  = return (emptyLetFloats, arg)  -- CastBy, TyArg
+
+makeTrivial :: SimplMode -> TopLevelFlag
+            -> FastString  -- ^ A "friendly name" to build the new binder from
+            -> OutExpr     -- ^ This expression satisfies the let/app invariant
+            -> SimplM (LetFloats, OutExpr)
+-- Binds the expression to a variable, if it's not trivial, returning the variable
+makeTrivial mode top_lvl context expr
+ = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr
+
+makeTrivialWithInfo :: SimplMode -> TopLevelFlag
+                    -> FastString  -- ^ a "friendly name" to build the new binder from
+                    -> IdInfo
+                    -> OutExpr     -- ^ This expression satisfies the let/app invariant
+                    -> SimplM (LetFloats, OutExpr)
+-- Propagate strictness and demand info to the new binder
+-- Note [Preserve strictness when floating coercions]
+-- Returned SimplEnv has same substitution as incoming one
+makeTrivialWithInfo mode top_lvl occ_fs info expr
+  | exprIsTrivial expr                          -- Already trivial
+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
+                                                --   See Note [Cannot trivialise]
+  = return (emptyLetFloats, expr)
+
+  | otherwise
+  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr
+        ; if   exprIsTrivial expr1  -- See Note [Trivial after prepareRhs]
+          then return (floats, expr1)
+          else do
+        { uniq <- getUniqueM
+        ; let name = mkSystemVarName uniq occ_fs
+              var  = mkLocalIdOrCoVarWithInfo name expr_ty info
+
+        -- Now something very like completeBind,
+        -- but without the postInlineUnconditinoally part
+        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1
+        ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2
+
+        ; let final_id = addLetBndrInfo var arity is_bot unf
+              bind     = NonRec final_id expr2
+
+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }}
+   where
+     expr_ty = exprType expr
+
+bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
+-- True iff we can have a binding of this expression at this level
+-- Precondition: the type is the type of the expression
+bindingOk top_lvl expr expr_ty
+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty
+  | otherwise          = True
+
+{- Note [Trivial after prepareRhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we call makeTrival on (e |> co), the recursive use of prepareRhs
+may leave us with
+   { a1 = e }  and   (a1 |> co)
+Now the latter is trivial, so we don't want to let-bind it.
+
+Note [Cannot trivialise]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   f :: Int -> Addr#
+
+   foo :: Bar
+   foo = Bar (f 3)
+
+Then we can't ANF-ise foo, even though we'd like to, because
+we can't make a top-level binding for the Addr# (f 3). And if
+so we don't want to turn it into
+   foo = let x = f 3 in Bar x
+because we'll just end up inlining x back, and that makes the
+simplifier loop.  Better not to ANF-ise it at all.
+
+Literal strings are an exception.
+
+   foo = Ptr "blob"#
+
+We want to turn this into:
+
+   foo1 = "blob"#
+   foo = Ptr foo1
+
+See Note [CoreSyn top-level string literals] in CoreSyn.
+
+************************************************************************
+*                                                                      *
+          Completing a lazy binding
+*                                                                      *
+************************************************************************
+
+completeBind
+  * deals only with Ids, not TyVars
+  * takes an already-simplified binder and RHS
+  * is used for both recursive and non-recursive bindings
+  * is used for both top-level and non-top-level bindings
+
+It does the following:
+  - tries discarding a dead binding
+  - tries PostInlineUnconditionally
+  - add unfolding [this is the only place we add an unfolding]
+  - add arity
+
+It does *not* attempt to do let-to-case.  Why?  Because it is used for
+  - top-level bindings (when let-to-case is impossible)
+  - many situations where the "rhs" is known to be a WHNF
+                (so let-to-case is inappropriate).
+
+Nor does it do the atomic-argument thing
+-}
+
+completeBind :: SimplEnv
+             -> TopLevelFlag            -- Flag stuck into unfolding
+             -> MaybeJoinCont           -- Required only for join point
+             -> InId                    -- Old binder
+             -> OutId -> OutExpr        -- New binder and RHS
+             -> SimplM (SimplFloats, SimplEnv)
+-- completeBind may choose to do its work
+--      * by extending the substitution (e.g. let x = y in ...)
+--      * or by adding to the floats in the envt
+--
+-- Binder /can/ be a JoinId
+-- Precondition: rhs obeys the let/app invariant
+completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
+ | isCoVar old_bndr
+ = case new_rhs of
+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)
+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))
+
+ | otherwise
+ = ASSERT( isId new_bndr )
+   do { let old_info = idInfo old_bndr
+            old_unf  = unfoldingInfo old_info
+            occ_info = occInfo old_info
+
+         -- Do eta-expansion on the RHS of the binding
+         -- See Note [Eta-expanding at let bindings] in SimplUtils
+      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)
+                                                          new_bndr new_rhs
+
+        -- Simplify the unfolding
+      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr
+                                           final_rhs (idType new_bndr) old_unf
+
+      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding
+
+      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs
+
+        then -- Inline and discard the binding
+             do  { tick (PostInlineUnconditionally old_bndr)
+                 ; return ( emptyFloats env
+                          , extendIdSubst env old_bndr $
+                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }
+                -- Use the substitution to make quite, quite sure that the
+                -- substitution will happen, since we are going to discard the binding
+
+        else -- Keep the binding
+             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
+             return (mkFloatBind env (NonRec final_bndr final_rhs)) }
+
+addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId
+addLetBndrInfo new_bndr new_arity is_bot new_unf
+  = new_bndr `setIdInfo` info5
+  where
+    info1 = idInfo new_bndr `setArityInfo` new_arity
+
+    -- Unfolding info: Note [Setting the new unfolding]
+    info2 = info1 `setUnfoldingInfo` new_unf
+
+    -- Demand info: Note [Setting the demand info]
+    -- We also have to nuke demand info if for some reason
+    -- eta-expansion *reduces* the arity of the binding to less
+    -- than that of the strictness sig. This can happen: see Note [Arity decrease].
+    info3 | isEvaldUnfolding new_unf
+            || (case strictnessInfo info2 of
+                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
+          = zapDemandInfo info2 `orElse` info2
+          | otherwise
+          = info2
+
+    -- Bottoming bindings: see Note [Bottoming bindings]
+    info4 | is_bot    = info3 `setStrictnessInfo`
+                        mkClosedStrictSig (replicate new_arity topDmd) botRes
+          | otherwise = info3
+
+     -- Zap call arity info. We have used it by now (via
+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this
+     -- information, leading to broken code later (e.g. #13479)
+    info5 = zapCallArityInfo info4
+
+
+{- Note [Arity decrease]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking the arity of a binding should not decrease.  But it *can*
+legitimately happen because of RULES.  Eg
+        f = g Int
+where g has arity 2, will have arity 2.  But if there's a rewrite rule
+        g Int --> h
+where h has arity 1, then f's arity will decrease.  Here's a real-life example,
+which is in the output of Specialise:
+
+     Rec {
+        $dm {Arity 2} = \d.\x. op d
+        {-# RULES forall d. $dm Int d = $s$dm #-}
+
+        dInt = MkD .... opInt ...
+        opInt {Arity 1} = $dm dInt
+
+        $s$dm {Arity 0} = \x. op dInt }
+
+Here opInt has arity 1; but when we apply the rule its arity drops to 0.
+That's why Specialise goes to a little trouble to pin the right arity
+on specialised functions too.
+
+Note [Bottoming bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   let x = error "urk"
+   in ...(case x of <alts>)...
+or
+   let f = \x. error (x ++ "urk")
+   in ...(case f "foo" of <alts>)...
+
+Then we'd like to drop the dead <alts> immediately.  So it's good to
+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as
+possible.
+
+We use tryEtaExpandRhs on every binding, and it turns ou that the
+arity computation it performs (via CoreArity.findRhsArity) already
+does a simple bottoming-expression analysis.  So all we need to do
+is propagate that info to the binder's IdInfo.
+
+This showed up in #12150; see comment:16.
+
+Note [Setting the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the unfolding is a value, the demand info may
+go pear-shaped, so we nuke it.  Example:
+     let x = (a,b) in
+     case x of (p,q) -> h p q x
+Here x is certainly demanded. But after we've nuked
+the case, we'll get just
+     let x = (a,b) in h a b x
+and now x is not demanded (I'm assuming h is lazy)
+This really happens.  Similarly
+     let f = \x -> e in ...f..f...
+After inlining f at some of its call sites the original binding may
+(for example) be no longer strictly demanded.
+The solution here is a bit ad hoc...
+
+
+************************************************************************
+*                                                                      *
+\subsection[Simplify-simplExpr]{The main function: simplExpr}
+*                                                                      *
+************************************************************************
+
+The reason for this OutExprStuff stuff is that we want to float *after*
+simplifying a RHS, not before.  If we do so naively we get quadratic
+behaviour as things float out.
+
+To see why it's important to do it after, consider this (real) example:
+
+        let t = f x
+        in fst t
+==>
+        let t = let a = e1
+                    b = e2
+                in (a,b)
+        in fst t
+==>
+        let a = e1
+            b = e2
+            t = (a,b)
+        in
+        a       -- Can't inline a this round, cos it appears twice
+==>
+        e1
+
+Each of the ==> steps is a round of simplification.  We'd save a
+whole round if we float first.  This can cascade.  Consider
+
+        let f = g d
+        in \x -> ...f...
+==>
+        let f = let d1 = ..d.. in \y -> e
+        in \x -> ...f...
+==>
+        let d1 = ..d..
+        in \x -> ...(\y ->e)...
+
+Only in this second round can the \y be applied, and it
+might do the same again.
+-}
+
+simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+simplExpr env (Type ty)
+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]
+       ; return (Type ty') }
+
+simplExpr env expr
+  = simplExprC env expr (mkBoringStop expr_out_ty)
+  where
+    expr_out_ty :: OutType
+    expr_out_ty = substTy env (exprType expr)
+    -- NB: Since 'expr' is term-valued, not (Type ty), this call
+    --     to exprType will succeed.  exprType fails on (Type ty).
+
+simplExprC :: SimplEnv
+           -> InExpr     -- A term-valued expression, never (Type ty)
+           -> SimplCont
+           -> SimplM OutExpr
+        -- Simplify an expression, given a continuation
+simplExprC env expr cont
+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $
+    do  { (floats, expr') <- simplExprF env expr cont
+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $
+          return (wrapFloats floats expr') }
+
+--------------------------------------------------
+simplExprF :: SimplEnv
+           -> InExpr     -- A term-valued expression, never (Type ty)
+           -> SimplCont
+           -> SimplM (SimplFloats, OutExpr)
+
+simplExprF env e cont
+  = {- pprTrace "simplExprF" (vcat
+      [ ppr e
+      , text "cont =" <+> ppr cont
+      , text "inscope =" <+> ppr (seInScope env)
+      , text "tvsubst =" <+> ppr (seTvSubst env)
+      , text "idsubst =" <+> ppr (seIdSubst env)
+      , text "cvsubst =" <+> ppr (seCvSubst env)
+      ]) $ -}
+    simplExprF1 env e cont
+
+simplExprF1 :: SimplEnv -> InExpr -> SimplCont
+            -> SimplM (SimplFloats, OutExpr)
+
+simplExprF1 _ (Type ty) _
+  = pprPanic "simplExprF: type" (ppr ty)
+    -- simplExprF does only with term-valued expressions
+    -- The (Type ty) case is handled separately by simplExpr
+    -- and by the other callers of simplExprF
+
+simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont
+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont
+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont
+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont
+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont
+
+simplExprF1 env (App fun arg) cont
+  = {-#SCC "simplExprF1-App" #-} case arg of
+      Type ty -> do { -- The argument type will (almost) certainly be used
+                      -- in the output program, so just force it now.
+                      -- See Note [Avoiding space leaks in OutType]
+                      arg' <- simplType env ty
+
+                      -- But use substTy, not simplType, to avoid forcing
+                      -- the hole type; it will likely not be needed.
+                      -- See Note [The hole type in ApplyToTy]
+                    ; let hole' = substTy env (exprType fun)
+
+                    ; simplExprF env fun $
+                      ApplyToTy { sc_arg_ty  = arg'
+                                , sc_hole_ty = hole'
+                                , sc_cont    = cont } }
+      _       -> simplExprF env fun $
+                 ApplyToVal { sc_arg = arg, sc_env = env
+                            , sc_dup = NoDup, sc_cont = cont }
+
+simplExprF1 env expr@(Lam {}) cont
+  = {-#SCC "simplExprF1-Lam" #-}
+    simplLam env zapped_bndrs body cont
+        -- The main issue here is under-saturated lambdas
+        --   (\x1. \x2. e) arg1
+        -- Here x1 might have "occurs-once" occ-info, because occ-info
+        -- is computed assuming that a group of lambdas is applied
+        -- all at once.  If there are too few args, we must zap the
+        -- occ-info, UNLESS the remaining binders are one-shot
+  where
+    (bndrs, body) = collectBinders expr
+    zapped_bndrs | need_to_zap = map zap bndrs
+                 | otherwise   = bndrs
+
+    need_to_zap = any zappable_bndr (drop n_args bndrs)
+    n_args = countArgs cont
+        -- NB: countArgs counts all the args (incl type args)
+        -- and likewise drop counts all binders (incl type lambdas)
+
+    zappable_bndr b = isId b && not (isOneShotBndr b)
+    zap b | isTyVar b = b
+          | otherwise = zapLamIdInfo b
+
+simplExprF1 env (Case scrut bndr _ alts) cont
+  = {-#SCC "simplExprF1-Case" #-}
+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
+                                 , sc_alts = alts
+                                 , sc_env = env, sc_cont = cont })
+
+simplExprF1 env (Let (Rec pairs) body) cont
+  | Just pairs' <- joinPointBindings_maybe pairs
+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont
+
+  | otherwise
+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont
+
+simplExprF1 env (Let (NonRec bndr rhs) body) cont
+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)
+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}
+    ASSERT( isTyVar bndr )
+    do { ty' <- simplType env ty
+       ; simplExprF (extendTvSubst env bndr ty') body cont }
+
+  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont
+
+  | otherwise
+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont
+
+{- Note [Avoiding space leaks in OutType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the simplifier is run for multiple iterations, we need to ensure
+that any thunks in the output of one simplifier iteration are forced
+by the evaluation of the next simplifier iteration. Otherwise we may
+retain multiple copies of the Core program and leak a terrible amount
+of memory (as in #13426).
+
+The simplifier is naturally strict in the entire "Expr part" of the
+input Core program, because any expression may contain binders, which
+we must find in order to extend the SimplEnv accordingly. But types
+do not contain binders and so it is tempting to write things like
+
+    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!
+
+This is Bad because the result includes a thunk (substTy env ty) which
+retains a reference to the whole simplifier environment; and the next
+simplifier iteration will not force this thunk either, because the
+line above is not strict in ty.
+
+So instead our strategy is for the simplifier to fully evaluate
+OutTypes when it emits them into the output Core program, for example
+
+    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good
+                                 ; return (Type ty') }
+
+where the only difference from above is that simplType calls seqType
+on the result of substTy.
+
+However, SimplCont can also contain OutTypes and it's not necessarily
+a good idea to force types on the way in to SimplCont, because they
+may end up not being used and forcing them could be a lot of wasted
+work. T5631 is a good example of this.
+
+- For ApplyToTy's sc_arg_ty, we force the type on the way in because
+  the type will almost certainly appear as a type argument in the
+  output program.
+
+- For the hole types in Stop and ApplyToTy, we force the type when we
+  emit it into the output program, after obtaining it from
+  contResultType. (The hole type in ApplyToTy is only directly used
+  to form the result type in a new Stop continuation.)
+-}
+
+---------------------------------
+-- Simplify a join point, adding the context.
+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:
+--   \x1 .. xn -> e => \x1 .. xn -> E[e]
+-- Note that we need the arity of the join point, since e may be a lambda
+-- (though this is unlikely). See Note [Case-of-case and join points].
+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont
+             -> SimplM OutExpr
+simplJoinRhs env bndr expr cont
+  | Just arity <- isJoinId_maybe bndr
+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr
+        ; (env', join_bndrs') <- simplLamBndrs env join_bndrs
+        ; join_body' <- simplExprC env' join_body cont
+        ; return $ mkLams join_bndrs' join_body' }
+
+  | otherwise
+  = pprPanic "simplJoinRhs" (ppr bndr)
+
+---------------------------------
+simplType :: SimplEnv -> InType -> SimplM OutType
+        -- Kept monadic just so we can do the seqType
+        -- See Note [Avoiding space leaks in OutType]
+simplType env ty
+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
+    seqType new_ty `seq` return new_ty
+  where
+    new_ty = substTy env ty
+
+---------------------------------
+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
+               -> SimplM (SimplFloats, OutExpr)
+simplCoercionF env co cont
+  = do { co' <- simplCoercion env co
+       ; rebuild env (Coercion co') cont }
+
+simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
+simplCoercion env co
+  = do { dflags <- getDynFlags
+       ; let opt_co = optCoercion dflags (getTCvSubst env) co
+       ; seqCo opt_co `seq` return opt_co }
+
+-----------------------------------
+-- | Push a TickIt context outwards past applications and cases, as
+-- long as this is a non-scoping tick, to let case and application
+-- optimisations apply.
+
+simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
+          -> SimplM (SimplFloats, OutExpr)
+simplTick env tickish expr cont
+  -- A scoped tick turns into a continuation, so that we can spot
+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do
+  -- it this way, then it would take two passes of the simplifier to
+  -- reduce ((scc t (\x . e)) e').
+  -- NB, don't do this with counting ticks, because if the expr is
+  -- bottom, then rebuildCall will discard the continuation.
+
+-- XXX: we cannot do this, because the simplifier assumes that
+-- the context can be pushed into a case with a single branch. e.g.
+--    scc<f>  case expensive of p -> e
+-- becomes
+--    case expensive of p -> scc<f> e
+--
+-- So I'm disabling this for now.  It just means we will do more
+-- simplifier iterations that necessary in some cases.
+
+--  | tickishScoped tickish && not (tickishCounts tickish)
+--  = simplExprF env expr (TickIt tickish cont)
+
+  -- For unscoped or soft-scoped ticks, we are allowed to float in new
+  -- cost, so we simply push the continuation inside the tick.  This
+  -- has the effect of moving the tick to the outside of a case or
+  -- application context, allowing the normal case and application
+  -- optimisations to fire.
+  | tickish `tickishScopesLike` SoftScope
+  = do { (floats, expr') <- simplExprF env expr cont
+       ; return (floats, mkTick tickish expr')
+       }
+
+  -- Push tick inside if the context looks like this will allow us to
+  -- do a case-of-case - see Note [case-of-scc-of-case]
+  | Select {} <- cont, Just expr' <- push_tick_inside
+  = simplExprF env expr' cont
+
+  -- We don't want to move the tick, but we might still want to allow
+  -- floats to pass through with appropriate wrapping (or not, see
+  -- wrap_floats below)
+  --- | not (tickishCounts tickish) || tickishCanSplit tickish
+  -- = wrap_floats
+
+  | otherwise
+  = no_floating_past_tick
+
+ where
+
+  -- Try to push tick inside a case, see Note [case-of-scc-of-case].
+  push_tick_inside =
+    case expr0 of
+      Case scrut bndr ty alts
+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)
+      _other -> Nothing
+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
+         movable t      = not (tickishCounts t) ||
+                          t `tickishScopesLike` NoScope ||
+                          tickishCanSplit t
+         tickScrut e    = foldr mkTick e ticks
+         -- Alternatives get annotated with all ticks that scope in some way,
+         -- but we don't want to count entries.
+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)
+         ts_scope         = map mkNoCount $
+                            filter (not . (`tickishScopesLike` NoScope)) ticks
+
+  no_floating_past_tick =
+    do { let (inc,outc) = splitCont cont
+       ; (floats, expr1) <- simplExprF env expr inc
+       ; let expr2    = wrapFloats floats expr1
+             tickish' = simplTickish env tickish
+       ; rebuild env (mkTick tickish' expr2) outc
+       }
+
+-- Alternative version that wraps outgoing floats with the tick.  This
+-- results in ticks being duplicated, as we don't make any attempt to
+-- eliminate the tick if we re-inline the binding (because the tick
+-- semantics allows unrestricted inlining of HNFs), so I'm not doing
+-- this any more.  FloatOut will catch any real opportunities for
+-- floating.
+--
+--  wrap_floats =
+--    do { let (inc,outc) = splitCont cont
+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc
+--       ; let tickish' = simplTickish env tickish
+--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
+--                                   mkTick (mkNoCount tickish') rhs)
+--              -- when wrapping a float with mkTick, we better zap the Id's
+--              -- strictness info and arity, because it might be wrong now.
+--       ; let env'' = addFloats env (mapFloats env' wrap_float)
+--       ; rebuild env'' expr' (TickIt tickish' outc)
+--       }
+
+
+  simplTickish env tickish
+    | Breakpoint n ids <- tickish
+          = Breakpoint n (map (getDoneId . substId env) ids)
+    | otherwise = tickish
+
+  -- Push type application and coercion inside a tick
+  splitCont :: SimplCont -> (SimplCont, SimplCont)
+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)
+    where (inc,outc) = splitCont tail
+  splitCont (CastIt co c) = (CastIt co inc, outc)
+    where (inc,outc) = splitCont c
+  splitCont other = (mkBoringStop (contHoleType other), other)
+
+  getDoneId (DoneId id)  = id
+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
+  getDoneId other = pprPanic "getDoneId" (ppr other)
+
+-- Note [case-of-scc-of-case]
+-- It's pretty important to be able to transform case-of-case when
+-- there's an SCC in the way.  For example, the following comes up
+-- in nofib/real/compress/Encode.hs:
+--
+--        case scctick<code_string.r1>
+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje
+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->
+--             (ww1_s13f, ww2_s13g, ww3_s13h)
+--             }
+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->
+--        tick<code_string.f1>
+--        (ww_s12Y,
+--         ww1_s12Z,
+--         PTTrees.PT
+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)
+--        }
+--
+-- We really want this case-of-case to fire, because then the 3-tuple
+-- will go away (indeed, the CPR optimisation is relying on this
+-- happening).  But the scctick is in the way - we need to push it
+-- inside to expose the case-of-case.  So we perform this
+-- transformation on the inner case:
+--
+--   scctick c (case e of { p1 -> e1; ...; pn -> en })
+--    ==>
+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }
+--
+-- So we've moved a constant amount of work out of the scc to expose
+-- the case.  We only do this when the continuation is interesting: in
+-- for now, it has to be another Case (maybe generalise this later).
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The main rebuilder}
+*                                                                      *
+************************************************************************
+-}
+
+rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+-- At this point the substitution in the SimplEnv should be irrelevant;
+-- only the in-scope set matters
+rebuild env expr cont
+  = case cont of
+      Stop {}          -> return (emptyFloats env, expr)
+      TickIt t cont    -> rebuild env (mkTick t expr) cont
+      CastIt co cont   -> rebuild env (mkCast expr co) cont
+                       -- NB: mkCast implements the (Coercion co |> g) optimisation
+
+      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
+
+      StrictArg { sc_fun = fun, sc_cont = cont }
+        -> rebuildCall env (fun `addValArgTo` expr) cont
+      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
+                 , sc_env = se, sc_cont = cont }
+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
+                                  -- expr satisfies let/app since it started life
+                                  -- in a call to simplNonRecE
+              ; (floats2, expr') <- simplLam env' bs body cont
+              ; return (floats1 `addFloats` floats2, expr') }
+
+      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}
+        -> rebuild env (App expr (Type ty)) cont
+
+      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}
+        -- See Note [Avoid redundant simplification]
+        -> do { (_, _, arg') <- simplArg env dup_flag se arg
+              ; rebuild env (App expr arg') cont }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Lambdas}
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Optimising reflexivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important (for compiler performance) to get rid of reflexivity as soon
+as it appears.  See #11735, #14737, and #15019.
+
+In particular, we want to behave well on
+
+ *  e |> co1 |> co2
+    where the two happen to cancel out entirely. That is quite common;
+    e.g. a newtype wrapping and unwrapping cancel.
+
+
+ * (f |> co) @t1 @t2 ... @tn x1 .. xm
+   Here we wil use pushCoTyArg and pushCoValArg successively, which
+   build up NthCo stacks.  Silly to do that if co is reflexive.
+
+However, we don't want to call isReflexiveCo too much, because it uses
+type equality which is expensive on big types (#14737 comment:7).
+
+A good compromise (determined experimentally) seems to be to call
+isReflexiveCo
+ * when composing casts, and
+ * at the end
+
+In investigating this I saw missed opportunities for on-the-fly
+coercion shrinkage. See #15090.
+-}
+
+
+simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
+          -> SimplM (SimplFloats, OutExpr)
+simplCast env body co0 cont0
+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}
+                   if isReflCo co1
+                   then return cont0  -- See Note [Optimising reflexivity]
+                   else addCoerce co1 cont0
+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
+  where
+        -- If the first parameter is MRefl, then simplifying revealed a
+        -- reflexive coercion. Omit.
+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont
+        addCoerceM MRefl   cont = return cont
+        addCoerceM (MCo co) cont = addCoerce co cont
+
+        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]
+          | isReflexiveCo co' = return cont
+          | otherwise         = addCoerce co' cont
+          where
+            co' = mkTransCo co1 co2
+
+        addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+          = {-#SCC "addCoerce-pushCoTyArg" #-}
+            do { tail' <- addCoerceM m_co' tail
+               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+
+        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
+                                      , sc_dup = dup, sc_cont = tail })
+          | Just (co1, m_co2) <- pushCoValArg co
+          , Pair _ new_ty <- coercionKind co1
+          , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg
+                                        -- See Note [Levity polymorphism invariants] in CoreSyn
+                                        -- test: typecheck/should_run/EtaExpandLevPoly
+          = {-#SCC "addCoerce-pushCoValArg" #-}
+            do { tail' <- addCoerceM m_co2 tail
+               ; if isReflCo co1
+                 then return (cont { sc_cont = tail' })
+                      -- Avoid simplifying if possible;
+                      -- See Note [Avoiding exponential behaviour]
+                 else do
+               { (dup', arg_se', arg') <- simplArg env dup arg_se arg
+                    -- When we build the ApplyTo we can't mix the OutCoercion
+                    -- 'co' with the InExpr 'arg', so we simplify
+                    -- to make it all consistent.  It's a bit messy.
+                    -- But it isn't a common case.
+                    -- Example of use: #995
+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1
+                                    , sc_env  = arg_se'
+                                    , sc_dup  = dup'
+                                    , sc_cont = tail' }) } }
+
+        addCoerce co cont
+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge
+                                            -- difference in T12227, for some reason
+                                            -- See Note [Optimising reflexivity]
+          | otherwise        = return (CastIt co cont)
+
+simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
+         -> SimplM (DupFlag, StaticEnv, OutExpr)
+simplArg env dup_flag arg_env arg
+  | isSimplified dup_flag
+  = return (dup_flag, arg_env, arg)
+  | otherwise
+  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg
+       ; return (Simplified, zapSubstEnv arg_env, arg') }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Lambdas}
+*                                                                      *
+************************************************************************
+-}
+
+simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
+         -> SimplM (SimplFloats, OutExpr)
+
+simplLam env [] body cont
+  = simplExprF env body cont
+
+simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
+  = do { tick (BetaReduction bndr)
+       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }
+
+simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
+                                           , sc_cont = cont, sc_dup = dup })
+  | isSimplified dup  -- Don't re-simplify if we've simplified it once
+                      -- See Note [Avoiding exponential behaviour]
+  = do  { tick (BetaReduction bndr)
+        ; (floats1, env') <- simplNonRecX env zapped_bndr arg
+        ; (floats2, expr') <- simplLam env' bndrs body cont
+        ; return (floats1 `addFloats` floats2, expr') }
+
+  | otherwise
+  = do  { tick (BetaReduction bndr)
+        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }
+  where
+    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]
+      | isId bndr = zapStableUnfolding bndr
+      | otherwise = bndr
+
+      -- Discard a non-counting tick on a lambda.  This may change the
+      -- cost attribution slightly (moving the allocation of the
+      -- lambda elsewhere), but we don't care: optimisation changes
+      -- cost attribution all the time.
+simplLam env bndrs body (TickIt tickish cont)
+  | not (tickishCounts tickish)
+  = simplLam env bndrs body cont
+
+        -- Not enough args, so there are real lambdas left to put in the result
+simplLam env bndrs body cont
+  = do  { (env', bndrs') <- simplLamBndrs env bndrs
+        ; body' <- simplExpr env' body
+        ; new_lam <- mkLam env bndrs' body' cont
+        ; rebuild env' new_lam cont }
+
+-------------
+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- Used for lambda binders.  These sometimes have unfoldings added by
+-- the worker/wrapper pass that must be preserved, because they can't
+-- be reconstructed from context.  For example:
+--      f x = case x of (a,b) -> fw a b x
+--      fw a b x{=(a,b)} = ...
+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
+simplLamBndr env bndr
+  | isId bndr && isFragileUnfolding old_unf   -- Special case
+  = do { (env1, bndr1) <- simplBinder env bndr
+       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr
+                                               old_unf (idType bndr1)
+       ; let bndr2 = bndr1 `setIdUnfolding` unf'
+       ; return (modifyInScope env1 bndr2, bndr2) }
+
+  | otherwise
+  = simplBinder env bndr                -- Normal case
+  where
+    old_unf = idUnfolding bndr
+
+simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
+
+------------------
+simplNonRecE :: SimplEnv
+             -> InId                    -- The binder, always an Id
+                                        -- Never a join point
+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
+             -> ([InBndr], InExpr)      -- Body of the let/lambda
+                                        --      \xs.e
+             -> SimplCont
+             -> SimplM (SimplFloats, OutExpr)
+
+-- simplNonRecE is used for
+--  * non-top-level non-recursive non-join-point lets in expressions
+--  * beta reduction
+--
+-- simplNonRec env b (rhs, rhs_se) (bs, body) k
+--   = let env in
+--     cont< let b = rhs_se(rhs) in \bs.body >
+--
+-- It deals with strict bindings, via the StrictBind continuation,
+-- which may abort the whole process
+--
+-- Precondition: rhs satisfies the let/app invariant
+--               Note [CoreSyn let/app invariant] in CoreSyn
+--
+-- The "body" of the binding comes as a pair of ([InId],InExpr)
+-- representing a lambda; so we recurse back to simplLam
+-- Why?  Because of the binder-occ-info-zapping done before
+--       the call to simplLam in simplExprF (Lam ...)
+
+simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
+  | ASSERT( isId bndr && not (isJoinId bndr) ) True
+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
+  = do { tick (PreInlineUnconditionally bndr)
+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+         simplLam env' bndrs body cont }
+
+  -- Deal with strict bindings
+  | isStrictId bndr          -- Includes coercions
+  , sm_case_case (getMode env)
+  = simplExprF (rhs_se `setInScopeFromE` env) rhs
+               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+  -- Deal with lazy bindings
+  | otherwise
+  = ASSERT( not (isTyVar bndr) )
+    do { (env1, bndr1) <- simplNonRecBndr env bndr
+       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing
+       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+       ; (floats2, expr') <- simplLam env3 bndrs body cont
+       ; return (floats1 `addFloats` floats2, expr') }
+
+------------------
+simplRecE :: SimplEnv
+          -> [(InId, InExpr)]
+          -> InExpr
+          -> SimplCont
+          -> SimplM (SimplFloats, OutExpr)
+
+-- simplRecE is used for
+--  * non-top-level recursive lets in expressions
+simplRecE env pairs body cont
+  = do  { let bndrs = map fst pairs
+        ; MASSERT(all (not . isJoinId) bndrs)
+        ; env1 <- simplRecBndrs env bndrs
+                -- NB: bndrs' don't have unfoldings or rules
+                -- We add them as we go down
+        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs
+        ; (floats2, expr') <- simplExprF env2 body cont
+        ; return (floats1 `addFloats` floats2, expr') }
+
+{- Note [Avoiding exponential behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One way in which we can get exponential behaviour is if we simplify a
+big expression, and the re-simplify it -- and then this happens in a
+deeply-nested way.  So we must be jolly careful about re-simplifying
+an expression.  That is why completeNonRecX does not try
+preInlineUnconditionally.
+
+Example:
+  f BIG, where f has a RULE
+Then
+ * We simplify BIG before trying the rule; but the rule does not fire
+ * We inline f = \x. x True
+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)
+
+However, if BIG has /not/ already been simplified, we'd /like/ to
+simplify BIG True; maybe good things happen.  That is why
+
+* simplLam has
+    - a case for (isSimplified dup), which goes via simplNonRecX, and
+    - a case for the un-simplified case, which goes via simplNonRecE
+
+* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,
+  in at least two places
+    - In simplCast/addCoerce, where we check for isReflCo
+    - In rebuildCall we avoid simplifying arguments before we have to
+      (see Note [Trying rewrite rules])
+
+
+Note [Zap unfolding when beta-reducing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound variables can have stable unfoldings, such as
+   $j = \x. \b{Unf=Just x}. e
+See Note [Case binders and join points] below; the unfolding for lets
+us optimise e better.  However when we beta-reduce it we want to
+revert to using the actual value, otherwise we can end up in the
+stupid situation of
+          let x = blah in
+          let b{Unf=Just x} = y
+          in ...b...
+Here it'd be far better to drop the unfolding and use the actual RHS.
+
+************************************************************************
+*                                                                      *
+                     Join points
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Rules and unfolding for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   simplExpr (join j x = rhs                         ) cont
+             (      {- RULE j (p:ps) = blah -}       )
+             (      {- StableUnfolding j = blah -}   )
+             (in blah                                )
+
+Then we will push 'cont' into the rhs of 'j'.  But we should *also* push
+'cont' into the RHS of
+  * Any RULEs for j, e.g. generated by SpecConstr
+  * Any stable unfolding for j, e.g. the result of an INLINE pragma
+
+Simplifying rules and stable-unfoldings happens a bit after
+simplifying the right-hand side, so we remember whether or not it
+is a join point, and what 'cont' is, in a value of type MaybeJoinCont
+
+#13900 wsa caused by forgetting to push 'cont' into the RHS
+of a SpecConstr-generated RULE for a join point.
+-}
+
+type MaybeJoinCont = Maybe SimplCont
+  -- Nothing => Not a join point
+  -- Just k  => This is a join binding with continuation k
+  -- See Note [Rules and unfolding for join points]
+
+simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
+                     -> InExpr -> SimplCont
+                     -> SimplM (SimplFloats, OutExpr)
+simplNonRecJoinPoint env bndr rhs body cont
+  | ASSERT( isJoinId bndr ) True
+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
+  = do { tick (PreInlineUnconditionally bndr)
+       ; simplExprF env' body cont }
+
+   | otherwise
+   = wrapJoinCont env cont $ \ env cont ->
+     do { -- We push join_cont into the join RHS and the body;
+          -- and wrap wrap_cont around the whole thing
+        ; let res_ty = contResultType cont
+        ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr
+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)
+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env
+        ; (floats2, body') <- simplExprF env3 body cont
+        ; return (floats1 `addFloats` floats2, body') }
+
+
+------------------
+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
+                  -> InExpr -> SimplCont
+                  -> SimplM (SimplFloats, OutExpr)
+simplRecJoinPoint env pairs body cont
+  = wrapJoinCont env cont $ \ env cont ->
+    do { let bndrs = map fst pairs
+             res_ty = contResultType cont
+       ; env1 <- simplRecJoinBndrs env res_ty bndrs
+               -- NB: bndrs' don't have unfoldings or rules
+               -- We add them as we go down
+       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs
+       ; (floats2, body') <- simplExprF env2 body cont
+       ; return (floats1 `addFloats` floats2, body') }
+
+--------------------
+wrapJoinCont :: SimplEnv -> SimplCont
+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+             -> SimplM (SimplFloats, OutExpr)
+-- Deal with making the continuation duplicable if necessary,
+-- and with the no-case-of-case situation.
+wrapJoinCont env cont thing_inside
+  | contIsStop cont        -- Common case; no need for fancy footwork
+  = thing_inside env cont
+
+  | not (sm_case_case (getMode env))
+    -- See Note [Join points wih -fno-case-of-case]
+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
+       ; return (floats2 `addFloats` floats3, expr3) }
+
+  | otherwise
+    -- Normal case; see Note [Join points and case-of-case]
+  = do { (floats1, cont')  <- mkDupableCont env cont
+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+       ; return (floats1 `addFloats` floats2, result) }
+
+
+--------------------
+trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont
+-- Drop outer context from join point invocation (jump)
+-- See Note [Join points and case-of-case]
+
+trimJoinCont _ Nothing cont
+  = cont -- Not a jump
+trimJoinCont var (Just arity) cont
+  = trim arity cont
+  where
+    trim 0 cont@(Stop {})
+      = cont
+    trim 0 cont
+      = mkBoringStop (contResultType cont)
+    trim n cont@(ApplyToVal { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k }
+    trim n cont@(ApplyToTy { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!
+    trim _ cont
+      = pprPanic "completeCall" $ ppr var $$ ppr cont
+
+
+{- Note [Join points and case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we perform the case-of-case transform (or otherwise push continuations
+inward), we want to treat join points specially. Since they're always
+tail-called and we want to maintain this invariant, we can do this (for any
+evaluation context E):
+
+  E[join j = e
+    in case ... of
+         A -> jump j 1
+         B -> jump j 2
+         C -> f 3]
+
+    -->
+
+  join j = E[e]
+  in case ... of
+       A -> jump j 1
+       B -> jump j 2
+       C -> E[f 3]
+
+As is evident from the example, there are two components to this behavior:
+
+  1. When entering the RHS of a join point, copy the context inside.
+  2. When a join point is invoked, discard the outer context.
+
+We need to be very careful here to remain consistent---neither part is
+optional!
+
+We need do make the continuation E duplicable (since we are duplicating it)
+with mkDuableCont.
+
+
+Note [Join points wih -fno-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose case-of-case is switched off, and we are simplifying
+
+    case (join j x = <j-rhs> in
+          case y of
+             A -> j 1
+             B -> j 2
+             C -> e) of <outer-alts>
+
+Usually, we'd push the outer continuation (case . of <outer-alts>) into
+both the RHS and the body of the join point j.  But since we aren't doing
+case-of-case we may then end up with this totally bogus result
+
+    join x = case <j-rhs> of <outer-alts> in
+    case (case y of
+             A -> j 1
+             B -> j 2
+             C -> e) of <outer-alts>
+
+This would be OK in the language of the paper, but not in GHC: j is no longer
+a join point.  We can only do the "push contination into the RHS of the
+join point j" if we also push the contination right down to the /jumps/ to
+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to
+
+    join x = case <j-rhs> of <outer-alts> in
+    case y of
+      A -> j 1
+      B -> j 2
+      C -> case e of <outer-alts>
+
+which is great.
+
+Bottom line: if case-of-case is off, we must stop pushing the continuation
+inwards altogether at any join point.  Instead simplify the (join ... in ...)
+with a Stop continuation, and wrap the original continuation around the
+outside.  Surprisingly tricky!
+
+
+************************************************************************
+*                                                                      *
+                     Variables
+*                                                                      *
+************************************************************************
+-}
+
+simplVar :: SimplEnv -> InVar -> SimplM OutExpr
+-- Look up an InVar in the environment
+simplVar env var
+  | isTyVar var = return (Type (substTyVar env var))
+  | isCoVar var = return (Coercion (substCoVar env var))
+  | otherwise
+  = case substId env var of
+        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
+        DoneId var1          -> return (Var var1)
+        DoneEx e _           -> return e
+
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+simplIdF env var cont
+  = case substId env var of
+      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+                                -- Don't trim; haven't already simplified e,
+                                -- so the cont is not embodied in e
+
+      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)
+
+      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)
+              -- Note [zapSubstEnv]
+              -- The template is already simplified, so don't re-substitute.
+              -- This is VITAL.  Consider
+              --      let x = e in
+              --      let y = \z -> ...x... in
+              --      \ x -> ...y...
+              -- We'll clone the inner \x, adding x->x' in the id_subst
+              -- Then when we inline y, we must *not* replace x by x' in
+              -- the inlined copy!!
+
+---------------------------------------------------------
+--      Dealing with a call site
+
+completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+completeCall env var cont
+  | Just expr <- callSiteInline dflags var active_unf
+                                lone_variable arg_infos interesting_cont
+  -- Inline the variable's RHS
+  = do { checkedTick (UnfoldingDone var)
+       ; dump_inline expr cont
+       ; simplExprF (zapSubstEnv env) expr cont }
+
+  | otherwise
+  -- Don't inline; instead rebuild the call
+  = do { rule_base <- getSimplRules
+       ; let info = mkArgInfo env var (getRules rule_base var)
+                              n_val_args call_cont
+       ; rebuildCall env info cont }
+
+  where
+    dflags = seDynFlags env
+    (lone_variable, arg_infos, call_cont) = contArgs cont
+    n_val_args       = length arg_infos
+    interesting_cont = interestingCallContext env call_cont
+    active_unf       = activeUnfolding (getMode env) var
+
+    dump_inline unfolding cont
+      | not (dopt Opt_D_dump_inlinings dflags) = return ()
+      | not (dopt Opt_D_verbose_core2core dflags)
+      = when (isExternalName (idName var)) $
+            liftIO $ printOutputForUser dflags alwaysQualify $
+                sep [text "Inlining done:", nest 4 (ppr var)]
+      | otherwise
+      = liftIO $ printOutputForUser dflags alwaysQualify $
+           sep [text "Inlining done: " <> ppr var,
+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
+                              text "Cont:  " <+> ppr cont])]
+
+rebuildCall :: SimplEnv
+            -> ArgInfo
+            -> SimplCont
+            -> SimplM (SimplFloats, OutExpr)
+-- We decided not to inline, so
+--    - simplify the arguments
+--    - try rewrite rules
+--    - and rebuild
+
+---------- Bottoming applications --------------
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
+  -- When we run out of strictness args, it means
+  -- that the call is definitely bottom; see SimplUtils.mkArgInfo
+  -- Then we want to discard the entire strict continuation.  E.g.
+  --    * case (error "hello") of { ... }
+  --    * (error "Hello") arg
+  --    * f (error "Hello") where f is strict
+  --    etc
+  -- Then, especially in the first of these cases, we'd like to discard
+  -- the continuation, leaving just the bottoming expression.  But the
+  -- type might not be right, so we may have to add a coerce.
+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
+                                 -- continuation to discard, else we do it
+                                 -- again and again!
+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]
+    return (emptyFloats env, castBottomExpr res cont_ty)
+  where
+    res     = argInfoExpr fun rev_args
+    cont_ty = contResultType cont
+
+---------- Try rewrite RULES --------------
+-- See Note [Trying rewrite rules]
+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+                              , ai_rules = Just (nr_wanted, rules) }) cont
+  | nr_wanted == 0 || no_more_args
+  , let info' = info { ai_rules = Nothing }
+  = -- We've accumulated a simplified call in <fun,rev_args>
+    -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
+    -- See also Note [Rules for recursive functions]
+    do { mb_match <- tryRules env rules fun (reverse rev_args) cont
+       ; case mb_match of
+             Just (env', rhs, cont') -> simplExprF env' rhs cont'
+             Nothing                 -> rebuildCall env info' cont }
+  where
+    no_more_args = case cont of
+                      ApplyToTy  {} -> False
+                      ApplyToVal {} -> False
+                      _             -> True
+
+
+---------- Simplify applications and casts --------------
+rebuildCall env info (CastIt co cont)
+  = rebuildCall env (addCastTo info co) cont
+
+rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
+  = rebuildCall env (addTyArgTo info arg_ty) cont
+
+rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
+                              , ai_strs = str:strs, ai_discs = disc:discs })
+            (ApplyToVal { sc_arg = arg, sc_env = arg_se
+                        , sc_dup = dup_flag, sc_cont = cont })
+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
+  = rebuildCall env (addValArgTo info' arg) cont
+
+  | str         -- Strict argument
+  , sm_case_case (getMode env)
+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
+    simplExprF (arg_se `setInScopeFromE` env) arg
+               (StrictArg { sc_fun = info', sc_cci = cci_strict
+                          , sc_dup = Simplified, sc_cont = cont })
+                -- Note [Shadowing]
+
+  | otherwise                           -- Lazy argument
+        -- DO NOT float anything outside, hence simplExprC
+        -- There is no benefit (unlike in a let-binding), and we'd
+        -- have to be very careful about bogus strictness through
+        -- floating a demanded let.
+  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
+                             (mkLazyArgStop arg_ty cci_lazy)
+        ; rebuildCall env (addValArgTo info' arg') cont }
+  where
+    info'  = info { ai_strs = strs, ai_discs = discs }
+    arg_ty = funArgTy fun_ty
+
+    -- Use this for lazy arguments
+    cci_lazy | encl_rules = RuleArgCtxt
+             | disc > 0   = DiscArgCtxt  -- Be keener here
+             | otherwise  = BoringCtxt   -- Nothing interesting
+
+    -- ..and this for strict arguments
+    cci_strict | encl_rules = RuleArgCtxt
+               | disc > 0   = DiscArgCtxt
+               | otherwise  = RhsCtxt
+      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we
+      -- want to be a bit more eager to inline g, because it may
+      -- expose an eval (on x perhaps) that can be eliminated or
+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
+      -- It's worth an 18% improvement in allocation for this
+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
+
+---------- No further useful info, revert to generic rebuild ------------
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
+  = rebuild env (argInfoExpr fun rev_args) cont
+
+{- Note [Trying rewrite rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet
+simplified.  We want to simplify enough arguments to allow the rules
+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone
+is sufficient.  Example: class ops
+   (+) dNumInt e2 e3
+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the
+latter's strictness when simplifying e2, e3.  Moreover, suppose we have
+  RULE  f Int = \x. x True
+
+Then given (f Int e1) we rewrite to
+   (\x. x True) e1
+without simplifying e1.  Now we can inline x into its unique call site,
+and absorb the True into it all in the same pass.  If we simplified
+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].
+
+So we try to apply rules if either
+  (a) no_more_args: we've run out of argument that the rules can "see"
+  (b) nr_wanted: none of the rules wants any more arguments
+
+
+Note [RULES apply to simplified arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very desirable to try RULES once the arguments have been simplified, because
+doing so ensures that rule cascades work in one pass.  Consider
+   {-# RULES g (h x) = k x
+             f (k x) = x #-}
+   ...f (g (h x))...
+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
+we match f's rules against the un-simplified RHS, it won't match.  This
+makes a particularly big difference when superclass selectors are involved:
+        op ($p1 ($p2 (df d)))
+We want all this to unravel in one sweep.
+
+Note [Avoid redundant simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because RULES apply to simplified arguments, there's a danger of repeatedly
+simplifying already-simplified arguments.  An important example is that of
+        (>>=) d e1 e2
+Here e1, e2 are simplified before the rule is applied, but don't really
+participate in the rule firing. So we mark them as Simplified to avoid
+re-simplifying them.
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+This part of the simplifier may break the no-shadowing invariant
+Consider
+        f (...(\a -> e)...) (case y of (a,b) -> e')
+where f is strict in its second arg
+If we simplify the innermost one first we get (...(\a -> e)...)
+Simplifying the second arg makes us float the case out, so we end up with
+        case y of (a,b) -> f (...(\a -> e)...) e'
+So the output does not have the no-shadowing invariant.  However, there is
+no danger of getting name-capture, because when the first arg was simplified
+we used an in-scope set that at least mentioned all the variables free in its
+static environment, and that is enough.
+
+We can't just do innermost first, or we'd end up with a dual problem:
+        case x of (a,b) -> f e (...(\a -> e')...)
+
+I spent hours trying to recover the no-shadowing invariant, but I just could
+not think of an elegant way to do it.  The simplifier is already knee-deep in
+continuations.  We have to keep the right in-scope set around; AND we have
+to get the effect that finding (error "foo") in a strict arg position will
+discard the entire application and replace it with (error "foo").  Getting
+all this at once is TOO HARD!
+
+
+************************************************************************
+*                                                                      *
+                Rewrite rules
+*                                                                      *
+************************************************************************
+-}
+
+tryRules :: SimplEnv -> [CoreRule]
+         -> Id -> [ArgSpec]
+         -> SimplCont
+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
+
+tryRules env rules fn args call_cont
+  | null rules
+  = return Nothing
+
+{- Disabled until we fix #8326
+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]
+  , [_type_arg, val_arg] <- args
+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
+  , isDeadBinder bndr
+  = do { let enum_to_tag :: CoreAlt -> CoreAlt
+                -- Takes   K -> e  into   tagK# -> e
+                -- where tagK# is the tag of constructor K
+             enum_to_tag (DataAlt con, [], rhs)
+               = ASSERT( isEnumerationTyCon (dataConTyCon con) )
+                (LitAlt tag, [], rhs)
+              where
+                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))
+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
+
+             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
+             new_bndr = setIdType bndr intPrimTy
+                 -- The binder is dead, but should have the right type
+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
+-}
+
+  | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)
+                                        (activeRule (getMode env)) fn
+                                        (argInfoAppArgs args) rules
+  -- Fire a rule for the function
+  = do { checkedTick (RuleFired (ruleName rule))
+       ; let cont' = pushSimplifiedArgs zapped_env
+                                        (drop (ruleArity rule) args)
+                                        call_cont
+                     -- (ruleArity rule) says how
+                     -- many args the rule consumed
+
+             occ_anald_rhs = occurAnalyseExpr rule_rhs
+                 -- See Note [Occurrence-analyse after rule firing]
+       ; dump rule rule_rhs
+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }
+            -- The occ_anald_rhs and cont' are all Out things
+            -- hence zapping the environment
+
+  | otherwise  -- No rule fires
+  = do { nodump  -- This ensures that an empty file is written
+       ; return Nothing }
+
+  where
+    dflags     = seDynFlags env
+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]
+
+    printRuleModule rule
+      = parens (maybe (text "BUILTIN")
+                      (pprModuleName . moduleName)
+                      (ruleModule rule))
+
+    dump rule rule_rhs
+      | dopt Opt_D_dump_rule_rewrites dflags
+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
+          [ text "Rule:" <+> ftext (ruleName rule)
+          , text "Module:" <+>  printRuleModule rule
+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
+          , text "After: " <+> pprCoreExpr rule_rhs
+          , text "Cont:  " <+> ppr call_cont ]
+
+      | dopt Opt_D_dump_rule_firings dflags
+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
+          ftext (ruleName rule)
+            <+> printRuleModule rule
+
+      | otherwise
+      = return ()
+
+    nodump
+      | dopt Opt_D_dump_rule_rewrites dflags
+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty
+
+      | dopt Opt_D_dump_rule_firings dflags
+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty
+
+      | otherwise
+      = return ()
+
+    log_rule dflags flag hdr details
+      = liftIO . dumpSDoc dflags alwaysQualify flag "" $
+                   sep [text hdr, nest 4 details]
+
+trySeqRules :: SimplEnv
+            -> OutExpr -> InExpr   -- Scrutinee and RHS
+            -> SimplCont
+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
+-- See Note [User-defined RULES for seq]
+trySeqRules in_env scrut rhs cont
+  = do { rule_base <- getSimplRules
+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }
+  where
+    no_cast_scrut = drop_casts scrut
+    scrut_ty  = exprType no_cast_scrut
+    seq_id_ty = idType seqId
+    rhs_ty    = substTy in_env (exprType rhs)
+    out_args  = [ TyArg { as_arg_ty  = scrut_ty
+                        , as_hole_ty = seq_id_ty }
+                , TyArg { as_arg_ty  = rhs_ty
+                       , as_hole_ty  = piResultTy seq_id_ty scrut_ty }
+                , ValArg no_cast_scrut]
+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
+                           , sc_env = in_env, sc_cont = cont }
+    -- Lazily evaluated, so we don't do most of this
+
+    drop_casts (Cast e _) = drop_casts e
+    drop_casts e          = e
+
+{- Note [User-defined RULES for seq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given
+   case (scrut |> co) of _ -> rhs
+look for rules that match the expression
+   seq @t1 @t2 scrut
+where scrut :: t1
+      rhs   :: t2
+
+If you find a match, rewrite it, and apply to 'rhs'.
+
+Notice that we can simply drop casts on the fly here, which
+makes it more likely that a rule will match.
+
+See Note [User-defined RULES for seq] in MkId.
+
+Note [Occurrence-analyse after rule firing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+After firing a rule, we occurrence-analyse the instantiated RHS before
+simplifying it.  Usually this doesn't make much difference, but it can
+be huge.  Here's an example (simplCore/should_compile/T7785)
+
+  map f (map f (map f xs)
+
+= -- Use build/fold form of map, twice
+  map f (build (\cn. foldr (mapFB c f) n
+                           (build (\cn. foldr (mapFB c f) n xs))))
+
+= -- Apply fold/build rule
+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))
+
+= -- Beta-reduce
+  -- Alas we have no occurrence-analysed, so we don't know
+  -- that c is used exactly once
+  map f (build (\cn. let c1 = mapFB c f in
+                     foldr (mapFB c1 f) n xs))
+
+= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)
+  -- We can do this because (mapFB c n) is a PAP and hence expandable
+  map f (build (\cn. let c1 = mapFB c n in
+                     foldr (mapFB c (f.f)) n x))
+
+This is not too bad.  But now do the same with the outer map, and
+we get another use of mapFB, and t can interact with /both/ remaining
+mapFB calls in the above expression.  This is stupid because actually
+that 'c1' binding is dead.  The outer map introduces another c2. If
+there is a deep stack of maps we get lots of dead bindings, and lots
+of redundant work as we repeatedly simplify the result of firing rules.
+
+The easy thing to do is simply to occurrence analyse the result of
+the rule firing.  Note that this occ-anals not only the RHS of the
+rule, but also the function arguments, which by now are OutExprs.
+E.g.
+      RULE f (g x) = x+1
+
+Call   f (g BIG)  -->   (\x. x+1) BIG
+
+The rule binders are lambda-bound and applied to the OutExpr arguments
+(here BIG) which lack all internal occurrence info.
+
+Is this inefficient?  Not really: we are about to walk over the result
+of the rule firing to simplify it, so occurrence analysis is at most
+a constant factor.
+
+Possible improvement: occ-anal the rules when putting them in the
+database; and in the simplifier just occ-anal the OutExpr arguments.
+But that's more complicated and the rule RHS is usually tiny; so I'm
+just doing the simple thing.
+
+Historical note: previously we did occ-anal the rules in Rule.hs,
+but failed to occ-anal the OutExpr arguments, which led to the
+nasty performance problem described above.
+
+
+Note [Optimising tagToEnum#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an enumeration data type:
+
+  data Foo = A | B | C
+
+Then we want to transform
+
+   case tagToEnum# x of   ==>    case x of
+     A -> e1                       DEFAULT -> e1
+     B -> e2                       1#      -> e2
+     C -> e3                       2#      -> e3
+
+thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT
+alternative we retain it (remember it comes first).  If not the case must
+be exhaustive, and we reflect that in the transformed version by adding
+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.
+See #8317.
+
+Note [Rules for recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that we shouldn't apply rules for a loop breaker:
+doing so might give rise to an infinite loop, because a RULE is
+rather like an extra equation for the function:
+     RULE:           f (g x) y = x+y
+     Eqn:            f a     y = a-y
+
+But it's too drastic to disable rules for loop breakers.
+Even the foldr/build rule would be disabled, because foldr
+is recursive, and hence a loop breaker:
+     foldr k z (build g) = g k z
+So it's up to the programmer: rules can cause divergence
+
+
+************************************************************************
+*                                                                      *
+                Rebuilding a case expression
+*                                                                      *
+************************************************************************
+
+Note [Case elimination]
+~~~~~~~~~~~~~~~~~~~~~~~
+The case-elimination transformation discards redundant case expressions.
+Start with a simple situation:
+
+        case x# of      ===>   let y# = x# in e
+          y# -> e
+
+(when x#, y# are of primitive type, of course).  We can't (in general)
+do this for algebraic cases, because we might turn bottom into
+non-bottom!
+
+The code in SimplUtils.prepareAlts has the effect of generalise this
+idea to look for a case where we're scrutinising a variable, and we
+know that only the default case can match.  For example:
+
+        case x of
+          0#      -> ...
+          DEFAULT -> ...(case x of
+                         0#      -> ...
+                         DEFAULT -> ...) ...
+
+Here the inner case is first trimmed to have only one alternative, the
+DEFAULT, after which it's an instance of the previous case.  This
+really only shows up in eliminating error-checking code.
+
+Note that SimplUtils.mkCase combines identical RHSs.  So
+
+        case e of       ===> case e of DEFAULT -> r
+           True  -> r
+           False -> r
+
+Now again the case may be elminated by the CaseElim transformation.
+This includes things like (==# a# b#)::Bool so that we simplify
+      case ==# a# b# of { True -> x; False -> x }
+to just
+      x
+This particular example shows up in default methods for
+comparison operations (e.g. in (>=) for Int.Int32)
+
+Note [Case to let transformation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a case over a lifted type has a single alternative, and is being
+used as a strict 'let' (all isDeadBinder bndrs), we may want to do
+this transformation:
+
+    case e of r       ===>   let r = e in ...r...
+      _ -> ...r...
+
+We treat the unlifted and lifted cases separately:
+
+* Unlifted case: 'e' satisfies exprOkForSpeculation
+  (ok-for-spec is needed to satisfy the let/app invariant).
+  This turns     case a +# b of r -> ...r...
+  into           let r = a +# b in ...r...
+  and thence     .....(a +# b)....
+
+  However, if we have
+      case indexArray# a i of r -> ...r...
+  we might like to do the same, and inline the (indexArray# a i).
+  But indexArray# is not okForSpeculation, so we don't build a let
+  in rebuildCase (lest it get floated *out*), so the inlining doesn't
+  happen either.  Annoying.
+
+* Lifted case: we need to be sure that the expression is already
+  evaluated (exprIsHNF).  If it's not already evaluated
+      - we risk losing exceptions, divergence or
+        user-specified thunk-forcing
+      - even if 'e' is guaranteed to converge, we don't want to
+        create a thunk (call by need) instead of evaluating it
+        right away (call by value)
+
+  However, we can turn the case into a /strict/ let if the 'r' is
+  used strictly in the body.  Then we won't lose divergence; and
+  we won't build a thunk because the let is strict.
+  See also Note [Case-to-let for strictly-used binders]
+
+  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.
+  We want to turn
+     case (absentError "foo") of r -> ...MkT r...
+  into
+     let r = absentError "foo" in ...MkT r...
+
+
+Note [Case-to-let for strictly-used binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have this:
+   case <scrut> of r { _ -> ..r.. }
+
+where 'r' is used strictly in (..r..), we can safely transform to
+   let r = <scrut> in ...r...
+
+This is a Good Thing, because 'r' might be dead (if the body just
+calls error), or might be used just once (in which case it can be
+inlined); or we might be able to float the let-binding up or down.
+E.g. #15631 has an example.
+
+Note that this can change the error behaviour.  For example, we might
+transform
+    case x of { _ -> error "bad" }
+    --> error "bad"
+which is might be puzzling if 'x' currently lambda-bound, but later gets
+let-bound to (error "good").
+
+Nevertheless, the paper "A semantics for imprecise exceptions" allows
+this transformation. If you want to fix the evaluation order, use
+'pseq'.  See #8900 for an example where the loss of this
+transformation bit us in practice.
+
+See also Note [Empty case alternatives] in CoreSyn.
+
+Historical notes
+
+There have been various earlier versions of this patch:
+
+* By Sept 18 the code looked like this:
+     || scrut_is_demanded_var scrut
+
+    scrut_is_demanded_var :: CoreExpr -> Bool
+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
+    scrut_is_demanded_var _          = False
+
+  This only fired if the scrutinee was a /variable/, which seems
+  an unnecessary restriction. So in #15631 I relaxed it to allow
+  arbitrary scrutinees.  Less code, less to explain -- but the change
+  had 0.00% effect on nofib.
+
+* Previously, in Jan 13 the code looked like this:
+     || case_bndr_evald_next rhs
+
+    case_bndr_evald_next :: CoreExpr -> Bool
+      -- See Note [Case binder next]
+    case_bndr_evald_next (Var v)         = v == case_bndr
+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e
+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e
+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e
+    case_bndr_evald_next _               = False
+
+  This patch was part of fixing #7542. See also
+  Note [Eta reduction of an eval'd function] in CoreUtils.)
+
+
+Further notes about case elimination
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:       test :: Integer -> IO ()
+                test = print
+
+Turns out that this compiles to:
+    Print.test
+      = \ eta :: Integer
+          eta1 :: Void# ->
+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
+          case hPutStr stdout
+                 (PrelNum.jtos eta ($w[] @ Char))
+                 eta1
+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
+
+Notice the strange '<' which has no effect at all. This is a funny one.
+It started like this:
+
+f x y = if x < 0 then jtos x
+          else if y==0 then "" else jtos x
+
+At a particular call site we have (f v 1).  So we inline to get
+
+        if v < 0 then jtos x
+        else if 1==0 then "" else jtos x
+
+Now simplify the 1==0 conditional:
+
+        if v<0 then jtos v else jtos v
+
+Now common-up the two branches of the case:
+
+        case (v<0) of DEFAULT -> jtos v
+
+Why don't we drop the case?  Because it's strict in v.  It's technically
+wrong to drop even unnecessary evaluations, and in practice they
+may be a result of 'seq' so we *definitely* don't want to drop those.
+I don't really know how to improve this situation.
+
+
+Note [FloatBinds from constructor wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have FloatBinds coming from the constructor wrapper
+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
+ew cannot float past them. We'd need to float the FloatBind
+together with the simplify floats, unfortunately the
+simplifier doesn't have case-floats. The simplest thing we can
+do is to wrap all the floats here. The next iteration of the
+simplifier will take care of all these cases and lets.
+
+Given data T = MkT !Bool, this allows us to simplify
+case $WMkT b of { MkT x -> f x }
+to
+case b of { b' -> f b' }.
+
+We could try and be more clever (like maybe wfloats only contain
+let binders, so we could float them). But the need for the
+extra complication is not clear.
+-}
+
+---------------------------------------------------------
+--      Eliminate the case if possible
+
+rebuildCase, reallyRebuildCase
+   :: SimplEnv
+   -> OutExpr          -- Scrutinee
+   -> InId             -- Case binder
+   -> [InAlt]          -- Alternatives (increasing order)
+   -> SimplCont
+   -> SimplM (SimplFloats, OutExpr)
+
+--------------------------------------------------
+--      1. Eliminate the case if there's a known constructor
+--------------------------------------------------
+
+rebuildCase env scrut case_bndr alts cont
+  | Lit lit <- scrut    -- No need for same treatment as constructors
+                        -- because literals are inlined more vigorously
+  , not (litIsLifted lit)
+  = do  { tick (KnownBranch case_bndr)
+        ; case findAlt (LitAlt lit) alts of
+            Nothing           -> missingAlt env case_bndr alts cont
+            Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs }
+
+  | Just (in_scope', wfloats, con, ty_args, other_args)
+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
+        -- Works when the scrutinee is a variable with a known unfolding
+        -- as well as when it's an explicit constructor application
+  , let env0 = setInScopeSet env in_scope'
+  = do  { tick (KnownBranch case_bndr)
+        ; case findAlt (DataAlt con) alts of
+            Nothing  -> missingAlt env0 case_bndr alts cont
+            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)
+                                                 `mkTyApps` ty_args
+                                                 `mkApps`   other_args
+                                       in simple_rhs env0 wfloats con_app bs rhs
+            Just (_, bs, rhs)       -> knownCon env0 scrut wfloats con ty_args other_args
+                                                case_bndr bs rhs cont
+        }
+  where
+    simple_rhs env wfloats scrut' bs rhs =
+      ASSERT( null bs )
+      do { (floats1, env') <- simplNonRecX env case_bndr scrut'
+             -- scrut is a constructor application,
+             -- hence satisfies let/app invariant
+         ; (floats2, expr') <- simplExprF env' rhs cont
+         ; case wfloats of
+             [] -> return (floats1 `addFloats` floats2, expr')
+             _ -> return
+               -- See Note [FloatBinds from constructor wrappers]
+                   ( emptyFloats env,
+                     MkCore.wrapFloats wfloats $
+                     wrapFloats (floats1 `addFloats` floats2) expr' )}
+
+
+--------------------------------------------------
+--      2. Eliminate the case if scrutinee is evaluated
+--------------------------------------------------
+
+rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
+  -- See if we can get rid of the case altogether
+  -- See Note [Case elimination]
+  -- mkCase made sure that if all the alternatives are equal,
+  -- then there is now only one (DEFAULT) rhs
+
+  -- 2a.  Dropping the case altogether, if
+  --      a) it binds nothing (so it's really just a 'seq')
+  --      b) evaluating the scrutinee has no side effects
+  | is_plain_seq
+  , exprOkForSideEffects scrut
+          -- The entire case is dead, so we can drop it
+          -- if the scrutinee converges without having imperative
+          -- side effects or raising a Haskell exception
+          -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
+   = simplExprF env rhs cont
+
+  -- 2b.  Turn the case into a let, if
+  --      a) it binds only the case-binder
+  --      b) unlifted case: the scrutinee is ok-for-speculation
+  --           lifted case: the scrutinee is in HNF (or will later be demanded)
+  -- See Note [Case to let transformation]
+  | all_dead_bndrs
+  , doCaseToLet scrut case_bndr
+  = do { tick (CaseElim case_bndr)
+       ; (floats1, env') <- simplNonRecX env case_bndr scrut
+       ; (floats2, expr') <- simplExprF env' rhs cont
+       ; return (floats1 `addFloats` floats2, expr') }
+
+  -- 2c. Try the seq rules if
+  --     a) it binds only the case binder
+  --     b) a rule for seq applies
+  -- See Note [User-defined RULES for seq] in MkId
+  | is_plain_seq
+  = do { mb_rule <- trySeqRules env scrut rhs cont
+       ; case mb_rule of
+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'
+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }
+  where
+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
+
+rebuildCase env scrut case_bndr alts cont
+  = reallyRebuildCase env scrut case_bndr alts cont
+
+
+doCaseToLet :: OutExpr          -- Scrutinee
+            -> InId             -- Case binder
+            -> Bool
+-- The situation is         case scrut of b { DEFAULT -> body }
+-- Can we transform thus?   let { b = scrut } in body
+doCaseToLet scrut case_bndr
+  | isTyCoVar case_bndr    -- Respect CoreSyn
+  = isTyCoArg scrut        -- Note [CoreSyn type and coercion invariant]
+
+  | isUnliftedType (idType case_bndr)
+  = exprOkForSpeculation scrut
+
+  | otherwise  -- Scrut has a lifted type
+  = exprIsHNF scrut
+    || isStrictDmd (idDemandInfo case_bndr)
+    -- See Note [Case-to-let for strictly-used binders]
+
+--------------------------------------------------
+--      3. Catch-all case
+--------------------------------------------------
+
+reallyRebuildCase env scrut case_bndr alts cont
+  | not (sm_case_case (getMode env))
+  = do { case_expr <- simplAlts env scrut case_bndr alts
+                                (mkBoringStop (contHoleType cont))
+       ; rebuild env case_expr cont }
+
+  | otherwise
+  = do { (floats, cont') <- mkDupableCaseCont env alts cont
+       ; case_expr <- simplAlts (env `setInScopeFromF` floats)
+                                scrut case_bndr alts cont'
+       ; return (floats, case_expr) }
+
+{-
+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
+
+Historical note: we use to do the "case binder swap" in the Simplifier
+so there were additional complications if the scrutinee was a variable.
+Now the binder-swap stuff is done in the occurrence analyser; see
+OccurAnal Note [Binder swap].
+
+Note [knownCon occ info]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If the case binder is not dead, then neither are the pattern bound
+variables:
+        case <any> of x { (a,b) ->
+        case x of { (p,q) -> p } }
+Here (a,b) both look dead, but come alive after the inner case is eliminated.
+The point is that we bring into the envt a binding
+        let x = (a,b)
+after the outer case, and that makes (a,b) alive.  At least we do unless
+the case binder is guaranteed dead.
+
+Note [Case alternative occ info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are simply reconstructing a case (the common case), we always
+zap the occurrence info on the binders in the alternatives.  Even
+if the case binder is dead, the scrutinee is usually a variable, and *that*
+can bring the case-alternative binders back to life.
+See Note [Add unfolding for scrutinee]
+
+Note [Improving seq]
+~~~~~~~~~~~~~~~~~~~
+Consider
+        type family F :: * -> *
+        type instance F Int = Int
+
+We'd like to transform
+        case e of (x :: F Int) { DEFAULT -> rhs }
+===>
+        case e `cast` co of (x'::Int)
+           I# x# -> let x = x' `cast` sym co
+                    in rhs
+
+so that 'rhs' can take advantage of the form of x'.  Notice that Note
+[Case of cast] (in OccurAnal) may then apply to the result.
+
+We'd also like to eliminate empty types (#13468). So if
+
+    data Void
+    type instance F Bool = Void
+
+then we'd like to transform
+        case (x :: F Bool) of { _ -> error "urk" }
+===>
+        case (x |> co) of (x' :: Void) of {}
+
+Nota Bene: we used to have a built-in rule for 'seq' that dropped
+casts, so that
+    case (x |> co) of { _ -> blah }
+dropped the cast; in order to improve the chances of trySeqRules
+firing.  But that works in the /opposite/ direction to Note [Improving
+seq] so there's a danger of flip/flopping.  Better to make trySeqRules
+insensitive to the cast, which is now is.
+
+The need for [Improving seq] showed up in Roman's experiments.  Example:
+  foo :: F Int -> Int -> Int
+  foo t n = t `seq` bar n
+     where
+       bar 0 = 0
+       bar n = bar (n - case t of TI i -> i)
+Here we'd like to avoid repeated evaluating t inside the loop, by
+taking advantage of the `seq`.
+
+At one point I did transformation in LiberateCase, but it's more
+robust here.  (Otherwise, there's a danger that we'll simply drop the
+'seq' altogether, before LiberateCase gets to see it.)
+-}
+
+simplAlts :: SimplEnv
+          -> OutExpr         -- Scrutinee
+          -> InId            -- Case binder
+          -> [InAlt]         -- Non-empty
+          -> SimplCont
+          -> SimplM OutExpr  -- Returns the complete simplified case expression
+
+simplAlts env0 scrut case_bndr alts cont'
+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr
+                                      , text "cont':" <+> ppr cont'
+                                      , text "in_scope" <+> ppr (seInScope env0) ])
+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr
+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding
+              env2       = modifyInScope env1 case_bndr2
+              -- See Note [Case binder evaluated-ness]
+
+        ; fam_envs <- getFamEnvs
+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut
+                                                       case_bndr case_bndr2 alts
+
+        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
+          -- NB: it's possible that the returned in_alts is empty: this is handled
+          -- by the caller (rebuildCase) in the missingAlt function
+
+        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
+
+        ; let alts_ty' = contResultType cont'
+        -- See Note [Avoiding space leaks in OutType]
+        ; seqType alts_ty' `seq`
+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }
+
+
+------------------------------------
+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
+           -> OutExpr -> InId -> OutId -> [InAlt]
+           -> SimplM (SimplEnv, OutExpr, OutId)
+-- Note [Improving seq]
+improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
+  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
+  = do { case_bndr2 <- newId (fsLit "nt") ty2
+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
+              env2 = extendIdSubst env case_bndr rhs
+        ; return (env2, scrut `Cast` co, case_bndr2) }
+
+improveSeq _ env scrut _ case_bndr1 _
+  = return (env, scrut, case_bndr1)
+
+
+------------------------------------
+simplAlt :: SimplEnv
+         -> Maybe OutExpr  -- The scrutinee
+         -> [AltCon]       -- These constructors can't be present when
+                           -- matching the DEFAULT alternative
+         -> OutId          -- The case binder
+         -> SimplCont
+         -> InAlt
+         -> SimplM OutAlt
+
+simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
+  = ASSERT( null bndrs )
+    do  { let env' = addBinderUnfolding env case_bndr'
+                                        (mkOtherCon imposs_deflt_cons)
+                -- Record the constructors that the case-binder *can't* be.
+        ; rhs' <- simplExprC env' rhs cont'
+        ; return (DEFAULT, [], rhs') }
+
+simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
+  = ASSERT( null bndrs )
+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
+        ; rhs' <- simplExprC env' rhs cont'
+        ; return (LitAlt lit, [], rhs') }
+
+simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]
+          let vs_with_evals = addEvals scrut' con vs
+        ; (env', vs') <- simplLamBndrs env vs_with_evals
+
+                -- Bind the case-binder to (con args)
+        ; let inst_tys' = tyConAppArgs (idType case_bndr')
+              con_app :: OutExpr
+              con_app   = mkConApp2 con inst_tys' vs'
+
+        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
+        ; rhs' <- simplExprC env'' rhs cont'
+        ; return (DataAlt con, vs', rhs') }
+
+{- Note [Adding evaluatedness info to pattern-bound variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+addEvals records the evaluated-ness of the bound variables of
+a case pattern.  This is *important*.  Consider
+
+     data T = T !Int !Int
+
+     case x of { T a b -> T (a+1) b }
+
+We really must record that b is already evaluated so that we don't
+go and re-evaluate it when constructing the result.
+See Note [Data-con worker strictness] in MkId.hs
+
+NB: simplLamBinders preserves this eval info
+
+In addition to handling data constructor fields with !s, addEvals
+also records the fact that the result of seq# is always in WHNF.
+See Note [seq# magic] in PrelRules.  Example (#15226):
+
+  case seq# v s of
+    (# s', v' #) -> E
+
+we want the compiler to be aware that v' is in WHNF in E.
+
+Open problem: we don't record that v itself is in WHNF (and we can't
+do it here).  The right thing is to do some kind of binder-swap;
+see #15226 for discussion.
+-}
+
+addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
+-- See Note [Adding evaluatedness info to pattern-bound variables]
+addEvals scrut con vs
+  -- Deal with seq# applications
+  | Just scr <- scrut
+  , isUnboxedTupleCon con
+  , [s,x] <- vs
+    -- Use stripNArgs rather than collectArgsTicks to avoid building
+    -- a list of arguments only to throw it away immediately.
+  , Just (Var f) <- stripNArgs 4 scr
+  , Just SeqOp <- isPrimOpId_maybe f
+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x
+  = [s, x']
+
+  -- Deal with banged datacon fields
+addEvals _scrut con vs = go vs the_strs
+    where
+      the_strs = dataConRepStrictness con
+
+      go [] [] = []
+      go (v:vs') strs | isTyVar v = v : go vs' strs
+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs
+      go _ _ = pprPanic "Simplify.addEvals"
+                (ppr con $$
+                 ppr vs  $$
+                 ppr_with_length (map strdisp the_strs) $$
+                 ppr_with_length (dataConRepArgTys con) $$
+                 ppr_with_length (dataConRepStrictness con))
+        where
+          ppr_with_length list
+            = ppr list <+> parens (text "length =" <+> ppr (length list))
+          strdisp MarkedStrict = "MarkedStrict"
+          strdisp NotMarkedStrict = "NotMarkedStrict"
+
+zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id
+zapIdOccInfoAndSetEvald str v =
+  setCaseBndrEvald str $ -- Add eval'dness info
+  zapIdOccInfo v         -- And kill occ info;
+                         -- see Note [Case alternative occ info]
+
+addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
+addAltUnfoldings env scrut case_bndr con_app
+  = do { let con_app_unf = mk_simple_unf con_app
+             env1 = addBinderUnfolding env case_bndr con_app_unf
+
+             -- See Note [Add unfolding for scrutinee]
+             env2 = case scrut of
+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf
+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
+                                                mk_simple_unf (Cast con_app (mkSymCo co))
+                      _                      -> env1
+
+       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
+       ; return env2 }
+  where
+    mk_simple_unf = mkSimpleUnfolding (seDynFlags env)
+
+addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
+addBinderUnfolding env bndr unf
+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
+  = WARN( not (eqType (idType bndr) (exprType tmpl)),
+          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
+    modifyInScope env (bndr `setIdUnfolding` unf)
+
+  | otherwise
+  = modifyInScope env (bndr `setIdUnfolding` unf)
+
+zapBndrOccInfo :: Bool -> Id -> Id
+-- Consider  case e of b { (a,b) -> ... }
+-- Then if we bind b to (a,b) in "...", and b is not dead,
+-- then we must zap the deadness info on a,b
+zapBndrOccInfo keep_occ_info pat_id
+  | keep_occ_info = pat_id
+  | otherwise     = zapIdOccInfo pat_id
+
+{- Note [Case binder evaluated-ness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pin on a (OtherCon []) unfolding to the case-binder of a Case,
+even though it'll be over-ridden in every case alternative with a more
+informative unfolding.  Why?  Because suppose a later, less clever, pass
+simply replaces all occurrences of the case binder with the binder itself;
+then Lint may complain about the let/app invariant.  Example
+    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....
+                ; K       -> blah }
+
+The let/app invariant requires that y is evaluated in the call to
+reallyUnsafePtrEq#, which it is.  But we still want that to be true if we
+propagate binders to occurrences.
+
+This showed up in #13027.
+
+Note [Add unfolding for scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general it's unlikely that a variable scrutinee will appear
+in the case alternatives   case x of { ...x unlikely to appear... }
+because the binder-swap in OccAnal has got rid of all such occurrences
+See Note [Binder swap] in OccAnal.
+
+BUT it is still VERY IMPORTANT to add a suitable unfolding for a
+variable scrutinee, in simplAlt.  Here's why
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+There is no occurrence of 'b' in the (...(f y)...).  But y gets
+the unfolding (a,b), and *that* mentions b.  If f has a RULE
+    RULE f (p, I# q) = ...
+we want that rule to match, so we must extend the in-scope env with a
+suitable unfolding for 'y'.  It's *essential* for rule matching; but
+it's also good for case-elimintation -- suppose that 'f' was inlined
+and did multi-level case analysis, then we'd solve it in one
+simplifier sweep instead of two.
+
+Exactly the same issue arises in SpecConstr;
+see Note [Add scrutinee to ValueEnv too] in SpecConstr
+
+HOWEVER, given
+  case x of y { Just a -> r1; Nothing -> r2 }
+we do not want to add the unfolding x -> y to 'x', which might seem cool,
+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we
+did that, we'd have to zap y's deadness info and that is a very useful
+piece of information.
+
+So instead we add the unfolding x -> Just a, and x -> Nothing in the
+respective RHSs.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Known constructor}
+*                                                                      *
+************************************************************************
+
+We are a bit careful with occurrence info.  Here's an example
+
+        (\x* -> case x of (a*, b) -> f a) (h v, e)
+
+where the * means "occurs once".  This effectively becomes
+        case (h v, e) of (a*, b) -> f a)
+and then
+        let a* = h v; b = e in f a
+and then
+        f (h v)
+
+All this should happen in one sweep.
+-}
+
+knownCon :: SimplEnv
+         -> OutExpr                                           -- The scrutinee
+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)
+         -> InId -> [InBndr] -> InExpr                        -- The alternative
+         -> SimplCont
+         -> SimplM (SimplFloats, OutExpr)
+
+knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
+  = do  { (floats1, env1)  <- bind_args env bs dc_args
+        ; (floats2, env2) <- bind_case_bndr env1
+        ; (floats3, expr') <- simplExprF env2 rhs cont
+        ; case dc_floats of
+            [] ->
+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')
+            _ ->
+              return ( emptyFloats env
+               -- See Note [FloatBinds from constructor wrappers]
+                     , MkCore.wrapFloats dc_floats $
+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }
+  where
+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
+
+                  -- Ugh!
+    bind_args env' [] _  = return (emptyFloats env', env')
+
+    bind_args env' (b:bs') (Type ty : args)
+      = ASSERT( isTyVar b )
+        bind_args (extendTvSubst env' b ty) bs' args
+
+    bind_args env' (b:bs') (Coercion co : args)
+      = ASSERT( isCoVar b )
+        bind_args (extendCvSubst env' b co) bs' args
+
+    bind_args env' (b:bs') (arg : args)
+      = ASSERT( isId b )
+        do { let b' = zap_occ b
+             -- Note that the binder might be "dead", because it doesn't
+             -- occur in the RHS; and simplNonRecX may therefore discard
+             -- it via postInlineUnconditionally.
+             -- Nevertheless we must keep it if the case-binder is alive,
+             -- because it may be used in the con_app.  See Note [knownCon occ info]
+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant
+           ; (floats2, env3)  <- bind_args env2 bs' args
+           ; return (floats1 `addFloats` floats2, env3) }
+
+    bind_args _ _ _ =
+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
+                             text "scrut:" <+> ppr scrut
+
+       -- It's useful to bind bndr to scrut, rather than to a fresh
+       -- binding      x = Con arg1 .. argn
+       -- because very often the scrut is a variable, so we avoid
+       -- creating, and then subsequently eliminating, a let-binding
+       -- BUT, if scrut is a not a variable, we must be careful
+       -- about duplicating the arg redexes; in that case, make
+       -- a new con-app from the args
+    bind_case_bndr env
+      | isDeadBinder bndr   = return (emptyFloats env, env)
+      | exprIsTrivial scrut = return (emptyFloats env
+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))
+      | otherwise           = do { dc_args <- mapM (simplVar env) bs
+                                         -- dc_ty_args are aready OutTypes,
+                                         -- but bs are InBndrs
+                                 ; let con_app = Var (dataConWorkId dc)
+                                                 `mkTyApps` dc_ty_args
+                                                 `mkApps`   dc_args
+                                 ; simplNonRecX env bndr con_app }
+
+-------------------
+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
+           -> SimplM (SimplFloats, OutExpr)
+                -- This isn't strictly an error, although it is unusual.
+                -- It's possible that the simplifier might "see" that
+                -- an inner case has no accessible alternatives before
+                -- it "sees" that the entire branch of an outer case is
+                -- inaccessible.  So we simply put an error case here instead.
+missingAlt env case_bndr _ cont
+  = WARN( True, text "missingAlt" <+> ppr case_bndr )
+    -- See Note [Avoiding space leaks in OutType]
+    let cont_ty = contResultType cont
+    in seqType cont_ty `seq`
+       return (emptyFloats env, mkImpossibleExpr cont_ty)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Duplicating continuations}
+*                                                                      *
+************************************************************************
+
+Consider
+  let x* = case e of { True -> e1; False -> e2 }
+  in b
+where x* is a strict binding.  Then mkDupableCont will be given
+the continuation
+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop
+and will split it into
+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop
+   join floats:  $j1 = e1, $j2 = e2
+   non_dupable:  let x* = [] in b; stop
+
+Putting this back together would give
+   let x* = let { $j1 = e1; $j2 = e2 } in
+            case e of { True -> $j1; False -> $j2 }
+   in b
+(Of course we only do this if 'e' wants to duplicate that continuation.)
+Note how important it is that the new join points wrap around the
+inner expression, and not around the whole thing.
+
+In contrast, any let-bindings introduced by mkDupableCont can wrap
+around the entire thing.
+
+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+     case (case x of { A -> error .. ; B -> e; C -> error ..)
+       of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately.  This is more direct than creating
+join points and inlining them away.  See #4930.
+-}
+
+--------------------
+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont
+                  -> SimplM (SimplFloats, SimplCont)
+mkDupableCaseCont env alts cont
+  | altsWouldDup alts = mkDupableCont env cont
+  | otherwise         = return (emptyFloats env, cont)
+
+altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
+altsWouldDup []  = False        -- See Note [Bottom alternatives]
+altsWouldDup [_] = False
+altsWouldDup (alt:alts)
+  | is_bot_alt alt = altsWouldDup alts
+  | otherwise      = not (all is_bot_alt alts)
+  where
+    is_bot_alt (_,_,rhs) = exprIsBottom rhs
+
+-------------------------
+mkDupableCont :: SimplEnv -> SimplCont
+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with
+                                       --   extra let/join-floats and in-scope variables
+                        , SimplCont)   -- dup_cont: duplicable continuation
+
+mkDupableCont env cont
+  | contIsDupable cont
+  = return (emptyFloats env, cont)
+
+mkDupableCont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
+
+mkDupableCont env (CastIt ty cont)
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, CastIt ty cont') }
+
+-- Duplicating ticks for now, not sure if this is good or not
+mkDupableCont env (TickIt t cont)
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, TickIt t cont') }
+
+mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
+                              , sc_body = body, sc_env = se, sc_cont = cont})
+  -- See Note [Duplicating StrictBind]
+  = do { let sb_env = se `setInScopeFromE` env
+       ; (sb_env1, bndr') <- simplBinder sb_env bndr
+       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
+          -- No need to use mkDupableCont before simplLam; we
+          -- use cont once here, and then share the result if necessary
+
+       ; let join_body = wrapFloats floats1 join_inner
+             res_ty    = contResultType cont
+
+       ; (floats2, body2)
+            <- if exprIsDupable (seDynFlags env) join_body
+               then return (emptyFloats env, join_body)
+               else do { join_bndr <- newJoinId [bndr'] res_ty
+                       ; let join_call = App (Var join_bndr) (Var bndr')
+                             join_rhs  = Lam (setOneShotLambda bndr') join_body
+                             join_bind = NonRec join_bndr join_rhs
+                             floats    = emptyFloats env `extendFloats` join_bind
+                       ; return (floats, join_call) }
+       ; return ( floats2
+                , StrictBind { sc_bndr = bndr', sc_bndrs = []
+                             , sc_body = body2
+                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2
+                                         -- See Note [StaticEnv invariant] in SimplUtils
+                             , sc_dup  = OkToDup
+                             , sc_cont = mkBoringStop res_ty } ) }
+
+mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
+        -- See Note [Duplicating StrictArg]
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+  = do { (floats1, cont') <- mkDupableCont env cont
+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
+                                           (ai_args info)
+       ; return ( foldl' addLetFloats floats1 floats_s
+                , StrictArg { sc_fun = info { ai_args = args' }
+                            , sc_cci = cci
+                            , sc_cont = cont'
+                            , sc_dup = OkToDup} ) }
+
+mkDupableCont env (ApplyToTy { sc_cont = cont
+                             , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, ApplyToTy { sc_cont = cont'
+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
+
+mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
+                              , sc_env = se, sc_cont = cont })
+  =     -- e.g.         [...hole...] (...arg...)
+        --      ==>
+        --              let a = ...arg...
+        --              in [...hole...] a
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+    do  { (floats1, cont') <- mkDupableCont env cont
+        ; let env' = env `setInScopeFromF` floats1
+        ; (_, se', arg') <- simplArg env' dup se arg
+        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'
+        ; let all_floats = floats1 `addLetFloats` let_floats2
+        ; return ( all_floats
+                 , ApplyToVal { sc_arg = arg''
+                              , sc_env = se' `setInScopeFromF` all_floats
+                                         -- Ensure that sc_env includes the free vars of
+                                         -- arg'' in its in-scope set, even if makeTrivial
+                                         -- has turned arg'' into a fresh variable
+                                         -- See Note [StaticEnv invariant] in SimplUtils
+                              , sc_dup = OkToDup, sc_cont = cont' }) }
+
+mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
+                          , sc_env = se, sc_cont = cont })
+  =     -- e.g.         (case [...hole...] of { pi -> ei })
+        --      ===>
+        --              let ji = \xij -> ei
+        --              in case [...hole...] of { pi -> ji xij }
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+    do  { tick (CaseOfCase case_bndr)
+        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont
+                -- NB: We call mkDupableCaseCont here to make cont duplicable
+                --     (if necessary, depending on the number of alts)
+                -- And this is important: see Note [Fusing case continuations]
+
+        ; let alt_env = se `setInScopeFromF` floats
+        ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts
+        -- Safe to say that there are no handled-cons for the DEFAULT case
+                -- NB: simplBinder does not zap deadness occ-info, so
+                -- a dead case_bndr' will still advertise its deadness
+                -- This is really important because in
+                --      case e of b { (# p,q #) -> ... }
+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
+                -- In the new alts we build, we have the new case binder, so it must retain
+                -- its deadness.
+        -- NB: we don't use alt_env further; it has the substEnv for
+        --     the alternatives, and we don't want that
+
+        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')
+                                              emptyJoinFloats alts'
+
+        ; let all_floats = floats `addJoinFloats` join_floats
+                           -- Note [Duplicated env]
+        ; return (all_floats
+                 , Select { sc_dup  = OkToDup
+                          , sc_bndr = case_bndr'
+                          , sc_alts = alts''
+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats
+                                      -- See Note [StaticEnv invariant] in SimplUtils
+                          , sc_cont = mkBoringStop (contResultType cont) } ) }
+
+mkDupableAlt :: DynFlags -> OutId
+             -> JoinFloats -> OutAlt
+             -> SimplM (JoinFloats, OutAlt)
+mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')
+  | exprIsDupable dflags rhs'  -- Note [Small alternative rhs]
+  = return (jfloats, (con, bndrs', rhs'))
+
+  | otherwise
+  = do  { let rhs_ty'  = exprType rhs'
+              scrut_ty = idType case_bndr
+              case_bndr_w_unf
+                = case con of
+                      DEFAULT    -> case_bndr
+                      DataAlt dc -> setIdUnfolding case_bndr unf
+                          where
+                                 -- See Note [Case binders and join points]
+                             unf = mkInlineUnfolding rhs
+                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
+
+                      LitAlt {} -> WARN( True, text "mkDupableAlt"
+                                                <+> ppr case_bndr <+> ppr con )
+                                   case_bndr
+                           -- The case binder is alive but trivial, so why has
+                           -- it not been substituted away?
+
+              final_bndrs'
+                | isDeadBinder case_bndr = filter abstract_over bndrs'
+                | otherwise              = bndrs' ++ [case_bndr_w_unf]
+
+              abstract_over bndr
+                  | isTyVar bndr = True -- Abstract over all type variables just in case
+                  | otherwise    = not (isDeadBinder bndr)
+                        -- The deadness info on the new Ids is preserved by simplBinders
+              final_args = varsToCoreExprs final_bndrs'
+                           -- Note [Join point abstraction]
+
+                -- We make the lambdas into one-shot-lambdas.  The
+                -- join point is sure to be applied at most once, and doing so
+                -- prevents the body of the join point being floated out by
+                -- the full laziness pass
+              really_final_bndrs     = map one_shot final_bndrs'
+              one_shot v | isId v    = setOneShotLambda v
+                         | otherwise = v
+              join_rhs   = mkLams really_final_bndrs rhs'
+
+        ; join_bndr <- newJoinId final_bndrs' rhs_ty'
+
+        ; let join_call = mkApps (Var join_bndr) final_args
+              alt'      = (con, bndrs', join_call)
+
+        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)
+                 , alt') }
+                -- See Note [Duplicated env]
+
+{-
+Note [Fusing case continuations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to fuse two successive case continuations when the
+first has one alternative.  That's why we call prepareCaseCont here.
+Consider this, which arises from thunk splitting (see Note [Thunk
+splitting] in WorkWrap):
+
+      let
+        x* = case (case v of {pn -> rn}) of
+               I# a -> I# a
+      in body
+
+The simplifier will find
+    (Var v) with continuation
+            Select (pn -> rn) (
+            Select [I# a -> I# a] (
+            StrictBind body Stop
+
+So we'll call mkDupableCont on
+   Select [I# a -> I# a] (StrictBind body Stop)
+There is just one alternative in the first Select, so we want to
+simplify the rhs (I# a) with continuation (StrictBind body Stop)
+Supposing that body is big, we end up with
+          let $j a = <let x = I# a in body>
+          in case v of { pn -> case rn of
+                                 I# a -> $j a }
+This is just what we want because the rn produces a box that
+the case rn cancels with.
+
+See #4957 a fuller example.
+
+Note [Case binders and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   case (case .. ) of c {
+     I# c# -> ....c....
+
+If we make a join point with c but not c# we get
+  $j = \c -> ....c....
+
+But if later inlining scrutinises the c, thus
+
+  $j = \c -> ... case c of { I# y -> ... } ...
+
+we won't see that 'c' has already been scrutinised.  This actually
+happens in the 'tabulate' function in wave4main, and makes a significant
+difference to allocation.
+
+An alternative plan is this:
+
+   $j = \c# -> let c = I# c# in ...c....
+
+but that is bad if 'c' is *not* later scrutinised.
+
+So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
+(a stable unfolding) that it's really I# c#, thus
+
+   $j = \c# -> \c[=I# c#] -> ...c....
+
+Absence analysis may later discard 'c'.
+
+NB: take great care when doing strictness analysis;
+    see Note [Lambda-bound unfoldings] in DmdAnal.
+
+Also note that we can still end up passing stuff that isn't used.  Before
+strictness analysis we have
+   let $j x y c{=(x,y)} = (h c, ...)
+   in ...
+After strictness analysis we see that h is strict, we end up with
+   let $j x y c{=(x,y)} = ($wh x y, ...)
+and c is unused.
+
+Note [Duplicated env]
+~~~~~~~~~~~~~~~~~~~~~
+Some of the alternatives are simplified, but have not been turned into a join point
+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to
+bind the join point, because it might to do PostInlineUnconditionally, and
+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
+but zapping it (as we do in mkDupableCont, the Select case) is safe, and
+at worst delays the join-point inlining.
+
+Note [Small alternative rhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is worth checking for a small RHS because otherwise we
+get extra let bindings that may cause an extra iteration of the simplifier to
+inline back in place.  Quite often the rhs is just a variable or constructor.
+The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra
+iterations because the version with the let bindings looked big, and so wasn't
+inlined, but after the join points had been inlined it looked smaller, and so
+was inlined.
+
+NB: we have to check the size of rhs', not rhs.
+Duplicating a small InAlt might invalidate occurrence information
+However, if it *is* dupable, we return the *un* simplified alternative,
+because otherwise we'd need to pair it up with an empty subst-env....
+but we only have one env shared between all the alts.
+(Remember we must zap the subst-env before re-simplifying something).
+Rather than do this we simply agree to re-simplify the original (small) thing later.
+
+Note [Funky mkLamTypes]
+~~~~~~~~~~~~~~~~~~~~~~
+Notice the funky mkLamTypes.  If the constructor has existentials
+it's possible that the join point will be abstracted over
+type variables as well as term variables.
+ Example:  Suppose we have
+        data T = forall t.  C [t]
+ Then faced with
+        case (case e of ...) of
+            C t xs::[t] -> rhs
+ We get the join point
+        let j :: forall t. [t] -> ...
+            j = /\t \xs::[t] -> rhs
+        in
+        case (case e of ...) of
+            C t xs::[t] -> j t xs
+
+Note [Duplicating StrictArg]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We make a StrictArg duplicable simply by making all its
+stored-up arguments (in sc_fun) trivial, by let-binding
+them.  Thus:
+        f E [..hole..]
+        ==>     let a = E
+                in f a [..hole..]
+Now if the thing in the hole is a case expression (which is when
+we'll call mkDupableCont), we'll push the function call into the
+branches, which is what we want.  Now RULES for f may fire, and
+call-pattern specialisation.  Here's an example from #3116
+     go (n+1) (case l of
+                 1  -> bs'
+                 _  -> Chunk p fpc (o+1) (l-1) bs')
+If we can push the call for 'go' inside the case, we get
+call-pattern specialisation for 'go', which is *crucial* for
+this program.
+
+Here is the (&&) example:
+        && E (case x of { T -> F; F -> T })
+  ==>   let a = E in
+        case x of { T -> && a F; F -> && a T }
+Much better!
+
+Notice that
+  * Arguments to f *after* the strict one are handled by
+    the ApplyToVal case of mkDupableCont.  Eg
+        f [..hole..] E
+
+  * We can only do the let-binding of E because the function
+    part of a StrictArg continuation is an explicit syntax
+    tree.  In earlier versions we represented it as a function
+    (CoreExpr -> CoreEpxr) which we couldn't take apart.
+
+Historical aide: previously we did this (where E is a
+big argument:
+        f E [..hole..]
+        ==>     let $j = \a -> f E a
+                in $j [..hole..]
+
+But this is terrible! Here's an example:
+        && E (case x of { T -> F; F -> T })
+Now, && is strict so we end up simplifying the case with
+an ArgOf continuation.  If we let-bind it, we get
+        let $j = \v -> && E v
+        in simplExpr (case x of { T -> F; F -> T })
+                     (ArgOf (\r -> $j r)
+And after simplifying more we get
+        let $j = \v -> && E v
+        in case x of { T -> $j F; F -> $j T }
+Which is a Very Bad Thing
+
+
+Note [Duplicating StrictBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We make a StrictBind duplicable in a very similar way to
+that for case expressions.  After all,
+   let x* = e in b   is similar to    case e of x -> b
+
+So we potentially make a join-point for the body, thus:
+   let x = [] in b   ==>   join j x = b
+                           in let x = [] in j x
+
+
+Note [Join point abstraction]  Historical note
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: This note is now historical, describing how (in the past) we used
+to add a void argument to nullary join points.  But now that "join
+point" is not a fuzzy concept but a formal syntactic construct (as
+distinguished by the JoinId constructor of IdDetails), each of these
+concerns is handled separately, with no need for a vestigial extra
+argument.
+
+Join points always have at least one value argument,
+for several reasons
+
+* If we try to lift a primitive-typed something out
+  for let-binding-purposes, we will *caseify* it (!),
+  with potentially-disastrous strictness results.  So
+  instead we turn it into a function: \v -> e
+  where v::Void#.  The value passed to this function is void,
+  which generates (almost) no code.
+
+* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now
+  we make the join point into a function whenever used_bndrs'
+  is empty.  This makes the join-point more CPR friendly.
+  Consider:       let j = if .. then I# 3 else I# 4
+                  in case .. of { A -> j; B -> j; C -> ... }
+
+  Now CPR doesn't w/w j because it's a thunk, so
+  that means that the enclosing function can't w/w either,
+  which is a lose.  Here's the example that happened in practice:
+          kgmod :: Int -> Int -> Int
+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+                      then 78
+                      else 5
+
+* Let-no-escape.  We want a join point to turn into a let-no-escape
+  so that it is implemented as a jump, and one of the conditions
+  for LNE is that it's not updatable.  In CoreToStg, see
+  Note [What is a non-escaping let]
+
+* Floating.  Since a join point will be entered once, no sharing is
+  gained by floating out, but something might be lost by doing
+  so because it might be allocated.
+
+I have seen a case alternative like this:
+        True -> \v -> ...
+It's a bit silly to add the realWorld dummy arg in this case, making
+        $j = \s v -> ...
+           True -> $j s
+(the \v alone is enough to make CPR happy) but I think it's rare
+
+There's a slight infelicity here: we pass the overall
+case_bndr to all the join points if it's used in *any* RHS,
+because we don't know its usage in each RHS separately
+
+
+
+************************************************************************
+*                                                                      *
+                    Unfoldings
+*                                                                      *
+************************************************************************
+-}
+
+simplLetUnfolding :: SimplEnv-> TopLevelFlag
+                  -> MaybeJoinCont
+                  -> InId
+                  -> OutExpr -> OutType
+                  -> Unfolding -> SimplM Unfolding
+simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf
+  | isStableUnfolding unf
+  = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty
+  | isExitJoinId id
+  = return noUnfolding -- See Note [Do not inline exit join points] in Exitify
+  | otherwise
+  = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs
+
+-------------------
+mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource
+               -> InId -> OutExpr -> SimplM Unfolding
+mkLetUnfolding dflags top_lvl src id new_rhs
+  = is_bottoming `seq`  -- See Note [Force bottoming field]
+    return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)
+            -- We make an  unfolding *even for loop-breakers*.
+            -- Reason: (a) It might be useful to know that they are WHNF
+            --         (b) In TidyPgm we currently assume that, if we want to
+            --             expose the unfolding then indeed we *have* an unfolding
+            --             to expose.  (We could instead use the RHS, but currently
+            --             we don't.)  The simple thing is always to have one.
+  where
+    is_top_lvl   = isTopLevel top_lvl
+    is_bottoming = isBottomingId id
+
+-------------------
+simplStableUnfolding :: SimplEnv -> TopLevelFlag
+                     -> MaybeJoinCont  -- Just k => a join point with continuation k
+                     -> InId
+                     -> Unfolding -> OutType -> SimplM Unfolding
+-- Note [Setting the new unfolding]
+simplStableUnfolding env top_lvl mb_cont id unf rhs_ty
+  = case unf of
+      NoUnfolding   -> return unf
+      BootUnfolding -> return unf
+      OtherCon {}   -> return unf
+
+      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
+        -> do { (env', bndrs') <- simplBinders unf_env bndrs
+              ; args' <- mapM (simplExpr env') args
+              ; return (mkDFunUnfolding bndrs' con args') }
+
+      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
+        | isStableSource src
+        -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points]
+                           Just cont -> simplJoinRhs unf_env id expr cont
+                           Nothing   -> simplExprC unf_env expr (mkBoringStop rhs_ty)
+              ; case guide of
+                  UnfWhen { ug_arity = arity
+                          , ug_unsat_ok = sat_ok
+                          , ug_boring_ok = boring_ok
+                          }
+                          -- Happens for INLINE things
+                     -> let guide' =
+                              UnfWhen { ug_arity = arity
+                                      , ug_unsat_ok = sat_ok
+                                      , ug_boring_ok =
+                                          boring_ok || inlineBoringOk expr'
+                                      }
+                        -- Refresh the boring-ok flag, in case expr'
+                        -- has got small. This happens, notably in the inlinings
+                        -- for dfuns for single-method classes; see
+                        -- Note [Single-method classes] in TcInstDcls.
+                        -- A test case is #4138
+                        -- But retain a previous boring_ok of True; e.g. see
+                        -- the way it is set in calcUnfoldingGuidanceWithArity
+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')
+                            -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+                  _other              -- Happens for INLINABLE things
+                     -> mkLetUnfolding dflags top_lvl src id expr' }
+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+                -- unfolding, and we need to make sure the guidance is kept up
+                -- to date with respect to any changes in the unfolding.
+
+        | otherwise -> return noUnfolding   -- Discard unstable unfoldings
+  where
+    dflags     = seDynFlags env
+    is_top_lvl = isTopLevel top_lvl
+    act        = idInlineActivation id
+    unf_env    = updMode (updModeForStableUnfoldings act) env
+         -- See Note [Simplifying inside stable unfoldings] in SimplUtils
+
+{-
+Note [Force bottoming field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to force bottoming, or the new unfolding holds
+on to the old unfolding (which is part of the id).
+
+Note [Setting the new unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
+  should do nothing at all, but simplifying gently might get rid of
+  more crap.
+
+* If not, we make an unfolding from the new RHS.  But *only* for
+  non-loop-breakers. Making loop breakers not have an unfolding at all
+  means that we can avoid tests in exprIsConApp, for example.  This is
+  important: if exprIsConApp says 'yes' for a recursive thing, then we
+  can get into an infinite loop
+
+If there's a stable unfolding on a loop breaker (which happens for
+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the
+user did say 'INLINE'.  May need to revisit this choice.
+
+************************************************************************
+*                                                                      *
+                    Rules
+*                                                                      *
+************************************************************************
+
+Note [Rules in a letrec]
+~~~~~~~~~~~~~~~~~~~~~~~~
+After creating fresh binders for the binders of a letrec, we
+substitute the RULES and add them back onto the binders; this is done
+*before* processing any of the RHSs.  This is important.  Manuel found
+cases where he really, really wanted a RULE for a recursive function
+to apply in that function's own right-hand side.
+
+See Note [Forming Rec groups] in OccurAnal
+-}
+
+addBndrRules :: SimplEnv -> InBndr -> OutBndr
+             -> MaybeJoinCont   -- Just k for a join point binder
+                                -- Nothing otherwise
+             -> SimplM (SimplEnv, OutBndr)
+-- Rules are added back into the bin
+addBndrRules env in_id out_id mb_cont
+  | null old_rules
+  = return (env, out_id)
+  | otherwise
+  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont
+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules
+       ; return (modifyInScope env final_id, final_id) }
+  where
+    old_rules = ruleInfoRules (idSpecialisation in_id)
+
+simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]
+           -> MaybeJoinCont -> SimplM [CoreRule]
+simplRules env mb_new_id rules mb_cont
+  = mapM simpl_rule rules
+  where
+    simpl_rule rule@(BuiltinRule {})
+      = return rule
+
+    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args
+                          , ru_fn = fn_name, ru_rhs = rhs })
+      = do { (env', bndrs') <- simplBinders env bndrs
+           ; let rhs_ty = substTy env' (exprType rhs)
+                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]
+                                Nothing   -> mkBoringStop rhs_ty
+                                Just cont -> ASSERT2( join_ok, bad_join_msg )
+                                             cont
+                 rule_env = updMode updModeForRules env'
+                 fn_name' = case mb_new_id of
+                              Just id -> idName id
+                              Nothing -> fn_name
+
+                 -- join_ok is an assertion check that the join-arity of the
+                 -- binder matches that of the rule, so that pushing the
+                 -- continuation into the RHS makes sense
+                 join_ok = case mb_new_id of
+                             Just id | Just join_arity <- isJoinId_maybe id
+                                     -> length args == join_arity
+                             _ -> False
+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule
+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]
+
+           ; args' <- mapM (simplExpr rule_env) args
+           ; rhs'  <- simplExprC rule_env rhs rhs_cont
+           ; return (rule { ru_bndrs = bndrs'
+                          , ru_fn    = fn_name'
+                          , ru_args  = args'
+                          , ru_rhs   = rhs' }) }
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/SimplStg.hs
@@ -0,0 +1,140 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplStg]{Driver for simplifying @STG@ programs}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module SimplStg ( stg2stg ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+
+import StgLint          ( lintStgTopBindings )
+import StgStats         ( showStgStats )
+import UnariseStg       ( unarise )
+import StgCse           ( stgCse )
+import StgLiftLams      ( stgLiftLams )
+import Module           ( Module )
+
+import DynFlags
+import ErrUtils
+import UniqSupply
+import Outputable
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.State.Strict
+
+newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadUnique StgM where
+  getUniqueSupplyM = StgM (state splitUniqSupply)
+  getUniqueM = StgM (state takeUniqFromSupply)
+
+runStgM :: UniqSupply -> StgM a -> IO a
+runStgM us (StgM m) = evalStateT m us
+
+stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
+        -> Module                    -- module being compiled
+        -> [StgTopBinding]           -- input program
+        -> IO [StgTopBinding]        -- output program
+
+stg2stg dflags this_mod binds
+  = do  { showPass dflags "Stg2Stg"
+        ; us <- mkSplitUniqSupply 'g'
+
+        -- Do the main business!
+        ; binds' <- runStgM us $
+            foldM do_stg_pass binds (getStgToDo dflags)
+
+        ; dump_when Opt_D_dump_stg "STG syntax:" binds'
+
+        ; return binds'
+   }
+
+  where
+    stg_linter what
+      | gopt Opt_DoStgLinting dflags
+      = lintStgTopBindings dflags this_mod what
+      | otherwise
+      = \ _whodunnit _binds -> return ()
+
+    -------------------------------------------
+    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
+    do_stg_pass binds to_do
+      = case to_do of
+          StgDoNothing ->
+            return binds
+
+          StgStats ->
+            trace (showStgStats binds) (return binds)
+
+          StgCSE -> do
+            let binds' = {-# SCC "StgCse" #-} stgCse binds
+            end_pass "StgCse" binds'
+
+          StgLiftLams -> do
+            us <- getUniqueSupplyM
+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
+            end_pass "StgLiftLams" binds'
+
+          StgUnarise -> do
+            liftIO (dump_when Opt_D_dump_stg "Pre unarise:" binds)
+            us <- getUniqueSupplyM
+            liftIO (stg_linter False "Pre-unarise" binds)
+            let binds' = unarise us binds
+            liftIO (stg_linter True "Unarise" binds')
+            return binds'
+
+    dump_when flag header binds
+      = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)
+
+    end_pass what binds2
+      = liftIO $ do -- report verbosely, if required
+          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
+            (vcat (map ppr binds2))
+          stg_linter False what binds2
+          return binds2
+
+-- -----------------------------------------------------------------------------
+-- StgToDo:  abstraction of stg-to-stg passes to run.
+
+-- | Optional Stg-to-Stg passes.
+data StgToDo
+  = StgCSE
+  -- ^ Common subexpression elimination
+  | StgLiftLams
+  -- ^ Lambda lifting closure variables, trading stack/register allocation for
+  -- heap allocation
+  | StgStats
+  | StgUnarise
+  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
+  | StgDoNothing
+  -- ^ Useful for building up 'getStgToDo'
+  deriving Eq
+
+-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
+getStgToDo :: DynFlags -> [StgToDo]
+getStgToDo dflags =
+  filter (/= StgDoNothing)
+    [ mandatory StgUnarise
+    -- Important that unarisation comes first
+    -- See Note [StgCse after unarisation] in StgCse
+    , optional Opt_StgCSE StgCSE
+    , optional Opt_StgLiftLams StgLiftLams
+    , optional Opt_StgStats StgStats
+    ] where
+      optional opt = runWhen (gopt opt dflags)
+      mandatory = id
+
+runWhen :: Bool -> StgToDo -> StgToDo
+runWhen True todo = todo
+runWhen _    _    = StgDoNothing
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgCse.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE TypeFamilies #-}
+
+{-|
+Note [CSE for Stg]
+~~~~~~~~~~~~~~~~~~
+This module implements a simple common subexpression elimination pass for STG.
+This is useful because there are expressions that we want to common up (because
+they are operationally equivalent), but that we cannot common up in Core, because
+their types differ.
+This was originally reported as #9291.
+
+There are two types of common code occurrences that we aim for, see
+note [Case 1: CSEing allocated closures] and
+note [Case 2: CSEing case binders] below.
+
+
+Note [Case 1: CSEing allocated closures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The first kind of CSE opportunity we aim for is generated by this Haskell code:
+
+    bar :: a -> (Either Int a, Either Bool a)
+    bar x = (Right x, Right x)
+
+which produces this Core:
+
+    bar :: forall a. a -> (Either Int a, Either Bool a)
+    bar @a x = (Right @Int @a x, Right @Bool @a x)
+
+where the two components of the tuple are different terms, and cannot be
+commoned up (easily). On the STG level we have
+
+    bar [x] = let c1 = Right [x]
+                  c2 = Right [x]
+              in (c1,c2)
+
+and now it is obvious that we can write
+
+    bar [x] = let c1 = Right [x]
+              in (c1,c1)
+
+instead.
+
+
+Note [Case 2: CSEing case binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The second kind of CSE opportunity we aim for is more interesting, and
+came up in #9291 and #5344: The Haskell code
+
+    foo :: Either Int a -> Either Bool a
+    foo (Right x) = Right x
+    foo _         = Left False
+
+produces this Core
+
+    foo :: forall a. Either Int a -> Either Bool a
+    foo @a e = case e of b { Left n -> …
+                           , Right x -> Right @Bool @a x }
+
+where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have
+different types. But in STG we have
+
+    foo [e] = case e of b { Left [n] -> …
+                          , Right [x] -> Right [x] }
+
+and nothing stops us from transforming that to
+
+    foo [e] = case e of b { Left [n] -> …
+                          , Right [x] -> b}
+
+
+Note [StgCse after unarisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider two unboxed sum terms:
+
+    (# 1 | #) :: (# Int | Int# #)
+    (# 1 | #) :: (# Int | Int  #)
+
+These two terms are not equal as they unarise to different unboxed
+tuples. However if we run StgCse before Unarise, it'll think the two
+terms (# 1 | #) are equal, and replace one of these with a binder to
+the other. That's bad -- #15300.
+
+Solution: do unarise first.
+
+-}
+
+module StgCse (stgCse) where
+
+import GhcPrelude
+
+import DataCon
+import Id
+import StgSyn
+import Outputable
+import VarEnv
+import CoreSyn (AltCon(..))
+import Data.List (mapAccumL)
+import Data.Maybe (fromMaybe)
+import CoreMap
+import NameEnv
+import Control.Monad( (>=>) )
+
+--------------
+-- The Trie --
+--------------
+
+-- A lookup trie for data constructor applications, i.e.
+-- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.
+
+data StgArgMap a = SAM
+    { sam_var :: DVarEnv a
+    , sam_lit :: LiteralMap a
+    }
+
+instance TrieMap StgArgMap where
+    type Key StgArgMap = StgArg
+    emptyTM  = SAM { sam_var = emptyTM
+                   , sam_lit = emptyTM }
+    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var
+    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit
+    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
+    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
+    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
+    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
+        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
+
+newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
+
+instance TrieMap ConAppMap where
+    type Key ConAppMap = (DataCon, [StgArg])
+    emptyTM  = CAM emptyTM
+    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args
+    alterTM  (dataCon, args) f m =
+        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
+    foldTM k = un_cam >.> foldTM (foldTM k)
+    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM
+
+-----------------
+-- The CSE Env --
+-----------------
+
+-- | The CSE environment. See note [CseEnv Example]
+data CseEnv = CseEnv
+    { ce_conAppMap :: ConAppMap OutId
+        -- ^ The main component of the environment is the trie that maps
+        --   data constructor applications (with their `OutId` arguments)
+        --   to an in-scope name that can be used instead.
+        --   This name is always either a let-bound variable or a case binder.
+    , ce_subst     :: IdEnv OutId
+        -- ^ This substitution is applied to the code as we traverse it.
+        --   Entries have one of two reasons:
+        --
+        --   * The input might have shadowing (see Note [Shadowing]), so we have
+        --     to rename some binders as we traverse the tree.
+        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,
+        --     we note this here as x ↦ y.
+    , ce_bndrMap     :: IdEnv OutId
+        -- ^ If we come across a case expression case x as b of … with a trivial
+        --   binder, we add b ↦ x to this.
+        --   This map is *only* used when looking something up in the ce_conAppMap.
+        --   See Note [Trivial case scrutinee]
+    , ce_in_scope  :: InScopeSet
+        -- ^ The third component is an in-scope set, to rename away any
+        --   shadowing binders
+    }
+
+{-|
+Note [CseEnv Example]
+~~~~~~~~~~~~~~~~~~~~~
+The following tables shows how the CseEnvironment changes as code is traversed,
+as well as the changes to that code.
+
+  InExpr                         OutExpr
+     conAppMap                   subst          in_scope
+  ───────────────────────────────────────────────────────────
+  -- empty                       {}             {}
+  case … as a of {Con x y ->     case … as a of {Con x y ->
+  -- Con x y ↦ a                 {}             {a,x,y}
+  let b = Con x y                (removed)
+  -- Con x y ↦ a                 b↦a            {a,x,y,b}
+  let c = Bar a                  let c = Bar a
+  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}
+  let c = some expression        let c' = some expression
+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}
+  let d = Bar b                  (removed)
+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}
+  (a, b, c d)                    (a, a, c' c)
+-}
+
+initEnv :: InScopeSet -> CseEnv
+initEnv in_scope = CseEnv
+    { ce_conAppMap = emptyTM
+    , ce_subst     = emptyVarEnv
+    , ce_bndrMap   = emptyVarEnv
+    , ce_in_scope  = in_scope
+    }
+
+envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId
+envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)
+  where args' = map go args -- See Note [Trivial case scrutinee]
+        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)
+        go (StgLitArg lit) = StgLitArg lit
+
+addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv
+-- do not bother with nullary data constructors, they are static anyways
+addDataCon _ _ [] env = env
+addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }
+  where
+    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)
+
+forgetCse :: CseEnv -> CseEnv
+forgetCse env = env { ce_conAppMap = emptyTM }
+    -- See note [Free variables of an StgClosure]
+
+addSubst :: OutId -> OutId -> CseEnv -> CseEnv
+addSubst from to env
+    = env { ce_subst = extendVarEnv (ce_subst env) from to }
+
+addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv
+addTrivCaseBndr from to env
+    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }
+
+substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]
+substArgs env = map (substArg env)
+
+substArg :: CseEnv -> InStgArg -> OutStgArg
+substArg env (StgVarArg from) = StgVarArg (substVar env from)
+substArg _   (StgLitArg lit)  = StgLitArg lit
+
+substVar :: CseEnv -> InId -> OutId
+substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
+
+-- Functions to enter binders
+
+-- This is much simpler than the equivalent code in CoreSubst:
+--  * We do not substitute type variables, and
+--  * There is nothing relevant in IdInfo at this stage
+--    that needs substitutions.
+-- Therefore, no special treatment for a recursive group is required.
+
+substBndr :: CseEnv -> InId -> (CseEnv, OutId)
+substBndr env old_id
+  = (new_env, new_id)
+  where
+    new_id = uniqAway (ce_in_scope env) old_id
+    no_change = new_id == old_id
+    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }
+    new_env | no_change = env'
+            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }
+
+substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])
+substBndrs env bndrs = mapAccumL substBndr env bndrs
+
+substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])
+substPairs env bndrs = mapAccumL go env bndrs
+  where go env (id, x) = let (env', id') = substBndr env id
+                         in (env', (id', x))
+
+-- Main entry point
+
+stgCse :: [InStgTopBinding] -> [OutStgTopBinding]
+stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds
+
+-- Top level bindings.
+--
+-- We do not CSE these, as top-level closures are allocated statically anyways.
+-- Also, they might be exported.
+-- But we still have to collect the set of in-scope variables, otherwise
+-- uniqAway might shadow a top-level closure.
+
+stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)
+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)
+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))
+    = (in_scope'
+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))
+  where in_scope' = in_scope `extendInScopeSet` bndr
+
+stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
+    = ( in_scope'
+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))
+  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
+
+stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
+    = let body' = stgCseExpr (initEnv in_scope) body
+      in  StgRhsClosure ext ccs upd args body'
+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)
+    = StgRhsCon ccs dataCon args
+
+------------------------------
+-- The actual AST traversal --
+------------------------------
+
+-- Trivial cases
+stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr
+stgCseExpr env (StgApp fun args)
+    = StgApp fun' args'
+  where fun' = substVar env fun
+        args' = substArgs env args
+stgCseExpr _ (StgLit lit)
+    = StgLit lit
+stgCseExpr env (StgOpApp op args tys)
+    = StgOpApp op args' tys
+  where args' = substArgs env args
+stgCseExpr _ (StgLam _ _)
+    = pprPanic "stgCseExp" (text "StgLam")
+stgCseExpr env (StgTick tick body)
+    = let body' = stgCseExpr env body
+      in StgTick tick body'
+stgCseExpr env (StgCase scrut bndr ty alts)
+    = mkStgCase scrut' bndr' ty alts'
+  where
+    scrut' = stgCseExpr env scrut
+    (env1, bndr') = substBndr env bndr
+    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1
+                 -- See Note [Trivial case scrutinee]
+         | otherwise                         = env1
+    alts' = map (stgCseAlt env2 ty bndr') alts
+
+
+-- A constructor application.
+-- To be removed by a variable use when found in the CSE environment
+stgCseExpr env (StgConApp dataCon args tys)
+    | Just bndr' <- envLookup dataCon args' env
+    = StgApp bndr' []
+    | otherwise
+    = StgConApp dataCon args' tys
+  where args' = substArgs env args
+
+-- Let bindings
+-- The binding might be removed due to CSE (we do not want trivial bindings on
+-- the STG level), so use the smart constructor `mkStgLet` to remove the binding
+-- if empty.
+stgCseExpr env (StgLet ext binds body)
+    = let (binds', env') = stgCseBind env binds
+          body' = stgCseExpr env' body
+      in mkStgLet (StgLet ext) binds' body'
+stgCseExpr env (StgLetNoEscape ext binds body)
+    = let (binds', env') = stgCseBind env binds
+          body' = stgCseExpr env' body
+      in mkStgLet (StgLetNoEscape ext) binds' body'
+
+-- Case alternatives
+-- Extend the CSE environment
+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
+    = let (env1, args') = substBndrs env args
+          env2
+            -- To avoid dealing with unboxed sums StgCse runs after unarise and
+            -- should maintain invariants listed in Note [Post-unarisation
+            -- invariants]. One of the invariants is that some binders are not
+            -- used (unboxed tuple case binders) which is what we check with
+            -- `stgCaseBndrInScope` here. If the case binder is not in scope we
+            -- don't add it to the CSE env. See also #15300.
+            | stgCaseBndrInScope ty True -- CSE runs after unarise
+            = addDataCon case_bndr dataCon (map StgVarArg args') env1
+            | otherwise
+            = env1
+            -- see note [Case 2: CSEing case binders]
+          rhs' = stgCseExpr env2 rhs
+      in (DataAlt dataCon, args', rhs')
+stgCseAlt env _ _ (altCon, args, rhs)
+    = let (env1, args') = substBndrs env args
+          rhs' = stgCseExpr env1 rhs
+      in (altCon, args', rhs')
+
+-- Bindings
+stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
+stgCseBind env (StgNonRec b e)
+    = let (env1, b') = substBndr env b
+      in case stgCseRhs env1 b' e of
+        (Nothing,      env2) -> (Nothing,                env2)
+        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)
+stgCseBind env (StgRec pairs)
+    = let (env1, pairs1) = substPairs env pairs
+      in case stgCsePairs env1 pairs1 of
+        ([],     env2) -> (Nothing, env2)
+        (pairs2, env2) -> (Just (StgRec pairs2), env2)
+
+stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)
+stgCsePairs env [] = ([], env)
+stgCsePairs env0 ((b,e):pairs)
+  = let (pairMB, env1) = stgCseRhs env0 b e
+        (pairs', env2) = stgCsePairs env1 pairs
+    in (pairMB `mbCons` pairs', env2)
+  where
+    mbCons = maybe id (:)
+
+-- The RHS of a binding.
+-- If it is a constructor application, either short-cut it or extend the environment
+stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
+stgCseRhs env bndr (StgRhsCon ccs dataCon args)
+    | Just other_bndr <- envLookup dataCon args' env
+    = let env' = addSubst bndr other_bndr env
+      in (Nothing, env')
+    | otherwise
+    = let env' = addDataCon bndr dataCon args' env
+            -- see note [Case 1: CSEing allocated closures]
+          pair = (bndr, StgRhsCon ccs dataCon args')
+      in (Just pair, env')
+  where args' = substArgs env args
+stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
+    = let (env1, args') = substBndrs env args
+          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]
+          body' = stgCseExpr env2 body
+      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
+
+
+mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
+mkStgCase scrut bndr ty alts | all isBndr alts = scrut
+                             | otherwise       = StgCase scrut bndr ty alts
+
+  where
+    -- see Note [All alternatives are the binder]
+    isBndr (_, _, StgApp f []) = f == bndr
+    isBndr _                   = False
+
+
+-- Utilities
+
+-- | This function short-cuts let-bindings that are now obsolete
+mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b
+mkStgLet _      Nothing      body = body
+mkStgLet stgLet (Just binds) body = stgLet binds body
+
+
+{-
+Note [All alternatives are the binder]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When all alternatives simply refer to the case binder, then we do not have
+to bother with the case expression at all (#13588). CoreSTG does this as well,
+but sometimes, types get into the way:
+
+    newtype T = MkT Int
+    f :: (Int, Int) -> (T, Int)
+    f (x, y) = (MkT x, y)
+
+Core cannot just turn this into
+
+    f p = p
+
+as this would not be well-typed. But to STG, where MkT is no longer in the way,
+we can.
+
+Note [Trivial case scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to be able to handle nested reconstruction of constructors as in
+
+    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)
+    nested (Right (Right v)) = Right (Right v)
+    nested _ = Left True
+
+So if we come across
+
+    case x of r1
+      Right a -> case a of r2
+              Right b -> let v = Right b
+                         in Right v
+
+we first replace v with r2. Next we want to replace Right r2 with r1. But the
+ce_conAppMap contains Right a!
+
+Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use
+this substitution before looking Right r2 up in ce_conAppMap, and everything
+works out.
+
+Note [Free variables of an StgClosure]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+StgClosures (function and thunks) have an explicit list of free variables:
+
+foo [x] =
+    let not_a_free_var = Left [x]
+    let a_free_var = Right [x]
+    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var
+    in closure
+
+If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,
+then the list of free variables would be wrong, so for now, we do not CSE
+across such a closure, simply because I (Joachim) was not sure about possible
+knock-on effects. If deemed safe and worth the slight code complication of
+re-calculating this list during or after this pass, this can surely be done.
+-}
diff --git a/compiler/simplStg/StgLiftLams.hs b/compiler/simplStg/StgLiftLams.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams.hs
@@ -0,0 +1,102 @@
+-- | Implements a selective lambda lifter, running late in the optimisation
+-- pipeline.
+--
+-- The transformation itself is implemented in "StgLiftLams.Transformation".
+-- If you are interested in the cost model that is employed to decide whether
+-- to lift a binding or not, look at "StgLiftLams.Analysis".
+-- "StgLiftLams.LiftM" contains the transformation monad that hides away some
+-- plumbing of the transformation.
+module StgLiftLams (
+    -- * Late lambda lifting in STG
+    -- $note
+    Transformation.stgLiftLams
+  ) where
+
+import qualified StgLiftLams.Transformation as Transformation
+
+-- Note [Late lambda lifting in STG]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- $note
+-- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>
+-- and #9476.
+--
+-- The basic idea behind lambda lifting is to turn locally defined functions
+-- into top-level functions. Free variables are then passed as additional
+-- arguments at *call sites* instead of having a closure allocated for them at
+-- *definition site*. Example:
+--
+-- @
+--    let x = ...; y = ... in
+--    let f = {x y} \a -> a + x + y in
+--    let g = {f x} \b -> f b + x in
+--    g 5
+-- @
+--
+-- Lambda lifting @f@ would
+--
+--   1. Turn @f@'s free variables into formal parameters
+--   2. Update @f@'s call site within @g@ to @f x y b@
+--   3. Update @g@'s closure: Add @y@ as an additional free variable, while
+--      removing @f@, because @f@ no longer allocates and can be floated to
+--      top-level.
+--   4. Actually float the binding of @f@ to top-level, eliminating the @let@
+--      in the process.
+--
+-- This results in the following program (with free var annotations):
+--
+-- @
+--    f x y a = a + x + y;
+--    let x = ...; y = ... in
+--    let g = {x y} \b -> f x y b + x in
+--    g 5
+-- @
+--
+-- This optimisation is all about lifting only when it is beneficial to do so.
+-- The above seems like a worthwhile lift, judging from heap allocation:
+-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while
+-- not changing the size of @g@'s closure.
+--
+-- You can probably sense that there's some kind of cost model at play here.
+-- And you are right! But we also employ a couple of other heuristics for the
+-- lifting decision which are outlined in "StgLiftLams.Analysis#when".
+--
+-- The transformation is done in "StgLiftLams.Transformation", which calls out
+-- to 'StgLiftLams.Analysis.goodToLift' for its lifting decision.
+-- It relies on "StgLiftLams.LiftM", which abstracts some subtle STG invariants
+-- into a monadic substrate.
+--
+-- Suffice to say: We trade heap allocation for stack allocation.
+-- The additional arguments have to passed on the stack (or in registers,
+-- depending on architecture) every time we call the function to save a single
+-- heap allocation when entering the let binding. Nofib suggests a mean
+-- improvement of about 1% for this pass, so it seems like a worthwhile thing to
+-- do. Compile-times went up by 0.6%, so all in all a very modest change.
+--
+-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'
+-- that is ultimately compiled to something like this
+-- (module desugaring/lowering to actual STG):
+--
+-- @
+--    propagate dt = ...;
+--    runExperiment ... =
+--      let xs = ... in
+--      let ys = ... in
+--      let go = {dt go} \xs ys -> case (xs, ys) of
+--            ([], []) -> []
+--            (x:xs', y:ys') -> propagate dt x y : go xs' ys'
+--      in go xs ys
+-- @
+--
+-- This will lambda lift @go@ to top-level, speeding up the resulting program
+-- by roughly one percent:
+--
+-- @
+--    propagate dt = ...;
+--    go dt xs ys = case (xs, ys) of
+--      ([], []) -> []
+--      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'
+--    runExperiment ... =
+--      let xs = ... in
+--      let ys = ... in
+--      in go dt xs ys
+-- @
diff --git a/compiler/simplStg/StgLiftLams/Analysis.hs b/compiler/simplStg/StgLiftLams/Analysis.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams/Analysis.hs
@@ -0,0 +1,565 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+
+-- | Provides the heuristics for when it's beneficial to lambda lift bindings.
+-- Most significantly, this employs a cost model to estimate impact on heap
+-- allocations, by looking at an STG expression's 'Skeleton'.
+module StgLiftLams.Analysis (
+    -- * #when# When to lift
+    -- $when
+
+    -- * #clogro# Estimating closure growth
+    -- $clogro
+
+    -- * AST annotation
+    Skeleton(..), BinderInfo(..), binderInfoBndr,
+    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,
+    -- * Lifting decision
+    goodToLift,
+    closureGrowth -- Exported just for the docs
+  ) where
+
+import GhcPrelude
+
+import BasicTypes
+import Demand
+import DynFlags
+import Id
+import SMRep ( WordOff )
+import StgSyn
+import qualified StgCmmArgRep
+import qualified StgCmmClosure
+import qualified StgCmmLayout
+import Outputable
+import Util
+import VarSet
+
+import Data.Maybe ( mapMaybe )
+
+-- Note [When to lift]
+-- ~~~~~~~~~~~~~~~~~~~
+-- $when
+-- The analysis proceeds in two steps:
+--
+--   1. It tags the syntax tree with analysis information in the form of
+--      'BinderInfo' at each binder and 'Skeleton's at each let-binding
+--      by 'tagSkeletonTopBind' and friends.
+--   2. The resulting syntax tree is treated by the "StgLiftLams.Transformation"
+--      module, calling out to 'goodToLift' to decide if a binding is worthwhile
+--      to lift.
+--      'goodToLift' consults argument occurrence information in 'BinderInfo'
+--      and estimates 'closureGrowth', for which it needs the 'Skeleton'.
+--
+-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',
+-- which employs a number of heuristics to identify and exclude lambda lifting
+-- opportunities deemed non-beneficial:
+--
+--  [Top-level bindings] can't be lifted.
+--  [Thunks] and data constructors shouldn't be lifted in order not to destroy
+--    sharing.
+--  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.
+--    Doing the lift would re-introduce the very allocation at call sites that
+--    we tried to get rid off in the first place. We capture analysis
+--    information in 'BinderInfo'. Note that we also consider a nullary
+--    application as argument occurrence, because it would turn into an n-ary
+--    partial application created by a generic apply function. This occurs in
+--    CPS-heavy code like the CS benchmark.
+--  [Join points] should not be lifted, simply because there's no reduction in
+--    allocation to be had.
+--  [Abstracting over join points] destroys join points, because they end up as
+--    arguments to the lifted function.
+--  [Abstracting over known local functions] turns a known call into an unknown
+--    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off
+--    with @-fstg-lift-lams-known@.
+--  [Calling convention] Don't lift when the resulting function would have a
+--    higher arity than available argument registers for the calling convention.
+--    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.
+--  [Closure growth] introduced when former free variables have to be available
+--    at call sites may actually lead to an increase in overall allocations
+--  resulting from a lift. Estimating closure growth is described in
+--  "StgLiftLams.Analysis#clogro" and is what most of this module is ultimately
+--  concerned with.
+--
+-- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with
+-- some more background and history.
+
+-- Note [Estimating closure growth]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- $clogro
+-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',
+-- capturing only syntactic details relevant to 'closureGrowth', such as
+--
+--   * 'ClosureSk', representing closure allocation.
+--   * 'RhsSk', representing a RHS of a binding and how many times it's called
+--     by an appropriate 'DmdShell'.
+--   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.
+--
+-- This abstraction is mostly so that the main analysis function 'closureGrowth'
+-- can stay simple and focused. Also, skeletons tend to be much smaller than
+-- the syntax tree they abstract, so it makes sense to construct them once and
+-- and operate on them instead of the actual syntax tree.
+--
+-- A more detailed treatment of computing closure growth, including examples,
+-- can be found in the paper referenced from the
+-- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.
+
+llTrace :: String -> SDoc -> a -> a
+llTrace _ _ c = c
+-- llTrace a b c = pprTrace a b c
+
+type instance BinderP      'LiftLams = BinderInfo
+type instance XRhsClosure  'LiftLams = DIdSet
+type instance XLet         'LiftLams = Skeleton
+type instance XLetNoEscape 'LiftLams = Skeleton
+
+freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
+freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs
+
+-- | Captures details of the syntax tree relevant to the cost model, such as
+-- closures, multi-shot lambdas and case expressions.
+data Skeleton
+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
+  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton
+  | AltSk !Skeleton !Skeleton
+  | BothSk !Skeleton !Skeleton
+  | NilSk
+
+bothSk :: Skeleton -> Skeleton -> Skeleton
+bothSk NilSk b = b
+bothSk a NilSk = a
+bothSk a b     = BothSk a b
+
+altSk :: Skeleton -> Skeleton -> Skeleton
+altSk NilSk b = b
+altSk a NilSk = a
+altSk a b     = AltSk a b
+
+rhsSk :: DmdShell -> Skeleton -> Skeleton
+rhsSk _        NilSk = NilSk
+rhsSk body_dmd skel  = RhsSk body_dmd skel
+
+-- | The type used in binder positions in 'GenStgExpr's.
+data BinderInfo
+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
+                           --   indicating whether it occurs as an argument
+                           --   or in a nullary application
+                           --   (see "StgLiftLams.Analysis#arg_occs").
+  | BoringBinder !Id       -- ^ Every other kind of binder
+
+-- | Gets the bound 'Id' out a 'BinderInfo'.
+binderInfoBndr :: BinderInfo -> Id
+binderInfoBndr (BoringBinder bndr)   = bndr
+binderInfoBndr (BindsClosure bndr _) = bndr
+
+-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
+-- occurrences as argument or in a nullary applications otherwise.
+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
+binderInfoOccursAsArg BoringBinder{}     = Nothing
+binderInfoOccursAsArg (BindsClosure _ b) = Just b
+
+instance Outputable Skeleton where
+  ppr NilSk = text ""
+  ppr (AltSk l r) = vcat
+    [ text "{ " <+> ppr l
+    , text "ALT"
+    , text "  " <+> ppr r
+    , text "}"
+    ]
+  ppr (BothSk l r) = ppr l $$ ppr r
+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
+  ppr (RhsSk body_dmd body) = hcat
+    [ text "λ["
+    , ppr str
+    , text ", "
+    , ppr use
+    , text "]. "
+    , ppr body
+    ]
+    where
+      str
+        | isStrictDmd body_dmd = '1'
+        | otherwise = '0'
+      use
+        | isAbsDmd body_dmd = '0'
+        | isUsedOnce body_dmd = '1'
+        | otherwise = 'ω'
+
+instance Outputable BinderInfo where
+  ppr = ppr . binderInfoBndr
+
+instance OutputableBndr BinderInfo where
+  pprBndr b = pprBndr b . binderInfoBndr
+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr
+  pprInfixOcc = pprInfixOcc . binderInfoBndr
+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr
+
+mkArgOccs :: [StgArg] -> IdSet
+mkArgOccs = mkVarSet . mapMaybe stg_arg_var
+  where
+    stg_arg_var (StgVarArg occ) = Just occ
+    stg_arg_var _               = Nothing
+
+-- | Tags every binder with its 'BinderInfo' and let bindings with their
+-- 'Skeleton's.
+tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
+-- NilSk is OK when tagging top-level bindings. Also, top-level things are never
+-- lambda-lifted, so no need to track their argument occurrences. They can also
+-- never be let-no-escapes (thus we pass False).
+tagSkeletonTopBind bind = bind'
+  where
+    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind
+
+-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with
+-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder
+-- occurrences in argument and nullary application position
+-- (cf. "StgLiftLams.Analysis#arg_occs").
+tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
+tagSkeletonExpr (StgLit lit)
+  = (NilSk, emptyVarSet, StgLit lit)
+tagSkeletonExpr (StgConApp con args tys)
+  = (NilSk, mkArgOccs args, StgConApp con args tys)
+tagSkeletonExpr (StgOpApp op args ty)
+  = (NilSk, mkArgOccs args, StgOpApp op args ty)
+tagSkeletonExpr (StgApp f args)
+  = (NilSk, arg_occs, StgApp f args)
+  where
+    arg_occs
+      -- This checks for nullary applications, which we treat the same as
+      -- argument occurrences, see "StgLiftLams.Analysis#arg_occs".
+      | null args = unitVarSet f
+      | otherwise = mkArgOccs args
+tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
+tagSkeletonExpr (StgCase scrut bndr ty alts)
+  = (skel, arg_occs, StgCase scrut' bndr' ty alts')
+  where
+    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut
+    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts
+    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)
+    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr
+    bndr' = BoringBinder bndr
+tagSkeletonExpr (StgTick t e)
+  = (skel, arg_occs, StgTick t e')
+  where
+    (skel, arg_occs, e') = tagSkeletonExpr e
+tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind
+tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind
+
+mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
+mkLet True = StgLetNoEscape
+mkLet _    = StgLet
+
+tagSkeletonLet
+  :: Bool
+  -- ^ Is the binding a let-no-escape?
+  -> CgStgExpr
+  -- ^ Let body
+  -> CgStgBinding
+  -- ^ Binding group
+  -> (Skeleton, IdSet, LlStgExpr)
+  -- ^ RHS skeletons, argument occurrences and annotated binding
+tagSkeletonLet is_lne body bind
+  = (let_skel, arg_occs, mkLet is_lne scope bind' body')
+  where
+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
+    (let_skel, arg_occs, scope, bind')
+      = tagSkeletonBinding is_lne body_skel body_arg_occs bind
+
+tagSkeletonBinding
+  :: Bool
+  -- ^ Is the binding a let-no-escape?
+  -> Skeleton
+  -- ^ Let body skeleton
+  -> IdSet
+  -- ^ Argument occurrences in the body
+  -> CgStgBinding
+  -- ^ Binding group
+  -> (Skeleton, IdSet, Skeleton, LlStgBinding)
+  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and
+  --   the annotated binding
+tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)
+  = (let_skel, arg_occs, scope, bind')
+  where
+    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs
+    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr
+    bind_skel
+      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes
+      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel
+    let_skel = bothSk body_skel bind_skel
+    occurs_as_arg = bndr `elemVarSet` body_arg_occs
+    -- Compared to the recursive case, this exploits the fact that @bndr@ is
+    -- never free in @rhs@.
+    scope = body_skel
+    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'
+tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
+  = (let_skel, arg_occs, scope, StgRec pairs')
+  where
+    (bndrs, _) = unzip pairs
+    -- Local recursive STG bindings also regard the defined binders as free
+    -- vars. We want to delete those for our cost model, as these are known
+    -- calls anyway when we add them to the same top-level recursive group as
+    -- the top-level binding currently being analysed.
+    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs
+    rhss_arg_occs = map sndOf3 skel_occs_rhss'
+    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)
+    arg_occs = scope_occs `delVarSetList` bndrs
+    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,
+    -- but we also need the un-wrapped skeletons for calculating the @scope@
+    -- of the group, as the outer closures don't contribute to closure growth
+    -- when we lift this specific binding.
+    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'
+    -- Now we can build the actual Skeleton for the expression just by
+    -- iterating over each bind pair.
+    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')
+    let_skel = foldr bothSk body_skel bind_skels
+    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))
+      where
+        -- Here, we finally add the closure around each @skel_rhs@.
+        bind_skel
+          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes
+          | otherwise = ClosureSk bndr fvs skel_rhs
+        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs
+        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
+
+tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
+tagSkeletonRhs _ (StgRhsCon ccs dc args)
+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)
+tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
+  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
+  where
+    bndrs' = map BoringBinder bndrs
+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
+    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel
+
+-- | How many times will the lambda body of the RHS bound to the given
+-- identifier be evaluated, relative to its defining context? This function
+-- computes the answer in form of a 'DmdShell'.
+rhsDmdShell :: Id -> DmdShell
+rhsDmdShell bndr
+  | is_thunk = oneifyDmd ds
+  | otherwise = peelManyCalls (idArity bndr) cd
+  where
+    is_thunk = idArity bndr == 0
+    -- Let's pray idDemandInfo is still OK after unarise...
+    (ds, cd) = toCleanDmd (idDemandInfo bndr)
+
+tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
+tagSkeletonAlt (con, bndrs, rhs)
+  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))
+  where
+    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs
+    arg_occs = alt_arg_occs `delVarSetList` bndrs
+
+-- | Combines several heuristics to decide whether to lambda-lift a given
+-- @let@-binding to top-level. See "StgLiftLams.Analysis#when" for details.
+goodToLift
+  :: DynFlags
+  -> TopLevelFlag
+  -> RecFlag
+  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into
+                        -- 'OutId's. See 'StgLiftLams.LiftM.liftedIdsExpander'.
+  -> [(BinderInfo, LlStgRhs)]
+  -> Skeleton
+  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to
+                        -- lift and @abs_ids@ are the variables it would
+                        -- abstract over
+goodToLift dflags top_lvl rec_flag expander pairs scope = decide
+  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]
+  , ("memoized", any_memoized)
+  , ("argument occurrences", arg_occs)
+  , ("join point", is_join_point)
+  , ("abstracts join points", abstracts_join_ids)
+  , ("abstracts known local function", abstracts_known_local_fun)
+  , ("args spill on stack", args_spill_on_stack)
+  , ("increases allocation", inc_allocs)
+  ] where
+      decide deciders
+        | not (fancy_or deciders)
+        = llTrace "stgLiftLams:lifting"
+                  (ppr bndrs <+> ppr abs_ids $$
+                   ppr allocs $$
+                   ppr scope) $
+          Just abs_ids
+        | otherwise
+        = Nothing
+      ppr_deciders = vcat . map (text . fst) . filter snd
+      fancy_or deciders
+        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $
+          any snd deciders
+
+      bndrs = map (binderInfoBndr . fst) pairs
+      bndrs_set = mkVarSet bndrs
+      rhss = map snd pairs
+
+      -- First objective: Calculate @abs_ids@, e.g. the former free variables
+      -- the lifted binding would abstract over. We have to merge the free
+      -- variables of all RHS to get the set of variables that will have to be
+      -- passed through parameters.
+      fvs = unionDVarSets (map freeVarsOfRhs rhss)
+      -- To lift the binding to top-level, we want to delete the lifted binders
+      -- themselves from the free var set. Local let bindings track recursive
+      -- occurrences in their free variable set. We neither want to apply our
+      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters
+      -- when lifted, as these are known calls. We call the resulting set the
+      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.
+      -- We will save the set in 'LiftM.e_expansions' for each of the variables
+      -- if we perform the lift.
+      abs_ids = expander (delDVarSetList fvs bndrs)
+
+      -- We don't lift updatable thunks or constructors
+      any_memoized = any is_memoized_rhs rhss
+      is_memoized_rhs StgRhsCon{} = True
+      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd
+
+      -- Don't lift binders occuring as arguments. This would result in complex
+      -- argument expressions which would have to be given a name, reintroducing
+      -- the very allocation at each call site that we wanted to get rid off in
+      -- the first place.
+      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)
+
+      -- These don't allocate anyway.
+      is_join_point = any isJoinId bndrs
+
+      -- Abstracting over join points/let-no-escapes spoils them.
+      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)
+
+      -- Abstracting over known local functions that aren't floated themselves
+      -- turns a known, fast call into an unknown, slow call:
+      --
+      --    let f x = ...
+      --        g y = ... f x ... -- this was a known call
+      --    in g 4
+      --
+      -- After lifting @g@, but not @f@:
+      --
+      --    l_g f y = ... f y ... -- this is now an unknown call
+      --    let f x = ...
+      --    in l_g f 4
+      --
+      -- We can abuse the results of arity analysis for this:
+      -- idArity f > 0 ==> known
+      known_fun id = idArity id > 0
+      abstracts_known_local_fun
+        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)
+
+      -- Number of arguments of a RHS in the current binding group if we decide
+      -- to lift it
+      n_args
+        = length
+        . StgCmmClosure.nonVoidIds -- void parameters don't appear in Cmm
+        . (dVarSetElems abs_ids ++)
+        . rhsLambdaBndrs
+      max_n_args
+        | isRec rec_flag = liftLamsRecArgs dflags
+        | otherwise      = liftLamsNonRecArgs dflags
+      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess
+      -- args are passed on the stack, which means slow memory accesses
+      args_spill_on_stack
+        | Just n <- max_n_args = maximum (map n_args rhss) > n
+        | otherwise = False
+
+      -- We only perform the lift if allocations didn't increase.
+      -- Note that @clo_growth@ will be 'infinity' if there was positive growth
+      -- under a multi-shot lambda.
+      -- Also, abstracting over LNEs is unacceptable. LNEs might return
+      -- unlifted tuples, which idClosureFootprint can't cope with.
+      inc_allocs = abstracts_join_ids || allocs > 0
+      allocs = clo_growth + mkIntWithInf (negate closuresSize)
+      -- We calculate and then add up the size of each binding's closure.
+      -- GHC does not currently share closure environments, and we either lift
+      -- the entire recursive binding group or none of it.
+      closuresSize = sum $ flip map rhss $ \rhs ->
+        closureSize dflags
+        . dVarSetElems
+        . expander
+        . flip dVarSetMinusVarSet bndrs_set
+        $ freeVarsOfRhs rhs
+      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope
+
+rhsLambdaBndrs :: LlStgRhs -> [Id]
+rhsLambdaBndrs StgRhsCon{} = []
+rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs
+
+-- | The size in words of a function closure closing over the given 'Id's,
+-- including the header.
+closureSize :: DynFlags -> [Id] -> WordOff
+closureSize dflags ids = words + sTD_HDR_SIZE dflags
+  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't
+  -- optimise differently when profiling is enabled.
+  where
+    (words, _, _)
+      -- Functions have a StdHeader (as opposed to ThunkHeader).
+      = StgCmmLayout.mkVirtHeapOffsets dflags StgCmmLayout.StdHeader
+      . StgCmmClosure.addIdReps
+      . StgCmmClosure.nonVoidIds
+      $ ids
+
+-- | The number of words a single 'Id' adds to a closure's size.
+-- Note that this can't handle unboxed tuples (which may still be present in
+-- let-no-escapes, even after Unarise), in which case
+-- @'StgCmmClosure.idPrimRep'@ will crash.
+idClosureFootprint:: DynFlags -> Id -> WordOff
+idClosureFootprint dflags
+  = StgCmmArgRep.argRepSizeW dflags
+  . StgCmmArgRep.idArgRep
+
+-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
+-- as a result of lifting @f@ to top-level. If there was any growing closure
+-- under a multi-shot lambda, the result will be 'infinity'.
+-- Also see "StgLiftLams.Analysis#clogro".
+closureGrowth
+  :: (DIdSet -> DIdSet)
+  -- ^ Expands outer free ids that were lifted to their free vars
+  -> (Id -> Int)
+  -- ^ Computes the closure footprint of an identifier
+  -> IdSet
+  -- ^ Binding group for which lifting is to be decided
+  -> DIdSet
+  -- ^ Free vars of the whole binding group prior to lifting it. These must be
+  --   available at call sites if we decide to lift the binding group.
+  -> Skeleton
+  -- ^ Abstraction of the scope of the function
+  -> IntWithInf
+  -- ^ Closure growth. 'infinity' indicates there was growth under a
+  --   (multi-shot) lambda.
+closureGrowth expander sizer group abs_ids = go
+  where
+    go NilSk = 0
+    go (BothSk a b) = go a + go b
+    go (AltSk a b) = max (go a) (go b)
+    go (ClosureSk _ clo_fvs rhs)
+      -- If no binder of the @group@ occurs free in the closure, the lifting
+      -- won't have any effect on it and we can omit the recursive call.
+      | n_occs == 0 = 0
+      -- Otherwise, we account the cost of allocating the closure and add it to
+      -- the closure growth of its RHS.
+      | otherwise   = mkIntWithInf cost + go rhs
+      where
+        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)
+        -- What we close over considering prior lifting decisions
+        clo_fvs' = expander clo_fvs
+        -- Variables that would additionally occur free in the closure body if
+        -- we lift @f@
+        newbies = abs_ids `minusDVarSet` clo_fvs'
+        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@
+        cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs
+    go (RhsSk body_dmd body)
+      -- The conservative assumption would be that
+      --   1. Every RHS with positive growth would be called multiple times,
+      --      modulo thunks.
+      --   2. Every RHS with negative growth wouldn't be called at all.
+      --
+      -- In the first case, we'd have to return 'infinity', while in the
+      -- second case, we'd have to return 0. But we can do far better
+      -- considering information from the demand analyser, which provides us
+      -- with conservative estimates on minimum and maximum evaluation
+      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of
+      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body
+      -- relative to its defining context.
+      | isAbsDmd body_dmd   = 0
+      | cg <= 0             = if isStrictDmd body_dmd then cg else 0
+      | isUsedOnce body_dmd = cg
+      | otherwise           = infinity
+      where
+        cg = go body
diff --git a/compiler/simplStg/StgLiftLams/LiftM.hs b/compiler/simplStg/StgLiftLams/LiftM.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams/LiftM.hs
@@ -0,0 +1,348 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'
+-- monad.
+module StgLiftLams.LiftM (
+    decomposeStgBinding, mkStgBinding,
+    Env (..),
+    -- * #floats# Handling floats
+    -- $floats
+    FloatLang (..), collectFloats, -- Exported just for the docs
+    -- * Transformation monad
+    LiftM, runLiftM, withCaffyness,
+    -- ** Adding bindings
+    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,
+    -- ** Substitution and binders
+    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,
+    -- ** Occurrences
+    substOcc, isLifted, formerFreeVars, liftedIdsExpander
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import CostCentre ( isCurrentCCS, dontCareCCS )
+import DynFlags
+import FastString
+import Id
+import IdInfo
+import Name
+import Outputable
+import OrdList
+import StgSubst
+import StgSyn
+import Type
+import UniqSupply
+import Util
+import VarEnv
+import VarSet
+
+import Control.Arrow ( second )
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )
+import qualified Control.Monad.Trans.RWS.Strict as RWS
+import Control.Monad.Trans.Cont ( ContT (..) )
+import Data.ByteString ( ByteString )
+
+-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@
+decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
+decomposeStgBinding (StgRec pairs) = (Recursive, pairs)
+decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])
+
+mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
+mkStgBinding Recursive = StgRec
+mkStgBinding NonRecursive = uncurry StgNonRec . head
+
+-- | Environment threaded around in a scoped, @Reader@-like fashion.
+data Env
+  = Env
+  { e_dflags     :: !DynFlags
+  -- ^ Read-only.
+  , e_subst      :: !Subst
+  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',
+  -- because shadowing might make a closure's free variables unavailable at its
+  -- call sites. Consider:
+  -- @
+  --    let f y = x + y in let x = 4 in f x
+  -- @
+  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't
+  -- available at its call site.
+  , e_expansions :: !(IdEnv DIdSet)
+  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because
+  -- they are bound at the top-level. Every occurrence must supply the formerly
+  -- free variables of the lifted 'Id', so they in turn become free variables of
+  -- the call sites. This environment tracks this expansion from lifted 'Id's to
+  -- their free variables.
+  --
+  -- 'InId's to 'OutId's.
+  --
+  -- Invariant: 'Id's not present in this map won't be substituted.
+  , e_in_caffy_context :: !Bool
+  -- ^ Are we currently analysing within a caffy context (e.g. the containing
+  -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely
+  -- assume that functions we lift out aren't caffy either.
+  }
+
+emptyEnv :: DynFlags -> Env
+emptyEnv dflags = Env dflags emptySubst emptyVarEnv False
+
+
+-- Note [Handling floats]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- $floats
+-- Consider the following expression:
+--
+-- @
+--     f x =
+--       let g y = ... f y ...
+--       in g x
+-- @
+--
+-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@
+-- binding above the binding for @f@:
+--
+-- @
+--     g f y = ... f y ...
+--     f x = g f x
+-- @
+--
+-- But this very unnecessarily turns a known call to @f@ into an unknown one, in
+-- addition to complicating matters for the analysis.
+-- Instead, we'd really like to put both functions in the same recursive group,
+-- thereby preserving the known call:
+--
+-- @
+--     Rec {
+--       g y = ... f y ...
+--       f x = g x
+--     }
+-- @
+--
+-- But we don't want this to happen for just /any/ binding. That would create
+-- possibly huge recursive groups in the process, calling for an occurrence
+-- analyser on STG.
+-- So, we need to track when we lift a binding out of a recursive RHS and add
+-- the binding to the same recursive group as the enclosing recursive binding
+-- (which must have either already been at the top-level or decided to be
+-- lifted itself in order to preserve the known call).
+--
+-- This is done by expressing this kind of nesting structure as a 'Writer' over
+-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to
+-- 'collectFloats'.
+-- API-wise, the analysis will not need to know about the whole 'FloatLang'
+-- business and will just manipulate it indirectly through actions in 'LiftM'.
+
+-- | We need to detect when we are lifting something out of the RHS of a
+-- recursive binding (c.f. "StgLiftLams.LiftM#floats"), in which case that
+-- binding needs to be added to the same top-level recursive group. This
+-- requires we detect a certain nesting structure, which is encoded by
+-- 'StartBindingGroup' and 'EndBindingGroup'.
+--
+-- Although 'collectFloats' will only ever care if the current binding to be
+-- lifted (through 'LiftedBinding') will occur inside such a binding group or
+-- not, e.g. doesn't care about the nesting level as long as its greater than 0.
+data FloatLang
+  = StartBindingGroup
+  | EndBindingGroup
+  | PlainTopBinding OutStgTopBinding
+  | LiftedBinding OutStgBinding
+
+instance Outputable FloatLang where
+  ppr StartBindingGroup = char '('
+  ppr EndBindingGroup = char ')'
+  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"
+  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)
+  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)
+    where
+      (rec, pairs) = decomposeStgBinding bind
+
+-- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.
+-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and
+-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding
+-- group has at least one recursive binding inside. Otherwise there's no point
+-- in announcing the binding group in the first place and an @ASSERT@ will
+-- trigger.
+collectFloats :: [FloatLang] -> [OutStgTopBinding]
+collectFloats = go (0 :: Int) []
+  where
+    go 0 [] [] = []
+    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")
+    go n binds (f:rest) = case f of
+      StartBindingGroup -> go (n+1) binds rest
+      EndBindingGroup
+        | n == 0 -> pprPanic "collectFloats" (text "no group to end")
+        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest
+        | otherwise -> go (n-1) binds rest
+      PlainTopBinding top_bind
+        | n == 0 -> top_bind : go n binds rest
+        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")
+      LiftedBinding bind
+        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest
+        | otherwise -> go n (bind:binds) rest
+
+    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding
+    rm_cccs = map_rhss removeRhsCCCS
+    merge_binds binds = ASSERT( any is_rec binds )
+                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)
+    is_rec StgRec{} = True
+    is_rec _ = False
+
+-- | Omitting this makes for strange closure allocation schemes that crash the
+-- GC.
+removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
+removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
+  | isCurrentCCS ccs
+  = StgRhsClosure ext dontCareCCS upd bndrs body
+removeRhsCCCS (StgRhsCon ccs con args)
+  | isCurrentCCS ccs
+  = StgRhsCon dontCareCCS con args
+removeRhsCCCS rhs = rhs
+
+-- | The analysis monad consists of the following 'RWST' components:
+--
+--     * 'Env': Reader-like context. Contains a substitution, info about how
+--       how lifted identifiers are to be expanded into applications and details
+--       such as 'DynFlags' and a flag helping with determining if a lifted
+--       binding is caffy.
+--
+--     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.
+--
+--     * No pure state component
+--
+--     * But wrapping around 'UniqSM' for generating fresh lifted binders.
+--       (The @uniqAway@ approach could give the same name to two different
+--       lifted binders, so this is necessary.)
+newtype LiftM a
+  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }
+  deriving (Functor, Applicative, Monad)
+
+instance HasDynFlags LiftM where
+  getDynFlags = LiftM (RWS.asks e_dflags)
+
+instance MonadUnique LiftM where
+  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)
+  getUniqueM = LiftM (lift getUniqueM)
+  getUniquesM = LiftM (lift getUniquesM)
+
+runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]
+runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)
+  where
+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())
+
+-- | Assumes a given caffyness for the execution of the passed action, which
+-- influences the 'cafInfo' of lifted bindings.
+withCaffyness :: Bool -> LiftM a -> LiftM a
+withCaffyness caffy action
+  = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action))
+
+-- | Writes a plain 'StgTopStringLit' to the output.
+addTopStringLit :: OutId -> ByteString -> LiftM ()
+addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id
+
+-- | Starts a recursive binding group. See #floats# and 'collectFloats'.
+startBindingGroup :: LiftM ()
+startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup
+
+-- | Ends a recursive binding group. See #floats# and 'collectFloats'.
+endBindingGroup :: LiftM ()
+endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup
+
+-- | Lifts a binding to top-level. Depending on whether it's declared inside
+-- a recursive RHS (see #floats# and 'collectFloats'), this might be added to
+-- an existing recursive top-level binding group.
+addLiftedBinding :: OutStgBinding -> LiftM ()
+addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding
+
+-- | Takes a binder and a continuation which is called with the substituted
+-- binder. The continuation will be evaluated in a 'LiftM' context in which that
+-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After
+-- the continuation finishes, the new binding won't be in scope anymore.
+withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a
+withSubstBndr bndr inner = LiftM $ do
+  subst <- RWS.asks e_subst
+  let (bndr', subst') = substBndr bndr subst
+  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))
+
+-- | See 'withSubstBndr'.
+withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a
+withSubstBndrs = runContT . traverse (ContT . withSubstBndr)
+
+-- | Similarly to 'withSubstBndr', this function takes a set of variables to
+-- abstract over, the binder to lift (and generate a fresh, substituted name
+-- for) and a continuation in which that fresh, lifted binder is in scope.
+--
+-- It takes care of all the details involved with copying and adjusting the
+-- binder, fresh name generation and caffyness.
+withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a
+withLiftedBndr abs_ids bndr inner = do
+  uniq <- getUniqueM
+  let str = "$l" ++ occNameString (getOccName bndr)
+  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)
+  -- When the enclosing top-level binding is not caffy, then the lifted
+  -- binding will not be caffy either. If we don't recognize this, non-caffy
+  -- things call caffy things and then codegen screws up.
+  in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context)
+  let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs
+  let bndr'
+        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least
+        -- for arity information.
+        = transferPolyIdInfo bndr (dVarSetElems abs_ids)
+        -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is
+        -- assumed to be caffy and will need an SRT. Transitive call sites might
+        -- not be caffy themselves and subsequently will miss a static link
+        -- field in their closure. Chaos ensues.
+        . flip setIdCafInfo caf_info
+        . mkSysLocalOrCoVar (mkFastString str) uniq
+        $ ty
+  LiftM $ RWS.local
+    (\e -> e
+      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e
+      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids
+      })
+    (unwrapLiftM (inner bndr'))
+
+-- | See 'withLiftedBndr'.
+withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
+withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)
+
+-- | Substitutes a binder /occurrence/, which was brought in scope earlier by
+-- 'withSubstBndr'\/'withLiftedBndr'.
+substOcc :: Id -> LiftM Id
+substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))
+
+-- | Whether the given binding was decided to be lambda lifted.
+isLifted :: InId -> LiftM Bool
+isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))
+
+-- | Returns an empty list for a binding that was not lifted and the list of all
+-- local variables the binding abstracts over (so, exactly the additional
+-- arguments at adjusted call sites) otherwise.
+formerFreeVars :: InId -> LiftM [OutId]
+formerFreeVars f = LiftM $ do
+  expansions <- RWS.asks e_expansions
+  pure $ case lookupVarEnv expansions f of
+    Nothing -> []
+    Just fvs -> dVarSetElems fvs
+
+-- | Creates an /expander function/ for the current set of lifted binders.
+-- This expander function will replace any 'InId' by their corresponding 'OutId'
+-- and, in addition, will expand any lifted binders by the former free variables
+-- it abstracts over.
+liftedIdsExpander :: LiftM (DIdSet -> DIdSet)
+liftedIdsExpander = LiftM $ do
+  expansions <- RWS.asks e_expansions
+  subst <- RWS.asks e_subst
+  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"
+  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.
+  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in
+  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much
+  -- trouble.
+  let go set fv = case lookupVarEnv expansions fv of
+        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted
+        Just fvs' -> unionDVarSet set fvs'
+  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)
+  pure expander
diff --git a/compiler/simplStg/StgLiftLams/Transformation.hs b/compiler/simplStg/StgLiftLams/Transformation.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams/Transformation.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE CPP #-}
+
+-- | (Mostly) textbook instance of the lambda lifting transformation,
+-- selecting which bindings to lambda lift by consulting 'goodToLift'.
+module StgLiftLams.Transformation (stgLiftLams) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import DynFlags
+import Id
+import IdInfo
+import StgFVs ( annBindingFreeVars )
+import StgLiftLams.Analysis
+import StgLiftLams.LiftM
+import StgSyn
+import Outputable
+import UniqSupply
+import Util
+import VarSet
+import Control.Monad ( when )
+import Data.Maybe ( isNothing )
+
+-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').
+stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
+stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())
+
+liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
+liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
+  addTopStringLit bndr' lit
+  rest
+liftTopLvl (StgTopLifted bind) rest = do
+  let is_rec = isRec $ fst $ decomposeStgBinding bind
+  when is_rec startBindingGroup
+  let bind_w_fvs = annBindingFreeVars bind
+  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do
+    -- We signal lifting of a binding through returning Nothing.
+    -- Should never happen for a top-level binding, though, since we are already
+    -- at top-level.
+    case mb_bind' of
+      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")
+      Just bind' -> addLiftedBinding bind'
+    when is_rec endBindingGroup
+    rest
+
+withLiftedBind
+  :: TopLevelFlag
+  -> LlStgBinding
+  -> Skeleton
+  -> (Maybe OutStgBinding -> LiftM a)
+  -> LiftM a
+withLiftedBind top_lvl bind scope k
+  | isTopLevel top_lvl
+  = withCaffyness (is_caffy pairs) go
+  | otherwise
+  = go
+  where
+    (rec, pairs) = decomposeStgBinding bind
+    is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)
+    go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))
+
+withLiftedBindPairs
+  :: TopLevelFlag
+  -> RecFlag
+  -> [(BinderInfo, LlStgRhs)]
+  -> Skeleton
+  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
+  -> LiftM a
+withLiftedBindPairs top rec pairs scope k = do
+  let (infos, rhss) = unzip pairs
+  let bndrs = map binderInfoBndr infos
+  expander <- liftedIdsExpander
+  dflags <- getDynFlags
+  case goodToLift dflags top rec expander pairs scope of
+    -- @abs_ids@ is the set of all variables that need to become parameters.
+    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do
+      -- Within this block, all binders in @bndrs@ will be noted as lifted, so
+      -- that the return value of @liftedIdsExpander@ in this context will also
+      -- expand the bindings in @bndrs@ to their free variables.
+      -- Now we can recurse into the RHSs and see if we can lift any further
+      -- bindings. We pass the set of expanded free variables (thus OutIds) on
+      -- to @liftRhs@ so that it can add them as parameter binders.
+      when (isRec rec) startBindingGroup
+      rhss' <- traverse (liftRhs (Just abs_ids)) rhss
+      let pairs' = zip bndrs' rhss'
+      addLiftedBinding (mkStgBinding rec pairs')
+      when (isRec rec) endBindingGroup
+      k Nothing
+    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do
+      -- Don't lift the current binding, but possibly some bindings in their
+      -- RHSs.
+      rhss' <- traverse (liftRhs Nothing) rhss
+      let pairs' = zip bndrs' rhss'
+      k (Just pairs')
+
+liftRhs
+  :: Maybe (DIdSet)
+  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@
+  -- as lambda binders, discarding all free vars.
+  -> LlStgRhs
+  -> LiftM OutStgRhs
+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)
+  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)
+    StgRhsCon ccs con <$> traverse liftArgs args
+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do
+  -- This RHS wasn't lifted.
+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+    StgRhsClosure noExtSilent ccs upd bndrs' <$> liftExpr body
+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do
+  -- This RHS was lifted. Insert extra binders for @former_fvs@.
+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do
+    let bndrs'' = dVarSetElems former_fvs ++ bndrs'
+    StgRhsClosure noExtSilent ccs upd bndrs'' <$> liftExpr body
+
+liftArgs :: InStgArg -> LiftM OutStgArg
+liftArgs a@(StgLitArg _) = pure a
+liftArgs (StgVarArg occ) = do
+  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
+  StgVarArg <$> substOcc occ
+
+liftExpr :: LlStgExpr -> LiftM OutStgExpr
+liftExpr (StgLit lit) = pure (StgLit lit)
+liftExpr (StgTick t e) = StgTick t <$> liftExpr e
+liftExpr (StgApp f args) = do
+  f' <- substOcc f
+  args' <- traverse liftArgs args
+  fvs' <- formerFreeVars f
+  let top_lvl_args = map StgVarArg fvs' ++ args'
+  pure (StgApp f' top_lvl_args)
+liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys
+liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
+liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
+liftExpr (StgCase scrut info ty alts) = do
+  scrut' <- liftExpr scrut
+  withSubstBndr (binderInfoBndr info) $ \bndr' -> do
+    alts' <- traverse liftAlt alts
+    pure (StgCase scrut' bndr' ty alts')
+liftExpr (StgLet scope bind body)
+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
+      body' <- liftExpr body
+      case mb_bind' of
+        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats
+        Just bind' -> pure (StgLet noExtSilent bind' body')
+liftExpr (StgLetNoEscape scope bind body)
+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
+      body' <- liftExpr body
+      case mb_bind' of
+        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")
+        Just bind' -> pure (StgLetNoEscape noExtSilent bind' body')
+
+liftAlt :: LlStgAlt -> LiftM OutStgAlt
+liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+  (,,) con bndrs' <$> liftExpr rhs
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgStats.hs
@@ -0,0 +1,173 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[StgStats]{Gathers statistical information about programs}
+
+
+The program gather statistics about
+\begin{enumerate}
+\item number of boxed cases
+\item number of unboxed cases
+\item number of let-no-escapes
+\item number of non-updatable lets
+\item number of updatable lets
+\item number of applications
+\item number of primitive applications
+\item number of closures (does not include lets bound to constructors)
+\item number of free variables in closures
+%\item number of top-level functions
+%\item number of top-level CAFs
+\item number of constructors
+\end{enumerate}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module StgStats ( showStgStats ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+
+import Id (Id)
+import Panic
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+data CounterType
+  = Literals
+  | Applications
+  | ConstructorApps
+  | PrimitiveApps
+  | LetNoEscapes
+  | StgCases
+  | FreeVariables
+  | ConstructorBinds Bool{-True<=>top-level-}
+  | ReEntrantBinds   Bool{-ditto-}
+  | SingleEntryBinds Bool{-ditto-}
+  | UpdatableBinds   Bool{-ditto-}
+  deriving (Eq, Ord)
+
+type Count      = Int
+type StatEnv    = Map CounterType Count
+
+emptySE :: StatEnv
+emptySE = Map.empty
+
+combineSE :: StatEnv -> StatEnv -> StatEnv
+combineSE = Map.unionWith (+)
+
+combineSEs :: [StatEnv] -> StatEnv
+combineSEs = foldr combineSE emptySE
+
+countOne :: CounterType -> StatEnv
+countOne c = Map.singleton c 1
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Top-level list of bindings (a ``program'')}
+*                                                                      *
+************************************************************************
+-}
+
+showStgStats :: [StgTopBinding] -> String
+
+showStgStats prog
+  = "STG Statistics:\n\n"
+    ++ concat (map showc (Map.toList (gatherStgStats prog)))
+  where
+    showc (x,n) = (showString (s x) . shows n) "\n"
+
+    s Literals                = "Literals                   "
+    s Applications            = "Applications               "
+    s ConstructorApps         = "ConstructorApps            "
+    s PrimitiveApps           = "PrimitiveApps              "
+    s LetNoEscapes            = "LetNoEscapes               "
+    s StgCases                = "StgCases                   "
+    s FreeVariables           = "FreeVariables              "
+    s (ConstructorBinds True) = "ConstructorBinds_Top       "
+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
+
+gatherStgStats :: [StgTopBinding] -> StatEnv
+gatherStgStats binds = combineSEs (map statTopBinding binds)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+statTopBinding :: StgTopBinding -> StatEnv
+statTopBinding (StgTopStringLit _ _) = countOne Literals
+statTopBinding (StgTopLifted bind) = statBinding True bind
+
+statBinding :: Bool -- True <=> top-level; False <=> nested
+            -> StgBinding
+            -> StatEnv
+
+statBinding top (StgNonRec b rhs)
+  = statRhs top (b, rhs)
+
+statBinding top (StgRec pairs)
+  = combineSEs (map (statRhs top) pairs)
+
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
+
+statRhs top (_, StgRhsCon _ _ _)
+  = countOne (ConstructorBinds top)
+
+statRhs top (_, StgRhsClosure _ _ u _ body)
+  = statExpr body `combineSE`
+    countOne (
+      case u of
+        ReEntrant   -> ReEntrantBinds   top
+        Updatable   -> UpdatableBinds   top
+        SingleEntry -> SingleEntryBinds top
+    )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Expressions}
+*                                                                      *
+************************************************************************
+-}
+
+statExpr :: StgExpr -> StatEnv
+
+statExpr (StgApp _ _)     = countOne Applications
+statExpr (StgLit _)       = countOne Literals
+statExpr (StgConApp _ _ _)= countOne ConstructorApps
+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgTick _ e)    = statExpr e
+
+statExpr (StgLetNoEscape _ binds body)
+  = statBinding False{-not top-level-} binds    `combineSE`
+    statExpr body                               `combineSE`
+    countOne LetNoEscapes
+
+statExpr (StgLet _ binds body)
+  = statBinding False{-not top-level-} binds    `combineSE`
+    statExpr body
+
+statExpr (StgCase expr _ _ alts)
+  = statExpr expr       `combineSE`
+    stat_alts alts      `combineSE`
+    countOne StgCases
+  where
+    stat_alts alts
+        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])
+
+statExpr (StgLam {}) = panic "statExpr StgLam"
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/UnariseStg.hs
@@ -0,0 +1,767 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-2012
+
+Note [Unarisation]
+~~~~~~~~~~~~~~~~~~
+The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
+binders. So for example:
+
+  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
+
+  ==>
+
+  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
+
+It is important that we do this at the STG level and NOT at the Core level
+because it would be very hard to make this pass Core-type-preserving. In this
+example the type of 'f' changes, for example.
+
+STG fed to the code generators *must* be unarised because the code generators do
+not support unboxed tuple and unboxed sum binders natively.
+
+In more detail: (see next note for unboxed sums)
+
+Suppose that a variable x : (# t1, t2 #).
+
+  * At the binding site for x, make up fresh vars  x1:t1, x2:t2
+
+  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]
+
+  * Replace the binding with a curried binding for x1,x2
+
+       Lambda:   \x.e                ==>   \x1 x2. e
+       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e
+
+  * Replace argument occurrences with a sequence of args via a lookup in
+    UnariseEnv
+
+       f a b x c d   ==>   f a b x1 x2 c d
+
+  * Replace tail-call occurrences with an unboxed tuple via a lookup in
+    UnariseEnv
+
+       x  ==>  (# x1, x2 #)
+
+    So, for example
+
+       f x = x    ==>   f x1 x2 = (# x1, x2 #)
+
+  * We /always/ eliminate a case expression when
+
+       - It scrutinises an unboxed tuple or unboxed sum
+
+       - The scrutinee is a variable (or when it is an explicit tuple, but the
+         simplifier eliminates those)
+
+    The case alternative (there can be only one) can be one of these two
+    things:
+
+      - An unboxed tuple pattern. e.g.
+
+          case v of x { (# x1, x2, x3 #) -> ... }
+
+        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
+        environment with
+
+          x :-> MultiVal [t1,t2,t3]
+          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
+
+      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
+
+By the end of this pass, we only have unboxed tuples in return positions.
+Unboxed sums are completely eliminated, see next note.
+
+Note [Translating unboxed sums to unboxed tuples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unarise also eliminates unboxed sum binders, and translates unboxed sums in
+return positions to unboxed tuples. We want to overlap fields of a sum when
+translating it to a tuple to have efficient memory layout. When translating a
+sum pattern to a tuple pattern, we need to translate it so that binders of sum
+alternatives will be mapped to right arguments after the term translation. So
+translation of sum DataCon applications to tuple DataCon applications and
+translation of sum patterns to tuple patterns need to be in sync.
+
+These translations work like this. Suppose we have
+
+  (# x1 | | ... #) :: (# t1 | t2 | ... #)
+
+remember that t1, t2 ... can be sums and tuples too. So we first generate
+layouts of those. Then we "merge" layouts of each alternative, which gives us a
+sum layout with best overlapping possible.
+
+Layout of a flat type 'ty1' is just [ty1].
+Layout of a tuple is just concatenation of layouts of its fields.
+
+For layout of a sum type,
+
+  - We first get layouts of all alternatives.
+  - We sort these layouts based on their "slot types".
+  - We merge all the alternatives.
+
+For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
+
+  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]
+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]
+  - Merge all alternatives together: [ Ptr, Word, Word ]
+
+We add a slot for the tag to the first position. So our tuple type is
+
+  (# Tag#, Any, Word#, Word# #)
+  (we use Any for pointer slots)
+
+Now, any term of this sum type needs to generate a tuple of this type instead.
+The translation works by simply putting arguments to first slots that they fit
+in. Suppose we had
+
+  (# (# 42#, 'c' #) | | #)
+
+42# fits in Word#, 'c' fits in Any, so we generate this application:
+
+  (# 1#, 'c', 42#, rubbish #)
+
+Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
+3# fits in Word #, so we get:
+
+  (# 2#, rubbish, 2#, 3# #).
+
+Note [Types in StgConApp]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this unboxed sum term:
+
+  (# 123 | #)
+
+What will be the unboxed tuple representation? We can't tell without knowing the
+type of this term. For example, these are all valid tuples for this:
+
+  (# 1#, 123 #)          -- when type is (# Int | String #)
+  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
+  (# 1#, 123, rubbish, rubbish #)
+                         -- when type is (# Int | (# Int, Int, Int #) #)
+
+So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
+layout to use. Note that unlifted values can't be let-bound, so we don't need
+types in StgRhsCon.
+
+Note [UnariseEnv can map to literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
+needs to map variables to literals too. Suppose we have this Core:
+
+  f (# x | #)
+
+  ==> (CorePrep)
+
+  case (# x | #) of y {
+    _ -> f y
+  }
+
+  ==> (MultiVal)
+
+  case (# 1#, x #) of [x1, x2] {
+    _ -> f x1 x2
+  }
+
+To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
+
+  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
+
+so that `f x1 x2` becomes `f 1# x`.
+
+Note [Unarisation and arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because of unarisation, the arity that will be recorded in the generated info
+table for an Id may be larger than the idArity. Instead we record what we call
+the RepArity, which is the Arity taking into account any expanded arguments, and
+corresponds to the number of (possibly-void) *registers* arguments will arrive
+in.
+
+Note [Post-unarisation invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+STG programs after unarisation have these invariants:
+
+  * No unboxed sums at all.
+
+  * No unboxed tuple binders. Tuples only appear in return position.
+
+  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
+    This means that it's safe to wrap `StgArg`s of DataCon applications with
+    `StgCmmEnv.NonVoid`, for example.
+
+  * Alt binders (binders in patterns) are always non-void.
+-}
+
+{-# LANGUAGE CPP, TupleSections #-}
+
+module UnariseStg (unarise) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import CoreSyn
+import DataCon
+import FastString (FastString, mkFastString)
+import Id
+import Literal
+import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
+import MkId (voidPrimId, voidArgId)
+import MonadUtils (mapAccumLM)
+import Outputable
+import RepType
+import StgSyn
+import Type
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
+import TysWiredIn
+import UniqSupply
+import Util
+import VarEnv
+
+import Data.Bifunctor (second)
+import Data.Maybe (mapMaybe)
+import qualified Data.IntMap as IM
+
+--------------------------------------------------------------------------------
+
+-- | A mapping from binders to the Ids they were expanded/renamed to.
+--
+--   x :-> MultiVal [a,b,c] in rho
+--
+-- iff  x's typePrimRep is not a singleton, or equivalently
+--      x's type is an unboxed tuple, sum or void.
+--
+--    x :-> UnaryVal x'
+--
+-- iff x's RepType is UnaryRep or equivalently
+--     x's type is not unboxed tuple, sum or void.
+--
+-- So
+--     x :-> MultiVal [a] in rho
+-- means x is represented by singleton tuple.
+--
+--     x :-> MultiVal [] in rho
+-- means x is void.
+--
+-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
+--            (i.e. no unboxed tuples, sums or voids)
+--
+type UnariseEnv = VarEnv UnariseVal
+
+data UnariseVal
+  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
+  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].
+
+instance Outputable UnariseVal where
+  ppr (MultiVal args) = text "MultiVal" <+> ppr args
+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg
+
+-- | Extend the environment, checking the UnariseEnv invariant.
+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
+extendRho rho x (MultiVal args)
+  = ASSERT(all (isNvUnaryType . stgArgType) args)
+    extendVarEnv rho x (MultiVal args)
+extendRho rho x (UnaryVal val)
+  = ASSERT(isNvUnaryType (stgArgType val))
+    extendVarEnv rho x (UnaryVal val)
+
+--------------------------------------------------------------------------------
+
+unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
+
+unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
+unariseTopBinding rho (StgTopLifted bind)
+  = StgTopLifted <$> unariseBinding rho bind
+unariseTopBinding _ bind@StgTopStringLit{} = return bind
+
+unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
+unariseBinding rho (StgNonRec x rhs)
+  = StgNonRec x <$> unariseRhs rho rhs
+unariseBinding rho (StgRec xrhss)
+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
+
+unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
+  = do (rho', args1) <- unariseFunArgBinders rho args
+       expr' <- unariseExpr rho' expr
+       return (StgRhsClosure ext ccs update_flag args1 expr')
+
+unariseRhs rho (StgRhsCon ccs con args)
+  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+    return (StgRhsCon ccs con (unariseConArgs rho args))
+
+--------------------------------------------------------------------------------
+
+unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
+
+unariseExpr rho e@(StgApp f [])
+  = case lookupVarEnv rho f of
+      Just (MultiVal args)  -- Including empty tuples
+        -> return (mkTuple args)
+      Just (UnaryVal (StgVarArg f'))
+        -> return (StgApp f' [])
+      Just (UnaryVal (StgLitArg f'))
+        -> return (StgLit f')
+      Nothing
+        -> return e
+
+unariseExpr rho e@(StgApp f args)
+  = return (StgApp f' (unariseFunArgs rho args))
+  where
+    f' = case lookupVarEnv rho f of
+           Just (UnaryVal (StgVarArg f')) -> f'
+           Nothing -> f
+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
+               -- Can't happen because 'args' is non-empty, and
+               -- a tuple or sum cannot be applied to anything
+
+unariseExpr _ (StgLit l)
+  = return (StgLit l)
+
+unariseExpr rho (StgConApp dc args ty_args)
+  | Just args' <- unariseMulti_maybe rho dc args ty_args
+  = return (mkTuple args')
+
+  | otherwise
+  , let args' = unariseConArgs rho args
+  = return (StgConApp dc args' (map stgArgType args'))
+
+unariseExpr rho (StgOpApp op args ty)
+  = return (StgOpApp op (unariseFunArgs rho args) ty)
+
+unariseExpr _ e@StgLam{}
+  = pprPanic "unariseExpr: found lambda" (ppr e)
+
+unariseExpr rho (StgCase scrut bndr alt_ty alts)
+  -- tuple/sum binders in the scrutinee can always be eliminated
+  | StgApp v [] <- scrut
+  , Just (MultiVal xs) <- lookupVarEnv rho v
+  = elimCase rho xs bndr alt_ty alts
+
+  -- Handle strict lets for tuples and sums:
+  --   case (# a,b #) of r -> rhs
+  -- and analogously for sums
+  | StgConApp dc args ty_args <- scrut
+  , Just args' <- unariseMulti_maybe rho dc args ty_args
+  = elimCase rho args' bndr alt_ty alts
+
+  -- general case
+  | otherwise
+  = do scrut' <- unariseExpr rho scrut
+       alts'  <- unariseAlts rho alt_ty bndr alts
+       return (StgCase scrut' bndr alt_ty alts')
+                       -- bndr may have a unboxed sum/tuple type but it will be
+                       -- dead after unarise (checked in StgLint)
+
+unariseExpr rho (StgLet ext bind e)
+  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
+
+unariseExpr rho (StgLetNoEscape ext bind e)
+  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
+
+unariseExpr rho (StgTick tick e)
+  = StgTick tick <$> unariseExpr rho e
+
+-- Doesn't return void args.
+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
+unariseMulti_maybe rho dc args ty_args
+  | isUnboxedTupleCon dc
+  = Just (unariseConArgs rho args)
+
+  | isUnboxedSumCon dc
+  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
+  = Just (mkUbxSum dc ty_args args1)
+
+  | otherwise
+  = Nothing
+
+--------------------------------------------------------------------------------
+
+elimCase :: UnariseEnv
+         -> [OutStgArg] -- non-void args
+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
+
+elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
+  = do let rho1 = extendRho rho bndr (MultiVal args)
+           rho2
+             | isUnboxedTupleBndr bndr
+             = mapTupleIdBinders bndrs args rho1
+             | otherwise
+             = ASSERT(isUnboxedSumBndr bndr)
+               if null bndrs then rho1
+                             else mapSumIdBinders bndrs args rho1
+
+       unariseExpr rho2 rhs
+
+elimCase rho args bndr (MultiValAlt _) alts
+  | isUnboxedSumBndr bndr
+  = do let (tag_arg : real_args) = args
+       tag_bndr <- mkId (mkFastString "tag") tagTy
+          -- this won't be used but we need a binder anyway
+       let rho1 = extendRho rho bndr (MultiVal args)
+           scrut' = case tag_arg of
+                      StgVarArg v     -> StgApp v []
+                      StgLitArg l     -> StgLit l
+
+       alts' <- unariseSumAlts rho1 real_args alts
+       return (StgCase scrut' tag_bndr tagAltTy alts')
+
+elimCase _ args bndr alt_ty alts
+  = pprPanic "elimCase - unhandled case"
+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
+
+--------------------------------------------------------------------------------
+
+unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys) <- unariseConArgBinder rho bndr
+       e' <- unariseExpr rho' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
+
+unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys1) <- unariseConArgBinders rho ys
+       MASSERT(ys1 `lengthIs` n)
+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
+       e' <- unariseExpr rho'' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
+
+unariseAlts _ (MultiValAlt _) bndr alts
+  | isUnboxedTupleBndr bndr
+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
+
+-- In this case we don't need to scrutinize the tag bit
+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
+       rhs' <- unariseExpr rho_sum_bndrs rhs
+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
+
+unariseAlts rho (MultiValAlt _) bndr alts
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
+                 scrt_bndrs,
+                 inner_case) ]
+
+unariseAlts rho _ _ alts
+  = mapM (\alt -> unariseAlt rho alt) alts
+
+unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
+unariseAlt rho (con, xs, e)
+  = do (rho', xs') <- unariseConArgBinders rho xs
+       (con, xs',) <$> unariseExpr rho' e
+
+--------------------------------------------------------------------------------
+
+-- | Make alternatives that match on the tag of a sum
+-- (i.e. generate LitAlts for the tag)
+unariseSumAlts :: UnariseEnv
+               -> [StgArg] -- sum components _excluding_ the tag bit.
+               -> [StgAlt] -- original alternative with sum LHS
+               -> UniqSM [StgAlt]
+unariseSumAlts env args alts
+  = do alts' <- mapM (unariseSumAlt env args) alts
+       return (mkDefaultLitAlt alts')
+
+unariseSumAlt :: UnariseEnv
+              -> [StgArg] -- sum components _excluding_ the tag bit.
+              -> StgAlt   -- original alternative with sum LHS
+              -> UniqSM StgAlt
+unariseSumAlt rho _ (DEFAULT, _, e)
+  = ( DEFAULT, [], ) <$> unariseExpr rho e
+
+unariseSumAlt rho args (DataAlt sumCon, bs, e)
+  = do let rho' = mapSumIdBinders bs args rho
+       e' <- unariseExpr rho' e
+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
+
+unariseSumAlt _ scrt alt
+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
+
+--------------------------------------------------------------------------------
+
+mapTupleIdBinders
+  :: [InId]       -- Un-processed binders of a tuple alternative.
+                  -- Can have void binders.
+  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
+                  -- Can't have void args.
+  -> UnariseEnv
+  -> UnariseEnv
+mapTupleIdBinders ids args0 rho0
+  = ASSERT(not (any (isVoidTy . stgArgType) args0))
+    let
+      ids_unarised :: [(Id, [PrimRep])]
+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
+
+      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
+      map_ids rho [] _  = rho
+      map_ids rho ((x, x_reps) : xs) args =
+        let
+          x_arity = length x_reps
+          (x_args, args') =
+            ASSERT(args `lengthAtLeast` x_arity)
+            splitAt x_arity args
+
+          rho'
+            | x_arity == 1
+            = ASSERT(x_args `lengthIs` 1)
+              extendRho rho x (UnaryVal (head x_args))
+            | otherwise
+            = extendRho rho x (MultiVal x_args)
+        in
+          map_ids rho' xs args'
+    in
+      map_ids rho0 ids_unarised args0
+
+mapSumIdBinders
+  :: [InId]      -- Binder of a sum alternative (remember that sum patterns
+                 -- only have one binder, so this list should be a singleton)
+  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
+                 -- Can't have void args.
+  -> UnariseEnv
+  -> UnariseEnv
+
+mapSumIdBinders [id] args rho0
+  = ASSERT(not (any (isVoidTy . stgArgType) args))
+    let
+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+      id_slots  = map primRepSlot $ typePrimRep (idType id)
+      layout1   = layoutUbxSum arg_slots id_slots
+    in
+      if isMultiValBndr id
+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
+        else ASSERT(layout1 `lengthIs` 1)
+             extendRho rho0 id (UnaryVal (args !! head layout1))
+
+mapSumIdBinders ids sum_args _
+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
+
+-- | Build a unboxed sum term from arguments of an alternative.
+--
+-- Example, for (# x | #) :: (# (# #) | Int #) we call
+--
+--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
+--
+-- which returns
+--
+--   [ 1#, rubbish ]
+--
+mkUbxSum
+  :: DataCon      -- Sum data con
+  -> [Type]       -- Type arguments of the sum data con
+  -> [OutStgArg]  -- Actual arguments of the alternative.
+  -> [OutStgArg]  -- Final tuple arguments
+mkUbxSum dc ty_args args0
+  = let
+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
+        -- drop tag slot
+
+      tag = dataConTag dc
+
+      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
+
+      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
+      mkTupArgs _ [] _
+        = []
+      mkTupArgs arg_idx (slot : slots_left) arg_map
+        | Just stg_arg <- IM.lookup arg_idx arg_map
+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
+        | otherwise
+        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
+
+      slotRubbishArg :: SlotTy -> StgArg
+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
+      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
+      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+    in
+      tag_arg : mkTupArgs 0 sum_slots arg_idxs
+
+--------------------------------------------------------------------------------
+
+{-
+For arguments (StgArg) and binders (Id) we have two kind of unarisation:
+
+  - When unarising function arg binders and arguments, we don't want to remove
+    void binders and arguments. For example,
+
+      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
+      f x y z = <body>
+
+    Here after unarise we should still get a function with arity 3. Similarly
+    in the call site we shouldn't remove void arguments:
+
+      f (# (# #), (# #) #) voidId rw
+
+    When unarising <body>, we extend the environment with these binders:
+
+      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
+
+    Because their rep types are `MultiRep []` (aka. void). This means that when
+    we see `x` in a function argument position, we actually replace it with a
+    void argument. When we see it in a DataCon argument position, we just get
+    rid of it, because DataCon applications in STG are always saturated.
+
+  - When unarising case alternative binders we remove void binders, but we
+    still update the environment the same way, because those binders may be
+    used in the RHS. Example:
+
+      case x of y {
+        (# x1, x2, x3 #) -> <RHS>
+      }
+
+    We know that y can't be void, because we don't scrutinize voids, so x will
+    be unarised to some number of arguments, and those arguments will have at
+    least one non-void thing. So in the rho we will have something like:
+
+      x :-> MultiVal [xu1, xu2]
+
+    Now, after we eliminate void binders in the pattern, we get exactly the same
+    number of binders, and extend rho again with these:
+
+      x1 :-> UnaryVal xu1
+      x2 :-> MultiVal [] -- x2 is void
+      x3 :-> UnaryVal xu2
+
+    Now when we see x2 in a function argument position or in return position, we
+    generate void#. In constructor argument position, we just remove it.
+
+So in short, when we have a void id,
+
+  - We keep it if it's a lambda argument binder or
+                       in argument position of an application.
+
+  - We remove it if it's a DataCon field binder or
+                         in argument position of a DataCon application.
+-}
+
+unariseArgBinder
+    :: Bool -- data con arg?
+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseArgBinder is_con_arg rho x =
+  case typePrimRep (idType x) of
+    []
+      | is_con_arg
+      -> return (extendRho rho x (MultiVal []), [])
+      | otherwise -- fun arg, do not remove void binders
+      -> return (extendRho rho x (MultiVal []), [voidArgId])
+
+    [rep]
+      -- Arg represented as single variable, but original type may still be an
+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
+      --
+      -- While not unarising the binder in this case does not break any programs
+      -- (because it unarises to a single variable), it triggers StgLint as we
+      -- break the the post-unarisation invariant that says unboxed tuple/sum
+      -- binders should vanish. See Note [Post-unarisation invariants].
+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)
+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
+      | otherwise
+      -> return (rho, [x])
+
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a function argument. Never returns an empty list.
+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
+unariseFunArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args
+    Just (MultiVal as)  -> as
+    Just (UnaryVal arg) -> [arg]
+    Nothing             -> [StgVarArg x]
+unariseFunArg _ arg = [arg]
+
+unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
+unariseFunArgs = concatMap . unariseFunArg
+
+unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
+
+-- Result list of binders is never empty
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinder = unariseArgBinder False
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a DataCon argument. Returns an empty list when argument is void.
+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
+unariseConArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (UnaryVal arg) -> [arg]
+    Just (MultiVal as) -> as      -- 'as' can be empty
+    Nothing
+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#
+                                  -- Here realWorld# is not in the envt, but
+                                  -- is a void, and so should be eliminated
+      | otherwise -> [StgVarArg x]
+unariseConArg _ arg@(StgLitArg lit) =
+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals
+    [arg]
+
+unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
+unariseConArgs = concatMap . unariseConArg
+
+unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
+
+-- Different from `unariseFunArgBinder`: result list of binders may be empty.
+-- See DataCon applications case in Note [Post-unarisation invariants].
+unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinder = unariseArgBinder True
+
+--------------------------------------------------------------------------------
+
+mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
+mkIds fs tys = mapM (mkId fs) tys
+
+mkId :: FastString -> UnaryType -> UniqSM Id
+mkId = mkSysLocalOrCoVarM
+
+isMultiValBndr :: Id -> Bool
+isMultiValBndr id
+  | [_] <- typePrimRep (idType id)
+  = False
+  | otherwise
+  = True
+
+isUnboxedSumBndr :: Id -> Bool
+isUnboxedSumBndr = isUnboxedSumType . idType
+
+isUnboxedTupleBndr :: Id -> Bool
+isUnboxedTupleBndr = isUnboxedTupleType . idType
+
+mkTuple :: [StgArg] -> StgExpr
+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
+
+tagAltTy :: AltType
+tagAltTy = PrimAlt IntRep
+
+tagTy :: Type
+tagTy = intPrimTy
+
+voidArg :: StgArg
+voidArg = StgVarArg voidPrimId
+
+mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
+-- We have an exhauseive list of literal alternatives
+--    1# -> e1
+--    2# -> e2
+-- Since they are exhaustive, we can replace one with DEFAULT, to avoid
+-- generating a final test. Remember, the DEFAULT comes first if it exists.
+mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/specialise/SpecConstr.hs
@@ -0,0 +1,2356 @@
+{-
+ToDo [Oct 2013]
+~~~~~~~~~~~~~~~
+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)
+2. Nuke NoSpecConstr
+
+
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[SpecConstr]{Specialise over constructors}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SpecConstr(
+        specConstrProgram,
+        SpecConstrAnnotation(..)
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreSubst
+import CoreUtils
+import CoreUnfold       ( couldBeSmallEnoughToInline )
+import CoreFVs          ( exprsFreeVarsList )
+import CoreMonad
+import Literal          ( litIsLifted )
+import HscTypes         ( ModGuts(..) )
+import WwLib            ( isWorkerSmallEnough, mkWorkerArgs )
+import DataCon
+import Coercion         hiding( substCo )
+import Rules
+import Type             hiding ( substTy )
+import TyCon            ( tyConName )
+import Id
+import PprCore          ( pprParendExpr )
+import MkCore           ( mkImpossibleExpr )
+import VarEnv
+import VarSet
+import Name
+import BasicTypes
+import DynFlags         ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
+                        , gopt, hasPprDebug )
+import Maybes           ( orElse, catMaybes, isJust, isNothing )
+import Demand
+import GHC.Serialized   ( deserializeWithData )
+import Util
+import Pair
+import UniqSupply
+import Outputable
+import FastString
+import UniqFM
+import MonadUtils
+import Control.Monad    ( zipWithM )
+import Data.List
+import PrelNames        ( specTyConName )
+import Module
+import TyCon ( TyCon )
+import GHC.Exts( SpecConstrAnnotation(..) )
+import Data.Ord( comparing )
+
+{-
+-----------------------------------------------------
+                        Game plan
+-----------------------------------------------------
+
+Consider
+        drop n []     = []
+        drop 0 xs     = []
+        drop n (x:xs) = drop (n-1) xs
+
+After the first time round, we could pass n unboxed.  This happens in
+numerical code too.  Here's what it looks like in Core:
+
+        drop n xs = case xs of
+                      []     -> []
+                      (y:ys) -> case n of
+                                  I# n# -> case n# of
+                                             0 -> []
+                                             _ -> drop (I# (n# -# 1#)) xs
+
+Notice that the recursive call has an explicit constructor as argument.
+Noticing this, we can make a specialised version of drop
+
+        RULE: drop (I# n#) xs ==> drop' n# xs
+
+        drop' n# xs = let n = I# n# in ...orig RHS...
+
+Now the simplifier will apply the specialisation in the rhs of drop', giving
+
+        drop' n# xs = case xs of
+                      []     -> []
+                      (y:ys) -> case n# of
+                                  0 -> []
+                                  _ -> drop' (n# -# 1#) xs
+
+Much better!
+
+We'd also like to catch cases where a parameter is carried along unchanged,
+but evaluated each time round the loop:
+
+        f i n = if i>0 || i>n then i else f (i*2) n
+
+Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
+In Core, by the time we've w/wd (f is strict in i) we get
+
+        f i# n = case i# ># 0 of
+                   False -> I# i#
+                   True  -> case n of { I# n# ->
+                            case i# ># n# of
+                                False -> I# i#
+                                True  -> f (i# *# 2#) n
+
+At the call to f, we see that the argument, n is known to be (I# n#),
+and n is evaluated elsewhere in the body of f, so we can play the same
+trick as above.
+
+
+Note [Reboxing]
+~~~~~~~~~~~~~~~
+We must be careful not to allocate the same constructor twice.  Consider
+        f p = (...(case p of (a,b) -> e)...p...,
+               ...let t = (r,s) in ...t...(f t)...)
+At the recursive call to f, we can see that t is a pair.  But we do NOT want
+to make a specialised copy:
+        f' a b = let p = (a,b) in (..., ...)
+because now t is allocated by the caller, then r and s are passed to the
+recursive call, which allocates the (r,s) pair again.
+
+This happens if
+  (a) the argument p is used in other than a case-scrutinisation way.
+  (b) the argument to the call is not a 'fresh' tuple; you have to
+        look into its unfolding to see that it's a tuple
+
+Hence the "OR" part of Note [Good arguments] below.
+
+ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
+allocation, but does perhaps save evals. In the RULE we'd have
+something like
+
+  f (I# x#) = f' (I# x#) x#
+
+If at the call site the (I# x) was an unfolding, then we'd have to
+rely on CSE to eliminate the duplicate allocation.... This alternative
+doesn't look attractive enough to pursue.
+
+ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that
+the conservative reboxing story prevents many useful functions from being
+specialised.  Example:
+        foo :: Maybe Int -> Int -> Int
+        foo   (Just m) 0 = 0
+        foo x@(Just m) n = foo x (n-m)
+Here the use of 'x' will clearly not require boxing in the specialised function.
+
+The strictness analyser has the same problem, in fact.  Example:
+        f p@(a,b) = ...
+If we pass just 'a' and 'b' to the worker, it might need to rebox the
+pair to create (a,b).  A more sophisticated analysis might figure out
+precisely the cases in which this could happen, but the strictness
+analyser does no such analysis; it just passes 'a' and 'b', and hopes
+for the best.
+
+So my current choice is to make SpecConstr similarly aggressive, and
+ignore the bad potential of reboxing.
+
+
+Note [Good arguments]
+~~~~~~~~~~~~~~~~~~~~~
+So we look for
+
+* A self-recursive function.  Ignore mutual recursion for now,
+  because it's less common, and the code is simpler for self-recursion.
+
+* EITHER
+
+   a) At a recursive call, one or more parameters is an explicit
+      constructor application
+        AND
+      That same parameter is scrutinised by a case somewhere in
+      the RHS of the function
+
+  OR
+
+    b) At a recursive call, one or more parameters has an unfolding
+       that is an explicit constructor application
+        AND
+      That same parameter is scrutinised by a case somewhere in
+      the RHS of the function
+        AND
+      Those are the only uses of the parameter (see Note [Reboxing])
+
+
+What to abstract over
+~~~~~~~~~~~~~~~~~~~~~
+There's a bit of a complication with type arguments.  If the call
+site looks like
+
+        f p = ...f ((:) [a] x xs)...
+
+then our specialised function look like
+
+        f_spec x xs = let p = (:) [a] x xs in ....as before....
+
+This only makes sense if either
+  a) the type variable 'a' is in scope at the top of f, or
+  b) the type variable 'a' is an argument to f (and hence fs)
+
+Actually, (a) may hold for value arguments too, in which case
+we may not want to pass them.  Suppose 'x' is in scope at f's
+defn, but xs is not.  Then we'd like
+
+        f_spec xs = let p = (:) [a] x xs in ....as before....
+
+Similarly (b) may hold too.  If x is already an argument at the
+call, no need to pass it again.
+
+Finally, if 'a' is not in scope at the call site, we could abstract
+it as we do the term variables:
+
+        f_spec a x xs = let p = (:) [a] x xs in ...as before...
+
+So the grand plan is:
+
+        * abstract the call site to a constructor-only pattern
+          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
+
+        * Find the free variables of the abstracted pattern
+
+        * Pass these variables, less any that are in scope at
+          the fn defn.  But see Note [Shadowing] below.
+
+
+NOTICE that we only abstract over variables that are not in scope,
+so we're in no danger of shadowing variables used in "higher up"
+in f_spec's RHS.
+
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+In this pass we gather up usage information that may mention variables
+that are bound between the usage site and the definition site; or (more
+seriously) may be bound to something different at the definition site.
+For example:
+
+        f x = letrec g y v = let x = ...
+                             in ...(g (a,b) x)...
+
+Since 'x' is in scope at the call site, we may make a rewrite rule that
+looks like
+        RULE forall a,b. g (a,b) x = ...
+But this rule will never match, because it's really a different 'x' at
+the call site -- and that difference will be manifest by the time the
+simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
+no-shadowing, so perhaps it may not be distinct?]
+
+Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
+is to run deShadowBinds before running SpecConstr, but instead we run the
+simplifier.  That gives the simplest possible program for SpecConstr to
+chew on; and it virtually guarantees no shadowing.
+
+Note [Specialising for constant parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This one is about specialising on a *constant* (but not necessarily
+constructor) argument
+
+    foo :: Int -> (Int -> Int) -> Int
+    foo 0 f = 0
+    foo m f = foo (f m) (+1)
+
+It produces
+
+    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
+    lvl_rmV =
+      \ (ds_dlk :: GHC.Base.Int) ->
+        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
+        GHC.Base.I# (GHC.Prim.+# x_alG 1)
+
+    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
+    GHC.Prim.Int#
+    T.$wfoo =
+      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
+        case ww_sme of ds_Xlw {
+          __DEFAULT ->
+        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
+        T.$wfoo ww1_Xmz lvl_rmV
+        };
+          0 -> 0
+        }
+
+The recursive call has lvl_rmV as its argument, so we could create a specialised copy
+with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
+
+When is this worth it?  Call the constant 'lvl'
+- If 'lvl' has an unfolding that is a constructor, see if the corresponding
+  parameter is scrutinised anywhere in the body.
+
+- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
+  parameter is applied (...to enough arguments...?)
+
+  Also do this is if the function has RULES?
+
+Also
+
+Note [Specialising for lambda parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    foo :: Int -> (Int -> Int) -> Int
+    foo 0 f = 0
+    foo m f = foo (f m) (\n -> n-m)
+
+This is subtly different from the previous one in that we get an
+explicit lambda as the argument:
+
+    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
+    GHC.Prim.Int#
+    T.$wfoo =
+      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
+        case ww_sm8 of ds_Xlr {
+          __DEFAULT ->
+        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
+        T.$wfoo
+          ww1_Xmq
+          (\ (n_ad3 :: GHC.Base.Int) ->
+             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
+             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
+             })
+        };
+          0 -> 0
+        }
+
+I wonder if SpecConstr couldn't be extended to handle this? After all,
+lambda is a sort of constructor for functions and perhaps it already
+has most of the necessary machinery?
+
+Furthermore, there's an immediate win, because you don't need to allocate the lambda
+at the call site; and if perchance it's called in the recursive call, then you
+may avoid allocating it altogether.  Just like for constructors.
+
+Looks cool, but probably rare...but it might be easy to implement.
+
+
+Note [SpecConstr for casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    data family T a :: *
+    data instance T Int = T Int
+
+    foo n = ...
+       where
+         go (T 0) = 0
+         go (T n) = go (T (n-1))
+
+The recursive call ends up looking like
+        go (T (I# ...) `cast` g)
+So we want to spot the constructor application inside the cast.
+That's why we have the Cast case in argToPat
+
+Note [Local recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a *local* recursive group, we can see all the calls to the
+function, so we seed the specialisation loop from the calls in the
+body, not from the calls in the RHS.  Consider:
+
+  bar m n = foo n (n,n) (n,n) (n,n) (n,n)
+   where
+     foo n p q r s
+       | n == 0    = m
+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
+
+If we start with the RHSs of 'foo', we get lots and lots of specialisations,
+most of which are not needed.  But if we start with the (single) call
+in the rhs of 'bar' we get exactly one fully-specialised copy, and all
+the recursive calls go to this fully-specialised copy. Indeed, the original
+function is later collected as dead code.  This is very important in
+specialising the loops arising from stream fusion, for example in NDP where
+we were getting literally hundreds of (mostly unused) specialisations of
+a local function.
+
+In a case like the above we end up never calling the original un-specialised
+function.  (Although we still leave its code around just in case.)
+
+However, if we find any boring calls in the body, including *unsaturated*
+ones, such as
+      letrec foo x y = ....foo...
+      in map foo xs
+then we will end up calling the un-specialised function, so then we *should*
+use the calls in the un-specialised RHS as seeds.  We call these
+"boring call patterns", and callsToPats reports if it finds any of these.
+
+Note [Seeding top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This seeding is done in the binding for seed_calls in specRec.
+
+1. If all the bindings in a top-level recursive group are local (not
+   exported), then all the calls are in the rest of the top-level
+   bindings.  This means we can specialise with those call patterns
+   ONLY, and NOT with the RHSs of the recursive group (exactly like
+   Note [Local recursive groups])
+
+2. But if any of the bindings are exported, the function may be called
+   with any old arguments, so (for lack of anything better) we specialise
+   based on
+     (a) the call patterns in the RHS
+     (b) the call patterns in the rest of the top-level bindings
+   NB: before Apr 15 we used (a) only, but Dimitrios had an example
+       where (b) was crucial, so I added that.
+       Adding (b) also improved nofib allocation results:
+                  multiplier: 4%   better
+                  minimax:    2.8% better
+
+Actually in case (2), instead of using the calls from the RHS, it
+would be better to specialise in the importing module.  We'd need to
+add an INLINABLE pragma to the function, and then it can be
+specialised in the importing scope, just as is done for type classes
+in Specialise.specImports. This remains to be done (#10346).
+
+Note [Top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To get the call usage information from "the rest of the top level
+bindings" (c.f. Note [Seeding top-level recursive groups]), we work
+backwards through the top-level bindings so we see the usage before we
+get to the binding of the function.  Before we can collect the usage
+though, we go through all the bindings and add them to the
+environment. This is necessary because usage is only tracked for
+functions in the environment.  These two passes are called
+   'go' and 'goEnv'
+in specConstrProgram.  (Looks a bit revolting to me.)
+
+Note [Do not specialise diverging functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Specialising a function that just diverges is a waste of code.
+Furthermore, it broke GHC (simpl014) thus:
+   {-# STR Sb #-}
+   f = \x. case x of (a,b) -> f x
+If we specialise f we get
+   f = \x. case x of (a,b) -> fspec a b
+But fspec doesn't have decent strictness info.  As it happened,
+(f x) :: IO t, so the state hack applied and we eta expanded fspec,
+and hence f.  But now f's strictness is less than its arity, which
+breaks an invariant.
+
+
+Note [Forcing specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With stream fusion and in other similar cases, we want to fully
+specialise some (but not necessarily all!) loops regardless of their
+size and the number of specialisations.
+
+We allow a library to do this, in one of two ways (one which is
+deprecated):
+
+  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.
+
+  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,
+     and then add *that* type as a parameter to the loop body
+
+The reason #2 is deprecated is because it requires GHCi, which isn't
+available for things like a cross compiler using stage1.
+
+Here's a (simplified) example from the `vector` package. You may bring
+the special 'force specialization' type into scope by saying:
+
+  import GHC.Types (SPEC(..))
+
+or by defining your own type (again, deprecated):
+
+  data SPEC = SPEC | SPEC2
+  {-# ANN type SPEC ForceSpecConstr #-}
+
+(Note this is the exact same definition of GHC.Types.SPEC, just
+without the annotation.)
+
+After that, you say:
+
+  foldl :: (a -> b -> a) -> a -> Stream b -> a
+  {-# INLINE foldl #-}
+  foldl f z (Stream step s _) = foldl_loop SPEC z s
+    where
+      foldl_loop !sPEC z s = case step s of
+                              Yield x s' -> foldl_loop sPEC (f z x) s'
+                              Skip       -> foldl_loop sPEC z s'
+                              Done       -> z
+
+SpecConstr will spot the SPEC parameter and always fully specialise
+foldl_loop. Note that
+
+  * We have to prevent the SPEC argument from being removed by
+    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
+    the SPEC argument.
+
+  * And lastly, the SPEC argument is ultimately eliminated by
+    SpecConstr itself so there is no runtime overhead.
+
+This is all quite ugly; we ought to come up with a better design.
+
+ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
+sc_force to True when calling specLoop. This flag does four things:
+
+  * Ignore specConstrThreshold, to specialise functions of arbitrary size
+        (see scTopBind)
+  * Ignore specConstrCount, to make arbitrary numbers of specialisations
+        (see specialise)
+  * Specialise even for arguments that are not scrutinised in the loop
+        (see argToPat; #4448)
+  * Only specialise on recursive types a finite number of times
+        (see is_too_recursive; #5550; Note [Limit recursive specialisation])
+
+The flag holds only for specialising a single binding group, and NOT
+for nested bindings.  (So really it should be passed around explicitly
+and not stored in ScEnv.)  #14379 turned out to be caused by
+   f SPEC x = let g1 x = ...
+              in ...
+We force-specialise f (because of the SPEC), but that generates a specialised
+copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and
+in each copy of g1 we get an unspecialised and specialised copy of g2; and so
+on. Result, exponential.  So the force-spec flag now only applies to one
+level of bindings at a time.
+
+Mechanism for this one-level-only thing:
+
+ - Switch it on at the call to specRec, in scExpr and scTopBinds
+ - Switch it off when doing the RHSs;
+   this can be done very conveniently in decreaseSpecCount
+
+What alternatives did I consider?
+
+* Annotating the loop itself doesn't work because (a) it is local and
+  (b) it will be w/w'ed and having w/w propagating annotations somehow
+  doesn't seem like a good idea. The types of the loop arguments
+  really seem to be the most persistent thing.
+
+* Annotating the types that make up the loop state doesn't work,
+  either, because (a) it would prevent us from using types like Either
+  or tuples here, (b) we don't want to restrict the set of types that
+  can be used in Stream states and (c) some types are fixed by the
+  user (e.g., the accumulator here) but we still want to specialise as
+  much as possible.
+
+Alternatives to ForceSpecConstr
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of giving the loop an extra argument of type SPEC, we
+also considered *wrapping* arguments in SPEC, thus
+  data SPEC a = SPEC a | SPEC2
+
+  loop = \arg -> case arg of
+                     SPEC state ->
+                        case state of (x,y) -> ... loop (SPEC (x',y')) ...
+                        S2 -> error ...
+The idea is that a SPEC argument says "specialise this argument
+regardless of whether the function case-analyses it".  But this
+doesn't work well:
+  * SPEC must still be a sum type, else the strictness analyser
+    eliminates it
+  * But that means that 'loop' won't be strict in its real payload
+This loss of strictness in turn screws up specialisation, because
+we may end up with calls like
+   loop (SPEC (case z of (p,q) -> (q,p)))
+Without the SPEC, if 'loop' were strict, the case would move out
+and we'd see loop applied to a pair. But if 'loop' isn't strict
+this doesn't look like a specialisable call.
+
+Note [Limit recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.
+Because there is no limit on the number of specialisations, a recursive call with
+a recursive constructor as an argument (for example, list cons) will generate
+a specialisation for that constructor. If the resulting specialisation also
+contains a recursive call with the constructor, this could proceed indefinitely.
+
+For example, if ForceSpecConstr is on:
+  loop :: [Int] -> [Int] -> [Int]
+  loop z []         = z
+  loop z (x:xs)     = loop (x:z) xs
+this example will create a specialisation for the pattern
+  loop (a:b) c      = loop' a b c
+
+  loop' a b []      = (a:b)
+  loop' a b (x:xs)  = loop (x:(a:b)) xs
+and a new pattern is found:
+  loop (a:(b:c)) d  = loop'' a b c d
+which can continue indefinitely.
+
+Roman's suggestion to fix this was to stop after a couple of times on recursive types,
+but still specialising on non-recursive types as much as possible.
+
+To implement this, we count the number of times we have gone round the
+"specialise recursively" loop ('go' in 'specRec').  Once have gone round
+more than N times (controlled by -fspec-constr-recursive=N) we check
+
+  - If sc_force is off, and sc_count is (Just max) then we don't
+    need to do anything: trim_pats will limit the number of specs
+
+  - Otherwise check if any function has now got more than (sc_count env)
+    specialisations.  If sc_count is "no limit" then we arbitrarily
+    choose 10 as the limit (ugh).
+
+See #5550.   Also #13623, where this test had become over-aggressive,
+and we lost a wonderful specialisation that we really wanted!
+
+Note [NoSpecConstr]
+~~~~~~~~~~~~~~~~~~~
+The ignoreDataCon stuff allows you to say
+    {-# ANN type T NoSpecConstr #-}
+to mean "don't specialise on arguments of this type".  It was added
+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised
+regardless of size; and then we needed a way to turn that *off*.  Now
+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
+(Used only for PArray, TODO: remove?)
+
+-----------------------------------------------------
+                Stuff not yet handled
+-----------------------------------------------------
+
+Here are notes arising from Roman's work that I don't want to lose.
+
+Example 1
+~~~~~~~~~
+    data T a = T !a
+
+    foo :: Int -> T Int -> Int
+    foo 0 t = 0
+    foo x t | even x    = case t of { T n -> foo (x-n) t }
+            | otherwise = foo (x-1) t
+
+SpecConstr does no specialisation, because the second recursive call
+looks like a boxed use of the argument.  A pity.
+
+    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
+    $wfoo_sFw =
+      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
+         case ww_sFo of ds_Xw6 [Just L] {
+           __DEFAULT ->
+                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
+                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
+                  0 ->
+                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
+                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
+                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
+                    } } };
+           0 -> 0
+
+Example 2
+~~~~~~~~~
+    data a :*: b = !a :*: !b
+    data T a = T !a
+
+    foo :: (Int :*: T Int) -> Int
+    foo (0 :*: t) = 0
+    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
+                  | otherwise = foo ((x-1) :*: t)
+
+Very similar to the previous one, except that the parameters are now in
+a strict tuple. Before SpecConstr, we have
+
+    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
+    $wfoo_sG3 =
+      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
+    GHC.Base.Int) ->
+        case ww_sFU of ds_Xws [Just L] {
+          __DEFAULT ->
+        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
+          __DEFAULT ->
+            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
+            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
+            };
+          0 ->
+            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
+            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
+            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
+            } } };
+          0 -> 0 }
+
+We get two specialisations:
+"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
+                  = Foo.$s$wfoo1 a_sFB sc_sGC ;
+"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
+                  = Foo.$s$wfoo y_aFp sc_sGC ;
+
+But perhaps the first one isn't good.  After all, we know that tpl_B2 is
+a T (I# x) really, because T is strict and Int has one constructor.  (We can't
+unbox the strict fields, because T is polymorphic!)
+
+************************************************************************
+*                                                                      *
+\subsection{Top level wrapper stuff}
+*                                                                      *
+************************************************************************
+-}
+
+specConstrProgram :: ModGuts -> CoreM ModGuts
+specConstrProgram guts
+  = do
+      dflags <- getDynFlags
+      us     <- getUniqueSupplyM
+      annos  <- getFirstAnnotations deserializeWithData guts
+      this_mod <- getModule
+      let binds' = reverse $ fst $ initUs us $ do
+                    -- Note [Top-level recursive groups]
+                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)
+                                          (mg_binds guts)
+                        -- binds is identical to (mg_binds guts), except that the
+                        -- binders on the LHS have been replaced by extendBndr
+                        --   (SPJ this seems like overkill; I don't think the binders
+                        --    will change at all; and we don't substitute in the RHSs anyway!!)
+                    go env nullUsage (reverse binds)
+
+      return (guts { mg_binds = binds' })
+  where
+    -- See Note [Top-level recursive groups]
+    goEnv env []            = return (env, [])
+    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind
+                                 (env'', binds') <- goEnv env' binds
+                                 return (env'', bind' : binds')
+
+    -- Arg list of bindings is in reverse order
+    go _   _   []           = return []
+    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind
+                                 binds' <- go env usg' binds
+                                 return (bind' : binds')
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Environment: goes downwards}
+*                                                                      *
+************************************************************************
+
+Note [Work-free values only in environment]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The sc_vals field keeps track of in-scope value bindings, so
+that if we come across (case x of Just y ->...) we can reduce the
+case from knowing that x is bound to a pair.
+
+But only *work-free* values are ok here. For example if the envt had
+    x -> Just (expensive v)
+then we do NOT want to expand to
+     let y = expensive v in ...
+because the x-binding still exists and we've now duplicated (expensive v).
+
+This seldom happens because let-bound constructor applications are
+ANF-ised, but it can happen as a result of on-the-fly transformations in
+SpecConstr itself.  Here is #7865:
+
+        let {
+          a'_shr =
+            case xs_af8 of _ {
+              [] -> acc_af6;
+              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->
+                (expensive x_af7, x_af7
+            } } in
+        let {
+          ds_sht =
+            case a'_shr of _ { (p'_afd, q'_afe) ->
+            TSpecConstr_DoubleInline.recursive
+              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)
+            } } in
+
+When processed knowing that xs_af8 was bound to a cons, we simplify to
+   a'_shr = (expensive x_af7, x_af7)
+and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.
+(There are other occurrences of a'_shr.)  No no no.
+
+It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned
+into a work-free value again, thus
+   a1 = expensive x_af7
+   a'_shr = (a1, x_af7)
+but that's more work, so until its shown to be important I'm going to
+leave it for now.
+
+Note [Making SpecConstr keener]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this, in (perf/should_run/T9339)
+   last (filter odd [1..1000])
+
+After optimisation, including SpecConstr, we get:
+   f :: Int# -> Int -> Int
+   f x y = case case remInt# x 2# of
+             __DEFAULT -> case x of
+                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)
+                            1000000# -> ...
+             0# -> case x of
+                     __DEFAULT -> f (+# wild_Xp 1#) y
+                    1000000#   -> y
+
+Not good!  We build an (I# x) box every time around the loop.
+SpecConstr (as described in the paper) does not specialise f, despite
+the call (f ... (I# x)) because 'y' is not scrutinied in the body.
+But it is much better to specialise f for the case where the argument
+is of form (I# x); then we build the box only when returning y, which
+is on the cold path.
+
+Another example:
+
+   f x = ...(g x)....
+
+Here 'x' is not scrutinised in f's body; but if we did specialise 'f'
+then the call (g x) might allow 'g' to be specialised in turn.
+
+So sc_keen controls whether or not we take account of whether argument is
+scrutinised in the body.  True <=> ignore that, and speicalise whenever
+the function is applied to a data constructor.
+-}
+
+data ScEnv = SCE { sc_dflags    :: DynFlags,
+                   sc_module    :: !Module,
+                   sc_size      :: Maybe Int,   -- Size threshold
+                                                -- Nothing => no limit
+
+                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn
+                                                -- Nothing => no limit
+                                                -- See Note [Avoiding exponential blowup]
+
+                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.
+                                                -- Stops ForceSpecConstr from diverging.
+
+                   sc_keen     :: Bool,         -- Specialise on arguments that are known
+                                                -- constructors, even if they are not
+                                                -- scrutinised in the body.  See
+                                                -- Note [Making SpecConstr keener]
+
+                   sc_force     :: Bool,        -- Force specialisation?
+                                                -- See Note [Forcing specialisation]
+
+                   sc_subst     :: Subst,       -- Current substitution
+                                                -- Maps InIds to OutExprs
+
+                   sc_how_bound :: HowBoundEnv,
+                        -- Binds interesting non-top-level variables
+                        -- Domain is OutVars (*after* applying the substitution)
+
+                   sc_vals      :: ValueEnv,
+                        -- Domain is OutIds (*after* applying the substitution)
+                        -- Used even for top-level bindings (but not imported ones)
+                        -- The range of the ValueEnv is *work-free* values
+                        -- such as (\x. blah), or (Just v)
+                        -- but NOT (Just (expensive v))
+                        -- See Note [Work-free values only in environment]
+
+                   sc_annotations :: UniqFM SpecConstrAnnotation
+             }
+
+---------------------
+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
+
+---------------------
+type ValueEnv = IdEnv Value             -- Domain is OutIds
+data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
+                                        --   The AltCon is never DEFAULT
+              | LambdaVal               -- Inlinable lambdas or PAPs
+
+instance Outputable Value where
+   ppr (ConVal con args) = ppr con <+> interpp'SP args
+   ppr LambdaVal         = text "<Lambda>"
+
+---------------------
+initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv
+initScEnv dflags this_mod anns
+  = SCE { sc_dflags      = dflags,
+          sc_module      = this_mod,
+          sc_size        = specConstrThreshold dflags,
+          sc_count       = specConstrCount     dflags,
+          sc_recursive   = specConstrRecursive dflags,
+          sc_keen        = gopt Opt_SpecConstrKeen dflags,
+          sc_force       = False,
+          sc_subst       = emptySubst,
+          sc_how_bound   = emptyVarEnv,
+          sc_vals        = emptyVarEnv,
+          sc_annotations = anns }
+
+data HowBound = RecFun  -- These are the recursive functions for which
+                        -- we seek interesting call patterns
+
+              | RecArg  -- These are those functions' arguments, or their sub-components;
+                        -- we gather occurrence information for these
+
+instance Outputable HowBound where
+  ppr RecFun = text "RecFun"
+  ppr RecArg = text "RecArg"
+
+scForce :: ScEnv -> Bool -> ScEnv
+scForce env b = env { sc_force = b }
+
+lookupHowBound :: ScEnv -> Id -> Maybe HowBound
+lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
+
+scSubstId :: ScEnv -> Id -> CoreExpr
+scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
+
+scSubstTy :: ScEnv -> Type -> Type
+scSubstTy env ty = substTy (sc_subst env) ty
+
+scSubstCo :: ScEnv -> Coercion -> Coercion
+scSubstCo env co = substCo (sc_subst env) co
+
+zapScSubst :: ScEnv -> ScEnv
+zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
+
+extendScInScope :: ScEnv -> [Var] -> ScEnv
+        -- Bring the quantified variables into scope
+extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
+
+        -- Extend the substitution
+extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
+extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
+
+extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
+extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
+
+extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
+extendHowBound env bndrs how_bound
+  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
+                            [(bndr,how_bound) | bndr <- bndrs] }
+
+extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
+extendBndrsWith how_bound env bndrs
+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
+  where
+    (subst', bndrs') = substBndrs (sc_subst env) bndrs
+    hb_env' = sc_how_bound env `extendVarEnvList`
+                    [(bndr,how_bound) | bndr <- bndrs']
+
+extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
+extendBndrWith how_bound env bndr
+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
+  where
+    (subst', bndr') = substBndr (sc_subst env) bndr
+    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
+
+extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
+extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
+                      where
+                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
+
+extendBndr :: ScEnv -> Var -> (ScEnv, Var)
+extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
+                      where
+                        (subst', bndr') = substBndr (sc_subst env) bndr
+
+extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
+extendValEnv env _  Nothing   = env
+extendValEnv env id (Just cv)
+ | valueIsWorkFree cv      -- Don't duplicate work!!  #7865
+ = env { sc_vals = extendVarEnv (sc_vals env) id cv }
+extendValEnv env _ _ = env
+
+extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
+-- When we encounter
+--      case scrut of b
+--          C x y -> ...
+-- we want to bind b, to (C x y)
+-- NB1: Extends only the sc_vals part of the envt
+-- NB2: Kill the dead-ness info on the pattern binders x,y, since
+--      they are potentially made alive by the [b -> C x y] binding
+extendCaseBndrs env scrut case_bndr con alt_bndrs
+   = (env2, alt_bndrs')
+ where
+   live_case_bndr = not (isDeadBinder case_bndr)
+   env1 | Var v <- stripTicksTopE (const True) scrut
+                         = extendValEnv env v cval
+        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]
+   env2 | live_case_bndr = extendValEnv env1 case_bndr cval
+        | otherwise      = env1
+
+   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
+              = map zap alt_bndrs
+              | otherwise
+              = alt_bndrs
+
+   cval = case con of
+                DEFAULT    -> Nothing
+                LitAlt {}  -> Just (ConVal con [])
+                DataAlt {} -> Just (ConVal con vanilla_args)
+                      where
+                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
+                                       varsToCoreExprs alt_bndrs
+
+   zap v | isTyVar v = v                -- See NB2 above
+         | otherwise = zapIdOccInfo v
+
+
+decreaseSpecCount :: ScEnv -> Int -> ScEnv
+-- See Note [Avoiding exponential blowup]
+decreaseSpecCount env n_specs
+  = env { sc_force = False   -- See Note [Forcing specialisation]
+        , sc_count = case sc_count env of
+                       Nothing -> Nothing
+                       Just n  -> Just (n `div` (n_specs + 1)) }
+        -- The "+1" takes account of the original function;
+        -- See Note [Avoiding exponential blowup]
+
+---------------------------------------------------
+-- See Note [Forcing specialisation]
+ignoreType    :: ScEnv -> Type   -> Bool
+ignoreDataCon  :: ScEnv -> DataCon -> Bool
+forceSpecBndr :: ScEnv -> Var    -> Bool
+
+ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
+
+ignoreType env ty
+  = case tyConAppTyCon_maybe ty of
+      Just tycon -> ignoreTyCon env tycon
+      _          -> False
+
+ignoreTyCon :: ScEnv -> TyCon -> Bool
+ignoreTyCon env tycon
+  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
+
+forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
+
+forceSpecFunTy :: ScEnv -> Type -> Bool
+forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
+
+forceSpecArgTy :: ScEnv -> Type -> Bool
+forceSpecArgTy env ty
+  | Just ty' <- coreView ty = forceSpecArgTy env ty'
+
+forceSpecArgTy env ty
+  | Just (tycon, tys) <- splitTyConApp_maybe ty
+  , tycon /= funTyCon
+      = tyConName tycon == specTyConName
+        || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
+        || any (forceSpecArgTy env) tys
+
+forceSpecArgTy _ _ = False
+
+{-
+Note [Add scrutinee to ValueEnv too]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+By the time we get to the call (f y), the ValueEnv
+will have a binding for y, and for c
+    y -> (a,b)
+    c -> I# v
+BUT that's not enough!  Looking at the call (f y) we
+see that y is pair (a,b), but we also need to know what 'b' is.
+So in extendCaseBndrs we must *also* add the binding
+   b -> I# v
+else we lose a useful specialisation for f.  This is necessary even
+though the simplifier has systematically replaced uses of 'x' with 'y'
+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came
+from outside the case.  See #4908 for the live example.
+
+Note [Avoiding exponential blowup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The sc_count field of the ScEnv says how many times we are prepared to
+duplicate a single function.  But we must take care with recursive
+specialisations.  Consider
+
+        let $j1 = let $j2 = let $j3 = ...
+                            in
+                            ...$j3...
+                  in
+                  ...$j2...
+        in
+        ...$j1...
+
+If we specialise $j1 then in each specialisation (as well as the original)
+we can specialise $j2, and similarly $j3.  Even if we make just *one*
+specialisation of each, because we also have the original we'll get 2^n
+copies of $j3, which is not good.
+
+So when recursively specialising we divide the sc_count by the number of
+copies we are making at this level, including the original.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Usage information: flows upwards}
+*                                                                      *
+************************************************************************
+-}
+
+data ScUsage
+   = SCU {
+        scu_calls :: CallEnv,           -- Calls
+                                        -- The functions are a subset of the
+                                        --      RecFuns in the ScEnv
+
+        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
+     }                                  -- The domain is OutIds
+
+type CallEnv = IdEnv [Call]
+data Call = Call Id [CoreArg] ValueEnv
+        -- The arguments of the call, together with the
+        -- env giving the constructor bindings at the call site
+        -- We keep the function mainly for debug output
+
+instance Outputable ScUsage where
+  ppr (SCU { scu_calls = calls, scu_occs = occs })
+    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls
+                                         , text "occs =" <+> ppr occs ])
+
+instance Outputable Call where
+  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)
+
+nullUsage :: ScUsage
+nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
+
+combineCalls :: CallEnv -> CallEnv -> CallEnv
+combineCalls = plusVarEnv_C (++)
+  where
+--    plus cs ds | length res > 1
+--               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs
+--                                               , text "ds:" <+> ppr ds])
+--                 res
+--               | otherwise = res
+--       where
+--          res = cs ++ ds
+
+combineUsage :: ScUsage -> ScUsage -> ScUsage
+combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
+                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
+
+combineUsages :: [ScUsage] -> ScUsage
+combineUsages [] = nullUsage
+combineUsages us = foldr1 combineUsage us
+
+lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
+     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
+
+data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
+            | UnkOcc    -- Used in some unknown way
+
+            | ScrutOcc  -- See Note [ScrutOcc]
+                 (DataConEnv [ArgOcc])   -- How the sub-components are used
+
+type DataConEnv a = UniqFM a     -- Keyed by DataCon
+
+{- Note  [ScrutOcc]
+~~~~~~~~~~~~~~~~~~~
+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
+is *only* taken apart or applied.
+
+  Functions, literal: ScrutOcc emptyUFM
+  Data constructors:  ScrutOcc subs,
+
+where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
+The domain of the UniqFM is the Unique of the data constructor
+
+The [ArgOcc] is the occurrences of the *pattern-bound* components
+of the data structure.  E.g.
+        data T a = forall b. MkT a b (b->a)
+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
+
+-}
+
+instance Outputable ArgOcc where
+  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs
+  ppr UnkOcc        = text "unk-occ"
+  ppr NoOcc         = text "no-occ"
+
+evalScrutOcc :: ArgOcc
+evalScrutOcc = ScrutOcc emptyUFM
+
+-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
+-- that if the thing is scrutinised anywhere then we get to see that
+-- in the overall result, even if it's also used in a boxed way
+-- This might be too aggressive; see Note [Reboxing] Alternative 3
+combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
+combineOcc NoOcc         occ           = occ
+combineOcc occ           NoOcc         = occ
+combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
+combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys
+combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs
+combineOcc UnkOcc        UnkOcc        = UnkOcc
+
+combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
+combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
+
+setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
+-- is a variable, and an interesting variable
+setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ
+setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ
+setScrutOcc env usg (Var v)    occ
+  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
+  | otherwise                           = usg
+setScrutOcc _env usg _other _occ        -- Catch-all
+  = usg
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The main recursive function}
+*                                                                      *
+************************************************************************
+
+The main recursive function gathers up usage information, and
+creates specialised versions of functions.
+-}
+
+scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
+        -- The unique supply is needed when we invent
+        -- a new name for the specialised function and its args
+
+scExpr env e = scExpr' env e
+
+scExpr' env (Var v)      = case scSubstId env v of
+                            Var v' -> return (mkVarUsage env v' [], Var v')
+                            e'     -> scExpr (zapScSubst env) e'
+
+scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))
+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
+scExpr' _   e@(Lit {})   = return (nullUsage, e)
+scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e
+                              return (usg, Tick t e')
+scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e
+                              return (usg, mkCast e' (scSubstCo env co))
+                              -- Important to use mkCast here
+                              -- See Note [SpecConstr call patterns]
+scExpr' env e@(App _ _)  = scApp env (collectArgs e)
+scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b
+                              (usg, e') <- scExpr env' e
+                              return (usg, Lam b' e')
+
+scExpr' env (Case scrut b ty alts)
+  = do  { (scrut_usg, scrut') <- scExpr env scrut
+        ; case isValue (sc_vals env) scrut' of
+                Just (ConVal con args) -> sc_con_app con args scrut'
+                _other                 -> sc_vanilla scrut_usg scrut'
+        }
+  where
+    sc_con_app con args scrut'  -- Known constructor; simplify
+     = do { let (_, bs, rhs) = findAlt con alts
+                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)
+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
+          ; scExpr alt_env' rhs }
+
+    sc_vanilla scrut_usg scrut' -- Normal case
+     = do { let (alt_env,b') = extendBndrWith RecArg env b
+                        -- Record RecArg for the components
+
+          ; (alt_usgs, alt_occs, alts')
+                <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
+
+          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs
+                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
+                -- The combined usage of the scrutinee is given
+                -- by scrut_occ, which is passed to scScrut, which
+                -- in turn treats a bare-variable scrutinee specially
+
+          ; return (foldr combineUsage scrut_usg' alt_usgs,
+                    Case scrut' b' (scSubstTy env ty) alts') }
+
+    sc_alt env scrut' b' (con,bs,rhs)
+     = do { let (env1, bs1) = extendBndrsWith RecArg env bs
+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
+          ; (usg, rhs') <- scExpr env2 rhs
+          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
+                scrut_occ = case con of
+                               DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
+                               _          -> ScrutOcc emptyUFM
+          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
+
+scExpr' env (Let (NonRec bndr rhs) body)
+  | isTyVar bndr        -- Type-lets may be created by doBeta
+  = scExpr' (extendScSubst env bndr rhs) body
+
+  | otherwise
+  = do  { let (body_env, bndr') = extendBndr env bndr
+        ; rhs_info  <- scRecRhs env (bndr',rhs)
+
+        ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+                           -- Note [Local let bindings]
+              rhs'      = ri_new_rhs rhs_info
+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
+
+        ; (body_usg, body') <- scExpr body_env3 body
+
+          -- NB: For non-recursive bindings we inherit sc_force flag from
+          -- the parent function (see Note [Forcing specialisation])
+        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info
+
+        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
+                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]
+                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')
+        }
+
+
+-- A *local* recursive group: see Note [Local recursive groups]
+scExpr' env (Let (Rec prs) body)
+  = do  { let (bndrs,rhss)      = unzip prs
+              (rhs_env1,bndrs') = extendRecBndrs env bndrs
+              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun
+              force_spec        = any (forceSpecBndr env) bndrs'
+                -- Note [Forcing specialisation]
+
+        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
+        ; (body_usg, body')     <- scExpr rhs_env2 body
+
+        -- NB: start specLoop from body_usg
+        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)
+                                       body_usg rhs_infos
+                -- Do not unconditionally generate specialisations from rhs_usgs
+                -- Instead use them only if we find an unspecialised call
+                -- See Note [Local recursive groups]
+
+        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]
+              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))
+
+        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
+                  Let bind' body') }
+
+{-
+Note [Local let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is not uncommon to find this
+
+   let $j = \x. <blah> in ...$j True...$j True...
+
+Here $j is an arbitrary let-bound function, but it often comes up for
+join points.  We might like to specialise $j for its call patterns.
+Notice the difference from a letrec, where we look for call patterns
+in the *RHS* of the function.  Here we look for call patterns in the
+*body* of the let.
+
+At one point I predicated this on the RHS mentioning the outer
+recursive function, but that's not essential and might even be
+harmful.  I'm not sure.
+-}
+
+scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
+
+scApp env (Var fn, args)        -- Function is a variable
+  = ASSERT( not (null args) )
+    do  { args_w_usgs <- mapM (scExpr env) args
+        ; let (arg_usgs, args') = unzip args_w_usgs
+              arg_usg = combineUsages arg_usgs
+        ; case scSubstId env fn of
+            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
+                        -- Do beta-reduction and try again
+
+            Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
+                               mkApps (Var fn') args')
+
+            other_fn' -> return (arg_usg, mkApps other_fn' args') }
+                -- NB: doing this ignores any usage info from the substituted
+                --     function, but I don't think that matters.  If it does
+                --     we can fix it.
+  where
+    doBeta :: OutExpr -> [OutExpr] -> OutExpr
+    -- ToDo: adjust for System IF
+    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
+    doBeta fn              args         = mkApps fn args
+
+-- The function is almost always a variable, but not always.
+-- In particular, if this pass follows float-in,
+-- which it may, we can get
+--      (let f = ...f... in f) arg1 arg2
+scApp env (other_fn, args)
+  = do  { (fn_usg,   fn')   <- scExpr env other_fn
+        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
+
+----------------------
+mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
+mkVarUsage env fn args
+  = case lookupHowBound env fn of
+        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]
+                           , scu_occs  = emptyVarEnv }
+        Just RecArg -> SCU { scu_calls = emptyVarEnv
+                           , scu_occs  = unitVarEnv fn arg_occ }
+        Nothing     -> nullUsage
+  where
+    -- I rather think we could use UnkOcc all the time
+    arg_occ | null args = UnkOcc
+            | otherwise = evalScrutOcc
+
+----------------------
+scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
+scTopBindEnv env (Rec prs)
+  = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
+              rhs_env2          = extendHowBound rhs_env1 bndrs RecFun
+
+              prs'              = zip bndrs' rhss
+        ; return (rhs_env2, Rec prs') }
+  where
+    (bndrs,rhss) = unzip prs
+
+scTopBindEnv env (NonRec bndr rhs)
+  = do  { let (env1, bndr') = extendBndr env bndr
+              env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)
+        ; return (env2, NonRec bndr' rhs) }
+
+----------------------
+scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
+
+{-
+scTopBind _ usage _
+  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False
+  = error "false"
+-}
+
+scTopBind env body_usage (Rec prs)
+  | Just threshold <- sc_size env
+  , not force_spec
+  , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)
+                -- No specialisation
+  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $
+    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss
+        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }
+
+  | otherwise   -- Do specialisation
+  = do  { rhs_infos <- mapM (scRecRhs env) prs
+
+        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)
+                                         body_usage rhs_infos
+
+        ; return (body_usage `combineUsage` spec_usage,
+                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }
+  where
+    (bndrs,rhss) = unzip prs
+    force_spec   = any (forceSpecBndr env) bndrs
+      -- Note [Forcing specialisation]
+
+scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions
+  = do  { (rhs_usg', rhs') <- scExpr env rhs
+        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }
+
+----------------------
+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
+scRecRhs env (bndr,rhs)
+  = do  { let (arg_bndrs,body)       = collectBinders rhs
+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
+        ; (body_usg, body')         <- scExpr body_env body
+        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'
+        ; return (RI { ri_rhs_usg = rhs_usg
+                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'
+                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body
+                     , ri_arg_occs = arg_occs }) }
+                -- The arg_occs says how the visible,
+                -- lambda-bound binders of the RHS are used
+                -- (including the TyVar binders)
+                -- Two pats are the same if they match both ways
+
+----------------------
+ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })
+              (SI { si_specs = specs })
+  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++
+              -- First the specialised bindings
+
+    [(fn `addIdSpecialisations` rules, new_rhs)]
+              -- And now the original binding
+  where
+    rules = [r | OS { os_rule = r } <- specs]
+
+{-
+************************************************************************
+*                                                                      *
+                The specialiser itself
+*                                                                      *
+************************************************************************
+-}
+
+data RhsInfo
+  = RI { ri_fn :: OutId                 -- The binder
+       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)
+       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS
+
+       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)
+       , ri_lam_body  :: InExpr        --   Note [Specialise original body]
+       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body
+    }
+
+data SpecInfo       -- Info about specialisations for a particular Id
+  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated
+
+       , si_n_specs :: Int              -- Length of si_specs; used for numbering them
+
+       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the
+       }                                --             from calls in the *original* RHS as
+                                        --             seeds for new specialisations;
+                                        --             if you decide to do so, here is the
+                                        --             RHS usage (which has not yet been
+                                        --             unleashed)
+                                        -- Nothing => we have
+                                        -- See Note [Local recursive groups]
+                                        -- See Note [spec_usg includes rhs_usg]
+
+        -- One specialisation: Rule plus definition
+data OneSpec =
+  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation
+     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation
+     , os_id   :: OutId      -- Spec id
+     , os_rhs  :: OutExpr }  -- Spec rhs
+
+noSpecInfo :: SpecInfo
+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }
+
+----------------------
+specNonRec :: ScEnv
+           -> ScUsage         -- Body usage
+           -> RhsInfo         -- Structure info usage info for un-specialised RHS
+           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)
+                                               --     plus details of specialisations
+
+specNonRec env body_usg rhs_info
+  = specialise env (scu_calls body_usg) rhs_info
+               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })
+
+----------------------
+specRec :: TopLevelFlag -> ScEnv
+        -> ScUsage                         -- Body usage
+        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs
+        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)
+                                           --     plus details of specialisations
+
+specRec top_lvl env body_usg rhs_infos
+  = go 1 seed_calls nullUsage init_spec_infos
+  where
+    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]
+       | isTopLevel top_lvl
+       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs
+       = (all_calls,     [noSpecInfo | _ <- rhs_infos])
+       | otherwise                              -- Seed from body only
+       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }
+                         | ri <- rhs_infos])
+
+    calls_in_body = scu_calls body_usg
+    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos
+    all_calls = calls_in_rhss `combineCalls` calls_in_body
+
+    -- Loop, specialising, until you get no new specialisations
+    go :: Int   -- Which iteration of the "until no new specialisations"
+                -- loop we are on; first iteration is 1
+       -> CallEnv   -- Seed calls
+                    -- Two accumulating parameters:
+       -> ScUsage      -- Usage from earlier specialisations
+       -> [SpecInfo]   -- Details of specialisations so far
+       -> UniqSM (ScUsage, [SpecInfo])
+    go n_iter seed_calls usg_so_far spec_infos
+      | isEmptyVarEnv seed_calls
+      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)
+        --                           , ppr seed_calls
+        --                           , ppr body_usg ]) $
+        return (usg_so_far, spec_infos)
+
+      -- Limit recursive specialisation
+      -- See Note [Limit recursive specialisation]
+      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop
+      , sc_force env || isNothing (sc_count env)
+           -- If both of these are false, the sc_count
+           -- threshold will prevent non-termination
+      , any ((> the_limit) . si_n_specs) spec_infos
+      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
+        return (usg_so_far, spec_infos)
+
+      | otherwise
+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
+        --                           , text "iteration" <+> int n_iter
+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
+        --                    ]) $
+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
+            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg
+                  extra_usg = combineUsages extra_usg_s
+                  all_usg   = usg_so_far `combineUsage` extra_usg
+            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }
+
+    -- See Note [Limit recursive specialisation]
+    the_limit = case sc_count env of
+                  Nothing  -> 10    -- Ugh!
+                  Just max -> max
+
+
+----------------------
+specialise
+   :: ScEnv
+   -> CallEnv                     -- Info on newly-discovered calls to this function
+   -> RhsInfo
+   -> SpecInfo                    -- Original RHS plus patterns dealt with
+   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage
+
+-- See Note [spec_usg includes rhs_usg]
+
+-- Note: this only generates *specialised* bindings
+-- The original binding is added by ruleInfoBinds
+--
+-- Note: the rhs here is the optimised version of the original rhs
+-- So when we make a specialised copy of the RHS, we're starting
+-- from an RHS whose nested functions have been optimised already.
+
+specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
+                              , ri_lam_body = body, ri_arg_occs = arg_occs })
+               spec_info@(SI { si_specs = specs, si_n_specs = spec_count
+                             , si_mb_unspec = mb_unspec })
+  | isBottomingId fn      -- Note [Do not specialise diverging functions]
+                          -- and do not generate specialisation seeds from its RHS
+  = -- pprTrace "specialise bot" (ppr fn) $
+    return (nullUsage, spec_info)
+
+  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]
+    || null arg_bndrs                     -- Only specialise functions
+  = -- pprTrace "specialise inactive" (ppr fn) $
+    case mb_unspec of    -- Behave as if there was a single, boring call
+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })
+                         -- See Note [spec_usg includes rhs_usg]
+      Nothing      -> return (nullUsage, spec_info)
+
+  | Just all_calls <- lookupVarEnv bind_calls fn
+  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
+    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls
+
+        ; let n_pats = length new_pats
+--        ; if (not (null new_pats) || isJust mb_unspec) then
+--            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
+--                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)
+--                                        , text "arg_occs" <+> ppr arg_occs
+--                                        , text "good pats" <+> ppr new_pats])  $
+--               return ()
+--          else return ()
+
+        ; let spec_env = decreaseSpecCount env n_pats
+        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
+                                                 (new_pats `zip` [spec_count..])
+                -- See Note [Specialise original body]
+
+        ; let spec_usg = combineUsages spec_usgs
+
+              -- If there were any boring calls among the seeds (= all_calls), then those
+              -- calls will call the un-specialised function.  So we should use the seeds
+              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
+              -- then in new_usg.
+              (new_usg, mb_unspec')
+                  = case mb_unspec of
+                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
+                      _                          -> (spec_usg,                      mb_unspec)
+
+--        ; pprTrace "specialise return }"
+--             (vcat [ ppr fn
+--                   , text "boring_call:" <+> ppr boring_call
+--                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $
+--          return ()
+
+          ; return (new_usg, SI { si_specs = new_specs ++ specs
+                                , si_n_specs = spec_count + n_pats
+                                , si_mb_unspec = mb_unspec' }) }
+
+  | otherwise  -- No new seeds, so return nullUsage
+  = return (nullUsage, spec_info)
+
+
+
+
+---------------------
+spec_one :: ScEnv
+         -> OutId       -- Function
+         -> [InVar]     -- Lambda-binders of RHS; should match patterns
+         -> InExpr      -- Body of the original function
+         -> (CallPat, Int)
+         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
+
+-- spec_one creates a specialised copy of the function, together
+-- with a rule for using it.  I'm very proud of how short this
+-- function is, considering what it does :-).
+
+{-
+  Example
+
+     In-scope: a, x::a
+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
+          [c::*, v::(b,c) are presumably bound by the (...) part]
+  ==>
+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
+                  (...entire body of f...) [b -> (b,c),
+                                            y -> ((:) (a,(b,c)) (x,v) hw)]
+
+     RULE:  forall b::* c::*,           -- Note, *not* forall a, x
+                   v::(b,c),
+                   hw::[(a,(b,c))] .
+
+            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
+-}
+
+spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
+  = do  { spec_uniq <- getUniqueM
+        ; let spec_env   = extendScSubstList (extendScInScope env qvars)
+                                             (arg_bndrs `zip` pats)
+              fn_name    = idName fn
+              fn_loc     = nameSrcSpan fn_name
+              fn_occ     = nameOccName fn_name
+              spec_occ   = mkSpecOcc fn_occ
+              -- We use fn_occ rather than fn in the rule_name string
+              -- as we don't want the uniq to end up in the rule, and
+              -- hence in the ABI, as that can cause spurious ABI
+              -- changes (#4012).
+              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)
+              spec_name  = mkInternalName spec_uniq spec_occ fn_loc
+--      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn
+--                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $
+--        return ()
+
+        -- Specialise the body
+        ; (spec_usg, spec_body) <- scExpr spec_env body
+
+--      ; pprTrace "done spec_one}" (ppr fn) $
+--        return ()
+
+                -- And build the results
+        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)
+                                                             qvars body_ty
+                -- Usual w/w hack to avoid generating
+                -- a spec_rhs of unlifted type and no args
+
+              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args
+                -- Annotate the variables with the strictness information from
+                -- the function (see Note [Strictness information in worker binders])
+
+              spec_join_arity | isJoinId fn = Just (length spec_lam_args)
+                              | otherwise   = Nothing
+              spec_id    = mkLocalIdOrCoVar spec_name
+                                            (mkLamTypes spec_lam_args body_ty)
+                             -- See Note [Transfer strictness]
+                             `setIdStrictness` spec_str
+                             `setIdArity` count isId spec_lam_args
+                             `asJoinId_maybe` spec_join_arity
+              spec_str   = calcSpecStrictness fn spec_lam_args pats
+
+
+                -- Conditionally use result of new worker-wrapper transform
+              spec_rhs   = mkLams spec_lam_args_str spec_body
+              body_ty    = exprType spec_body
+              rule_rhs   = mkVarApps (Var spec_id) spec_call_args
+              inline_act = idInlineActivation fn
+              this_mod   = sc_module spec_env
+              rule       = mkRule this_mod True {- Auto -} True {- Local -}
+                                  rule_name inline_act fn_name qvars pats rule_rhs
+                           -- See Note [Transfer activation]
+        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
+                               , os_id = spec_id
+                               , os_rhs = spec_rhs }) }
+
+
+-- See Note [Strictness information in worker binders]
+handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]
+handOutStrictnessInformation = go
+  where
+    go _ [] = []
+    go [] vs = vs
+    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs
+    go dmds (v:vs) = v : go dmds vs
+
+calcSpecStrictness :: Id                     -- The original function
+                   -> [Var] -> [CoreExpr]    -- Call pattern
+                   -> StrictSig              -- Strictness of specialised thing
+-- See Note [Transfer strictness]
+calcSpecStrictness fn qvars pats
+  = mkClosedStrictSig spec_dmds topRes
+  where
+    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
+    StrictSig (DmdType _ dmds _) = idStrictness fn
+
+    dmd_env = go emptyVarEnv dmds pats
+
+    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
+    go env ds (Type {} : pats)     = go env ds pats
+    go env ds (Coercion {} : pats) = go env ds pats
+    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats
+    go env _      _                = env
+
+    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
+    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
+    go_one env d e
+           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
+           , (Var _, args) <- collectArgs e = go env ds args
+    go_one env _         _ = env
+
+{-
+Note [spec_usg includes rhs_usg]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In calls to 'specialise', the returned ScUsage must include the rhs_usg in
+the passed-in SpecInfo, unless there are no calls at all to the function.
+
+The caller can, indeed must, assume this.  He should not combine in rhs_usg
+himself, or he'll get rhs_usg twice -- and that can lead to an exponential
+blowup of duplicates in the CallEnv.  This is what gave rise to the massive
+performance loss in #8852.
+
+Note [Specialise original body]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RhsInfo for a binding keeps the *original* body of the binding.  We
+must specialise that, *not* the result of applying specExpr to the RHS
+(which is also kept in RhsInfo). Otherwise we end up specialising a
+specialised RHS, and that can lead directly to exponential behaviour.
+
+Note [Transfer activation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+  This note is for SpecConstr, but exactly the same thing
+  happens in the overloading specialiser; see
+  Note [Auto-specialisation and RULES] in Specialise.
+
+In which phase should the specialise-constructor rules be active?
+Originally I made them always-active, but Manuel found that this
+defeated some clever user-written rules.  Then I made them active only
+in Phase 0; after all, currently, the specConstr transformation is
+only run after the simplifier has reached Phase 0, but that meant
+that specialisations didn't fire inside wrappers; see test
+simplCore/should_compile/spec-inline.
+
+So now I just use the inline-activation of the parent Id, as the
+activation for the specialisation RULE, just like the main specialiser;
+
+This in turn means there is no point in specialising NOINLINE things,
+so we test for that.
+
+Note [Transfer strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must transfer strictness information from the original function to
+the specialised one.  Suppose, for example
+
+  f has strictness     SS
+        and a RULE     f (a:as) b = f_spec a as b
+
+Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need
+when calling f_spec instead of call-by-value.  And that can result in
+unbounded worsening in space (cf the classic foldl vs foldl')
+
+See #3437 for a good example.
+
+The function calcSpecStrictness performs the calculation.
+
+Note [Strictness information in worker binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+After having calculated the strictness annotation for the worker (see Note
+[Transfer strictness] above), we also want to have this information attached to
+the worker’s arguments, for the benefit of later passes. The function
+handOutStrictnessInformation decomposes the strictness annotation calculated by
+calcSpecStrictness and attaches them to the variables.
+
+************************************************************************
+*                                                                      *
+\subsection{Argument analysis}
+*                                                                      *
+************************************************************************
+
+This code deals with analysing call-site arguments to see whether
+they are constructor applications.
+
+Note [Free type variables of the qvar types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a call (f @a x True), that we want to specialise, what variables should
+we quantify over.  Clearly over 'a' and 'x', but what about any type variables
+free in x's type?  In fact we don't need to worry about them because (f @a)
+can only be a well-typed application if its type is compatible with x, so any
+variables free in x's type must be free in (f @a), and hence either be gathered
+via 'a' itself, or be in scope at f's defn.  Hence we just take
+  (exprsFreeVars pats).
+
+BUT phantom type synonyms can mess this reasoning up,
+  eg   x::T b   with  type T b = Int
+So we apply expandTypeSynonyms to the bound Ids.
+See # 5458.  Yuk.
+
+Note [SpecConstr call patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "call patterns" that we collect is going to become the LHS of a RULE.
+It's important that it doesn't have
+     e |> Refl
+or
+    e |> g1 |> g2
+because both of these will be optimised by Simplify.simplRule. In the
+former case such optimisation benign, because the rule will match more
+terms; but in the latter we may lose a binding of 'g1' or 'g2', and
+end up with a rule LHS that doesn't bind the template variables
+(#10602).
+
+The simplifier eliminates such things, but SpecConstr itself constructs
+new terms by substituting.  So the 'mkCast' in the Cast case of scExpr
+is very important!
+
+Note [Choosing patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If we get lots of patterns we may not want to make a specialisation
+for each of them (code bloat), so we choose as follows, implemented
+by trim_pats.
+
+* The flag -fspec-constr-count-N sets the sc_count field
+  of the ScEnv to (Just n).  This limits the total number
+  of specialisations for a given function to N.
+
+* -fno-spec-constr-count sets the sc_count field to Nothing,
+  which switches of the limit.
+
+* The ghastly ForceSpecConstr trick also switches of the limit
+  for a particular function
+
+* Otherwise we sort the patterns to choose the most general
+  ones first; more general => more widely applicable.
+
+Note [SpecConstr and casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#14270) a call like
+
+    let f = e
+    in ... f (K @(a |> co)) ...
+
+where 'co' is a coercion variable not in scope at f's definition site.
+If we aren't caereful we'll get
+
+    let $sf a co = e (K @(a |> co))
+        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co
+        f = e
+    in ...
+
+But alas, when we match the call we won't bind 'co', because type-matching
+(for good reasons) discards casts).
+
+I don't know how to solve this, so for now I'm just discarding any
+call patterns that
+  * Mentions a coercion variable in a type argument
+  * That is not in scope at the binding of the function
+
+I think this is very rare.
+
+It is important (e.g. #14936) that this /only/ applies to
+coercions mentioned in casts.  We don't want to be discombobulated
+by casts in terms!  For example, consider
+   f ((e1,e2) |> sym co)
+where, say,
+   f  :: Foo -> blah
+   co :: Foo ~R (Int,Int)
+
+Here we definitely do want to specialise for that pair!  We do not
+match on the structre of the coercion; instead we just match on a
+coercion variable, so the RULE looks like
+
+   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)
+     f ((x,y) |> co) = $sf x y co
+
+Often the body of f looks like
+   f arg = ...(case arg |> co' of
+                (x,y) -> blah)...
+
+so that the specialised f will turn into
+   $sf x y co = let arg = (x,y) |> co
+                in ...(case arg>| co' of
+                         (x,y) -> blah)....
+
+which will simplify to not use 'co' at all.  But we can't guarantee
+that co will end up unused, so we still pass it.  Absence analysis
+may remove it later.
+
+Note that this /also/ discards the call pattern if we have a cast in a
+/term/, although in fact Rules.match does make a very flaky and
+fragile attempt to match coercions.  e.g. a call like
+    f (Maybe Age) (Nothing |> co) blah
+    where co :: Maybe Int ~ Maybe Age
+will be discarded.  It's extremely fragile to match on the form of a
+coercion, so I think it's better just not to try.  A more complicated
+alternative would be to discard calls that mention coercion variables
+only in kind-casts, but I'm doing the simple thing for now.
+-}
+
+type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
+                                        -- See Note [SpecConstr call patterns]
+
+callsToNewPats :: ScEnv -> Id
+               -> SpecInfo
+               -> [ArgOcc] -> [Call]
+               -> UniqSM (Bool, [CallPat])
+        -- Result has no duplicate patterns,
+        -- nor ones mentioned in done_pats
+        -- Bool indicates that there was at least one boring pattern
+callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
+  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
+
+        ; let have_boring_call = any isNothing mb_pats
+
+              good_pats :: [CallPat]
+              good_pats = catMaybes mb_pats
+
+              -- Remove patterns we have already done
+              new_pats = filterOut is_done good_pats
+              is_done p = any (samePat p . os_pat) done_specs
+
+              -- Remove duplicates
+              non_dups = nubBy samePat new_pats
+
+              -- Remove ones that have too many worker variables
+              small_pats = filterOut too_big non_dups
+              too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)
+                  -- We are about to construct w/w pair in 'spec_one'.
+                  -- Omit specialisation leading to high arity workers.
+                  -- See Note [Limit w/w arity] in WwLib
+
+                -- Discard specialisations if there are too many of them
+              trimmed_pats = trim_pats env fn spec_info small_pats
+
+--        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+--                                       , text "done_specs:" <+> ppr (map os_pat done_specs)
+--                                       , text "good_pats:" <+> ppr good_pats ]) $
+--          return ()
+
+        ; return (have_boring_call, trimmed_pats) }
+
+
+trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]
+-- See Note [Choosing patterns]
+trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
+  | sc_force env
+    || isNothing mb_scc
+    || n_remaining >= n_pats
+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)
+    pats          -- No need to trim
+
+  | otherwise
+  = emit_trace $  -- Need to trim, so keep the best ones
+    take n_remaining sorted_pats
+
+  where
+    n_pats         = length pats
+    spec_count'    = n_pats + done_spec_count
+    n_remaining    = max_specs - done_spec_count
+    mb_scc         = sc_count env
+    Just max_specs = mb_scc
+
+    sorted_pats = map fst $
+                  sortBy (comparing snd) $
+                  [(pat, pat_cons pat) | pat <- pats]
+     -- Sort in order of increasing number of constructors
+     -- (i.e. decreasing generality) and pick the initial
+     -- segment of this list
+
+    pat_cons :: CallPat -> Int
+    -- How many data constructors of literals are in
+    -- the pattern.  More data-cons => less general
+    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps
+       where
+          q_set = mkVarSet qs
+          n_cons (Var v) | v `elemVarSet` q_set = 0
+                         | otherwise            = 1
+          n_cons (Cast e _)  = n_cons e
+          n_cons (App e1 e2) = n_cons e1 + n_cons e2
+          n_cons (Lit {})    = 1
+          n_cons _           = 0
+
+    emit_trace result
+       | debugIsOn || hasPprDebug (sc_dflags env)
+         -- Suppress this scary message for ordinary users!  #5125
+       = pprTrace "SpecConstr" msg result
+       | otherwise
+       = result
+    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)
+                     , nest 2 (text "has" <+>
+                               speakNOf spec_count' (text "call pattern") <> comma <+>
+                               text "but the limit is" <+> int max_specs) ]
+               , text "Use -fspec-constr-count=n to set the bound"
+               , text "done_spec_count =" <+> int done_spec_count
+               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats
+               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]
+
+
+callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
+        -- The [Var] is the variables to quantify over in the rule
+        --      Type variables come first, since they may scope
+        --      over the following term variables
+        -- The [CoreExpr] are the argument patterns for the rule
+callToPats env bndr_occs call@(Call _ args con_env)
+  | args `ltLength` bndr_occs      -- Check saturated
+  = return Nothing
+  | otherwise
+  = do  { let in_scope = substInScope (sc_subst env)
+        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
+        ; let pat_fvs = exprsFreeVarsList pats
+                -- To get determinism we need the list of free variables in
+                -- deterministic order. Otherwise we end up creating
+                -- lambdas with different argument orders. See
+                -- determinism/simplCore/should_compile/spec-inline-determ.hs
+                -- for an example. For explanation of determinism
+                -- considerations See Note [Unique Determinism] in Unique.
+
+              in_scope_vars = getInScopeVars in_scope
+              is_in_scope v = v `elemVarSet` in_scope_vars
+              qvars         = filterOut is_in_scope pat_fvs
+                -- Quantify over variables that are not in scope
+                -- at the call site
+                -- See Note [Free type variables of the qvar types]
+                -- See Note [Shadowing] at the top
+
+              (ktvs, ids)   = partition isTyVar qvars
+              qvars'        = scopedSort ktvs ++ map sanitise ids
+                -- Order into kind variables, type variables, term variables
+                -- The kind of a type variable may mention a kind variable
+                -- and the type of a term variable may mention a type variable
+
+              sanitise id   = id `setIdType` expandTypeSynonyms (idType id)
+                -- See Note [Free type variables of the qvar types]
+
+              -- Bad coercion variables: see Note [SpecConstr and casts]
+              bad_covars :: CoVarSet
+              bad_covars = mapUnionVarSet get_bad_covars pats
+              get_bad_covars :: CoreArg -> CoVarSet
+              get_bad_covars (Type ty)
+                = filterVarSet (\v -> isId v && not (is_in_scope v)) $
+                  tyCoVarsOfType ty
+              get_bad_covars _
+                = emptyVarSet
+
+        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
+          WARN( not (isEmptyVarSet bad_covars)
+              , text "SpecConstr: bad covars:" <+> ppr bad_covars
+                $$ ppr call )
+          if interesting && isEmptyVarSet bad_covars
+          then return (Just (qvars', pats))
+          else return Nothing }
+
+    -- argToPat takes an actual argument, and returns an abstracted
+    -- version, consisting of just the "constructor skeleton" of the
+    -- argument, with non-constructor sub-expression replaced by new
+    -- placeholder variables.  For example:
+    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
+
+argToPat :: ScEnv
+         -> InScopeSet                  -- What's in scope at the fn defn site
+         -> ValueEnv                    -- ValueEnv at the call site
+         -> CoreArg                     -- A call arg (or component thereof)
+         -> ArgOcc
+         -> UniqSM (Bool, CoreArg)
+
+-- Returns (interesting, pat),
+-- where pat is the pattern derived from the argument
+--            interesting=True if the pattern is non-trivial (not a variable or type)
+-- E.g.         x:xs         --> (True, x:xs)
+--              f xs         --> (False, w)        where w is a fresh wildcard
+--              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
+--              \x. x+y      --> (True, \x. x+y)
+--              lvl7         --> (True, lvl7)      if lvl7 is bound
+--                                                 somewhere further out
+
+argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
+  = return (False, arg)
+
+argToPat env in_scope val_env (Tick _ arg) arg_occ
+  = argToPat env in_scope val_env arg arg_occ
+        -- Note [Notes in call patterns]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
+        -- Perhaps we should not ignore profiling notes, but I'm going to
+        -- ride roughshod over them all for now.
+        --- See Note [Notes in RULE matching] in Rules
+
+argToPat env in_scope val_env (Let _ arg) arg_occ
+  = argToPat env in_scope val_env arg arg_occ
+        -- See Note [Matching lets] in Rule.hs
+        -- Look through let expressions
+        -- e.g.         f (let v = rhs in (v,w))
+        -- Here we can specialise for f (v,w)
+        -- because the rule-matcher will look through the let.
+
+{- Disabled; see Note [Matching cases] in Rule.hs
+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
+  | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs
+  = argToPat env in_scope val_env rhs arg_occ
+-}
+
+argToPat env in_scope val_env (Cast arg co) arg_occ
+  | not (ignoreType env ty2)
+  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
+        ; if not interesting then
+                wildCardPat ty2
+          else do
+        { -- Make a wild-card pattern for the coercion
+          uniq <- getUniqueM
+        ; let co_name = mkSysTvName uniq (fsLit "sg")
+              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
+        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
+  where
+    Pair ty1 ty2 = coercionKind co
+
+
+
+{-      Disabling lambda specialisation for now
+        It's fragile, and the spec_loop can be infinite
+argToPat in_scope val_env arg arg_occ
+  | is_value_lam arg
+  = return (True, arg)
+  where
+    is_value_lam (Lam v e)         -- Spot a value lambda, even if
+        | isId v       = True      -- it is inside a type lambda
+        | otherwise    = is_value_lam e
+    is_value_lam other = False
+-}
+
+  -- Check for a constructor application
+  -- NB: this *precedes* the Var case, so that we catch nullary constrs
+argToPat env in_scope val_env arg arg_occ
+  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
+  , Just arg_occs <- mb_scrut dc
+  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
+        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
+        ; return (True,
+                  mkConApp dc (ty_args ++ args')) }
+  where
+    mb_scrut dc = case arg_occ of
+                    ScrutOcc bs | Just occs <- lookupUFM bs dc
+                                -> Just (occs)  -- See Note [Reboxing]
+                    _other      | sc_force env || sc_keen env
+                                -> Just (repeat UnkOcc)
+                                | otherwise
+                                -> Nothing
+
+  -- Check if the argument is a variable that
+  --    (a) is used in an interesting way in the function body
+  --    (b) we know what its value is
+  -- In that case it counts as "interesting"
+argToPat env in_scope val_env (Var v) arg_occ
+  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
+    is_value,                                                            -- (b)
+       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]
+       -- So sc_keen focused just on f (I# x), where we have freshly-allocated
+       -- box that we can eliminate in the caller
+    not (ignoreType env (varType v))
+  = return (True, Var v)
+  where
+    is_value
+        | isLocalId v = v `elemInScopeSet` in_scope
+                        && isJust (lookupVarEnv val_env v)
+                -- Local variables have values in val_env
+        | otherwise   = isValueUnfolding (idUnfolding v)
+                -- Imports have unfoldings
+
+--      I'm really not sure what this comment means
+--      And by not wild-carding we tend to get forall'd
+--      variables that are in scope, which in turn can
+--      expose the weakness in let-matching
+--      See Note [Matching lets] in Rules
+
+  -- Check for a variable bound inside the function.
+  -- Don't make a wild-card, because we may usefully share
+  --    e.g.  f a = let x = ... in f (x,x)
+  -- NB: this case follows the lambda and con-app cases!!
+-- argToPat _in_scope _val_env (Var v) _arg_occ
+--   = return (False, Var v)
+        -- SLPJ : disabling this to avoid proliferation of versions
+        -- also works badly when thinking about seeding the loop
+        -- from the body of the let
+        --       f x y = letrec g z = ... in g (x,y)
+        -- We don't want to specialise for that *particular* x,y
+
+  -- The default case: make a wild-card
+  -- We use this for coercions too
+argToPat _env _in_scope _val_env arg _arg_occ
+  = wildCardPat (exprType arg)
+
+wildCardPat :: Type -> UniqSM (Bool, CoreArg)
+wildCardPat ty
+  = do { uniq <- getUniqueM
+       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty
+       ; return (False, varToCoreExpr id) }
+
+argsToPats :: ScEnv -> InScopeSet -> ValueEnv
+           -> [CoreArg] -> [ArgOcc]  -- Should be same length
+           -> UniqSM (Bool, [CoreArg])
+argsToPats env in_scope val_env args occs
+  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
+       ; let (interesting_s, args') = unzip stuff
+       ; return (or interesting_s, args') }
+
+isValue :: ValueEnv -> CoreExpr -> Maybe Value
+isValue _env (Lit lit)
+  | litIsLifted lit = Nothing
+  | otherwise       = Just (ConVal (LitAlt lit) [])
+
+isValue env (Var v)
+  | Just cval <- lookupVarEnv env v
+  = Just cval  -- You might think we could look in the idUnfolding here
+               -- but that doesn't take account of which branch of a
+               -- case we are in, which is the whole point
+
+  | not (isLocalId v) && isCheapUnfolding unf
+  = isValue env (unfoldingTemplate unf)
+  where
+    unf = idUnfolding v
+        -- However we do want to consult the unfolding
+        -- as well, for let-bound constructors!
+
+isValue env (Lam b e)
+  | isTyVar b = case isValue env e of
+                  Just _  -> Just LambdaVal
+                  Nothing -> Nothing
+  | otherwise = Just LambdaVal
+
+isValue env (Tick t e)
+  | not (tickishIsCode t)
+  = isValue env e
+
+isValue _env expr       -- Maybe it's a constructor application
+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr
+  = case isDataConWorkId_maybe fun of
+
+        Just con | args `lengthAtLeast` dataConRepArity con
+                -- Check saturated; might be > because the
+                --                  arity excludes type args
+                -> Just (ConVal (DataAlt con) args)
+
+        _other | valArgCount args < idArity fun
+                -- Under-applied function
+               -> Just LambdaVal        -- Partial application
+
+        _other -> Nothing
+
+isValue _env _expr = Nothing
+
+valueIsWorkFree :: Value -> Bool
+valueIsWorkFree LambdaVal       = True
+valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
+
+samePat :: CallPat -> CallPat -> Bool
+samePat (vs1, as1) (vs2, as2)
+  = all2 same as1 as2
+  where
+    same (Var v1) (Var v2)
+        | v1 `elem` vs1 = v2 `elem` vs2
+        | v2 `elem` vs2 = False
+        | otherwise     = v1 == v2
+
+    same (Lit l1)    (Lit l2)    = l1==l2
+    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
+
+    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
+    same (Coercion {}) (Coercion {}) = True
+    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes
+    same (Cast e1 _) e2 = same e1 e2
+    same e1 (Tick _ e2) = same e1 e2
+    same e1 (Cast e2 _) = same e1 e2
+
+    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
+                 False  -- Let, lambda, case should not occur
+    bad (Case {}) = True
+    bad (Let {})  = True
+    bad (Lam {})  = True
+    bad _other    = False
+
+{-
+Note [Ignore type differences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want to generate specialisations where the call patterns
+differ only in their type arguments!  Not only is it utterly useless,
+but it also means that (with polymorphic recursion) we can generate
+an infinite number of specialisations. Example is Data.Sequence.adjustTree,
+I think.
+-}
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
new file mode 100644
--- /dev/null
+++ b/compiler/specialise/Specialise.hs
@@ -0,0 +1,2463 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
+-}
+
+{-# LANGUAGE CPP #-}
+module Specialise ( specProgram, specUnfolding ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Id
+import TcType hiding( substTy )
+import Type   hiding( substTy, extendTvSubstList )
+import Module( Module, HasModule(..) )
+import Coercion( Coercion )
+import CoreMonad
+import qualified CoreSubst
+import CoreUnfold
+import Var              ( isLocalVar )
+import VarSet
+import VarEnv
+import CoreSyn
+import Rules
+import CoreOpt          ( collectBindersPushingCo )
+import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )
+import CoreFVs
+import CoreArity        ( etaExpandToJoinPointRule )
+import UniqSupply
+import Name
+import MkId             ( voidArgId, voidPrimId )
+import Maybes           ( catMaybes, isJust )
+import MonadUtils       ( foldlM )
+import BasicTypes
+import HscTypes
+import Bag
+import DynFlags
+import Util
+import Outputable
+import FastString
+import State
+import UniqDFM
+
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
+*                                                                      *
+************************************************************************
+
+These notes describe how we implement specialisation to eliminate
+overloading.
+
+The specialisation pass works on Core
+syntax, complete with all the explicit dictionary application,
+abstraction and construction as added by the type checker.  The
+existing type checker remains largely as it is.
+
+One important thought: the {\em types} passed to an overloaded
+function, and the {\em dictionaries} passed are mutually redundant.
+If the same function is applied to the same type(s) then it is sure to
+be applied to the same dictionary(s)---or rather to the same {\em
+values}.  (The arguments might look different but they will evaluate
+to the same value.)
+
+Second important thought: we know that we can make progress by
+treating dictionary arguments as static and worth specialising on.  So
+we can do without binding-time analysis, and instead specialise on
+dictionary arguments and no others.
+
+The basic idea
+~~~~~~~~~~~~~~
+Suppose we have
+
+        let f = <f_rhs>
+        in <body>
+
+and suppose f is overloaded.
+
+STEP 1: CALL-INSTANCE COLLECTION
+
+We traverse <body>, accumulating all applications of f to types and
+dictionaries.
+
+(Might there be partial applications, to just some of its types and
+dictionaries?  In principle yes, but in practice the type checker only
+builds applications of f to all its types and dictionaries, so partial
+applications could only arise as a result of transformation, and even
+then I think it's unlikely.  In any case, we simply don't accumulate such
+partial applications.)
+
+
+STEP 2: EQUIVALENCES
+
+So now we have a collection of calls to f:
+        f t1 t2 d1 d2
+        f t3 t4 d3 d4
+        ...
+Notice that f may take several type arguments.  To avoid ambiguity, we
+say that f is called at type t1/t2 and t3/t4.
+
+We take equivalence classes using equality of the *types* (ignoring
+the dictionary args, which as mentioned previously are redundant).
+
+STEP 3: SPECIALISATION
+
+For each equivalence class, choose a representative (f t1 t2 d1 d2),
+and create a local instance of f, defined thus:
+
+        f@t1/t2 = <f_rhs> t1 t2 d1 d2
+
+f_rhs presumably has some big lambdas and dictionary lambdas, so lots
+of simplification will now result.  However we don't actually *do* that
+simplification.  Rather, we leave it for the simplifier to do.  If we
+*did* do it, though, we'd get more call instances from the specialised
+RHS.  We can work out what they are by instantiating the call-instance
+set from f's RHS with the types t1, t2.
+
+Add this new id to f's IdInfo, to record that f has a specialised version.
+
+Before doing any of this, check that f's IdInfo doesn't already
+tell us about an existing instance of f at the required type/s.
+(This might happen if specialisation was applied more than once, or
+it might arise from user SPECIALIZE pragmas.)
+
+Recursion
+~~~~~~~~~
+Wait a minute!  What if f is recursive?  Then we can't just plug in
+its right-hand side, can we?
+
+But it's ok.  The type checker *always* creates non-recursive definitions
+for overloaded recursive functions.  For example:
+
+        f x = f (x+x)           -- Yes I know its silly
+
+becomes
+
+        f a (d::Num a) = let p = +.sel a d
+                         in
+                         letrec fl (y::a) = fl (p y y)
+                         in
+                         fl
+
+We still have recursion for non-overloaded functions which we
+specialise, but the recursive call should get specialised to the
+same recursive version.
+
+
+Polymorphism 1
+~~~~~~~~~~~~~~
+
+All this is crystal clear when the function is applied to *constant
+types*; that is, types which have no type variables inside.  But what if
+it is applied to non-constant types?  Suppose we find a call of f at type
+t1/t2.  There are two possibilities:
+
+(a) The free type variables of t1, t2 are in scope at the definition point
+of f.  In this case there's no problem, we proceed just as before.  A common
+example is as follows.  Here's the Haskell:
+
+        g y = let f x = x+x
+              in f y + f y
+
+After typechecking we have
+
+        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
+                                in +.sel a d (f a d y) (f a d y)
+
+Notice that the call to f is at type type "a"; a non-constant type.
+Both calls to f are at the same type, so we can specialise to give:
+
+        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
+                                in +.sel a d (f@a y) (f@a y)
+
+
+(b) The other case is when the type variables in the instance types
+are *not* in scope at the definition point of f.  The example we are
+working with above is a good case.  There are two instances of (+.sel a d),
+but "a" is not in scope at the definition of +.sel.  Can we do anything?
+Yes, we can "common them up", a sort of limited common sub-expression deal.
+This would give:
+
+        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
+                                    f@a (x::a) = +.sel@a x x
+                                in +.sel@a (f@a y) (f@a y)
+
+This can save work, and can't be spotted by the type checker, because
+the two instances of +.sel weren't originally at the same type.
+
+Further notes on (b)
+
+* There are quite a few variations here.  For example, the defn of
+  +.sel could be floated ouside the \y, to attempt to gain laziness.
+  It certainly mustn't be floated outside the \d because the d has to
+  be in scope too.
+
+* We don't want to inline f_rhs in this case, because
+that will duplicate code.  Just commoning up the call is the point.
+
+* Nothing gets added to +.sel's IdInfo.
+
+* Don't bother unless the equivalence class has more than one item!
+
+Not clear whether this is all worth it.  It is of course OK to
+simply discard call-instances when passing a big lambda.
+
+Polymorphism 2 -- Overloading
+~~~~~~~~~~~~~~
+Consider a function whose most general type is
+
+        f :: forall a b. Ord a => [a] -> b -> b
+
+There is really no point in making a version of g at Int/Int and another
+at Int/Bool, because it's only instantiating the type variable "a" which
+buys us any efficiency. Since g is completely polymorphic in b there
+ain't much point in making separate versions of g for the different
+b types.
+
+That suggests that we should identify which of g's type variables
+are constrained (like "a") and which are unconstrained (like "b").
+Then when taking equivalence classes in STEP 2, we ignore the type args
+corresponding to unconstrained type variable.  In STEP 3 we make
+polymorphic versions.  Thus:
+
+        f@t1/ = /\b -> <f_rhs> t1 b d1 d2
+
+We do this.
+
+
+Dictionary floating
+~~~~~~~~~~~~~~~~~~~
+Consider this
+
+        f a (d::Num a) = let g = ...
+                         in
+                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
+
+Here, g is only called at one type, but the dictionary isn't in scope at the
+definition point for g.  Usually the type checker would build a
+definition for d1 which enclosed g, but the transformation system
+might have moved d1's defn inward.  Solution: float dictionary bindings
+outwards along with call instances.
+
+Consider
+
+        f x = let g p q = p==q
+                  h r s = (r+s, g r s)
+              in
+              h x x
+
+
+Before specialisation, leaving out type abstractions we have
+
+        f df x = let g :: Eq a => a -> a -> Bool
+                     g dg p q = == dg p q
+                     h :: Num a => a -> a -> (a, Bool)
+                     h dh r s = let deq = eqFromNum dh
+                                in (+ dh r s, g deq r s)
+              in
+              h df x x
+
+After specialising h we get a specialised version of h, like this:
+
+                    h' r s = let deq = eqFromNum df
+                             in (+ df r s, g deq r s)
+
+But we can't naively make an instance for g from this, because deq is not in scope
+at the defn of g.  Instead, we have to float out the (new) defn of deq
+to widen its scope.  Notice that this floating can't be done in advance -- it only
+shows up when specialisation is done.
+
+User SPECIALIZE pragmas
+~~~~~~~~~~~~~~~~~~~~~~~
+Specialisation pragmas can be digested by the type checker, and implemented
+by adding extra definitions along with that of f, in the same way as before
+
+        f@t1/t2 = <f_rhs> t1 t2 d1 d2
+
+Indeed the pragmas *have* to be dealt with by the type checker, because
+only it knows how to build the dictionaries d1 and d2!  For example
+
+        g :: Ord a => [a] -> [a]
+        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
+
+Here, the specialised version of g is an application of g's rhs to the
+Ord dictionary for (Tree Int), which only the type checker can conjure
+up.  There might not even *be* one, if (Tree Int) is not an instance of
+Ord!  (All the other specialision has suitable dictionaries to hand
+from actual calls.)
+
+Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
+it is buried in a complex (as-yet-un-desugared) binding group.
+Maybe we should say
+
+        f@t1/t2 = f* t1 t2 d1 d2
+
+where f* is the Id f with an IdInfo which says "inline me regardless!".
+Indeed all the specialisation could be done in this way.
+That in turn means that the simplifier has to be prepared to inline absolutely
+any in-scope let-bound thing.
+
+
+Again, the pragma should permit polymorphism in unconstrained variables:
+
+        h :: Ord a => [a] -> b -> b
+        {-# SPECIALIZE h :: [Int] -> b -> b #-}
+
+We *insist* that all overloaded type variables are specialised to ground types,
+(and hence there can be no context inside a SPECIALIZE pragma).
+We *permit* unconstrained type variables to be specialised to
+        - a ground type
+        - or left as a polymorphic type variable
+but nothing in between.  So
+
+        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
+
+is *illegal*.  (It can be handled, but it adds complication, and gains the
+programmer nothing.)
+
+
+SPECIALISING INSTANCE DECLARATIONS
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        instance Foo a => Foo [a] where
+                ...
+        {-# SPECIALIZE instance Foo [Int] #-}
+
+The original instance decl creates a dictionary-function
+definition:
+
+        dfun.Foo.List :: forall a. Foo a -> Foo [a]
+
+The SPECIALIZE pragma just makes a specialised copy, just as for
+ordinary function definitions:
+
+        dfun.Foo.List@Int :: Foo [Int]
+        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
+
+The information about what instance of the dfun exist gets added to
+the dfun's IdInfo in the same way as a user-defined function too.
+
+
+Automatic instance decl specialisation?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Can instance decls be specialised automatically?  It's tricky.
+We could collect call-instance information for each dfun, but
+then when we specialised their bodies we'd get new call-instances
+for ordinary functions; and when we specialised their bodies, we might get
+new call-instances of the dfuns, and so on.  This all arises because of
+the unrestricted mutual recursion between instance decls and value decls.
+
+Still, there's no actual problem; it just means that we may not do all
+the specialisation we could theoretically do.
+
+Furthermore, instance decls are usually exported and used non-locally,
+so we'll want to compile enough to get those specialisations done.
+
+Lastly, there's no such thing as a local instance decl, so we can
+survive solely by spitting out *usage* information, and then reading that
+back in as a pragma when next compiling the file.  So for now,
+we only specialise instance decls in response to pragmas.
+
+
+SPITTING OUT USAGE INFORMATION
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To spit out usage information we need to traverse the code collecting
+call-instance information for all imported (non-prelude?) functions
+and data types. Then we equivalence-class it and spit it out.
+
+This is done at the top-level when all the call instances which escape
+must be for imported functions and data types.
+
+*** Not currently done ***
+
+
+Partial specialisation by pragmas
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What about partial specialisation:
+
+        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
+        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
+
+or even
+
+        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
+
+Seems quite reasonable.  Similar things could be done with instance decls:
+
+        instance (Foo a, Foo b) => Foo (a,b) where
+                ...
+        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
+        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
+
+Ho hum.  Things are complex enough without this.  I pass.
+
+
+Requirements for the simplifier
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The simplifier has to be able to take advantage of the specialisation.
+
+* When the simplifier finds an application of a polymorphic f, it looks in
+f's IdInfo in case there is a suitable instance to call instead.  This converts
+
+        f t1 t2 d1 d2   ===>   f_t1_t2
+
+Note that the dictionaries get eaten up too!
+
+* Dictionary selection operations on constant dictionaries must be
+  short-circuited:
+
+        +.sel Int d     ===>  +Int
+
+The obvious way to do this is in the same way as other specialised
+calls: +.sel has inside it some IdInfo which tells that if it's applied
+to the type Int then it should eat a dictionary and transform to +Int.
+
+In short, dictionary selectors need IdInfo inside them for constant
+methods.
+
+* Exactly the same applies if a superclass dictionary is being
+  extracted:
+
+        Eq.sel Int d   ===>   dEqInt
+
+* Something similar applies to dictionary construction too.  Suppose
+dfun.Eq.List is the function taking a dictionary for (Eq a) to
+one for (Eq [a]).  Then we want
+
+        dfun.Eq.List Int d      ===> dEq.List_Int
+
+Where does the Eq [Int] dictionary come from?  It is built in
+response to a SPECIALIZE pragma on the Eq [a] instance decl.
+
+In short, dfun Ids need IdInfo with a specialisation for each
+constant instance of their instance declaration.
+
+All this uses a single mechanism: the SpecEnv inside an Id
+
+
+What does the specialisation IdInfo look like?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The SpecEnv of an Id maps a list of types (the template) to an expression
+
+        [Type]  |->  Expr
+
+For example, if f has this RuleInfo:
+
+        [Int, a]  ->  \d:Ord Int. f' a
+
+it means that we can replace the call
+
+        f Int t  ===>  (\d. f' t)
+
+This chucks one dictionary away and proceeds with the
+specialised version of f, namely f'.
+
+
+What can't be done this way?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no way, post-typechecker, to get a dictionary for (say)
+Eq a from a dictionary for Eq [a].  So if we find
+
+        ==.sel [t] d
+
+we can't transform to
+
+        eqList (==.sel t d')
+
+where
+        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
+
+Of course, we currently have no way to automatically derive
+eqList, nor to connect it to the Eq [a] instance decl, but you
+can imagine that it might somehow be possible.  Taking advantage
+of this is permanently ruled out.
+
+Still, this is no great hardship, because we intend to eliminate
+overloading altogether anyway!
+
+A note about non-tyvar dictionaries
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Ids have types like
+
+        forall a,b,c. Eq a -> Ord [a] -> tau
+
+This seems curious at first, because we usually only have dictionary
+args whose types are of the form (C a) where a is a type variable.
+But this doesn't hold for the functions arising from instance decls,
+which sometimes get arguments with types of form (C (T a)) for some
+type constructor T.
+
+Should we specialise wrt this compound-type dictionary?  We used to say
+"no", saying:
+        "This is a heuristic judgement, as indeed is the fact that we
+        specialise wrt only dictionaries.  We choose *not* to specialise
+        wrt compound dictionaries because at the moment the only place
+        they show up is in instance decls, where they are simply plugged
+        into a returned dictionary.  So nothing is gained by specialising
+        wrt them."
+
+But it is simpler and more uniform to specialise wrt these dicts too;
+and in future GHC is likely to support full fledged type signatures
+like
+        f :: Eq [(a,b)] => ...
+
+
+************************************************************************
+*                                                                      *
+\subsubsection{The new specialiser}
+*                                                                      *
+************************************************************************
+
+Our basic game plan is this.  For let(rec) bound function
+        f :: (C a, D c) => (a,b,c,d) -> Bool
+
+* Find any specialised calls of f, (f ts ds), where
+  ts are the type arguments t1 .. t4, and
+  ds are the dictionary arguments d1 .. d2.
+
+* Add a new definition for f1 (say):
+
+        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
+
+  Note that we abstract over the unconstrained type arguments.
+
+* Add the mapping
+
+        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
+
+  to the specialisations of f.  This will be used by the
+  simplifier to replace calls
+                (f t1 t2 t3 t4) da db
+  by
+                (\d1 d1 -> f1 t2 t4) da db
+
+  All the stuff about how many dictionaries to discard, and what types
+  to apply the specialised function to, are handled by the fact that the
+  SpecEnv contains a template for the result of the specialisation.
+
+We don't build *partial* specialisations for f.  For example:
+
+  f :: Eq a => a -> a -> Bool
+  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
+
+Here, little is gained by making a specialised copy of f.
+There's a distinct danger that the specialised version would
+first build a dictionary for (Eq b, Eq c), and then select the (==)
+method from it!  Even if it didn't, not a great deal is saved.
+
+We do, however, generate polymorphic, but not overloaded, specialisations:
+
+  f :: Eq a => [a] -> b -> b -> b
+  ... SPECIALISE f :: [Int] -> b -> b -> b ...
+
+Hence, the invariant is this:
+
+        *** no specialised version is overloaded ***
+
+
+************************************************************************
+*                                                                      *
+\subsubsection{The exported function}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Specialise calls to type-class overloaded functions occuring in a program.
+specProgram :: ModGuts -> CoreM ModGuts
+specProgram guts@(ModGuts { mg_module = this_mod
+                          , mg_rules = local_rules
+                          , mg_binds = binds })
+  = do { dflags <- getDynFlags
+
+             -- Specialise the bindings of this module
+       ; (binds', uds) <- runSpecM dflags this_mod (go binds)
+
+             -- Specialise imported functions
+       ; hpt_rules <- getRuleBase
+       ; let rule_base = extendRuleBaseList hpt_rules local_rules
+       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet
+                                                [] rule_base uds
+
+       ; let final_binds
+               | null spec_binds = binds'
+               | otherwise       = Rec (flattenBinds spec_binds) : binds'
+                   -- Note [Glom the bindings if imported functions are specialised]
+
+       ; return (guts { mg_binds = final_binds
+                      , mg_rules = new_rules ++ local_rules }) }
+  where
+        -- We need to start with a Subst that knows all the things
+        -- that are in scope, so that the substitution engine doesn't
+        -- accidentally re-use a unique that's already in use
+        -- Easiest thing is to do it all at once, as if all the top-level
+        -- decls were mutually recursive
+    top_env = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $
+                              bindersOfBinds binds
+                 , se_interesting = emptyVarSet }
+
+    go []           = return ([], emptyUDs)
+    go (bind:binds) = do (binds', uds) <- go binds
+                         (bind', uds') <- specBind top_env bind uds
+                         return (bind' ++ binds', uds')
+
+{-
+Note [Wrap bindings returned by specImports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'specImports' returns a set of specialized bindings. However, these are lacking
+necessary floated dictionary bindings, which are returned by
+UsageDetails(ud_binds). These dictionaries need to be brought into scope with
+'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,
+for instance, the 'specImports' call in 'specProgram'.
+
+
+Note [Disabling cross-module specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since GHC 7.10 we have performed specialisation of INLINABLE bindings living
+in modules outside of the current module. This can sometimes uncover user code
+which explodes in size when aggressively optimized. The
+-fno-cross-module-specialise option was introduced to allow users to being
+bitten by such instances to revert to the pre-7.10 behavior.
+
+See #10491
+-}
+
+-- | Specialise a set of calls to imported bindings
+specImports :: DynFlags
+            -> Module
+            -> SpecEnv          -- Passed in so that all top-level Ids are in scope
+            -> VarSet           -- Don't specialise these ones
+                                -- See Note [Avoiding recursive specialisation]
+            -> [Id]             -- Stack of imported functions being specialised
+            -> RuleBase         -- Rules from this module and the home package
+                                -- (but not external packages, which can change)
+            -> UsageDetails     -- Calls for imported things, and floating bindings
+            -> CoreM ( [CoreRule]   -- New rules
+                     , [CoreBind] ) -- Specialised bindings
+                                    -- See Note [Wrapping bindings returned by specImports]
+specImports dflags this_mod top_env done callers rule_base
+            (MkUD { ud_binds = dict_binds, ud_calls = calls })
+  -- See Note [Disabling cross-module specialisation]
+  | not $ gopt Opt_CrossModuleSpecialise dflags
+  = return ([], [])
+
+  | otherwise
+  = do { let import_calls = dVarEnvElts calls
+       ; (rules, spec_binds) <- go rule_base import_calls
+
+             -- Don't forget to wrap the specialized bindings with
+             -- bindings for the needed dictionaries.
+             -- See Note [Wrap bindings returned by specImports]
+       ; let spec_binds' = wrapDictBinds dict_binds spec_binds
+
+       ; return (rules, spec_binds') }
+  where
+    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
+    go _ [] = return ([], [])
+    go rb (cis@(CIS fn _) : other_calls)
+      = do { let ok_calls = filterCalls cis dict_binds
+                     -- Drop calls that (directly or indirectly) refer to fn
+                     -- See Note [Avoiding loops]
+--           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn
+--                                                       , text "calls" <+> ppr cis
+--                                                       , text "ud_binds =" <+> ppr dict_binds
+--                                                       , text "dump set =" <+> ppr dump_set
+--                                                       , text "filtered calls =" <+> ppr ok_calls ])
+           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env
+                                                 done callers rb fn ok_calls
+
+           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
+           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
+
+specImport :: DynFlags
+           -> Module
+           -> SpecEnv               -- Passed in so that all top-level Ids are in scope
+           -> VarSet                -- Don't specialise these
+                                    -- See Note [Avoiding recursive specialisation]
+           -> [Id]                  -- Stack of imported functions being specialised
+           -> RuleBase              -- Rules from this module
+           -> Id -> [CallInfo]      -- Imported function and calls for it
+           -> CoreM ( [CoreRule]    -- New rules
+                    , [CoreBind] )  -- Specialised bindings
+specImport dflags this_mod top_env done callers rb fn calls_for_fn
+  | fn `elemVarSet` done
+  = return ([], [])     -- No warning.  This actually happens all the time
+                        -- when specialising a recursive function, because
+                        -- the RHS of the specialised function contains a recursive
+                        -- call to the original function
+
+  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning
+  = return ([], [])
+
+  | wantSpecImport dflags unfolding
+  , Just rhs <- maybeUnfoldingTemplate unfolding
+  = do {     -- Get rules from the external package state
+             -- We keep doing this in case we "page-fault in"
+             -- more rules as we go along
+       ; hsc_env <- getHscEnv
+       ; eps <- liftIO $ hscEPS hsc_env
+       ; vis_orphs <- getVisibleOrphanMods
+       ; let full_rb = unionRuleBase rb (eps_rule_base eps)
+             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn
+
+       ; (rules1, spec_pairs, uds)
+             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $
+                runSpecM dflags this_mod $
+                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs
+       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
+             -- After the rules kick in we may get recursion, but
+             -- we rely on a global GlomBinds to sort that out later
+             -- See Note [Glom the bindings if imported functions are specialised]
+
+              -- Now specialise any cascaded calls
+       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $
+                                  specImports dflags this_mod top_env
+                                              (extendVarSet done fn)
+                                              (fn:callers)
+                                              (extendRuleBaseList rb rules1)
+                                              uds
+
+       ; let final_binds = spec_binds2 ++ spec_binds1
+
+       ; return (rules2 ++ rules1, final_binds) }
+
+  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn
+                   ; return ([], [])}
+
+  where
+    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
+
+-- | Returns whether or not to show a missed-spec warning.
+-- If -Wall-missed-specializations is on, show the warning.
+-- Otherwise, if -Wmissed-specializations is on, only show a warning
+-- if there is at least one imported function being specialized,
+-- and if all imported functions are marked with an inline pragma
+-- Use the most specific warning as the reason.
+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
+-- See Note [Warning about missed specialisations]
+tryWarnMissingSpecs dflags callers fn calls_for_fn
+  | wopt Opt_WarnMissedSpecs dflags
+    && not (null callers)
+    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs
+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs
+  | otherwise                             = return ()
+  where
+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
+    doWarn reason = 
+      warnMsg reason
+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)
+                        | caller <- callers])
+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
+
+wantSpecImport :: DynFlags -> Unfolding -> Bool
+-- See Note [Specialise imported INLINABLE things]
+wantSpecImport dflags unf
+ = case unf of
+     NoUnfolding      -> False
+     BootUnfolding    -> False
+     OtherCon {}      -> False
+     DFunUnfolding {} -> True
+     CoreUnfolding { uf_src = src, uf_guidance = _guidance }
+       | gopt Opt_SpecialiseAggressively dflags -> True
+       | isStableSource src -> True
+               -- Specialise even INLINE things; it hasn't inlined yet,
+               -- so perhaps it never will.  Moreover it may have calls
+               -- inside it that we want to specialise
+       | otherwise -> False    -- Stable, not INLINE, hence INLINABLE
+
+{- Note [Warning about missed specialisations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose
+ * In module Lib, you carefully mark a function 'foo' INLINABLE
+ * Import Lib(foo) into another module M
+ * Call 'foo' at some specialised type in M
+Then you jolly well expect it to be specialised in M.  But what if
+'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be
+specialised too.  But if 'bar' is not marked INLINABLE it may well
+not be specialised.  The warning Opt_WarnMissedSpecs warns about this.
+
+It's more noisy to warning about a missed specialisation opportunity
+for /every/ overloaded imported function, but sometimes useful. That
+is what Opt_WarnAllMissedSpecs does.
+
+ToDo: warn about missed opportunities for local functions.
+
+Note [Specialise imported INLINABLE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What imported functions do we specialise?  The basic set is
+ * DFuns and things with INLINABLE pragmas.
+but with -fspecialise-aggressively we add
+ * Anything with an unfolding template
+
+#8874 has a good example of why we want to auto-specialise DFuns.
+
+We have the -fspecialise-aggressively flag (usually off), because we
+risk lots of orphan modules from over-vigorous specialisation.
+However it's not a big deal: anything non-recursive with an
+unfolding-template will probably have been inlined already.
+
+Note [Glom the bindings if imported functions are specialised]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an imported, *recursive*, INLINABLE function
+   f :: Eq a => a -> a
+   f = /\a \d x. ...(f a d)...
+In the module being compiled we have
+   g x = f (x::Int)
+Now we'll make a specialised function
+   f_spec :: Int -> Int
+   f_spec = \x -> ...(f Int dInt)...
+   {-# RULE  f Int _ = f_spec #-}
+   g = \x. f Int dInt x
+Note that f_spec doesn't look recursive
+After rewriting with the RULE, we get
+   f_spec = \x -> ...(f_spec)...
+BUT since f_spec was non-recursive before it'll *stay* non-recursive.
+The occurrence analyser never turns a NonRec into a Rec.  So we must
+make sure that f_spec is recursive.  Easiest thing is to make all
+the specialisations for imported bindings recursive.
+
+
+Note [Avoiding recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
+'f's RHS.  So we want to specialise g,h.  But we don't want to
+specialise f any more!  It's possible that f's RHS might have a
+recursive yet-more-specialised call, so we'd diverge in that case.
+And if the call is to the same type, one specialisation is enough.
+Avoiding this recursive specialisation loop is the reason for the
+'done' VarSet passed to specImports and specImport.
+
+************************************************************************
+*                                                                      *
+\subsubsection{@specExpr@: the main function}
+*                                                                      *
+************************************************************************
+-}
+
+data SpecEnv
+  = SE { se_subst :: CoreSubst.Subst
+             -- We carry a substitution down:
+             -- a) we must clone any binding that might float outwards,
+             --    to avoid name clashes
+             -- b) we carry a type substitution to use when analysing
+             --    the RHS of specialised bindings (no type-let!)
+
+
+       , se_interesting :: VarSet
+             -- Dict Ids that we know something about
+             -- and hence may be worth specialising against
+             -- See Note [Interesting dictionary arguments]
+     }
+
+specVar :: SpecEnv -> Id -> CoreExpr
+specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v
+
+specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
+
+---------------- First the easy cases --------------------
+specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)
+specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)
+specExpr env (Var v)       = return (specVar env v, emptyUDs)
+specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)
+specExpr env (Cast e co)
+  = do { (e', uds) <- specExpr env e
+       ; return ((mkCast e' (substCo env co)), uds) }
+specExpr env (Tick tickish body)
+  = do { (body', uds) <- specExpr env body
+       ; return (Tick (specTickish env tickish) body', uds) }
+
+---------------- Applications might generate a call instance --------------------
+specExpr env expr@(App {})
+  = go expr []
+  where
+    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg
+                               (fun', uds_app) <- go fun (arg':args)
+                               return (App fun' arg', uds_arg `plusUDs` uds_app)
+
+    go (Var f)       args = case specVar env f of
+                                Var f' -> return (Var f', mkCallUDs env f' args)
+                                e'     -> return (e', emptyUDs) -- I don't expect this!
+    go other         _    = specExpr env other
+
+---------------- Lambda/case require dumping of usage details --------------------
+specExpr env e@(Lam _ _) = do
+    (body', uds) <- specExpr env' body
+    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds
+    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)
+  where
+    (bndrs, body) = collectBinders e
+    (env', bndrs') = substBndrs env bndrs
+        -- More efficient to collect a group of binders together all at once
+        -- and we don't want to split a lambda group with dumped bindings
+
+specExpr env (Case scrut case_bndr ty alts)
+  = do { (scrut', scrut_uds) <- specExpr env scrut
+       ; (scrut'', case_bndr', alts', alts_uds)
+             <- specCase env scrut' case_bndr alts
+       ; return (Case scrut'' case_bndr' (substTy env ty) alts'
+                , scrut_uds `plusUDs` alts_uds) }
+
+---------------- Finally, let is the interesting case --------------------
+specExpr env (Let bind body)
+  = do { -- Clone binders
+         (rhs_env, body_env, bind') <- cloneBindSM env bind
+
+         -- Deal with the body
+       ; (body', body_uds) <- specExpr body_env body
+
+        -- Deal with the bindings
+      ; (binds', uds) <- specBind rhs_env bind' body_uds
+
+        -- All done
+      ; return (foldr Let body' binds', uds) }
+
+specTickish :: SpecEnv -> Tickish Id -> Tickish Id
+specTickish env (Breakpoint ix ids)
+  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]
+  -- drop vars from the list if they have a non-variable substitution.
+  -- should never happen, but it's harmless to drop them anyway.
+specTickish _ other_tickish = other_tickish
+
+specCase :: SpecEnv
+         -> CoreExpr            -- Scrutinee, already done
+         -> Id -> [CoreAlt]
+         -> SpecM ( CoreExpr    -- New scrutinee
+                  , Id
+                  , [CoreAlt]
+                  , UsageDetails)
+specCase env scrut' case_bndr [(con, args, rhs)]
+  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]
+  , interestingDict env scrut'
+  , not (isDeadBinder case_bndr && null sc_args')
+  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
+
+       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')
+                              [(con, args', Var sc_arg')]
+                       | sc_arg' <- sc_args' ]
+
+             -- Extend the substitution for RHS to map the *original* binders
+             -- to their floated versions.
+             mb_sc_flts :: [Maybe DictId]
+             mb_sc_flts = map (lookupVarEnv clone_env) args'
+             clone_env  = zipVarEnv sc_args' sc_args_flt
+             subst_prs  = (case_bndr, Var case_bndr_flt)
+                        : [ (arg, Var sc_flt)
+                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
+             env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs
+                                , se_interesting = se_interesting env_rhs `extendVarSetList`
+                                                   (case_bndr_flt : sc_args_flt) }
+
+       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs
+       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')
+             case_bndr_set = unitVarSet case_bndr_flt
+             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
+                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
+             flt_binds     = scrut_bind : sc_binds
+             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
+             all_uds = flt_binds `addDictBinds` free_uds
+             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')
+       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
+  where
+    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)
+    sc_args' = filter is_flt_sc_arg args'
+
+    clone_me bndr = do { uniq <- getUniqueM
+                       ; return (mkUserLocalOrCoVar occ uniq ty loc) }
+       where
+         name = idName bndr
+         ty   = idType bndr
+         occ  = nameOccName name
+         loc  = getSrcSpan name
+
+    arg_set = mkVarSet args'
+    is_flt_sc_arg var =  isId var
+                      && not (isDeadBinder var)
+                      && isDictTy var_ty
+                      && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)
+       where
+         var_ty = idType var
+
+
+specCase env scrut case_bndr alts
+  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
+       ; return (scrut, case_bndr', alts', uds_alts) }
+  where
+    (env_alt, case_bndr') = substBndr env case_bndr
+    spec_alt (con, args, rhs) = do
+          (rhs', uds) <- specExpr env_rhs rhs
+          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
+          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)
+        where
+          (env_rhs, args') = substBndrs env_alt args
+
+{-
+Note [Floating dictionaries out of cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   g = \d. case d of { MkD sc ... -> ...(f sc)... }
+Naively we can't float d2's binding out of the case expression,
+because 'sc' is bound by the case, and that in turn means we can't
+specialise f, which seems a pity.
+
+So we invert the case, by floating out a binding
+for 'sc_flt' thus:
+    sc_flt = case d of { MkD sc ... -> sc }
+Now we can float the call instance for 'f'.  Indeed this is just
+what'll happen if 'sc' was originally bound with a let binding,
+but case is more efficient, and necessary with equalities. So it's
+good to work with both.
+
+You might think that this won't make any difference, because the
+call instance will only get nuked by the \d.  BUT if 'g' itself is
+specialised, then transitively we should be able to specialise f.
+
+In general, given
+   case e of cb { MkD sc ... -> ...(f sc)... }
+we transform to
+   let cb_flt = e
+       sc_flt = case cb_flt of { MkD sc ... -> sc }
+   in
+   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
+
+The "_flt" things are the floated binds; we use the current substitution
+to substitute sc -> sc_flt in the RHS
+
+************************************************************************
+*                                                                      *
+                     Dealing with a binding
+*                                                                      *
+************************************************************************
+-}
+
+specBind :: SpecEnv                     -- Use this for RHSs
+         -> CoreBind                    -- Binders are already cloned by cloneBindSM,
+                                        -- but RHSs are un-processed
+         -> UsageDetails                -- Info on how the scope of the binding
+         -> SpecM ([CoreBind],          -- New bindings
+                   UsageDetails)        -- And info to pass upstream
+
+-- Returned UsageDetails:
+--    No calls for binders of this bind
+specBind rhs_env (NonRec fn rhs) body_uds
+  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs
+       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs
+
+       ; let pairs = spec_defns ++ [(fn', rhs')]
+                        -- fn' mentions the spec_defns in its rules,
+                        -- so put the latter first
+
+             combined_uds = body_uds1 `plusUDs` rhs_uds
+
+             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
+
+             final_binds :: [DictBind]
+             -- See Note [From non-recursive to recursive]
+             final_binds
+               | not (isEmptyBag dump_dbs)
+               , not (null spec_defns)
+               = [recWithDumpedDicts pairs dump_dbs]
+               | otherwise
+               = [mkDB $ NonRec b r | (b,r) <- pairs]
+                 ++ bagToList dump_dbs
+
+       ; if float_all then
+             -- Rather than discard the calls mentioning the bound variables
+             -- we float this (dictionary) binding along with the others
+              return ([], free_uds `snocDictBinds` final_binds)
+         else
+             -- No call in final_uds mentions bound variables,
+             -- so we can just leave the binding here
+              return (map fst final_binds, free_uds) }
+
+
+specBind rhs_env (Rec pairs) body_uds
+       -- Note [Specialising a recursive group]
+  = do { let (bndrs,rhss) = unzip pairs
+       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss
+       ; let scope_uds = body_uds `plusUDs` rhs_uds
+                       -- Includes binds and calls arising from rhss
+
+       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs
+
+       ; (bndrs3, spec_defns3, uds3)
+             <- if null spec_defns1  -- Common case: no specialisation
+                then return (bndrs1, [], uds1)
+                else do {            -- Specialisation occurred; do it again
+                          (bndrs2, spec_defns2, uds2)
+                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)
+                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }
+
+       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3
+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')
+                                             dumped_dbs
+
+       ; if float_all then
+              return ([], final_uds `snocDictBind` final_bind)
+         else
+              return ([fst final_bind], final_uds) }
+
+
+---------------------------
+specDefns :: SpecEnv
+          -> UsageDetails               -- Info on how it is used in its scope
+          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS
+          -> SpecM ([OutId],            -- Original Ids with RULES added
+                    [(OutId,OutExpr)],  -- Extra, specialised bindings
+                    UsageDetails)       -- Stuff to fling upwards from the specialised versions
+
+-- Specialise a list of bindings (the contents of a Rec), but flowing usages
+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation
+-- in turn generates a specialised call for 'f', we catch that in this one sweep.
+-- But not vice versa (it's a fixpoint problem).
+
+specDefns _env uds []
+  = return ([], [], uds)
+specDefns env uds ((bndr,rhs):pairs)
+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
+       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs
+       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
+
+---------------------------
+specDefn :: SpecEnv
+         -> UsageDetails                -- Info on how it is used in its scope
+         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS
+         -> SpecM (Id,                  -- Original Id with added RULES
+                   [(Id,CoreExpr)],     -- Extra, specialised bindings
+                   UsageDetails)        -- Stuff to fling upwards from the specialised versions
+
+specDefn env body_uds fn rhs
+  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
+             rules_for_me = idCoreRules fn
+       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me
+                                                    calls_for_me fn rhs
+       ; return ( fn `addIdSpecialisations` rules
+                , spec_defns
+                , body_uds_without_me `plusUDs` spec_uds) }
+                -- It's important that the `plusUDs` is this way
+                -- round, because body_uds_without_me may bind
+                -- dictionaries that are used in calls_for_me passed
+                -- to specDefn.  So the dictionary bindings in
+                -- spec_uds may mention dictionaries bound in
+                -- body_uds_without_me
+
+---------------------------
+specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn
+                               -- Nothing        =>  specialising local fn
+          -> SpecEnv
+          -> [CoreRule]        -- Existing RULES for the fn
+          -> [CallInfo]
+          -> OutId -> InExpr
+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details
+
+-- This function checks existing rules, and does not create
+-- duplicate ones. So the caller does not need to do this filtering.
+-- See 'already_covered'
+
+type SpecInfo = ( [CoreRule]       -- Specialisation rules
+                , [(Id,CoreExpr)]  -- Specialised definition
+                , UsageDetails )   -- Usage details from specialised RHSs
+
+specCalls mb_mod env existing_rules calls_for_me fn rhs
+        -- The first case is the interesting one
+  |  rhs_tyvars `lengthIs`      n_tyvars -- Rhs of fn's defn has right number of big lambdas
+  && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args
+  && notNull calls_for_me               -- And there are some calls to specialise
+  && not (isNeverActive (idInlineActivation fn))
+        -- Don't specialise NOINLINE things
+        -- See Note [Auto-specialisation and RULES]
+
+--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
+--      See Note [Inline specialisation] for why we do not
+--      switch off specialisation for inline functions
+
+  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
+    foldlM spec_call ([], [], emptyUDs) calls_for_me
+
+  | otherwise   -- No calls or RHS doesn't fit our preconceptions
+  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,
+          text "Missed specialisation opportunity for"
+                                 <+> ppr fn $$ _trace_doc )
+          -- Note [Specialisation shape]
+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
+    return ([], [], emptyUDs)
+  where
+    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
+                     , ppr rhs_bndrs, ppr n_dicts
+                     , ppr (idInlineActivation fn) ]
+
+    fn_type                 = idType fn
+    fn_arity                = idArity fn
+    fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here
+    (tyvars, theta, _)      = tcSplitSigmaTy fn_type
+    n_tyvars                = length tyvars
+    n_dicts                 = length theta
+    inl_prag                = idInlinePragma fn
+    inl_act                 = inlinePragmaActivation inl_prag
+    is_local                = isLocalId fn
+
+        -- Figure out whether the function has an INLINE pragma
+        -- See Note [Inline specialisations]
+
+    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs
+                                 -- See Note [Account for casts in binding]
+    (rhs_tyvars, rhs_bndrs1)   = span isTyVar rhs_bndrs
+    (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1
+    body                       = mkLams rhs_bndrs2 rhs_body
+                                 -- Glue back on the non-dict lambdas
+
+    in_scope = CoreSubst.substInScope (se_subst env)
+
+    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool
+    already_covered dflags new_rules args      -- Note [Specialisations already covered]
+       = isJust (lookupRule dflags (in_scope, realIdUnfolding)
+                            (const True) fn args
+                            (new_rules ++ existing_rules))
+         -- NB: we look both in the new_rules (generated by this invocation
+         --     of specCalls), and in existing_rules (passed in to specCalls)
+
+    mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
+    mk_ty_args [] poly_tvs
+      = ASSERT( null poly_tvs ) []
+    mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)
+      = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs
+    mk_ty_args (Just ty : call_ts) poly_tvs
+      = Type ty : mk_ty_args call_ts poly_tvs
+    mk_ty_args (Nothing : _) [] = panic "mk_ty_args"
+
+    ----------------------------------------------------------
+        -- Specialise to one particular call pattern
+    spec_call :: SpecInfo                         -- Accumulating parameter
+              -> CallInfo                         -- Call instance
+              -> SpecM SpecInfo
+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)
+              (CI { ci_key = CallKey call_ts, ci_args = call_ds })
+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
+
+        -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
+        -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
+
+        -- Construct the new binding
+        --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
+        -- PLUS the rule
+        --      RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b
+        --      In the rule, d1' and d2' are just wildcards, not used in the RHS
+        -- PLUS the usage-details
+        --      { d1' = dx1; d2' = dx2 }
+        -- where d1', d2' are cloned versions of d1,d2, with the type substitution
+        -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
+        --
+        -- Note that the substitution is applied to the whole thing.
+        -- This is convenient, but just slightly fragile.  Notably:
+        --      * There had better be no name clashes in a/b/c
+        do { let
+                -- poly_tyvars = [b] in the example above
+                -- spec_tyvars = [a,c]
+                -- ty_args     = [t1,b,t3]
+                spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
+                env1          = extendTvSubstList env spec_tv_binds
+                (rhs_env, poly_tyvars) = substBndrs env1
+                                            [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
+
+             -- Clone rhs_dicts, including instantiating their types
+           ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids
+           ; let (rhs_env2, dx_binds, spec_dict_args)
+                            = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids
+                 ty_args    = mk_ty_args call_ts poly_tyvars
+                 ev_args    = map varToCoreExpr inst_dict_ids  -- ev_args, ev_bndrs:
+                 ev_bndrs   = exprsFreeIdsList ev_args         -- See Note [Evidence foralls]
+                 rule_args  = ty_args     ++ ev_args
+                 rule_bndrs = poly_tyvars ++ ev_bndrs
+
+           ; dflags <- getDynFlags
+           ; if already_covered dflags rules_acc rule_args
+             then return spec_acc
+             else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids
+                  --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)
+                  --                           , ppr dx_binds ]) $
+                  do
+           {    -- Figure out the type of the specialised function
+             let body_ty = applyTypeToArgs rhs fn_type rule_args
+                 (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
+                   | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs
+                   , not (isJoinId fn)
+                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])
+                   | otherwise = (poly_tyvars, poly_tyvars)
+                 spec_id_ty = mkLamTypes lam_args body_ty
+                 join_arity_change = length app_args - length rule_args
+                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
+                                 = Just (orig_join_arity + join_arity_change)
+                                 | otherwise
+                                 = Nothing
+
+           ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity
+           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)
+           ; this_mod <- getModule
+           ; let
+                -- The rule to put in the function's specialisation is:
+                --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
+                herald = case mb_mod of
+                           Nothing        -- Specialising local fn
+                               -> text "SPEC"
+                           Just this_mod  -- Specialising imported fn
+                               -> text "SPEC/" <> ppr this_mod
+
+                rule_name = mkFastString $ showSDoc dflags $
+                            herald <+> ftext (occNameFS (getOccName fn))
+                                   <+> hsep (map ppr_call_key_ty call_ts)
+                            -- This name ends up in interface files, so use occNameString.
+                            -- Otherwise uniques end up there, making builds
+                            -- less deterministic (See #4012 comment:61 ff)
+
+                rule_wout_eta = mkRule
+                                  this_mod
+                                  True {- Auto generated -}
+                                  is_local
+                                  rule_name
+                                  inl_act       -- Note [Auto-specialisation and RULES]
+                                  (idName fn)
+                                  rule_bndrs
+                                  rule_args
+                                  (mkVarApps (Var spec_f) app_args)
+
+                spec_rule
+                  = case isJoinId_maybe fn of
+                      Just join_arity -> etaExpandToJoinPointRule join_arity
+                                                                  rule_wout_eta
+                      Nothing -> rule_wout_eta
+
+                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+                spec_uds = foldr consDictBind rhs_uds dx_binds
+
+                --------------------------------------
+                -- Add a suitable unfolding if the spec_inl_prag says so
+                -- See Note [Inline specialisations]
+                (spec_inl_prag, spec_unf)
+                  | not is_local && isStrongLoopBreaker (idOccInfo fn)
+                  = (neverInlinePragma, noUnfolding)
+                        -- See Note [Specialising imported functions] in OccurAnal
+
+                  | InlinePragma { inl_inline = Inlinable } <- inl_prag
+                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)
+
+                  | otherwise
+                  = (inl_prag, specUnfolding dflags poly_tyvars spec_app
+                                             arity_decrease fn_unf)
+
+                arity_decrease = length spec_dict_args
+                spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args
+
+                --------------------------------------
+                -- Adding arity information just propagates it a bit faster
+                --      See Note [Arity decrease] in Simplify
+                -- Copy InlinePragma information from the parent Id.
+                -- So if f has INLINE[1] so does spec_f
+                spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)
+                                        `setInlinePragma` spec_inl_prag
+                                        `setIdUnfolding`  spec_unf
+                                        `asJoinId_maybe`  spec_join_arity
+
+           ; return ( spec_rule                  : rules_acc
+                    , (spec_f_w_arity, spec_rhs) : pairs_acc
+                    , spec_uds           `plusUDs` uds_acc
+                    ) } }
+
+{- Note [Account for casts in binding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: Eq a => a -> IO ()
+   {-# INLINABLE f
+       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g
+     #-}
+   f = ...
+
+In f's stable unfolding we have done some modest simplification which
+has pushed the cast to the outside.  (I wonder if this is the Right
+Thing, but it's what happens now; see SimplUtils Note [Casts and
+lambdas].)  Now that stable unfolding must be specialised, so we want
+to push the cast back inside. It would be terrible if the cast
+defeated specialisation!  Hence the use of collectBindersPushingCo.
+
+Note [Evidence foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (#12212) that we are specialising
+   f :: forall a b. (Num a, F a ~ F b) => blah
+with a=b=Int. Then the RULE will be something like
+   RULE forall (d:Num Int) (g :: F Int ~ F Int).
+        f Int Int d g = f_spec
+But both varToCoreExpr (when constructing the LHS args), and the
+simplifier (when simplifying the LHS args), will transform to
+   RULE forall (d:Num Int) (g :: F Int ~ F Int).
+        f Int Int d <F Int> = f_spec
+by replacing g with Refl.  So now 'g' is unbound, which results in a later
+crash. So we use Refl right off the bat, and do not forall-quantify 'g':
+ * varToCoreExpr generates a Refl
+ * exprsFreeIdsList returns the Ids bound by the args,
+   which won't include g
+
+You might wonder if this will match as often, but the simplifier replaces
+complicated Refl coercions with Refl pretty aggressively.
+
+Note [Orphans and auto-generated rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise an INLINABLE function, or when we have
+-fspecialise-aggressively, we auto-generate RULES that are orphans.
+We don't want to warn about these, or we'd generate a lot of warnings.
+Thus, we only warn about user-specified orphan rules.
+
+Indeed, we don't even treat the module as an orphan module if it has
+auto-generated *rule* orphans.  Orphan modules are read every time we
+compile, so they are pretty obtrusive and slow down every compilation,
+even non-optimised ones.  (Reason: for type class instances it's a
+type correctness issue.)  But specialisation rules are strictly for
+*optimisation* only so it's fine not to read the interface.
+
+What this means is that a SPEC rules from auto-specialisation in
+module M will be used in other modules only if M.hi has been read for
+some other reason, which is actually pretty likely.
+-}
+
+bindAuxiliaryDicts
+        :: SpecEnv
+        -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions
+        -> [DictId]                 -- A cloned dict-id for each dict arg
+        -> (SpecEnv,                -- Substitute for all orig_dicts
+            [DictBind],             -- Auxiliary dict bindings
+            [CoreExpr])             -- Witnessing expressions (all trivial)
+-- Bind any dictionary arguments to fresh names, to preserve sharing
+bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
+                   orig_dict_ids call_ds inst_dict_ids
+  = (env', dx_binds, spec_dict_args)
+  where
+    (dx_binds, spec_dict_args) = go call_ds inst_dict_ids
+    env' = env { se_subst = subst `CoreSubst.extendSubstList`
+                                     (orig_dict_ids `zip` spec_dict_args)
+                                  `CoreSubst.extendInScopeList` dx_ids
+               , se_interesting = interesting `unionVarSet` interesting_dicts }
+
+    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]
+    interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds
+                                 , interestingDict env dx ]
+                  -- See Note [Make the new dictionaries interesting]
+
+    go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])
+    go [] _  = ([], [])
+    go (dx:dxs) (dx_id:dx_ids)
+      | exprIsTrivial dx = (dx_binds,                          dx        : args)
+      | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)
+      where
+        (dx_binds, args) = go dxs dx_ids
+             -- In the first case extend the substitution but not bindings;
+             -- in the latter extend the bindings but not the substitution.
+             -- For the former, note that we bind the *original* dict in the substitution,
+             -- overriding any d->dx_id binding put there by substBndrs
+    go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)
+
+{-
+Note [Make the new dictionaries interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Important!  We're going to substitute dx_id1 for d
+and we want it to look "interesting", else we won't gather *any*
+consequential calls. E.g.
+    f d = ...g d....
+If we specialise f for a call (f (dfun dNumInt)), we'll get
+a consequent call (g d') with an auxiliary definition
+    d' = df dNumInt
+We want that consequent call to look interesting
+
+
+Note [From non-recursive to recursive]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even in the non-recursive case, if any dict-binds depend on 'fn' we might
+have built a recursive knot
+
+      f a d x = <blah>
+      MkUD { ud_binds = NonRec d7  (MkD ..f..)
+           , ud_calls = ...(f T d7)... }
+
+The we generate
+
+     Rec { fs x = <blah>[T/a, d7/d]
+           f a d x = <blah>
+               RULE f T _ = fs
+           d7 = ...f... }
+
+Here the recursion is only through the RULE.
+
+However we definitely should /not/ make the Rec in this wildly common
+case:
+      d = ...
+      MkUD { ud_binds = NonRec d7 (...d...)
+           , ud_calls = ...(f T d7)... }
+
+Here we want simply to add d to the floats, giving
+      MkUD { ud_binds = NonRec d (...)
+                        NonRec d7 (...d...)
+           , ud_calls = ...(f T d7)... }
+
+In general, we need only make this Rec if
+  - there are some specialisations (spec_binds non-empty)
+  - there are some dict_binds that depend on f (dump_dbs non-empty)
+
+Note [Avoiding loops]
+~~~~~~~~~~~~~~~~~~~~~
+When specialising /dictionary functions/ we must be very careful to
+avoid building loops. Here is an example that bit us badly: #3591
+
+     class Eq a => C a
+     instance Eq [a] => C [a]
+
+This translates to
+     dfun :: Eq [a] -> C [a]
+     dfun a d = MkD a d (meth d)
+
+     d4 :: Eq [T] = <blah>
+     d2 ::  C [T] = dfun T d4
+     d1 :: Eq [T] = $p1 d2
+     d3 ::  C [T] = dfun T d1
+
+None of these definitions is recursive. What happened was that we
+generated a specialisation:
+
+     RULE forall d. dfun T d = dT  :: C [T]
+     dT = (MkD a d (meth d)) [T/a, d1/d]
+        = MkD T d1 (meth d1)
+
+But now we use the RULE on the RHS of d2, to get
+
+    d2 = dT = MkD d1 (meth d1)
+    d1 = $p1 d2
+
+and now d1 is bottom!  The problem is that when specialising 'dfun' we
+should first dump "below" the binding all floated dictionary bindings
+that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be
+placed below 'dfun', and thus unavailable to it when specialising
+'dfun'.  That in turn means that the call (dfun T d1) must be
+discarded.  On the other hand, the call (dfun T d4) is fine, assuming
+d4 doesn't mention dfun.
+
+Solution:
+  Discard all calls that mention dictionaries that depend
+  (directly or indirectly) on the dfun we are specialising.
+  This is done by 'filterCalls'
+
+--------------
+Here's another example, this time for an imported dfun, so the call
+to filterCalls is in specImports (#13429). Suppose we have
+  class Monoid v => C v a where ...
+
+We start with a call
+   f @ [Integer] @ Integer $fC[]Integer
+
+Specialising call to 'f' gives dict bindings
+   $dMonoid_1 :: Monoid [Integer]
+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer
+
+   $dC_1 :: C [Integer] (Node [Integer] Integer)
+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+
+...plus a recursive call to
+   f @ [Integer] @ (Node [Integer] Integer) $dC_1
+
+Specialising that call gives
+   $dMonoid_2  :: Monoid [Integer]
+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1
+
+   $dC_2 :: C [Integer] (Node [Integer] Integer)
+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2
+
+Now we have two calls to the imported function
+  M.$fCvNode :: Monoid v => C v a
+  M.$fCvNode @v @a m = C m some_fun
+
+But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)
+for specialisation, else we get:
+
+  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1
+  $s$fCvNode = C $dMonoid_2 ...
+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode
+
+Now use the rule to rewrite the call in the RHS of $dC_1
+and we get a loop!
+
+--------------
+Here's yet another example
+
+  class C a where { foo,bar :: [a] -> [a] }
+
+  instance C Int where
+     foo x = r_bar x
+     bar xs = reverse xs
+
+  r_bar :: C a => [a] -> [a]
+  r_bar xs = bar (xs ++ xs)
+
+That translates to:
+
+    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
+
+    Rec { $fCInt :: C Int = MkC foo_help reverse
+          foo_help (xs::[Int]) = r_bar Int $fCInt xs }
+
+The call (r_bar $fCInt) mentions $fCInt,
+                        which mentions foo_help,
+                        which mentions r_bar
+But we DO want to specialise r_bar at Int:
+
+    Rec { $fCInt :: C Int = MkC foo_help reverse
+          foo_help (xs::[Int]) = r_bar Int $fCInt xs
+
+          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
+            RULE r_bar Int _ = r_bar_Int
+
+          r_bar_Int xs = bar Int $fCInt (xs ++ xs)
+           }
+
+Note that, because of its RULE, r_bar joins the recursive
+group.  (In this case it'll unravel a short moment later.)
+
+
+Note [Specialising a recursive group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    let rec { f x = ...g x'...
+            ; g y = ...f y'.... }
+    in f 'a'
+Here we specialise 'f' at Char; but that is very likely to lead to
+a specialisation of 'g' at Char.  We must do the latter, else the
+whole point of specialisation is lost.
+
+But we do not want to keep iterating to a fixpoint, because in the
+presence of polymorphic recursion we might generate an infinite number
+of specialisations.
+
+So we use the following heuristic:
+  * Arrange the rec block in dependency order, so far as possible
+    (the occurrence analyser already does this)
+
+  * Specialise it much like a sequence of lets
+
+  * Then go through the block a second time, feeding call-info from
+    the RHSs back in the bottom, as it were
+
+In effect, the ordering maxmimises the effectiveness of each sweep,
+and we do just two sweeps.   This should catch almost every case of
+monomorphic recursion -- the exception could be a very knotted-up
+recursion with multiple cycles tied up together.
+
+This plan is implemented in the Rec case of specBindItself.
+
+Note [Specialisations already covered]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We obviously don't want to generate two specialisations for the same
+argument pattern.  There are two wrinkles
+
+1. We do the already-covered test in specDefn, not when we generate
+the CallInfo in mkCallUDs.  We used to test in the latter place, but
+we now iterate the specialiser somewhat, and the Id at the call site
+might therefore not have all the RULES that we can see in specDefn
+
+2. What about two specialisations where the second is an *instance*
+of the first?  If the more specific one shows up first, we'll generate
+specialisations for both.  If the *less* specific one shows up first,
+we *don't* currently generate a specialisation for the more specific
+one.  (See the call to lookupRule in already_covered.)  Reasons:
+  (a) lookupRule doesn't say which matches are exact (bad reason)
+  (b) if the earlier specialisation is user-provided, it's
+      far from clear that we should auto-specialise further
+
+Note [Auto-specialisation and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   g :: Num a => a -> a
+   g = ...
+
+   f :: (Int -> Int) -> Int
+   f w = ...
+   {-# RULE f g = 0 #-}
+
+Suppose that auto-specialisation makes a specialised version of
+g::Int->Int That version won't appear in the LHS of the RULE for f.
+So if the specialisation rule fires too early, the rule for f may
+never fire.
+
+It might be possible to add new rules, to "complete" the rewrite system.
+Thus when adding
+        RULE forall d. g Int d = g_spec
+also add
+        RULE f g_spec = 0
+
+But that's a bit complicated.  For now we ask the programmer's help,
+by *copying the INLINE activation pragma* to the auto-specialised
+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
+will also not be active until phase 2.  And that's what programmers
+should jolly well do anyway, even aside from specialisation, to ensure
+that g doesn't inline too early.
+
+This in turn means that the RULE would never fire for a NOINLINE
+thing so not much point in generating a specialisation at all.
+
+Note [Specialisation shape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only specialise a function if it has visible top-level lambdas
+corresponding to its overloading.  E.g. if
+        f :: forall a. Eq a => ....
+then its body must look like
+        f = /\a. \d. ...
+
+Reason: when specialising the body for a call (f ty dexp), we want to
+substitute dexp for d, and pick up specialised calls in the body of f.
+
+This doesn't always work.  One example I came across was this:
+        newtype Gen a = MkGen{ unGen :: Int -> a }
+
+        choose :: Eq a => a -> Gen a
+        choose n = MkGen (\r -> n)
+
+        oneof = choose (1::Int)
+
+It's a silly example, but we get
+        choose = /\a. g `cast` co
+where choose doesn't have any dict arguments.  Thus far I have not
+tried to fix this (wait till there's a real example).
+
+Mind you, then 'choose' will be inlined (since RHS is trivial) so
+it doesn't matter.  This comes up with single-method classes
+
+   class C a where { op :: a -> a }
+   instance C a => C [a] where ....
+==>
+   $fCList :: C a => C [a]
+   $fCList = $copList |> (...coercion>...)
+   ....(uses of $fCList at particular types)...
+
+So we suppress the WARN if the rhs is trivial.
+
+Note [Inline specialisations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is what we do with the InlinePragma of the original function
+  * Activation/RuleMatchInfo: both transferred to the
+                              specialised function
+  * InlineSpec:
+       (a) An INLINE pragma is transferred
+       (b) An INLINABLE pragma is *not* transferred
+
+Why (a): transfer INLINE pragmas? The point of INLINE was precisely to
+specialise the function at its call site, and arguably that's not so
+important for the specialised copies.  BUT *pragma-directed*
+specialisation now takes place in the typechecker/desugarer, with
+manually specified INLINEs.  The specialisation here is automatic.
+It'd be very odd if a function marked INLINE was specialised (because
+of some local use), and then forever after (including importing
+modules) the specialised version wasn't INLINEd.  After all, the
+programmer said INLINE!
+
+You might wonder why we specialise INLINE functions at all.  After
+all they should be inlined, right?  Two reasons:
+
+ * Even INLINE functions are sometimes not inlined, when they aren't
+   applied to interesting arguments.  But perhaps the type arguments
+   alone are enough to specialise (even though the args are too boring
+   to trigger inlining), and it's certainly better to call the
+   specialised version.
+
+ * The RHS of an INLINE function might call another overloaded function,
+   and we'd like to generate a specialised version of that function too.
+   This actually happens a lot. Consider
+      replicateM_ :: (Monad m) => Int -> m a -> m ()
+      {-# INLINABLE replicateM_ #-}
+      replicateM_ d x ma = ...
+   The strictness analyser may transform to
+      replicateM_ :: (Monad m) => Int -> m a -> m ()
+      {-# INLINE replicateM_ #-}
+      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma
+
+      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()
+      {-# INLINABLE $wreplicateM_ #-}
+      $wreplicateM_ = ...
+   Now an importing module has a specialised call to replicateM_, say
+   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!
+   This particular example had a huge effect on the call to replicateM_
+   in nofib/shootout/n-body.
+
+Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples.
+Suppose we have
+    {-# INLINABLE f #-}
+    f :: Ord a => [a] -> Int
+    f xs = letrec f' = ...f'... in f'
+Then, when f is specialised and optimised we might get
+    wgo :: [Int] -> Int#
+    wgo = ...wgo...
+    f_spec :: [Int] -> Int
+    f_spec xs = case wgo xs of { r -> I# r }
+and we clearly want to inline f_spec at call sites.  But if we still
+have the big, un-optimised of f (albeit specialised) captured in an
+INLINABLE pragma for f_spec, we won't get that optimisation.
+
+So we simply drop INLINABLE pragmas when specialising. It's not really
+a complete solution; ignoring specialisation for now, INLINABLE functions
+don't get properly strictness analysed, for example. But it works well
+for examples involving specialisation, which is the dominant use of
+INLINABLE.  See #4874.
+
+
+************************************************************************
+*                                                                      *
+\subsubsection{UsageDetails and suchlike}
+*                                                                      *
+************************************************************************
+-}
+
+data UsageDetails
+  = MkUD {
+      ud_binds :: !(Bag DictBind),
+               -- See Note [Floated dictionary bindings]
+               -- The order is important;
+               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+               -- (Remember, Bags preserve order in GHC.)
+
+      ud_calls :: !CallDetails
+
+      -- INVARIANT: suppose bs = bindersOf ud_binds
+      -- Then 'calls' may *mention* 'bs',
+      -- but there should be no calls *for* bs
+    }
+
+-- | A 'DictBind' is a binding along with a cached set containing its free
+-- variables (both type variables and dictionaries)
+type DictBind = (CoreBind, VarSet)
+
+{- Note [Floated dictionary bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We float out dictionary bindings for the reasons described under
+"Dictionary floating" above.  But not /just/ dictionary bindings.
+Consider
+
+   f :: Eq a => blah
+   f a d = rhs
+
+   $c== :: T -> T -> Bool
+   $c== x y = ...
+
+   $df :: Eq T
+   $df = Eq $c== ...
+
+   gurgle = ...(f @T $df)...
+
+We gather the call info for (f @T $df), and we don't want to drop it
+when we come across the binding for $df.  So we add $df to the floats
+and continue.  But then we have to add $c== to the floats, and so on.
+These all float above the binding for 'f', and and now we can
+successfully specialise 'f'.
+
+So the DictBinds in (ud_binds :: Bag DictBind) may contain
+non-dictionary bindings too.
+-}
+
+instance Outputable UsageDetails where
+  ppr (MkUD { ud_binds = dbs, ud_calls = calls })
+        = text "MkUD" <+> braces (sep (punctuate comma
+                [text "binds" <+> equals <+> ppr dbs,
+                 text "calls" <+> equals <+> ppr calls]))
+
+emptyUDs :: UsageDetails
+emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }
+
+------------------------------------------------------------
+type CallDetails  = DIdEnv CallInfoSet
+  -- The order of specialized binds and rules depends on how we linearize
+  -- CallDetails, so to get determinism we must use a deterministic set here.
+  -- See Note [Deterministic UniqFM] in UniqDFM
+
+data CallInfoSet = CIS Id (Bag CallInfo)
+  -- The list of types and dictionaries is guaranteed to
+  -- match the type of f
+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)
+  -- These dups are eliminated by already_covered in specCalls
+
+data CallInfo
+  = CI { ci_key  :: CallKey     -- Type arguments
+       , ci_args :: [DictExpr]  -- Dictionary arguments
+       , ci_fvs  :: VarSet      -- Free vars of the ci_key and ci_args
+                                -- call (including tyvars)
+                                -- [*not* include the main id itself, of course]
+    }
+
+newtype CallKey   = CallKey [Maybe Type]
+  -- Nothing => unconstrained type argument
+
+type DictExpr = CoreExpr
+
+ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
+ciSetFilter p (CIS id a) = CIS id (filterBag p a)
+
+instance Outputable CallInfoSet where
+  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)
+                        2 (ppr map)
+
+pprCallInfo :: Id -> CallInfo -> SDoc
+pprCallInfo fn (CI { ci_key = key })
+  = ppr fn <+> ppr key
+
+ppr_call_key_ty :: Maybe Type -> SDoc
+ppr_call_key_ty Nothing   = char '_'
+ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty
+
+instance Outputable CallKey where
+  ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))
+
+instance Outputable CallInfo where
+  ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })
+    = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])
+
+unionCalls :: CallDetails -> CallDetails -> CallDetails
+unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2
+
+unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
+unionCallInfoSet (CIS f calls1) (CIS _ calls2) =
+  CIS f (calls1 `unionBags` calls2)
+
+callDetailsFVs :: CallDetails -> VarSet
+callDetailsFVs calls =
+  nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
+  -- It's OK to use nonDetFoldUDFM here because we forget the ordering
+  -- immediately by converting to a nondeterministic set.
+
+callInfoFVs :: CallInfoSet -> VarSet
+callInfoFVs (CIS _ call_info) =
+  foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
+
+------------------------------------------------------------
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
+singleCall id tys dicts
+  = MkUD {ud_binds = emptyBag,
+          ud_calls = unitDVarEnv id $ CIS id $
+                     unitBag (CI { ci_key = CallKey tys
+                                 , ci_args = dicts
+                                 , ci_fvs  = call_fvs }) }
+  where
+    call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
+    tys_fvs  = tyCoVarsOfTypes (catMaybes tys)
+        -- The type args (tys) are guaranteed to be part of the dictionary
+        -- types, because they are just the constrained types,
+        -- and the dictionary is therefore sure to be bound
+        -- inside the binding for any type variables free in the type;
+        -- hence it's safe to neglect tyvars free in tys when making
+        -- the free-var set for this call
+        -- BUT I don't trust this reasoning; play safe and include tys_fvs
+        --
+        -- We don't include the 'id' itself.
+
+mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
+mkCallUDs env f args
+  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])
+    res
+  where
+    res = mkCallUDs' env f args
+
+mkCallUDs' env f args
+  | not (want_calls_for f)  -- Imported from elsewhere
+  || null theta             -- Not overloaded
+  = emptyUDs
+
+  |  not (all type_determines_value theta)
+  || not (spec_tys `lengthIs` n_tyvars)
+  || not ( dicts   `lengthIs` n_dicts)
+  || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]
+  -- See also Note [Specialisations already covered]
+  = -- pprTrace "mkCallUDs: discarding" _trace_doc
+    emptyUDs    -- Not overloaded, or no specialisation wanted
+
+  | otherwise
+  = -- pprTrace "mkCallUDs: keeping" _trace_doc
+    singleCall f spec_tys dicts
+  where
+    _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
+                      , ppr (map (interestingDict env) dicts)]
+    (tyvars, theta, _)      = tcSplitSigmaTy (idType f)
+    constrained_tyvars      = tyCoVarsOfTypes theta
+    n_tyvars                = length tyvars
+    n_dicts                 = length theta
+
+    spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args]
+    dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
+
+    -- ignores Coercion arguments
+    type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)]
+    type_zip tvs      (Coercion _ : args) = type_zip tvs args
+    type_zip (tv:tvs) (Type ty : args)    = (tv, ty) : type_zip tvs args
+    type_zip _        _                   = []
+
+    mk_spec_ty tyvar ty
+        | tyvar `elemVarSet` constrained_tyvars = Just ty
+        | otherwise                             = Nothing
+
+    want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))
+         -- For imported things, we gather call instances if
+         -- there is an unfolding that we could in principle specialise
+         -- We might still decide not to use it (consulting dflags)
+         -- in specImports
+         -- Use 'realIdUnfolding' to ignore the loop-breaker flag!
+
+    type_determines_value pred    -- See Note [Type determines value]
+        = case classifyPredType pred of
+            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs
+            EqPred {}       -> True
+            IrredPred {}    -> True   -- Things like (D []) where D is a
+                                      -- Constraint-ranged family; #7785
+            ForAllPred {}   -> True
+
+{-
+Note [Type determines value]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only specialise if all overloading is on non-IP *class* params,
+because these are the ones whose *type* determines their *value*.  In
+parrticular, with implicit params, the type args *don't* say what the
+value of the implicit param is!  See #7101
+
+However, consider
+         type family D (v::*->*) :: Constraint
+         type instance D [] = ()
+         f :: D v => v Char -> Int
+If we see a call (f "foo"), we'll pass a "dictionary"
+  () |> (g :: () ~ D [])
+and it's good to specialise f at this dictionary.
+
+So the question is: can an implicit parameter "hide inside" a
+type-family constraint like (D a).  Well, no.  We don't allow
+        type instance D Maybe = ?x:Int
+Hence the IrredPred case in type_determines_value.
+See #7785.
+
+Note [Interesting dictionary arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+         \a.\d:Eq a.  let f = ... in ...(f d)...
+There really is not much point in specialising f wrt the dictionary d,
+because the code for the specialised f is not improved at all, because
+d is lambda-bound.  We simply get junk specialisations.
+
+What is "interesting"?  Just that it has *some* structure.  But what about
+variables?
+
+ * A variable might be imported, in which case its unfolding
+   will tell us whether it has useful structure
+
+ * Local variables are cloned on the way down (to avoid clashes when
+   we float dictionaries), and cloning drops the unfolding
+   (cloneIdBndr).  Moreover, we make up some new bindings, and it's a
+   nuisance to give them unfoldings.  So we keep track of the
+   "interesting" dictionaries as a VarSet in SpecEnv.
+   We have to take care to put any new interesting dictionary
+   bindings in the set.
+
+We accidentally lost accurate tracking of local variables for a long
+time, because cloned variables don't have unfoldings. But makes a
+massive difference in a few cases, eg #5113. For nofib as a
+whole it's only a small win: 2.2% improvement in allocation for ansi,
+1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.
+-}
+
+interestingDict :: SpecEnv -> CoreExpr -> Bool
+-- A dictionary argument is interesting if it has *some* structure
+-- NB: "dictionary" arguments include constraints of all sorts,
+--     including equality constraints; hence the Coercion case
+interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)
+                            || isDataConWorkId v
+                            || v `elemVarSet` se_interesting env
+interestingDict _ (Type _)                = False
+interestingDict _ (Coercion _)            = False
+interestingDict env (App fn (Type _))     = interestingDict env fn
+interestingDict env (App fn (Coercion _)) = interestingDict env fn
+interestingDict env (Tick _ a)            = interestingDict env a
+interestingDict env (Cast e _)            = interestingDict env e
+interestingDict _ _                       = True
+
+plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
+plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
+        (MkUD {ud_binds = db2, ud_calls = calls2})
+  = MkUD { ud_binds = db1    `unionBags`   db2
+         , ud_calls = calls1 `unionCalls`  calls2 }
+
+-----------------------------
+_dictBindBndrs :: Bag DictBind -> [Id]
+_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
+
+-- | Construct a 'DictBind' from a 'CoreBind'
+mkDB :: CoreBind -> DictBind
+mkDB bind = (bind, bind_fvs bind)
+
+-- | Identify the free variables of a 'CoreBind'
+bind_fvs :: CoreBind -> VarSet
+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
+bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs
+                           where
+                             bndrs = map fst prs
+                             rhs_fvs = unionVarSets (map pair_fvs prs)
+
+pair_fvs :: (Id, CoreExpr) -> VarSet
+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
+                       `unionVarSet` idFreeVars bndr
+        -- idFreeVars: don't forget variables mentioned in
+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage
+        -- Also tyvars mentioned in its type; they may not appear
+        -- in the RHS
+        --      type T a = Int
+        --      x :: T a = 3
+  where
+    interesting :: InterestingVarFun
+    interesting v = isLocalVar v || (isId v && isDFunId v)
+        -- Very important: include DFunIds /even/ if it is imported
+        -- Reason: See Note [Avoiding loops], the second exmaple
+        --         involving an imported dfun.  We must know whether
+        --         a dictionary binding depends on an imported dfun,
+        --         in case we try to specialise that imported dfun
+        --         #13429 illustrates
+
+-- | Flatten a set of "dumped" 'DictBind's, and some other binding
+-- pairs, into a single recursive binding.
+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind
+recWithDumpedDicts pairs dbs
+  = (Rec bindings, fvs)
+  where
+    (bindings, fvs) = foldrBag add
+                               ([], emptyVarSet)
+                               (dbs `snocBag` mkDB (Rec pairs))
+    add (NonRec b r, fvs') (pairs, fvs) =
+      ((b,r) : pairs, fvs `unionVarSet` fvs')
+    add (Rec prs1,   fvs') (pairs, fvs) =
+      (prs1 ++ pairs, fvs `unionVarSet` fvs')
+
+snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
+-- Add ud_binds to the tail end of the bindings in uds
+snocDictBinds uds dbs
+  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }
+
+consDictBind :: DictBind -> UsageDetails -> UsageDetails
+consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }
+
+addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
+addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }
+
+snocDictBind :: UsageDetails -> DictBind -> UsageDetails
+snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }
+
+wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
+wrapDictBinds dbs binds
+  = foldrBag add binds dbs
+  where
+    add (bind,_) binds = bind : binds
+
+wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
+wrapDictBindsE dbs expr
+  = foldrBag add expr dbs
+  where
+    add (bind,_) expr = Let bind expr
+
+----------------------
+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
+-- Used at a lambda or case binder; just dump anything mentioning the binder
+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+  | null bndrs = (uds, emptyBag)  -- Common in case alternatives
+  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
+                 (free_uds, dump_dbs)
+  where
+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
+    bndr_set = mkVarSet bndrs
+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
+    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor
+                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be
+                                                    -- no calls for any of the dicts in dump_dbs
+
+dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
+-- Used at a let(rec) binding.
+-- We return a boolean indicating whether the binding itself is mentioned,
+-- directly or indirectly, by any of the ud_calls; in that case we want to
+-- float the binding itself;
+-- See Note [Floated dictionary bindings]
+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
+    (free_uds, dump_dbs, float_all)
+  where
+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
+    bndr_set = mkVarSet bndrs
+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
+    free_calls = deleteCallsFor bndrs orig_calls
+    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
+
+callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
+callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+  = -- pprTrace ("callsForMe")
+    --          (vcat [ppr fn,
+    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),
+    --                 text "Orig calls ="   <+> ppr orig_calls,
+    --                 text "Dep set ="      <+> ppr dep_set,
+    --                 text "Calls for me =" <+> ppr calls_for_me]) $
+    (uds_without_me, calls_for_me)
+  where
+    uds_without_me = MkUD { ud_binds = orig_dbs
+                          , ud_calls = delDVarEnv orig_calls fn }
+    calls_for_me = case lookupDVarEnv orig_calls fn of
+                        Nothing -> []
+                        Just cis -> filterCalls cis orig_dbs
+         -- filterCalls: drop calls that (directly or indirectly)
+         -- refer to fn.  See Note [Avoiding loops]
+
+----------------------
+filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
+-- See Note [Avoiding loops]
+filterCalls (CIS fn call_bag) dbs
+  = filter ok_call (bagToList call_bag)
+  where
+    dump_set = foldlBag go (unitVarSet fn) dbs
+      -- This dump-set could also be computed by splitDictBinds
+      --   (_,_,dump_set) = splitDictBinds dbs {fn}
+      -- But this variant is shorter
+
+    go so_far (db,fvs) | fvs `intersectsVarSet` so_far
+                       = extendVarSetList so_far (bindersOf db)
+                       | otherwise = so_far
+
+    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)
+
+----------------------
+splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
+-- splitDictBinds dbs bndrs returns
+--   (free_dbs, dump_dbs, dump_set)
+-- where
+--   * dump_dbs depends, transitively on bndrs
+--   * 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;
+                -- we're accumulating the set of dumped ids in dump_set
+   where
+    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
+        | dump_idset `intersectsVarSet` fvs     -- Dump it
+        = (free_dbs, dump_dbs `snocBag` db,
+           extendVarSetList dump_idset (bindersOf bind))
+
+        | otherwise     -- Don't dump it
+        = (free_dbs `snocBag` db, dump_dbs, dump_idset)
+
+
+----------------------
+deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
+-- Remove calls *mentioning* bs in any way
+deleteCallsMentioning bs calls
+  = mapDVarEnv (ciSetFilter keep_call) calls
+  where
+    keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)
+
+deleteCallsFor :: [Id] -> CallDetails -> CallDetails
+-- Remove calls *for* bs
+deleteCallsFor bs calls = delDVarEnvList calls bs
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Boring helper functions}
+*                                                                      *
+************************************************************************
+-}
+
+newtype SpecM a = SpecM (State SpecState a)
+
+data SpecState = SpecState {
+                     spec_uniq_supply :: UniqSupply,
+                     spec_module :: Module,
+                     spec_dflags :: DynFlags
+                 }
+
+instance Functor SpecM where
+    fmap = liftM
+
+instance Applicative SpecM where
+    pure x = SpecM $ return x
+    (<*>) = ap
+
+instance Monad SpecM where
+    SpecM x >>= f = SpecM $ do y <- x
+                               case f y of
+                                   SpecM z ->
+                                       z
+#if !MIN_VERSION_base(4,13,0)
+    fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail SpecM where
+   fail str = SpecM $ error str
+
+instance MonadUnique SpecM where
+    getUniqueSupplyM
+        = SpecM $ do st <- get
+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st
+                     put $ st { spec_uniq_supply = us2 }
+                     return us1
+
+    getUniqueM
+        = SpecM $ do st <- get
+                     let (u,us') = takeUniqFromSupply $ spec_uniq_supply st
+                     put $ st { spec_uniq_supply = us' }
+                     return u
+
+instance HasDynFlags SpecM where
+    getDynFlags = SpecM $ liftM spec_dflags get
+
+instance HasModule SpecM where
+    getModule = SpecM $ liftM spec_module get
+
+runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a
+runSpecM dflags this_mod (SpecM spec)
+    = do us <- getUniqueSupplyM
+         let initialState = SpecState {
+                                spec_uniq_supply = us,
+                                spec_module = this_mod,
+                                spec_dflags = dflags
+                            }
+         return $ evalState spec initialState
+
+mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
+mapAndCombineSM _ []     = return ([], emptyUDs)
+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
+                              (ys, uds2) <- mapAndCombineSM f xs
+                              return (y:ys, uds1 `plusUDs` uds2)
+
+extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
+extendTvSubstList env tv_binds
+  = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }
+
+substTy :: SpecEnv -> Type -> Type
+substTy env ty = CoreSubst.substTy (se_subst env) ty
+
+substCo :: SpecEnv -> Coercion -> Coercion
+substCo env co = CoreSubst.substCo (se_subst env) co
+
+substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
+substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of
+                      (subst', bs') -> (env { se_subst = subst' }, bs')
+
+substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
+substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of
+                      (subst', bs') -> (env { se_subst = subst' }, bs')
+
+cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
+-- Clone the binders of the bind; return new bind with the cloned binders
+-- Return the substitution to use for RHSs, and the one to use for the body
+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)
+  = do { us <- getUniqueSupplyM
+       ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr
+             interesting' | interestingDict env rhs
+                          = interesting `extendVarSet` bndr'
+                          | otherwise = interesting
+       ; return (env, env { se_subst = subst', se_interesting = interesting' }
+                , NonRec bndr' rhs) }
+
+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)
+  = do { us <- getUniqueSupplyM
+       ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)
+             env' = env { se_subst = subst'
+                        , se_interesting = interesting `extendVarSetList`
+                                           [ v | (v,r) <- pairs, interestingDict env r ] }
+       ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }
+
+newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
+-- Make up completely fresh binders for the dictionaries
+-- Their bindings are going to float outwards
+newDictBndr env b = do { uniq <- getUniqueM
+                       ; let n   = idName b
+                             ty' = substTy env (idType b)
+                       ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }
+
+newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
+    -- Give the new Id a similar occurrence name to the old one
+newSpecIdSM old_id new_ty join_arity_maybe
+  = do  { uniq <- getUniqueM
+        ; let name    = idName old_id
+              new_occ = mkSpecOcc (nameOccName name)
+              new_id  = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name)
+                          `asJoinId_maybe` join_arity_maybe
+        ; return new_id }
+
+{-
+                Old (but interesting) stuff about unboxed bindings
+                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+What should we do when a value is specialised to a *strict* unboxed value?
+
+        map_*_* f (x:xs) = let h = f x
+                               t = map f xs
+                           in h:t
+
+Could convert let to case:
+
+        map_*_Int# f (x:xs) = case f x of h# ->
+                              let t = map f xs
+                              in h#:t
+
+This may be undesirable since it forces evaluation here, but the value
+may not be used in all branches of the body. In the general case this
+transformation is impossible since the mutual recursion in a letrec
+cannot be expressed as a case.
+
+There is also a problem with top-level unboxed values, since our
+implementation cannot handle unboxed values at the top level.
+
+Solution: Lift the binding of the unboxed value and extract it when it
+is used:
+
+        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
+                                  t = map f xs
+                              in case h of
+                                 _Lift h# -> h#:t
+
+Now give it to the simplifier and the _Lifting will be optimised away.
+
+The benefit is that we have given the specialised "unboxed" values a
+very simple lifted semantics and then leave it up to the simplifier to
+optimise it --- knowing that the overheads will be removed in nearly
+all cases.
+
+In particular, the value will only be evaluated in the branches of the
+program which use it, rather than being forced at the point where the
+value is bound. For example:
+
+        filtermap_*_* p f (x:xs)
+          = let h = f x
+                t = ...
+            in case p x of
+                True  -> h:t
+                False -> t
+   ==>
+        filtermap_*_Int# p f (x:xs)
+          = let h = case (f x) of h# -> _Lift h#
+                t = ...
+            in case p x of
+                True  -> case h of _Lift h#
+                           -> h#:t
+                False -> t
+
+The binding for h can still be inlined in the one branch and the
+_Lifting eliminated.
+
+
+Question: When won't the _Lifting be eliminated?
+
+Answer: When they at the top-level (where it is necessary) or when
+inlining would duplicate work (or possibly code depending on
+options). However, the _Lifting will still be eliminated if the
+strictness analyser deems the lifted binding strict.
+-}
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -0,0 +1,935 @@
+{-# LANGUAGE CPP #-}
+
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+--
+
+--------------------------------------------------------------
+-- Converting Core to STG Syntax
+--------------------------------------------------------------
+
+-- And, as we have the info in hand, we may convert some lets to
+-- let-no-escapes.
+
+module CoreToStg ( coreToStg ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils        ( exprType, findDefault, isJoinBind
+                        , exprIsTickedString_maybe )
+import CoreArity        ( manifestArity )
+import StgSyn
+
+import Type
+import RepType
+import TyCon
+import MkId             ( coercionTokenId )
+import Id
+import IdInfo
+import DataCon
+import CostCentre
+import VarEnv
+import Module
+import Name             ( isExternalName, nameOccName, nameModule_maybe )
+import OccName          ( occNameFS )
+import BasicTypes       ( Arity )
+import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )
+import Literal
+import Outputable
+import MonadUtils
+import FastString
+import Util
+import DynFlags
+import ForeignCall
+import Demand           ( isUsedOnce )
+import PrimOp           ( PrimCall(..) )
+import SrcLoc           ( mkGeneralSrcSpan )
+
+import Data.List.NonEmpty (nonEmpty, toList)
+import Data.Maybe    (fromMaybe)
+import Control.Monad (liftM, ap)
+
+-- Note [Live vs free]
+-- ~~~~~~~~~~~~~~~~~~~
+--
+-- The two are not the same. Liveness is an operational property rather
+-- than a semantic one. A variable is live at a particular execution
+-- point if it can be referred to directly again. In particular, a dead
+-- variable's stack slot (if it has one):
+--
+--           - should be stubbed to avoid space leaks, and
+--           - may be reused for something else.
+--
+-- There ought to be a better way to say this. Here are some examples:
+--
+--         let v = [q] \[x] -> e
+--         in
+--         ...v...  (but no q's)
+--
+-- Just after the `in', v is live, but q is dead. If the whole of that
+-- let expression was enclosed in a case expression, thus:
+--
+--         case (let v = [q] \[x] -> e in ...v...) of
+--                 alts[...q...]
+--
+-- (ie `alts' mention `q'), then `q' is live even after the `in'; because
+-- we'll return later to the `alts' and need it.
+--
+-- Let-no-escapes make this a bit more interesting:
+--
+--         let-no-escape v = [q] \ [x] -> e
+--         in
+--         ...v...
+--
+-- Here, `q' is still live at the `in', because `v' is represented not by
+-- a closure but by the current stack state.  In other words, if `v' is
+-- live then so is `q'. Furthermore, if `e' mentions an enclosing
+-- let-no-escaped variable, then its free variables are also live if `v' is.
+
+-- Note [What are these SRTs all about?]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider the Core program,
+--
+--     fibs = go 1 1
+--       where go a b = let c = a + c
+--                      in c : go b c
+--     add x = map (\y -> x*y) fibs
+--
+-- In this case we have a CAF, 'fibs', which is quite large after evaluation and
+-- has only one possible user, 'add'. Consequently, we want to ensure that when
+-- all references to 'add' die we can garbage collect any bit of 'fibs' that we
+-- have evaluated.
+--
+-- However, how do we know whether there are any references to 'fibs' still
+-- around? Afterall, the only reference to it is buried in the code generated
+-- for 'add'. The answer is that we record the CAFs referred to by a definition
+-- in its info table, namely a part of it known as the Static Reference Table
+-- (SRT).
+--
+-- Since SRTs are so common, we use a special compact encoding for them in: we
+-- produce one table containing a list of CAFs in a module and then include a
+-- bitmap in each info table describing which entries of this table the closure
+-- references.
+--
+-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.
+
+-- Note [What is a non-escaping let]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- NB: Nowadays this is recognized by the occurrence analyser by turning a
+-- "non-escaping let" into a join point. The following is then an operational
+-- account of join points.
+--
+-- Consider:
+--
+--     let x = fvs \ args -> e
+--     in
+--         if ... then x else
+--            if ... then x else ...
+--
+-- `x' is used twice (so we probably can't unfold it), but when it is
+-- entered, the stack is deeper than it was when the definition of `x'
+-- happened.  Specifically, if instead of allocating a closure for `x',
+-- we saved all `x's fvs on the stack, and remembered the stack depth at
+-- that moment, then whenever we enter `x' we can simply set the stack
+-- pointer(s) to these remembered (compile-time-fixed) values, and jump
+-- to the code for `x'.
+--
+-- All of this is provided x is:
+--   1. non-updatable;
+--   2. guaranteed to be entered before the stack retreats -- ie x is not
+--      buried in a heap-allocated closure, or passed as an argument to
+--      something;
+--   3. all the enters have exactly the right number of arguments,
+--      no more no less;
+--   4. all the enters are tail calls; that is, they return to the
+--      caller enclosing the definition of `x'.
+--
+-- Under these circumstances we say that `x' is non-escaping.
+--
+-- An example of when (4) does not hold:
+--
+--     let x = ...
+--     in case x of ...alts...
+--
+-- Here, `x' is certainly entered only when the stack is deeper than when
+-- `x' is defined, but here it must return to ...alts... So we can't just
+-- adjust the stack down to `x''s recalled points, because that would lost
+-- alts' context.
+--
+-- Things can get a little more complicated.  Consider:
+--
+--     let y = ...
+--     in let x = fvs \ args -> ...y...
+--     in ...x...
+--
+-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
+-- non-escaping way in ...y..., then `y' is non-escaping.
+--
+-- `x' can even be recursive!  Eg:
+--
+--     letrec x = [y] \ [v] -> if v then x True else ...
+--     in
+--         ...(x b)...
+
+-- Note [Cost-centre initialization plan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
+-- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
+-- We now initialize these correctly. The initialization works like this:
+--
+--   - For non-top level bindings always use `currentCCS`.
+--
+--   - For top-level bindings, check if the binding is a CAF
+--
+--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
+--                 and use it. Note that these new cost centres need to be
+--                 collected to be able to generate cost centre initialization
+--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
+--
+--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
+--
+--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
+--                 do we set CCCS from it; so we just slam in
+--                 dontCareCostCentre.
+
+-- --------------------------------------------------------------
+-- Setting variable info: top-level, binds, RHSs
+-- --------------------------------------------------------------
+
+coreToStg :: DynFlags -> Module -> CoreProgram
+          -> ([StgTopBinding], CollectedCCs)
+coreToStg dflags this_mod pgm
+  = (pgm', final_ccs)
+  where
+    (_, (local_ccs, local_cc_stacks), pgm')
+      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+
+    prof = WayProf `elem` ways dflags
+
+    final_ccs
+      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
+      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
+      | prof
+      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
+      | otherwise
+      = emptyCollectedCCs
+
+    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
+
+coreTopBindsToStg
+    :: DynFlags
+    -> Module
+    -> IdEnv HowBound           -- environment for the bindings
+    -> CollectedCCs
+    -> CoreProgram
+    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
+
+coreTopBindsToStg _      _        env ccs []
+  = (env, ccs, [])
+coreTopBindsToStg dflags this_mod env ccs (b:bs)
+  = (env2, ccs2, b':bs')
+  where
+        (env1, ccs1, b' ) =
+          coreTopBindToStg dflags this_mod env ccs b
+        (env2, ccs2, bs') =
+          coreTopBindsToStg dflags this_mod env1 ccs1 bs
+
+coreTopBindToStg
+        :: DynFlags
+        -> Module
+        -> IdEnv HowBound
+        -> CollectedCCs
+        -> CoreBind
+        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
+
+coreTopBindToStg _ _ env ccs (NonRec id e)
+  | Just str <- exprIsTickedString_maybe e
+  -- top-level string literal
+  -- See Note [CoreSyn top-level string literals] in CoreSyn
+  = let
+        env' = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet 0
+    in (env', ccs, StgTopStringLit id str)
+
+coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
+  = let
+        env'      = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet $! manifestArity rhs
+
+        (stg_rhs, ccs') =
+            initCts env $
+              coreToTopStgRhs dflags ccs this_mod (id,rhs)
+
+        bind = StgTopLifted $ StgNonRec id stg_rhs
+    in
+    ASSERT2(consistentCafInfo id bind, ppr id )
+      -- 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
+      --     assertion again!
+    (env', ccs', bind)
+
+coreTopBindToStg dflags this_mod env ccs (Rec pairs)
+  = ASSERT( not (null pairs) )
+    let
+        binders = map fst pairs
+
+        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
+                     | (b, rhs) <- pairs ]
+        env' = extendVarEnvList env extra_env'
+
+        -- generate StgTopBindings and CAF cost centres created for CAFs
+        (ccs', stg_rhss)
+          = initCts env' $ do
+               mapAccumLM (\ccs rhs -> do
+                            (rhs', ccs') <-
+                              coreToTopStgRhs dflags ccs this_mod rhs
+                            return (ccs', rhs'))
+                          ccs
+                          pairs
+
+        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
+    in
+    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
+    (env', ccs', bind)
+
+
+-- Assertion helper: this checks that the CafInfo on the Id matches
+-- what CoreToStg has figured out about the binding's SRT.  The
+-- CafInfo will be exact in all cases except when CorePrep has
+-- floated out a binding, in which case it will be approximate.
+consistentCafInfo :: Id -> StgTopBinding -> Bool
+consistentCafInfo id bind
+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
+    safe
+  where
+    safe  = id_marked_caffy || not binding_is_caffy
+    exact = id_marked_caffy == binding_is_caffy
+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
+    binding_is_caffy = topStgBindHasCafRefs bind
+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
+
+coreToTopStgRhs
+        :: DynFlags
+        -> CollectedCCs
+        -> Module
+        -> (Id,CoreExpr)
+        -> CtsM (StgRhs, CollectedCCs)
+
+coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
+  = do { new_rhs <- coreToStgExpr rhs
+
+       ; let (stg_rhs, ccs') =
+               mkTopStgRhs dflags this_mod ccs bndr new_rhs
+             stg_arity =
+               stgRhsArity stg_rhs
+
+       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
+                 ccs') }
+  where
+        -- It's vital that the arity on a top-level Id matches
+        -- the arity of the generated STG binding, else an importing
+        -- module will use the wrong calling convention
+        --      (#2844 was an example where this happened)
+        -- NB1: we can't move the assertion further out without
+        --      blocking the "knot" tied in coreTopBindsToStg
+        -- NB2: the arity check is only needed for Ids with External
+        --      Names, because they are externally visible.  The CorePrep
+        --      pass introduces "sat" things with Local Names and does
+        --      not bother to set their Arity info, so don't fail for those
+    arity_ok stg_arity
+       | isExternalName (idName bndr) = id_arity == stg_arity
+       | otherwise                    = True
+    id_arity  = idArity bndr
+    mk_arity_msg stg_arity
+        = vcat [ppr bndr,
+                text "Id arity:" <+> ppr id_arity,
+                text "STG arity:" <+> ppr stg_arity]
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
+
+coreToStgExpr
+        :: CoreExpr
+        -> CtsM StgExpr
+
+-- The second and third components can be derived in a simple bottom up pass, not
+-- dependent on any decisions about which variables will be let-no-escaped or
+-- not.  The first component, that is, the decorated expression, may then depend
+-- on these components, but it in turn is not scrutinised as the basis for any
+-- decisions.  Hence no black holes.
+
+-- No LitInteger's or LitNatural's should be left by the time this is called.
+-- CorePrep should have converted them all to a real core representation.
+coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
+coreToStgExpr (Lit l)      = return (StgLit l)
+coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
+  -- 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 expr@(App _ _)
+  = coreToStgApp Nothing f args ticks
+  where
+    (f, args, ticks) = myCollectArgs expr
+
+coreToStgExpr expr@(Lam _ _)
+  = let
+        (args, body) = myCollectBinders expr
+        args'        = filterStgBinders args
+    in
+    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
+    body' <- coreToStgExpr body
+    let
+        result_expr = case nonEmpty args' of
+          Nothing     -> body'
+          Just args'' -> StgLam args'' body'
+
+    return result_expr
+
+coreToStgExpr (Tick tick expr)
+  = do case tick of
+         HpcTick{}    -> return ()
+         ProfNote{}   -> return ()
+         SourceNote{} -> return ()
+         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
+       expr2 <- coreToStgExpr expr
+       return (StgTick tick expr2)
+
+coreToStgExpr (Cast expr _)
+  = coreToStgExpr expr
+
+-- Cases require a little more real work.
+
+coreToStgExpr (Case scrut _ _ [])
+  = coreToStgExpr scrut
+    -- See Note [Empty case alternatives] in CoreSyn If the case
+    -- alternatives are empty, the scrutinee must diverge or raise an
+    -- exception, so we can just dive into it.
+    --
+    -- Of course this may seg-fault if the scrutinee *does* return.  A
+    -- belt-and-braces approach would be to move this case into the
+    -- code generator, and put a return point anyway that calls a
+    -- runtime system error function.
+
+
+coreToStgExpr (Case scrut bndr _ alts) = do
+    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
+    scrut2 <- coreToStgExpr scrut
+    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
+  where
+    vars_alt (con, binders, rhs)
+      | DataAlt c <- con, c == unboxedUnitDataCon
+      = -- This case is a bit smelly.
+        -- See Note [Nullary unboxed tuple] in Type.hs
+        -- where a nullary tuple is mapped to (State# World#)
+        ASSERT( null binders )
+        do { rhs2 <- coreToStgExpr rhs
+           ; return (DEFAULT, [], rhs2)  }
+      | otherwise
+      = let     -- Remove type variables
+            binders' = filterStgBinders binders
+        in
+        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
+        rhs2 <- coreToStgExpr rhs
+        return (con, binders', rhs2)
+
+coreToStgExpr (Let bind body) = do
+    coreToStgLet bind body
+
+coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
+
+mkStgAltType :: Id -> [CoreAlt] -> AltType
+mkStgAltType bndr alts
+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples
+
+  | otherwise
+  = case prim_reps of
+      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
+        Just tc
+          | isAbstractTyCon tc -> look_for_better_tycon
+          | isAlgTyCon tc      -> AlgAlt tc
+          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
+                                  PolyAlt
+        Nothing                -> PolyAlt
+      [unlifted] -> PrimAlt unlifted
+      not_unary  -> MultiValAlt (length not_unary)
+  where
+   bndr_ty   = idType bndr
+   prim_reps = typePrimRep bndr_ty
+
+   _is_poly_alt_tycon tc
+        =  isFunTyCon tc
+        || isPrimTyCon tc   -- "Any" is lifted but primitive
+        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
+                            -- function application where argument has a
+                            -- type-family type
+
+   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
+   -- constructors inside it.  Then we may get a better TyCon by
+   -- grabbing the one from a constructor alternative
+   -- if one exists.
+   look_for_better_tycon
+        | ((DataAlt con, _, _) : _) <- data_alts =
+                AlgAlt (dataConTyCon con)
+        | otherwise =
+                ASSERT(null data_alts)
+                PolyAlt
+        where
+                (data_alts, _deflt) = findDefault alts
+
+-- ---------------------------------------------------------------------------
+-- 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
+    (args', ticks') <- coreToStgArgs args
+    how_bound <- lookupVarCts f
+
+    let
+        n_val_args       = valArgCount args
+
+        -- Mostly, the arity info of a function is in the fn's IdInfo
+        -- But new bindings introduced by CoreSat may not have no
+        -- arity info; it would do us no good anyway.  For example:
+        --      let f = \ab -> e in f
+        -- No point in having correct arity info for f!
+        -- Hence the hasArity stuff below.
+        -- NB: f_arity is only consulted for LetBound things
+        f_arity   = stgArity f how_bound
+        saturated = f_arity <= n_val_args
+
+        res_ty = exprType (mkApps (Var f) args)
+        app = case idDetails f of
+                DataConWorkId dc
+                  | saturated    -> StgConApp dc args'
+                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
+
+                -- Some primitive operator that might be implemented as a library call.
+                PrimOpId op      -> ASSERT( saturated )
+                                    StgOpApp (StgPrimOp op) args' res_ty
+
+                -- A call to some primitive Cmm function.
+                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
+                                          PrimCallConv _))
+                                 -> ASSERT( saturated )
+                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+                -- A regular foreign call.
+                FCallId call     -> ASSERT( saturated )
+                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+
+                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
+                _other           -> StgApp f args'
+
+        tapp = foldr StgTick app (ticks ++ ticks')
+
+    -- Forcing these fixes a leak in the code generator, noticed while
+    -- profiling for trac #4367
+    app `seq` return tapp
+
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
+
+coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
+coreToStgArgs []
+  = return ([], [])
+
+coreToStgArgs (Type _ : args) = do     -- Type argument
+    (args', ts) <- coreToStgArgs args
+    return (args', ts)
+
+coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
+  = do { (args', ts) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', ts) }
+
+coreToStgArgs (Tick t e : args)
+  = ASSERT( not (tickishIsCode t) )
+    do { (args', ts) <- coreToStgArgs (e : args)
+       ; return (args', t:ts) }
+
+coreToStgArgs (arg : args) = do         -- Non-type argument
+    (stg_args, ticks) <- coreToStgArgs args
+    arg' <- coreToStgExpr arg
+    let
+        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
+        stg_arg = case arg'' of
+                       StgApp v []        -> StgVarArg v
+                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
+                       StgLit lit         -> StgLitArg lit
+                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
+
+        -- WARNING: what if we have an argument like (v `cast` co)
+        --          where 'co' changes the representation type?
+        --          (This really only happens if co is unsafe.)
+        -- Then all the getArgAmode stuff in CgBindery will set the
+        -- cg_rep of the CgIdInfo based on the type of v, rather
+        -- than the type of 'co'.
+        -- This matters particularly when the function is a primop
+        -- or foreign call.
+        -- Wanted: a better solution than this hacky warning
+    let
+        arg_ty = exprType arg
+        stg_arg_ty = stgArgType stg_arg
+        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
+                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
+        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
+        -- we can treat an unlifted value as lifted.  But the other way round
+        -- we complain.
+        -- We also want to check if a pointer is cast to a non-ptr etc
+
+    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
+     return (stg_arg : stg_args, ticks ++ aticks)
+
+
+-- ---------------------------------------------------------------------------
+-- The magic for lets:
+-- ---------------------------------------------------------------------------
+
+coreToStgLet
+         :: CoreBind     -- bindings
+         -> CoreExpr     -- body
+         -> CtsM StgExpr -- new let
+
+coreToStgLet bind body = do
+    (bind2, body2)
+       <- do
+
+          ( bind2, env_ext)
+                <- vars_bind bind
+
+          -- Do the body
+          extendVarEnvCts env_ext $ do
+             body2 <- coreToStgExpr body
+
+             return (bind2, body2)
+
+        -- Compute the new let-expression
+    let
+        new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2
+                | otherwise       = StgLet noExtSilent bind2 body2
+
+    return new_let
+  where
+    mk_binding binder rhs
+        = (binder, LetBound NestedLet (manifestArity rhs))
+
+    vars_bind :: CoreBind
+              -> CtsM (StgBinding,
+                       [(Id, HowBound)])  -- extension to environment
+
+    vars_bind (NonRec binder rhs) = do
+        rhs2 <- coreToStgRhs (binder,rhs)
+        let
+            env_ext_item = mk_binding binder rhs
+
+        return (StgNonRec binder rhs2, [env_ext_item])
+
+    vars_bind (Rec pairs)
+      =    let
+                binders = map fst pairs
+                env_ext = [ mk_binding b rhs
+                          | (b,rhs) <- pairs ]
+           in
+           extendVarEnvCts env_ext $ do
+              rhss2 <- mapM coreToStgRhs pairs
+              return (StgRec (binders `zip` rhss2), env_ext)
+
+coreToStgRhs :: (Id,CoreExpr)
+             -> CtsM StgRhs
+
+coreToStgRhs (bndr, rhs) = do
+    new_rhs <- coreToStgExpr rhs
+    return (mkStgRhs bndr new_rhs)
+
+-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
+-- appended to `CollectedCCs` argument.
+mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
+            -> Id -> StgExpr -> (StgRhs, CollectedCCs)
+
+mkTopStgRhs dflags this_mod ccs bndr rhs
+  | StgLam bndrs body <- rhs
+  = -- StgLam can't have empty arguments, so not CAF
+    ( StgRhsClosure noExtSilent
+                    dontCareCCS
+                    ReEntrant
+                    (toList bndrs) body
+    , ccs )
+
+  | StgConApp con args _ <- unticked_rhs
+  , -- Dynamic StgConApps are updatable
+    not (isDllConApp dflags this_mod con args)
+  = -- CorePrep does this right, but just to make sure
+    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+           , ppr bndr $$ ppr con $$ ppr args)
+    ( StgRhsCon dontCareCCS con args, ccs )
+
+  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+  | gopt Opt_AutoSccsOnIndividualCafs dflags
+  = ( StgRhsClosure noExtSilent
+                    caf_ccs
+                    upd_flag [] rhs
+    , collectCC caf_cc caf_ccs ccs )
+
+  | otherwise
+  = ( StgRhsClosure noExtSilent
+                    all_cafs_ccs
+                    upd_flag [] rhs
+    , ccs )
+
+  where
+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
+
+    -- CAF cost centres generated for -fcaf-all
+    caf_cc = mkAutoCC bndr modl
+    caf_ccs = mkSingletonCCS caf_cc
+           -- careful: the binder might be :Main.main,
+           -- which doesn't belong to module mod_name.
+           -- bug #249, tests prof001, prof002
+    modl | Just m <- nameModule_maybe (idName bndr) = m
+         | otherwise = this_mod
+
+    -- default CAF cost centre
+    (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialzation plan].
+mkStgRhs :: Id -> StgExpr -> StgRhs
+mkStgRhs bndr rhs
+  | StgLam bndrs body <- rhs
+  = StgRhsClosure noExtSilent
+                  currentCCS
+                  ReEntrant
+                  (toList bndrs) body
+
+  | isJoinId bndr -- must be a nullary join point
+  = ASSERT(idJoinArity bndr == 0)
+    StgRhsClosure noExtSilent
+                  currentCCS
+                  ReEntrant -- ignored for LNE
+                  [] rhs
+
+  | StgConApp con args _ <- unticked_rhs
+  = StgRhsCon currentCCS con args
+
+  | otherwise
+  = StgRhsClosure noExtSilent
+                  currentCCS
+                  upd_flag [] rhs
+  where
+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
+
+  {-
+    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
+    well; and making these into simple non-updatable thunks breaks other
+    assumptions (namely that they will be entered only once).
+
+    upd_flag | isPAP env rhs  = ReEntrant
+             | otherwise      = Updatable
+
+-- Detect thunks which will reduce immediately to PAPs, and make them
+-- non-updatable.  This has several advantages:
+--
+--         - the non-updatable thunk behaves exactly like the PAP,
+--
+--         - the thunk is more efficient to enter, because it is
+--           specialised to the task.
+--
+--         - we save one update frame, one stg_update_PAP, one update
+--           and lots of PAP_enters.
+--
+--         - in the case where the thunk is top-level, we save building
+--           a black hole and furthermore the thunk isn't considered to
+--           be a CAF any more, so it doesn't appear in any SRTs.
+--
+-- We do it here, because the arity information is accurate, and we need
+-- to do it before the SRT pass to save the SRT entries associated with
+-- any top-level PAPs.
+
+isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
+                              where
+                                 arity = stgArity f (lookupBinding env f)
+isPAP env _               = False
+
+-}
+
+{- ToDo:
+          upd = if isOnceDem dem
+                    then (if isNotTop toplev
+                            then SingleEntry    -- HA!  Paydirt for "dem"
+                            else
+                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
+                     Updatable)
+                else Updatable
+        -- For now we forbid SingleEntry CAFs; they tickle the
+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+        -- and I don't understand why.  There's only one SE_CAF (well,
+        -- only one that tickled a great gaping bug in an earlier attempt
+        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+        -- specifically Main.lvl6 in spectral/cryptarithm2.
+        -- So no great loss.  KSW 2000-07.
+-}
+
+-- ---------------------------------------------------------------------------
+-- A monad for the core-to-STG pass
+-- ---------------------------------------------------------------------------
+
+-- There's a lot of stuff to pass around, so we use this CtsM
+-- ("core-to-STG monad") monad to help.  All the stuff here is only passed
+-- *down*.
+
+newtype CtsM a = CtsM
+    { unCtsM :: IdEnv HowBound
+             -> a
+    }
+
+data HowBound
+  = ImportBound         -- Used only as a response to lookupBinding; never
+                        -- exists in the range of the (IdEnv HowBound)
+
+  | LetBound            -- A let(rec) in this module
+        LetInfo         -- Whether top level or nested
+        Arity           -- Its arity (local Ids don't have arity info at this point)
+
+  | LambdaBound         -- Used for both lambda and case
+  deriving (Eq)
+
+data LetInfo
+  = TopLet              -- top level things
+  | NestedLet
+  deriving (Eq)
+
+-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
+-- variables that are live if x is live.  This LiveInfo comprises
+--         (a) dynamic live variables (ones with a non-top-level binding)
+--         (b) static live variabes (CAFs or things that refer to CAFs)
+--
+-- For "normal" variables (a) is just x alone.  If x is a let-no-escaped
+-- variable then x is represented by a code pointer and a stack pointer
+-- (well, one for each stack).  So all of the variables needed in the
+-- execution of x are live if x is, and are therefore recorded in the
+-- LetBound constructor; x itself *is* included.
+--
+-- The set of dynamic live variables is guaranteed ot have no further
+-- let-no-escaped variables in it.
+
+-- The std monad functions:
+
+initCts :: IdEnv HowBound -> CtsM a -> a
+initCts env m = unCtsM m env
+
+
+
+{-# INLINE thenCts #-}
+{-# INLINE returnCts #-}
+
+returnCts :: a -> CtsM a
+returnCts e = CtsM $ \_ -> e
+
+thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
+thenCts m k = CtsM $ \env
+  -> unCtsM (k (unCtsM m env)) env
+
+instance Functor CtsM where
+    fmap = liftM
+
+instance Applicative CtsM where
+    pure = returnCts
+    (<*>) = ap
+
+instance Monad CtsM where
+    (>>=)  = thenCts
+
+-- Functions specific to this monad:
+
+extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
+extendVarEnvCts ids_w_howbound expr
+   =    CtsM $   \env
+   -> unCtsM expr (extendVarEnvList env ids_w_howbound)
+
+lookupVarCts :: Id -> CtsM HowBound
+lookupVarCts v = CtsM $ \env -> lookupBinding env v
+
+lookupBinding :: IdEnv HowBound -> Id -> HowBound
+lookupBinding env v = case lookupVarEnv env v of
+                        Just xx -> xx
+                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
+
+getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
+getAllCAFsCC this_mod =
+    let
+      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+      all_cafs_cc  = mkAllCafsCC this_mod span
+      all_cafs_ccs = mkSingletonCCS all_cafs_cc
+    in
+      (all_cafs_cc, all_cafs_ccs)
+
+-- Misc.
+
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs = filter isId bndrs
+
+myCollectBinders :: Expr Var -> ([Var], Expr Var)
+myCollectBinders expr
+  = go [] expr
+  where
+    go bs (Lam b e)          = go (b:bs) e
+    go bs (Cast e _)         = go bs e
+    go bs e                  = (reverse bs, e)
+
+-- | Precondition: argument expression is an 'App', and there is a 'Var' at the
+-- head of the 'App' chain.
+myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
+myCollectArgs expr
+  = go expr [] []
+  where
+    go (Var v)          as ts = (v, as, ts)
+    go (App f a)        as ts = go f (a:as) ts
+    go (Tick t e)       as ts = ASSERT( all isTypeArg as )
+                                go e as (t:ts) -- ticks can appear in type apps
+    go (Cast e _)       as ts = go e as ts
+    go (Lam b e)        as ts
+       | isTyVar b            = go e as ts -- Note [Collect args]
+    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+
+-- Note [Collect args]
+-- ~~~~~~~~~~~~~~~~~~~
+--
+-- This big-lambda case occurred following a rather obscure eta expansion.
+-- It all seems a bit yukky to me.
+
+stgArity :: Id -> HowBound -> Arity
+stgArity _ (LetBound _ arity) = arity
+stgArity f ImportBound        = idArity f
+stgArity _ LambdaBound        = 0
diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgFVs.hs
@@ -0,0 +1,130 @@
+-- | Free variable analysis on STG terms.
+module StgFVs (
+    annTopBindingsFreeVars,
+    annBindingFreeVars
+  ) where
+
+import GhcPrelude
+
+import StgSyn
+import Id
+import VarSet
+import CoreSyn    ( Tickish(Breakpoint) )
+import Outputable
+import Util
+
+import Data.Maybe ( mapMaybe )
+
+newtype Env
+  = Env
+  { locals :: IdSet
+  }
+
+emptyEnv :: Env
+emptyEnv = Env emptyVarSet
+
+addLocals :: [Id] -> Env -> Env
+addLocals bndrs env
+  = env { locals = extendVarSetList (locals env) bndrs }
+
+-- | Annotates a top-level STG binding group with its free variables.
+annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]
+annTopBindingsFreeVars = map go
+  where
+    go (StgTopStringLit id bs) = StgTopStringLit id bs
+    go (StgTopLifted bind)
+      = StgTopLifted (annBindingFreeVars bind)
+
+-- | Annotates an STG binding with its free variables.
+annBindingFreeVars :: StgBinding -> CgStgBinding
+annBindingFreeVars = fst . binding emptyEnv emptyDVarSet
+
+boundIds :: StgBinding -> [Id]
+boundIds (StgNonRec b _) = [b]
+boundIds (StgRec pairs)  = map fst pairs
+
+-- Note [Tracking local binders]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 'locals' contains non-toplevel, non-imported binders.
+-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only
+-- places where new local binders are introduced.
+-- Why do it there rather than in 'binding'? Two reasons:
+--
+--   1. We call 'binding' from 'annTopBindingsFreeVars', which would
+--      add top-level bindings to the 'locals' set.
+--   2. In the let(-no-escape) case, we need to extend the environment
+--      prior to analysing the body, but we also need the fvs from the
+--      body to analyse the RHSs. No way to do this without some
+--      knot-tying.
+
+-- | This makes sure that only local, non-global free vars make it into the set.
+mkFreeVarSet :: Env -> [Id] -> DIdSet
+mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)
+
+args :: Env -> [StgArg] -> DIdSet
+args env = mkFreeVarSet env . mapMaybe f
+  where
+    f (StgVarArg occ) = Just occ
+    f _               = Nothing
+
+binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)
+binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
+  where
+    -- See Note [Tacking local binders]
+    (r', rhs_fvs) = rhs env r
+    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs
+binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)
+  where
+    -- See Note [Tacking local binders]
+    bndrs = map fst pairs
+    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs
+    pairs' = zip bndrs rhss
+    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs
+
+expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)
+expr env = go
+  where
+    go (StgApp occ as)
+      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))
+    go (StgLit lit) = (StgLit lit, emptyDVarSet)
+    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)
+    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)
+    go StgLam{} = pprPanic "StgFVs: StgLam" empty
+    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
+      where
+        (scrut', scrut_fvs) = go scrut
+        -- See Note [Tacking local binders]
+        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts
+        alt_fvs = unionDVarSets alt_fvss
+        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr
+    go (StgLet ext bind body) = go_bind (StgLet ext) bind body
+    go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body
+    go (StgTick tick e) = (StgTick tick e', fvs')
+      where
+        (e', fvs) = go e
+        fvs' = unionDVarSet (tickish tick) fvs
+        tickish (Breakpoint _ ids) = mkDVarSet ids
+        tickish _                  = emptyDVarSet
+
+    go_bind dc bind body = (dc bind' body', fvs)
+      where
+        -- See Note [Tacking local binders]
+        env' = addLocals (boundIds bind) env
+        (body', body_fvs) = expr env' body
+        (bind', fvs) = binding env' body_fvs bind
+
+rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)
+rhs env (StgRhsClosure _ ccs uf bndrs body)
+  = (StgRhsClosure fvs ccs uf bndrs body', fvs)
+  where
+    -- See Note [Tacking local binders]
+    (body', body_fvs) = expr (addLocals bndrs env) body
+    fvs = delDVarSetList body_fvs bndrs
+rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)
+
+alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)
+alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
+  where
+    -- See Note [Tacking local binders]
+    (e', rhs_fvs) = expr (addLocals bndrs env) e
+    fvs = delDVarSetList rhs_fvs bndrs
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgLint.hs
@@ -0,0 +1,397 @@
+{- |
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+A lint pass to check basic STG invariants:
+
+- Variables should be defined before used.
+
+- Let bindings should not have unboxed types (unboxed bindings should only
+  appear in case), except when they're join points (see Note [CoreSyn let/app
+  invariant] and #14117).
+
+- If linting after unarisation, invariants listed in Note [Post-unarisation
+  invariants].
+
+Because we don't have types and coercions in STG we can't really check types
+here.
+
+Some history:
+
+StgLint used to check types, but it never worked and so it was disabled in 2000
+with this note:
+
+    WARNING:
+    ~~~~~~~~
+
+    This module has suffered bit-rot; it is likely to yield lint errors
+    for Stg code that is currently perfectly acceptable for code
+    generation.  Solution: don't use it!  (KSW 2000-05).
+
+Since then there were some attempts at enabling it again, as summarised in
+#14787. It's finally decided that we remove all type checking and only look for
+basic properties listed above.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}
+
+module StgLint ( lintStgTopBindings ) where
+
+import GhcPrelude
+
+import StgSyn
+
+import DynFlags
+import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+import BasicTypes       ( TopLevelFlag(..), isTopLevel )
+import CostCentre       ( isCurrentCCS )
+import Id               ( Id, idType, isJoinId, idName )
+import VarSet
+import DataCon
+import CoreSyn          ( AltCon(..) )
+import Name             ( getSrcLoc, nameIsLocalOrFrom )
+import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
+import Type
+import RepType
+import SrcLoc
+import Outputable
+import Module           ( Module )
+import qualified ErrUtils as Err
+import Control.Applicative ((<|>))
+import Control.Monad
+
+lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
+                   => DynFlags
+                   -> Module -- ^ module being compiled
+                   -> Bool   -- ^ have we run Unarise yet?
+                   -> String -- ^ who produced the STG?
+                   -> [GenStgTopBinding a]
+                   -> IO ()
+
+lintStgTopBindings dflags this_mod unarised whodunnit binds
+  = {-# SCC "StgLint" #-}
+    case initL this_mod unarised top_level_binds (lint_binds binds) of
+      Nothing  ->
+        return ()
+      Just msg -> do
+        putLogMsg dflags NoReason Err.SevDump noSrcSpan
+          (defaultDumpStyle dflags)
+          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
+                        text whodunnit <+> text "***",
+                  msg,
+                  text "*** Offending Program ***",
+                  pprGenStgTopBindings binds,
+                  text "*** End of Offense ***"])
+        Err.ghcExit dflags 1
+  where
+    -- Bring all top-level binds into scope because CoreToStg does not generate
+    -- bindings in dependency order (so we may see a use before its definition).
+    top_level_binds = mkVarSet (bindersOfTopBinds binds)
+
+    lint_binds :: [GenStgTopBinding a] -> LintM ()
+
+    lint_binds [] = return ()
+    lint_binds (bind:binds) = do
+        binders <- lint_bind bind
+        addInScopeVars binders $
+            lint_binds binds
+
+    lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
+    lint_bind (StgTopStringLit v _) = return [v]
+
+lintStgArg :: StgArg -> LintM ()
+lintStgArg (StgLitArg _) = return ()
+lintStgArg (StgVarArg v) = lintStgVar v
+
+lintStgVar :: Id -> LintM ()
+lintStgVar id = checkInScope id
+
+lintStgBinds
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
+lintStgBinds top_lvl (StgNonRec binder rhs) = do
+    lint_binds_help top_lvl (binder,rhs)
+    return [binder]
+
+lintStgBinds top_lvl (StgRec pairs)
+  = addInScopeVars binders $ do
+        mapM_ (lint_binds_help top_lvl) pairs
+        return binders
+  where
+    binders = [b | (b,_) <- pairs]
+
+lint_binds_help
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag
+    -> (Id, GenStgRhs a)
+    -> LintM ()
+lint_binds_help top_lvl (binder, rhs)
+  = addLoc (RhsOf binder) $ do
+        when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
+        lintStgRhs rhs
+        -- Check binder doesn't have unlifted type or it's a join point
+        checkL (isJoinId binder || not (isUnliftedType (idType binder)))
+               (mkUnliftedTyMsg binder rhs)
+
+-- | Top-level bindings can't inherit the cost centre stack from their
+-- (static) allocation site.
+checkNoCurrentCCS
+    :: (OutputablePass a, BinderP a ~ Id)
+    => GenStgRhs a
+    -> LintM ()
+checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
+  | isCurrentCCS ccs
+  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
+  | isCurrentCCS ccs
+  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS _
+  = return ()
+
+lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
+
+lintStgRhs (StgRhsClosure _ _ _ [] expr)
+  = lintStgExpr expr
+
+lintStgRhs (StgRhsClosure _ _ _ binders expr)
+  = addLoc (LambdaBodyOf binders) $
+      addInScopeVars binders $
+        lintStgExpr expr
+
+lintStgRhs rhs@(StgRhsCon _ con args) = do
+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $
+      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
+               ppr rhs)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
+
+lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
+
+lintStgExpr (StgLit _) = return ()
+
+lintStgExpr (StgApp fun args) = do
+    lintStgVar fun
+    mapM_ lintStgArg args
+
+lintStgExpr app@(StgConApp con args _arg_tys) = do
+    -- unboxed sums should vanish during unarise
+    lf <- getLintFlags
+    when (lf_unarised lf && isUnboxedSumCon con) $
+      addErrL (text "Unboxed sum after unarise:" $$
+               ppr app)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
+
+lintStgExpr (StgOpApp _ args _) =
+    mapM_ lintStgArg args
+
+lintStgExpr lam@(StgLam _ _) =
+    addErrL (text "Unexpected StgLam" <+> ppr lam)
+
+lintStgExpr (StgLet _ binds body) = do
+    binders <- lintStgBinds NotTopLevel binds
+    addLoc (BodyOfLetRec binders) $
+      addInScopeVars binders $
+        lintStgExpr body
+
+lintStgExpr (StgLetNoEscape _ binds body) = do
+    binders <- lintStgBinds NotTopLevel binds
+    addLoc (BodyOfLetRec binders) $
+      addInScopeVars binders $
+        lintStgExpr body
+
+lintStgExpr (StgTick _ expr) = lintStgExpr expr
+
+lintStgExpr (StgCase scrut bndr alts_type alts) = do
+    lintStgExpr scrut
+
+    lf <- getLintFlags
+    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
+
+    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
+
+lintAlt
+    :: (OutputablePass a, BinderP a ~ Id)
+    => (AltCon, [Id], GenStgExpr a) -> LintM ()
+
+lintAlt (DEFAULT, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (LitAlt _, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (DataAlt _, bndrs, rhs) = do
+    mapM_ checkPostUnariseBndr bndrs
+    addInScopeVars bndrs (lintStgExpr rhs)
+
+{-
+************************************************************************
+*                                                                      *
+Utilities
+*                                                                      *
+************************************************************************
+-}
+
+bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
+bindersOf (StgNonRec binder _) = [binder]
+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]
+
+bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
+bindersOfTop (StgTopLifted bind) = bindersOf bind
+bindersOfTop (StgTopStringLit binder _) = [binder]
+
+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
+bindersOfTopBinds = foldr ((++) . bindersOfTop) []
+
+{-
+************************************************************************
+*                                                                      *
+The Lint monad
+*                                                                      *
+************************************************************************
+-}
+
+newtype LintM a = LintM
+    { unLintM :: Module
+              -> LintFlags
+              -> [LintLocInfo]     -- Locations
+              -> IdSet             -- Local vars in scope
+              -> Bag MsgDoc        -- Error messages so far
+              -> (a, Bag MsgDoc)   -- Result and error messages (if any)
+    }
+
+data LintFlags = LintFlags { lf_unarised :: !Bool
+                             -- ^ have we run the unariser yet?
+                           }
+
+data LintLocInfo
+  = RhsOf Id            -- The variable bound
+  | LambdaBodyOf [Id]   -- The lambda-binder
+  | BodyOfLetRec [Id]   -- One of the binders
+
+dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
+dumpLoc (RhsOf v) =
+  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
+dumpLoc (LambdaBodyOf bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
+
+dumpLoc (BodyOfLetRec bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
+
+
+pp_binders :: [Id] -> SDoc
+pp_binders bs
+  = sep (punctuate comma (map pp_binder bs))
+  where
+    pp_binder b
+      = hsep [ppr b, dcolon, ppr (idType b)]
+
+initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
+initL this_mod unarised locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
+  if isEmptyBag errs then
+      Nothing
+  else
+      Just (vcat (punctuate blankLine (bagToList errs)))
+
+instance Functor LintM where
+      fmap = liftM
+
+instance Applicative LintM where
+      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
+      (<*>) = ap
+      (*>)  = thenL_
+
+instance Monad LintM where
+    (>>=) = thenL
+    (>>)  = (*>)
+
+thenL :: LintM a -> (a -> LintM b) -> LintM b
+thenL m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf loc scope errs'
+
+thenL_ :: LintM a -> LintM b -> LintM b
+thenL_ m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (_, errs') -> unLintM k mod lf loc scope errs'
+
+checkL :: Bool -> MsgDoc -> LintM ()
+checkL True  _   = return ()
+checkL False msg = addErrL msg
+
+-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
+checkPostUnariseBndr :: Id -> LintM ()
+checkPostUnariseBndr bndr = do
+    lf <- getLintFlags
+    when (lf_unarised lf) $
+      forM_ (checkPostUnariseId bndr) $ \unexpected ->
+        addErrL $
+          text "After unarisation, binder " <>
+          ppr bndr <> text " has " <> text unexpected <> text " type " <>
+          ppr (idType bndr)
+
+-- Arguments shouldn't have sum, tuple, or void types.
+checkPostUnariseConArg :: StgArg -> LintM ()
+checkPostUnariseConArg arg = case arg of
+    StgLitArg _ ->
+      return ()
+    StgVarArg id -> do
+      lf <- getLintFlags
+      when (lf_unarised lf) $
+        forM_ (checkPostUnariseId id) $ \unexpected ->
+          addErrL $
+            text "After unarisation, arg " <>
+            ppr id <> text " has " <> text unexpected <> text " type " <>
+            ppr (idType id)
+
+-- Post-unarisation args and case alt binders should not have unboxed tuple,
+-- unboxed sum, or void types. Return what the binder is if it is one of these.
+checkPostUnariseId :: Id -> Maybe String
+checkPostUnariseId id =
+    let
+      id_ty = idType id
+      is_sum, is_tuple, is_void :: Maybe String
+      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
+      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
+      is_void = guard (isVoidTy id_ty) >> return "void"
+    in
+      is_sum <|> is_tuple <|> is_void
+
+addErrL :: MsgDoc -> LintM ()
+addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
+
+addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
+addErr errs_so_far msg locs
+  = errs_so_far `snocBag` mk_msg locs
+  where
+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
+                     in  mkLocMessage SevWarning l (hdr $$ msg)
+    mk_msg []      = msg
+
+addLoc :: LintLocInfo -> LintM a -> LintM a
+addLoc extra_loc m = LintM $ \mod lf loc scope errs
+   -> unLintM m mod lf (extra_loc:loc) scope errs
+
+addInScopeVars :: [Id] -> LintM a -> LintM a
+addInScopeVars ids m = LintM $ \mod lf loc scope errs
+ -> let
+        new_set = mkVarSet ids
+    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
+
+checkInScope :: Id -> LintM ()
+checkInScope id = LintM $ \mod _lf loc scope errs
+ -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
+        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
+                                text "is out of scope"]) loc)
+    else
+        ((), errs)
+
+mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
+mkUnliftedTyMsg binder rhs
+  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
+     text "has unlifted type" <+> quotes (ppr (idType binder)))
+    $$
+    (text "RHS:" <+> ppr rhs)
diff --git a/compiler/stgSyn/StgSubst.hs b/compiler/stgSyn/StgSubst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgSubst.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP #-}
+
+module StgSubst where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Id
+import VarEnv
+import Control.Monad.Trans.State.Strict
+import Outputable
+import Util
+
+-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not
+-- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but
+-- with the domain being 'Id's instead of entire 'CoreExpr'.
+data Subst = Subst InScopeSet IdSubstEnv
+
+type IdSubstEnv = IdEnv Id
+
+-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@
+emptySubst :: Subst
+emptySubst = mkEmptySubst emptyInScopeSet
+
+-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet'
+-- are in scope.
+mkEmptySubst :: InScopeSet -> Subst
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv
+
+-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way
+-- that avoids shadowing the 'InScopeSet', returning the result and an updated
+-- 'Subst' that should be used by subsequent substitutions.
+substBndr :: Id -> Subst -> (Id, Subst)
+substBndr id (Subst in_scope env)
+  = (new_id, Subst new_in_scope new_env)
+  where
+    new_id = uniqAway in_scope id
+    no_change = new_id == id -- in case nothing shadowed
+    new_in_scope = in_scope `extendInScopeSet` new_id
+    new_env
+      | no_change = delVarEnv env id
+      | otherwise = extendVarEnv env id new_id
+
+-- | @substBndrs = runState . traverse (state . substBndr)@
+substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst)
+substBndrs = runState . traverse (state . substBndr)
+
+-- | Substitutes an occurrence of an identifier for its counterpart recorded
+-- in the 'Subst'.
+lookupIdSubst :: HasCallStack => Id -> Subst -> Id
+lookupIdSubst id (Subst in_scope env)
+  | not (isLocalId id) = id
+  | Just id' <- lookupVarEnv env id = id'
+  | Just id' <- lookupInScope in_scope id = id'
+  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)
+                id
+
+-- | Substitutes an occurrence of an identifier for its counterpart recorded
+-- in the 'Subst'. Does not generate a debug warning if the identifier to
+-- to substitute wasn't in scope.
+noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
+noWarnLookupIdSubst id (Subst in_scope env)
+  | not (isLocalId id) = id
+  | Just id' <- lookupVarEnv env id = id'
+  | Just id' <- lookupInScope in_scope id = id'
+  | otherwise = id
+
+-- | Add the 'Id' to the in-scope set and remove any existing substitutions for
+-- it.
+extendInScope :: Id -> Subst -> Subst
+extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env
+
+-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the
+-- in-scope set is such that TyCORep Note [The substitution invariant]
+-- holds after extending the substitution like this.
+extendSubst :: Id -> Id -> Subst -> Subst
+extendSubst id new_id (Subst in_scope env)
+  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )
+    Subst in_scope (extendVarEnv env id new_id)
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgSyn.hs
@@ -0,0 +1,892 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[StgSyn]{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
+being one that happens to be ideally suited to spineless tagless code
+generation.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module StgSyn (
+        StgArg(..),
+
+        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
+        GenStgAlt, AltType(..),
+
+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
+        NoExtSilent, noExtSilent,
+        OutputablePass,
+
+        UpdateFlag(..), isUpdatable,
+
+        -- a set of synonyms for the vanilla parameterisation
+        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
+
+        -- a set of synonyms for the code gen parameterisation
+        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,
+
+        -- a set of synonyms for the lambda lifting parameterisation
+        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,
+
+        -- a set of synonyms to distinguish in- and out variants
+        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
+        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
+
+        -- StgOp
+        StgOp(..),
+
+        -- utils
+        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
+        isDllConApp,
+        stgArgType,
+        stripStgTicksTop,
+        stgCaseBndrInScope,
+
+        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn     ( AltCon, Tickish )
+import CostCentre  ( CostCentreStack )
+import Data.ByteString ( ByteString )
+import Data.Data   ( Data )
+import Data.List   ( intersperse )
+import DataCon
+import DynFlags
+import FastString
+import ForeignCall ( ForeignCall )
+import Id
+import IdInfo      ( mayHaveCafRefs )
+import VarSet
+import Literal     ( Literal, literalType )
+import Module      ( Module )
+import Outputable
+import Packages    ( isDllName )
+import Platform
+import PprCore     ( {- instances -} )
+import PrimOp      ( PrimOp, PrimCall )
+import TyCon       ( PrimRep(..), TyCon )
+import Type        ( Type )
+import RepType     ( typePrimRep1 )
+import Unique      ( Unique )
+import Util
+
+import Data.List.NonEmpty ( NonEmpty, toList )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{@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@):
+-}
+
+-- | A top-level binding.
+data GenStgTopBinding pass
+-- See Note [CoreSyn top-level string literals]
+  = StgTopLifted (GenStgBinding pass)
+  | StgTopStringLit Id ByteString
+
+data GenStgBinding pass
+  = StgNonRec (BinderP pass) (GenStgRhs pass)
+  | StgRec    [(BinderP pass, GenStgRhs pass)]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{@StgArg@}
+*                                                                      *
+************************************************************************
+-}
+
+data StgArg
+  = StgVarArg  Id
+  | StgLitArg  Literal
+
+-- | 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
+ | platformOS (targetPlatform dflags) == OSMinGW32
+    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args
+ | otherwise = False
+  where
+    -- NB: typePrimRep1 is legit because any free variables won't have
+    -- unlifted type (there are no unlifted things at top level)
+    is_dll_arg :: StgArg -> Bool
+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
+                             && 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
+--    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
+isAddrRep LiftedRep   = True
+isAddrRep UnliftedRep = True
+isAddrRep _           = False
+
+-- | Type of an @StgArg@
+--
+-- Very half baked because we have lost the type arguments.
+stgArgType :: StgArg -> Type
+stgArgType (StgVarArg v)   = idType v
+stgArgType (StgLitArg lit) = literalType lit
+
+
+-- | Strip ticks of a given type from an STG expression
+stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
+stripStgTicksTop p = go []
+   where go ts (StgTick t e) | p t = go (t:ts) e
+         go ts other               = (reverse ts, other)
+
+-- | Given an alt type and whether the program is unarised, return whether the
+-- case binder is in scope.
+--
+-- Case binders of unboxed tuple or unboxed sum type always dead after the
+-- unariser has run. See Note [Post-unarisation invariants].
+stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
+stgCaseBndrInScope alt_ty unarised =
+    case alt_ty of
+      AlgAlt _      -> True
+      PrimAlt _     -> True
+      MultiValAlt _ -> not unarised
+      PolyAlt       -> True
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{STG expressions}
+*                                                                      *
+************************************************************************
+
+The @GenStgExpr@ data type is parameterised on binder and occurrence
+info, as before.
+
+************************************************************************
+*                                                                      *
+\subsubsection{@GenStgExpr@ application}
+*                                                                      *
+************************************************************************
+
+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 []@.
+-}
+
+data GenStgExpr pass
+  = StgApp
+        Id       -- function
+        [StgArg] -- arguments; may be empty
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
+*                                                                      *
+************************************************************************
+
+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
+  | StgConApp   DataCon
+                [StgArg] -- Saturated
+                [Type]   -- See Note [Types in StgConApp] in UnariseStg
+
+  | StgOpApp    StgOp    -- Primitive op or foreign call
+                [StgArg] -- Saturated.
+                Type     -- Result type
+                         -- We need to know this so that we can
+                         -- assign result registers
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@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
+        (NonEmpty (BinderP pass))
+        StgExpr    -- Body of lambda
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@GenStgExpr@: case-expressions}
+*                                                                      *
+************************************************************************
+
+This has the same boxed/unboxed business as Core case expressions.
+-}
+
+  | StgCase
+        (GenStgExpr pass) -- the thing to examine
+        (BinderP pass) -- binds the result of evaluating the scrutinee
+        AltType
+        [GenStgAlt pass]
+                    -- The DEFAULT case is always *first*
+                    -- if it is there at all
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@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.
+
+(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
+
+\item
+\begin{verbatim}
+let-constructor x = Constructor [args]
+in e
+\end{verbatim}
+
+(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
+
+\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.
+
+\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!
+
+(We've backed away from this toward case-expressions with
+suitably-magical alts ...)
+
+\item
+~[Advanced stuff here! Not to start with, but makes pattern matching
+generate more efficient code.]
+
+\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.
+
+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-escapes-not is an @StgLetNoEscape@.)
+
+\item
+We may eventually want:
+\begin{verbatim}
+let-literal x = Literal
+in e
+\end{verbatim}
+\end{enumerate}
+
+And so the code for let(rec)-things:
+-}
+
+  | StgLet
+        (XLet pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
+
+  | StgLetNoEscape
+        (XLetNoEscape pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
+
+{-
+%************************************************************************
+%*                                                                      *
+\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
+%*                                                                      *
+%************************************************************************
+
+Finally for @hpc@ expressions we introduce a new STG construct.
+-}
+
+  | StgTick
+    (Tickish Id)
+    (GenStgExpr pass)       -- sub expression
+
+-- END of GenStgExpr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{STG right-hand sides}
+*                                                                      *
+************************************************************************
+
+Here's the rest of the interesting stuff for @StgLet@s; the first
+flavour is for closures:
+-}
+
+data GenStgRhs pass
+  = StgRhsClosure
+        (XRhsClosure pass) -- ^ Extension point for non-global free var
+                           --   list just before 'CodeGen'.
+        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)
+        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'
+        [BinderP pass]     -- ^ arguments; if empty, then not a function;
+                           --   as above, order is important.
+        (GenStgExpr pass)  -- ^ body
+
+{-
+An example may be in order.  Consider:
+\begin{verbatim}
+let t = \x -> \y -> ... x ... y ... p ... q in e
+\end{verbatim}
+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):
+-}
+
+  | StgRhsCon
+        CostCentreStack -- CCS to be attached (default is CurrentCCS).
+                        -- Top-level (static) ones will end up with
+                        -- DontCareCCS, because we don't count static
+                        -- data in heap profiles, and we don't set CCCS
+                        -- from static closure.
+        DataCon         -- Constructor. Never an unboxed tuple or sum, as those
+                        -- are not allocated.
+        [StgArg]        -- Args
+
+-- | Used as a data type index for the stgSyn AST
+data StgPass
+  = Vanilla
+  | LiftLams
+  | CodeGen
+
+-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns
+-- 'empty'.
+data NoExtSilent = NoExtSilent
+  deriving (Data, Eq, Ord)
+
+instance Outputable NoExtSilent where
+  ppr _ = empty
+
+-- | Used when constructing a term with an unused extension point that should
+-- not appear in pretty-printed output at all.
+noExtSilent :: NoExtSilent
+noExtSilent = NoExtSilent
+-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications
+-- on build time...
+
+-- TODO: Do we really want to the extension point type families to have a closed
+-- domain?
+type family BinderP (pass :: StgPass)
+type instance BinderP 'Vanilla = Id
+type instance BinderP 'CodeGen = Id
+
+type family XRhsClosure (pass :: StgPass)
+type instance XRhsClosure 'Vanilla = NoExtSilent
+-- | Code gen needs to track non-global free vars
+type instance XRhsClosure 'CodeGen = DIdSet
+
+type family XLet (pass :: StgPass)
+type instance XLet 'Vanilla = NoExtSilent
+type instance XLet 'CodeGen = NoExtSilent
+
+type family XLetNoEscape (pass :: StgPass)
+type instance XLetNoEscape 'Vanilla = NoExtSilent
+type instance XLetNoEscape 'CodeGen = NoExtSilent
+
+stgRhsArity :: StgRhs -> Int
+stgRhsArity (StgRhsClosure _ _ _ bndrs _)
+  = ASSERT( all isId bndrs ) length bndrs
+  -- The arity never includes type parameters, but they should have gone by now
+stgRhsArity (StgRhsCon _ _ _) = 0
+
+-- Note [CAF consistency]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
+-- reality.
+--
+-- Specifically, if the RHS mentions any Id that itself is marked
+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
+-- have taken place since then.
+
+topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
+topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
+  = topRhsHasCafRefs rhs
+topStgBindHasCafRefs (StgTopLifted (StgRec binds))
+  = any topRhsHasCafRefs (map snd binds)
+topStgBindHasCafRefs StgTopStringLit{}
+  = False
+
+topRhsHasCafRefs :: GenStgRhs pass -> Bool
+topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
+  = -- See Note [CAF consistency]
+    isUpdatable upd || exprHasCafRefs body
+topRhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+exprHasCafRefs :: GenStgExpr pass -> Bool
+exprHasCafRefs (StgApp f args)
+  = stgIdHasCafRefs f || any stgArgHasCafRefs args
+exprHasCafRefs StgLit{}
+  = False
+exprHasCafRefs (StgConApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgOpApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgLam _ body)
+  = exprHasCafRefs body
+exprHasCafRefs (StgCase scrt _ _ alts)
+  = exprHasCafRefs scrt || any altHasCafRefs alts
+exprHasCafRefs (StgLet _ bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgLetNoEscape _ bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgTick _ expr)
+  = exprHasCafRefs expr
+
+bindHasCafRefs :: GenStgBinding pass -> Bool
+bindHasCafRefs (StgNonRec _ rhs)
+  = rhsHasCafRefs rhs
+bindHasCafRefs (StgRec binds)
+  = any rhsHasCafRefs (map snd binds)
+
+rhsHasCafRefs :: GenStgRhs pass -> Bool
+rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
+  = exprHasCafRefs body
+rhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+altHasCafRefs :: GenStgAlt pass -> Bool
+altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
+
+stgArgHasCafRefs :: StgArg -> Bool
+stgArgHasCafRefs (StgVarArg id)
+  = stgIdHasCafRefs id
+stgArgHasCafRefs _
+  = False
+
+stgIdHasCafRefs :: Id -> Bool
+stgIdHasCafRefs id =
+  -- We are looking for occurrences of an Id that is bound at top level, and may
+  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
+  -- imported or defined in this module) are GlobalIds, so the test is easy.
+  isGlobalId id && mayHaveCafRefs (idCafInfo id)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[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.
+-}
+
+type GenStgAlt pass
+  = (AltCon,          -- alts: data constructor,
+     [BinderP pass],  -- constructor's parameters,
+     GenStgExpr pass) -- ...right-hand side.
+
+data AltType
+  = PolyAlt             -- Polymorphic (a lifted type variable)
+  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
+                        -- the arity could indeed be 1 for unary unboxed tuple
+                        -- or enum-like unboxed sums
+  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
+  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[Stg]{The Plain STG parameterisation}
+*                                                                      *
+************************************************************************
+
+This happens to be the only one we use at the moment.
+-}
+
+type StgTopBinding = GenStgTopBinding 'Vanilla
+type StgBinding    = GenStgBinding    'Vanilla
+type StgExpr       = GenStgExpr       'Vanilla
+type StgRhs        = GenStgRhs        'Vanilla
+type StgAlt        = GenStgAlt        'Vanilla
+
+type LlStgTopBinding = GenStgTopBinding 'LiftLams
+type LlStgBinding    = GenStgBinding    'LiftLams
+type LlStgExpr       = GenStgExpr       'LiftLams
+type LlStgRhs        = GenStgRhs        'LiftLams
+type LlStgAlt        = GenStgAlt        'LiftLams
+
+type CgStgTopBinding = GenStgTopBinding 'CodeGen
+type CgStgBinding    = GenStgBinding    'CodeGen
+type CgStgExpr       = GenStgExpr       'CodeGen
+type CgStgRhs        = GenStgRhs        'CodeGen
+type CgStgAlt        = GenStgAlt        'CodeGen
+
+{- Many passes apply a substitution, and it's very handy to have type
+   synonyms to remind us whether or not the substitution has been applied.
+   See CoreSyn for precedence in Core land
+-}
+
+type InStgTopBinding  = StgTopBinding
+type InStgBinding     = StgBinding
+type InStgArg         = StgArg
+type InStgExpr        = StgExpr
+type InStgRhs         = StgRhs
+type InStgAlt         = StgAlt
+type OutStgTopBinding = StgTopBinding
+type OutStgBinding    = StgBinding
+type OutStgArg        = StgArg
+type OutStgExpr       = StgExpr
+type OutStgRhs        = StgRhs
+type OutStgAlt        = StgAlt
+
+{-
+
+************************************************************************
+*                                                                      *
+\subsubsection[UpdateFlag-datatype]{@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.
+-}
+
+data UpdateFlag = ReEntrant | Updatable | SingleEntry
+
+instance Outputable UpdateFlag where
+    ppr u = char $ case u of
+                       ReEntrant   -> 'r'
+                       Updatable   -> 'u'
+                       SingleEntry -> 's'
+
+isUpdatable :: UpdateFlag -> Bool
+isUpdatable ReEntrant   = False
+isUpdatable SingleEntry = False
+isUpdatable Updatable   = True
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{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.
+-}
+
+data StgOp
+  = StgPrimOp  PrimOp
+
+  | StgPrimCallOp PrimCall
+
+  | StgFCallOp ForeignCall Unique
+        -- The Unique is occasionally needed by the C pretty-printer
+        -- (which lacks a unique supply), notably when generating a
+        -- typedef for foreign-export-dynamic
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[Stg-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.
+-}
+
+type OutputablePass pass =
+  ( Outputable (XLet pass)
+  , Outputable (XLetNoEscape pass)
+  , Outputable (XRhsClosure pass)
+  , OutputableBndr (BinderP pass)
+  )
+
+pprGenStgTopBinding
+  :: OutputablePass pass => GenStgTopBinding pass -> SDoc
+pprGenStgTopBinding (StgTopStringLit bndr str)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (pprHsBytes str <> semi)
+pprGenStgTopBinding (StgTopLifted bind)
+  = pprGenStgBinding bind
+
+pprGenStgBinding
+  :: OutputablePass pass => GenStgBinding pass -> SDoc
+
+pprGenStgBinding (StgNonRec bndr rhs)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (ppr rhs <> semi)
+
+pprGenStgBinding (StgRec pairs)
+  = vcat [ text "Rec {"
+         , vcat (map ppr_bind pairs)
+         , text "end Rec }" ]
+  where
+    ppr_bind (bndr, expr)
+      = hang (hsep [pprBndr LetBind bndr, equals])
+             4 (ppr expr <> semi)
+
+pprGenStgTopBindings
+  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
+pprGenStgTopBindings binds
+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+
+pprStgBinding :: StgBinding -> SDoc
+pprStgBinding = pprGenStgBinding
+
+pprStgTopBindings :: [StgTopBinding] -> SDoc
+pprStgTopBindings = pprGenStgTopBindings
+
+instance Outputable StgArg where
+    ppr = pprStgArg
+
+instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
+    ppr = pprGenStgTopBinding
+
+instance OutputablePass pass => Outputable (GenStgBinding pass) where
+    ppr = pprGenStgBinding
+
+instance OutputablePass pass => Outputable (GenStgExpr pass) where
+    ppr = pprStgExpr
+
+instance OutputablePass pass => Outputable (GenStgRhs pass) where
+    ppr rhs = pprStgRhs rhs
+
+pprStgArg :: StgArg -> SDoc
+pprStgArg (StgVarArg var) = ppr var
+pprStgArg (StgLitArg con) = ppr con
+
+pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
+-- special case
+pprStgExpr (StgLit lit)     = ppr lit
+
+-- general case
+pprStgExpr (StgApp func args)
+  = hang (ppr func) 4 (sep (map (ppr) args))
+
+pprStgExpr (StgConApp con args _)
+  = hsep [ ppr con, brackets (interppSP args) ]
+
+pprStgExpr (StgOpApp op args _)
+  = hsep [ pprStgOp op, brackets (interppSP args)]
+
+pprStgExpr (StgLam bndrs body)
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
+            <+> text "->",
+         pprStgExpr body ]
+  where ppr_list = brackets . fsep . punctuate comma
+
+-- special case: let v = <very specific thing>
+--               in
+--               let ...
+--               in
+--               ...
+--
+-- Very special!  Suspicious! (SLPJ)
+
+{-
+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+                        expr@(StgLet _ _))
+  = ($$)
+      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
+                          ppr cc,
+                          pp_binder_info bi,
+                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),
+                          ppr upd_flag, text " [",
+                          interppSP args, char ']'])
+            8 (sep [hsep [ppr rhs, text "} in"]]))
+      (ppr expr)
+-}
+
+-- special case: let ... in let ...
+
+pprStgExpr (StgLet ext bind expr@StgLet{})
+  = ($$)
+      (sep [hang (text "let" <+> ppr ext <+> text "{")
+                2 (hsep [pprGenStgBinding bind, text "} in"])])
+      (ppr expr)
+
+-- general case
+pprStgExpr (StgLet ext bind expr)
+  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),
+           hang (text "} in ") 2 (ppr expr)]
+
+pprStgExpr (StgLetNoEscape ext bind expr)
+  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")
+                2 (pprGenStgBinding bind),
+           hang (text "} in ")
+                2 (ppr expr)]
+
+pprStgExpr (StgTick tickish expr)
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_SuppressTicks dflags
+    then pprStgExpr expr
+    else sep [ ppr tickish, pprStgExpr expr ]
+
+
+-- Don't indent for a single case alternative.
+pprStgExpr (StgCase expr bndr alt_type [alt])
+  = sep [sep [text "case",
+           nest 4 (hsep [pprStgExpr expr,
+             whenPprDebug (dcolon <+> ppr alt_type)]),
+           text "of", pprBndr CaseBind bndr, char '{'],
+           pprStgAlt False alt,
+           char '}']
+
+pprStgExpr (StgCase expr bndr alt_type alts)
+  = sep [sep [text "case",
+           nest 4 (hsep [pprStgExpr expr,
+             whenPprDebug (dcolon <+> ppr alt_type)]),
+           text "of", pprBndr CaseBind bndr, char '{'],
+           nest 2 (vcat (map (pprStgAlt True) alts)),
+           char '}']
+
+
+pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
+pprStgAlt indent (con, params, expr)
+  | indent    = hang altPattern 4 (ppr expr <> semi)
+  | otherwise = sep [altPattern, ppr expr <> semi]
+    where
+      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+
+
+pprStgOp :: StgOp -> SDoc
+pprStgOp (StgPrimOp  op)   = ppr op
+pprStgOp (StgPrimCallOp op)= ppr op
+pprStgOp (StgFCallOp op _) = ppr op
+
+instance Outputable AltType where
+  ppr PolyAlt         = text "Polymorphic"
+  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n
+  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
+  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
+
+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,
+                if not $ gopt Opt_SuppressStgExts dflags
+                  then ppr ext else empty,
+                char '\\' <> ppr upd_flag, brackets (interppSP args)])
+         4 (ppr body)
+
+pprStgRhs (StgRhsCon cc con args)
+  = hcat [ ppr cc,
+           space, ppr con, text "! ", brackets (interppSP args)]
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stranal/DmdAnal.hs
@@ -0,0 +1,1571 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+
+                        -----------------
+                        A demand analysis
+                        -----------------
+-}
+
+{-# LANGUAGE CPP #-}
+
+module DmdAnal ( dmdAnalProgram ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import WwLib            ( findTypeShape, deepSplitProductType_maybe )
+import Demand   -- All of it
+import CoreSyn
+import CoreSeq          ( seqBinds )
+import Outputable
+import VarEnv
+import BasicTypes
+import Data.List
+import DataCon
+import Id
+import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )
+import TyCon
+import Type
+import Coercion         ( Coercion, coVarsOfCo )
+import FamInstEnv
+import Util
+import Maybes           ( isJust )
+import TysWiredIn
+import TysPrim          ( realWorldStatePrimTy )
+import ErrUtils         ( dumpIfSet_dyn )
+import Name             ( getName, stableNameCmp )
+import Data.Function    ( on )
+import UniqSet
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Top level stuff}
+*                                                                      *
+************************************************************************
+-}
+
+dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
+dmdAnalProgram dflags fam_envs binds
+  = do {
+        let { binds_plus_dmds = do_prog binds } ;
+        dumpIfSet_dyn dflags Opt_D_dump_str_signatures
+                      "Strictness signatures" $
+            dumpStrSig binds_plus_dmds ;
+        -- See Note [Stamp out space leaks in demand analysis]
+        seqBinds binds_plus_dmds `seq` return binds_plus_dmds
+    }
+  where
+    do_prog :: CoreProgram -> CoreProgram
+    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds
+
+-- Analyse a (group of) top-level binding(s)
+dmdAnalTopBind :: AnalEnv
+               -> CoreBind
+               -> (AnalEnv, CoreBind)
+dmdAnalTopBind env (NonRec id rhs)
+  = (extendAnalEnv TopLevel env id2 (idStrictness id2), NonRec id2 rhs2)
+  where
+    ( _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing env             cleanEvalDmd id rhs
+    ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin env) cleanEvalDmd id rhs1
+        -- Do two passes to improve CPR information
+        -- See Note [CPR for thunks]
+        -- See Note [Optimistic CPR in the "virgin" case]
+        -- See Note [Initial CPR for strict binders]
+
+dmdAnalTopBind env (Rec pairs)
+  = (env', Rec pairs')
+  where
+    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs
+                -- We get two iterations automatically
+                -- c.f. the NonRec case above
+
+{- Note [Stamp out space leaks in demand analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The demand analysis pass outputs a new copy of the Core program in
+which binders have been annotated with demand and strictness
+information. It's tiresome to ensure that this information is fully
+evaluated everywhere that we produce it, so we just run a single
+seqBinds over the output before returning it, to ensure that there are
+no references holding on to the input Core program.
+
+This makes a ~30% reduction in peak memory usage when compiling
+DynFlags (cf #9675 and #13426).
+
+This is particularly important when we are doing late demand analysis,
+since we don't do a seqBinds at any point thereafter. Hence code
+generation would hold on to an extra copy of the Core program, via
+unforced thunks in demand or strictness information; and it is the
+most memory-intensive part of the compilation process, so this added
+seqBinds makes a big difference in peak memory usage.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The analyser itself}
+*                                                                      *
+************************************************************************
+
+Note [Ensure demand is strict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important not to analyse e with a lazy demand because
+a) When we encounter   case s of (a,b) ->
+        we demand s with U(d1d2)... but if the overall demand is lazy
+        that is wrong, and we'd need to reduce the demand on s,
+        which is inconvenient
+b) More important, consider
+        f (let x = R in x+x), where f is lazy
+   We still want to mark x as demanded, because it will be when we
+   enter the let.  If we analyse f's arg with a Lazy demand, we'll
+   just mark x as Lazy
+c) The application rule wouldn't be right either
+   Evaluating (f x) in a L demand does *not* cause
+   evaluation of f in a C(L) demand!
+-}
+
+-- If e is complicated enough to become a thunk, its contents will be evaluated
+-- at most once, so oneify it.
+dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
+dmdTransformThunkDmd e
+  | exprIsTrivial e = id
+  | otherwise       = oneifyDmd
+
+-- Do not process absent demands
+-- Otherwise act like in a normal demand analysis
+-- See ↦* relation in the Cardinality Analysis paper
+dmdAnalStar :: AnalEnv
+            -> Demand   -- This one takes a *Demand*
+            -> CoreExpr -- Should obey the let/app invariatn
+            -> (BothDmdArg, CoreExpr)
+dmdAnalStar env dmd e
+  | (dmd_shell, cd) <- toCleanDmd dmd
+  , (dmd_ty, e')    <- dmdAnal env cd e
+  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
+    -- The argument 'e' should satisfy the let/app invariant
+    -- See Note [Analysing with absent demand] in Demand.hs
+    (postProcessDmdType dmd_shell dmd_ty, e')
+
+-- Main Demand Analsysis machinery
+dmdAnal, dmdAnal' :: AnalEnv
+        -> CleanDemand         -- The main one takes a *CleanDemand*
+        -> CoreExpr -> (DmdType, CoreExpr)
+
+-- The CleanDemand is always strict and not absent
+--    See Note [Ensure demand is strict]
+
+dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
+                  dmdAnal' env d e
+
+dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
+dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
+dmdAnal' _ _ (Coercion co)
+  = (unitDmdType (coercionDmdEnv co), Coercion co)
+
+dmdAnal' env dmd (Var var)
+  = (dmdTransform env var dmd, Var var)
+
+dmdAnal' env dmd (Cast e co)
+  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
+  where
+    (dmd_ty, e') = dmdAnal env dmd e
+
+dmdAnal' env dmd (Tick t e)
+  = (dmd_ty, Tick t e')
+  where
+    (dmd_ty, e') = dmdAnal env dmd e
+
+dmdAnal' env dmd (App fun (Type ty))
+  = (fun_ty, App fun' (Type ty))
+  where
+    (fun_ty, fun') = dmdAnal env dmd fun
+
+-- Lots of the other code is there to make this
+-- beautiful, compositional, application rule :-)
+dmdAnal' env dmd (App fun arg)
+  = -- This case handles value arguments (type args handled above)
+    -- Crucially, coercions /are/ handled here, because they are
+    -- value arguments (#10288)
+    let
+        call_dmd          = mkCallDmd dmd
+        (fun_ty, fun')    = dmdAnal env call_dmd fun
+        (arg_dmd, res_ty) = splitDmdTy fun_ty
+        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
+    in
+--    pprTrace "dmdAnal:app" (vcat
+--         [ text "dmd =" <+> ppr dmd
+--         , text "expr =" <+> ppr (App fun arg)
+--         , text "fun dmd_ty =" <+> ppr fun_ty
+--         , text "arg dmd =" <+> ppr arg_dmd
+--         , text "arg dmd_ty =" <+> ppr arg_ty
+--         , text "res dmd_ty =" <+> ppr res_ty
+--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
+    (res_ty `bothDmdType` arg_ty, App fun' arg')
+
+dmdAnal' env dmd (Lam var body)
+  | isTyVar var
+  = let
+        (body_ty, body') = dmdAnal env dmd body
+    in
+    (body_ty, Lam var body')
+
+  | otherwise
+  = let (body_dmd, defer_and_use) = peelCallDmd dmd
+          -- body_dmd: a demand to analyze the body
+
+        env'             = extendSigsWithLam env var
+        (body_ty, body') = dmdAnal env' body_dmd body
+        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var
+    in
+    (postProcessUnsat defer_and_use lam_ty, Lam var' body')
+
+dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
+  -- Only one alternative with a product constructor
+  | let tycon = dataConTyCon dc
+  , isJust (isDataProductTyCon_maybe tycon)
+  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
+  = let
+        env_w_tc                 = env { ae_rec_tc = rec_tc' }
+        env_alt                  = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs
+        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs
+        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
+        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
+        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
+        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
+                | otherwise                   = alt_ty2
+
+        -- Compute demand on the scrutinee
+        -- See Note [Demand on scrutinee of a product case]
+        scrut_dmd          = mkProdDmd id_dmds
+        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
+        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty
+        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd
+        bndrs'             = setBndrsDemandInfo bndrs id_dmds
+    in
+--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
+--                                   , text "dmd" <+> ppr dmd
+--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
+--                                   , text "id_dmds" <+> ppr id_dmds
+--                                   , text "scrut_dmd" <+> ppr scrut_dmd
+--                                   , text "scrut_ty" <+> ppr scrut_ty
+--                                   , text "alt_ty" <+> ppr alt_ty2
+--                                   , text "res_ty" <+> ppr res_ty ]) $
+    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])
+
+dmdAnal' env dmd (Case scrut case_bndr ty alts)
+  = let      -- Case expression with multiple alternatives
+        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
+        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
+        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
+                               -- NB: Base case is botDmdType, for empty case alternatives
+                               --     This is a unit for lubDmdType, and the right result
+                               --     when there really are no alternatives
+        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
+    in
+--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
+--                                   , text "scrut_ty" <+> ppr scrut_ty
+--                                   , text "alt_tys" <+> ppr alt_tys
+--                                   , text "alt_ty" <+> ppr alt_ty
+--                                   , text "res_ty" <+> ppr res_ty ]) $
+    (res_ty, Case scrut' case_bndr' ty alts')
+
+-- Let bindings can be processed in two ways:
+-- Down (RHS before body) or Up (body before RHS).
+-- The following case handle the up variant.
+--
+-- It is very simple. For  let x = rhs in body
+--   * Demand-analyse 'body' in the current environment
+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
+--   * Demand-analyse 'rhs' in 'rhs_dmd'
+--
+-- This is used for a non-recursive local let without manifest lambdas.
+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
+dmdAnal' env dmd (Let (NonRec id rhs) body)
+  | useLetUp id
+  = (final_ty, Let (NonRec id' rhs') body')
+  where
+    (body_ty, body')   = dmdAnal env dmd body
+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
+    id'                = setIdDemandInfo id id_dmd
+
+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
+    final_ty           = body_ty' `bothDmdType` rhs_ty
+
+dmdAnal' env dmd (Let (NonRec id rhs) body)
+  = (body_ty2, Let (NonRec id2 rhs') body')
+  where
+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs
+    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
+    (body_ty, body')     = dmdAnal env1 dmd body
+    (body_ty1, id2)      = annotateBndr env body_ty id1
+    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
+
+        -- If the actual demand is better than the vanilla call
+        -- demand, you might think that we might do better to re-analyse
+        -- the RHS with the stronger demand.
+        -- But (a) That seldom happens, because it means that *every* path in
+        --         the body of the let has to use that stronger demand
+        -- (b) It often happens temporarily in when fixpointing, because
+        --     the recursive function at first seems to place a massive demand.
+        --     But we don't want to go to extra work when the function will
+        --     probably iterate to something less demanding.
+        -- In practice, all the times the actual demand on id2 is more than
+        -- the vanilla call demand seem to be due to (b).  So we don't
+        -- bother to re-analyse the RHS.
+
+dmdAnal' env dmd (Let (Rec pairs) body)
+  = let
+        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs
+        (body_ty, body')        = dmdAnal env' dmd body
+        body_ty1                = deleteFVs body_ty (map fst pairs)
+        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
+    in
+    body_ty2 `seq`
+    (body_ty2,  Let (Rec pairs') body')
+
+io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
+-- See Note [IO hack in the demand analyser]
+io_hack_reqd scrut con bndrs
+  | (bndr:_) <- bndrs
+  , con == tupleDataCon Unboxed 2
+  , idType bndr `eqType` realWorldStatePrimTy
+  , (fun, _) <- collectArgs scrut
+  = case fun of
+      Var f -> not (isPrimOpId f)
+      _     -> True
+  | otherwise
+  = False
+
+dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
+dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
+  | null bndrs    -- Literals, DEFAULT, and nullary constructors
+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs
+  = (rhs_ty, (con, [], rhs'))
+
+  | otherwise     -- Non-nullary data constructors
+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs
+  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs
+  , let case_bndr_dmd = findIdDemand alt_ty case_bndr
+        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds
+  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
+
+
+{- Note [IO hack in the demand analyser]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's a hack here for I/O operations.  Consider
+
+     case foo x s of { (# s', r #) -> y }
+
+Is this strict in 'y'? Often not! If foo x s performs some observable action
+(including raising an exception with raiseIO#, modifying a mutable variable, or
+even ending the program normally), then we must not force 'y' (which may fail
+to terminate) until we have performed foo x s.
+
+Hackish solution: spot the IO-like situation and add a virtual branch,
+as if we had
+     case foo x s of
+        (# s, r #) -> y
+        other      -> return ()
+So the 'y' isn't necessarily going to be evaluated
+
+A more complete example (#148, #1592) where this shows up is:
+     do { let len = <expensive> ;
+        ; when (...) (exitWith ExitSuccess)
+        ; print len }
+
+However, consider
+  f x s = case getMaskingState# s of
+            (# s, r #) ->
+          case x of I# x2 -> ...
+
+Here it is terribly sad to make 'f' lazy in 's'.  After all,
+getMaskingState# is not going to diverge or throw an exception!  This
+situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
+(on an MVar not an Int), and made a material difference.
+
+So if the scrutinee is a primop call, we *don't* apply the
+state hack:
+  - If it is a simple, terminating one like getMaskingState,
+    applying the hack is over-conservative.
+  - If the primop is raise# then it returns bottom, so
+    the case alternatives are already discarded.
+  - If the primop can raise a non-IO exception, like
+    divide by zero or seg-fault (eg writing an array
+    out of bounds) then we don't mind evaluating 'x' first.
+
+Note [Demand on the scrutinee of a product case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When figuring out the demand on the scrutinee of a product case,
+we use the demands of the case alternative, i.e. id_dmds.
+But note that these include the demand on the case binder;
+see Note [Demand on case-alternative binders] in Demand.hs.
+This is crucial. Example:
+   f x = case x of y { (a,b) -> k y a }
+If we just take scrut_demand = U(L,A), then we won't pass x to the
+worker, so the worker will rebuild
+     x = (a, absent-error)
+and that'll crash.
+
+Note [Aggregated demand for cardinality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use different strategies for strictness and usage/cardinality to
+"unleash" demands captured on free variables by bindings. Let us
+consider the example:
+
+f1 y = let {-# NOINLINE h #-}
+           h = y
+       in  (h, h)
+
+We are interested in obtaining cardinality demand U1 on |y|, as it is
+used only in a thunk, and, therefore, is not going to be updated any
+more. Therefore, the demand on |y|, captured and unleashed by usage of
+|h| is U1. However, if we unleash this demand every time |h| is used,
+and then sum up the effects, the ultimate demand on |y| will be U1 +
+U1 = U. In order to avoid it, we *first* collect the aggregate demand
+on |h| in the body of let-expression, and only then apply the demand
+transformer:
+
+transf[x](U) = {y |-> U1}
+
+so the resulting demand on |y| is U1.
+
+The situation is, however, different for strictness, where this
+aggregating approach exhibits worse results because of the nature of
+|both| operation for strictness. Consider the example:
+
+f y c =
+  let h x = y |seq| x
+   in case of
+        True  -> h True
+        False -> y
+
+It is clear that |f| is strict in |y|, however, the suggested analysis
+will infer from the body of |let| that |h| is used lazily (as it is
+used in one branch only), therefore lazy demand will be put on its
+free variable |y|. Conversely, if the demand on |h| is unleashed right
+on the spot, we will get the desired result, namely, that |f| is
+strict in |y|.
+
+
+************************************************************************
+*                                                                      *
+                    Demand transformer
+*                                                                      *
+************************************************************************
+-}
+
+dmdTransform :: AnalEnv         -- The strictness environment
+             -> Id              -- The function
+             -> CleanDemand     -- The demand on the function
+             -> DmdType         -- The demand type of the function in this context
+        -- Returned DmdEnv includes the demand on
+        -- this function plus demand on its free variables
+
+dmdTransform env var dmd
+  | isDataConWorkId var                          -- Data constructor
+  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
+
+  | gopt Opt_DmdTxDictSel (ae_dflags env),
+    Just _ <- isClassOpId_maybe var -- Dictionary component selector
+  = dmdTransformDictSelSig (idStrictness var) dmd
+
+  | isGlobalId var                               -- Imported function
+  = let res = dmdTransformSig (idStrictness var) dmd in
+--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
+    res
+
+  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
+  , let fn_ty = dmdTransformSig sig dmd
+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
+    if isTopLevel top_lvl
+    then fn_ty   -- Don't record top level things
+    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
+
+  | otherwise                                    -- Local non-letrec-bound thing
+  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+-- Recursive bindings
+dmdFix :: TopLevelFlag
+       -> AnalEnv                            -- Does not include bindings for this binding
+       -> CleanDemand
+       -> [(Id,CoreExpr)]
+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
+
+dmdFix top_lvl env let_dmd orig_pairs
+  = loop 1 initial_pairs
+  where
+    bndrs = map fst orig_pairs
+
+    -- See Note [Initialising strictness]
+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
+                  | otherwise     = orig_pairs
+
+    -- If fixed-point iteration does not yield a result we use this instead
+    -- See Note [Safe abortion in the fixed-point iteration]
+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    abort = (env, lazy_fv', zapped_pairs)
+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
+            -- Note [Lazy and unleashable free variables]
+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
+            zapped_pairs = zapIdStrictness pairs'
+
+    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
+    -- annotation does not change any more.
+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    loop n pairs
+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
+      | n == 10        = abort
+      | otherwise      = loop (n+1) pairs'
+      where
+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
+        first_round       = n == 1
+        (lazy_fv, pairs') = step first_round pairs
+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
+
+    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
+    step first_round pairs = (lazy_fv, pairs')
+      where
+        -- In all but the first iteration, delete the virgin flag
+        start_env | first_round = env
+                  | otherwise   = nonVirgin env
+
+        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
+
+        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
+                -- mapAccumL: Use the new signature to do the next pair
+                -- The occurrence analyser has arranged them in a good order
+                -- so this can significantly reduce the number of iterations needed
+
+        my_downRhs (env, lazy_fv) (id,rhs)
+          = ((env', lazy_fv'), (id', rhs'))
+          where
+            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs
+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
+
+
+    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
+
+{-
+Note [Safe abortion in the fixed-point iteration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Fixed-point iteration may fail to terminate. But we cannot simply give up and
+return the environment and code unchanged! We still need to do one additional
+round, for two reasons:
+
+ * To get information on used free variables (both lazy and strict!)
+   (see Note [Lazy and unleashable free variables])
+ * To ensure that all expressions have been traversed at least once, and any left-over
+   strictness annotations have been updated.
+
+This final iteration does not add the variables to the strictness signature
+environment, which effectively assigns them 'nopSig' (see "getStrictness")
+
+-}
+
+-- Let bindings can be processed in two ways:
+-- Down (RHS before body) or Up (body before RHS).
+-- dmdAnalRhsLetDown implements the Down variant:
+--  * assuming a demand of <L,U>
+--  * looking at the definition
+--  * determining a strictness signature
+--
+-- It is used for toplevel definition, recursive definitions and local
+-- non-recursive definitions that have manifest lambdas.
+-- Local non-recursive definitions without a lambda are handled with LetUp.
+--
+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
+dmdAnalRhsLetDown :: TopLevelFlag
+           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
+           -> AnalEnv -> CleanDemand
+           -> Id -> CoreExpr
+           -> (DmdEnv, Id, CoreExpr)
+-- Process the RHS of the binding, add the strictness signature
+-- to the Id, and augment the environment with the signature as well.
+dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
+  = (lazy_fv, id', rhs')
+  where
+    rhs_arity      = idArity id
+    rhs_dmd
+      -- See Note [Demand analysis for join points]
+      -- See Note [idArity for join points] in SimplUtils
+      -- rhs_arity matches the join arity of the join point
+      | isJoinId id
+      = mkCallDmds rhs_arity let_dmd
+      | otherwise
+      -- NB: rhs_arity
+      -- See Note [Demand signatures are computed for a threshold demand based on idArity]
+      = mkRhsDmd env rhs_arity rhs
+    (DmdType rhs_fv rhs_dmds rhs_res, rhs')
+                   = dmdAnal env rhs_dmd rhs
+    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res')
+    id'            = set_idStrictness env id sig
+        -- See Note [NOINLINE and strictness]
+
+
+    -- See Note [Aggregated demand for cardinality]
+    rhs_fv1 = case rec_flag of
+                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
+                Nothing -> rhs_fv
+
+    -- See Note [Lazy and unleashable free variables]
+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
+
+    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res
+    trim_all  = is_thunk && not_strict
+    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
+
+    -- See Note [CPR for thunks]
+    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
+    not_strict
+       =  isTopLevel top_lvl  -- Top level and recursive things don't
+       || isJust rec_flag     -- get their demandInfo set at all
+       || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
+          -- See Note [Optimistic CPR in the "virgin" case]
+
+-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
+-- unleashing on the given function's @rhs@, by creating a call demand of
+-- @rhs_arity@ with a body demand appropriate for possible product types.
+-- See Note [Product demands for function body].
+-- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a
+-- clean usage demand of @C1(C1(U(U,U)))@.
+mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
+mkRhsDmd env rhs_arity rhs =
+  case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of
+    Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))
+    _                 -> mkCallDmds rhs_arity cleanEvalDmd
+
+-- | If given the let-bound 'Id', 'useLetUp' determines whether we should
+-- process the binding up (body before rhs) or down (rhs before body).
+--
+-- We use LetDown if there is a chance to get a useful strictness signature to
+-- unleash at call sites. LetDown is generally more precise than LetUp if we can
+-- correctly guess how it will be used in the body, that is, for which incoming
+-- demand the strictness signature should be computed, which allows us to
+-- unleash higher-order demands on arguments at call sites. This is mostly the
+-- case when
+--
+--   * The binding takes any arguments before performing meaningful work (cf.
+--     'idArity'), in which case we are interested to see how it uses them.
+--   * The binding is a join point, hence acting like a function, not a value.
+--     As a big plus, we know *precisely* how it will be used in the body; since
+--     it's always tail-called, we can directly unleash the incoming demand of
+--     the let binding on its RHS when computing a strictness signature. See
+--     [Demand analysis for join points].
+--
+-- Thus, if the binding is not a join point and its arity is 0, we have a thunk
+-- and use LetUp, implying that we have no usable demand signature available
+-- when we analyse the let body.
+--
+-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free
+-- vars at most once, regardless of how many times it was forced in the body.
+-- This makes a real difference wrt. usage demands. The other reason is being
+-- able to unleash a more precise product demand on its RHS once we know how the
+-- thunk was used in the let body.
+--
+-- Characteristic examples, always assuming a single evaluation:
+--
+--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that
+--     the expression uses @y@ at most once.
+--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that
+--     @b@ is absent.
+--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that
+--     the expression uses @y@ strictly, because we have @f@'s demand signature
+--     available at the call site.
+--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>
+--     LetDown. Compared to LetUp, we find out that the expression uses @y@
+--     strictly, because we can unleash @exit@'s signature at each call site.
+--   * For a more convincing example with join points, see Note [Demand analysis
+--     for join points].
+--
+useLetUp :: Var -> Bool
+useLetUp f = idArity f == 0 && not (isJoinId f)
+
+{- Note [Demand analysis for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   g :: (Int,Int) -> Int
+   g (p,q) = p+q
+
+   f :: T -> Int -> Int
+   f x p = g (join j y = (p,y)
+              in case x of
+                   A -> j 3
+                   B -> j 4
+                   C -> (p,7))
+
+If j was a vanilla function definition, we'd analyse its body with
+evalDmd, and think that it was lazy in p.  But for join points we can
+do better!  We know that j's body will (if called at all) be evaluated
+with the demand that consumes the entire join-binding, in this case
+the argument demand from g.  Whizzo!  g evaluates both components of
+its argument pair, so p will certainly be evaluated if j is called.
+
+For f to be strict in p, we need /all/ paths to evaluate p; in this
+case the C branch does so too, so we are fine.  So, as usual, we need
+to transport demands on free variables to the call site(s).  Compare
+Note [Lazy and unleashable free variables].
+
+The implementation is easy.  When analysing a join point, we can
+analyse its body with the demand from the entire join-binding (written
+let_dmd here).
+
+Another win for join points!  #13543.
+
+Note [Demand signatures are computed for a threshold demand based on idArity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We compute demand signatures assuming idArity incoming arguments to approximate
+behavior for when we have a call site with at least that many arguments. idArity
+is /at least/ the number of manifest lambdas, but might be higher for PAPs and
+trivial RHS (see Note [Demand analysis for trivial right-hand sides]).
+
+Because idArity of a function varies independently of its cardinality properties
+(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode
+the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'
+(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to
+unleash a demand signature when the incoming number of arguments is less than
+that. See Note [What are demand signatures?] for more details on soundness.
+
+Why idArity arguments? Because that's a conservative estimate of how many
+arguments we must feed a function before it does anything interesting with them.
+Also it elegantly subsumes the trivial RHS and PAP case.
+
+There might be functions for which we might want to analyse for more incoming
+arguments than idArity. Example:
+
+  f x =
+    if expensive
+      then \y -> ... y ...
+      else \y -> ... y ...
+
+We'd analyse `f` under a unary call demand C(S), corresponding to idArity
+being 1. That's enough to look under the manifest lambda and find out how a
+unary call would use `x`, but not enough to look into the lambdas in the if
+branches.
+
+On the other hand, if we analysed for call demand C(C(S)), we'd get useful
+strictness info for `y` (and more precise info on `x`) and possibly CPR
+information, but
+
+  * We would no longer be able to unleash the signature at unary call sites
+  * Performing the worker/wrapper split based on this information would be
+    implicitly eta-expanding `f`, playing fast and loose with divergence and
+    even being unsound in the presence of newtypes, so we refrain from doing so.
+    Also see Note [Don't eta expand in w/w] in WorkWrap.
+
+Since we only compute one signature, we do so for arity 1. Computing multiple
+signatures for different arities (i.e., polyvariance) would be entirely
+possible, if it weren't for the additional runtime and implementation
+complexity.
+
+Note [idArity varies independently of dmdTypeDepth]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound
+identifier. But that means we would have to zap demand signatures every time we
+reset or decrease arity. That's an unnecessary dependency, because
+
+  * The demand signature captures a semantic property that is independent of
+    what the binding's current arity is
+  * idArity is analysis information itself, thus volatile
+  * We already *have* dmdTypeDepth, wo why not just use it to encode the
+    threshold for when to unleash the signature
+    (cf. Note [Understanding DmdType and StrictSig] in Demand)
+
+Consider the following expression, for example:
+
+    (let go x y = `x` seq ... in go) |> co
+
+`go` might have a strictness signature of `<S><L>`. The simplifier will identify
+`go` as a nullary join point through `joinPointBinding_maybe` and float the
+coercion into the binding, leading to an arity decrease:
+
+    join go = (\x y -> `x` seq ...) |> co in go
+
+With the CoreLint check, we would have to zap `go`'s perfectly viable strictness
+signature.
+
+Note [What are demand signatures?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Demand analysis interprets expressions in the abstract domain of demand
+transformers. Given an incoming demand we put an expression under, its abstract
+transformer gives us back a demand type denoting how other things (like
+arguments and free vars) were used when the expression was evaluated.
+Here's an example:
+
+  f x y =
+    if x + expensive
+      then \z -> z + y * ...
+      else \z -> z * ...
+
+The abstract transformer (let's call it F_e) of the if expression (let's call it
+e) would transform an incoming head demand <S,HU> into a demand type like
+{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:
+
+     Demand ---F_e---> DmdType
+     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>
+
+Let's assume that the demand transformers we compute for an expression are
+correct wrt. to some concrete semantics for Core. How do demand signatures fit
+in? They are strange beasts, given that they come with strict rules when to
+it's sound to unleash them.
+
+Fortunately, we can formalise the rules with Galois connections. Consider
+f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of
+the actual abstract transformer of f's RHS for arity 2. So, what happens is that
+we abstract *once more* from the abstract domain we already are in, replacing
+the incoming Demand by a simple lattice with two elements denoting incoming
+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom
+element). Here's the diagram:
+
+     A_2 -----f_f----> DmdType
+      ^                   |
+      | α               γ |
+      |                   v
+     Demand ---F_f---> DmdType
+
+With
+  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness
+  α(_)         =  <2
+  γ(ty)        =  ty
+and F_f being the abstract transformer of f's RHS and f_f being the abstracted
+abstract transformer computable from our demand signature simply by
+
+  f_f(>=2) = {}<S,1*U><L,U>
+  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>
+
+where postProcessUnsat makes a proper top element out of the given demand type.
+
+Note [Demand analysis for trivial right-hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    foo = plusInt |> co
+where plusInt is an arity-2 function with known strictness.  Clearly
+we want plusInt's strictness to propagate to foo!  But because it has
+no manifest lambdas, it won't do so automatically, and indeed 'co' might
+have type (Int->Int->Int) ~ T.
+
+Fortunately, CoreArity gives 'foo' arity 2, which is enough for LetDown to
+forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
+CoreArity)! A small example is the test case NewtypeArity.
+
+
+Note [Product demands for function body]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This example comes from shootout/binary_trees:
+
+    Main.check' = \ b z ds. case z of z' { I# ip ->
+                                case ds_d13s of
+                                  Main.Nil -> z'
+                                  Main.Node s14k s14l s14m ->
+                                    Main.check' (not b)
+                                      (Main.check' b
+                                         (case b {
+                                            False -> I# (-# s14h s14k);
+                                            True  -> I# (+# s14h s14k)
+                                          })
+                                         s14l)
+                                     s14m   }   }   }
+
+Here we *really* want to unbox z, even though it appears to be used boxed in
+the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
+the whole function gets the CPR property if we do.
+
+So for the demand on the body of a RHS we use a product demand if it's
+a product type.
+
+************************************************************************
+*                                                                      *
+\subsection{Strictness signatures and types}
+*                                                                      *
+************************************************************************
+-}
+
+unitDmdType :: DmdEnv -> DmdType
+unitDmdType dmd_env = DmdType dmd_env [] topRes
+
+coercionDmdEnv :: Coercion -> DmdEnv
+coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
+                    -- The VarSet from coVarsOfCo is really a VarEnv Var
+
+addVarDmd :: DmdType -> Var -> Demand -> DmdType
+addVarDmd (DmdType fv ds res) var dmd
+  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
+
+addLazyFVs :: DmdType -> DmdEnv -> DmdType
+addLazyFVs dmd_ty lazy_fvs
+  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
+        -- Using bothDmdType (rather than just both'ing the envs)
+        -- is vital.  Consider
+        --      let f = \x -> (x,y)
+        --      in  error (f 3)
+        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
+        -- demand with the bottom coming up from 'error'
+        --
+        -- I got a loop in the fixpointer without this, due to an interaction
+        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was
+        --      letrec f n x
+        --          = letrec g y = x `fatbar`
+        --                         letrec h z = z + ...g...
+        --                         in h (f (n-1) x)
+        --      in ...
+        -- In the initial iteration for f, f=Bot
+        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
+        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
+        -- places on its free variables.  Suppose it places none.  Then the
+        --      x `fatbar` ...call to h...
+        -- will give a x->V demand for x.  That turns into a L demand for x,
+        -- which floats out of the defn for h.  Without the modifyEnv, that
+        -- L demand doesn't get both'd with the Bot coming up from the inner
+        -- call to f.  So we just get an L demand for x for g.
+
+{-
+Note [Do not strictify the argument dictionaries of a dfun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker can tie recursive knots involving dfuns, so we do the
+conservative thing and refrain from strictifying a dfun's argument
+dictionaries.
+-}
+
+setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
+setBndrsDemandInfo (b:bs) (d:ds)
+  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)
+  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds
+setBndrsDemandInfo [] ds = ASSERT( null ds ) []
+setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)
+
+annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
+-- The returned env has the var deleted
+-- The returned var is annotated with demand info
+-- according to the result demand of the provided demand type
+-- No effect on the argument demands
+annotateBndr env dmd_ty var
+  | isId var  = (dmd_ty', setIdDemandInfo var dmd)
+  | otherwise = (dmd_ty, var)
+  where
+    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
+
+annotateLamIdBndr :: AnalEnv
+                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
+                  -> DmdType    -- Demand type of body
+                  -> Id         -- Lambda binder
+                  -> (DmdType,  -- Demand type of lambda
+                      Id)       -- and binder annotated with demand
+
+annotateLamIdBndr env arg_of_dfun dmd_ty id
+-- For lambdas we add the demand to the argument demands
+-- Only called for Ids
+  = ASSERT( isId id )
+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
+    (final_ty, setIdDemandInfo id dmd)
+  where
+      -- Watch out!  See note [Lambda-bound unfoldings]
+    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
+                 Nothing  -> main_ty
+                 Just unf -> main_ty `bothDmdType` unf_ty
+                          where
+                             (unf_ty, _) = dmdAnalStar env dmd unf
+
+    main_ty = addDemand dmd dmd_ty'
+    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
+
+deleteFVs :: DmdType -> [Var] -> DmdType
+deleteFVs (DmdType fvs dmds res) bndrs
+  = DmdType (delVarEnvList fvs bndrs) dmds res
+
+{-
+Note [CPR for sum types]
+~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we do not do CPR for let-bindings that
+   * non-top level
+   * bind a sum type
+Reason: I found that in some benchmarks we were losing let-no-escapes,
+which messed it all up.  Example
+   let j = \x. ....
+   in case y of
+        True  -> j False
+        False -> j True
+If we w/w this we get
+   let j' = \x. ....
+   in case y of
+        True  -> case j' False of { (# a #) -> Just a }
+        False -> case j' True of { (# a #) -> Just a }
+Notice that j' is not a let-no-escape any more.
+
+However this means in turn that the *enclosing* function
+may be CPR'd (via the returned Justs).  But in the case of
+sums, there may be Nothing alternatives; and that messes
+up the sum-type CPR.
+
+Conclusion: only do this for products.  It's still not
+guaranteed OK for products, but sums definitely lose sometimes.
+
+Note [CPR for thunks]
+~~~~~~~~~~~~~~~~~~~~~
+If the rhs is a thunk, we usually forget the CPR info, because
+it is presumably shared (else it would have been inlined, and
+so we'd lose sharing if w/w'd it into a function).  E.g.
+
+        let r = case expensive of
+                  (a,b) -> (b,a)
+        in ...
+
+If we marked r as having the CPR property, then we'd w/w into
+
+        let $wr = \() -> case expensive of
+                            (a,b) -> (# b, a #)
+            r = case $wr () of
+                  (# b,a #) -> (b,a)
+        in ...
+
+But now r is a thunk, which won't be inlined, so we are no further ahead.
+But consider
+
+        f x = let r = case expensive of (a,b) -> (b,a)
+              in if foo r then r else (x,x)
+
+Does f have the CPR property?  Well, no.
+
+However, if the strictness analyser has figured out (in a previous
+iteration) that it's strict, then we DON'T need to forget the CPR info.
+Instead we can retain the CPR info and do the thunk-splitting transform
+(see WorkWrap.splitThunk).
+
+This made a big difference to PrelBase.modInt, which had something like
+        modInt = \ x -> let r = ... -> I# v in
+                        ...body strict in r...
+r's RHS isn't a value yet; but modInt returns r in various branches, so
+if r doesn't have the CPR property then neither does modInt
+Another case I found in practice (in Complex.magnitude), looks like this:
+                let k = if ... then I# a else I# b
+                in ... body strict in k ....
+(For this example, it doesn't matter whether k is returned as part of
+the overall result; but it does matter that k's RHS has the CPR property.)
+Left to itself, the simplifier will make a join point thus:
+                let $j k = ...body strict in k...
+                if ... then $j (I# a) else $j (I# b)
+With thunk-splitting, we get instead
+                let $j x = let k = I#x in ...body strict in k...
+                in if ... then $j a else $j b
+This is much better; there's a good chance the I# won't get allocated.
+
+The difficulty with this is that we need the strictness type to
+look at the body... but we now need the body to calculate the demand
+on the variable, so we can decide whether its strictness type should
+have a CPR in it or not.  Simple solution:
+        a) use strictness info from the previous iteration
+        b) make sure we do at least 2 iterations, by doing a second
+           round for top-level non-recs.  Top level recs will get at
+           least 2 iterations except for totally-bottom functions
+           which aren't very interesting anyway.
+
+NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
+
+Note [Optimistic CPR in the "virgin" case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Demand and strictness info are initialized by top elements. However,
+this prevents from inferring a CPR property in the first pass of the
+analyser, so we keep an explicit flag ae_virgin in the AnalEnv
+datatype.
+
+We can't start with 'not-demanded' (i.e., top) because then consider
+        f x = let
+                  t = ... I# x
+              in
+              if ... then t else I# y else f x'
+
+In the first iteration we'd have no demand info for x, so assume
+not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
+we'd see that t was demanded, and so give it the CPR property, but by
+now f has TopRes, so it will stay TopRes.  Instead, by checking the
+ae_virgin flag at the first time round, we say 'yes t is demanded' the
+first time.
+
+However, this does mean that for non-recursive bindings we must
+iterate twice to be sure of not getting over-optimistic CPR info,
+in the case where t turns out to be not-demanded.  This is handled
+by dmdAnalTopBind.
+
+
+Note [NOINLINE and strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The strictness analyser used to have a HACK which ensured that NOINLNE
+things were not strictness-analysed.  The reason was unsafePerformIO.
+Left to itself, the strictness analyser would discover this strictness
+for unsafePerformIO:
+        unsafePerformIO:  C(U(AV))
+But then consider this sub-expression
+        unsafePerformIO (\s -> let r = f x in
+                               case writeIORef v r s of (# s1, _ #) ->
+                               (# s1, r #)
+The strictness analyser will now find that r is sure to be eval'd,
+and may then hoist it out.  This makes tests/lib/should_run/memo002
+deadlock.
+
+Solving this by making all NOINLINE things have no strictness info is overkill.
+In particular, it's overkill for runST, which is perfectly respectable.
+Consider
+        f x = runST (return x)
+This should be strict in x.
+
+So the new plan is to define unsafePerformIO using the 'lazy' combinator:
+
+        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+
+Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
+magically NON-STRICT, and is inlined after strictness analysis.  So
+unsafePerformIO will look non-strict, and that's what we want.
+
+Now we don't need the hack in the strictness analyser.  HOWEVER, this
+decision does mean that even a NOINLINE function is not entirely
+opaque: some aspect of its implementation leaks out, notably its
+strictness.  For example, if you have a function implemented by an
+error stub, but which has RULES, you may want it not to be eliminated
+in favour of error!
+
+Note [Lazy and unleashable free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We put the strict and once-used FVs in the DmdType of the Id, so
+that at its call sites we unleash demands on its strict fvs.
+An example is 'roll' in imaginary/wheel-sieve2
+Something like this:
+        roll x = letrec
+                     go y = if ... then roll (x-1) else x+1
+                 in
+                 go ms
+We want to see that roll is strict in x, which is because
+go is called.   So we put the DmdEnv for x in go's DmdType.
+
+Another example:
+
+        f :: Int -> Int -> Int
+        f x y = let t = x+1
+            h z = if z==0 then t else
+                  if z==1 then x+1 else
+                  x + h (z-1)
+        in h y
+
+Calling h does indeed evaluate x, but we can only see
+that if we unleash a demand on x at the call site for t.
+
+Incidentally, here's a place where lambda-lifting h would
+lose the cigar --- we couldn't see the joint strictness in t/x
+
+        ON THE OTHER HAND
+
+We don't want to put *all* the fv's from the RHS into the
+DmdType. Because
+
+ * it makes the strictness signatures larger, and hence slows down fixpointing
+
+and
+
+ * it is useless information at the call site anyways:
+   For lazy, used-many times fv's we will never get any better result than
+   that, no matter how good the actual demand on the function at the call site
+   is (unless it is always absent, but then the whole binder is useless).
+
+Therefore we exclude lazy multiple-used fv's from the environment in the
+DmdType.
+
+But now the signature lies! (Missing variables are assumed to be absent.) To
+make up for this, the code that analyses the binding keeps the demand on those
+variable separate (usually called "lazy_fv") and adds it to the demand of the
+whole binding later.
+
+What if we decide _not_ to store a strictness signature for a binding at all, as
+we do when aborting a fixed-point iteration? The we risk losing the information
+that the strict variables are being used. In that case, we take all free variables
+mentioned in the (unsound) strictness signature, conservatively approximate the
+demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
+
+
+Note [Lambda-bound unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We allow a lambda-bound variable to carry an unfolding, a facility that is used
+exclusively for join points; see Note [Case binders and join points].  If so,
+we must be careful to demand-analyse the RHS of the unfolding!  Example
+   \x. \y{=Just x}. <body>
+Then if <body> uses 'y', then transitively it uses 'x', and we must not
+forget that fact, otherwise we might make 'x' absent when it isn't.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Strictness signatures}
+*                                                                      *
+************************************************************************
+-}
+
+type DFunFlag = Bool  -- indicates if the lambda being considered is in the
+                      -- sequence of lambdas at the top of the RHS of a dfun
+notArgOfDfun :: DFunFlag
+notArgOfDfun = False
+
+data AnalEnv
+  = AE { ae_dflags :: DynFlags
+       , ae_sigs   :: SigEnv
+       , ae_virgin :: Bool    -- True on first iteration only
+                              -- See Note [Initialising strictness]
+       , ae_rec_tc :: RecTcChecker
+       , ae_fam_envs :: FamInstEnvs
+ }
+
+        -- We use the se_env to tell us whether to
+        -- record info about a variable in the DmdEnv
+        -- We do so if it's a LocalId, but not top-level
+        --
+        -- The DmdEnv gives the demand on the free vars of the function
+        -- when it is given enough args to satisfy the strictness signature
+
+type SigEnv = VarEnv (StrictSig, TopLevelFlag)
+
+instance Outputable AnalEnv where
+  ppr (AE { ae_sigs = env, ae_virgin = virgin })
+    = text "AE" <+> braces (vcat
+         [ text "ae_virgin =" <+> ppr virgin
+         , text "ae_sigs =" <+> ppr env ])
+
+emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
+emptyAnalEnv dflags fam_envs
+    = AE { ae_dflags = dflags
+         , ae_sigs = emptySigEnv
+         , ae_virgin = True
+         , ae_rec_tc = initRecTc
+         , ae_fam_envs = fam_envs
+         }
+
+emptySigEnv :: SigEnv
+emptySigEnv = emptyVarEnv
+
+-- | Extend an environment with the strictness IDs attached to the id
+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
+extendAnalEnvs top_lvl env vars
+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
+
+extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
+extendSigEnvs top_lvl sigs vars
+  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]
+
+extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
+extendAnalEnv top_lvl env var sig
+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
+
+extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
+extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
+
+lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
+
+nonVirgin :: AnalEnv -> AnalEnv
+nonVirgin env = env { ae_virgin = False }
+
+extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
+-- Extend the AnalEnv when we meet a lambda binder
+extendSigsWithLam env id
+  | isId id
+  , isStrictDmd (idDemandInfo id) || ae_virgin env
+       -- See Note [Optimistic CPR in the "virgin" case]
+       -- See Note [Initial CPR for strict binders]
+  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
+  = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
+
+  | otherwise
+  = env
+
+extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
+-- See Note [CPR in a product case alternative]
+extendEnvForProdAlt env scrut case_bndr dc bndrs
+  = foldl' do_con_arg env1 ids_w_strs
+  where
+    env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
+
+    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc
+    case_bndr_sig = cprProdSig (dataConRepArity dc)
+    fam_envs      = ae_fam_envs env
+
+    do_con_arg env (id, str)
+       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str
+       , ae_virgin env || (is_var_scrut && is_strict)  -- See Note [CPR in a product case alternative]
+       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id
+       = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
+       | otherwise
+       = env
+
+    is_var_scrut = is_var scrut
+    is_var (Cast e _) = is_var e
+    is_var (Var v)    = isLocalId v
+    is_var _          = False
+
+findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
+-- Return the demands on the Ids in the [Var]
+findBndrsDmds env dmd_ty bndrs
+  = go dmd_ty bndrs
+  where
+    go dmd_ty []  = (dmd_ty, [])
+    go dmd_ty (b:bs)
+      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs
+                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b
+                    in (dmd_ty2, dmd : dmds)
+      | otherwise = go dmd_ty bs
+
+findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
+-- See Note [Trimming a demand to a type] in Demand.hs
+findBndrDmd env arg_of_dfun dmd_ty id
+  = (dmd_ty', dmd')
+  where
+    dmd' = killUsageDemand (ae_dflags env) $
+           strictify $
+           trimToType starting_dmd (findTypeShape fam_envs id_ty)
+
+    (dmd_ty', starting_dmd) = peelFV dmd_ty id
+
+    id_ty = idType id
+
+    strictify dmd
+      | gopt Opt_DictsStrict (ae_dflags env)
+             -- We never want to strictify a recursive let. At the moment
+             -- annotateBndr is only call for non-recursive lets; if that
+             -- changes, we need a RecFlag parameter and another guard here.
+      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]
+      = strictifyDictDmd id_ty dmd
+      | otherwise
+      = dmd
+
+    fam_envs = ae_fam_envs env
+
+set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
+set_idStrictness env id sig
+  = setIdStrictness id (killUsageSig (ae_dflags env) sig)
+
+dumpStrSig :: CoreProgram -> SDoc
+dumpStrSig binds = vcat (map printId ids)
+  where
+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
+  getIds (NonRec i _) = [ i ]
+  getIds (Rec bs)     = map fst bs
+  printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
+             | otherwise       = empty
+
+{- Note [CPR in a product case alternative]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a case alternative for a product type, we want to give some of the
+binders the CPR property.  Specifically
+
+ * The case binder; inside the alternative, the case binder always has
+   the CPR property, meaning that a case on it will successfully cancel.
+   Example:
+        f True  x = case x of y { I# x' -> if x' ==# 3
+                                           then y
+                                           else I# 8 }
+        f False x = I# 3
+
+   By giving 'y' the CPR property, we ensure that 'f' does too, so we get
+        f b x = case fw b x of { r -> I# r }
+        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
+        fw False x = 3
+
+   Of course there is the usual risk of re-boxing: we have 'x' available
+   boxed and unboxed, but we return the unboxed version for the wrapper to
+   box.  If the wrapper doesn't cancel with its caller, we'll end up
+   re-boxing something that we did have available in boxed form.
+
+ * Any strict binders with product type, can use
+   Note [Initial CPR for strict binders].  But we can go a little
+   further. Consider
+
+      data T = MkT !Int Int
+
+      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))
+                   | otherwise = x
+
+   For $wf2 we are going to unbox the MkT *and*, since it is strict, the
+   first argument of the MkT; see Note [Add demands for strict constructors]
+   in WwLib. But then we don't want box it up again when returning it! We want
+   'f2' to have the CPR property, so we give 'x' the CPR property.
+
+ * It's a bit delicate because if this case is scrutinising something other
+   than an argument the original function, we really don't have the unboxed
+   version available.  E.g
+      g v = case foo v of
+              MkT x y | y>0       -> ...
+                      | otherwise -> x
+   Here we don't have the unboxed 'x' available.  Hence the
+   is_var_scrut test when making use of the strictness annotation.
+   Slightly ad-hoc, because even if the scrutinee *is* a variable it
+   might not be a onre of the arguments to the original function, or a
+   sub-component thereof.  But it's simple, and nothing terrible
+   happens if we get it wrong.  e.g. #10694.
+
+
+Note [Initial CPR for strict binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CPR is initialized for a lambda binder in an optimistic manner, i.e,
+if the binder is used strictly and at least some of its components as
+a product are used, which is checked by the value of the absence
+demand.
+
+If the binder is marked demanded with a strict demand, then give it a
+CPR signature. Here's a concrete example ('f1' in test T10482a),
+assuming h is strict:
+
+  f1 :: Int -> Int
+  f1 x = case h x of
+          A -> x
+          B -> f1 (x-1)
+          C -> x+1
+
+If we notice that 'x' is used strictly, we can give it the CPR
+property; and hence f1 gets the CPR property too.  It's sound (doesn't
+change strictness) to give it the CPR property because by the time 'x'
+is returned (case A above), it'll have been evaluated (by the wrapper
+of 'h' in the example).
+
+Moreover, if f itself is strict in x, then we'll pass x unboxed to
+f1, and so the boxed version *won't* be available; in that case it's
+very helpful to give 'x' the CPR property.
+
+Note that
+
+  * We only want to do this for something that definitely
+    has product type, else we may get over-optimistic CPR results
+    (e.g. from \x -> x!).
+
+  * See Note [CPR examples]
+
+Note [CPR examples]
+~~~~~~~~~~~~~~~~~~~~
+Here are some examples (stranal/should_compile/T10482a) of the
+usefulness of Note [CPR in a product case alternative].  The main
+point: all of these functions can have the CPR property.
+
+    ------- f1 -----------
+    -- x is used strictly by h, so it'll be available
+    -- unboxed before it is returned in the True branch
+
+    f1 :: Int -> Int
+    f1 x = case h x x of
+            True  -> x
+            False -> f1 (x-1)
+
+
+    ------- f2 -----------
+    -- x is a strict field of MkT2, so we'll pass it unboxed
+    -- to $wf2, so it's available unboxed.  This depends on
+    -- the case expression analysing (a subcomponent of) one
+    -- of the original arguments to the function, so it's
+    -- a bit more delicate.
+
+    data T2 = MkT2 !Int Int
+
+    f2 :: T2 -> Int
+    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+                  | otherwise = x
+
+
+    ------- f3 -----------
+    -- h is strict in x, so x will be unboxed before it
+    -- is rerturned in the otherwise case.
+
+    data T3 = MkT3 Int Int
+
+    f1 :: T3 -> Int
+    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+                  | otherwise = x
+
+
+    ------- f4 -----------
+    -- Just like f2, but MkT4 can't unbox its strict
+    -- argument automatically, as f2 can
+
+    data family Foo a
+    newtype instance Foo Int = Foo Int
+
+    data T4 a = MkT4 !(Foo a) Int
+
+    f4 :: T4 Int -> Int
+    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                          | otherwise = v
+
+
+Note [Initialising strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See section 9.2 (Finding fixpoints) of the paper.
+
+Our basic plan is to initialise the strictness of each Id in a
+recursive group to "bottom", and find a fixpoint from there.  However,
+this group B might be inside an *enclosing* recursive group A, in
+which case we'll do the entire fixpoint shebang on for each iteration
+of A. This can be illustrated by the following example:
+
+Example:
+
+  f [] = []
+  f (x:xs) = let g []     = f xs
+                 g (y:ys) = y+1 : g ys
+              in g (h x)
+
+At each iteration of the fixpoint for f, the analyser has to find a
+fixpoint for the enclosed function g. In the meantime, the demand
+values for g at each iteration for f are *greater* than those we
+encountered in the previous iteration for f. Therefore, we can begin
+the fixpoint for g not with the bottom value but rather with the
+result of the previous analysis. I.e., when beginning the fixpoint
+process for g, we can start from the demand signature computed for g
+previously and attached to the binding occurrence of g.
+
+To speed things up, we initialise each iteration of A (the enclosing
+one) from the result of the last one, which is neatly recorded in each
+binder.  That way we make use of earlier iterations of the fixpoint
+algorithm. (Cunning plan.)
+
+But on the *first* iteration we want to *ignore* the current strictness
+of the Id, and start from "bottom".  Nowadays the Id can have a current
+strictness, because interface files record strictness for nested bindings.
+To know when we are in the first iteration, we look at the ae_virgin
+field of the AnalEnv.
+
+
+Note [Final Demand Analyser run]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some of the information that the demand analyser determines is not always
+preserved by the simplifier.  For example, the simplifier will happily rewrite
+  \y [Demand=1*U] let x = y in x + x
+to
+  \y [Demand=1*U] y + y
+which is quite a lie.
+
+The once-used information is (currently) only used by the code
+generator, though.  So:
+
+ * We zap the used-once info in the worker-wrapper;
+   see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's
+   not reliable, it's better not to have it at all.
+
+ * Just before TidyCore, we add a pass of the demand analyser,
+      but WITHOUT subsequent worker/wrapper and simplifier,
+   right before TidyCore.  See SimplCore.getCoreToDo.
+
+   This way, correct information finds its way into the module interface
+   (strictness signatures!) and the code generator (single-entry thunks!)
+
+Note that, in contrast, the single-call information (C1(..)) /can/ be
+relied upon, as the simplifier tends to be very careful about not
+duplicating actual function calls.
+
+Also see #11731.
+-}
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stranal/WorkWrap.hs
@@ -0,0 +1,760 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
+-}
+
+{-# LANGUAGE CPP #-}
+module WorkWrap ( wwTopBinds ) where
+
+import GhcPrelude
+
+import CoreArity        ( manifestArity )
+import CoreSyn
+import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )
+import CoreUtils        ( exprType, exprIsHNF )
+import CoreFVs          ( exprFreeVars )
+import Var
+import Id
+import IdInfo
+import Type
+import UniqSupply
+import BasicTypes
+import DynFlags
+import Demand
+import WwLib
+import Util
+import Outputable
+import FamInstEnv
+import MonadUtils
+
+#include "HsVersions.h"
+
+{-
+We take Core bindings whose binders have:
+
+\begin{enumerate}
+
+\item Strictness attached (by the front-end of the strictness
+analyser), and / or
+
+\item Constructed Product Result information attached by the CPR
+analysis pass.
+
+\end{enumerate}
+
+and we return some ``plain'' bindings which have been
+worker/wrapper-ified, meaning:
+
+\begin{enumerate}
+
+\item Functions have been split into workers and wrappers where
+appropriate.  If a function has both strictness and CPR properties
+then only one worker/wrapper doing both transformations is produced;
+
+\item Binders' @IdInfos@ have been updated to reflect the existence of
+these workers/wrappers (this is where we get STRICTNESS and CPR pragma
+info for exported values).
+\end{enumerate}
+-}
+
+wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
+
+wwTopBinds dflags fam_envs us top_binds
+  = initUs_ us $ do
+    top_binds' <- mapM (wwBind dflags fam_envs) top_binds
+    return (concat top_binds')
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
+*                                                                      *
+************************************************************************
+
+@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
+turn.  Non-recursive case first, then recursive...
+-}
+
+wwBind  :: DynFlags
+        -> FamInstEnvs
+        -> CoreBind
+        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;
+                                -- the caller will convert to Expr/Binding,
+                                -- as appropriate.
+
+wwBind dflags fam_envs (NonRec binder rhs) = do
+    new_rhs <- wwExpr dflags fam_envs rhs
+    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs
+    return [NonRec b e | (b,e) <- new_pairs]
+      -- Generated bindings must be non-recursive
+      -- because the original binding was.
+
+wwBind dflags fam_envs (Rec pairs)
+  = return . Rec <$> concatMapM do_one pairs
+  where
+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs
+                              tryWW dflags fam_envs Recursive binder new_rhs
+
+{-
+@wwExpr@ basically just walks the tree, looking for appropriate
+annotations that can be used. Remember it is @wwBind@ that does the
+matching by looking for strict arguments of the correct type.
+@wwExpr@ is a version that just returns the ``Plain'' Tree.
+-}
+
+wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr
+
+wwExpr _      _ e@(Type {}) = return e
+wwExpr _      _ e@(Coercion {}) = return e
+wwExpr _      _ e@(Lit  {}) = return e
+wwExpr _      _ e@(Var  {}) = return e
+
+wwExpr dflags fam_envs (Lam binder expr)
+  = Lam new_binder <$> wwExpr dflags fam_envs expr
+  where new_binder | isId binder = zapIdUsedOnceInfo binder
+                   | otherwise   = binder
+  -- See Note [Zapping Used Once info in WorkWrap]
+
+wwExpr dflags fam_envs (App f a)
+  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a
+
+wwExpr dflags fam_envs (Tick note expr)
+  = Tick note <$> wwExpr dflags fam_envs expr
+
+wwExpr dflags fam_envs (Cast expr co) = do
+    new_expr <- wwExpr dflags fam_envs expr
+    return (Cast new_expr co)
+
+wwExpr dflags fam_envs (Let bind expr)
+  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr
+
+wwExpr dflags fam_envs (Case expr binder ty alts) = do
+    new_expr <- wwExpr dflags fam_envs expr
+    new_alts <- mapM ww_alt alts
+    let new_binder = zapIdUsedOnceInfo binder
+      -- See Note [Zapping Used Once info in WorkWrap]
+    return (Case new_expr new_binder ty new_alts)
+  where
+    ww_alt (con, binders, rhs) = do
+        new_rhs <- wwExpr dflags fam_envs rhs
+        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b
+                          | b <- binders ]
+           -- See Note [Zapping Used Once info in WorkWrap]
+        return (con, new_binders, new_rhs)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
+*                                                                      *
+************************************************************************
+
+@tryWW@ just accumulates arguments, converts strictness info from the
+front-end into the proper form, then calls @mkWwBodies@ to do
+the business.
+
+The only reason this is monadised is for the unique supply.
+
+Note [Don't w/w INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very important to refrain from w/w-ing an INLINE function (ie one
+with a stable unfolding) because the wrapper will then overwrite the
+old stable unfolding with the wrapper code.
+
+Furthermore, if the programmer has marked something as INLINE,
+we may lose by w/w'ing it.
+
+If the strictness analyser is run twice, this test also prevents
+wrappers (which are INLINEd) from being re-done.  (You can end up with
+several liked-named Ids bouncing around at the same time---absolute
+mischief.)
+
+Notice that we refrain from w/w'ing an INLINE function even if it is
+in a recursive group.  It might not be the loop breaker.  (We could
+test for loop-breaker-hood, but I'm not sure that ever matters.)
+
+Note [Worker-wrapper for INLINABLE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  {-# INLINABLE f #-}
+  f :: Ord a => [a] -> Int -> a
+  f x y = ....f....
+
+where f is strict in y, we might get a more efficient loop by w/w'ing
+f.  But that would make a new unfolding which would overwrite the old
+one! So the function would no longer be INLNABLE, and in particular
+will not be specialised at call sites in other modules.
+
+This comes in practice (#6056).
+
+Solution: do the w/w for strictness analysis, but transfer the Stable
+unfolding to the *worker*.  So we will get something like this:
+
+  {-# INLINE[0] f #-}
+  f :: Ord a => [a] -> Int -> a
+  f d x y = case y of I# y' -> fw d x y'
+
+  {-# INLINABLE[0] fw #-}
+  fw :: Ord a => [a] -> Int# -> a
+  fw d x y' = let y = I# y' in ...f...
+
+How do we "transfer the unfolding"? Easy: by using the old one, wrapped
+in work_fn! See CoreUnfold.mkWorkerUnfolding.
+
+Note [Worker-wrapper for NOINLINE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to disable worker/wrapper for NOINLINE things, but it turns out
+this can cause unnecessary reboxing of values. Consider
+
+  {-# NOINLINE f #-}
+  f :: Int -> a
+  f x = error (show x)
+
+  g :: Bool -> Bool -> Int -> Int
+  g True  True  p = f p
+  g False True  p = p + 1
+  g b     False p = g b True p
+
+the strictness analysis will discover f and g are strict, but because f
+has no wrapper, the worker for g will rebox p. So we get
+
+  $wg x y p# =
+    let p = I# p# in  -- Yikes! Reboxing!
+    case x of
+      False ->
+        case y of
+          False -> $wg False True p#
+          True -> +# p# 1#
+      True ->
+        case y of
+          False -> $wg True True p#
+          True -> case f p of { }
+
+  g x y p = case p of (I# p#) -> $wg x y p#
+
+Now, in this case the reboxing will float into the True branch, and so
+the allocation will only happen on the error path. But it won't float
+inwards if there are multiple branches that call (f p), so the reboxing
+will happen on every call of g. Disaster.
+
+Solution: do worker/wrapper even on NOINLINE things; but move the
+NOINLINE pragma to the worker.
+
+(See #13143 for a real-world example.)
+
+It is crucial that we do this for *all* NOINLINE functions. #10069
+demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but
+fail to deliver:
+
+  data C = C Int# Int#
+
+  {-# NOINLINE c1 #-}
+  c1 :: C -> Int#
+  c1 (C _ n) = n
+
+  {-# NOINLINE fc #-}
+  fc :: C -> Int#
+  fc c = 2 *# c1 c
+
+Failing to w/w `c1`, but still w/wing `fc` leads to the following code:
+
+  c1 :: C -> Int#
+  c1 (C _ n) = n
+
+  $wfc :: Int# -> Int#
+  $wfc n = let c = C 0# n in 2 #* c1 c
+
+  fc :: C -> Int#
+  fc (C _ n) = $wfc n
+
+Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.
+This generalises to any function that derives its strictness signature from
+its callees, so we have to make sure that when a function announces particular
+strictness properties, we have to w/w them accordingly, even if it means
+splitting a NOINLINE function.
+
+Note [Worker activation]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Follows on from Note [Worker-wrapper for INLINABLE functions]
+
+It is *vital* that if the worker gets an INLINABLE pragma (from the
+original function), then the worker has the same phase activation as
+the wrapper (or later).  That is necessary to allow the wrapper to
+inline into the worker's unfolding: see SimplUtils
+Note [Simplifying inside stable unfoldings].
+
+If the original is NOINLINE, it's important that the work inherit the
+original activation. Consider
+
+  {-# NOINLINE expensive #-}
+  expensive x = x + 1
+
+  f y = let z = expensive y in ...
+
+If expensive's worker inherits the wrapper's activation,
+we'll get this (because of the compromise in point (2) of
+Note [Wrapper activation])
+
+  {-# NOINLINE[0] $wexpensive #-}
+  $wexpensive x = x + 1
+  {-# INLINE[0] expensive #-}
+  expensive x = $wexpensive x
+
+  f y = let z = expensive y in ...
+
+and $wexpensive will be immediately inlined into expensive, followed by
+expensive into f. This effectively removes the original NOINLINE!
+
+Otherwise, nothing is lost by giving the worker the same activation as the
+wrapper, because the worker won't have any chance of inlining until the
+wrapper does; there's no point in giving it an earlier activation.
+
+Note [Don't w/w inline small non-loop-breaker things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, we refrain from w/w-ing *small* functions, which are not
+loop breakers, because they'll inline anyway.  But we must take care:
+it may look small now, but get to be big later after other inlining
+has happened.  So we take the precaution of adding an INLINE pragma to
+any such functions.
+
+I made this change when I observed a big function at the end of
+compilation with a useful strictness signature but no w-w.  (It was
+small during demand analysis, we refrained from w/w, and then got big
+when something was inlined in its rhs.) When I measured it on nofib,
+it didn't make much difference; just a few percent improved allocation
+on one benchmark (bspt/Euclid.space).  But nothing got worse.
+
+There is an infelicity though.  We may get something like
+      f = g val
+==>
+      g x = case gw x of r -> I# r
+
+      f {- InlineStable, Template = g val -}
+      f = case gw x of r -> I# r
+
+The code for f duplicates that for g, without any real benefit. It
+won't really be executed, because calls to f will go via the inlining.
+
+Note [Don't CPR join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There's no point in doing CPR on a join point. If the whole function is getting
+CPR'd, then the case expression around the worker function will get pushed into
+the join point by the simplifier, which will have the same effect that CPR would
+have - the result will be returned in an unboxed tuple.
+
+  f z = let join j x y = (x+1, y+1)
+        in case z of A -> j 1 2
+                     B -> j 2 3
+
+  =>
+
+  f z = case $wf z of (# a, b #) -> (a, b)
+  $wf z = case (let join j x y = (x+1, y+1)
+                in case z of A -> j 1 2
+                             B -> j 2 3) of (a, b) -> (# a, b #)
+
+  =>
+
+  f z = case $wf z of (# a, b #) -> (a, b)
+  $wf z = let join j x y = (# x+1, y+1 #)
+          in case z of A -> j 1 2
+                       B -> j 2 3
+
+Doing CPR on a join point would be tricky anyway, as the worker could not be
+a join point because it would not be tail-called. However, doing the *argument*
+part of W/W still works for join points, since the wrapper body will make a tail
+call:
+
+  f z = let join j x y = x + y
+        in ...
+
+  =>
+
+  f z = let join $wj x# y# = x# +# y#
+                 j x y = case x of I# x# ->
+                         case y of I# y# ->
+                         $wj x# y#
+        in ...
+
+Note [Wrapper activation]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+When should the wrapper inlining be active?
+
+1. It must not be active earlier than the current Activation of the
+   Id
+
+2. It should be active at some point, despite (1) because of
+   Note [Worker-wrapper for NOINLINE functions]
+
+3. For ordinary functions with no pragmas we want to inline the
+   wrapper as early as possible (#15056).  Suppose another module
+   defines    f x = g x x
+   and suppose there is some RULE for (g True True).  Then if we have
+   a call (f True), we'd expect to inline 'f' and the RULE will fire.
+   But if f is w/w'd (which it might be), we want the inlining to
+   occur just as if it hadn't been.
+
+   (This only matters if f's RHS is big enough to w/w, but small
+   enough to inline given the call site, but that can happen.)
+
+4. We do not want to inline the wrapper before specialisation.
+         module Foo where
+           f :: Num a => a -> Int -> a
+           f n 0 = n              -- Strict in the Int, hence wrapper
+           f n x = f (n+n) (x-1)
+
+           g :: Int -> Int
+           g x = f x x            -- Provokes a specialisation for f
+
+         module Bar where
+           import Foo
+
+           h :: Int -> Int
+           h x = f 3 x
+
+   In module Bar we want to give specialisations a chance to fire
+   before inlining f's wrapper.
+
+Reminder: Note [Don't w/w INLINE things], so we don't need to worry
+          about INLINE things here.
+
+Conclusion:
+  - If the user said NOINLINE[n], respect that
+  - If the user said NOINLINE, inline the wrapper as late as
+    poss (phase 0). This is a compromise driven by (2) above
+  - Otherwise inline wrapper in phase 2.  That allows the
+    'gentle' simplification pass to apply specialisation rules
+
+Historical note: At one stage I tried making the wrapper inlining
+always-active, and that had a very bad effect on nofib/imaginary/x2n1;
+a wrapper was inlined before the specialisation fired.
+
+Note [Wrapper NoUserInline]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The use an inl_inline of NoUserInline on the wrapper distinguishes
+this pragma from one that was given by the user. In particular, CSE
+will not happen if there is a user-specified pragma, but should happen
+for w/w’ed things (#14186).
+-}
+
+tryWW   :: DynFlags
+        -> FamInstEnvs
+        -> RecFlag
+        -> Id                           -- The fn binder
+        -> CoreExpr                     -- The bound rhs; its innards
+                                        --   are already ww'd
+        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;
+                                        -- if one, then no worker (only
+                                        -- the orig "wrapper" lives on);
+                                        -- if two, then a worker and a
+                                        -- wrapper.
+tryWW dflags fam_envs is_rec fn_id rhs
+  -- See Note [Worker-wrapper for NOINLINE functions]
+
+  | Just stable_unf <- certainlyWillInline dflags fn_info
+  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]
+        -- See Note [Don't w/w INLINE things]
+        -- See Note [Don't w/w inline small non-loop-breaker things]
+
+  | is_fun && is_eta_exp
+  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs
+
+  | is_thunk                                   -- See Note [Thunk splitting]
+  = splitThunk dflags fam_envs is_rec new_fn_id rhs
+
+  | otherwise
+  = return [ (new_fn_id, rhs) ]
+
+  where
+    fn_info      = idInfo fn_id
+    (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info)
+
+    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)
+        -- See Note [Zapping DmdEnv after Demand Analyzer] and
+        -- See Note [Zapping Used Once info in WorkWrap]
+
+    is_fun     = notNull wrap_dmds || isJoinId fn_id
+    -- See Note [Don't eta expand in w/w]
+    is_eta_exp = length wrap_dmds == manifestArity rhs
+    is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)
+                            && not (isUnliftedType (idType fn_id))
+
+{-
+Note [Zapping DmdEnv after Demand Analyzer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the worker-wrapper pass we zap the DmdEnv.  Why?
+ (a) it is never used again
+ (b) it wastes space
+ (c) it becomes incorrect as things are cloned, because
+     we don't push the substitution into it
+
+Why here?
+ * Because we don’t want to do it in the Demand Analyzer, as we never know
+   there when we are doing the last pass.
+ * We want them to be still there at the end of DmdAnal, so that
+   -ddump-str-anal contains them.
+ * We don’t want a second pass just for that.
+ * WorkWrap looks at all bindings anyway.
+
+We also need to do it in TidyCore.tidyLetBndr to clean up after the
+final, worker/wrapper-less run of the demand analyser (see
+Note [Final Demand Analyser run] in DmdAnal).
+
+Note [Zapping Used Once info in WorkWrap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the worker-wrapper pass we zap the used once info in demands and in
+strictness signatures.
+
+Why?
+ * The simplifier may happen to transform code in a way that invalidates the
+   data (see #11731 for an example).
+ * It is not used in later passes, up to code generation.
+
+So as the data is useless and possibly wrong, we want to remove it. The most
+convenient place to do that is the worker wrapper phase, as it runs after every
+run of the demand analyser besides the very last one (which is the one where we
+want to _keep_ the info for the code generator).
+
+We do not do it in the demand analyser for the same reasons outlined in
+Note [Zapping DmdEnv after Demand Analyzer] above.
+
+Note [Don't eta expand in w/w]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A binding where the manifestArity of the RHS is less than idArity of the binder
+means CoreArity didn't eta expand that binding. When this happens, it does so
+for a reason (see Note [exprArity invariant] in CoreArity) and we probably have
+a PAP, cast or trivial expression as RHS.
+
+Performing the worker/wrapper split will implicitly eta-expand the binding to
+idArity, overriding CoreArity's decision. Other than playing fast and loose with
+divergence, it's also broken for newtypes:
+
+  f = (\xy.blah) |> co
+    where
+      co :: (Int -> Int -> Char) ~ T
+
+Then idArity is 2 (despite the type T), and it can have a StrictSig based on a
+threshold of 2. But we can't w/w it without a type error.
+
+The situation is less grave for PAPs, but the implicit eta expansion caused a
+compiler allocation regression in T15164, where huge recursive instance method
+groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the
+simplifier, when simply waiting for the PAPs to inline arrived at the same
+output program.
+
+Note there is the worry here that such PAPs and trivial RHSs might not *always*
+be inlined. That would lead to reboxing, because the analysis tacitly assumes
+that we W/W'd for idArity and will propagate analysis information under that
+assumption. So far, this doesn't seem to matter in practice.
+See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.
+-}
+
+
+---------------------
+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
+         -> UniqSM [(Id, CoreExpr)]
+splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
+    -- The arity should match the signature
+    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_res_info
+    case stuff of
+      Just (work_demands, join_arity, wrap_fn, work_fn) -> do
+        work_uniq <- getUniqueM
+        let work_rhs = work_fn rhs
+            work_act = case fn_inline_spec of  -- See Note [Worker activation]
+                          NoInline -> fn_act
+                          _        -> wrap_act
+
+            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
+                                     , inl_inline = fn_inline_spec
+                                     , inl_sat    = Nothing
+                                     , inl_act    = work_act
+                                     , inl_rule   = FunLike }
+              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]
+              -- inl_act:    see Note [Worker activation]
+              -- inl_rule:   it does not make sense for workers to be constructorlike.
+
+            work_join_arity | isJoinId fn_id = Just join_arity
+                            | otherwise      = Nothing
+              -- worker is join point iff wrapper is join point
+              -- (see Note [Don't CPR join points])
+
+            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)
+                        `setIdOccInfo` occInfo fn_info
+                                -- Copy over occurrence info from parent
+                                -- Notably whether it's a loop breaker
+                                -- Doesn't matter much, since we will simplify next, but
+                                -- seems right-er to do so
+
+                        `setInlinePragma` work_prag
+
+                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding
+                                -- See Note [Worker-wrapper for INLINABLE functions]
+
+                        `setIdStrictness` mkClosedStrictSig work_demands work_res_info
+                                -- Even though we may not be at top level,
+                                -- it's ok to give it an empty DmdEnv
+
+                        `setIdDemandInfo` worker_demand
+
+                        `setIdArity` work_arity
+                                -- Set the arity so that the Core Lint check that the
+                                -- arity is consistent with the demand type goes
+                                -- through
+                        `asJoinId_maybe` work_join_arity
+
+            work_arity = length work_demands
+
+            -- See Note [Demand on the Worker]
+            single_call = saturatedByOneShots arity (demandInfo fn_info)
+            worker_demand | single_call = mkWorkerDemand work_arity
+                          | otherwise   = topDmd
+
+            wrap_rhs  = wrap_fn work_id
+            wrap_act  = case fn_act of  -- See Note [Wrapper activation]
+                           ActiveAfter {} -> fn_act
+                           NeverActive    -> activeDuringFinal
+                           _              -> activeAfterInitial
+            wrap_prag = InlinePragma { inl_src    = SourceText "{-# INLINE"
+                                     , inl_inline = NoUserInline
+                                     , inl_sat    = Nothing
+                                     , inl_act    = wrap_act
+                                     , inl_rule   = rule_match_info }
+                -- inl_act:    see Note [Wrapper activation]
+                -- inl_inline: see Note [Wrapper NoUserInline]
+                -- inl_rule:   RuleMatchInfo is (and must be) unaffected
+
+            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity
+                              `setInlinePragma` wrap_prag
+                              `setIdOccInfo`    noOccInfo
+                                -- Zap any loop-breaker-ness, to avoid bleating from Lint
+                                -- about a loop breaker with an INLINE rule
+
+
+
+        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]
+            -- Worker first, because wrapper mentions it
+
+      Nothing -> return [(fn_id, rhs)]
+  where
+    rhs_fvs         = exprFreeVars rhs
+    fn_inl_prag     = inlinePragInfo fn_info
+    fn_inline_spec  = inl_inline fn_inl_prag
+    fn_act          = inl_act fn_inl_prag
+    rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag
+    fn_unfolding    = unfoldingInfo fn_info
+    arity           = arityInfo fn_info
+                    -- The arity is set by the simplifier using exprEtaExpandArity
+                    -- So it may be more than the number of top-level-visible lambdas
+
+    use_res_info  | isJoinId fn_id = topRes -- Note [Don't CPR join points]
+                  | otherwise      = res_info
+    work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able
+                  | otherwise
+                  = case returnsCPR_maybe res_info of
+                       Just _  -> topRes    -- Cpr stuff done by wrapper; kill it here
+                       Nothing -> res_info  -- Preserve exception/divergence
+
+
+{-
+Note [Demand on the worker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+If the original function is called once, according to its demand info, then
+so is the worker. This is important so that the occurrence analyser can
+attach OneShot annotations to the worker’s lambda binders.
+
+
+Example:
+
+  -- Original function
+  f [Demand=<L,1*C1(U)>] :: (a,a) -> a
+  f = \p -> ...
+
+  -- Wrapper
+  f [Demand=<L,1*C1(U)>] :: a -> a -> a
+  f = \p -> case p of (a,b) -> $wf a b
+
+  -- Worker
+  $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int
+  $wf = \a b -> ...
+
+We need to check whether the original function is called once, with
+sufficiently many arguments. This is done using saturatedByOneShots, which
+takes the arity of the original function (resp. the wrapper) and the demand on
+the original function.
+
+The demand on the worker is then calculated using mkWorkerDemand, and always of
+the form [Demand=<L,1*(C1(...(C1(U))))>]
+
+
+Note [Do not split void functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this rather common form of binding:
+        $j = \x:Void# -> ...no use of x...
+
+Since x is not used it'll be marked as absent.  But there is no point
+in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs.
+
+If x has a more interesting type (eg Int, or Int#), there *is* a point
+in w/w so that we don't pass the argument at all.
+
+Note [Thunk splitting]
+~~~~~~~~~~~~~~~~~~~~~~
+Suppose x is used strictly (never mind whether it has the CPR
+property).
+
+      let
+        x* = x-rhs
+      in body
+
+splitThunk transforms like this:
+
+      let
+        x* = case x-rhs of { I# a -> I# a }
+      in body
+
+Now simplifier will transform to
+
+      case x-rhs of
+        I# a -> let x* = I# a
+                in body
+
+which is what we want. Now suppose x-rhs is itself a case:
+
+        x-rhs = case e of { T -> I# a; F -> I# b }
+
+The join point will abstract over a, rather than over (which is
+what would have happened before) which is fine.
+
+Notice that x certainly has the CPR property now!
+
+In fact, splitThunk uses the function argument w/w splitting
+function, so that if x's demand is deeper (say U(U(L,L),L))
+then the splitting will go deeper too.
+-}
+
+-- See Note [Thunk splitting]
+-- splitThunk converts the *non-recursive* binding
+--      x = e
+-- into
+--      x = let x = e
+--          in case x of
+--               I# y -> let x = I# y in x }
+-- See comments above. Is it not beautifully short?
+-- Moreover, it works just as well when there are
+-- several binders, and if the binders are lifted
+-- E.g.     x = e
+--     -->  x = let x = e in
+--              case x of (a,b) -> let x = (a,b)  in x
+
+splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
+splitThunk dflags fam_envs is_rec fn_id rhs
+  = ASSERT(not (isJoinId fn_id))
+    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]
+       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
+       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
+                   return res
+                   else return [(fn_id, rhs)] }
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stranal/WwLib.hs
@@ -0,0 +1,1192 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
+             , deepSplitProductType_maybe, findTypeShape
+             , isWorkerSmallEnough
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils        ( exprType, mkCast )
+import Id
+import IdInfo           ( JoinArity )
+import DataCon
+import Demand
+import MkCore           ( mkAbsentErrorApp, mkCoreUbxTup
+                        , mkCoreApp, mkCoreLet )
+import MkId             ( voidArgId, voidPrimId )
+import TysWiredIn       ( tupleDataCon )
+import TysPrim          ( voidPrimTy )
+import Literal          ( absentLiteralOf, rubbishLit )
+import VarEnv           ( mkInScopeSet )
+import VarSet           ( VarSet )
+import Type
+import RepType          ( isVoidTy, typePrimRep )
+import Coercion
+import FamInstEnv
+import BasicTypes       ( Boxity(..) )
+import TyCon
+import UniqSupply
+import Unique
+import Maybes
+import Util
+import Outputable
+import DynFlags
+import FastString
+import ListSetOps
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
+*                                                                      *
+************************************************************************
+
+Here's an example.  The original function is:
+
+\begin{verbatim}
+g :: forall a . Int -> [a] -> a
+
+g = \/\ a -> \ x ys ->
+        case x of
+          0 -> head ys
+          _ -> head (tail ys)
+\end{verbatim}
+
+From this, we want to produce:
+\begin{verbatim}
+-- wrapper (an unfolding)
+g :: forall a . Int -> [a] -> a
+
+g = \/\ a -> \ x ys ->
+        case x of
+          I# x# -> $wg a x# ys
+            -- call the worker; don't forget the type args!
+
+-- worker
+$wg :: forall a . Int# -> [a] -> a
+
+$wg = \/\ a -> \ x# ys ->
+        let
+            x = I# x#
+        in
+            case x of               -- note: body of g moved intact
+              0 -> head ys
+              _ -> head (tail ys)
+\end{verbatim}
+
+Something we have to be careful about:  Here's an example:
+
+\begin{verbatim}
+-- "f" strictness: U(P)U(P)
+f (I# a) (I# b) = a +# b
+
+g = f   -- "g" strictness same as "f"
+\end{verbatim}
+
+\tr{f} will get a worker all nice and friendly-like; that's good.
+{\em But we don't want a worker for \tr{g}}, even though it has the
+same strictness as \tr{f}.  Doing so could break laziness, at best.
+
+Consequently, we insist that the number of strictness-info items is
+exactly the same as the number of lambda-bound arguments.  (This is
+probably slightly paranoid, but OK in practice.)  If it isn't the
+same, we ``revise'' the strictness info, so that we won't propagate
+the unusable strictness-info into the interfaces.
+
+
+************************************************************************
+*                                                                      *
+\subsection{The worker wrapper core}
+*                                                                      *
+************************************************************************
+
+@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
+-}
+
+type WwResult
+  = ([Demand],              -- Demands for worker (value) args
+     JoinArity,             -- Number of worker (type OR value) args
+     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
+     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs
+
+mkWwBodies :: DynFlags
+           -> FamInstEnvs
+           -> VarSet         -- Free vars of RHS
+                             -- See Note [Freshen WW arguments]
+           -> Id             -- The original function
+           -> [Demand]       -- Strictness of original function
+           -> DmdResult      -- Info about function result
+           -> UniqSM (Maybe WwResult)
+
+-- wrap_fn_args E       = \x y -> E
+-- work_fn_args E       = E x y
+
+-- wrap_fn_str E        = case x of { (a,b) ->
+--                        case a of { (a1,a2) ->
+--                        E a1 a2 b y }}
+-- work_fn_str E        = \a1 a2 b y ->
+--                        let a = (a1,a2) in
+--                        let x = (a,b) in
+--                        E
+
+mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info
+  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
+                -- See Note [Freshen WW arguments]
+
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+             <- mkWWargs empty_subst fun_ty demands
+        ; (useful1, work_args, wrap_fn_str, work_fn_str)
+             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args
+
+        -- Do CPR w/w.  See Note [Always do CPR w/w]
+        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
+              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info
+
+        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
+              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
+              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
+              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
+
+        ; if isWorkerSmallEnough dflags work_args
+             && not (too_many_args_for_join_point wrap_args)
+             && ((useful1 && not only_one_void_argument) || useful2)
+          then return (Just (worker_args_dmds, length work_call_args,
+                       wrapper_body, worker_body))
+          else return Nothing
+        }
+        -- We use an INLINE unconditionally, even if the wrapper turns out to be
+        -- something trivial like
+        --      fw = ...
+        --      f = __inline__ (coerce T fw)
+        -- The point is to propagate the coerce to f's call sites, so even though
+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
+        -- fw from being inlined into f's RHS
+  where
+    fun_ty        = idType fun_id
+    mb_join_arity = isJoinId_maybe fun_id
+    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)
+                          -- See Note [Do not unpack class dictionaries]
+
+    -- Note [Do not split void functions]
+    only_one_void_argument
+      | [d] <- demands
+      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
+      , isAbsDmd d && isVoidTy arg_ty1
+      = True
+      | otherwise
+      = False
+
+    -- Note [Join points returning functions]
+    too_many_args_for_join_point wrap_args
+      | Just join_arity <- mb_join_arity
+      , wrap_args `lengthExceeds` join_arity
+      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>
+                     int join_arity <+> text "but" <+>
+                     int (length wrap_args) <+> text "args")
+        True
+      | otherwise
+      = False
+
+-- See Note [Limit w/w arity]
+isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
+isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
+    -- We count only Free variables (isId) to skip Type, Kind
+    -- variables which have no runtime representation.
+
+{-
+Note [Always do CPR w/w]
+~~~~~~~~~~~~~~~~~~~~~~~~
+At one time we refrained from doing CPR w/w for thunks, on the grounds that
+we might duplicate work.  But that is already handled by the demand analyser,
+which doesn't give the CPR proprety if w/w might waste work: see
+Note [CPR for thunks] in DmdAnal.
+
+And if something *has* been given the CPR property and we don't w/w, it's
+a disaster, because then the enclosing function might say it has the CPR
+property, but now doesn't and there a cascade of disaster.  A good example
+is #5920.
+
+Note [Limit w/w arity]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Guard against high worker arity as it generates a lot of stack traffic.
+A simplified example is #11565#comment:6
+
+Current strategy is very simple: don't perform w/w transformation at all
+if the result produces a wrapper with arity higher than -fmax-worker-args=.
+
+It is a bit all or nothing, consider
+
+        f (x,y) (a,b,c,d,e ... , z) = rhs
+
+Currently we will remove all w/w ness entirely. But actually we could
+w/w on the (x,y) pair... it's the huge product that is the problem.
+
+Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
+solve f. But we can get a lot of args from deeply-nested products:
+
+        g (a, (b, (c, (d, ...)))) = rhs
+
+This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
+given some "fuel" saying how many arguments it could add; when we ran
+out of fuel it would stop w/wing.
+Still not very clever because it had a left-right bias.
+
+************************************************************************
+*                                                                      *
+\subsection{Making wrapper args}
+*                                                                      *
+************************************************************************
+
+During worker-wrapper stuff we may end up with an unlifted thing
+which we want to let-bind without losing laziness.  So we
+add a void argument.  E.g.
+
+        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
+==>
+        fw = /\ a -> \void -> E
+        f  = /\ a -> \x y z -> fw realworld
+
+We use the state-token type which generates no code.
+-}
+
+mkWorkerArgs :: DynFlags -> [Var]
+             -> Type    -- Type of body
+             -> ([Var], -- Lambda bound args
+                 [Var]) -- Args at call site
+mkWorkerArgs dflags args res_ty
+    | any isId args || not needsAValueLambda
+    = (args, args)
+    | otherwise
+    = (args ++ [voidArgId], args ++ [voidPrimId])
+    where
+      -- See "Making wrapper args" section above
+      needsAValueLambda =
+        lifted
+        -- We may encounter a levity-polymorphic result, in which case we
+        -- conservatively assume that we have laziness that needs preservation.
+        -- See #15186.
+        || not (gopt Opt_FunToThunk dflags)
+           -- see Note [Protecting the last value argument]
+
+      -- Might the result be lifted?
+      lifted =
+        case isLiftedType_maybe res_ty of
+          Just lifted -> lifted
+          Nothing     -> True
+
+{-
+Note [Protecting the last value argument]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the user writes (\_ -> E), they might be intentionally disallowing
+the sharing of E. Since absence analysis and worker-wrapper are keen
+to remove such unused arguments, we add in a void argument to prevent
+the function from becoming a thunk.
+
+The user can avoid adding the void argument with the -ffun-to-thunk
+flag. However, this can create sharing, which may be bad in two ways. 1) It can
+create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
+removes the last argument from a function f, then f now looks like a thunk, and
+so f can't be inlined *under a lambda*.
+
+Note [Join points and beta-redexes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Originally, the worker would invoke the original function by calling it with
+arguments, thus producing a beta-redex for the simplifier to munch away:
+
+  \x y z -> e => (\x y z -> e) wx wy wz
+
+Now that we have special rules about join points, however, this is Not Good if
+the original function is itself a join point, as then it may contain invocations
+of other join points:
+
+  join j1 x = ...
+  join j2 y = if y == 0 then 0 else j1 y
+
+  =>
+
+  join j1 x = ...
+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
+  join j2 y = case y of I# y# -> jump $wj2 y#
+
+There can't be an intervening lambda between a join point's declaration and its
+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:
+
+  ...
+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
+  ...
+
+Hence we simply do the beta-reduction here. (This would be harder if we had to
+worry about hygiene, but luckily wy is freshly generated.)
+
+Note [Join points returning functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is crucial that the arity of a join point depends on its *callers,* not its
+own syntax. What this means is that a join point can have "extra lambdas":
+
+f :: Int -> Int -> (Int, Int) -> Int
+f x y = join j (z, w) = \(u, v) -> ...
+        in jump j (x, y)
+
+Typically this happens with functions that are seen as computing functions,
+rather than being curried. (The real-life example was GraphOps.addConflicts.)
+
+When we create the wrapper, it *must* be in "eta-contracted" form so that the
+jump has the right number of arguments:
+
+f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
+             j (z, w)  = jump $wj z w
+
+(See Note [Join points and beta-redexes] for where the lets come from.) If j
+were a function, we would instead say
+
+f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
+            j (z, w) (u, v) = $wj z w u v
+
+Notice that the worker ends up with the same lambdas; it's only the wrapper we
+have to be concerned about.
+
+FIXME Currently the functionality to produce "eta-contracted" wrappers is
+unimplemented; we simply give up.
+
+************************************************************************
+*                                                                      *
+\subsection{Coercion stuff}
+*                                                                      *
+************************************************************************
+
+We really want to "look through" coerces.
+Reason: I've seen this situation:
+
+        let f = coerce T (\s -> E)
+        in \x -> case x of
+                    p -> coerce T' f
+                    q -> \s -> E2
+                    r -> coerce T' f
+
+If only we w/w'd f, we'd get
+        let f = coerce T (\s -> fw s)
+            fw = \s -> E
+        in ...
+
+Now we'll inline f to get
+
+        let fw = \s -> E
+        in \x -> case x of
+                    p -> fw
+                    q -> \s -> E2
+                    r -> fw
+
+Now we'll see that fw has arity 1, and will arity expand
+the \x to get what we want.
+-}
+
+-- mkWWargs just does eta expansion
+-- is driven off the function type and arity.
+-- It chomps bites off foralls, arrows, newtypes
+-- and keeps repeating that until it's satisfied the supplied arity
+
+mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type
+                                --   See Note [Freshen WW arguments]
+         -> Type                -- The type of the function
+         -> [Demand]     -- Demands and one-shot info for value arguments
+         -> UniqSM  ([Var],            -- Wrapper args
+                     CoreExpr -> CoreExpr,      -- Wrapper fn
+                     CoreExpr -> CoreExpr,      -- Worker fn
+                     Type)                      -- Type of wrapper body
+
+mkWWargs subst fun_ty demands
+  | null demands
+  = return ([], id, id, substTy subst fun_ty)
+
+  | (dmd:demands') <- demands
+  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
+  = do  { uniq <- getUniqueM
+        ; let arg_ty' = substTy subst arg_ty
+              id = mk_wrap_arg uniq arg_ty' dmd
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+              <- mkWWargs subst fun_ty' demands'
+        ; return (id : wrap_args,
+                  Lam id . wrap_fn_args,
+                  apply_or_bind_then work_fn_args (varToCoreExpr id),
+                  res_ty) }
+
+  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
+  = do  { uniq <- getUniqueM
+        ; let (subst', tv') = cloneTyVarBndr subst tv uniq
+                -- See Note [Freshen WW arguments]
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+             <- mkWWargs subst' fun_ty' demands
+        ; return (tv' : wrap_args,
+                  Lam tv' . wrap_fn_args,
+                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),
+                  res_ty) }
+
+  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty
+        -- The newtype case is for when the function has
+        -- a newtype after the arrow (rare)
+        --
+        -- It's also important when we have a function returning (say) a pair
+        -- wrapped in a  newtype, at least if CPR analysis can look
+        -- through such newtypes, which it probably can since they are
+        -- simply coerces.
+
+  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+            <-  mkWWargs subst rep_ty demands
+       ; let co' = substCo subst co
+       ; return (wrap_args,
+                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),
+                  \e -> work_fn_args (Cast e co'),
+                  res_ty) }
+
+  | otherwise
+  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand
+    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow
+  where
+    -- See Note [Join points and beta-redexes]
+    apply_or_bind_then k arg (Lam bndr body)
+      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!
+    apply_or_bind_then k arg fun
+      = k $ mkCoreApp (text "mkWWargs") fun arg
+applyToVars :: [Var] -> CoreExpr -> CoreExpr
+applyToVars vars fn = mkVarApps fn vars
+
+mk_wrap_arg :: Unique -> Type -> Demand -> Id
+mk_wrap_arg uniq ty dmd
+  = mkSysLocalOrCoVar (fsLit "w") uniq ty
+       `setIdDemandInfo` dmd
+
+{- Note [Freshen WW arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Wen we do a worker/wrapper split, we must not in-scope names as the arguments
+of the worker, else we'll get name capture.  E.g.
+
+   -- y1 is in scope from further out
+   f x = ..y1..
+
+If we accidentally choose y1 as a worker argument disaster results:
+
+   fww y1 y2 = let x = (y1,y2) in ...y1...
+
+To avoid this:
+
+  * We use a fresh unique for both type-variable and term-variable binders
+    Originally we lacked this freshness for type variables, and that led
+    to the very obscure #12562.  (A type variable in the worker shadowed
+    an outer term-variable binding.)
+
+  * Because of this cloning we have to substitute in the type/kind of the
+    new binders.  That's why we carry the TCvSubst through mkWWargs.
+
+    So we need a decent in-scope set, just in case that type/kind
+    itself has foralls.  We get this from the free vars of the RHS of the
+    function since those are the only variables that might be captured.
+    It's a lazy thunk, which will only be poked if the type/kind has a forall.
+
+    Another tricky case was when f :: forall a. a -> forall a. a->a
+    (i.e. with shadowing), and then the worker used the same 'a' twice.
+
+************************************************************************
+*                                                                      *
+\subsection{Strictness stuff}
+*                                                                      *
+************************************************************************
+-}
+
+mkWWstr :: DynFlags
+        -> FamInstEnvs
+        -> Bool    -- True <=> INLINEABLE pragma on this function defn
+                   -- See Note [Do not unpack class dictionaries]
+        -> [Var]                                -- Wrapper args; have their demand info on them
+                                                --  *Includes type variables*
+        -> UniqSM (Bool,                        -- Is this useful
+                   [Var],                       -- Worker args
+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
+                                                -- and without its lambdas
+                                                -- This fn adds the unboxing
+
+                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
+                                                -- and lacking its lambdas.
+                                                -- This fn does the reboxing
+mkWWstr dflags fam_envs has_inlineable_prag args
+  = go args
+  where
+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
+
+    go []           = return (False, [], nop_fn, nop_fn)
+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args
+                         ; return ( useful1 || useful2
+                                  , args1 ++ args2
+                                  , wrap_fn1 . wrap_fn2
+                                  , work_fn1 . work_fn2) }
+
+{-
+Note [Unpacking arguments with product and polymorphic demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The argument is unpacked in a case if it has a product type and has a
+strict *and* used demand put on it. I.e., arguments, with demands such
+as the following ones:
+
+   <S,U(U, L)>
+   <S(L,S),U>
+
+will be unpacked, but
+
+   <S,U> or <B,U>
+
+will not, because the pieces aren't used. This is quite important otherwise
+we end up unpacking massive tuples passed to the bottoming function. Example:
+
+        f :: ((Int,Int) -> String) -> (Int,Int) -> a
+        f g pr = error (g pr)
+
+        main = print (f fst (1, error "no"))
+
+Does 'main' print "error 1" or "error no"?  We don't really want 'f'
+to unbox its second argument.  This actually happened in GHC's onwn
+source code, in Packages.applyPackageFlag, which ended up un-boxing
+the enormous DynFlags tuple, and being strict in the
+as-yet-un-filled-in pkgState files.
+-}
+
+----------------------
+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
+--   *  wrap_fn assumes wrap_arg is in scope,
+--        brings into scope work_args (via cases)
+--   * work_fn assumes work_args are in scope, a
+--        brings into scope wrap_arg (via lets)
+-- See Note [How to do the worker/wrapper split]
+mkWWstr_one :: DynFlags -> FamInstEnvs
+            -> Bool    -- True <=> INLINEABLE pragma on this function defn
+                       -- See Note [Do not unpack class dictionaries]
+            -> Var
+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+mkWWstr_one dflags fam_envs has_inlineable_prag arg
+  | isTyVar arg
+  = return (False, [arg],  nop_fn, nop_fn)
+
+  | isAbsDmd dmd
+  , Just work_fn <- mk_absent_let dflags arg
+     -- Absent case.  We can't always handle absence for arbitrary
+     -- unlifted types, so we need to choose just the cases we can
+     -- (that's what mk_absent_let does)
+  = return (True, [], nop_fn, work_fn)
+
+  | isStrictDmd dmd
+  , Just cs <- splitProdDmd_maybe dmd
+      -- See Note [Unpacking arguments with product and polymorphic demands]
+  , not (has_inlineable_prag && isClassPred arg_ty)
+      -- See Note [Do not unpack class dictionaries]
+  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty
+  , cs `equalLength` inst_con_arg_tys
+      -- See Note [mkWWstr and unsafeCoerce]
+  = unbox_one dflags fam_envs arg cs stuff
+
+  | isSeqDmd dmd   -- For seqDmd, splitProdDmd_maybe will return Nothing, but
+                   -- it should behave like <S, U(AAAA)>, for some suitable arity
+  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty
+  , let abs_dmds = map (const absDmd) inst_con_arg_tys
+  = unbox_one dflags fam_envs arg abs_dmds stuff
+
+  | otherwise   -- Other cases
+  = return (False, [arg], nop_fn, nop_fn)
+
+  where
+    arg_ty = idType arg
+    dmd    = idDemandInfo arg
+
+unbox_one :: DynFlags -> FamInstEnvs -> Var
+          -> [Demand]
+          -> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+unbox_one dflags fam_envs arg cs
+          (data_con, inst_tys, inst_con_arg_tys, co)
+  = do { (uniq1:uniqs) <- getUniquesM
+        ; let   -- See Note [Add demands for strict constructors]
+                cs'       = addDataConStrictness data_con cs
+                unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs'
+                unbox_fn  = mkUnpackCase (Var arg) co uniq1
+                                         data_con unpk_args
+                arg_no_unf = zapStableUnfolding arg
+                             -- See Note [Zap unfolding when beta-reducing]
+                             -- in Simplify.hs; and see #13890
+                rebox_fn   = Let (NonRec arg_no_unf con_app)
+                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args
+         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
+                           -- Don't pass the arg, rebox instead
+  where
+    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
+
+----------------------
+nop_fn :: CoreExpr -> CoreExpr
+nop_fn body = body
+
+addDataConStrictness :: DataCon -> [Demand] -> [Demand]
+-- See Note [Add demands for strict constructors]
+addDataConStrictness con ds
+  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )
+    zipWith add ds strs
+  where
+    strs = dataConRepStrictness con
+    add dmd str | isMarkedStrict str = strictifyDmd dmd
+                | otherwise          = dmd
+
+{- Note [How to do the worker/wrapper split]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The worker-wrapper transformation, mkWWstr_one, takes into account
+several possibilities to decide if the function is worthy for
+splitting:
+
+1. If an argument is absent, it would be silly to pass it to
+   the worker.  Hence the isAbsDmd case.  This case must come
+   first because a demand like <S,A> or <B,A> is possible.
+   E.g. <B,A> comes from a function like
+       f x = error "urk"
+   and <S,A> can come from Note [Add demands for strict constructors]
+
+2. If the argument is evaluated strictly, and we can split the
+   product demand (splitProdDmd_maybe), then unbox it and w/w its
+   pieces.  For example
+
+    f :: (Int, Int) -> Int
+    f p = (case p of (a,b) -> a) + 1
+  is split to
+    f :: (Int, Int) -> Int
+    f p = case p of (a,b) -> $wf a
+
+    $wf :: Int -> Int
+    $wf a = a + 1
+
+  and
+    g :: Bool -> (Int, Int) -> Int
+    g c p = case p of (a,b) ->
+               if c then a else b
+  is split to
+   g c p = case p of (a,b) -> $gw c a b
+   $gw c a b = if c then a else b
+
+2a But do /not/ split if the components are not used; that is, the
+   usage is just 'Used' rather than 'UProd'. In this case
+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing
+   a massive tuple which is barely used.  Example:
+
+        f :: ((Int,Int) -> String) -> (Int,Int) -> a
+        f g pr = error (g pr)
+
+        main = print (f fst (1, error "no"))
+
+   Here, f does not take 'pr' apart, and it's stupid to do so.
+   Imagine that it had millions of fields. This actually happened
+   in GHC itself where the tuple was DynFlags
+
+3. A plain 'seqDmd', which is head-strict with usage UHead, can't
+   be split by splitProdDmd_maybe.  But we want it to behave just
+   like U(AAAA) for suitable number of absent demands. So we have
+   a special case for it, with arity coming from the data constructor.
+
+Note [Worker-wrapper for bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used not to split if the result is bottom.
+[Justification:  there's no efficiency to be gained.]
+
+But it's sometimes bad not to make a wrapper.  Consider
+        fw = \x# -> let x = I# x# in case e of
+                                        p1 -> error_fn x
+                                        p2 -> error_fn x
+                                        p3 -> the real stuff
+The re-boxing code won't go away unless error_fn gets a wrapper too.
+[We don't do reboxing now, but in general it's better to pass an
+unboxed thing to f, and have it reboxed in the error cases....]
+
+Note [Add demands for strict constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this program (due to Roman):
+
+    data X a = X !a
+
+    foo :: X Int -> Int -> Int
+    foo (X a) n = go 0
+     where
+       go i | i < n     = a + go (i+1)
+            | otherwise = 0
+
+We want the worker for 'foo' too look like this:
+
+    $wfoo :: Int# -> Int# -> Int#
+
+with the first argument unboxed, so that it is not eval'd each time
+around the 'go' loop (which would otherwise happen, since 'foo' is not
+strict in 'a').  It is sound for the wrapper to pass an unboxed arg
+because X is strict, so its argument must be evaluated.  And if we
+*don't* pass an unboxed argument, we can't even repair it by adding a
+`seq` thus:
+
+    foo (X a) n = a `seq` go 0
+
+because the seq is discarded (very early) since X is strict!
+
+So here's what we do
+
+* We leave the demand-analysis alone.  The demand on 'a' in the
+  definition of 'foo' is <L, U(U)>; the strictness info is Lazy
+  because foo's body may or may not evaluate 'a'; but the usage info
+  says that 'a' is unpacked and its content is used.
+
+* During worker/wrapper, if we unpack a strict constructor (as we do
+  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
+  the strict arguments of the data constructor.
+
+* That in turn means that, if the usage info supports doing so
+  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
+  -- even though the original demand (e.g. on 'a') was lazy.
+
+* What does "bump up the strictness" mean?  Just add a head-strict
+  demand to the strictness!  Even for a demand like <L,A> we can
+  safely turn it into <S,A>; remember case (1) of
+  Note [How to do the worker/wrapper split].
+
+The net effect is that the w/w transformation is more aggressive about
+unpacking the strict arguments of a data constructor, when that
+eagerness is supported by the usage info.
+
+There is the usual danger of reboxing, which as usual we ignore. But
+if X is monomorphic, and has an UNPACK pragma, then this optimisation
+is even more important.  We don't want the wrapper to rebox an unboxed
+argument, and pass an Int to $wfoo!
+
+This works in nested situations like
+
+    data family Bar a
+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
+    newtype instance Bar Int = Bar Int
+
+    foo :: Bar ((Int, Int), Int) -> Int -> Int
+    foo f k = case f of BarPair x y ->
+              case burble of
+                 True -> case x of
+                           BarPair p q -> ...
+                 False -> ...
+
+The extra eagerness lets us produce a worker of type:
+     $wfoo :: Int# -> Int# -> Int# -> Int -> Int
+     $wfoo p# q# y# = ...
+
+even though the `case x` is only lazily evaluated.
+
+--------- Historical note ------------
+We used to add data-con strictness demands when demand analysing case
+expression. However, it was noticed in #15696 that this misses some cases. For
+instance, consider the program (from T10482)
+
+    data family Bar a
+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
+    newtype instance Bar Int = Bar Int
+
+    foo :: Bar ((Int, Int), Int) -> Int -> Int
+    foo f k =
+      case f of
+        BarPair x y -> case burble of
+                          True -> case x of
+                                    BarPair p q -> ...
+                          False -> ...
+
+We really should be able to assume that `p` is already evaluated since it came
+from a strict field of BarPair. This strictness would allow us to produce a
+worker of type:
+
+    $wfoo :: Int# -> Int# -> Int# -> Int -> Int
+    $wfoo p# q# y# = ...
+
+even though the `case x` is only lazily evaluated
+
+Indeed before we fixed #15696 this would happen since we would float the inner
+`case x` through the `case burble` to get:
+
+    foo f k =
+      case f of
+        BarPair x y -> case x of
+                          BarPair p q -> case burble of
+                                          True -> ...
+                                          False -> ...
+
+However, after fixing #15696 this could no longer happen (for the reasons
+discussed in ticket:15696#comment:76). This means that the demand placed on `f`
+would then be significantly weaker (since the False branch of the case on
+`burble` is not strict in `p` or `q`).
+
+Consequently, we now instead account for data-con strictness in mkWWstr_one,
+applying the strictness demands to the final result of DmdAnal. The result is
+that we get the strict demand signature we wanted even if we can't float
+the case on `x` up through the case on `burble`.
+
+
+Note [mkWWstr and unsafeCoerce]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+By using unsafeCoerce, it is possible to make the number of demands fail to
+match the number of constructor arguments; this happened in #8037.
+If so, the worker/wrapper split doesn't work right and we get a Core Lint
+bug.  The fix here is simply to decline to do w/w if that happens.
+
+Note [Record evaluated-ness in worker/wrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   data T = MkT !Int Int
+
+   f :: T -> T
+   f x = e
+
+and f's is strict, and has the CPR property.  The we are going to generate
+this w/w split
+
+   f x = case x of
+           MkT x1 x2 -> case $wf x1 x2 of
+                           (# r1, r2 #) -> MkT r1 r2
+
+   $wfw x1 x2 = let x = MkT x1 x2 in
+                case e of
+                  MkT r1 r2 -> (# r1, r2 #)
+
+Note that
+
+* In the worker $wf, inside 'e' we can be sure that x1 will be
+  evaluated (it came from unpacking the argument MkT.  But that's no
+  immediately apparent in $wf
+
+* In the wrapper 'f', which we'll inline at call sites, we can be sure
+  that 'r1' has been evaluated (because it came from unpacking the result
+  MkT.  But that is not immediately apparent from the wrapper code.
+
+Missing these facts isn't unsound, but it loses possible future
+opportunities for optimisation.
+
+Solution: use setCaseBndrEvald when creating
+ (A) The arg binders x1,x2 in mkWstr_one
+         See #13077, test T13077
+ (B) The result binders r1,r2 in mkWWcpr_help
+         See Trace #13077, test T13077a
+         And #13027 comment:20, item (4)
+to record that the relevant binder is evaluated.
+
+
+************************************************************************
+*                                                                      *
+         Type scrutiny that is specific to demand analysis
+*                                                                      *
+************************************************************************
+
+Note [Do not unpack class dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+   f :: Ord a => [a] -> Int -> a
+   {-# INLINABLE f #-}
+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
+(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which
+can still be specialised by the type-class specialiser, something like
+   fw :: Ord a => [a] -> Int# -> a
+
+BUT if f is strict in the Ord dictionary, we might unpack it, to get
+   fw :: (a->a->Bool) -> [a] -> Int# -> a
+and the type-class specialiser can't specialise that.  An example is
+#6056.
+
+But in any other situation a dictionary is just an ordinary value,
+and can be unpacked.  So we track the INLINABLE pragma, and switch
+off the unpacking in mkWWstr_one (see the isClassPred test).
+
+Historical note: #14955 describes how I got this fix wrong
+the first time.
+-}
+
+deepSplitProductType_maybe
+    :: FamInstEnvs -> Type
+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
+-- then  dc @ tys (args::arg_tys) :: rep_ty
+--       co :: ty ~ rep_ty
+-- Why do we return the strictness of the data-con arguments?
+-- Answer: see Note [Record evaluated-ness in worker/wrapper]
+deepSplitProductType_maybe fam_envs ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkRepReflCo ty, ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  , Just con <- isDataProductTyCon_maybe tc
+  , let arg_tys = dataConInstArgTys con tc_args
+        strict_marks = dataConRepStrictness con
+  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
+deepSplitProductType_maybe _ _ = Nothing
+
+deepSplitCprType_maybe
+    :: FamInstEnvs -> ConTag -> Type
+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
+-- then  dc @ tys (args::arg_tys) :: rep_ty
+--       co :: ty ~ rep_ty
+-- Why do we return the strictness of the data-con arguments?
+-- Answer: see Note [Record evaluated-ness in worker/wrapper]
+deepSplitCprType_maybe fam_envs con_tag ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkRepReflCo ty, ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  , isDataTyCon tc
+  , let cons = tyConDataCons tc
+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the
+                                 -- type constructor via a .hs-bool file (#8743)
+  , let con = cons `getNth` (con_tag - fIRST_TAG)
+        arg_tys = dataConInstArgTys con tc_args
+        strict_marks = dataConRepStrictness con
+  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)
+deepSplitCprType_maybe _ _ _ = Nothing
+
+findTypeShape :: FamInstEnvs -> Type -> TypeShape
+-- Uncover the arrow and product shape of a type
+-- The data type TypeShape is defined in Demand
+-- See Note [Trimming a demand to a type] in Demand
+findTypeShape fam_envs ty
+  | Just (tc, tc_args)  <- splitTyConApp_maybe ty
+  , Just con <- isDataProductTyCon_maybe tc
+  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)
+
+  | Just (_, res) <- splitFunTy_maybe ty
+  = TsFun (findTypeShape fam_envs res)
+
+  | Just (_, ty') <- splitForAllTy_maybe ty
+  = findTypeShape fam_envs ty'
+
+  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
+  = findTypeShape fam_envs ty'
+
+  | otherwise
+  = TsUnk
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{CPR stuff}
+*                                                                      *
+************************************************************************
+
+
+@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
+info and adds in the CPR transformation.  The worker returns an
+unboxed tuple containing non-CPR components.  The wrapper takes this
+tuple and re-produces the correct structured output.
+
+The non-CPR results appear ordered in the unboxed tuple as if by a
+left-to-right traversal of the result structure.
+-}
+
+mkWWcpr :: Bool
+        -> FamInstEnvs
+        -> Type                              -- function body type
+        -> DmdResult                         -- CPR analysis results
+        -> UniqSM (Bool,                     -- Is w/w'ing useful?
+                   CoreExpr -> CoreExpr,     -- New wrapper
+                   CoreExpr -> CoreExpr,     -- New worker
+                   Type)                     -- Type of worker's body
+
+mkWWcpr opt_CprAnal fam_envs body_ty res
+    -- CPR explicitly turned off (or in -O0)
+  | not opt_CprAnal = return (False, id, id, body_ty)
+    -- CPR is turned on by default for -O and O2
+  | otherwise
+  = case returnsCPR_maybe res of
+       Nothing      -> return (False, id, id, body_ty)  -- No CPR info
+       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
+                    -> mkWWcpr_help stuff
+                    |  otherwise
+                       -- See Note [non-algebraic or open body type warning]
+                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
+                       return (False, id, id, body_ty)
+
+mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)
+             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
+
+mkWWcpr_help (data_con, inst_tys, arg_tys, co)
+  | [arg1@(arg_ty1, _)] <- arg_tys
+  , isUnliftedType arg_ty1
+        -- Special case when there is a single result of unlifted type
+        --
+        -- Wrapper:     case (..call worker..) of x -> C x
+        -- Worker:      case (   ..body..    ) of C x -> x
+  = do { (work_uniq : arg_uniq : _) <- getUniquesM
+       ; let arg       = mk_ww_local arg_uniq arg1
+             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
+
+       ; return ( True
+                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
+                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)
+                                -- varToCoreExpr important here: arg can be a coercion
+                                -- Lacking this caused #10658
+                , arg_ty1 ) }
+
+  | otherwise   -- The general case
+        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
+        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
+  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM
+       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)
+             args        = zipWith mk_ww_local uniqs arg_tys
+             ubx_tup_ty  = exprType ubx_tup_app
+             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)
+             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
+
+       ; return (True
+                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
+                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
+                , ubx_tup_ty ) }
+
+mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
+-- (mkUnpackCase e co uniq Con args body)
+--      returns
+-- case e |> co of bndr { Con args -> body }
+
+mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]
+  = Tick tickish (mkUnpackCase e co uniq con args body)
+mkUnpackCase scrut co uniq boxing_con unpk_args body
+  = Case casted_scrut bndr (exprType body)
+         [(DataAlt boxing_con, unpk_args, body)]
+  where
+    casted_scrut = scrut `mkCast` co
+    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)
+
+{-
+Note [non-algebraic or open body type warning]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are a few cases where the W/W transformation is told that something
+returns a constructor, but the type at hand doesn't really match this. One
+real-world example involves unsafeCoerce:
+  foo = IO a
+  foo = unsafeCoerce c_exit
+  foreign import ccall "c_exit" c_exit :: IO ()
+Here CPR will tell you that `foo` returns a () constructor for sure, but trying
+to create a worker/wrapper for type `a` obviously fails.
+(This was a real example until ee8e792  in libraries/base.)
+
+It does not seem feasible to avoid all such cases already in the analyser (and
+after all, the analysis is not really wrong), so we simply do nothing here in
+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
+other cases where something went avoidably wrong.
+
+
+Note [Profiling and unpacking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the original function looked like
+        f = \ x -> {-# SCC "foo" #-} E
+
+then we want the CPR'd worker to look like
+        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
+and definitely not
+        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
+
+This transform doesn't move work or allocation
+from one cost centre to another.
+
+Later [SDM]: presumably this is because we want the simplifier to
+eliminate the case, and the scc would get in the way?  I'm ok with
+including the case itself in the cost centre, since it is morally
+part of the function (post transformation) anyway.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Utilities}
+*                                                                      *
+************************************************************************
+
+Note [Absent errors]
+~~~~~~~~~~~~~~~~~~~~
+We make a new binding for Ids that are marked absent, thus
+   let x = absentError "x :: Int"
+The idea is that this binding will never be used; but if it
+buggily is used we'll get a runtime error message.
+
+Coping with absence for *unlifted* types is important; see, for
+example, #4306 and #15627.  In the UnliftedRep case, we can
+use LitRubbish, which we need to apply to the required type.
+For the unlifted types of singleton kind like Float#, Addr#, etc. we
+also find a suitable literal, using Literal.absentLiteralOf.  We don't
+have literals for every primitive type, so the function is partial.
+
+Note: I did try the experiment of using an error thunk for unlifted
+things too, relying on the simplifier to drop it as dead code.
+But this is fragile
+
+ - It fails when profiling is on, which disables various optimisations
+
+ - It fails when reboxing happens. E.g.
+      data T = MkT Int Int#
+      f p@(MkT a _) = ...g p....
+   where g is /lazy/ in 'p', but only uses the first component.  Then
+   'f' is /strict/ in 'p', and only uses the first component.  So we only
+   pass that component to the worker for 'f', which reconstructs 'p' to
+   pass it to 'g'.  Alas we can't say
+       ...f (MkT a (absentError Int# "blah"))...
+   bacause `MkT` is strict in its Int# argument, so we get an absentError
+   exception when we shouldn't.  Very annoying!
+
+So absentError is only used for lifted types.
+-}
+
+-- | Tries to find a suitable dummy RHS to bind the given absent identifier to.
+--
+-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
+-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
+-- found (currently only happens for bindings of 'VecRep' representation).
+mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let dflags arg
+  -- The lifted case: Bind 'absentError'
+  -- See Note [Absent errors]
+  | not (isUnliftedType arg_ty)
+  = Just (Let (NonRec lifted_arg abs_rhs))
+  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@
+  -- See Note [Absent errors]
+  | [UnliftedRep] <- typePrimRep arg_ty
+  = Just (Let (NonRec arg unlifted_rhs))
+  -- The monomorphic unlifted cases: Bind to some literal, if possible
+  -- See Note [Absent errors]
+  | Just tc <- tyConAppTyCon_maybe arg_ty
+  , Just lit <- absentLiteralOf tc
+  = Just (Let (NonRec arg (Lit lit)))
+  | arg_ty `eqType` voidPrimTy
+  = Just (Let (NonRec arg (Var voidPrimId)))
+  | otherwise
+  = WARN( True, text "No absent value for" <+> ppr arg_ty )
+    Nothing -- Can happen for 'State#' and things of 'VecRep'
+  where
+    lifted_arg   = arg `setIdStrictness` botSig
+              -- Note in strictness signature that this is bottoming
+              -- (for the sake of the "empty case scrutinee not known to
+              -- diverge for sure lint" warning)
+    arg_ty       = idType arg
+    abs_rhs      = mkAbsentErrorApp arg_ty msg
+    msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)
+                          (ppr arg <+> ppr (idType arg))
+              -- We need to suppress uniques here because otherwise they'd
+              -- end up in the generated code as strings. This is bad for
+              -- determinism, because with different uniques the strings
+              -- will have different lengths and hence different costs for
+              -- the inliner leading to different inlining.
+              -- See also Note [Unique Determinism] in Unique
+    unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]
+
+mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
+-- The StrictnessMark comes form the data constructor and says
+-- whether this field is strict
+-- See Note [Record evaluated-ness in worker/wrapper]
+mk_ww_local uniq (ty,str)
+  = setCaseBndrEvald str $
+    mkSysLocalOrCoVar (fsLit "ww") uniq ty
diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/ClsInst.hs
@@ -0,0 +1,699 @@
+{-# LANGUAGE CPP #-}
+
+module ClsInst (
+     matchGlobalInst,
+     ClsInstResult(..),
+     InstanceWhat(..), safeOverlap,
+     AssocInstInfo(..), isNotAssociated
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcEnv
+import TcRnMonad
+import TcType
+import TcMType
+import TcEvidence
+import RnEnv( addUsedGRE )
+import RdrName( lookupGRE_FieldLabel )
+import InstEnv
+import Inst( instDFunType )
+import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
+
+import TysWiredIn
+import TysPrim( eqPrimTyCon, eqReprPrimTyCon )
+import PrelNames
+
+import Id
+import Type
+import MkCore ( mkStringExprFS, mkNaturalExpr )
+
+import Name   ( Name )
+import VarEnv ( VarEnv )
+import DataCon
+import TyCon
+import Class
+import DynFlags
+import Outputable
+import Util( splitAtList, fstOf3 )
+import Data.Maybe
+
+{- *******************************************************************
+*                                                                    *
+              A helper for associated types within
+              class instance declarations
+*                                                                    *
+**********************************************************************-}
+
+-- | Extra information about the parent instance declaration, needed
+-- when type-checking associated types. The 'Class' is the enclosing
+-- class, the [TyVar] are the /scoped/ type variable of the instance decl.
+-- The @VarEnv Type@ maps class variables to their instance types.
+data AssocInstInfo
+  = NotAssociated
+  | InClsInst { ai_class    :: Class
+              , ai_tyvars   :: [TyVar]      -- ^ The /scoped/ tyvars of the instance
+                                            -- Why scoped?  See bind_me in
+                                            -- TcValidity.checkConsistentFamInst
+              , ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types
+                -- See Note [Matching in the consistent-instantation check]
+    }
+
+isNotAssociated :: AssocInstInfo -> Bool
+isNotAssociated NotAssociated  = True
+isNotAssociated (InClsInst {}) = False
+
+
+{- *******************************************************************
+*                                                                    *
+                       Class lookup
+*                                                                    *
+**********************************************************************-}
+
+-- | Indicates if Instance met the Safe Haskell overlapping instances safety
+-- check.
+--
+-- See Note [Safe Haskell Overlapping Instances] in TcSimplify
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+type SafeOverlapping = Bool
+
+data ClsInstResult
+  = NoInstance   -- Definitely no instance
+
+  | OneInst { cir_new_theta :: [TcPredType]
+            , cir_mk_ev     :: [EvExpr] -> EvTerm
+            , cir_what      :: InstanceWhat }
+
+  | NotSure      -- Multiple matches and/or one or more unifiers
+
+data InstanceWhat
+  = BuiltinInstance
+  | LocalInstance
+  | TopLevInstance { iw_dfun_id   :: DFunId
+                   , iw_safe_over :: SafeOverlapping }
+
+instance Outputable ClsInstResult where
+  ppr NoInstance = text "NoInstance"
+  ppr NotSure    = text "NotSure"
+  ppr (OneInst { cir_new_theta = ev
+               , cir_what = what })
+    = text "OneInst" <+> vcat [ppr ev, ppr what]
+
+instance Outputable InstanceWhat where
+  ppr BuiltinInstance = text "built-in instance"
+  ppr LocalInstance   = text "locally-quantified instance"
+  ppr (TopLevInstance { iw_safe_over = so })
+     = text "top-level instance" <+> (text $ if so then "[safe]" else "[unsafe]")
+
+safeOverlap :: InstanceWhat -> Bool
+safeOverlap (TopLevInstance { iw_safe_over = so }) = so
+safeOverlap _                                      = True
+
+matchGlobalInst :: DynFlags
+                -> Bool      -- True <=> caller is the short-cut solver
+                             -- See Note [Shortcut solving: overlap]
+                -> Class -> [Type] -> TcM ClsInstResult
+matchGlobalInst dflags short_cut clas tys
+  | cls_name == knownNatClassName
+  = matchKnownNat    dflags short_cut clas tys
+  | cls_name == knownSymbolClassName
+  = matchKnownSymbol dflags short_cut clas tys
+  | isCTupleClass clas                = matchCTuple          clas tys
+  | cls_name == typeableClassName     = matchTypeable        clas tys
+  | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys
+  | clas `hasKey` eqTyConKey          = matchHomoEquality         tys
+  | clas `hasKey` coercibleTyConKey   = matchCoercible            tys
+  | cls_name == hasFieldClassName     = matchHasField dflags short_cut clas tys
+  | otherwise                         = matchInstEnv dflags short_cut clas tys
+  where
+    cls_name = className clas
+
+
+{- ********************************************************************
+*                                                                     *
+                   Looking in the instance environment
+*                                                                     *
+***********************************************************************-}
+
+
+matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
+matchInstEnv dflags short_cut_solver clas tys
+   = do { instEnvs <- tcGetInstEnvs
+        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
+              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
+              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
+        ; traceTc "matchInstEnv" $
+            vcat [ text "goal:" <+> ppr clas <+> ppr tys
+                 , text "matches:" <+> ppr matches
+                 , text "unify:" <+> ppr unify ]
+        ; case (matches, unify, safeHaskFail) of
+
+            -- Nothing matches
+            ([], [], _)
+                -> do { traceTc "matchClass not matching" (ppr pred)
+                      ; return NoInstance }
+
+            -- A single match (& no safe haskell failure)
+            ([(ispec, inst_tys)], [], False)
+                | short_cut_solver      -- Called from the short-cut solver
+                , isOverlappable ispec
+                -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
+                -- then don't let the short-cut solver choose it, because a
+                -- later instance might overlap it.  #14434 is an example
+                -- See Note [Shortcut solving: overlap]
+                -> do { traceTc "matchClass: ignoring overlappable" (ppr pred)
+                      ; return NotSure }
+
+                | otherwise
+                -> do { let dfun_id = instanceDFunId ispec
+                      ; traceTc "matchClass success" $
+                        vcat [text "dict" <+> ppr pred,
+                              text "witness" <+> ppr dfun_id
+                                             <+> ppr (idType dfun_id) ]
+                                -- Record that this dfun is needed
+                      ; match_one (null unsafeOverlaps) dfun_id inst_tys }
+
+            -- More than one matches (or Safe Haskell fail!). Defer any
+            -- reactions of a multitude until we learn more about the reagent
+            _   -> do { traceTc "matchClass multiple matches, deferring choice" $
+                        vcat [text "dict" <+> ppr pred,
+                              text "matches" <+> ppr matches]
+                      ; return NotSure } }
+   where
+     pred = mkClassPred clas tys
+
+match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult
+             -- See Note [DFunInstType: instantiating types] in InstEnv
+match_one so dfun_id mb_inst_tys
+  = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)
+       ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
+       ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)
+       ; return $ OneInst { cir_new_theta = theta
+                          , cir_mk_ev     = evDFunApp dfun_id tys
+                          , cir_what      = TopLevInstance { iw_dfun_id = dfun_id
+                                                           , iw_safe_over = so } } }
+
+
+{- Note [Shortcut solving: overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  instance {-# OVERLAPPABLE #-} C a where ...
+and we are typechecking
+  f :: C a => a -> a
+  f = e  -- Gives rise to [W] C a
+
+We don't want to solve the wanted constraint with the overlappable
+instance; rather we want to use the supplied (C a)! That was the whole
+point of it being overlappable!  #14434 wwas an example.
+
+Alas even if the instance has no overlap flag, thus
+  instance C a where ...
+there is nothing to stop it being overlapped. GHC provides no way to
+declare an instance as "final" so it can't be overlapped.  But really
+only final instances are OK for short-cut solving.  Sigh. #15135
+was a puzzling example.
+-}
+
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for CTuples
+*                                                                     *
+***********************************************************************-}
+
+matchCTuple :: Class -> [Type] -> TcM ClsInstResult
+matchCTuple clas tys   -- (isCTupleClass clas) holds
+  = return (OneInst { cir_new_theta = tys
+                    , cir_mk_ev     = tuple_ev
+                    , cir_what      = BuiltinInstance })
+            -- The dfun *is* the data constructor!
+  where
+     data_con = tyConSingleDataCon (classTyCon clas)
+     tuple_ev = evDFunApp (dataConWrapId data_con) tys
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Literals
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [KnownNat & KnownSymbol and EvLit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A part of the type-level literals implementation are the classes
+"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
+defining singleton values.  Here is the key stuff from GHC.TypeLits
+
+  class KnownNat (n :: Nat) where
+    natSing :: SNat n
+
+  newtype SNat (n :: Nat) = SNat Integer
+
+Conceptually, this class has infinitely many instances:
+
+  instance KnownNat 0       where natSing = SNat 0
+  instance KnownNat 1       where natSing = SNat 1
+  instance KnownNat 2       where natSing = SNat 2
+  ...
+
+In practice, we solve `KnownNat` predicates in the type-checker
+(see typecheck/TcInteract.hs) because we can't have infinitely many instances.
+The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
+
+We make the following assumptions about dictionaries in GHC:
+  1. The "dictionary" for classes with a single method---like `KnownNat`---is
+     a newtype for the type of the method, so using a evidence amounts
+     to a coercion, and
+  2. Newtypes use the same representation as their definition types.
+
+So, the evidence for `KnownNat` is just a value of the representation type,
+wrapped in two newtype constructors: one to make it into a `SNat` value,
+and another to make it into a `KnownNat` dictionary.
+
+Also note that `natSing` and `SNat` are never actually exposed from the
+library---they are just an implementation detail.  Instead, users see
+a more convenient function, defined in terms of `natSing`:
+
+  natVal :: KnownNat n => proxy n -> Integer
+
+The reason we don't use this directly in the class is that it is simpler
+and more efficient to pass around an integer rather than an entire function,
+especially when the `KnowNat` evidence is packaged up in an existential.
+
+The story for kind `Symbol` is analogous:
+  * class KnownSymbol
+  * newtype SSymbol
+  * Evidence: a Core literal (e.g. mkNaturalExpr)
+
+
+Note [Fabricating Evidence for Literals in Backpack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Let `T` be a type of kind `Nat`. When solving for a purported instance
+of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`,
+in which case the evidence `EvLit (EvNum n)` is generated on the
+fly. It might appear that this is sufficient as users cannot define
+their own instances of `KnownNat`. However, for backpack module this
+would not work (see issue #15379). Consider the signature `Abstract`
+
+> signature Abstract where
+>   data T :: Nat
+>   instance KnownNat T
+
+and a module `Util` that depends on it:
+
+> module Util where
+>  import Abstract
+>  printT :: IO ()
+>  printT = do print $ natVal (Proxy :: Proxy T)
+
+Clearly, we need to "use" the dictionary associated with `KnownNat T`
+in the module `Util`, but it is too early for the compiler to produce
+a real dictionary as we still have not fixed what `T` is. Only when we
+mixin a concrete module
+
+> module Concrete where
+>   type T = 42
+
+do we really get hold of the underlying integer. So the strategy that
+we follow is the following
+
+1. If T is indeed available as a type alias for an integer constant,
+   generate the dictionary on the fly, failing which
+
+2. Look up the type class environment for the evidence.
+
+Finally actual code gets generate for Util only when a module like
+Concrete gets "mixed-in" in place of the signature Abstract. As a
+result all things, including the typeclass instances, in Concrete gets
+reexported. So `KnownNat` gets resolved the normal way post-Backpack.
+
+A similar generation works for `KnownSymbol` as well
+
+-}
+
+matchKnownNat :: DynFlags
+              -> Bool      -- True <=> caller is the short-cut solver
+                           -- See Note [Shortcut solving: overlap]
+              -> Class -> [Type] -> TcM ClsInstResult
+matchKnownNat _ _ clas [ty]     -- clas = KnownNat
+  | Just n <- isNumLitTy ty = do
+        et <- mkNaturalExpr n
+        makeLitDict clas ty et
+matchKnownNat df sc clas tys = matchInstEnv df sc clas tys
+ -- See Note [Fabricating Evidence for Literals in Backpack] for why
+ -- this lookup into the instance environment is required.
+
+matchKnownSymbol :: DynFlags
+                 -> Bool      -- True <=> caller is the short-cut solver
+                              -- See Note [Shortcut solving: overlap]
+                 -> Class -> [Type] -> TcM ClsInstResult
+matchKnownSymbol _ _ clas [ty]  -- clas = KnownSymbol
+  | Just s <- isStrLitTy ty = do
+        et <- mkStringExprFS s
+        makeLitDict clas ty et
+matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys
+ -- See Note [Fabricating Evidence for Literals in Backpack] for why
+ -- this lookup into the instance environment is required.
+
+makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
+-- makeLitDict adds a coercion that will convert the literal into a dictionary
+-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
+-- in TcEvidence.  The coercion happens in 2 steps:
+--
+--     Integer -> SNat n     -- representation of literal to singleton
+--     SNat n  -> KnownNat n -- singleton to dictionary
+--
+--     The process is mirrored for Symbols:
+--     String    -> SSymbol n
+--     SSymbol n -> KnownSymbol n
+makeLitDict clas ty et
+    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
+          -- co_dict :: KnownNat n ~ SNat n
+    , [ meth ]   <- classMethods clas
+    , Just tcRep <- tyConAppTyCon_maybe -- SNat
+                      $ funResultTy         -- SNat n
+                      $ dropForAlls         -- KnownNat n => SNat n
+                      $ idType meth         -- forall n. KnownNat n => SNat n
+    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
+          -- SNat n ~ Integer
+    , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))
+    = return $ OneInst { cir_new_theta = []
+                       , cir_mk_ev     = \_ -> ev_tm
+                       , cir_what      = BuiltinInstance }
+
+    | otherwise
+    = pprPanic "makeLitDict" $
+      text "Unexpected evidence for" <+> ppr (className clas)
+      $$ vcat (map (ppr . idType) (classMethods clas))
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Typeable
+*                                                                     *
+***********************************************************************-}
+
+-- | Assumes that we've checked that this is the 'Typeable' class,
+-- and it was applied to the correct argument.
+matchTypeable :: Class -> [Type] -> TcM ClsInstResult
+matchTypeable clas [k,t]  -- clas = Typeable
+  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
+  | isForAllTy k                      = return NoInstance   -- Polytype
+  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type
+
+  -- Now cases that do work
+  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t
+  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t
+  | tcIsConstraintKind t                   = doTyConApp clas t constraintKindTyCon []
+  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret
+  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
+  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks
+  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
+
+matchTypeable _ _ = return NoInstance
+
+-- | Representation for a type @ty@ of the form @arg -> ret@.
+doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult
+doFunTy clas ty arg_ty ret_ty
+  = return $ OneInst { cir_new_theta = preds
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  where
+    preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]
+    mk_ev [arg_ev, ret_ev] = evTypeable ty $
+                             EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev)
+    mk_ev _ = panic "TcInteract.doFunTy"
+
+
+-- | Representation for type constructor applied to some kinds.
+-- 'onlyNamedBndrsApplied' has ensured that this application results in a type
+-- of monomorphic kind (e.g. all kind variables have been instantiated).
+doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
+doTyConApp clas ty tc kind_args
+  | Just _ <- tyConRepName_maybe tc
+  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  | otherwise
+  = return NoInstance
+  where
+    mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds)
+
+-- | Representation for TyCon applications of a concrete kind. We just use the
+-- kind itself, but first we must make sure that we've instantiated all kind-
+-- polymorphism, but no more.
+onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
+onlyNamedBndrsApplied tc ks
+ = all isNamedTyConBinder used_bndrs &&
+   not (any isNamedTyConBinder leftover_bndrs)
+ where
+   bndrs                        = tyConBinders tc
+   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs
+
+doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
+-- Representation for an application of a type to a type-or-kind.
+--  This may happen when the type expression starts with a type variable.
+--  Example (ignoring kind parameter):
+--    Typeable (f Int Char)                      -->
+--    (Typeable (f Int), Typeable Char)          -->
+--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
+--    Typeable f
+doTyApp clas ty f tk
+  | isForAllTy (tcTypeKind f)
+  = return NoInstance -- We can't solve until we know the ctr.
+  | otherwise
+  = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk]
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  where
+    mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2)
+    mk_ev _ = panic "doTyApp"
+
+
+-- Emit a `Typeable` constraint for the given type.
+mk_typeable_pred :: Class -> Type -> PredType
+mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ]
+
+  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
+  -- we generate a sub-goal for the appropriate class.
+  -- See Note [Typeable for Nat and Symbol]
+doTyLit :: Name -> Type -> TcM ClsInstResult
+doTyLit kc t = do { kc_clas <- tcLookupClass kc
+                  ; let kc_pred    = mkClassPred kc_clas [ t ]
+                        mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev)
+                        mk_ev _    = panic "doTyLit"
+                  ; return (OneInst { cir_new_theta = [kc_pred]
+                                    , cir_mk_ev     = mk_ev
+                                    , cir_what      = BuiltinInstance }) }
+
+{- Note [Typeable (T a b c)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For type applications we always decompose using binary application,
+via doTyApp, until we get to a *kind* instantiation.  Example
+   Proxy :: forall k. k -> *
+
+To solve Typeable (Proxy (* -> *) Maybe) we
+  - First decompose with doTyApp,
+    to get (Typeable (Proxy (* -> *))) and Typeable Maybe
+  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp
+
+If we attempt to short-cut by solving it all at once, via
+doTyConApp
+
+(this note is sadly truncated FIXME)
+
+
+Note [No Typeable for polytypes or qualified types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not support impredicative typeable, such as
+   Typeable (forall a. a->a)
+   Typeable (Eq a => a -> a)
+   Typeable (() => Int)
+   Typeable (((),()) => Int)
+
+See #9858.  For forall's the case is clear: we simply don't have
+a TypeRep for them.  For qualified but not polymorphic types, like
+(Eq a => a -> a), things are murkier.  But:
+
+ * We don't need a TypeRep for these things.  TypeReps are for
+   monotypes only.
+
+ * Perhaps we could treat `=>` as another type constructor for `Typeable`
+   purposes, and thus support things like `Eq Int => Int`, however,
+   at the current state of affairs this would be an odd exception as
+   no other class works with impredicative types.
+   For now we leave it off, until we have a better story for impredicativity.
+
+
+Note [Typeable for Nat and Symbol]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have special Typeable instances for Nat and Symbol.  Roughly we
+have this instance, implemented here by doTyLit:
+      instance KnownNat n => Typeable (n :: Nat) where
+         typeRep = typeNatTypeRep @n
+where
+   Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a
+
+Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a
+runtime value 'n'; it turns it into a string with 'show' and uses
+that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon.
+See #10348.
+
+Because of this rule it's inadvisable (see #15322) to have a constraint
+    f :: (Typeable (n :: Nat)) => blah
+in a function signature; it gives rise to overlap problems just as
+if you'd written
+    f :: Eq [a] => blah
+-}
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for lifted equality
+*                                                                     *
+***********************************************************************-}
+
+-- See also Note [The equality types story] in TysPrim
+matchHeteroEquality :: [Type] -> TcM ClsInstResult
+-- Solves (t1 ~~ t2)
+matchHeteroEquality args
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]
+                    , cir_mk_ev     = evDataConApp heqDataCon args
+                    , cir_what      = BuiltinInstance })
+
+matchHomoEquality :: [Type] -> TcM ClsInstResult
+-- Solves (t1 ~ t2)
+matchHomoEquality args@[k,t1,t2]
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]
+                    , cir_mk_ev     = evDataConApp eqDataCon args
+                    , cir_what      = BuiltinInstance })
+matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)
+
+-- See also Note [The equality types story] in TysPrim
+matchCoercible :: [Type] -> TcM ClsInstResult
+matchCoercible args@[k, t1, t2]
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
+                    , cir_mk_ev     = evDataConApp coercibleDataCon args
+                    , cir_what      = BuiltinInstance })
+  where
+    args' = [k, k, t1, t2]
+matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
+
+
+{- ********************************************************************
+*                                                                     *
+              Class lookup for overloaded record fields
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+    data T y = MkT { foo :: [y] }
+
+and `foo` is in scope.  Then GHC will automatically solve a constraint like
+
+    HasField "foo" (T Int) b
+
+by emitting a new wanted
+
+    T alpha -> [alpha] ~# T Int -> b
+
+and building a HasField dictionary out of the selector function `foo`,
+appropriately cast.
+
+The HasField class is defined (in GHC.Records) thus:
+
+    class HasField (x :: k) r a | x r -> a where
+      getField :: r -> a
+
+Since this is a one-method class, it is represented as a newtype.
+Hence we can solve `HasField "foo" (T Int) b` by taking an expression
+of type `T Int -> b` and casting it using the newtype coercion.
+Note that
+
+    foo :: forall y . T y -> [y]
+
+so the expression we construct is
+
+    foo @alpha |> co
+
+where
+
+    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
+
+is built from
+
+    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
+
+which is the new wanted, and
+
+    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
+
+which can be derived from the newtype coercion.
+
+If `foo` is not in scope, or has a higher-rank or existentially
+quantified type, then the constraint is not solved automatically, but
+may be solved by a user-supplied HasField instance.  Similarly, if we
+encounter a HasField constraint where the field is not a literal
+string, or does not belong to the type, then we fall back on the
+normal constraint solver behaviour.
+-}
+
+-- See Note [HasField instances]
+matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
+matchHasField dflags short_cut clas tys
+  = do { fam_inst_envs <- tcGetFamInstEnvs
+       ; rdr_env       <- getGlobalRdrEnv
+       ; case tys of
+           -- We are matching HasField {k} x r a...
+           [_k_ty, x_ty, r_ty, a_ty]
+               -- x should be a literal string
+             | Just x <- isStrLitTy x_ty
+               -- r should be an applied type constructor
+             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
+               -- use representation tycon (if data family); it has the fields
+             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
+               -- x should be a field of r
+             , Just fl <- lookupTyConFieldLabel x r_tc
+               -- the field selector should be in scope
+             , Just gre <- lookupGRE_FieldLabel rdr_env fl
+
+             -> do { sel_id <- tcLookupId (flSelector fl)
+                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
+
+                         -- The first new wanted constraint equates the actual
+                         -- type of the selector with the type (r -> a) within
+                         -- the HasField x r a dictionary.  The preds will
+                         -- typically be empty, but if the datatype has a
+                         -- "stupid theta" then we have to include it here.
+                   ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds
+
+                         -- Use the equality proof to cast the selector Id to
+                         -- type (r -> a), then use the newtype coercion to cast
+                         -- it to a HasField dictionary.
+                         mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co
+                           where
+                             co = mkTcSubCo (evTermCoercion (EvExpr ev1))
+                                      `mkTcTransCo` mkTcSymCo co2
+                         mk_ev [] = panic "matchHasField.mk_ev"
+
+                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
+                                                              tys
+
+                         tvs = mkTyVarTys (map snd tv_prs)
+
+                     -- The selector must not be "naughty" (i.e. the field
+                     -- cannot have an existentially quantified type), and
+                     -- it must not be higher-rank.
+                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
+                     then do { addUsedGRE True gre
+                             ; return OneInst { cir_new_theta = theta
+                                              , cir_mk_ev     = mk_ev
+                                              , cir_what      = BuiltinInstance } }
+                     else matchInstEnv dflags short_cut clas tys }
+
+           _ -> matchInstEnv dflags short_cut clas tys }
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/FamInst.hs
@@ -0,0 +1,955 @@
+-- The @FamInst@ type: family instance heads
+
+{-# LANGUAGE CPP, GADTs #-}
+
+module FamInst (
+        FamInstEnvs, tcGetFamInstEnvs,
+        checkFamInstConsistency, tcExtendLocalFamInstEnv,
+        tcLookupDataFamInst, tcLookupDataFamInst_maybe,
+        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
+        newFamInst,
+
+        -- * Injectivity
+        makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes
+    ) where
+
+import GhcPrelude
+
+import HscTypes
+import FamInstEnv
+import InstEnv( roughMatchTcs )
+import Coercion
+import CoreLint
+import TcEvidence
+import LoadIface
+import TcRnMonad
+import SrcLoc
+import TyCon
+import TcType
+import CoAxiom
+import DynFlags
+import Module
+import Outputable
+import Util
+import RdrName
+import DataCon ( dataConName )
+import Maybes
+import Type
+import TyCoRep
+import TcMType
+import Name
+import Pair
+import Panic
+import VarSet
+import Bag( Bag, unionBags, unitBag )
+import Control.Monad
+
+#include "HsVersions.h"
+
+{- Note [The type family instance consistency story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To preserve type safety we must ensure that for any given module, all
+the type family instances used either in that module or in any module
+it directly or indirectly imports are consistent. For example, consider
+
+  module F where
+    type family F a
+
+  module A where
+    import F( F )
+    type instance F Int = Bool
+    f :: F Int -> Bool
+    f x = x
+
+  module B where
+    import F( F )
+    type instance F Int = Char
+    g :: Char -> F Int
+    g x = x
+
+  module Bad where
+    import A( f )
+    import B( g )
+    bad :: Char -> Int
+    bad c = f (g c)
+
+Even though module Bad never mentions the type family F at all, by
+combining the functions f and g that were type checked in contradictory
+type family instance environments, the function bad is able to coerce
+from one type to another. So when we type check Bad we must verify that
+the type family instances defined in module A are consistent with those
+defined in module B.
+
+How do we ensure that we maintain the necessary consistency?
+
+* Call a module which defines at least one type family instance a
+  "family instance module". This flag `mi_finsts` is recorded in the
+  interface file.
+
+* For every module we calculate the set of all of its direct and
+  indirect dependencies that are family instance modules. This list
+  `dep_finsts` is also recorded in the interface file so we can compute
+  this list for a module from the lists for its direct dependencies.
+
+* When type checking a module M we check consistency of all the type
+  family instances that are either provided by its `dep_finsts` or
+  defined in the module M itself. This is a pairwise check, i.e., for
+  every pair of instances we must check that they are consistent.
+
+  - For family instances coming from `dep_finsts`, this is checked in
+    checkFamInstConsistency, called from tcRnImports. See Note
+    [Checking family instance consistency] for details on this check
+    (and in particular how we avoid having to do all these checks for
+    every module we compile).
+
+  - That leaves checking the family instances defined in M itself
+    against instances defined in either M or its `dep_finsts`. This is
+    checked in `tcExtendLocalFamInstEnv'.
+
+There are four subtle points in this scheme which have not been
+addressed yet.
+
+* We have checked consistency of the family instances *defined* by M
+  or its imports, but this is not by definition the same thing as the
+  family instances *used* by M or its imports.  Specifically, we need to
+  ensure when we use a type family instance while compiling M that this
+  instance was really defined from either M or one of its imports,
+  rather than being an instance that we happened to know about from
+  reading an interface file in the course of compiling an unrelated
+  module. Otherwise, we'll end up with no record of the fact that M
+  depends on this family instance and type safety will be compromised.
+  See #13102.
+
+* It can also happen that M uses a function defined in another module
+  which is not transitively imported by M. Examples include the
+  desugaring of various overloaded constructs, and references inserted
+  by Template Haskell splices. If that function's definition makes use
+  of type family instances which are not checked against those visible
+  from M, type safety can again be compromised. See #13251.
+
+* When a module C imports a boot module B.hs-boot, we check that C's
+  type family instances are compatible with those visible from
+  B.hs-boot. However, C will eventually be linked against a different
+  module B.hs, which might define additional type family instances which
+  are inconsistent with C's. This can also lead to loss of type safety.
+  See #9562.
+
+* The call to checkFamConsistency for imported functions occurs very
+  early (in tcRnImports) and that causes problems if the imported
+  instances use type declared in the module being compiled.
+  See Note [Loading your own hi-boot file] in LoadIface.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                 Making a FamInst
+*                                                                      *
+************************************************************************
+-}
+
+-- All type variables in a FamInst must be fresh. This function
+-- creates the fresh variables and applies the necessary substitution
+-- It is defined here to avoid a dependency from FamInstEnv on the monad
+-- code.
+
+newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
+-- Freshen the type variables of the FamInst branches
+newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
+  = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )
+    ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )
+    -- We used to have an assertion that the tyvars of the RHS were bound
+    -- by tcv_set, but in error situations like  F Int = a that isn't
+    -- true; a later check in checkValidFamInst rejects it
+    do { (subst, tvs') <- freshenTyVarBndrs tvs
+       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs
+       ; dflags <- getDynFlags
+       ; let lhs'     = substTys subst lhs
+             rhs'     = substTy  subst rhs
+             tcvs'    = tvs' ++ cvs'
+       ; ifErrsM (return ()) $ -- Don't lint when there are errors, because
+                               -- errors might mean TcTyCons.
+                               -- See Note [Recover from validity error] in TcTyClsDecls
+         when (gopt Opt_DoCoreLinting dflags) $
+           -- Check that the types involved in this instance are well formed.
+           -- Do /not/ expand type synonyms, for the reasons discussed in
+           -- Note [Linting type synonym applications].
+           case lintTypes dflags tcvs' (rhs':lhs') of
+             Nothing       -> pure ()
+             Just fail_msg -> pprPanic "Core Lint error" (vcat [ fail_msg
+                                                               , ppr fam_tc
+                                                               , ppr subst
+                                                               , ppr tvs'
+                                                               , ppr cvs'
+                                                               , ppr lhs'
+                                                               , ppr rhs' ])
+       ; return (FamInst { fi_fam      = tyConName fam_tc
+                         , fi_flavor   = flavor
+                         , fi_tcs      = roughMatchTcs lhs
+                         , fi_tvs      = tvs'
+                         , fi_cvs      = cvs'
+                         , fi_tys      = lhs'
+                         , fi_rhs      = rhs'
+                         , fi_axiom    = axiom }) }
+  where
+    lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs)
+    rhs_kind = tcTypeKind rhs
+    tcv_set  = mkVarSet (tvs ++ cvs)
+    pp_ax    = pprCoAxiom axiom
+    CoAxBranch { cab_tvs = tvs
+               , cab_cvs = cvs
+               , cab_lhs = lhs
+               , cab_rhs = rhs } = coAxiomSingleBranch axiom
+
+
+{-
+************************************************************************
+*                                                                      *
+        Optimised overlap checking for family instances
+*                                                                      *
+************************************************************************
+
+Note [Checking family instance consistency]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For any two family instance modules that we import directly or indirectly, we
+check whether the instances in the two modules are consistent, *unless* we can
+be certain that the instances of the two modules have already been checked for
+consistency during the compilation of modules that we import.
+
+Why do we need to check?  Consider
+   module X1 where                module X2 where
+    data T1                         data T2
+    type instance F T1 b = Int      type instance F a T2 = Char
+    f1 :: F T1 a -> Int             f2 :: Char -> F a T2
+    f1 x = x                        f2 x = x
+
+Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
+Notice that neither instance is an orphan.
+
+How do we know which pairs of modules have already been checked? For each
+module M we directly import, we look up the family instance modules that M
+imports (directly or indirectly), say F1, ..., FN. For any two modules
+among M, F1, ..., FN, we know that the family instances defined in those
+two modules are consistent--because we checked that when we compiled M.
+
+For every other pair of family instance modules we import (directly or
+indirectly), we check that they are consistent now. (So that we can be
+certain that the modules in our `HscTypes.dep_finsts' are consistent.)
+
+There is some fancy footwork regarding hs-boot module loops, see
+Note [Don't check hs-boot type family instances too early]
+
+Note [Checking family instance optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As explained in Note [Checking family instance consistency]
+we need to ensure that every pair of transitive imports that define type family
+instances is consistent.
+
+Let's define df(A) = transitive imports of A that define type family instances
++ A, if A defines type family instances
+
+Then for every direct import A, df(A) is already consistent.
+
+Let's name the current module M.
+
+We want to make sure that df(M) is consistent.
+df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports.
+
+We perform the check iteratively, maintaining a set of consistent modules 'C'
+and trying to add df(D_i) to it.
+
+The key part is how to ensure that the union C U df(D_i) is consistent.
+
+Let's consider two modules: A and B from C U df(D_i).
+There are nine possible ways to choose A and B from C U df(D_i):
+
+             | A in C only      | A in C and B in df(D_i) | A in df(D_i) only
+--------------------------------------------------------------------------------
+B in C only  | Already checked  | Already checked         | Needs to be checked
+             | when checking C  | when checking C         |
+--------------------------------------------------------------------------------
+B in C and   | Already checked  | Already checked         | Already checked when
+B in df(D_i) | when checking C  | when checking C         | checking df(D_i)
+--------------------------------------------------------------------------------
+B in df(D_i) | Needs to be      | Already checked         | Already checked when
+only         | checked          | when checking df(D_i)   | checking df(D_i)
+
+That means to ensure that C U df(D_i) is consistent we need to check every
+module from C - df(D_i) against every module from df(D_i) - C and
+every module from df(D_i) - C against every module from C - df(D_i).
+But since the checks are symmetric it suffices to pick A from C - df(D_i)
+and B from df(D_i) - C.
+
+In other words these are the modules we need to check:
+  [ (m1, m2) | m1 <- C, m1 not in df(D_i)
+             , m2 <- df(D_i), m2 not in C ]
+
+One final thing to note here is that if there's lot of overlap between
+subsequent df(D_i)'s then we expect those set differences to be small.
+That situation should be pretty common in practice, there's usually
+a set of utility modules that every module imports directly or indirectly.
+
+This is basically the idea from #13092, comment:14.
+-}
+
+-- This function doesn't check ALL instances for consistency,
+-- only ones that aren't involved in recursive knot-tying
+-- loops; see Note [Don't check hs-boot type family instances too early].
+-- We don't need to check the current module, this is done in
+-- tcExtendLocalFamInstEnv.
+-- See Note [The type family instance consistency story].
+checkFamInstConsistency :: [Module] -> TcM ()
+checkFamInstConsistency directlyImpMods
+  = do { dflags     <- getDynFlags
+       ; (eps, hpt) <- getEpsAndHpt
+       ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
+       ; let { -- Fetch the iface of a given module.  Must succeed as
+               -- all directly imported modules must already have been loaded.
+               modIface mod =
+                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
+                   Nothing    -> panicDoc "FamInst.checkFamInstConsistency"
+                                          (ppr mod $$ pprHPT hpt)
+                   Just iface -> iface
+
+               -- Which family instance modules were checked for consistency
+               -- when we compiled `mod`?
+               -- Itself (if a family instance module) and its dep_finsts.
+               -- This is df(D_i) from
+               -- Note [Checking family instance optimization]
+             ; modConsistent :: Module -> [Module]
+             ; modConsistent mod =
+                 if mi_finsts (modIface mod) then mod:deps else deps
+                 where
+                 deps = dep_finsts . mi_deps . modIface $ mod
+
+             ; hmiModule     = mi_module . hm_iface
+             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+                               . md_fam_insts . hm_details
+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
+                                           | hmi <- eltsHpt hpt]
+
+             }
+
+       ; checkMany hpt_fam_insts modConsistent directlyImpMods
+       }
+  where
+    -- See Note [Checking family instance optimization]
+    checkMany
+      :: ModuleEnv FamInstEnv   -- home package family instances
+      -> (Module -> [Module])   -- given A, modules checked when A was checked
+      -> [Module]               -- modules to process
+      -> TcM ()
+    checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods
+      where
+      go :: [Module] -- list of consistent modules
+         -> ModuleSet -- set of consistent modules, same elements as the
+                      -- list above
+         -> [Module] -- modules to process
+         -> TcM ()
+      go _ _ [] = return ()
+      go consistent consistent_set (mod:mods) = do
+        sequence_
+          [ check hpt_fam_insts m1 m2
+          | m1 <- to_check_from_mod
+            -- loop over toCheckFromMod first, it's usually smaller,
+            -- it may even be empty
+          , m2 <- to_check_from_consistent
+          ]
+        go consistent' consistent_set' mods
+        where
+        mod_deps_consistent =  modConsistent mod
+        mod_deps_consistent_set = mkModuleSet mod_deps_consistent
+        consistent' = to_check_from_mod ++ consistent
+        consistent_set' =
+          extendModuleSetList consistent_set to_check_from_mod
+        to_check_from_consistent =
+          filterOut (`elemModuleSet` mod_deps_consistent_set) consistent
+        to_check_from_mod =
+          filterOut (`elemModuleSet` consistent_set) mod_deps_consistent
+        -- Why don't we just minusModuleSet here?
+        -- We could, but doing so means one of two things:
+        --
+        --   1. When looping over the cartesian product we convert
+        --   a set into a non-deterministicly ordered list. Which
+        --   happens to be fine for interface file determinism
+        --   in this case, today, because the order only
+        --   determines the order of deferred checks. But such
+        --   invariants are hard to keep.
+        --
+        --   2. When looping over the cartesian product we convert
+        --   a set into a deterministically ordered list - this
+        --   adds some additional cost of sorting for every
+        --   direct import.
+        --
+        --   That also explains why we need to keep both 'consistent'
+        --   and 'consistentSet'.
+        --
+        --   See also Note [ModuleEnv performance and determinism].
+    check hpt_fam_insts m1 m2
+      = do { env1' <- getFamInsts hpt_fam_insts m1
+           ; env2' <- getFamInsts hpt_fam_insts m2
+           -- We're checking each element of env1 against env2.
+           -- The cost of that is dominated by the size of env1, because
+           -- for each instance in env1 we look it up in the type family
+           -- environment env2, and lookup is cheap.
+           -- The code below ensures that env1 is the smaller environment.
+           ; let sizeE1 = famInstEnvSize env1'
+                 sizeE2 = famInstEnvSize env2'
+                 (env1, env2) = if sizeE1 < sizeE2 then (env1', env2')
+                                                   else (env2', env1')
+           -- Note [Don't check hs-boot type family instances too early]
+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           -- Family instance consistency checking involves checking that
+           -- the family instances of our imported modules are consistent with
+           -- one another; this might lead you to think that this process
+           -- has nothing to do with the module we are about to typecheck.
+           -- Not so!  Consider the following case:
+           --
+           --   -- A.hs-boot
+           --   type family F a
+           --
+           --   -- B.hs
+           --   import {-# SOURCE #-} A
+           --   type instance F Int = Bool
+           --
+           --   -- A.hs
+           --   import B
+           --   type family F a
+           --
+           -- When typechecking A, we are NOT allowed to poke the TyThing
+           -- for F until we have typechecked the family.  Thus, we
+           -- can't do consistency checking for the instance in B
+           -- (checkFamInstConsistency is called during renaming).
+           -- Failing to defer the consistency check lead to #11062.
+           --
+           -- Additionally, we should also defer consistency checking when
+           -- type from the hs-boot file of the current module occurs on
+           -- the left hand side, as we will poke its TyThing when checking
+           -- for overlap.
+           --
+           --   -- F.hs
+           --   type family F a
+           --
+           --   -- A.hs-boot
+           --   import F
+           --   data T
+           --
+           --   -- B.hs
+           --   import {-# SOURCE #-} A
+           --   import F
+           --   type instance F T = Int
+           --
+           --   -- A.hs
+           --   import B
+           --   data T = MkT
+           --
+           -- In fact, it is even necessary to defer for occurrences in
+           -- the RHS, because we may test for *compatibility* in event
+           -- of an overlap.
+           --
+           -- Why don't we defer ALL of the checks to later?  Well, many
+           -- instances aren't involved in the recursive loop at all.  So
+           -- we might as well check them immediately; and there isn't
+           -- a good time to check them later in any case: every time
+           -- we finish kind-checking a type declaration and add it to
+           -- a context, we *then* consistency check all of the instances
+           -- which mentioned that type.  We DO want to check instances
+           -- as quickly as possible, so that we aren't typechecking
+           -- values with inconsistent axioms in scope.
+           --
+           -- See also Note [Tying the knot]
+           -- for why we are doing this at all.
+           ; let check_now = famInstEnvElts env1
+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
+           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
+ }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+                   ; eps <- getEps
+                   ; return (expectJust "checkFamInstConsistency" $
+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+  where
+    doc = ppr mod <+> text "is a family-instance module"
+
+{-
+************************************************************************
+*                                                                      *
+        Lookup
+*                                                                      *
+************************************************************************
+
+-}
+
+-- | If @co :: T ts ~ rep_ty@ then:
+--
+-- > instNewTyCon_maybe T ts = Just (rep_ty, co)
+--
+-- Checks for a newtype, and for being saturated
+-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
+tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
+tcInstNewTyCon_maybe = instNewTyCon_maybe
+
+-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
+-- there is no data family to unwrap.
+-- Returns a Representational coercion
+tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
+                    -> (TyCon, [TcType], Coercion)
+tcLookupDataFamInst fam_inst_envs tc tc_args
+  | Just (rep_tc, rep_args, co)
+      <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
+  = (rep_tc, rep_args, co)
+  | otherwise
+  = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args))
+
+tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
+                          -> Maybe (TyCon, [TcType], Coercion)
+-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)
+-- and returns a coercion between the two: co :: F [a] ~R FList a.
+tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
+  | isDataFamilyTyCon tc
+  , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
+  , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax
+                                                   , fi_cvs   = cvs })
+                 , fim_tys      = rep_args
+                 , fim_cos      = rep_cos } <- match
+  , let rep_tc = dataFamInstRepTyCon rep_fam
+        co     = mkUnbranchedAxInstCo Representational ax rep_args
+                                      (mkCoVarCos cvs)
+  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv
+    Just (rep_tc, rep_args, co)
+
+  | otherwise
+  = Nothing
+
+-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,
+-- potentially looking through newtype /instances/.
+--
+-- It is only used by the type inference engine (specifically, when
+-- solving representational equality), and hence it is careful to unwrap
+-- only if the relevant data constructor is in scope.  That's why
+-- it get a GlobalRdrEnv argument.
+--
+-- It is careful not to unwrap data/newtype instances if it can't
+-- continue unwrapping.  Such care is necessary for proper error
+-- messages.
+--
+-- It does not look through type families.
+-- It does not normalise arguments to a tycon.
+--
+-- If the result is Just (rep_ty, (co, gres), rep_ty), then
+--    co : ty ~R rep_ty
+--    gres are the GREs for the data constructors that
+--                          had to be in scope
+tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
+                              -> GlobalRdrEnv
+                              -> Type
+                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
+tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
+-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
+  = topNormaliseTypeX stepper plus ty
+  where
+    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
+         -> (Bag GlobalRdrElt, TcCoercion)
+    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2
+                                     , co1 `mkTransCo` co2 )
+
+    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
+    stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance
+
+    -- For newtype instances we take a double step or nothing, so that
+    -- we don't return the representation type of the newtype instance,
+    -- which would lead to terrible error messages
+    unwrap_newtype_instance rec_nts tc tys
+      | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys
+      = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $
+        unwrap_newtype rec_nts tc' tys'
+      | otherwise = NS_Done
+
+    unwrap_newtype rec_nts tc tys
+      | Just con <- newTyConDataCon_maybe tc
+      , Just gre <- lookupGRE_Name rdr_env (dataConName con)
+           -- This is where we check that the
+           -- data constructor is in scope
+      = mapStepResult (\co -> (unitBag gre, co)) $
+        unwrapNewTypeStepper rec_nts tc tys
+
+      | otherwise
+      = NS_Done
+
+{-
+************************************************************************
+*                                                                      *
+        Extending the family instance environment
+*                                                                      *
+************************************************************************
+-}
+
+-- Add new locally-defined family instances, checking consistency with
+-- previous locally-defined family instances as well as all instances
+-- available from imported modules. This requires loading all of our
+-- imports that define family instances (if we haven't loaded them already).
+tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
+
+-- If we weren't actually given any instances to add, then we don't want
+-- to go to the bother of loading family instance module dependencies.
+tcExtendLocalFamInstEnv [] thing_inside = thing_inside
+
+-- Otherwise proceed...
+tcExtendLocalFamInstEnv fam_insts thing_inside
+ = do { -- Load family-instance modules "below" this module, so that
+        -- allLocalFamInst can check for consistency with them
+        -- See Note [The type family instance consistency story]
+        loadDependentFamInstModules fam_insts
+
+        -- Now add the instances one by one
+      ; env <- getGblEnv
+      ; (inst_env', fam_insts') <- foldlM addLocalFamInst
+                                       (tcg_fam_inst_env env, tcg_fam_insts env)
+                                       fam_insts
+
+      ; let env' = env { tcg_fam_insts    = fam_insts'
+                       , tcg_fam_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside
+      }
+
+loadDependentFamInstModules :: [FamInst] -> TcM ()
+-- Load family-instance modules "below" this module, so that
+-- allLocalFamInst can check for consistency with them
+-- See Note [The type family instance consistency story]
+loadDependentFamInstModules fam_insts
+ = do { env <- getGblEnv
+      ; let this_mod = tcg_mod env
+            imports  = tcg_imports env
+
+            want_module mod  -- See Note [Home package family instances]
+              | mod == this_mod = False
+              | home_fams_only  = moduleUnitId mod == moduleUnitId this_mod
+              | otherwise       = True
+            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts
+
+      ; loadModuleInterfaces (text "Loading family-instance modules") $
+        filter want_module (imp_finsts imports) }
+
+{- Note [Home package family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Optimization: If we're only defining type family instances
+for type families *defined in the home package*, then we
+only have to load interface files that belong to the home
+package. The reason is that there's no recursion between
+packages, so modules in other packages can't possibly define
+instances for our type families.
+
+(Within the home package, we could import a module M that
+imports us via an hs-boot file, and thereby defines an
+instance of a type family defined in this module. So we can't
+apply the same logic to avoid reading any interface files at
+all, when we define an instances for type family defined in
+the current module.
+-}
+
+-- Check that the proposed new instance is OK,
+-- and then add it to the home inst env
+-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
+-- in FamInstEnv.hs
+addLocalFamInst :: (FamInstEnv,[FamInst])
+                -> FamInst
+                -> TcM (FamInstEnv, [FamInst])
+addLocalFamInst (home_fie, my_fis) fam_inst
+        -- home_fie includes home package and this module
+        -- my_fies is just the ones from this module
+  = do { traceTc "addLocalFamInst" (ppr fam_inst)
+
+           -- Unlike the case of class instances, don't override existing
+           -- instances in GHCi; it's unsound. See #7102.
+
+       ; mod <- getModule
+       ; traceTc "alfi" (ppr mod)
+
+           -- Fetch imported instances, so that we report
+           -- overlaps correctly.
+           -- Really we ought to only check consistency with
+           -- those instances which are transitively imported
+           -- by the current module, rather than every instance
+           -- we've ever seen. Fixing this is part of #13102.
+       ; eps <- getEps
+       ; let inst_envs = (eps_fam_inst_env eps, home_fie)
+             home_fie' = extendFamInstEnv home_fie fam_inst
+
+           -- Check for conflicting instance decls and injectivity violations
+       ; no_conflict    <- checkForConflicts            inst_envs fam_inst
+       ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst
+
+       ; if no_conflict && injectivity_ok then
+            return (home_fie', fam_inst : my_fis)
+         else
+            return (home_fie,  my_fis) }
+
+{-
+************************************************************************
+*                                                                      *
+        Checking an instance against conflicts with an instance env
+*                                                                      *
+************************************************************************
+
+Check whether a single family instance conflicts with those in two instance
+environments (one for the EPS and one for the HPT).
+-}
+
+checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
+checkForConflicts inst_envs fam_inst
+  = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
+       ; traceTc "checkForConflicts" $
+         vcat [ ppr (map fim_instance conflicts)
+              , ppr fam_inst
+              -- , ppr inst_envs
+         ]
+       ; reportConflictInstErr fam_inst conflicts
+       ; return (null conflicts) }
+
+-- | Check whether a new open type family equation can be added without
+-- violating injectivity annotation supplied by the user. Returns True when
+-- this is possible and False if adding this equation would violate injectivity
+-- annotation.
+checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool
+checkForInjectivityConflicts instEnvs famInst
+    | isTypeFamilyTyCon tycon
+    -- type family is injective in at least one argument
+    , Injective inj <- tyConInjectivityInfo tycon = do
+    { let axiom = coAxiomSingleBranch fi_ax
+          conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst
+          -- see Note [Verifying injectivity annotation] in FamInstEnv
+          errs = makeInjectivityErrors fi_ax axiom inj conflicts
+    ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs
+    ; return (null errs)
+    }
+
+    -- if there was no injectivity annotation or tycon does not represent a
+    -- type family we report no conflicts
+    | otherwise = return True
+    where tycon = famInstTyCon famInst
+          fi_ax = fi_axiom famInst
+
+-- | Build a list of injectivity errors together with their source locations.
+makeInjectivityErrors
+   :: CoAxiom br   -- ^ Type family for which we generate errors
+   -> CoAxBranch   -- ^ Currently checked equation (represented by axiom)
+   -> [Bool]       -- ^ Injectivity annotation
+   -> [CoAxBranch] -- ^ List of injectivity conflicts
+   -> [(SDoc, SrcSpan)]
+makeInjectivityErrors fi_ax axiom inj conflicts
+  = ASSERT2( any id inj, text "No injective type variables" )
+    let lhs             = coAxBranchLHS axiom
+        rhs             = coAxBranchRHS axiom
+        fam_tc          = coAxiomTyCon fi_ax
+        are_conflicts   = not $ null conflicts
+        unused_inj_tvs  = unusedInjTvsInRHS fam_tc inj lhs rhs
+        inj_tvs_unused  = not $ and (isEmptyVarSet <$> unused_inj_tvs)
+        tf_headed       = isTFHeaded rhs
+        bare_variables  = bareTvInRHSViolated lhs rhs
+        wrong_bare_rhs  = not $ null bare_variables
+
+        err_builder herald eqns
+                        = ( hang herald
+                               2 (vcat (map (pprCoAxBranchUser fam_tc) eqns))
+                          , coAxBranchSpan (head eqns) )
+        errorIf p f     = if p then [f err_builder axiom] else []
+     in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )
+        ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs)
+        ++ errorIf tf_headed       tfHeadedErr
+        ++ errorIf wrong_bare_rhs (bareVariableInRHSErr   bare_variables)
+
+
+-- | Return a list of type variables that the function is injective in and that
+-- do not appear on injective positions in the RHS of a family instance
+-- declaration. The returned Pair includes invisible vars followed by visible ones
+unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet
+-- INVARIANT: [Bool] list contains at least one True value
+-- See Note [Verifying injectivity annotation]. This function implements fourth
+-- check described there.
+-- In theory, instead of implementing this whole check in this way, we could
+-- attempt to unify equation with itself.  We would reject exactly the same
+-- equations but this method gives us more precise error messages by returning
+-- precise names of variables that are not mentioned in the RHS.
+unusedInjTvsInRHS tycon injList lhs rhs =
+  (`minusVarSet` injRhsVars) <$> injLHSVars
+    where
+      inj_pairs :: [(Type, ArgFlag)]
+      -- All the injective arguments, paired with their visibility
+      inj_pairs = ASSERT2( injList `equalLength` lhs
+                         , ppr tycon $$ ppr injList $$ ppr lhs )
+                  filterByList injList (lhs `zip` tyConArgFlags tycon lhs)
+
+      -- set of type and kind variables in which type family is injective
+      invis_lhs, vis_lhs :: [Type]
+      (invis_lhs, vis_lhs) = partitionInvisibles inj_pairs
+
+      invis_vars = tyCoVarsOfTypes invis_lhs
+      Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs
+      injLHSVars
+        = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars')
+               vis_vars
+
+      -- set of type variables appearing in the RHS on an injective position.
+      -- For all returned variables we assume their associated kind variables
+      -- also appear in the RHS.
+      injRhsVars = injTyVarsOfType rhs
+
+injTyVarsOfType :: TcTauType -> TcTyVarSet
+-- Collect all type variables that are either arguments to a type
+--   constructor or to /injective/ type families.
+-- Determining the overall type determines thes variables
+--
+-- E.g.   Suppose F is injective in its second arg, but not its first
+--        then injVarOfType (Either a (F [b] (a,c))) = {a,c}
+--        Determining the overall type determines a,c but not b.
+injTyVarsOfType ty
+  | Just ty' <- coreView ty -- #12430
+  = injTyVarsOfType ty'
+injTyVarsOfType (TyVarTy v)
+  = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)
+injTyVarsOfType (TyConApp tc tys)
+  | isTypeFamilyTyCon tc
+   = case tyConInjectivityInfo tc of
+        NotInjective  -> emptyVarSet
+        Injective inj -> injTyVarsOfTypes (filterByList inj tys)
+  | otherwise
+  = injTyVarsOfTypes tys
+injTyVarsOfType (LitTy {})
+  = emptyVarSet
+injTyVarsOfType (FunTy _ arg res)
+  = injTyVarsOfType arg `unionVarSet` injTyVarsOfType res
+injTyVarsOfType (AppTy fun arg)
+  = injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg
+-- No forall types in the RHS of a type family
+injTyVarsOfType (CastTy ty _)   = injTyVarsOfType ty
+injTyVarsOfType (CoercionTy {}) = emptyVarSet
+injTyVarsOfType (ForAllTy {})    =
+    panic "unusedInjTvsInRHS.injTyVarsOfType"
+
+injTyVarsOfTypes :: [Type] -> VarSet
+injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys
+
+-- | Is type headed by a type family application?
+isTFHeaded :: Type -> Bool
+-- See Note [Verifying injectivity annotation]. This function implements third
+-- check described there.
+isTFHeaded ty | Just ty' <- coreView ty
+              = isTFHeaded ty'
+isTFHeaded ty | (TyConApp tc args) <- ty
+              , isTypeFamilyTyCon tc
+              = args `lengthIs` tyConArity tc
+isTFHeaded _  = False
+
+
+-- | If a RHS is a bare type variable return a set of LHS patterns that are not
+-- bare type variables.
+bareTvInRHSViolated :: [Type] -> Type -> [Type]
+-- See Note [Verifying injectivity annotation]. This function implements second
+-- check described there.
+bareTvInRHSViolated pats rhs | isTyVarTy rhs
+   = filter (not . isTyVarTy) pats
+bareTvInRHSViolated _ _ = []
+
+
+-- | Type of functions that use error message and a list of axioms to build full
+-- error message (with a source location) for injective type families.
+type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)
+
+-- | Build injecivity error herald common to all injectivity errors.
+injectivityErrorHerald :: Bool -> SDoc
+injectivityErrorHerald isSingular =
+  text "Type family equation" <> s isSingular <+> text "violate" <>
+  s (not isSingular) <+> text "injectivity annotation" <>
+  if isSingular then dot else colon
+  -- Above is an ugly hack.  We want this: "sentence. herald:" (note the dot and
+  -- colon).  But if herald is empty we want "sentence:" (note the colon).  We
+  -- can't test herald for emptiness so we rely on the fact that herald is empty
+  -- only when isSingular is False.  If herald is non empty it must end with a
+  -- colon.
+    where
+      s False = text "s"
+      s True  = empty
+
+-- | Build error message for a pair of equations violating an injectivity
+-- annotation.
+conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch
+                   -> (SDoc, SrcSpan)
+conflictInjInstErr conflictingEqns errorBuilder tyfamEqn
+  | confEqn : _ <- conflictingEqns
+  = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn]
+  | otherwise
+  = panic "conflictInjInstErr"
+
+-- | Build error message for equation with injective type variables unused in
+-- the RHS.
+unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch
+                       -> (SDoc, SrcSpan)
+unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn
+  = let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)
+                                  [tyfamEqn]
+    in (pprWithExplicitKindsWhen has_kinds doc, loc)
+    where
+      tvs = invis_vars `unionVarSet` vis_vars
+      has_types = not $ isEmptyVarSet vis_vars
+      has_kinds = not $ isEmptyVarSet invis_vars
+
+      doc = sep [ what <+> text "variable" <>
+                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)
+                , text "cannot be inferred from the right-hand side." ]
+      what = case (has_types, has_kinds) of
+               (True, True)   -> text "Type and kind"
+               (True, False)  -> text "Type"
+               (False, True)  -> text "Kind"
+               (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs
+      msg = doc $$ text "In the type family equation:"
+
+-- | Build error message for equation that has a type family call at the top
+-- level of RHS
+tfHeadedErr :: InjErrorBuilder -> CoAxBranch
+            -> (SDoc, SrcSpan)
+tfHeadedErr errorBuilder famInst
+  = errorBuilder (injectivityErrorHerald True $$
+                  text "RHS of injective type family equation cannot" <+>
+                  text "be a type family:") [famInst]
+
+-- | Build error message for equation that has a bare type variable in the RHS
+-- but LHS pattern is not a bare type variable.
+bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch
+                     -> (SDoc, SrcSpan)
+bareVariableInRHSErr tys errorBuilder famInst
+  = errorBuilder (injectivityErrorHerald True $$
+                  text "RHS of injective type family equation is a bare" <+>
+                  text "type variable" $$
+                  text "but these LHS type and kind patterns are not bare" <+>
+                  text "variables:" <+> pprQuotedList tys) [famInst]
+
+
+reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
+reportConflictInstErr _ []
+  = return ()  -- No conflicts
+reportConflictInstErr fam_inst (match1 : _)
+  | FamInstMatch { fim_instance = conf_inst } <- match1
+  , let sorted  = sortWith getSpan [fam_inst, conf_inst]
+        fi1     = head sorted
+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
+  = setSrcSpan span $ addErr $
+    hang (text "Conflicting family instance declarations:")
+       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)
+               | fi <- sorted
+               , let ax = famInstAxiom fi ])
+ where
+   getSpan = getSrcLoc . famInstAxiom
+   -- The sortWith just arranges that instances are dislayed in order
+   -- of source location, which reduced wobbling in error messages,
+   -- and is better for users
+
+tcGetFamInstEnvs :: TcM FamInstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetFamInstEnvs
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/FunDeps.hs
@@ -0,0 +1,675 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 2000
+
+
+FunDeps - functional dependencies
+
+It's better to read it as: "if we know these, then we're going to know these"
+-}
+
+{-# LANGUAGE CPP #-}
+
+module FunDeps (
+        FunDepEqn(..), pprEquation,
+        improveFromInstEnv, improveFromAnother,
+        checkInstCoverage, checkFunDeps,
+        pprFundeps
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Name
+import Var
+import Class
+import Type
+import TcType( transSuperClasses )
+import CoAxiom( TypeEqn )
+import Unify
+import FamInst( injTyVarsOfTypes )
+import InstEnv
+import VarSet
+import VarEnv
+import Outputable
+import ErrUtils( Validity(..), allValid )
+import SrcLoc
+import Util
+
+import Pair             ( Pair(..) )
+import Data.List        ( nubBy )
+import Data.Maybe
+import Data.Foldable    ( fold )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generate equations from functional dependencies}
+*                                                                      *
+************************************************************************
+
+
+Each functional dependency with one variable in the RHS is responsible
+for generating a single equality. For instance:
+     class C a b | a -> b
+The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha
+will generate the following FunDepEqn
+     FDEqn { fd_qtvs = []
+           , fd_eqs  = [Pair Bool alpha]
+           , fd_pred1 = C Int Bool
+           , fd_pred2 = C Int alpha
+           , fd_loc = ... }
+However notice that a functional dependency may have more than one variable
+in the RHS which will create more than one pair of types in fd_eqs. Example:
+     class C a b c | a -> b c
+     [Wanted] C Int alpha alpha
+     [Wanted] C Int Bool beta
+Will generate:
+     FDEqn { fd_qtvs = []
+           , fd_eqs  = [Pair Bool alpha, Pair alpha beta]
+           , fd_pred1 = C Int Bool
+           , fd_pred2 = C Int alpha
+           , fd_loc = ... }
+
+INVARIANT: Corresponding types aren't already equal
+That is, there exists at least one non-identity equality in FDEqs.
+
+Assume:
+       class C a b c | a -> b c
+       instance C Int x x
+And:   [Wanted] C Int Bool alpha
+We will /match/ the LHS of fundep equations, producing a matching substitution
+and create equations for the RHS sides. In our last example we'd have generated:
+      ({x}, [fd1,fd2])
+where
+       fd1 = FDEq 1 Bool x
+       fd2 = FDEq 2 alpha x
+To ``execute'' the equation, make fresh type variable for each tyvar in the set,
+instantiate the two types with these fresh variables, and then unify or generate
+a new constraint. In the above example we would generate a new unification
+variable 'beta' for x and produce the following constraints:
+     [Wanted] (Bool ~ beta)
+     [Wanted] (alpha ~ beta)
+
+Notice the subtle difference between the above class declaration and:
+       class C a b c | a -> b, a -> c
+where we would generate:
+      ({x},[fd1]),({x},[fd2])
+This means that the template variable would be instantiated to different
+unification variables when producing the FD constraints.
+
+Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''
+-}
+
+data FunDepEqn loc
+  = FDEqn { fd_qtvs :: [TyVar]   -- Instantiate these type and kind vars
+                                 --   to fresh unification vars,
+                                 -- Non-empty only for FunDepEqns arising from instance decls
+
+          , fd_eqs   :: [TypeEqn]  -- Make these pairs of types equal
+          , fd_pred1 :: PredType   -- The FunDepEqn arose from
+          , fd_pred2 :: PredType   --  combining these two constraints
+          , fd_loc   :: loc  }
+
+{-
+Given a bunch of predicates that must hold, such as
+
+        C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5
+
+improve figures out what extra equations must hold.
+For example, if we have
+
+        class C a b | a->b where ...
+
+then improve will return
+
+        [(t1,t2), (t4,t5)]
+
+NOTA BENE:
+
+  * improve does not iterate.  It's possible that when we make
+    t1=t2, for example, that will in turn trigger a new equation.
+    This would happen if we also had
+        C t1 t7, C t2 t8
+    If t1=t2, we also get t7=t8.
+
+    improve does *not* do this extra step.  It relies on the caller
+    doing so.
+
+  * The equations unify types that are not already equal.  So there
+    is no effect iff the result of improve is empty
+-}
+
+instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
+-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys)
+instFD (ls,rs) tvs tys
+  = (map lookup ls, map lookup rs)
+  where
+    env       = zipVarEnv tvs tys
+    lookup tv = lookupVarEnv_NF env tv
+
+zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true
+                   -> [Type] -> [Type]
+                   -> [TypeEqn]
+-- Create a list of (Type,Type) pairs from two lists of types,
+-- making sure that the types are not already equal
+zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2)
+ | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2
+ | otherwise       = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2
+zipAndComputeFDEqs _ _ _ = []
+
+-- Improve a class constraint from another class constraint
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+improveFromAnother :: loc
+                   -> PredType -- Template item (usually given, or inert)
+                   -> PredType -- Workitem [that can be improved]
+                   -> [FunDepEqn loc]
+-- Post: FDEqs always oriented from the other to the workitem
+--       Equations have empty quantified variables
+improveFromAnother loc pred1 pred2
+  | Just (cls1, tys1) <- getClassPredTys_maybe pred1
+  , Just (cls2, tys2) <- getClassPredTys_maybe pred2
+  , cls1 == cls2
+  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc }
+    | let (cls_tvs, cls_fds) = classTvsFds cls1
+    , fd <- cls_fds
+    , let (ltys1, rs1) = instFD fd cls_tvs tys1
+          (ltys2, rs2) = instFD fd cls_tvs tys2
+    , eqTypes ltys1 ltys2               -- The LHSs match
+    , let eqs = zipAndComputeFDEqs eqType rs1 rs2
+    , not (null eqs) ]
+
+improveFromAnother _ _ _ = []
+
+
+-- Improve a class constraint from instance declarations
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+instance Outputable (FunDepEqn a) where
+  ppr = pprEquation
+
+pprEquation :: FunDepEqn a -> SDoc
+pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })
+  = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),
+          nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2
+                       | Pair t1 t2 <- pairs])]
+
+improveFromInstEnv :: InstEnvs
+                   -> (PredType -> SrcSpan -> loc)
+                   -> PredType
+                   -> [FunDepEqn loc] -- Needs to be a FunDepEqn because
+                                      -- of quantified variables
+-- Post: Equations oriented from the template (matching instance) to the workitem!
+improveFromInstEnv inst_env mk_loc pred
+  | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred )
+                       getClassPredTys_maybe pred
+  , let (cls_tvs, cls_fds) = classTvsFds cls
+        instances          = classInstances inst_env cls
+        rough_tcs          = roughMatchTcs tys
+  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs
+            , fd_pred1 = p_inst, fd_pred2 = pred
+            , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }
+    | fd <- cls_fds             -- Iterate through the fundeps first,
+                                -- because there often are none!
+    , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs
+                -- Trim the rough_tcs based on the head of the fundep.
+                -- Remember that instanceCantMatch treats both arguments
+                -- symmetrically, so it's ok to trim the rough_tcs,
+                -- rather than trimming each inst_tcs in turn
+    , ispec <- instances
+    , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec
+                                      tys trimmed_tcs -- NB: orientation
+    , let p_inst = mkClassPred cls (is_tys ispec)
+    ]
+improveFromInstEnv _ _ _ = []
+
+
+improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class
+             -> ClsInst                    -- An instance template
+             -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate
+             -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton
+
+improveClsFD clas_tvs fd
+             (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst })
+             tys_actual rough_tcs_actual
+
+-- Compare instance      {a,b}    C sx sp sy sq
+--         with wanted     [W] C tx tp ty tq
+--         for fundep (x,y -> p,q)  from class  (C x p y q)
+-- If (sx,sy) unifies with (tx,ty), take the subst S
+
+-- 'qtvs' are the quantified type variables, the ones which can be instantiated
+-- to make the types match.  For example, given
+--      class C a b | a->b where ...
+--      instance C (Maybe x) (Tree x) where ..
+--
+-- and a wanted constraint of form (C (Maybe t1) t2),
+-- then we will call checkClsFD with
+--
+--      is_qtvs = {x}, is_tys = [Maybe x,  Tree x]
+--                     tys_actual = [Maybe t1, t2]
+--
+-- We can instantiate x to t1, and then we want to force
+--      (Tree x) [t1/x]  ~   t2
+
+  | instanceCantMatch rough_tcs_inst rough_tcs_actual
+  = []          -- Filter out ones that can't possibly match,
+
+  | otherwise
+  = ASSERT2( equalLength tys_inst tys_actual &&
+             equalLength tys_inst clas_tvs
+            , ppr tys_inst <+> ppr tys_actual )
+
+    case tcMatchTyKis ltys1 ltys2 of
+        Nothing  -> []
+        Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2)
+                        -- Don't include any equations that already hold.
+                        -- Reason: then we know if any actual improvement has happened,
+                        --         in which case we need to iterate the solver
+                        -- In making this check we must taking account of the fact that any
+                        -- qtvs that aren't already instantiated can be instantiated to anything
+                        -- at all
+                        -- NB: We can't do this 'is-useful-equation' check element-wise
+                        --     because of:
+                        --           class C a b c | a -> b c
+                        --           instance C Int x x
+                        --           [Wanted] C Int alpha Int
+                        -- We would get that  x -> alpha  (isJust) and x -> Int (isJust)
+                        -- so we would produce no FDs, which is clearly wrong.
+                  -> []
+
+                  | null fdeqs
+                  -> []
+
+                  | otherwise
+                  -> -- pprTrace "iproveClsFD" (vcat
+                     --  [ text "is_tvs =" <+> ppr qtvs
+                     --  , text "tys_inst =" <+> ppr tys_inst
+                     --  , text "tys_actual =" <+> ppr tys_actual
+                     --  , text "ltys1 =" <+> ppr ltys1
+                     --  , text "ltys2 =" <+> ppr ltys2
+                     --  , text "subst =" <+> ppr subst ]) $
+                     [(meta_tvs, fdeqs)]
+                        -- We could avoid this substTy stuff by producing the eqn
+                        -- (qtvs, ls1++rs1, ls2++rs2)
+                        -- which will re-do the ls1/ls2 unification when the equation is
+                        -- executed.  What we're doing instead is recording the partial
+                        -- work of the ls1/ls2 unification leaving a smaller unification problem
+                  where
+                    rtys1' = map (substTyUnchecked subst) rtys1
+
+                    fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2
+                        -- Don't discard anything!
+                        -- We could discard equal types but it's an overkill to call
+                        -- eqType again, since we know for sure that /at least one/
+                        -- equation in there is useful)
+
+                    meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv))
+                               | tv <- qtvs, tv `notElemTCvSubst` subst ]
+                        -- meta_tvs are the quantified type variables
+                        -- that have not been substituted out
+                        --
+                        -- Eg.  class C a b | a -> b
+                        --      instance C Int [y]
+                        -- Given constraint C Int z
+                        -- we generate the equation
+                        --      ({y}, [y], z)
+                        --
+                        -- But note (a) we get them from the dfun_id, so they are *in order*
+                        --              because the kind variables may be mentioned in the
+                        --              type variabes' kinds
+                        --          (b) we must apply 'subst' to the kinds, in case we have
+                        --              matched out a kind variable, but not a type variable
+                        --              whose kind mentions that kind variable!
+                        --          #6015, #6068
+  where
+    (ltys1, rtys1) = instFD fd clas_tvs tys_inst
+    (ltys2, rtys2) = instFD fd clas_tvs tys_actual
+
+{-
+%************************************************************************
+%*                                                                      *
+        The Coverage condition for instance declarations
+*                                                                      *
+************************************************************************
+
+Note [Coverage condition]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Example
+      class C a b | a -> b
+      instance theta => C t1 t2
+
+For the coverage condition, we check
+   (normal)    fv(t2) `subset` fv(t1)
+   (liberal)   fv(t2) `subset` oclose(fv(t1), theta)
+
+The liberal version  ensures the self-consistency of the instance, but
+it does not guarantee termination. Example:
+
+   class Mul a b c | a b -> c where
+        (.*.) :: a -> b -> c
+
+   instance Mul Int Int Int where (.*.) = (*)
+   instance Mul Int Float Float where x .*. y = fromIntegral x * y
+   instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v
+
+In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).
+But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )
+
+But it is a mistake to accept the instance because then this defn:
+        f = \ b x y -> if b then x .*. [y] else y
+makes instance inference go into a loop, because it requires the constraint
+        Mul a [b] b
+-}
+
+checkInstCoverage :: Bool   -- Be liberal
+                  -> Class -> [PredType] -> [Type]
+                  -> Validity
+-- "be_liberal" flag says whether to use "liberal" coverage of
+--              See Note [Coverage Condition] below
+--
+-- Return values
+--    Nothing  => no problems
+--    Just msg => coverage problem described by msg
+
+checkInstCoverage be_liberal clas theta inst_taus
+  = allValid (map fundep_ok fds)
+  where
+    (tyvars, fds) = classTvsFds clas
+    fundep_ok fd
+       | and (isEmptyVarSet <$> undetermined_tvs) = IsValid
+       | otherwise                                = NotValid msg
+       where
+         (ls,rs) = instFD fd tyvars inst_taus
+         ls_tvs = tyCoVarsOfTypes ls
+         rs_tvs = splitVisVarsOfTypes rs
+
+         undetermined_tvs | be_liberal = liberal_undet_tvs
+                          | otherwise  = conserv_undet_tvs
+
+         closed_ls_tvs = oclose theta ls_tvs
+         liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs
+         conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs
+
+         undet_set = fold undetermined_tvs
+
+         msg = pprWithExplicitKindsWhen
+                 (isEmptyVarSet $ pSnd undetermined_tvs) $
+               vcat [ -- text "ls_tvs" <+> ppr ls_tvs
+                      -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)
+                      -- , text "theta" <+> ppr theta
+                      -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))
+                      -- , text "rs_tvs" <+> ppr rs_tvs
+                      sep [ text "The"
+                            <+> ppWhen be_liberal (text "liberal")
+                            <+> text "coverage condition fails in class"
+                            <+> quotes (ppr clas)
+                          , nest 2 $ text "for functional dependency:"
+                            <+> quotes (pprFunDep fd) ]
+                    , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls
+                          , nest 2 $
+                            (if isSingleton ls
+                             then text "does not"
+                             else text "do not jointly")
+                            <+> text "determine rhs type"<>plural rs
+                            <+> pprQuotedList rs ]
+                    , text "Un-determined variable" <> pluralVarSet undet_set <> colon
+                            <+> pprVarSet undet_set (pprWithCommas ppr)
+                    , ppWhen (not be_liberal &&
+                              and (isEmptyVarSet <$> liberal_undet_tvs)) $
+                      text "Using UndecidableInstances might help" ]
+
+{- Note [Closing over kinds in coverage]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a fundep  (a::k) -> b
+Then if 'a' is instantiated to (x y), where x:k2->*, y:k2,
+then fixing x really fixes k2 as well, and so k2 should be added to
+the lhs tyvars in the fundep check.
+
+Example (#8391), using liberal coverage
+      data Foo a = ...  -- Foo :: forall k. k -> *
+      class Bar a b | a -> b
+      instance Bar a (Foo a)
+
+    In the instance decl, (a:k) does fix (Foo k a), but only if we notice
+    that (a:k) fixes k.  #10109 is another example.
+
+Here is a more subtle example, from HList-0.4.0.0 (#10564)
+
+  class HasFieldM (l :: k) r (v :: Maybe *)
+        | l r -> v where ...
+  class HasFieldM1 (b :: Maybe [*]) (l :: k) r v
+        | b l r -> v where ...
+  class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])
+        | e1 l -> r
+
+  data Label :: k -> *
+  type family LabelsOf (a :: [*]) ::  *
+
+  instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b,
+            HasFieldM1 b l (r xs) v)
+         => HasFieldM l (r xs) v where
+
+Is the instance OK? Does {l,r,xs} determine v?  Well:
+
+  * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b,
+    plus the fundep "| el l -> r" in class HMameberM,
+    we get {l,k,xs} -> b
+
+  * Note the 'k'!! We must call closeOverKinds on the seed set
+    ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b
+    fundep won't fire.  This was the reason for #10564.
+
+  * So starting from seeds {l,r,xs,k} we do oclose to get
+    first {l,r,xs,k,b}, via the HMemberM constraint, and then
+    {l,r,xs,k,b,v}, via the HasFieldM1 constraint.
+
+  * And that fixes v.
+
+However, we must closeOverKinds whenever augmenting the seed set
+in oclose!  Consider #10109:
+
+  data Succ a   -- Succ :: forall k. k -> *
+  class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
+  instance (Add a b ab) => Add (Succ {k1} (a :: k1))
+                               b
+                               (Succ {k3} (ab :: k3})
+
+We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}.
+Now use the fundep to extend to {a,k1,b,k2,ab}.  But we need to
+closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all
+the variables free in (Succ {k3} ab).
+
+Bottom line:
+  * closeOverKinds on initial seeds (done automatically
+    by tyCoVarsOfTypes in checkInstCoverage)
+  * and closeOverKinds whenever extending those seeds (in oclose)
+
+Note [The liberal coverage condition]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(oclose preds tvs) closes the set of type variables tvs,
+wrt functional dependencies in preds.  The result is a superset
+of the argument set.  For example, if we have
+        class C a b | a->b where ...
+then
+        oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}
+because if we know x and y then that fixes z.
+
+We also use equality predicates in the predicates; if we have an
+assumption `t1 ~ t2`, then we use the fact that if we know `t1` we
+also know `t2` and the other way.
+  eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}
+
+oclose is used (only) when checking the coverage condition for
+an instance declaration
+
+Note [Equality superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class (a ~ [b]) => C a b
+
+Remember from Note [The equality types story] in TysPrim, that
+  * (a ~~ b) is a superclass of (a ~ b)
+  * (a ~# b) is a superclass of (a ~~ b)
+
+So when oclose expands superclasses we'll get a (a ~# [b]) superclass.
+But that's an EqPred not a ClassPred, and we jolly well do want to
+account for the mutual functional dependencies implied by (t1 ~# t2).
+Hence the EqPred handling in oclose.  See #10778.
+
+Note [Care with type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#12803)
+  class C x y | x -> y
+  type family F a b
+  type family G c d = r | r -> d
+
+Now consider
+  oclose (C (F a b) (G c d)) {a,b}
+
+Knowing {a,b} fixes (F a b) regardless of the injectivity of F.
+But knowing (G c d) fixes only {d}, because G is only injective
+in its second parameter.
+
+Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds.
+-}
+
+oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet
+-- See Note [The liberal coverage condition]
+oclose preds fixed_tvs
+  | null tv_fds = fixed_tvs -- Fast escape hatch for common case.
+  | otherwise   = fixVarSet extend fixed_tvs
+  where
+    extend fixed_tvs = foldl' add fixed_tvs tv_fds
+       where
+          add fixed_tvs (ls,rs)
+            | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs
+            | otherwise                = fixed_tvs
+            -- closeOverKinds: see Note [Closing over kinds in coverage]
+
+    tv_fds  :: [(TyCoVarSet,TyCoVarSet)]
+    tv_fds  = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs)
+                  -- See Note [Care with type functions]
+              | pred <- preds
+              , pred' <- pred : transSuperClasses pred
+                   -- Look for fundeps in superclasses too
+              , (ls, rs) <- determined pred' ]
+
+    determined :: PredType -> [([Type],[Type])]
+    determined pred
+       = case classifyPredType pred of
+            EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]
+               -- See Note [Equality superclasses]
+            ClassPred cls tys  -> [ instFD fd cls_tvs tys
+                                  | let (cls_tvs, cls_fds) = classTvsFds cls
+                                  , fd <- cls_fds ]
+            _ -> []
+
+
+{- *********************************************************************
+*                                                                      *
+        Check that a new instance decl is OK wrt fundeps
+*                                                                      *
+************************************************************************
+
+Here is the bad case:
+        class C a b | a->b where ...
+        instance C Int Bool where ...
+        instance C Int Char where ...
+
+The point is that a->b, so Int in the first parameter must uniquely
+determine the second.  In general, given the same class decl, and given
+
+        instance C s1 s2 where ...
+        instance C t1 t2 where ...
+
+Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).
+
+Matters are a little more complicated if there are free variables in
+the s2/t2.
+
+        class D a b c | a -> b
+        instance D a b => D [(a,a)] [b] Int
+        instance D a b => D [a]     [b] Bool
+
+The instance decls don't overlap, because the third parameter keeps
+them separate.  But we want to make sure that given any constraint
+        D s1 s2 s3
+if s1 matches
+
+Note [Bogus consistency check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In checkFunDeps we check that a new ClsInst is consistent with all the
+ClsInsts in the environment.
+
+The bogus aspect is discussed in #10675. Currenty it if the two
+types are *contradicatory*, using (isNothing . tcUnifyTys).  But all
+the papers say we should check if the two types are *equal* thus
+   not (substTys subst rtys1 `eqTypes` substTys subst rtys2)
+For now I'm leaving the bogus form because that's the way it has
+been for years.
+-}
+
+checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]
+-- The Consistency Check.
+-- Check whether adding DFunId would break functional-dependency constraints
+-- Used only for instance decls defined in the module being compiled
+-- Returns a list of the ClsInst in InstEnvs that are inconsistent
+-- with the proposed new ClsInst
+checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls
+                                , is_tys = tys1, is_tcs = rough_tcs1 })
+  | null fds
+  = []
+  | otherwise
+  = nubBy eq_inst $
+    [ ispec | ispec <- cls_insts
+            , fd    <- fds
+            , is_inconsistent fd ispec ]
+  where
+    cls_insts      = classInstances inst_envs cls
+    (cls_tvs, fds) = classTvsFds cls
+    qtv_set1       = mkVarSet qtvs1
+
+    is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 })
+      | instanceCantMatch trimmed_tcs rough_tcs2
+      = False
+      | otherwise
+      = case tcUnifyTyKis bind_fn ltys1 ltys2 of
+          Nothing         -> False
+          Just subst
+            -> isNothing $   -- Bogus legacy test (#10675)
+                             -- See Note [Bogus consistency check]
+               tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)
+
+      where
+        trimmed_tcs    = trimRoughMatchTcs cls_tvs fd rough_tcs1
+        (ltys1, rtys1) = instFD fd cls_tvs tys1
+        (ltys2, rtys2) = instFD fd cls_tvs tys2
+        qtv_set2       = mkVarSet qtvs2
+        bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe
+                   | tv `elemVarSet` qtv_set2 = BindMe
+                   | otherwise                = Skolem
+
+    eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2
+        -- A single instance may appear twice in the un-nubbed conflict list
+        -- because it may conflict with more than one fundep.  E.g.
+        --      class C a b c | a -> b, a -> c
+        --      instance C Int Bool Bool
+        --      instance C Int Char Char
+        -- The second instance conflicts with the first by *both* fundeps
+
+trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
+-- Computing rough_tcs for a particular fundep
+--     class C a b c | a -> b where ...
+-- For each instance .... => C ta tb tc
+-- we want to match only on the type ta; so our
+-- rough-match thing must similarly be filtered.
+-- Hence, we Nothing-ise the tb and tc types right here
+--
+-- Result list is same length as input list, just with more Nothings
+trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs
+  = zipWith select clas_tvs mb_tcs
+  where
+    select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
+                         | otherwise           = Nothing
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/Inst.hs
@@ -0,0 +1,843 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The @Inst@ type: dictionaries or method instances
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Inst (
+       deeplySkolemise,
+       topInstantiate, topInstantiateInferred, deeplyInstantiate,
+       instCall, instDFunType, instStupidTheta, instTyVarsWith,
+       newWanted, newWanteds,
+
+       tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
+
+       newOverloadedLit, mkOverLit,
+
+       newClsInst,
+       tcGetInsts, tcGetInstEnvs, getOverlapFlag,
+       tcExtendLocalInstEnv,
+       instCallConstraints, newMethodFromName,
+       tcSyntaxName,
+
+       -- Simple functions over evidence variables
+       tyCoVarsOfWC,
+       tyCoVarsOfCt, tyCoVarsOfCts,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
+import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )
+
+import BasicTypes ( IntegralLit(..), SourceText(..) )
+import FastString
+import HsSyn
+import TcHsSyn
+import TcRnMonad
+import TcEnv
+import TcEvidence
+import InstEnv
+import TysWiredIn  ( heqDataCon, eqDataCon )
+import CoreSyn     ( isOrphan )
+import FunDeps
+import TcMType
+import Type
+import TyCoRep
+import TcType
+import HscTypes
+import Class( Class )
+import MkId( mkDictFunId )
+import CoreSyn( Expr(..) )  -- For the Coercion constructor
+import Id
+import Name
+import Var      ( EvVar, tyVarName, VarBndr(..) )
+import DataCon
+import VarEnv
+import PrelNames
+import SrcLoc
+import DynFlags
+import Util
+import Outputable
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad( unless )
+
+{-
+************************************************************************
+*                                                                      *
+                Creating and emittind constraints
+*                                                                      *
+************************************************************************
+-}
+
+newMethodFromName
+  :: CtOrigin              -- ^ why do we need this?
+  -> Name                  -- ^ name of the method
+  -> [TcRhoType]           -- ^ types with which to instantiate the class
+  -> TcM (HsExpr GhcTcId)
+-- ^ Used when 'Name' is the wired-in name for a wired-in class method,
+-- so the caller knows its type for sure, which should be of form
+--
+-- > forall a. C a => <blah>
+--
+-- 'newMethodFromName' is supposed to instantiate just the outer
+-- type variable and constraint
+
+newMethodFromName origin name ty_args
+  = do { id <- tcLookupId name
+              -- Use tcLookupId not tcLookupGlobalId; the method is almost
+              -- always a class op, but with -XRebindableSyntax GHC is
+              -- meant to find whatever thing is in scope, and that may
+              -- be an ordinary function.
+
+       ; let ty = piResultTys (idType id) ty_args
+             (theta, _caller_knows_this) = tcSplitPhiTy ty
+       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
+                 instCall origin ty_args theta
+
+       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
+
+{-
+************************************************************************
+*                                                                      *
+        Deep instantiation and skolemisation
+*                                                                      *
+************************************************************************
+
+Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+deeplySkolemise decomposes and skolemises a type, returning a type
+with all its arrows visible (ie not buried under foralls)
+
+Examples:
+
+  deeplySkolemise (Int -> forall a. Ord a => blah)
+    =  ( wp, [a], [d:Ord a], Int -> blah )
+    where wp = \x:Int. /\a. \(d:Ord a). <hole> x
+
+  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
+    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
+
+In general,
+  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
+    and   e :: rho
+  then    wrap e :: ty
+    and   'wrap' binds tvs, evs
+
+ToDo: this eta-abstraction plays fast and loose with termination,
+      because it can introduce extra lambdas.  Maybe add a `seq` to
+      fix this
+-}
+
+deeplySkolemise :: TcSigmaType
+                -> TcM ( HsWrapper
+                       , [(Name,TyVar)]     -- All skolemised variables
+                       , [EvVar]            -- All "given"s
+                       , TcRhoType )
+
+deeplySkolemise ty
+  = go init_subst ty
+  where
+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
+
+    go subst ty
+      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
+      = do { let arg_tys' = substTys subst arg_tys
+           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'
+           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
+           ; ev_vars1       <- newEvVars (substTheta subst' theta)
+           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
+           ; let tv_prs1 = map tyVarName tvs `zip` tvs1
+           ; return ( mkWpLams ids1
+                      <.> mkWpTyLams tvs1
+                      <.> mkWpLams ev_vars1
+                      <.> wrap
+                      <.> mkWpEvVarApps ids1
+                    , tv_prs1  ++ tvs_prs2
+                    , ev_vars1 ++ ev_vars2
+                    , mkVisFunTys arg_tys' rho ) }
+
+      | otherwise
+      = return (idHsWrapper, [], [], substTy subst ty)
+        -- substTy is a quick no-op on an empty substitution
+
+-- | Instantiate all outer type variables
+-- and any context. Never looks through arrows.
+topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- if    topInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
+topInstantiate = top_instantiate True
+
+-- | Instantiate all outer 'Inferred' binders
+-- and any context. Never looks through arrows or specified type variables.
+-- Used for visible type application.
+topInstantiateInferred :: CtOrigin -> TcSigmaType
+                       -> TcM (HsWrapper, TcSigmaType)
+-- if    topInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho
+topInstantiateInferred = top_instantiate False
+
+top_instantiate :: Bool   -- True  <=> instantiate *all* variables
+                          -- False <=> instantiate only the inferred ones
+                -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+top_instantiate inst_all orig ty
+  | not (null binders && null theta)
+  = do { let (inst_bndrs, leave_bndrs) = span should_inst binders
+             (inst_theta, leave_theta)
+               | null leave_bndrs = (theta, [])
+               | otherwise        = ([], theta)
+             in_scope    = mkInScopeSet (tyCoVarsOfType ty)
+             empty_subst = mkEmptyTCvSubst in_scope
+             inst_tvs    = binderVars inst_bndrs
+       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
+       ; let inst_theta' = substTheta subst inst_theta
+             sigma'      = substTy subst (mkForAllTys leave_bndrs $
+                                          mkPhiTy leave_theta rho)
+             inst_tv_tys' = mkTyVarTys inst_tvs'
+
+       ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
+       ; traceTc "Instantiating"
+                 (vcat [ text "all tyvars?" <+> ppr inst_all
+                       , text "origin" <+> pprCtOrigin orig
+                       , text "type" <+> debugPprType ty
+                       , text "theta" <+> ppr theta
+                       , text "leave_bndrs" <+> ppr leave_bndrs
+                       , text "with" <+> vcat (map debugPprType inst_tv_tys')
+                       , text "theta:" <+>  ppr inst_theta' ])
+
+       ; (wrap2, rho2) <-
+           if null leave_bndrs
+
+         -- account for types like forall a. Num a => forall b. Ord b => ...
+           then top_instantiate inst_all orig sigma'
+
+         -- but don't loop if there were any un-inst'able tyvars
+           else return (idHsWrapper, sigma')
+
+       ; return (wrap2 <.> wrap1, rho2) }
+
+  | otherwise = return (idHsWrapper, ty)
+  where
+    (binders, phi) = tcSplitForAllVarBndrs ty
+    (theta, rho)   = tcSplitPhiTy phi
+
+    should_inst bndr
+      | inst_all  = True
+      | otherwise = binderArgFlag bndr == Inferred
+
+deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
+-- In general if
+-- if    deeplyInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho
+-- That is, wrap :: ty ~> rho
+--
+-- If you don't need the HsWrapper returned from this function, consider
+-- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that
+-- only computes the returned TcRhoType.
+
+deeplyInstantiate orig ty =
+  deeply_instantiate orig
+                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
+                     ty
+
+deeply_instantiate :: CtOrigin
+                   -> TCvSubst
+                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Internal function to deeply instantiate that builds on an existing subst.
+-- It extends the input substitution and applies the final subtitution to
+-- the types on return.  See #12549.
+
+deeply_instantiate orig subst ty
+  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
+  = do { (subst', tvs') <- newMetaTyVarsX subst tvs
+       ; let arg_tys' = substTys   subst' arg_tys
+             theta'   = substTheta subst' theta
+       ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
+       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
+       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
+                                                , text "type" <+> ppr ty
+                                                , text "with" <+> ppr tvs'
+                                                , text "args:" <+> ppr ids1
+                                                , text "theta:" <+>  ppr theta'
+                                                , text "subst:" <+> ppr subst'])
+       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
+       ; return (mkWpLams ids1
+                    <.> wrap2
+                    <.> wrap1
+                    <.> mkWpEvVarApps ids1,
+                 mkVisFunTys arg_tys' rho2) }
+
+  | otherwise
+  = do { let ty' = substTy subst ty
+       ; traceTc "deeply_instantiate final subst"
+                 (vcat [ text "origin:"   <+> pprCtOrigin orig
+                       , text "type:"     <+> ppr ty
+                       , text "new type:" <+> ppr ty'
+                       , text "subst:"    <+> ppr subst ])
+      ; return (idHsWrapper, ty') }
+
+
+instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
+-- Use this when you want to instantiate (forall a b c. ty) with
+-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
+-- not yet match (perhaps because there are unsolved constraints; #14154)
+-- If they don't match, emit a kind-equality to promise that they will
+-- eventually do so, and thus make a kind-homongeneous substitution.
+instTyVarsWith orig tvs tys
+  = go empty_subst tvs tys
+  where
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))
+
+    go subst [] []
+      = return subst
+    go subst (tv:tvs) (ty:tys)
+      | tv_kind `tcEqType` ty_kind
+      = go (extendTCvSubst subst tv ty) tvs tys
+      | otherwise
+      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
+           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }
+      where
+        tv_kind = substTy subst (tyVarKind tv)
+        ty_kind = tcTypeKind ty
+
+    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
+
+{-
+************************************************************************
+*                                                                      *
+            Instantiating a call
+*                                                                      *
+************************************************************************
+
+Note [Handling boxed equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The solver deals entirely in terms of unboxed (primitive) equality.
+There should never be a boxed Wanted equality. Ever. But, what if
+we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
+is boxed, so naive treatment here would emit a boxed Wanted equality.
+
+So we simply check for this case and make the right boxing of evidence.
+
+-}
+
+----------------
+instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
+-- Instantiate the constraints of a call
+--      (instCall o tys theta)
+-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
+-- (b) Throws these dictionaries into the LIE
+-- (c) Returns an HsWrapper ([.] tys dicts)
+
+instCall orig tys theta
+  = do  { dict_app <- instCallConstraints orig theta
+        ; return (dict_app <.> mkWpTyApps tys) }
+
+----------------
+instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
+-- Instantiates the TcTheta, puts all constraints thereby generated
+-- into the LIE, and returns a HsWrapper to enclose the call site.
+
+instCallConstraints orig preds
+  | null preds
+  = return idHsWrapper
+  | otherwise
+  = do { evs <- mapM go preds
+       ; traceTc "instCallConstraints" (ppr evs)
+       ; return (mkWpEvApps evs) }
+  where
+    go :: TcPredType -> TcM EvTerm
+    go pred
+     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
+     = do  { co <- unifyType Nothing ty1 ty2
+           ; return (evCoercion co) }
+
+       -- Try short-cut #2
+     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
+     , tc `hasKey` heqTyConKey
+     = do { co <- unifyType Nothing ty1 ty2
+          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
+
+     | otherwise
+     = emitWanted orig pred
+
+instDFunType :: DFunId -> [DFunInstType]
+             -> TcM ( [TcType]      -- instantiated argument types
+                    , TcThetaType ) -- instantiated constraint
+-- See Note [DFunInstType: instantiating types] in InstEnv
+instDFunType dfun_id dfun_inst_tys
+  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
+       ; return (inst_tys, substTheta subst dfun_theta) }
+  where
+    dfun_ty = idType dfun_id
+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
+                  -- With quantified constraints, the
+                  -- type of a dfun may not be closed
+
+    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
+    go subst [] [] = return (subst, [])
+    go subst (tv:tvs) (Just ty : mb_tys)
+      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
+                                 tvs
+                                 mb_tys
+           ; return (subst', ty : tys) }
+    go subst (tv:tvs) (Nothing : mb_tys)
+      = do { (subst', tv') <- newMetaTyVarX subst tv
+           ; (subst'', tys) <- go subst' tvs mb_tys
+           ; return (subst'', mkTyVarTy tv' : tys) }
+    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
+
+----------------
+instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
+-- Similar to instCall, but only emit the constraints in the LIE
+-- Used exclusively for the 'stupid theta' of a data constructor
+instStupidTheta orig theta
+  = do  { _co <- instCallConstraints orig theta -- Discard the coercion
+        ; return () }
+
+
+{- *********************************************************************
+*                                                                      *
+         Instantiating Kinds
+*                                                                      *
+********************************************************************* -}
+
+-- | Instantiates up to n invisible binders
+-- Returns the instantiating types, and body kind
+tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)
+
+tcInstInvisibleTyBinders 0 kind
+  = return ([], kind)
+tcInstInvisibleTyBinders n ty
+  = go n empty_subst ty
+  where
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
+
+    go n subst kind
+      | n > 0
+      , Just (bndr, body) <- tcSplitPiTy_maybe kind
+      , isInvisibleBinder bndr
+      = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
+           ; (args, inner_ty) <- go (n-1) subst' body
+           ; return (arg:args, inner_ty) }
+      | otherwise
+      = return ([], substTy subst kind)
+
+-- | Used only in *types*
+tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
+tcInstInvisibleTyBinder subst (Named (Bndr tv _))
+  = do { (subst', tv') <- newMetaTyVarX subst tv
+       ; return (subst', mkTyVarTy tv') }
+
+tcInstInvisibleTyBinder subst (Anon af ty)
+  | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)
+    -- Equality is the *only* constraint currently handled in types.
+    -- See Note [Constraints in kinds] in TyCoRep
+  = ASSERT( af == InvisArg )
+    do { co <- unifyKind Nothing k1 k2
+       ; arg' <- mk co
+       ; return (subst, arg') }
+
+  | otherwise  -- This should never happen
+               -- See TyCoRep Note [Constraints in kinds]
+  = pprPanic "tcInvisibleTyBinder" (ppr ty)
+
+-------------------------------
+get_eq_tys_maybe :: Type
+                 -> Maybe ( Coercion -> TcM Type
+                             -- given a coercion proving t1 ~# t2, produce the
+                             -- right instantiation for the TyBinder at hand
+                          , Type  -- t1
+                          , Type  -- t2
+                          )
+-- See Note [Constraints in kinds] in TyCoRep
+get_eq_tys_maybe ty
+  -- Lifted heterogeneous equality (~~)
+  | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
+  , tc `hasKey` heqTyConKey
+  = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
+
+  -- Lifted homogeneous equality (~)
+  | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
+  , tc `hasKey` eqTyConKey
+  = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
+
+  | otherwise
+  = Nothing
+
+-- | This takes @a ~# b@ and returns @a ~~ b@.
+mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+-- monadic just for convenience with mkEqBoxTy
+mkHEqBoxTy co ty1 ty2
+  = return $
+    mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
+  where k1 = tcTypeKind ty1
+        k2 = tcTypeKind ty2
+
+-- | This takes @a ~# b@ and returns @a ~ b@.
+mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+mkEqBoxTy co ty1 ty2
+  = return $
+    mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
+  where k = tcTypeKind ty1
+
+{-
+************************************************************************
+*                                                                      *
+                Literals
+*                                                                      *
+************************************************************************
+
+-}
+
+{-
+In newOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want.  This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
+
+-}
+
+newOverloadedLit :: HsOverLit GhcRn
+                 -> ExpRhoType
+                 -> TcM (HsOverLit GhcTcId)
+newOverloadedLit
+  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
+  | not rebindable
+    -- all built-in overloaded lits are tau-types, so we can just
+    -- tauify the ExpType
+  = do { res_ty <- expTypeToType res_ty
+       ; dflags <- getDynFlags
+       ; case shortCutLit dflags val res_ty of
+        -- Do not generate a LitInst for rebindable syntax.
+        -- Reason: If we do, tcSimplify will call lookupInst, which
+        --         will call tcSyntaxName, which does unification,
+        --         which tcSimplify doesn't like
+           Just expr -> return (lit { ol_witness = expr
+                                    , ol_ext = OverLitTc False res_ty })
+           Nothing   -> newNonTrivialOverloadedLit orig lit
+                                                   (mkCheckExpType res_ty) }
+
+  | otherwise
+  = newNonTrivialOverloadedLit orig lit res_ty
+  where
+    orig = LiteralOrigin lit
+newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"
+
+-- Does not handle things that 'shortCutLit' can handle. See also
+-- newOverloadedLit in TcUnify
+newNonTrivialOverloadedLit :: CtOrigin
+                           -> HsOverLit GhcRn
+                           -> ExpRhoType
+                           -> TcM (HsOverLit GhcTcId)
+newNonTrivialOverloadedLit orig
+  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
+               , ol_ext = rebindable }) res_ty
+  = do  { hs_lit <- mkOverLit val
+        ; let lit_ty = hsLitType hs_lit
+        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
+                                      [synKnownType lit_ty] res_ty $
+                      \_ -> return ()
+        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
+        ; res_ty <- readExpType res_ty
+        ; return (lit { ol_witness = witness
+                      , ol_ext = OverLitTc rebindable res_ty }) }
+newNonTrivialOverloadedLit _ lit _
+  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
+
+------------
+mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
+mkOverLit (HsIntegral i)
+  = do  { integer_ty <- tcMetaTy integerTyConName
+        ; return (HsInteger (il_text i)
+                            (il_value i) integer_ty) }
+
+mkOverLit (HsFractional r)
+  = do  { rat_ty <- tcMetaTy rationalTyConName
+        ; return (HsRat noExt r rat_ty) }
+
+mkOverLit (HsIsString src s) = return (HsString src s)
+
+{-
+************************************************************************
+*                                                                      *
+                Re-mappable syntax
+
+     Used only for arrow syntax -- find a way to nuke this
+*                                                                      *
+************************************************************************
+
+Suppose we are doing the -XRebindableSyntax thing, and we encounter
+a do-expression.  We have to find (>>) in the current environment, which is
+done by the rename. Then we have to check that it has the same type as
+Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
+this:
+
+  (>>) :: HB m n mn => m a -> n b -> mn b
+
+So the idea is to generate a local binding for (>>), thus:
+
+        let then72 :: forall a b. m a -> m b -> m b
+            then72 = ...something involving the user's (>>)...
+        in
+        ...the do-expression...
+
+Now the do-expression can proceed using then72, which has exactly
+the expected type.
+
+In fact tcSyntaxName just generates the RHS for then72, because we only
+want an actual binding in the do-expression case. For literals, we can
+just use the expression inline.
+-}
+
+tcSyntaxName :: CtOrigin
+             -> TcType                 -- ^ Type to instantiate it at
+             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)
+             -> TcM (Name, HsExpr GhcTcId)
+                                       -- ^ (Standard name, suitable expression)
+-- USED ONLY FOR CmdTop (sigh) ***
+-- See Note [CmdSyntaxTable] in HsExpr
+
+tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
+  | std_nm == user_nm
+  = do rhs <- newMethodFromName orig std_nm [ty]
+       return (std_nm, rhs)
+
+tcSyntaxName orig ty (std_nm, user_nm_expr) = do
+    std_id <- tcLookupId std_nm
+    let
+        -- C.f. newMethodAtLoc
+        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
+        sigma1         = substTyWith [tv] [ty] tau
+        -- Actually, the "tau-type" might be a sigma-type in the
+        -- case of locally-polymorphic methods.
+
+    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
+
+        -- Check that the user-supplied thing has the
+        -- same type as the standard one.
+        -- Tiresome jiggling because tcCheckSigma takes a located expression
+     span <- getSrcSpanM
+     expr <- tcPolyExpr (L span user_nm_expr) sigma1
+     return (std_nm, unLoc expr)
+
+syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
+               -> TcRn (TidyEnv, SDoc)
+syntaxNameCtxt name orig ty tidy_env
+  = do { inst_loc <- getCtLocM orig (Just TypeLevel)
+       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
+                          <+> text "(needed by a syntactic construct)"
+                        , nest 2 (text "has the required type:"
+                                  <+> ppr (tidyType tidy_env ty))
+                        , nest 2 (pprCtLoc inst_loc) ]
+       ; return (tidy_env, msg) }
+
+{-
+************************************************************************
+*                                                                      *
+                Instances
+*                                                                      *
+************************************************************************
+-}
+
+getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+-- Construct the OverlapFlag from the global module flags,
+-- but if the overlap_mode argument is (Just m),
+--     set the OverlapMode to 'm'
+getOverlapFlag overlap_mode
+  = do  { dflags <- getDynFlags
+        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
+              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
+              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
+                                  , overlapMode   = x }
+              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
+                            | overlap_ok    = use (Overlaps NoSourceText)
+                            | otherwise     = use (NoOverlap NoSourceText)
+
+              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
+        ; return final_oflag }
+
+tcGetInsts :: TcM [ClsInst]
+-- Gets the local class instances.
+tcGetInsts = fmap tcg_insts getGblEnv
+
+newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
+           -> Class -> [Type] -> TcM ClsInst
+newClsInst overlap_mode dfun_name tvs theta clas tys
+  = do { (subst, tvs') <- freshenTyVarBndrs tvs
+             -- Be sure to freshen those type variables,
+             -- so they are sure not to appear in any lookup
+       ; let tys' = substTys subst tys
+
+             dfun = mkDictFunId dfun_name tvs theta clas tys
+             -- The dfun uses the original 'tvs' because
+             -- (a) they don't need to be fresh
+             -- (b) they may be mentioned in the ib_binds field of
+             --     an InstInfo, and in TcEnv.pprInstInfoDetails it's
+             --     helpful to use the same names
+
+       ; oflag <- getOverlapFlag overlap_mode
+       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
+       ; warnIfFlag Opt_WarnOrphans
+                    (isOrphan (is_orphan inst))
+                    (instOrphWarn inst)
+       ; return inst }
+
+instOrphWarn :: ClsInst -> SDoc
+instOrphWarn inst
+  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
+    $$ text "To avoid this"
+    $$ nest 4 (vcat possibilities)
+  where
+    possibilities =
+      text "move the instance declaration to the module of the class or of the type, or" :
+      text "wrap the type with a newtype and declare the instance on the new type." :
+      []
+
+tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
+  -- Add new locally-defined instances
+tcExtendLocalInstEnv dfuns thing_inside
+ = do { traceDFuns dfuns
+      ; env <- getGblEnv
+      ; (inst_env', cls_insts') <- foldlM addLocalInst
+                                          (tcg_inst_env env, tcg_insts env)
+                                          dfuns
+      ; let env' = env { tcg_insts    = cls_insts'
+                       , tcg_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside }
+
+addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
+-- Check that the proposed new instance is OK,
+-- and then add it to the home inst env
+-- If overwrite_inst, then we can overwrite a direct match
+addLocalInst (home_ie, my_insts) ispec
+   = do {
+             -- Load imported instances, so that we report
+             -- duplicates correctly
+
+             -- 'matches'  are existing instance declarations that are less
+             --            specific than the new one
+             -- 'dups'     are those 'matches' that are equal to the new one
+         ; isGHCi <- getIsGHCi
+         ; eps    <- getEps
+         ; tcg_env <- getGblEnv
+
+           -- In GHCi, we *override* any identical instances
+           -- that are also defined in the interactive context
+           -- See Note [Override identical instances in GHCi]
+         ; let home_ie'
+                 | isGHCi    = deleteFromInstEnv home_ie ispec
+                 | otherwise = home_ie
+
+               global_ie = eps_inst_env eps
+               inst_envs = InstEnvs { ie_global  = global_ie
+                                    , ie_local   = home_ie'
+                                    , ie_visible = tcVisibleOrphanMods tcg_env }
+
+             -- Check for inconsistent functional dependencies
+         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
+         ; unless (null inconsistent_ispecs) $
+           funDepErr ispec inconsistent_ispecs
+
+             -- Check for duplicate instance decls.
+         ; let (_tvs, cls, tys) = instanceHead ispec
+               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
+               dups             = filter (identicalClsInstHead ispec) (map fst matches)
+         ; unless (null dups) $
+           dupInstErr ispec (head dups)
+
+         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
+
+{-
+Note [Signature files and type class instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instances in signature files do not have an effect when compiling:
+when you compile a signature against an implementation, you will
+see the instances WHETHER OR NOT the instance is declared in
+the file (this is because the signatures go in the EPS and we
+can't filter them out easily.)  This is also why we cannot
+place the instance in the hi file: it would show up as a duplicate,
+and we don't have instance reexports anyway.
+
+However, you might find them useful when typechecking against
+a signature: the instance is a way of indicating to GHC that
+some instance exists, in case downstream code uses it.
+
+Implementing this is a little tricky.  Consider the following
+situation (sigof03):
+
+ module A where
+     instance C T where ...
+
+ module ASig where
+     instance C T
+
+When compiling ASig, A.hi is loaded, which brings its instances
+into the EPS.  When we process the instance declaration in ASig,
+we should ignore it for the purpose of doing a duplicate check,
+since it's not actually a duplicate. But don't skip the check
+entirely, we still want this to fail (tcfail221):
+
+ module ASig where
+     instance C T
+     instance C T
+
+Note that in some situations, the interface containing the type
+class instances may not have been loaded yet at all.  The usual
+situation when A imports another module which provides the
+instances (sigof02m):
+
+ module A(module B) where
+     import B
+
+See also Note [Signature lazy interface loading].  We can't
+rely on this, however, since sometimes we'll have spurious
+type class instances in the EPS, see #9422 (sigof02dm)
+
+************************************************************************
+*                                                                      *
+        Errors and tracing
+*                                                                      *
+************************************************************************
+-}
+
+traceDFuns :: [ClsInst] -> TcRn ()
+traceDFuns ispecs
+  = traceTc "Adding instances:" (vcat (map pp ispecs))
+  where
+    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
+                  2 (ppr ispec)
+        -- Print the dfun name itself too
+
+funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
+funDepErr ispec ispecs
+  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
+                    (ispec : ispecs)
+
+dupInstErr :: ClsInst -> ClsInst -> TcRn ()
+dupInstErr ispec dup_ispec
+  = addClsInstsErr (text "Duplicate instance declarations:")
+                    [ispec, dup_ispec]
+
+addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
+addClsInstsErr herald ispecs
+  = setSrcSpan (getSrcSpan (head sorted)) $
+    addErr (hang herald 2 (pprInstances sorted))
+ where
+   sorted = sortWith getSrcLoc ispecs
+   -- The sortWith just arranges that instances are dislayed in order
+   -- of source location, which reduced wobbling in error messages,
+   -- and is better for users
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -0,0 +1,79 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[TcAnnotations]{Typechecking annotations}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcAnnotations ( tcAnnotations, annCtxt ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TcSplice ( runAnnotation )
+import Module
+import DynFlags
+import Control.Monad ( when )
+
+import HsSyn
+import Name
+import Annotations
+import TcRnMonad
+import SrcLoc
+import Outputable
+
+-- Some platforms don't support the external interpreter, and
+-- compilation on those platforms shouldn't fail just due to
+-- annotations
+#ifndef GHCI
+tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
+tcAnnotations anns = do
+  dflags <- getDynFlags
+  case gopt Opt_ExternalInterpreter dflags of
+    True  -> tcAnnotations' anns
+    False -> warnAnns anns
+warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
+--- No GHCI; emit a warning (not an error) and ignore. cf #4268
+warnAnns [] = return []
+warnAnns anns@(L loc _ : _)
+  = do { setSrcSpan loc $ addWarnTc NoReason $
+             (text "Ignoring ANN annotation" <> plural anns <> comma
+             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")
+       ; return [] }
+#else
+tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
+tcAnnotations = tcAnnotations'
+#endif
+
+tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]
+tcAnnotations' anns = mapM tcAnnotation anns
+
+tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
+tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
+    -- Work out what the full target of this annotation was
+    mod <- getModule
+    let target = annProvenanceToTarget mod provenance
+
+    -- Run that annotation and construct the full Annotation data structure
+    setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do
+      -- See #10826 -- Annotations allow one to bypass Safe Haskell.
+      dflags <- getDynFlags
+      when (safeLanguageOn dflags) $ failWithTc safeHsErr
+      runAnnotation target expr
+    where
+      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."
+                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]
+tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"
+
+annProvenanceToTarget :: Module -> AnnProvenance Name
+                      -> AnnTarget Name
+annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name
+annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
+annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
+
+annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
+annCtxt ann
+  = hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcArrows.hs
@@ -0,0 +1,440 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+Typecheck arrow notation
+-}
+
+{-# LANGUAGE RankNTypes, TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcArrows ( tcProc ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )
+
+import HsSyn
+import TcMatches
+import TcHsSyn( hsLPatType )
+import TcType
+import TcMType
+import TcBinds
+import TcPat
+import TcUnify
+import TcRnMonad
+import TcEnv
+import TcEvidence
+import Id( mkLocalId )
+import Inst
+import Name
+import TysWiredIn
+import VarSet
+import TysPrim
+import BasicTypes( Arity )
+import SrcLoc
+import Outputable
+import Util
+
+import Control.Monad
+
+{-
+Note [Arrow overview]
+~~~~~~~~~~~~~~~~~~~~~
+Here's a summary of arrows and how they typecheck.  First, here's
+a cut-down syntax:
+
+  expr ::= ....
+        |  proc pat cmd
+
+  cmd ::= cmd exp                    -- Arrow application
+       |  \pat -> cmd                -- Arrow abstraction
+       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0
+       |  ... -- If, case in the usual way
+
+  cmd_type ::= carg_type --> type
+
+  carg_type ::= ()
+             |  (type, carg_type)
+
+Note that
+ * The 'exp' in an arrow form can mention only
+   "arrow-local" variables
+
+ * An "arrow-local" variable is bound by an enclosing
+   cmd binding form (eg arrow abstraction)
+
+ * A cmd_type is here written with a funny arrow "-->",
+   The bit on the left is a carg_type (command argument type)
+   which itself is a nested tuple, finishing with ()
+
+ * The arrow-tail operator (e1 -< e2) means
+       (| e1 <<< arr snd |) e2
+
+
+************************************************************************
+*                                                                      *
+                Proc
+*                                                                      *
+************************************************************************
+-}
+
+tcProc :: InPat GhcRn -> LHsCmdTop GhcRn        -- proc pat -> expr
+       -> ExpRhoType                            -- Expected type of whole proc expression
+       -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
+
+tcProc pat cmd exp_ty
+  = newArrowScope $
+    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
+        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
+        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
+        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
+        ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $
+                          tcCmdTop cmd_env cmd (unitTy, res_ty)
+        ; let res_co = mkTcTransCo co
+                         (mkTcAppCo co1 (mkTcNomReflCo res_ty))
+        ; return (pat', cmd', res_co) }
+
+{-
+************************************************************************
+*                                                                      *
+                Commands
+*                                                                      *
+************************************************************************
+-}
+
+-- See Note [Arrow overview]
+type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
+type CmdArgType = TcTauType                  -- carg_type, a nested tuple
+
+data CmdEnv
+  = CmdEnv {
+        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*
+    }
+
+mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
+mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
+
+---------------------------------------
+tcCmdTop :: CmdEnv
+         -> LHsCmdTop GhcRn
+         -> CmdType
+         -> TcM (LHsCmdTop GhcTcId)
+
+tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
+  = setSrcSpan loc $
+    do  { cmd'   <- tcCmd env cmd cmd_ty
+        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"
+
+----------------------------------------
+tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
+        -- The main recursive function
+tcCmd env (L loc cmd) res_ty
+  = setSrcSpan loc $ do
+        { cmd' <- tc_cmd env cmd res_ty
+        ; return (L loc cmd') }
+
+tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
+tc_cmd env (HsCmdPar x cmd) res_ty
+  = do  { cmd' <- tcCmd env cmd res_ty
+        ; return (HsCmdPar x cmd') }
+
+tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty
+  = do  { (binds', body') <- tcLocalBinds binds         $
+                             setSrcSpan body_loc        $
+                             tc_cmd env body res_ty
+        ; return (HsCmdLet x (L l binds') (L body_loc body')) }
+
+tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
+  = addErrCtxt (cmdCtxt in_cmd) $ do
+      (scrut', scrut_ty) <- tcInferRho scrut
+      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
+      return (HsCmdCase x scrut' matches')
+  where
+    match_ctxt = MC { mc_what = CaseAlt,
+                      mc_body = mc_body }
+    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
+                              ; tcCmd env body (stk, res_ty') }
+
+tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+  = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
+        ; b1'   <- tcCmd env b1 res_ty
+        ; b2'   <- tcCmd env b2 res_ty
+        ; return (HsCmdIf x Nothing pred' b1' b2')
+    }
+
+tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
+  = do  { pred_ty <- newOpenFlexiTyVarTy
+        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
+        -- because we're going to apply it to the environment, not
+        -- the return value.
+        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
+        ; let r_ty = mkTyVarTy r_tv
+        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
+                  (text "Predicate type of `ifThenElse' depends on result type")
+        ; (pred', fun')
+            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
+                                       (mkCheckExpType r_ty) $ \ _ ->
+               tcMonoExpr pred (mkCheckExpType pred_ty)
+
+        ; b1'   <- tcCmd env b1 res_ty
+        ; b2'   <- tcCmd env b2 res_ty
+        ; return (HsCmdIf x (Just fun') pred' b1' b2')
+    }
+
+-------------------------------------------
+--              Arrow application
+--          (f -< a)   or   (f -<< a)
+--
+--   D   |- fun :: a t1 t2
+--   D,G |- arg :: t1
+--  ------------------------
+--   D;G |-a  fun -< arg :: stk --> t2
+--
+--   D,G |- fun :: a t1 t2
+--   D,G |- arg :: t1
+--  ------------------------
+--   D;G |-a  fun -<< arg :: stk --> t2
+--
+-- (plus -<< requires ArrowApply)
+
+tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
+  = addErrCtxt (cmdCtxt cmd)    $
+    do  { arg_ty <- newOpenFlexiTyVarTy
+        ; let fun_ty = mkCmdArrTy env arg_ty res_ty
+        ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))
+
+        ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
+
+        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
+  where
+       -- Before type-checking f, use the environment of the enclosing
+       -- proc for the (-<) case.
+       -- Local bindings, inside the enclosing proc, are not in scope
+       -- inside f.  In the higher-order case (-<<), they are.
+       -- See Note [Escaping the arrow scope] in TcRnTypes
+    select_arrow_scope tc = case ho_app of
+        HsHigherOrderApp -> tc
+        HsFirstOrderApp  -> escapeArrowScope tc
+
+-------------------------------------------
+--              Command application
+--
+-- D,G |-  exp : t
+-- D;G |-a cmd : (t,stk) --> res
+-- -----------------------------
+-- D;G |-a cmd exp : stk --> res
+
+tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
+  = addErrCtxt (cmdCtxt cmd)    $
+    do  { arg_ty <- newOpenFlexiTyVarTy
+        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
+        ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)
+        ; return (HsCmdApp x fun' arg') }
+
+-------------------------------------------
+--              Lambda
+--
+-- D;G,x:t |-a cmd : stk --> res
+-- ------------------------------
+-- D;G |-a (\x.cmd) : (t,stk) --> res
+
+tc_cmd env
+       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc
+                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],
+                         mg_origin = origin }))
+       (cmd_stk, res_ty)
+  = addErrCtxt (pprMatchInCtxt match)        $
+    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
+
+                -- Check the patterns, and the GRHSs inside
+        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $
+                             tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
+                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
+
+        ; let match' = L mtch_loc (Match { m_ext = noExt
+                                         , m_ctxt = LambdaExpr, m_pats = pats'
+                                         , m_grhss = grhss' })
+              arg_tys = map hsLPatType pats'
+              cmd' = HsCmdLam x (MG { mg_alts = L l [match']
+                                    , mg_ext = MatchGroupTc arg_tys res_ty
+                                    , mg_origin = origin })
+        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
+  where
+    n_pats     = length pats
+    match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
+    pg_ctxt    = PatGuard match_ctxt
+
+    tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty
+        = do { (binds', grhss') <- tcLocalBinds binds $
+                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss
+             ; return (GRHSs x grhss' (L l binds')) }
+    tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"
+
+    tc_grhs stk_ty res_ty (GRHS x guards body)
+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
+                                  \ res_ty -> tcCmd env body
+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)
+             ; return (GRHS x guards' rhs') }
+    tc_grhs _ _ (XGRHS _) = panic "tc_grhs"
+
+-------------------------------------------
+--              Do notation
+
+tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
+  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
+        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
+        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }
+
+
+-----------------------------------------------------------------
+--      Arrow ``forms''       (| e c1 .. cn |)
+--
+--      D; G |-a1 c1 : stk1 --> r1
+--      ...
+--      D; G |-an cn : stkn --> rn
+--      D |-  e :: forall e. a1 (e, stk1) t1
+--                                ...
+--                        -> an (e, stkn) tn
+--                        -> a  (e, stk) t
+--      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)
+--      ----------------------------------------------
+--      D; G |-a  (| e c1 ... cn |)  :  stk --> t
+
+tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
+  = addErrCtxt (cmdCtxt cmd)    $
+    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
+                              -- We use alphaTyVar for 'w'
+        ; let e_ty = mkInvForAllTy alphaTyVar $
+                     mkVisFunTys cmd_tys $
+                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
+        ; expr' <- tcPolyExpr expr e_ty
+        ; return (HsCmdArrForm x expr' f fixity cmd_args') }
+
+  where
+    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
+    tc_cmd_arg cmd
+       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind
+            ; stk_ty <- newFlexiTyVarTy liftedTypeKind
+            ; res_ty <- newFlexiTyVarTy liftedTypeKind
+            ; let env' = env { cmd_arr = arr_ty }
+            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
+            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
+
+tc_cmd _ (XCmd {}) _ = panic "tc_cmd"
+
+-----------------------------------------------------------------
+--              Base case for illegal commands
+-- This is where expressions that aren't commands get rejected
+
+tc_cmd _ cmd _
+  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),
+                      text "was found where an arrow command was expected"])
+
+
+matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
+matchExpectedCmdArgs 0 ty
+  = return (mkTcNomReflCo ty, [], ty)
+matchExpectedCmdArgs n ty
+  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
+       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
+       ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }
+
+{-
+************************************************************************
+*                                                                      *
+                Stmts
+*                                                                      *
+************************************************************************
+-}
+
+--------------------------------
+--      Mdo-notation
+-- The distinctive features here are
+--      (a) RecStmts, and
+--      (b) no rebindable syntax
+
+tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
+tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside
+  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)
+        ; thing <- thing_inside (panic "tcArrDoStmt")
+        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }
+
+tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
+  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
+        ; thing          <- thing_inside res_ty
+        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
+  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                            thing_inside res_ty
+        ; return (mkTcBindStmt pat' rhs', thing) }
+
+tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
+                            , recS_rec_ids = rec_names }) res_ty thing_inside
+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
+        ; tcExtendIdEnv tup_ids $ do
+        { (stmts', tup_rets)
+                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
+                        -- ToDo: res_ty not really right
+                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)
+
+        ; thing <- thing_inside res_ty
+                -- NB:  The rec_ids for the recursive things
+                --      already scope over this part. This binding may shadow
+                --      some of them with polymorphic things with the same Name
+                --      (see note [RecStmt] in HsExpr)
+
+        ; let rec_ids = takeList rec_names tup_ids
+        ; later_ids <- tcLookupLocalIds later_names
+
+        ; let rec_rets = takeList rec_names tup_rets
+        ; let ret_table = zip tup_ids tup_rets
+        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
+
+        ; return (emptyRecStmtId { recS_stmts = stmts'
+                                 , recS_later_ids = later_ids
+                                 , recS_rec_ids = rec_ids
+                                 , recS_ext = unitRecStmtTc
+                                     { recS_later_rets = later_rets
+                                     , recS_rec_rets = rec_rets
+                                     , recS_ret_ty = res_ty} }, thing)
+        }}
+
+tcArrDoStmt _ _ stmt _ _
+  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
+
+tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
+                        ; rhs' <- tcCmd env rhs (unitTy, ty)
+                        ; return (rhs', ty) }
+
+{-
+************************************************************************
+*                                                                      *
+                Helpers
+*                                                                      *
+************************************************************************
+-}
+
+mkPairTy :: Type -> Type -> Type
+mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
+
+arrowTyConKind :: Kind          --  *->*->*
+arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind
+
+{-
+************************************************************************
+*                                                                      *
+                Errors
+*                                                                      *
+************************************************************************
+-}
+
+cmdCtxt :: HsCmd GhcRn -> SDoc
+cmdCtxt cmd = text "In the command:" <+> ppr cmd
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcBackpack.hs
@@ -0,0 +1,1000 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module TcBackpack (
+    findExtraSigImports',
+    findExtraSigImports,
+    implicitRequirements',
+    implicitRequirements,
+    checkUnitId,
+    tcRnCheckUnitId,
+    tcRnMergeSignatures,
+    mergeSignatures,
+    tcRnInstantiateSignature,
+    instantiateSignature,
+) where
+
+import GhcPrelude
+
+import BasicTypes (defaultFixity)
+import Packages
+import TcRnExports
+import DynFlags
+import HsSyn
+import RdrName
+import TcRnMonad
+import TcTyDecls
+import InstEnv
+import FamInstEnv
+import Inst
+import TcIface
+import TcMType
+import TcType
+import TcSimplify
+import LoadIface
+import RnNames
+import ErrUtils
+import Id
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import SrcLoc
+import HscTypes
+import Outputable
+import Type
+import FastString
+import RnFixity ( lookupFixityRn )
+import Maybes
+import TcEnv
+import Var
+import IfaceSyn
+import PrelNames
+import qualified Data.Map as Map
+
+import Finder
+import UniqDSet
+import NameShape
+import TcErrors
+import TcUnify
+import RnModIface
+import Util
+
+import Control.Monad
+import Data.List (find)
+
+import {-# SOURCE #-} TcRnDriver
+
+#include "HsVersions.h"
+
+fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
+fixityMisMatch real_thing real_fixity sig_fixity =
+    vcat [ppr real_thing <+> text "has conflicting fixities in the module",
+          text "and its hsig file",
+          text "Main module:" <+> ppr_fix real_fixity,
+          text "Hsig file:" <+> ppr_fix sig_fixity]
+  where
+    ppr_fix f =
+        ppr f <+>
+        (if f == defaultFixity
+            then parens (text "default")
+            else empty)
+
+checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
+checkHsigDeclM sig_iface sig_thing real_thing = do
+    let name = getName real_thing
+    -- TODO: Distinguish between signature merging and signature
+    -- implementation cases.
+    checkBootDeclM False sig_thing real_thing
+    real_fixity <- lookupFixityRn name
+    let sig_fixity = case mi_fix_fn sig_iface (occName name) of
+                        Nothing -> defaultFixity
+                        Just f -> f
+    when (real_fixity /= sig_fixity) $
+      addErrAt (nameSrcSpan name)
+        (fixityMisMatch real_thing real_fixity sig_fixity)
+
+-- | Given a 'ModDetails' of an instantiated signature (note that the
+-- 'ModDetails' must be knot-tied consistently with the actual implementation)
+-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
+-- verify that the actual implementation actually matches the original
+-- interface.
+--
+-- Note that it is already assumed that the implementation *exports*
+-- a sufficient set of entities, since otherwise the renaming and then
+-- typechecking of the signature 'ModIface' would have failed.
+checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
+checkHsigIface tcg_env gr sig_iface
+  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
+               md_types = sig_type_env, md_exports = sig_exports   } = do
+    traceTc "checkHsigIface" $ vcat
+        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
+    mapM_ check_export (map availName sig_exports)
+    unless (null sig_fam_insts) $
+        panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
+               "instances in hsig files yet...")
+    -- Delete instances so we don't look them up when
+    -- checking instance satisfiability
+    -- TODO: this should not be necessary
+    tcg_env <- getGblEnv
+    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
+                        tcg_fam_inst_env = emptyFamInstEnv,
+                        tcg_insts = [],
+                        tcg_fam_insts = [] } $ do
+    mapM_ check_inst sig_insts
+    failIfErrsM
+  where
+    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
+    -- in package p that defines T; and we implement with himpl:H.  Then the
+    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
+    -- have to look up the right name.
+    sig_type_occ_env = mkOccEnv
+                     . map (\t -> (nameOccName (getName t), t))
+                     $ nameEnvElts sig_type_env
+    dfun_names = map getName sig_insts
+    check_export name
+      -- Skip instances, we'll check them later
+      -- TODO: Actually this should never happen, because DFuns are
+      -- never exported...
+      | name `elem` dfun_names = return ()
+      -- See if we can find the type directly in the hsig ModDetails
+      -- TODO: need to special case wired in names
+      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
+        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
+        -- tcg_env (TODO: but maybe this isn't relevant anymore).
+        r <- tcLookupImported_maybe name
+        case r of
+          Failed err -> addErr err
+          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing
+
+      -- The hsig did NOT define this function; that means it must
+      -- be a reexport.  In this case, make sure the 'Name' of the
+      -- reexport matches the 'Name exported here.
+      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
+        when (name /= name') $ do
+            -- See Note [Error reporting bad reexport]
+            -- TODO: Actually this error swizzle doesn't work
+            let p (L _ ie) = name `elem` ieNames ie
+                loc = case tcg_rn_exports tcg_env of
+                       Just es | Just e <- find p (map fst es)
+                         -- TODO: maybe we can be a little more
+                         -- precise here and use the Located
+                         -- info for the *specific* name we matched.
+                         -> getLoc e
+                       _ -> nameSrcSpan name
+            dflags <- getDynFlags
+            addErrAt loc
+                (badReexportedBootThing dflags False name name')
+      -- This should actually never happen, but whatever...
+      | otherwise =
+        addErrAt (nameSrcSpan name)
+            (missingBootThing False name "exported by")
+
+-- Note [Error reporting bad reexport]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NB: You want to be a bit careful about what location you report on reexports.
+-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
+-- correct source location.  However, if it was *reexported*, obviously the name
+-- is not going to have the right location.  In this case, we need to grovel in
+-- tcg_rn_exports to figure out where the reexport came from.
+
+
+
+-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
+-- assume that the implementing file actually implemented the instances (they
+-- may be reexported from elsewhere).  Where should we look for the instances?
+-- We do the same as we would otherwise: consult the EPS.  This isn't perfect
+-- (we might conclude the module exports an instance when it doesn't, see
+-- #9422), but we will never refuse to compile something.
+check_inst :: ClsInst -> TcM ()
+check_inst sig_inst = do
+    -- TODO: This could be very well generalized to support instance
+    -- declarations in boot files.
+    tcg_env <- getGblEnv
+    -- NB: Have to tug on the interface, not necessarily
+    -- tugged... but it didn't work?
+    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
+    -- Based off of 'simplifyDeriv'
+    let ty = idType (instanceDFunId sig_inst)
+        skol_info = InstSkol
+        -- Based off of tcSplitDFunTy
+        (tvs, theta, pred) =
+           case tcSplitForAllTys ty of { (tvs, rho)   ->
+           case splitFunTys rho     of { (theta, pred) ->
+           (tvs, theta, pred) }}
+        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
+    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+    (tclvl,cts) <- pushTcLevelM $ do
+       wanted <- newWanted origin
+                           (Just TypeLevel)
+                           (substTy skol_subst pred)
+       givens <- forM theta $ \given -> do
+           loc <- getCtLocM origin (Just TypeLevel)
+           let given_pred = substTy skol_subst given
+           new_ev <- newEvVar given_pred
+           return CtGiven { ctev_pred = given_pred
+                          -- Doesn't matter, make something up
+                          , ctev_evar = new_ev
+                          , ctev_loc = loc
+                          }
+       return $ wanted : givens
+    unsolved <- simplifyWantedsTcM cts
+
+    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
+    reportAllUnsolved (mkImplicWC implic)
+
+-- | Return this list of requirement interfaces that need to be merged
+-- to form @mod_name@, or @[]@ if this is not a requirement.
+requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
+requirementMerges dflags mod_name =
+    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
+
+-- | For a module @modname@ of type 'HscSource', determine the list
+-- of extra "imports" of other requirements which should be considered part of
+-- the import of the requirement, because it transitively depends on those
+-- requirements by imports of modules from other packages.  The situation
+-- is something like this:
+--
+--      unit p where
+--          signature A
+--          signature B
+--              import A
+--
+--      unit q where
+--          dependency p[A=<A>,B=<B>]
+--          signature A
+--          signature B
+--
+-- Although q's B does not directly import A, we still have to make sure we
+-- process A first, because the merging process will cause B to indirectly
+-- import A.  This function finds the TRANSITIVE closure of all such imports
+-- we need to make.
+findExtraSigImports' :: HscEnv
+                     -> HscSource
+                     -> ModuleName
+                     -> IO (UniqDSet ModuleName)
+findExtraSigImports' hsc_env HsigFile modname =
+    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
+        (initIfaceLoad hsc_env
+            . withException
+            $ moduleFreeHolesPrecise (text "findExtraSigImports")
+                (mkModule (IndefiniteUnitId iuid) mod_name)))
+  where
+    reqs = requirementMerges (hsc_dflags hsc_env) modname
+
+findExtraSigImports' _ _ _ = return emptyUniqDSet
+
+-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
+-- "TcRnDriver".
+findExtraSigImports :: HscEnv -> HscSource -> ModuleName
+                    -> IO [(Maybe FastString, Located ModuleName)]
+findExtraSigImports hsc_env hsc_src modname = do
+    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
+    return [ (Nothing, noLoc mod_name)
+           | mod_name <- uniqDSetToList extra_requirements ]
+
+-- A version of 'implicitRequirements'' which is more friendly
+-- for "GhcMake" and "TcRnDriver".
+implicitRequirements :: HscEnv
+                     -> [(Maybe FastString, Located ModuleName)]
+                     -> IO [(Maybe FastString, Located ModuleName)]
+implicitRequirements hsc_env normal_imports
+  = do mns <- implicitRequirements' hsc_env normal_imports
+       return [ (Nothing, noLoc mn) | mn <- mns ]
+
+-- Given a list of 'import M' statements in a module, figure out
+-- any extra implicit requirement imports they may have.  For
+-- example, if they 'import M' and M resolves to p[A=<B>], then
+-- they actually also import the local requirement B.
+implicitRequirements' :: HscEnv
+                     -> [(Maybe FastString, Located ModuleName)]
+                     -> IO [ModuleName]
+implicitRequirements' hsc_env normal_imports
+  = fmap concat $
+    forM normal_imports $ \(mb_pkg, L _ imp) -> do
+        found <- findImportedModule hsc_env imp mb_pkg
+        case found of
+            Found _ mod | thisPackage dflags /= moduleUnitId mod ->
+                return (uniqDSetToList (moduleFreeHoles mod))
+            _ -> return []
+  where dflags = hsc_dflags hsc_env
+
+-- | Given a 'UnitId', make sure it is well typed.  This is because
+-- unit IDs come from Cabal, which does not know if things are well-typed or
+-- not; a component may have been filled with implementations for the holes
+-- that don't actually fulfill the requirements.
+--
+-- INVARIANT: the UnitId is NOT a InstalledUnitId
+checkUnitId :: UnitId -> TcM ()
+checkUnitId uid = do
+    case splitUnitIdInsts uid of
+      (_, Just indef) ->
+        let insts = indefUnitIdInsts indef in
+        forM_ insts $ \(mod_name, mod) ->
+            -- NB: direct hole instantiations are well-typed by construction
+            -- (because we FORCE things to be merged in), so don't check them
+            when (not (isHoleModule mod)) $ do
+                checkUnitId (moduleUnitId mod)
+                _ <- mod `checkImplements` IndefModule indef mod_name
+                return ()
+      _ -> return () -- if it's hashed, must be well-typed
+
+-- | Top-level driver for signature instantiation (run when compiling
+-- an @hsig@ file.)
+tcRnCheckUnitId ::
+    HscEnv -> UnitId ->
+    IO (Messages, Maybe ())
+tcRnCheckUnitId hsc_env uid =
+   withTiming (pure dflags)
+              (text "Check unit id" <+> ppr uid)
+              (const ()) $
+   initTc hsc_env
+          HsigFile -- bogus
+          False
+          mAIN -- bogus
+          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
+    $ checkUnitId uid
+  where
+   dflags = hsc_dflags hsc_env
+   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
+
+-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
+
+-- | Top-level driver for signature merging (run after typechecking
+-- an @hsig@ file).
+tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
+                    -> IO (Messages, Maybe TcGblEnv)
+tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
+  withTiming (pure dflags)
+             (text "Signature merging" <+> brackets (ppr this_mod))
+             (const ()) $
+  initTc hsc_env HsigFile False this_mod real_loc $
+    mergeSignatures hpm orig_tcg_env iface
+ where
+  dflags   = hsc_dflags hsc_env
+  this_mod = mi_module iface
+  real_loc = tcg_top_loc orig_tcg_env
+
+thinModIface :: [AvailInfo] -> ModIface -> ModIface
+thinModIface avails iface =
+    iface {
+        mi_exports = avails,
+        -- mi_fixities = ...,
+        -- mi_warns = ...,
+        -- mi_anns = ...,
+        -- TODO: The use of nameOccName here is a bit dodgy, because
+        -- perhaps there might be two IfaceTopBndr that are the same
+        -- OccName but different Name.  Requires better understanding
+        -- of invariants here.
+        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
+        -- mi_insts = ...,
+        -- mi_fam_insts = ...,
+    }
+  where
+    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
+    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)
+
+    exported_occs = mkOccSet [ occName n
+                             | a <- avails
+                             , n <- availNames a ]
+    exported_decls = filter_decls exported_occs
+
+    non_exported_occs = mkOccSet [ occName n
+                                 | (_, d) <- exported_decls
+                                 , n <- ifaceDeclNeverExportedRefs d ]
+    non_exported_decls = filter_decls non_exported_occs
+
+    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
+    dfun_pred _ = False
+    dfun_decls = filter (dfun_pred . snd) (mi_decls iface)
+
+-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
+-- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept
+-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
+-- refers to it; we can't decide to keep it by looking at the exports
+-- of a module after thinning.  Keep this synchronized with
+-- 'rnIfaceDecl'.
+ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
+ifaceDeclNeverExportedRefs d@IfaceFamily{} =
+    case ifFamFlav d of
+        IfaceClosedSynFamilyTyCon (Just (n, _))
+            -> [n]
+        _   -> []
+ifaceDeclNeverExportedRefs _ = []
+
+
+-- Note [Blank hsigs for all requirements]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- One invariant that a client of GHC must uphold is that there
+-- must be an hsig file for every requirement (according to
+-- @-this-unit-id@); this ensures that for every interface
+-- file (hi), there is a source file (hsig), which helps grease
+-- the wheels of recompilation avoidance which assumes that
+-- source files always exist.
+
+{-
+inheritedSigPvpWarning :: WarningTxt
+inheritedSigPvpWarning =
+    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
+  where
+    msg = "Inherited requirements from non-signature libraries (libraries " ++
+          "with modules) should not be used, as this mode of use is not " ++
+          "compatible with PVP-style version bounds.  Instead, copy the " ++
+          "declaration to the local hsig file or move the signature to a " ++
+          "library of its own and add that library as a dependency."
+-}
+
+-- Note [Handling never-exported TyThings under Backpack]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
+--   never be mentioned in the export list of a module (mi_avails).
+--   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
+--   TyThings DO have a standalone IfaceDecl declaration in their
+--   interface file.
+--
+-- Originally, Backpack was designed under the assumption that anything
+-- you could declare in a module could also be exported; thus, merging
+-- the export lists of two signatures is just merging the declarations
+-- of two signatures writ small.  Of course, in GHC Haskell, there are a
+-- few important things which are not explicitly exported but still can
+-- be used:  in particular, dictionary functions for instances, Typeable
+-- TyCon bindings, and coercion axioms for type families also count.
+--
+-- When handling these non-exported things, there two primary things
+-- we need to watch out for:
+--
+--  * Signature matching/merging is done by comparing each
+--    of the exported entities of a signature and a module.  These exported
+--    entities may refer to non-exported TyThings which must be tested for
+--    consistency.  For example, an instance (ClsInst) will refer to a
+--    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the
+--    embedded 'DFunId' in 'is_dfun'.
+--
+--    For this to work at all, we must ensure that pointers in 'is_dfun' refer
+--    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
+--    Unfortunately, this is the OPPOSITE of how we treat most other references
+--    to 'Name's, so this case needs to be handled specially.
+--
+--    The details are in the documentation for 'typecheckIfacesForMerging'.
+--    and the Note [Resolving never-exported Names in TcIface].
+--
+--  * When we rename modules and signatures, we use the export lists to
+--    decide how the declarations should be renamed.  However, this
+--    means we don't get any guidance for how to rename non-exported
+--    entities.  Fortunately, we only need to rename these entities
+--    *consistently*, so that 'typecheckIfacesForMerging' can wire them
+--    up as needed.
+--
+--    The details are in Note [rnIfaceNeverExported] in 'RnModIface'.
+--
+-- The root cause for all of these complications is the fact that these
+-- logically "implicit" entities are defined indirectly in an interface
+-- file.  #13151 gives a proposal to make these *truly* implicit.
+
+merge_msg :: ModuleName -> [IndefModule] -> SDoc
+merge_msg mod_name [] =
+    text "while checking the local signature" <+> ppr mod_name <+>
+    text "for consistency"
+merge_msg mod_name reqs =
+  hang (text "while merging the signatures from" <> colon)
+   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$
+      bullet <+> text "...and the local signature for" <+> ppr mod_name)
+
+-- | Given a local 'ModIface', merge all inherited requirements
+-- from 'requirementMerges' into this signature, producing
+-- a final 'TcGblEnv' that matches the local signature and
+-- all required signatures.
+mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
+mergeSignatures
+  (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),
+                    hpm_src_files = src_files })
+  orig_tcg_env lcl_iface0 = setSrcSpan loc $ do
+    -- The lcl_iface0 is the ModIface for the local hsig
+    -- file, which is guaranteed to exist, see
+    -- Note [Blank hsigs for all requirements]
+    hsc_env <- getTopEnv
+    dflags  <- getDynFlags
+
+    -- Copy over some things from the original TcGblEnv that
+    -- we want to preserve
+    updGblEnv (\env -> env {
+        -- Renamed imports/declarations are often used
+        -- by programs that use the GHC API, e.g., Haddock.
+        -- These won't get filled by the merging process (since
+        -- we don't actually rename the parsed module again) so
+        -- we need to take them directly from the previous
+        -- typechecking.
+        --
+        -- NB: the export declarations aren't in their final
+        -- form yet.  We'll fill those in when we reprocess
+        -- the export declarations.
+        tcg_rn_imports = tcg_rn_imports orig_tcg_env,
+        tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,
+        -- Annotations
+        tcg_ann_env    = tcg_ann_env    orig_tcg_env,
+        -- Documentation header
+        tcg_doc_hdr    = tcg_doc_hdr orig_tcg_env
+        -- tcg_dus?
+        -- tcg_th_used           = tcg_th_used orig_tcg_env,
+        -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env
+        -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env
+       }) $ do
+    tcg_env <- getGblEnv
+
+    let outer_mod = tcg_mod tcg_env
+        inner_mod = tcg_semantic_mod tcg_env
+        mod_name = moduleName (tcg_mod tcg_env)
+
+    -- STEP 1: Figure out all of the external signature interfaces
+    -- we are going to merge in.
+    let reqs = requirementMerges dflags mod_name
+
+    addErrCtxt (merge_msg mod_name reqs) $ do
+
+    -- STEP 2: Read in the RAW forms of all of these interfaces
+    ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
+        let m = mkModule (IndefiniteUnitId iuid) mod_name
+            im = fst (splitModuleInsts m)
+        in fmap fst
+         . withException
+         $ findAndReadIface (text "mergeSignatures") im m False
+
+    -- STEP 3: Get the unrenamed exports of all these interfaces,
+    -- thin it according to the export list, and do shaping on them.
+    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
+        -- This function gets run on every inherited interface, and
+        -- it's responsible for:
+        --
+        --  1. Merging the exports of the interface into @nsubst@,
+        --  2. Adding these exports to the "OK to import" set (@oks@)
+        --  if they came from a package with no exposed modules
+        --  (this means we won't report a PVP error in this case), and
+        --  3. Thinning the interface according to an explicit export
+        --  list.
+        --
+        gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
+            let insts = indefUnitIdInsts iuid
+                isFromSignaturePackage =
+                    let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
+                        pkg = getInstalledPackageDetails dflags inst_uid
+                    in null (exposedModules pkg)
+            -- 3(a). Rename the exports according to how the dependency
+            -- was instantiated.  The resulting export list will be accurate
+            -- except for exports *from the signature itself* (which may
+            -- be subsequently updated by exports from other signatures in
+            -- the merge.
+            as1 <- tcRnModExports insts ireq_iface
+            -- 3(b). Thin the interface if it comes from a signature package.
+            (thinned_iface, as2) <- case mb_exports of
+                    Just (L loc _)
+                      -- Check if the package containing this signature is
+                      -- a signature package (i.e., does not expose any
+                      -- modules.)  If so, we can thin it.
+                      | isFromSignaturePackage
+                      -> setSrcSpan loc $ do
+                        -- Suppress missing errors; they might be used to refer
+                        -- to entities from other signatures we are merging in.
+                        -- If an identifier truly doesn't exist in any of the
+                        -- signatures that are merged in, we will discover this
+                        -- when we run exports_from_avail on the final merged
+                        -- export list.
+                        (mb_r, msgs) <- tryTc $ do
+                            -- Suppose that we have written in a signature:
+                            --  signature A ( module A ) where {- empty -}
+                            -- If I am also inheriting a signature from a
+                            -- signature package, does 'module A' scope over
+                            -- all of its exports?
+                            --
+                            -- There are two possible interpretations:
+                            --
+                            --  1. For non self-reexports, a module reexport
+                            --  is interpreted only in terms of the local
+                            --  signature module, and not any of the inherited
+                            --  ones.  The reason for this is because after
+                            --  typechecking, module exports are completely
+                            --  erased from the interface of a file, so we
+                            --  have no way of "interpreting" a module reexport.
+                            --  Thus, it's only useful for the local signature
+                            --  module (where we have a useful GlobalRdrEnv.)
+                            --
+                            --  2. On the other hand, a common idiom when
+                            --  you want to "export everything, plus a reexport"
+                            --  in modules is to say module A ( module A, reex ).
+                            --  This applies to signature modules too; and in
+                            --  particular, you probably still want the entities
+                            --  from the inherited signatures to be preserved
+                            --  too.
+                            --
+                            -- We think it's worth making a special case for
+                            -- self reexports to make use case (2) work.  To
+                            -- do this, we take the exports of the inherited
+                            -- signature @as1@, and bundle them into a
+                            -- GlobalRdrEnv where we treat them as having come
+                            -- from the import @import A@.  Thus, we will
+                            -- pick them up if they are referenced explicitly
+                            -- (@foo@) or even if we do a module reexport
+                            -- (@module A@).
+                            let ispec = ImpSpec ImpDeclSpec{
+                                            -- NB: This needs to be mod name
+                                            -- of the local signature, not
+                                            -- the (original) module name of
+                                            -- the inherited signature,
+                                            -- because we need module
+                                            -- LocalSig (from the local
+                                            -- export list) to match it!
+                                            is_mod  = mod_name,
+                                            is_as   = mod_name,
+                                            is_qual = False,
+                                            is_dloc = loc
+                                          } ImpAll
+                                rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
+                            setGblEnv tcg_env {
+                                tcg_rdr_env = rdr_env
+                            } $ exports_from_avail mb_exports rdr_env
+                                    -- NB: tcg_imports is also empty!
+                                    emptyImportAvails
+                                    (tcg_semantic_mod tcg_env)
+                        case mb_r of
+                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
+                            Nothing -> addMessages msgs >> failM
+                    -- We can't think signatures from non signature packages
+                    _ -> return (ireq_iface, as1)
+            -- 3(c). Only identifiers from signature packages are "ok" to
+            -- import (that is, they are safe from a PVP perspective.)
+            -- (NB: This code is actually dead right now.)
+            let oks' | isFromSignaturePackage
+                     = extendOccSetList oks (exportOccs as2)
+                     | otherwise
+                     = oks
+            -- 3(d). Extend the name substitution (performing shaping)
+            mb_r <- extend_ns nsubst as2
+            case mb_r of
+                Left err -> failWithTc err
+                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
+        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
+        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
+    -- Process each interface, getting the thinned interfaces as well as
+    -- the final, full set of exports @nsubst@ and the exports which are
+    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
+    (nsubst, ok_to_use, rev_thinned_ifaces)
+        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
+    let thinned_ifaces = reverse rev_thinned_ifaces
+        exports        = nameShapeExports nsubst
+        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)
+        _warn_occs     = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
+        warns          = NoWarnings
+        {-
+        -- TODO: Warnings are transitive, but this is not what we want here:
+        -- if a module reexports an entity from a signature, that should be OK.
+        -- Not supported in current warning framework
+        warns | null warn_occs = NoWarnings
+              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
+        -}
+    setGblEnv tcg_env {
+        -- The top-level GlobalRdrEnv is quite interesting.  It consists
+        -- of two components:
+        --  1. First, we reuse the GlobalRdrEnv of the local signature.
+        --     This is very useful, because it means that if we have
+        --     to print a message involving some entity that the local
+        --     signature imported, we'll qualify it accordingly.
+        --  2. Second, we need to add all of the declarations we are
+        --     going to merge in (as they need to be in scope for the
+        --     final test of the export list.)
+        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
+        -- Inherit imports from the local signature, so that module
+        -- rexports are picked up correctly
+        tcg_imports = tcg_imports orig_tcg_env,
+        tcg_exports = exports,
+        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),
+        tcg_warns   = warns
+        } $ do
+    tcg_env <- getGblEnv
+
+    -- Make sure we didn't refer to anything that doesn't actually exist
+    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
+    (mb_lies, _) <- exports_from_avail mb_exports rdr_env
+                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
+
+    {- -- NB: This is commented out, because warns above is disabled.
+    -- If you tried to explicitly export an identifier that has a warning
+    -- attached to it, that's probably a mistake.  Warn about it.
+    case mb_lies of
+      Nothing -> return ()
+      Just lies ->
+        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
+          setSrcSpan loc $
+            unless (nameOccName n `elemOccSet` ok_to_use) $
+                addWarn NoReason $ vcat [
+                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
+                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
+                    ]
+    -}
+
+    failIfErrsM
+
+    -- Save the exports
+    setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do
+    tcg_env <- getGblEnv
+
+    -- STEP 4: Rename the interfaces
+    ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
+        tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
+    lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
+    let ifaces = lcl_iface : ext_ifaces
+
+    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
+    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+                            | (occ, f) <- concatMap mi_fixities ifaces
+                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]
+
+    -- STEP 5: Typecheck the interfaces
+    let type_env_var = tcg_type_env_var tcg_env
+
+    -- typecheckIfacesForMerging does two things:
+    --      1. It merges the all of the ifaces together, and typechecks the
+    --      result to type_env.
+    --      2. It typechecks each iface individually, but with their 'Name's
+    --      resolving to the merged type_env from (1).
+    -- See typecheckIfacesForMerging for more details.
+    (type_env, detailss) <- initIfaceTcRn $
+                            typecheckIfacesForMerging inner_mod ifaces type_env_var
+    let infos = zip ifaces detailss
+
+    -- Test for cycles
+    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
+
+    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
+    -- detailss, and given a Name that doesn't correspond to anything real.  See
+    -- also Note [Signature merging DFuns]
+
+    -- Add the merged type_env to TcGblEnv, so that it gets serialized
+    -- out when we finally write out the interface.
+    --
+    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
+    -- rather than use tcExtendGlobalEnv (the normal method to add newly
+    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these
+    -- TyThings to 'tcg_type_env_var', which is consulted when
+    -- we read in interfaces to tie the knot.  But *these TyThings themselves
+    -- come from interface*, so that would result in deadlock.  Don't
+    -- update it!
+    setGblEnv tcg_env {
+        tcg_tcs = typeEnvTyCons type_env,
+        tcg_patsyns = typeEnvPatSyns type_env,
+        tcg_type_env = type_env,
+        tcg_fix_env = fix_env
+        } $ do
+    tcg_env <- getGblEnv
+
+    -- STEP 6: Check for compatibility/merge things
+    tcg_env <- (\x -> foldM x tcg_env infos)
+             $ \tcg_env (iface, details) -> do
+
+        let check_export name
+              | Just sig_thing <- lookupTypeEnv (md_types details) name
+              = case lookupTypeEnv type_env (getName sig_thing) of
+                  Just thing -> checkHsigDeclM iface sig_thing thing
+                  Nothing -> panic "mergeSignatures: check_export"
+              -- Oops! We're looking for this export but it's
+              -- not actually in the type environment of the signature's
+              -- ModDetails.
+              --
+              -- NB: This case happens because the we're iterating
+              -- over the union of all exports, so some interfaces
+              -- won't have everything.  Note that md_exports is nonsense
+              -- (it's the same as exports); maybe we should fix this
+              -- eventually.
+              | otherwise
+              = return ()
+        mapM_ check_export (map availName exports)
+
+        -- Note [Signature merging instances]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- Merge instances into the global environment.  The algorithm here is
+        -- dumb and simple: if an instance has exactly the same DFun type
+        -- (tested by 'memberInstEnv') as an existing instance, we drop it;
+        -- otherwise, we add it even, even if this would cause overlap.
+        --
+        -- Why don't we deduplicate instances with identical heads?  There's no
+        -- good choice if they have premises:
+        --
+        --      instance K1 a => K (T a)
+        --      instance K2 a => K (T a)
+        --
+        -- Why not eagerly error in this case?  The overlapping head does not
+        -- necessarily mean that the instances are unimplementable: in fact,
+        -- they may be implemented without overlap (if, for example, the
+        -- implementing module has 'instance K (T a)'; both are implemented in
+        -- this case.)  The implements test just checks that the wanteds are
+        -- derivable assuming the givens.
+        --
+        -- Still, overlapping instances with hypotheses like above are going
+        -- to be a bad deal, because instance resolution when we're typechecking
+        -- against the merged signature is going to have a bad time when
+        -- there are overlapping heads like this: we never backtrack, so it
+        -- may be difficult to see that a wanted is derivable.  For now,
+        -- we hope that we get lucky / the overlapping instances never
+        -- get used, but it is not a very good situation to be in.
+        --
+        let merge_inst (insts, inst_env) inst
+                | memberInstEnv inst_env inst -- test DFun Type equality
+                = (insts, inst_env)
+                | otherwise
+                -- NB: is_dfun_name inst is still nonsense here,
+                -- see Note [Signature merging DFuns]
+                = (inst:insts, extendInstEnv inst_env inst)
+            (insts, inst_env) = foldl' merge_inst
+                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)
+                                    (md_insts details)
+            -- This is a HACK to prevent calculateAvails from including imp_mod
+            -- in the listing.  We don't want it because a module is NOT
+            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
+            iface' = iface { mi_orphan = False, mi_finsts = False }
+            avails = plusImportAvails (tcg_imports tcg_env) $
+                        calculateAvails dflags iface' False False ImportedBySystem
+        return tcg_env {
+            tcg_inst_env = inst_env,
+            tcg_insts    = insts,
+            tcg_imports  = avails,
+            tcg_merged   =
+                if outer_mod == mi_module iface
+                    -- Don't add ourselves!
+                    then tcg_merged tcg_env
+                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env
+            }
+
+    -- Note [Signature merging DFuns]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- Once we know all of instances which will be defined by this merged
+    -- signature, we go through each of the DFuns and rename them with a fresh,
+    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
+    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
+    --
+    -- We can't do this fixup earlier, because we need a way to identify each
+    -- source DFun (from each of the signatures we are merging in) so that
+    -- when we have a ClsInst, we can pull up the correct DFun to check if
+    -- the types match.
+    --
+    -- See also Note [rnIfaceNeverExported] in RnModIface
+    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
+        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
+        let dfun = setVarName (is_dfun inst) n
+        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
+    tcg_env <- return tcg_env {
+            tcg_insts = map snd dfun_insts,
+            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
+        }
+
+    addDependentFiles src_files
+
+    return tcg_env
+
+-- | Top-level driver for signature instantiation (run when compiling
+-- an @hsig@ file.)
+tcRnInstantiateSignature ::
+    HscEnv -> Module -> RealSrcSpan ->
+    IO (Messages, Maybe TcGblEnv)
+tcRnInstantiateSignature hsc_env this_mod real_loc =
+   withTiming (pure dflags)
+              (text "Signature instantiation"<+>brackets (ppr this_mod))
+              (const ()) $
+   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
+  where
+   dflags = hsc_dflags hsc_env
+
+exportOccs :: [AvailInfo] -> [OccName]
+exportOccs = concatMap (map occName . availNames)
+
+impl_msg :: Module -> IndefModule -> SDoc
+impl_msg impl_mod (IndefModule req_uid req_mod_name) =
+  text "while checking that" <+> ppr impl_mod <+>
+  text "implements signature" <+> ppr req_mod_name <+>
+  text "in" <+> ppr req_uid
+
+-- | Check if module implements a signature.  (The signature is
+-- always un-hashed, which is why its components are specified
+-- explicitly.)
+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
+checkImplements impl_mod req_mod@(IndefModule uid mod_name) =
+  addErrCtxt (impl_msg impl_mod req_mod) $ do
+    let insts = indefUnitIdInsts uid
+
+    -- STEP 1: Load the implementing interface, and make a RdrEnv
+    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',
+    -- so that we treat all orphan instances it provides as visible
+    -- when we verify that all instances are checked (see #12945), and so that
+    -- when we eventually write out the interface we record appropriate
+    -- dependency information.
+    impl_iface <- initIfaceTcRn $
+        loadSysInterface (text "checkImplements 1") impl_mod
+    let impl_gr = mkGlobalRdrEnv
+                    (gresFromAvails Nothing (mi_exports impl_iface))
+        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)
+
+    -- Load all the orphans, so the subsequent 'checkHsigIface' sees
+    -- all the instances it needs to
+    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
+                         (dep_orphs (mi_deps impl_iface))
+
+    dflags <- getDynFlags
+    let avails = calculateAvails dflags
+                    impl_iface False{- safe -} False{- boot -} ImportedBySystem
+        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+                            | (occ, f) <- mi_fixities impl_iface
+                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
+    updGblEnv (\tcg_env -> tcg_env {
+        -- Setting tcg_rdr_env to treat all exported entities from
+        -- the implementing module as in scope improves error messages,
+        -- as it reduces the amount of qualification we need.  Unfortunately,
+        -- we still end up qualifying references to external modules
+        -- (see bkpfail07 for an example); we'd need to record more
+        -- information in ModIface to solve this.
+        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
+        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
+        -- This is here so that when we call 'lookupFixityRn' for something
+        -- directly implemented by the module, we grab the right thing
+        tcg_fix_env = fix_env
+        }) $ do
+
+    -- STEP 2: Load the *unrenamed, uninstantiated* interface for
+    -- the ORIGINAL signature.  We are going to eventually rename it,
+    -- but we must proceed slowly, because it is NOT known if the
+    -- instantiation is correct.
+    let sig_mod = mkModule (IndefiniteUnitId uid) mod_name
+        isig_mod = fst (splitModuleInsts sig_mod)
+    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False
+    isig_iface <- case mb_isig_iface of
+        Succeeded (iface, _) -> return iface
+        Failed err -> failWithTc $
+            hang (text "Could not find hi interface for signature" <+>
+                  quotes (ppr isig_mod) <> colon) 4 err
+
+    -- STEP 3: Check that the implementing interface exports everything
+    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
+    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
+        case lookupGlobalRdrEnv impl_gr occ of
+            [] -> addErr $ quotes (ppr occ)
+                    <+> text "is exported by the hsig file, but not"
+                    <+> text "exported by the implementing module"
+                    <+> quotes (ppr impl_mod)
+            _ -> return ()
+    failIfErrsM
+
+    -- STEP 4: Now that the export is complete, rename the interface...
+    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
+
+    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst
+    -- lets us determine how top-level identifiers should be handled.)
+    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface
+
+    -- STEP 6: Check that it's sufficient
+    tcg_env <- getGblEnv
+    checkHsigIface tcg_env impl_gr sig_iface sig_details
+
+    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
+    -- so we write them out.
+    return tcg_env {
+        tcg_exports = mi_exports sig_iface
+        }
+
+-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
+-- library to use the actual implementations of the relevant entities,
+-- checking that the implementation matches the signature.
+instantiateSignature :: TcRn TcGblEnv
+instantiateSignature = do
+    tcg_env <- getGblEnv
+    dflags <- getDynFlags
+    let outer_mod = tcg_mod tcg_env
+        inner_mod = tcg_semantic_mod tcg_env
+    -- TODO: setup the local RdrEnv so the error messages look a little better.
+    -- But this information isn't stored anywhere. Should we RETYPECHECK
+    -- the local one just to get the information?  Hmm...
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    inner_mod `checkImplements`
+        IndefModule
+            (newIndefUnitId (thisComponentId dflags)
+                            (thisUnitIdInsts dflags))
+            (moduleName outer_mod)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcBinds.hs
@@ -0,0 +1,1738 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcBinds]{TcBinds}
+-}
+
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
+                 tcHsBootSigs, tcPolyCheck,
+                 addTypecheckedBinds,
+                 chooseInferredQuantifiers,
+                 badBootDeclErr ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
+import CoreSyn (Tickish (..))
+import CostCentre (mkUserCC, CCFlavour(DeclCC))
+import DynFlags
+import FastString
+import HsSyn
+import HscTypes( isHsBootOrSig )
+import TcSigs
+import TcRnMonad
+import TcEnv
+import TcUnify
+import TcSimplify
+import TcEvidence
+import TcHsType
+import TcPat
+import TcMType
+import FamInstEnv( normaliseType )
+import FamInst( tcGetFamInstEnvs )
+import TyCon
+import TcType
+import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
+import TysPrim
+import TysWiredIn( mkBoxedTupleTy )
+import Id
+import Var
+import VarSet
+import VarEnv( TidyEnv )
+import Module
+import Name
+import NameSet
+import NameEnv
+import SrcLoc
+import Bag
+import ErrUtils
+import Digraph
+import Maybes
+import Util
+import BasicTypes
+import Outputable
+import PrelNames( ipClassName )
+import TcValidity (checkValidType)
+import UniqFM
+import UniqSet
+import qualified GHC.LanguageExtensions as LangExt
+import ConLike
+
+import Control.Monad
+
+#include "HsVersions.h"
+
+{- *********************************************************************
+*                                                                      *
+               A useful helper function
+*                                                                      *
+********************************************************************* -}
+
+addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
+addTypecheckedBinds tcg_env binds
+  | isHsBootOrSig (tcg_src tcg_env) = tcg_env
+    -- Do not add the code for record-selector bindings
+    -- when compiling hs-boot files
+  | otherwise = tcg_env { tcg_binds = foldr unionBags
+                                            (tcg_binds tcg_env)
+                                            binds }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Type-checking bindings}
+*                                                                      *
+************************************************************************
+
+@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
+it needs to know something about the {\em usage} of the things bound,
+so that it can create specialisations of them.  So @tcBindsAndThen@
+takes a function which, given an extended environment, E, typechecks
+the scope of the bindings returning a typechecked thing and (most
+important) an LIE.  It is this LIE which is then used as the basis for
+specialising the things bound.
+
+@tcBindsAndThen@ also takes a "combiner" which glues together the
+bindings and the "thing" to make a new "thing".
+
+The real work is done by @tcBindWithSigsAndThen@.
+
+Recursive and non-recursive binds are handled in essentially the same
+way: because of uniques there are no scoping issues left.  The only
+difference is that non-recursive bindings can bind primitive values.
+
+Even for non-recursive binding groups we add typings for each binder
+to the LVE for the following reason.  When each individual binding is
+checked the type of its LHS is unified with that of its RHS; and
+type-checking the LHS of course requires that the binder is in scope.
+
+At the top-level the LIE is sure to contain nothing but constant
+dictionaries, which we resolve at the module level.
+
+Note [Polymorphic recursion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is
+
+        * Bind any variable for which we have a type signature
+          to an Id with a polymorphic type.  Then when type-checking
+          the RHSs we'll make a full polymorphic call.
+
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
+
+        f :: Eq a => [a] -> [a]
+        f xs = ...f...
+
+If we don't take care, after typechecking we get
+
+        f = /\a -> \d::Eq a -> let f' = f a d
+                               in
+                               \ys:[a] -> ...f'...
+
+Notice the stupid construction of (f a d), which is of course
+identical to the function we're executing.  In this case, the
+polymorphic recursion isn't being used (but that's a very common case).
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
+
+        ff :: [Int] -> [Int]
+        ff = f Int dEqInt
+
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
+
+        ff = f Int dEqInt
+
+           = let f' = f Int dEqInt in \ys. ...f'...
+
+           = let f' = let f' = f Int dEqInt in \ys. ...f'...
+                      in \ys. ...f'...
+
+Etc.
+
+NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
+which would make the space leak go away in this case
+
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding.  So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints.  That's what the "lies_avail"
+is doing.
+
+Then we get
+
+        f = /\a -> \d::Eq a -> letrec
+                                 fm = \ys:[a] -> ...fm...
+                               in
+                               fm
+-}
+
+tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
+           -> TcM (TcGblEnv, TcLclEnv)
+-- The TcGblEnv contains the new tcg_binds and tcg_spects
+-- The TcLclEnv has an extended type envt for the new bindings
+tcTopBinds binds sigs
+  = do  { -- Pattern synonym bindings populate the global environment
+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
+            do { gbl <- getGblEnv
+               ; lcl <- getLclEnv
+               ; return (gbl, lcl) }
+        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids
+
+        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
+        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)
+        ; traceTc "complete_matches" (ppr complete_matches)
+
+        ; let { tcg_env' = tcg_env { tcg_imp_specs
+                                      = specs ++ tcg_imp_specs tcg_env
+                                   , tcg_complete_matches
+                                      = complete_matches
+                                          ++ tcg_complete_matches tcg_env }
+                           `addTypecheckedBinds` map snd binds' }
+
+        ; return (tcg_env', tcl_env) }
+        -- The top level bindings are flattened into a giant
+        -- implicitly-mutually-recursive LHsBinds
+
+
+-- Note [Typechecking Complete Matches]
+-- Much like when a user bundled a pattern synonym, the result types of
+-- all the constructors in the match pragma must be consistent.
+--
+-- If we allowed pragmas with inconsistent types then it would be
+-- impossible to ever match every constructor in the list and so
+-- the pragma would be useless.
+
+
+
+
+
+-- This is only used in `tcCompleteSig`. We fold over all the conlikes,
+-- this accumulator keeps track of the first `ConLike` with a concrete
+-- return type. After fixing the return type, all other constructors with
+-- a fixed return type must agree with this.
+--
+-- The fields of `Fixed` cache the first conlike and its return type so
+-- that that we can compare all the other conlikes to it. The conlike is
+-- stored for error messages.
+--
+-- `Nothing` in the case that the type is fixed by a type signature
+data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon
+
+tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
+tcCompleteSigs sigs =
+  let
+      doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
+      doOne c@(CompleteMatchSig _ _ lns mtc)
+        = fmap Just $ do
+           addErrCtxt (text "In" <+> ppr c) $
+            case mtc of
+              Nothing -> infer_complete_match
+              Just tc -> check_complete_match tc
+        where
+
+          checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)
+
+          infer_complete_match = do
+            (res, cls) <- checkCLTypes AcceptAny
+            case res of
+              AcceptAny -> failWithTc ambiguousError
+              Fixed _ tc  -> return $ mkMatch cls tc
+
+          check_complete_match tc_name = do
+            ty_con <- tcLookupLocatedTyCon tc_name
+            (_, cls) <- checkCLTypes (Fixed Nothing ty_con)
+            return $ mkMatch cls ty_con
+
+          mkMatch :: [ConLike] -> TyCon -> CompleteMatch
+          mkMatch cls ty_con = CompleteMatch {
+            completeMatchConLikes = map conLikeName cls,
+            completeMatchTyCon = tyConName ty_con
+            }
+      doOne _ = return Nothing
+
+      ambiguousError :: SDoc
+      ambiguousError =
+        text "A type signature must be provided for a set of polymorphic"
+          <+> text "pattern synonyms."
+
+
+      -- See note [Typechecking Complete Matches]
+      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
+                  -> TcM (CompleteSigType, [ConLike])
+      checkCLType (cst, cs) n = do
+        cl <- addLocM tcLookupConLike n
+        let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
+              res_ty_con = fst <$> splitTyConApp_maybe res_ty
+        case (cst, res_ty_con) of
+          (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)
+          (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)
+          (Fixed mfcl tc, Nothing)  -> return (Fixed mfcl tc, cl:cs)
+          (Fixed mfcl tc, Just tc') ->
+            if tc == tc'
+              then return (Fixed mfcl tc, cl:cs)
+              else case mfcl of
+                     Nothing ->
+                      addErrCtxt (text "In" <+> ppr cl) $
+                        failWithTc typeSigErrMsg
+                     Just cl -> failWithTc (errMsg cl)
+             where
+              typeSigErrMsg :: SDoc
+              typeSigErrMsg =
+                text "Couldn't match expected type"
+                      <+> quotes (ppr tc)
+                      <+> text "with"
+                      <+> quotes (ppr tc')
+
+              errMsg :: ConLike -> SDoc
+              errMsg fcl =
+                text "Cannot form a group of complete patterns from patterns"
+                  <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)
+                  <+> text "as they match different type constructors"
+                  <+> parens (quotes (ppr tc)
+                               <+> text "resp."
+                               <+> quotes (ppr tc'))
+  in  mapMaybeM (addLocM doOne) sigs
+
+tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it.  The renamer checked all this
+tcHsBootSigs binds sigs
+  = do  { checkTc (null binds) badBootDeclErr
+        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
+  where
+    tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
+      where
+        f (dL->L _ name)
+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
+               ; return (mkVanillaGlobal name sigma_ty) }
+        -- Notice that we make GlobalIds, not LocalIds
+    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
+
+badBootDeclErr :: MsgDoc
+badBootDeclErr = text "Illegal declarations in an hs-boot file"
+
+------------------------
+tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
+             -> TcM (HsLocalBinds GhcTcId, thing)
+
+tcLocalBinds (EmptyLocalBinds x) thing_inside
+  = do  { thing <- thing_inside
+        ; return (EmptyLocalBinds x, thing) }
+
+tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
+  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
+        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
+tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
+
+tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
+  = do  { ipClass <- tcLookupClass ipClassName
+        ; (given_ips, ip_binds') <-
+            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
+
+        -- If the binding binds ?x = E, we  must now
+        -- discharge any ?x constraints in expr_lie
+        -- See Note [Implicit parameter untouchables]
+        ; (ev_binds, result) <- checkConstraints (IPSkol ips)
+                                  [] given_ips thing_inside
+
+        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
+  where
+    ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]
+
+        -- I wonder if we should do these one at at time
+        -- Consider     ?x = 4
+        --              ?y = ?x + 1
+    tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)
+       = do { ty <- newOpenFlexiTyVarTy
+            ; let p = mkStrLitTy $ hsIPNameFS ip
+            ; ip_id <- newDict ipClass [ p, ty ]
+            ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
+            ; let d = toDict ipClass p ty `fmap` expr'
+            ; return (ip_id, (IPBind noExt (Right ip_id) d)) }
+    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
+    tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"
+
+    -- Coerces a `t` into a dictionry for `IP "x" t`.
+    -- co : t -> IP "x" t
+    toDict ipClass x ty = mkHsWrap $ mkWpCastR $
+                          wrapIP $ mkClassPred ipClass [x,ty]
+
+tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
+tcLocalBinds (XHsLocalBindsLR _)           _ = panic "tcLocalBinds"
+
+{- Note [Implicit parameter untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We add the type variables in the types of the implicit parameters
+as untouchables, not so much because we really must not unify them,
+but rather because we otherwise end up with constraints like this
+    Num alpha, Implic { wanted = alpha ~ Int }
+The constraint solver solves alpha~Int by unification, but then
+doesn't float that solved constraint out (it's not an unsolved
+wanted).  Result disaster: the (Num alpha) is again solved, this
+time by defaulting.  No no no.
+
+However [Oct 10] this is all handled automatically by the
+untouchable-range idea.
+-}
+
+tcValBinds :: TopLevelFlag
+           -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
+           -> TcM thing
+           -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
+
+tcValBinds top_lvl binds sigs thing_inside
+  = do  {   -- Typecheck the signatures
+            -- It's easier to do so now, once for all the SCCs together
+            -- because a single signature  f,g :: <type>
+            -- might relate to more than one SCC
+        ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
+                                tcTySigs sigs
+
+                -- Extend the envt right away with all the Ids
+                -- declared with complete type signatures
+                -- Do not extend the TcBinderStack; instead
+                -- we extend it on a per-rhs basis in tcExtendForRhs
+        ; tcExtendSigIds top_lvl poly_ids $ do
+            { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
+                   { thing <- thing_inside
+                     -- See Note [Pattern synonym builders don't yield dependencies]
+                     --     in RnBinds
+                   ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
+                   ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
+                   ; return (extra_binds, thing) }
+            ; return (binds' ++ extra_binds', thing) }}
+  where
+    patsyns = getPatSynBinds binds
+    prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
+
+------------------------
+tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
+             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
+             -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
+-- Typecheck a whole lot of value bindings,
+-- one strongly-connected component at a time
+-- Here a "strongly connected component" has the strightforward
+-- meaning of a group of bindings that mention each other,
+-- ignoring type signatures (that part comes later)
+
+tcBindGroups _ _ _ [] thing_inside
+  = do  { thing <- thing_inside
+        ; return ([], thing) }
+
+tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
+  = do  { -- See Note [Closed binder groups]
+          type_env <- getLclTypeEnv
+        ; let closed = isClosedBndrGroup type_env (snd group)
+        ; (group', (groups', thing))
+                <- tc_group top_lvl sig_fn prag_fn group closed $
+                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
+        ; return (group' ++ groups', thing) }
+
+-- Note [Closed binder groups]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+--  A mutually recursive group is "closed" if all of the free variables of
+--  the bindings are closed. For example
+--
+-- >  h = \x -> let f = ...g...
+-- >                g = ....f...x...
+-- >             in ...
+--
+-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
+-- closed.
+--
+-- So we need to compute closed-ness on each strongly connected components,
+-- before we sub-divide it based on what type signatures it has.
+--
+
+------------------------
+tc_group :: forall thing.
+            TopLevelFlag -> TcSigFun -> TcPragEnv
+         -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
+         -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
+
+-- Typecheck one strongly-connected component of the original program.
+-- We get a list of groups back, because there may
+-- be specialisations etc as well
+
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
+        -- A single non-recursive binding
+        -- We want to keep non-recursive things non-recursive
+        -- so that we desugar unlifted bindings correctly
+  = do { let bind = case bagToList binds of
+                 [bind] -> bind
+                 []     -> panic "tc_group: empty list of binds"
+                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"
+       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
+                                     thing_inside
+       ; return ( [(NonRecursive, bind')], thing) }
+
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
+  =     -- To maximise polymorphism, we do a new
+        -- strongly-connected-component analysis, this time omitting
+        -- any references to variables with type signatures.
+        -- (This used to be optional, but isn't now.)
+        -- See Note [Polymorphic recursion] in HsBinds.
+    do  { traceTc "tc_group rec" (pprLHsBinds binds)
+        ; when hasPatSyn $ recursivePatSynErr binds
+        ; (binds1, thing) <- go sccs
+        ; return ([(Recursive, binds1)], thing) }
+                -- Rec them all together
+  where
+    hasPatSyn = anyBag (isPatSyn . unLoc) binds
+    isPatSyn PatSynBind{} = True
+    isPatSyn _ = False
+
+    sccs :: [SCC (LHsBind GhcRn)]
+    sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
+
+    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)
+    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn
+                                                            closed ids1 $
+                                             go sccs
+                        ; return (binds1 `unionBags` binds2, thing) }
+    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }
+
+    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
+    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
+
+    tc_sub_group rec_tc binds =
+      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
+
+recursivePatSynErr :: OutputableBndrId (GhcPass p) =>
+                      LHsBinds (GhcPass p) -> TcM a
+recursivePatSynErr binds
+  = failWithTc $
+    hang (text "Recursive pattern synonym definition with following bindings:")
+       2 (vcat $ map pprLBind . bagToList $ binds)
+  where
+    pprLoc loc  = parens (text "defined at" <+> ppr loc)
+    pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)
+                                <+> pprLoc loc
+
+tc_single :: forall thing.
+            TopLevelFlag -> TcSigFun -> TcPragEnv
+          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
+          -> TcM (LHsBinds GhcTcId, thing)
+tc_single _top_lvl sig_fn _prag_fn
+          (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) }))
+          _ thing_inside
+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
+       ; thing <- setGblEnv tcg_env thing_inside
+       ; return (aux_binds, thing)
+       }
+
+tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
+  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
+                                      NonRecursive NonRecursive
+                                      closed
+                                      [lbind]
+       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
+       ; return (binds1, thing) }
+
+------------------------
+type BKey = Int -- Just number off the bindings
+
+mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
+-- See Note [Polymorphic recursion] in HsBinds.
+mkEdges sig_fn binds
+  = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
+                         Just key <- [lookupNameEnv key_map n], no_sig n ]
+    | (bind, key) <- keyd_binds
+    ]
+    -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
+    -- is still deterministic even if the edges are in nondeterministic order
+    -- as explained in Note [Deterministic SCC] in Digraph.
+  where
+    bind_fvs (FunBind { fun_ext = fvs }) = fvs
+    bind_fvs (PatBind { pat_ext = fvs }) = fvs
+    bind_fvs _                           = emptyNameSet
+
+    no_sig :: Name -> Bool
+    no_sig n = not (hasCompleteSig sig_fn n)
+
+    keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+    key_map :: NameEnv BKey     -- Which binding it comes from
+    key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds
+                                     , bndr <- collectHsBindBinders bind ]
+
+------------------------
+tcPolyBinds :: TcSigFun -> TcPragEnv
+            -> RecFlag         -- Whether the group is really recursive
+            -> RecFlag         -- Whether it's recursive after breaking
+                               -- dependencies based on type signatures
+            -> IsGroupClosed   -- Whether the group is closed
+            -> [LHsBind GhcRn]  -- None are PatSynBind
+            -> TcM (LHsBinds GhcTcId, [TcId])
+
+-- Typechecks a single bunch of values bindings all together,
+-- and generalises them.  The bunch may be only part of a recursive
+-- group, because we use type signatures to maximise polymorphism
+--
+-- Returns a list because the input may be a single non-recursive binding,
+-- in which case the dependency order of the resulting bindings is
+-- important.
+--
+-- Knows nothing about the scope of the bindings
+-- None of the bindings are pattern synonyms
+
+tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
+  = setSrcSpan loc                              $
+    recoverM (recoveryCode binder_names sig_fn) $ do
+        -- Set up main recover; take advantage of any type sigs
+
+    { traceTc "------------------------------------------------" Outputable.empty
+    ; traceTc "Bindings for {" (ppr binder_names)
+    ; dflags   <- getDynFlags
+    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
+    ; traceTc "Generalisation plan" (ppr plan)
+    ; result@(_, poly_ids) <- case plan of
+         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
+         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
+         CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
+
+    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
+                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
+                                          ])
+
+    ; return result }
+  where
+    binder_names = collectHsBindListBinders bind_list
+    loc = foldr1 combineSrcSpans (map getLoc bind_list)
+         -- The mbinds have been dependency analysed and
+         -- may no longer be adjacent; so find the narrowest
+         -- span that includes them all
+
+--------------
+-- If typechecking the binds fails, then return with each
+-- signature-less binder given type (forall a.a), to minimise
+-- subsequent error messages
+recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id])
+recoveryCode binder_names sig_fn
+  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
+        ; let poly_ids = map mk_dummy binder_names
+        ; return (emptyBag, poly_ids) }
+  where
+    mk_dummy name
+      | Just sig <- sig_fn name
+      , Just poly_id <- completeSigPolyId_maybe sig
+      = poly_id
+      | otherwise
+      = mkLocalId name forall_a_a
+
+forall_a_a :: TcType
+-- At one point I had (forall r (a :: TYPE r). a), but of course
+-- that type is ill-formed: its mentions 'r' which escapes r's scope.
+-- Another alternative would be (forall (a :: TYPE kappa). a), where
+-- kappa is a unification variable. But I don't think we need that
+-- complication here. I'm going to just use (forall (a::*). a).
+-- See #15276
+forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
+
+{- *********************************************************************
+*                                                                      *
+                         tcPolyNoGen
+*                                                                      *
+********************************************************************* -}
+
+tcPolyNoGen     -- No generalisation whatsoever
+  :: RecFlag       -- Whether it's recursive after breaking
+                   -- dependencies based on type signatures
+  -> TcPragEnv -> TcSigFun
+  -> [LHsBind GhcRn]
+  -> TcM (LHsBinds GhcTcId, [TcId])
+
+tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
+  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
+                                             (LetGblBndr prag_fn)
+                                             bind_list
+       ; mono_ids' <- mapM tc_mono_info mono_infos
+       ; return (binds', mono_ids') }
+  where
+    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
+      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
+           ; return mono_id }
+           -- NB: tcPrags generates error messages for
+           --     specialisation pragmas for non-overloaded sigs
+           -- Indeed that is why we call it here!
+           -- So we can safely ignore _specs
+
+
+{- *********************************************************************
+*                                                                      *
+                         tcPolyCheck
+*                                                                      *
+********************************************************************* -}
+
+tcPolyCheck :: TcPragEnv
+            -> TcIdSigInfo     -- Must be a complete signature
+            -> LHsBind GhcRn   -- Must be a FunBind
+            -> TcM (LHsBinds GhcTcId, [TcId])
+-- There is just one binding,
+--   it is a Funbind
+--   it has a complete type signature,
+tcPolyCheck prag_fn
+            (CompleteSig { sig_bndr  = poly_id
+                         , sig_ctxt  = ctxt
+                         , sig_loc   = sig_loc })
+            (dL->L loc (FunBind { fun_id = (dL->L nm_loc name)
+                                , fun_matches = matches }))
+  = setSrcSpan sig_loc $
+    do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
+       ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
+                -- See Note [Instantiate sig with fresh variables]
+
+       ; mono_name <- newNameAt (nameOccName name) nm_loc
+       ; ev_vars   <- newEvVars theta
+       ; let mono_id   = mkLocalId mono_name tau
+             skol_info = SigSkol ctxt (idType poly_id) tv_prs
+             skol_tvs  = map snd tv_prs
+
+       ; (ev_binds, (co_fn, matches'))
+            <- checkConstraints skol_info skol_tvs ev_vars $
+               tcExtendBinderStack [TcIdBndr mono_id NotTopLevel]  $
+               tcExtendNameTyVarEnv tv_prs $
+               setSrcSpan loc           $
+               tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)
+
+       ; let prag_sigs = lookupPragEnv prag_fn name
+       ; spec_prags <- tcSpecPrags poly_id prag_sigs
+       ; poly_id    <- addInlinePrags poly_id prag_sigs
+
+       ; mod <- getModule
+       ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
+       ; let bind' = FunBind { fun_id      = cL nm_loc mono_id
+                             , fun_matches = matches'
+                             , fun_co_fn   = co_fn
+                             , fun_ext     = placeHolderNamesTc
+                             , fun_tick    = tick }
+
+             export = ABE { abe_ext = noExt
+                          , abe_wrap = idHsWrapper
+                          , abe_poly  = poly_id
+                          , abe_mono  = mono_id
+                          , abe_prags = SpecPrags spec_prags }
+
+             abs_bind = cL loc $
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs      = skol_tvs
+                                 , abs_ev_vars  = ev_vars
+                                 , abs_ev_binds = [ev_binds]
+                                 , abs_exports  = [export]
+                                 , abs_binds    = unitBag (cL loc bind')
+                                 , abs_sig      = True }
+
+       ; return (unitBag abs_bind, [poly_id]) }
+
+tcPolyCheck _prag_fn sig bind
+  = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
+
+funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
+             -> TcM [Tickish TcId]
+funBindTicks loc fun_id mod sigs
+  | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]
+      -- this can only be a singleton list, as duplicate pragmas are rejected
+      -- by the renamer
+  , let cc_str
+          | Just cc_str <- mb_cc_str
+          = sl_fs $ unLoc cc_str
+          | otherwise
+          = getOccFS (Var.varName fun_id)
+        cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
+  = do
+      flavour <- DeclCC <$> getCCIndexM cc_name
+      let cc = mkUserCC cc_name mod loc flavour
+      return [ProfNote cc True True]
+  | otherwise
+  = return []
+
+{- Note [Instantiate sig with fresh variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's vital to instantiate a type signature with fresh variables.
+For example:
+      type T = forall a. [a] -> [a]
+      f :: T;
+      f = g where { g :: T; g = <rhs> }
+
+ We must not use the same 'a' from the defn of T at both places!!
+(Instantiation is only necessary because of type synonyms.  Otherwise,
+it's all cool; each signature has distinct type variables from the renamer.)
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+                         tcPolyInfer
+*                                                                      *
+********************************************************************* -}
+
+tcPolyInfer
+  :: RecFlag       -- Whether it's recursive after breaking
+                   -- dependencies based on type signatures
+  -> TcPragEnv -> TcSigFun
+  -> Bool         -- True <=> apply the monomorphism restriction
+  -> [LHsBind GhcRn]
+  -> TcM (LHsBinds GhcTcId, [TcId])
+tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
+  = do { (tclvl, wanted, (binds', mono_infos))
+             <- pushLevelAndCaptureConstraints  $
+                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
+
+       ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))
+                          | info <- mono_infos ]
+             sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
+             infer_mode = if mono then ApplyMR else NoRestrictions
+
+       ; mapM_ (checkOverloadedSig mono) sigs
+
+       ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
+       ; (qtvs, givens, ev_binds, residual, insoluble)
+                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
+       ; emitConstraints residual
+
+       ; let inferred_theta = map evVarPred givens
+       ; exports <- checkNoErrs $
+                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
+
+       ; loc <- getSrcSpanM
+       ; let poly_ids = map abe_poly exports
+             abs_bind = cL loc $
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs = qtvs
+                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
+                                 , abs_exports = exports, abs_binds = binds'
+                                 , abs_sig = False }
+
+       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
+       ; return (unitBag abs_bind, poly_ids) }
+         -- poly_ids are guaranteed zonked by mkExport
+
+--------------
+mkExport :: TcPragEnv
+         -> Bool                        -- True <=> there was an insoluble type error
+                                        --          when typechecking the bindings
+         -> [TyVar] -> TcThetaType      -- Both already zonked
+         -> MonoBindInfo
+         -> TcM (ABExport GhcTc)
+-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
+--
+-- mkExport generates exports with
+--      zonked type variables,
+--      zonked poly_ids
+-- The former is just because no further unifications will change
+-- the quantified type variables, so we can fix their final form
+-- right now.
+-- The latter is needed because the poly_ids are used to extend the
+-- type environment; see the invariant on TcEnv.tcExtendIdEnv
+
+-- Pre-condition: the qtvs and theta are already zonked
+
+mkExport prag_fn insoluble qtvs theta
+         mono_info@(MBI { mbi_poly_name = poly_name
+                        , mbi_sig       = mb_sig
+                        , mbi_mono_id   = mono_id })
+  = do  { mono_ty <- zonkTcType (idType mono_id)
+        ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
+
+        -- NB: poly_id has a zonked type
+        ; poly_id <- addInlinePrags poly_id prag_sigs
+        ; spec_prags <- tcSpecPrags poly_id prag_sigs
+                -- tcPrags requires a zonked poly_id
+
+        -- See Note [Impedance matching]
+        -- NB: we have already done checkValidType, including an ambiguity check,
+        --     on the type; either when we checked the sig or in mkInferredPolyId
+        ; let poly_ty     = idType poly_id
+              sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
+                -- This type is just going into tcSubType,
+                -- so Inferred vs. Specified doesn't matter
+
+        ; wrap <- if sel_poly_ty `eqType` poly_ty  -- NB: eqType ignores visibility
+                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer
+                                           -- an ambiguous type and have AllowAmbiguousType
+                                           -- e..g infer  x :: forall a. F a -> Int
+                  else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
+                       tcSubType_NC sig_ctxt sel_poly_ty poly_ty
+
+        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
+        ; when warn_missing_sigs $
+              localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
+
+        ; return (ABE { abe_ext = noExt
+                      , abe_wrap = wrap
+                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
+                      , abe_poly  = poly_id
+                      , abe_mono  = mono_id
+                      , abe_prags = SpecPrags spec_prags }) }
+  where
+    prag_sigs = lookupPragEnv prag_fn poly_name
+    sig_ctxt  = InfSigCtxt poly_name
+
+mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when
+                          --          checking the binding group for this Id
+                 -> [TyVar] -> TcThetaType
+                 -> Name -> Maybe TcIdSigInst -> TcType
+                 -> TcM TcId
+mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
+  | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst
+  , CompleteSig { sig_bndr = poly_id } <- sig
+  = return poly_id
+
+  | otherwise  -- Either no type sig or partial type sig
+  = checkNoErrs $  -- The checkNoErrs ensures that if the type is ambiguous
+                   -- we don't carry on to the impedance matching, and generate
+                   -- a duplicate ambiguity error.  There is a similar
+                   -- checkNoErrs for complete type signatures too.
+    do { fam_envs <- tcGetFamInstEnvs
+       ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
+               -- Unification may not have normalised the type,
+               -- (see Note [Lazy flattening] in TcFlatten) so do it
+               -- here to make it as uncomplicated as possible.
+               -- Example: f :: [F Int] -> Bool
+               -- should be rewritten to f :: [Char] -> Bool, if possible
+               --
+               -- We can discard the coercion _co, because we'll reconstruct
+               -- it in the call to tcSubType below
+
+       ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
+                                (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
+
+       ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
+
+       ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
+                                          , ppr inferred_poly_ty])
+       ; unless insoluble $
+         addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
+         checkValidType (InfSigCtxt poly_name) inferred_poly_ty
+         -- See Note [Validity of inferred types]
+         -- If we found an insoluble error in the function definition, don't
+         -- do this check; otherwise (#14000) we may report an ambiguity
+         -- error for a rather bogus type.
+
+       ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
+
+
+chooseInferredQuantifiers :: TcThetaType   -- inferred
+                          -> TcTyVarSet    -- tvs free in tau type
+                          -> [TcTyVar]     -- inferred quantified tvs
+                          -> Maybe TcIdSigInst
+                          -> TcM ([TyVarBinder], TcThetaType)
+chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
+  = -- No type signature (partial or complete) for this binder,
+    do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
+                        -- Include kind variables!  #7916
+             my_theta = pickCapturedPreds free_tvs inferred_theta
+             binders  = [ mkTyVarBinder Inferred tv
+                        | tv <- qtvs
+                        , tv `elemVarSet` free_tvs ]
+       ; return (binders, my_theta) }
+
+chooseInferredQuantifiers inferred_theta tau_tvs qtvs
+                          (Just (TISI { sig_inst_sig   = sig  -- Always PartialSig
+                                      , sig_inst_wcx   = wcx
+                                      , sig_inst_theta = annotated_theta
+                                      , sig_inst_skols = annotated_tvs }))
+  = -- Choose quantifiers for a partial type signature
+    do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs
+
+            -- Check whether the quantified variables of the
+            -- partial signature have been unified together
+            -- See Note [Quantified variables in partial type signatures]
+       ; mapM_ report_dup_tyvar_tv_err  (findDupTyVarTvs psig_qtv_prs)
+
+            -- Check whether a quantified variable of the partial type
+            -- signature is not actually quantified.  How can that happen?
+            -- See Note [Quantification and partial signatures] Wrinkle 4
+            --     in TcSimplify
+       ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs
+                                          , not (tv `elem` qtvs) ]
+
+       ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)
+
+       ; annotated_theta      <- zonkTcTypes annotated_theta
+       ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx
+
+       ; let keep_me    = free_tvs `unionVarSet` psig_qtvs
+             final_qtvs = [ mkTyVarBinder vis tv
+                          | tv <- qtvs -- Pulling from qtvs maintains original order
+                          , tv `elemVarSet` keep_me
+                          , let vis | tv `elemVarSet` psig_qtvs = Specified
+                                    | otherwise                 = Inferred ]
+
+       ; return (final_qtvs, my_theta) }
+  where
+    report_dup_tyvar_tv_err (n1,n2)
+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
+      = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
+                     2 (hang (text "both bound by the partial type signature:")
+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
+
+      | otherwise -- Can't happen; by now we know it's a partial sig
+      = pprPanic "report_tyvar_tv_err" (ppr sig)
+
+    report_mono_sig_tv_err n
+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
+      = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))
+                     2 (hang (text "bound by the partial type signature:")
+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
+      | otherwise -- Can't happen; by now we know it's a partial sig
+      = pprPanic "report_mono_sig_tv_err" (ppr sig)
+
+    choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
+                        -> TcM (VarSet, TcThetaType)
+    choose_psig_context _ annotated_theta Nothing
+      = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
+                                            `unionVarSet` tau_tvs)
+           ; return (free_tvs, annotated_theta) }
+
+    choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
+      = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
+                            -- growThetaVars just like the no-type-sig case
+                            -- Omitting this caused #12844
+                 seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there
+                            `unionVarSet` tau_tvs            --       by the user
+
+           ; let keep_me  = psig_qtvs `unionVarSet` free_tvs
+                 my_theta = pickCapturedPreds keep_me inferred_theta
+
+           -- Fill in the extra-constraints wildcard hole with inferred_theta,
+           -- so that the Hole constraint we have already emitted
+           -- (in tcHsPartialSigType) can report what filled it in.
+           -- NB: my_theta already includes all the annotated constraints
+           ; let inferred_diff = [ pred
+                                 | pred <- my_theta
+                                 , all (not . (`eqType` pred)) annotated_theta ]
+           ; ctuple <- mk_ctuple inferred_diff
+
+           ; case tcGetCastedTyVar_maybe wc_var_ty of
+               -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
+               -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
+               -- make the kinds work out, we reverse the cast here.
+               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
+               Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
+
+           ; traceTc "completeTheta" $
+                vcat [ ppr sig
+                     , ppr annotated_theta, ppr inferred_theta
+                     , ppr inferred_diff ]
+           ; return (free_tvs, my_theta) }
+
+    mk_ctuple preds = return (mkBoxedTupleTy preds)
+       -- Hack alert!  See TcHsType:
+       -- Note [Extra-constraint holes in partial type signatures]
+
+
+mk_impedance_match_msg :: MonoBindInfo
+                       -> TcType -> TcType
+                       -> TidyEnv -> TcM (TidyEnv, SDoc)
+-- This is a rare but rather awkward error messages
+mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
+                       inf_ty sig_ty tidy_env
+ = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env  inf_ty
+      ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
+      ; let msg = vcat [ text "When checking that the inferred type"
+                       , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
+                       , text "is as general as its" <+> what <+> text "signature"
+                       , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
+      ; return (tidy_env2, msg) }
+  where
+    what = case mb_sig of
+             Nothing                     -> text "inferred"
+             Just sig | isPartialSig sig -> text "(partial)"
+                      | otherwise        -> empty
+
+
+mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
+mk_inf_msg poly_name poly_ty tidy_env
+ = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
+      ; let msg = vcat [ text "When checking the inferred type"
+                       , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
+      ; return (tidy_env1, msg) }
+
+
+-- | Warn the user about polymorphic local binders that lack type signatures.
+localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
+localSigWarn flag id mb_sig
+  | Just _ <- mb_sig               = return ()
+  | not (isSigmaTy (idType id))    = return ()
+  | otherwise                      = warnMissingSignatures flag msg id
+  where
+    msg = text "Polymorphic local binding with no type signature:"
+
+warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
+warnMissingSignatures flag msg id
+  = do  { env0 <- tcInitTidyEnv
+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
+        ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
+  where
+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
+
+checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
+-- Example:
+--   f :: Eq a => a -> a
+--   K f = e
+-- The MR applies, but the signature is overloaded, and it's
+-- best to complain about this directly
+-- c.f #11339
+checkOverloadedSig monomorphism_restriction_applies sig
+  | not (null (sig_inst_theta sig))
+  , monomorphism_restriction_applies
+  , let orig_sig = sig_inst_sig sig
+  = setSrcSpan (sig_loc orig_sig) $
+    failWith $
+    hang (text "Overloaded signature conflicts with monomorphism restriction")
+       2 (ppr orig_sig)
+  | otherwise
+  = return ()
+
+{- Note [Partial type signatures and generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If /any/ of the signatures in the gropu is a partial type signature
+   f :: _ -> Int
+then we *always* use the InferGen plan, and hence tcPolyInfer.
+We do this even for a local binding with -XMonoLocalBinds, when
+we normally use NoGen.
+
+Reasons:
+  * The TcSigInfo for 'f' has a unification variable for the '_',
+    whose TcLevel is one level deeper than the current level.
+    (See pushTcLevelM in tcTySig.)  But NoGen doesn't increase
+    the TcLevel like InferGen, so we lose the level invariant.
+
+  * The signature might be   f :: forall a. _ -> a
+    so it really is polymorphic.  It's not clear what it would
+    mean to use NoGen on this, and indeed the ASSERT in tcLhs,
+    in the (Just sig) case, checks that if there is a signature
+    then we are using LetLclBndr, and hence a nested AbsBinds with
+    increased TcLevel
+
+It might be possible to fix these difficulties somehow, but there
+doesn't seem much point.  Indeed, adding a partial type signature is a
+way to get per-binding inferred generalisation.
+
+We apply the MR if /all/ of the partial signatures lack a context.
+In particular (#11016):
+   f2 :: (?loc :: Int) => _
+   f2 = ?loc
+It's stupid to apply the MR here.  This test includes an extra-constraints
+wildcard; that is, we don't apply the MR if you write
+   f3 :: _ => blah
+
+Note [Quantified variables in partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: forall a. a -> a -> _
+  f x y = g x y
+  g :: forall b. b -> b -> _
+  g x y = [x, y]
+
+Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
+together, which is fine.  So we bind 'a' and 'b' to TyVarTvs, which can then
+unify with each other.
+
+But now consider:
+  f :: forall a b. a -> b -> _
+  f x y = [x, y]
+
+We want to get an error from this, because 'a' and 'b' get unified.
+So we make a test, one per parital signature, to check that the
+explicitly-quantified type variables have not been unified together.
+#14449 showed this up.
+
+
+Note [Validity of inferred types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to check inferred type for validity, in case it uses language
+extensions that are not turned on.  The principle is that if the user
+simply adds the inferred type to the program source, it'll compile fine.
+See #8883.
+
+Examples that might fail:
+ - the type might be ambiguous
+
+ - an inferred theta that requires type equalities e.g. (F a ~ G b)
+                                or multi-parameter type classes
+ - an inferred type that includes unboxed tuples
+
+
+Note [Impedance matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f 0 x = x
+   f n x = g [] (not x)
+
+   g [] y = f 10 y
+   g _  y = f 9  y
+
+After typechecking we'll get
+  f_mono_ty :: a -> Bool -> Bool
+  g_mono_ty :: [b] -> Bool -> Bool
+with constraints
+  (Eq a, Num a)
+
+Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
+The types we really want for f and g are
+   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
+   g :: forall b. [b] -> Bool -> Bool
+
+We can get these by "impedance matching":
+   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
+   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
+
+   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
+   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
+
+Suppose the shared quantified tyvars are qtvs and constraints theta.
+Then we want to check that
+     forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype
+and the proof is the impedance matcher.
+
+Notice that the impedance matcher may do defaulting.  See #7173.
+
+It also cleverly does an ambiguity check; for example, rejecting
+   f :: F a -> F a
+where F is a non-injective type function.
+-}
+
+
+{-
+Note [SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no point in a SPECIALISE pragma for a non-overloaded function:
+   reverse :: [a] -> [a]
+   {-# SPECIALISE reverse :: [Int] -> [Int] #-}
+
+But SPECIALISE INLINE *can* make sense for GADTS:
+   data Arr e where
+     ArrInt :: !Int -> ByteArray# -> Arr Int
+     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
+
+   (!:) :: Arr e -> Int -> e
+   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
+   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
+   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
+   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
+
+When (!:) is specialised it becomes non-recursive, and can usefully
+be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
+for a non-overloaded function.
+
+************************************************************************
+*                                                                      *
+                         tcMonoBinds
+*                                                                      *
+************************************************************************
+
+@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
+The signatures have been dealt with already.
+-}
+
+data MonoBindInfo = MBI { mbi_poly_name :: Name
+                        , mbi_sig       :: Maybe TcIdSigInst
+                        , mbi_mono_id   :: TcId }
+
+tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
+                        -- i.e. the binders are mentioned in their RHSs, and
+                        --      we are not rescued by a type signature
+            -> TcSigFun -> LetBndrSpec
+            -> [LHsBind GhcRn]
+            -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
+tcMonoBinds is_rec sig_fn no_gen
+           [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name)
+                                  , fun_matches = matches
+                                  , fun_ext = fvs })]
+                             -- Single function binding,
+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
+  , Nothing <- sig_fn name   -- ...with no type signature
+  =     -- Note [Single function non-recursive binding special-case]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- In this very special case we infer the type of the
+        -- right hand side first (it may have a higher-rank type)
+        -- and *then* make the monomorphic Id for the LHS
+        -- e.g.         f = \(x::forall a. a->a) -> <body>
+        --      We want to infer a higher-rank type for f
+    setSrcSpan b_loc    $
+    do  { ((co_fn, matches'), rhs_ty)
+            <- tcInferInst $ \ exp_ty ->
+                  -- tcInferInst: see TcUnify,
+                  -- Note [Deep instantiation of InferResult] in TcUnify
+               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
+                  -- We extend the error context even for a non-recursive
+                  -- function so that in type error messages we show the
+                  -- type of the thing whose rhs we are type checking
+               tcMatchesFun (cL nm_loc name) matches exp_ty
+
+        ; mono_id <- newLetBndr no_gen name rhs_ty
+        ; return (unitBag $ cL b_loc $
+                     FunBind { fun_id = cL nm_loc mono_id,
+                               fun_matches = matches', fun_ext = fvs,
+                               fun_co_fn = co_fn, fun_tick = [] },
+                  [MBI { mbi_poly_name = name
+                       , mbi_sig       = Nothing
+                       , mbi_mono_id   = mono_id }]) }
+
+tcMonoBinds _ sig_fn no_gen binds
+  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
+
+        -- Bring the monomorphic Ids, into scope for the RHSs
+        ; let mono_infos = getMonoBindInfo tc_binds
+              rhs_id_env = [ (name, mono_id)
+                           | MBI { mbi_poly_name = name
+                                 , mbi_sig       = mb_sig
+                                 , mbi_mono_id   = mono_id } <- mono_infos
+                           , case mb_sig of
+                               Just sig -> isPartialSig sig
+                               Nothing  -> True ]
+                -- A monomorphic binding for each term variable that lacks
+                -- a complete type sig.  (Ones with a sig are already in scope.)
+
+        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
+                                       | (n,id) <- rhs_id_env]
+        ; binds' <- tcExtendRecIds rhs_id_env $
+                    mapM (wrapLocM tcRhs) tc_binds
+
+        ; return (listToBag binds', mono_infos) }
+
+
+------------------------
+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
+-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
+--      if there's a signature for it, use the instantiated signature type
+--      otherwise invent a type variable
+-- You see that quite directly in the FunBind case.
+--
+-- But there's a complication for pattern bindings:
+--      data T = MkT (forall a. a->a)
+--      MkT f = e
+-- Here we can guess a type variable for the entire LHS (which will be refined to T)
+-- but we want to get (f::forall a. a->a) as the RHS environment.
+-- The simplest way to do this is to typecheck the pattern, and then look up the
+-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
+
+data TcMonoBind         -- Half completed; LHS done, RHS not done
+  = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
+  | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))
+              TcSigmaType
+
+tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
+-- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
+--                    or NoGen    (LetBndrSpec = LetGblBndr)
+-- CheckGen is used only for functions with a complete type signature,
+--          and tcPolyCheck doesn't use tcMonoBinds at all
+
+tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name)
+                             , fun_matches = matches })
+  | Just (TcIdSig sig) <- sig_fn name
+  = -- There is a type signature.
+    -- It must be partial; if complete we'd be in tcPolyCheck!
+    --    e.g.   f :: _ -> _
+    --           f x = ...g...
+    --           Just g = ...f...
+    -- Hence always typechecked with InferGen
+    do { mono_info <- tcLhsSigId no_gen (name, sig)
+       ; return (TcFunBind mono_info nm_loc matches) }
+
+  | otherwise  -- No type signature
+  = do { mono_ty <- newOpenFlexiTyVarTy
+       ; mono_id <- newLetBndr no_gen name mono_ty
+       ; let mono_info = MBI { mbi_poly_name = name
+                             , mbi_sig       = Nothing
+                             , mbi_mono_id   = mono_id }
+       ; return (TcFunBind mono_info nm_loc matches) }
+
+tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
+  = -- See Note [Typechecking pattern bindings]
+    do  { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
+
+        ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
+                             [ (mbi_poly_name mbi, mbi_mono_id mbi)
+                             | mbi <- sig_mbis ]
+
+            -- See Note [Existentials in pattern bindings]
+        ; ((pat', nosig_mbis), pat_ty)
+            <- addErrCtxt (patMonoBindsCtxt pat grhss) $
+               tcInferNoInst $ \ exp_ty ->
+               tcLetPat inst_sig_fun no_gen pat exp_ty $
+               mapM lookup_info nosig_names
+
+        ; let mbis = sig_mbis ++ nosig_mbis
+
+        ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
+                                | mbi <- mbis, let id = mbi_mono_id mbi ]
+                           $$ ppr no_gen)
+
+        ; return (TcPatBind mbis pat' grhss pat_ty) }
+  where
+    bndr_names = collectPatBinders pat
+    (nosig_names, sig_names) = partitionWith find_sig bndr_names
+
+    find_sig :: Name -> Either Name (Name, TcIdSigInfo)
+    find_sig name = case sig_fn name of
+                      Just (TcIdSig sig) -> Right (name, sig)
+                      _                  -> Left name
+
+      -- After typechecking the pattern, look up the binder
+      -- names that lack a signature, which the pattern has brought
+      -- into scope.
+    lookup_info :: Name -> TcM MonoBindInfo
+    lookup_info name
+      = do { mono_id <- tcLookupId name
+           ; return (MBI { mbi_poly_name = name
+                         , mbi_sig       = Nothing
+                         , mbi_mono_id   = mono_id }) }
+
+tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
+        -- AbsBind, VarBind impossible
+
+-------------------
+tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
+tcLhsSigId no_gen (name, sig)
+  = do { inst_sig <- tcInstSig sig
+       ; mono_id <- newSigLetBndr no_gen name inst_sig
+       ; return (MBI { mbi_poly_name = name
+                     , mbi_sig       = Just inst_sig
+                     , mbi_mono_id   = mono_id }) }
+
+------------
+newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
+newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
+  | CompleteSig { sig_bndr = poly_id } <- id_sig
+  = addInlinePrags poly_id (lookupPragEnv prags name)
+newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
+  = newLetBndr no_gen name tau
+
+-------------------
+tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)
+tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
+                 loc matches)
+  = tcExtendIdBinderStackForRhs [info]  $
+    tcExtendTyVarEnvForRhs mb_sig       $
+    do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
+        ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id))
+                                 matches (mkCheckExpType $ idType mono_id)
+        ; return ( FunBind { fun_id = cL loc mono_id
+                           , fun_matches = matches'
+                           , fun_co_fn = co_fn
+                           , fun_ext = placeHolderNamesTc
+                           , fun_tick = [] } ) }
+
+tcRhs (TcPatBind infos pat' grhss pat_ty)
+  = -- When we are doing pattern bindings we *don't* bring any scoped
+    -- type variables into scope unlike function bindings
+    -- Wny not?  They are not completely rigid.
+    -- That's why we have the special case for a single FunBind in tcMonoBinds
+    tcExtendIdBinderStackForRhs infos        $
+    do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
+        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
+                    tcGRHSsPat grhss pat_ty
+        ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
+                           , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
+                           , pat_ticks = ([],[]) } )}
+
+tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
+tcExtendTyVarEnvForRhs Nothing thing_inside
+  = thing_inside
+tcExtendTyVarEnvForRhs (Just sig) thing_inside
+  = tcExtendTyVarEnvFromSig sig thing_inside
+
+tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
+tcExtendTyVarEnvFromSig sig_inst thing_inside
+  | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
+  = tcExtendNameTyVarEnv wcs $
+    tcExtendNameTyVarEnv skol_prs $
+    thing_inside
+
+tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
+-- Extend the TcBinderStack for the RHS of the binding, with
+-- the monomorphic Id.  That way, if we have, say
+--     f = \x -> blah
+-- and something goes wrong in 'blah', we get a "relevant binding"
+-- looking like  f :: alpha -> beta
+-- This applies if 'f' has a type signature too:
+--    f :: forall a. [a] -> [a]
+--    f x = True
+-- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
+-- If we had the *polymorphic* version of f in the TcBinderStack, it
+-- would not be reported as relevant, because its type is closed
+tcExtendIdBinderStackForRhs infos thing_inside
+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+                        | MBI { mbi_mono_id = mono_id } <- infos ]
+                        thing_inside
+    -- NotTopLevel: it's a monomorphic binding
+
+---------------------
+getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
+getMonoBindInfo tc_binds
+  = foldr (get_info . unLoc) [] tc_binds
+  where
+    get_info (TcFunBind info _ _)    rest = info : rest
+    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
+
+
+{- Note [Typechecking pattern bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look at:
+   - typecheck/should_compile/ExPat
+   - #12427, typecheck/should_compile/T12427{a,b}
+
+  data T where
+    MkT :: Integral a => a -> Int -> T
+
+and suppose t :: T.  Which of these pattern bindings are ok?
+
+  E1. let { MkT p _ = t } in <body>
+
+  E2. let { MkT _ q = t } in <body>
+
+  E3. let { MkT (toInteger -> r) _ = t } in <body>
+
+* (E1) is clearly wrong because the existential 'a' escapes.
+  What type could 'p' possibly have?
+
+* (E2) is fine, despite the existential pattern, because
+  q::Int, and nothing escapes.
+
+* Even (E3) is fine.  The existential pattern binds a dictionary
+  for (Integral a) which the view pattern can use to convert the
+  a-valued field to an Integer, so r :: Integer.
+
+An easy way to see all three is to imagine the desugaring.
+For (E2) it would look like
+    let q = case t of MkT _ q' -> q'
+    in <body>
+
+
+We typecheck pattern bindings as follows.  First tcLhs does this:
+
+  1. Take each type signature q :: ty, partial or complete, and
+     instantiate it (with tcLhsSigId) to get a MonoBindInfo.  This
+     gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
+     a fresh name.
+
+     Any fresh unification variables in instantiate(ty) born here, not
+     deep under implications as would happen if we allocated them when
+     we encountered q during tcPat.
+
+  2. Build a little environment mapping "q" -> "qm" for those Ids
+     with signatures (inst_sig_fun)
+
+  3. Invoke tcLetPat to typecheck the pattern.
+
+     - We pass in the current TcLevel.  This is captured by
+       TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
+       PatEnv.
+
+     - When tcPat finds an existential constructor, it binds fresh
+       type variables and dictionaries as usual, increments the TcLevel,
+       and emits an implication constraint.
+
+     - When we come to a binder (TcPat.tcPatBndr), it looks it up
+       in the little environment (the pc_sig_fn field of PatCtxt).
+
+         Success => There was a type signature, so just use it,
+                    checking compatibility with the expected type.
+
+         Failure => No type sigature.
+             Infer case: (happens only outside any constructor pattern)
+                         use a unification variable
+                         at the outer level pc_lvl
+
+             Check case: use promoteTcType to promote the type
+                         to the outer level pc_lvl.  This is the
+                         place where we emit a constraint that'll blow
+                         up if existential capture takes place
+
+       Result: the type of the binder is always at pc_lvl. This is
+       crucial.
+
+  4. Throughout, when we are making up an Id for the pattern-bound variables
+     (newLetBndr), we have two cases:
+
+     - If we are generalising (generalisation plan is InferGen or
+       CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case
+       we want to bind a cloned, local version of the variable, with the
+       type given by the pattern context, *not* by the signature (even if
+       there is one; see #7268). The mkExport part of the
+       generalisation step will do the checking and impedance matching
+       against the signature.
+
+     - If for some some reason we are not generalising (plan = NoGen), the
+       LetBndrSpec will be LetGblBndr.  In that case we must bind the
+       global version of the Id, and do so with precisely the type given
+       in the signature.  (Then we unify with the type from the pattern
+       context type.)
+
+
+And that's it!  The implication constraints check for the skolem
+escape.  It's quite simple and neat, and more expressive than before
+e.g. GHC 8.0 rejects (E2) and (E3).
+
+Example for (E1), starting at level 1.  We generate
+     p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
+The (a~beta) can't float (because of the 'a'), nor be solved (because
+beta is untouchable.)
+
+Example for (E2), we generate
+     q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
+The beta is untouchable, but floats out of the constraint and can
+be solved absolutely fine.
+
+
+************************************************************************
+*                                                                      *
+                Generalisation
+*                                                                      *
+********************************************************************* -}
+
+data GeneralisationPlan
+  = NoGen               -- No generalisation, no AbsBinds
+
+  | InferGen            -- Implicit generalisation; there is an AbsBinds
+       Bool             --   True <=> apply the MR; generalise only unconstrained type vars
+
+  | CheckGen (LHsBind GhcRn) TcIdSigInfo
+                        -- One FunBind with a signature
+                        -- Explicit generalisation
+
+-- A consequence of the no-AbsBinds choice (NoGen) is that there is
+-- no "polymorphic Id" and "monmomorphic Id"; there is just the one
+
+instance Outputable GeneralisationPlan where
+  ppr NoGen          = text "NoGen"
+  ppr (InferGen b)   = text "InferGen" <+> ppr b
+  ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
+
+decideGeneralisationPlan
+   :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
+   -> GeneralisationPlan
+decideGeneralisationPlan dflags lbinds closed sig_fn
+  | has_partial_sigs                         = InferGen (and partial_sig_mrs)
+  | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
+  | do_not_generalise closed                 = NoGen
+  | otherwise                                = InferGen mono_restriction
+  where
+    binds = map unLoc lbinds
+
+    partial_sig_mrs :: [Bool]
+    -- One for each partial signature (so empty => no partial sigs)
+    -- The Bool is True if the signature has no constraint context
+    --      so we should apply the MR
+    -- See Note [Partial type signatures and generalisation]
+    partial_sig_mrs
+      = [ null theta
+        | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
+            <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
+        , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
+
+    has_partial_sigs   = not (null partial_sig_mrs)
+
+    mono_restriction  = xopt LangExt.MonomorphismRestriction dflags
+                     && any restricted binds
+
+    do_not_generalise (IsGroupClosed _ True) = False
+        -- The 'True' means that all of the group's
+        -- free vars have ClosedTypeId=True; so we can ignore
+        -- -XMonoLocalBinds, and generalise anyway
+    do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
+
+    -- With OutsideIn, all nested bindings are monomorphic
+    -- except a single function binding with a signature
+    one_funbind_with_sig
+      | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds
+      , Just (TcIdSig sig) <- sig_fn (unLoc v)
+      = Just (lbind, sig)
+      | otherwise
+      = Nothing
+
+    -- The Haskell 98 monomorphism restriction
+    restricted (PatBind {})                              = True
+    restricted (VarBind { var_id = v })                  = no_sig v
+    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
+                                                           && no_sig (unLoc v)
+    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
+
+    restricted_match mg = matchGroupArity mg == 0
+        -- No args => like a pattern binding
+        -- Some args => a function binding
+
+    no_sig n = not (hasCompleteSig sig_fn n)
+
+isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
+isClosedBndrGroup type_env binds
+  = IsGroupClosed fv_env type_closed
+  where
+    type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
+
+    fv_env :: NameEnv NameSet
+    fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
+
+    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
+    bindFvs (FunBind { fun_id = (dL->L _ f)
+                     , fun_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
+         in [(f, open_fvs)]
+    bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
+         in [(b, open_fvs) | b <- collectPatBinders pat]
+    bindFvs _
+       = []
+
+    get_open_fvs fvs = filterNameSet (not . is_closed) fvs
+
+    is_closed :: Name -> ClosedTypeId
+    is_closed name
+      | Just thing <- lookupNameEnv type_env name
+      = case thing of
+          AGlobal {}                     -> True
+          ATcId { tct_info = ClosedLet } -> True
+          _                              -> False
+
+      | otherwise
+      = True  -- The free-var set for a top level binding mentions
+
+
+    is_closed_type_id :: Name -> Bool
+    -- We're already removed Global and ClosedLet Ids
+    is_closed_type_id name
+      | Just thing <- lookupNameEnv type_env name
+      = case thing of
+          ATcId { tct_info = NonClosedLet _ cl } -> cl
+          ATcId { tct_info = NotLetBound }       -> False
+          ATyVar {}                              -> False
+               -- In-scope type variables are not closed!
+          _ -> pprPanic "is_closed_id" (ppr name)
+
+      | otherwise
+      = True   -- The free-var set for a top level binding mentions
+               -- imported things too, so that we can report unused imports
+               -- These won't be in the local type env.
+               -- Ditto class method etc from the current module
+
+
+{- *********************************************************************
+*                                                                      *
+               Error contexts and messages
+*                                                                      *
+********************************************************************* -}
+
+-- This one is called on LHS, when pat and grhss are both Name
+-- and on RHS, when pat is TcId and grhss is still Name
+patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)
+                 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
+patMonoBindsCtxt pat grhss
+  = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcCanonical.hs
@@ -0,0 +1,2465 @@
+{-# LANGUAGE CPP #-}
+
+module TcCanonical(
+     canonicalize,
+     unifyDerived,
+     makeSuperClasses, maybeSym,
+     StopOrContinue(..), stopWith, continueWith,
+     solveCallStack    -- For TcSimplify
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import TcUnify( swapOverTyVars, metaTyVarUpdateOK )
+import TcType
+import Type
+import TcFlatten
+import TcSMonad
+import TcEvidence
+import TcEvTerm
+import Class
+import TyCon
+import TyCoRep   -- cleverly decomposes types, good for completeness checking
+import Coercion
+import CoreSyn
+import Id( idType, mkTemplateLocals )
+import FamInstEnv ( FamInstEnvs )
+import FamInst ( tcTopNormaliseNewTypeTF_maybe )
+import Var
+import VarEnv( mkInScopeSet )
+import VarSet( delVarSetList )
+import Outputable
+import DynFlags( DynFlags )
+import NameSet
+import RdrName
+import HsTypes( HsIPName(..) )
+
+import Pair
+import Util
+import Bag
+import MonadUtils
+import Control.Monad
+import Data.Maybe ( isJust )
+import Data.List  ( zip4 )
+import BasicTypes
+
+import Data.Bifunctor ( bimap )
+
+{-
+************************************************************************
+*                                                                      *
+*                      The Canonicaliser                               *
+*                                                                      *
+************************************************************************
+
+Note [Canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~
+
+Canonicalization converts a simple constraint to a canonical form. It is
+unary (i.e. treats individual constraints one at a time).
+
+Constraints originating from user-written code come into being as
+CNonCanonicals (except for CHoleCans, arising from holes). We know nothing
+about these constraints. So, first:
+
+     Classify CNonCanoncal constraints, depending on whether they
+     are equalities, class predicates, or other.
+
+Then proceed depending on the shape of the constraint. Generally speaking,
+each constraint gets flattened and then decomposed into one of several forms
+(see type Ct in TcRnTypes).
+
+When an already-canonicalized constraint gets kicked out of the inert set,
+it must be recanonicalized. But we know a bit about its shape from the
+last time through, so we can skip the classification step.
+
+-}
+
+-- Top-level canonicalization
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+canonicalize :: Ct -> TcS (StopOrContinue Ct)
+canonicalize (CNonCanonical { cc_ev = ev })
+  = {-# SCC "canNC" #-}
+    case classifyPredType pred of
+      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
+                                  canClassNC ev cls tys
+      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
+                                  canEqNC    ev eq_rel ty1 ty2
+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
+                                  canIrred ev
+      ForAllPred _ _ pred   -> do traceTcS "canEvNC:forall" (ppr pred)
+                                  canForAll ev (isClassPred pred)
+  where
+    pred = ctEvPred ev
+
+canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
+  = canForAll ev pend_sc
+
+canonicalize (CIrredCan { cc_ev = ev })
+  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)
+  = -- For insolubles (all of which are equalities, do /not/ flatten the arguments
+    -- In #14350 doing so led entire-unnecessary and ridiculously large
+    -- type function expansion.  Instead, canEqNC just applies
+    -- the substitution to the predicate, and may do decomposition;
+    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose
+    canEqNC ev eq_rel ty1 ty2
+
+  | otherwise
+  = canIrred ev
+
+canonicalize (CDictCan { cc_ev = ev, cc_class  = cls
+                       , cc_tyargs = xis, cc_pend_sc = pend_sc })
+  = {-# SCC "canClass" #-}
+    canClass ev cls xis pend_sc
+
+canonicalize (CTyEqCan { cc_ev = ev
+                       , cc_tyvar  = tv
+                       , cc_rhs    = xi
+                       , cc_eq_rel = eq_rel })
+  = {-# SCC "canEqLeafTyVarEq" #-}
+    canEqNC ev eq_rel (mkTyVarTy tv) xi
+      -- NB: Don't use canEqTyVar because that expects flattened types,
+      -- and tv and xi may not be flat w.r.t. an updated inert set
+
+canonicalize (CFunEqCan { cc_ev = ev
+                        , cc_fun    = fn
+                        , cc_tyargs = xis1
+                        , cc_fsk    = fsk })
+  = {-# SCC "canEqLeafFunEq" #-}
+    canCFunEqCan ev fn xis1 fsk
+
+canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })
+  = canHole ev hole
+
+{-
+************************************************************************
+*                                                                      *
+*                      Class Canonicalization
+*                                                                      *
+************************************************************************
+-}
+
+canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
+-- "NC" means "non-canonical"; that is, we have got here
+-- from a NonCanonical constraint, not from a CDictCan
+-- Precondition: EvVar is class evidence
+canClassNC ev cls tys
+  | isGiven ev  -- See Note [Eagerly expand given superclasses]
+  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
+       ; emitWork sc_cts
+       ; canClass ev cls tys False }
+
+  | isWanted ev
+  , Just ip_name <- isCallStackPred cls tys
+  , OccurrenceOf func <- ctLocOrigin loc
+  -- If we're given a CallStack constraint that arose from a function
+  -- call, we need to push the current call-site onto the stack instead
+  -- of solving it directly from a given.
+  -- See Note [Overview of implicit CallStacks] in TcEvidence
+  -- and Note [Solving CallStack constraints] in TcSMonad
+  = do { -- First we emit a new constraint that will capture the
+         -- given CallStack.
+       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
+                            -- We change the origin to IPOccOrigin so
+                            -- this rule does not fire again.
+                            -- See Note [Overview of implicit CallStacks]
+
+       ; new_ev <- newWantedEvVarNC new_loc pred
+
+         -- Then we solve the wanted by pushing the call-site
+         -- onto the newly emitted CallStack
+       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
+       ; solveCallStack ev ev_cs
+
+       ; canClass new_ev cls tys False }
+
+  | otherwise
+  = canClass ev cls tys (has_scs cls)
+
+  where
+    has_scs cls = not (null (classSCTheta cls))
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
+-- Also called from TcSimplify when defaulting call stacks
+solveCallStack ev ev_cs = do
+  -- We're given ev_cs :: CallStack, but the evidence term should be a
+  -- dictionary, so we have to coerce ev_cs to a dictionary for
+  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
+  cs_tm <- evCallStack ev_cs
+  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
+  setEvBindIfWanted ev ev_tm
+
+canClass :: CtEvidence
+         -> Class -> [Type]
+         -> Bool            -- True <=> un-explored superclasses
+         -> TcS (StopOrContinue Ct)
+-- Precondition: EvVar is class evidence
+
+canClass ev cls tys pend_sc
+  =   -- all classes do *nominal* matching
+    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
+    do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys
+       ; MASSERT( isTcReflCo _kind_co )
+       ; let co = mkTcTyConAppCo Nominal cls_tc cos
+             xi = mkClassPred cls xis
+             mk_ct new_ev = CDictCan { cc_ev = new_ev
+                                     , cc_tyargs = xis
+                                     , cc_class = cls
+                                     , cc_pend_sc = pend_sc }
+       ; mb <- rewriteEvidence ev xi co
+       ; traceTcS "canClass" (vcat [ ppr ev
+                                   , ppr xi, ppr mb ])
+       ; return (fmap mk_ct mb) }
+  where
+    cls_tc = classTyCon cls
+
+{- Note [The superclass story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to add superclass constraints for two reasons:
+
+* For givens [G], they give us a route to proof.  E.g.
+    f :: Ord a => a -> Bool
+    f x = x == x
+  We get a Wanted (Eq a), which can only be solved from the superclass
+  of the Given (Ord a).
+
+* For wanteds [W], and deriveds [WD], [D], they may give useful
+  functional dependencies.  E.g.
+     class C a b | a -> b where ...
+     class C a b => D a b where ...
+  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass
+  and that might tell us about beta, via C's fundeps.  We can get this
+  by generating a [D] (C Int beta) constraint.  It's derived because
+  we don't actually have to cough up any evidence for it; it's only there
+  to generate fundep equalities.
+
+See Note [Why adding superclasses can help].
+
+For these reasons we want to generate superclass constraints for both
+Givens and Wanteds. But:
+
+* (Minor) they are often not needed, so generating them aggressively
+  is a waste of time.
+
+* (Major) if we want recursive superclasses, there would be an infinite
+  number of them.  Here is a real-life example (#10318);
+
+     class (Frac (Frac a) ~ Frac a,
+            Fractional (Frac a),
+            IntegralDomain (Frac a))
+         => IntegralDomain a where
+      type Frac a :: *
+
+  Notice that IntegralDomain has an associated type Frac, and one
+  of IntegralDomain's superclasses is another IntegralDomain constraint.
+
+So here's the plan:
+
+1. Eagerly generate superclasses for given (but not wanted)
+   constraints; see Note [Eagerly expand given superclasses].
+   This is done using mkStrictSuperClasses in canClassNC, when
+   we take a non-canonical Given constraint and cannonicalise it.
+
+   However stop if you encounter the same class twice.  That is,
+   mkStrictSuperClasses expands eagerly, but has a conservative
+   termination condition: see Note [Expanding superclasses] in TcType.
+
+2. Solve the wanteds as usual, but do no further expansion of
+   superclasses for canonical CDictCans in solveSimpleGivens or
+   solveSimpleWanteds; Note [Danger of adding superclasses during solving]
+
+   However, /do/ continue to eagerly expand superlasses for new /given/
+   /non-canonical/ constraints (canClassNC does this).  As #12175
+   showed, a type-family application can expand to a class constraint,
+   and we want to see its superclasses for just the same reason as
+   Note [Eagerly expand given superclasses].
+
+3. If we have any remaining unsolved wanteds
+        (see Note [When superclasses help] in TcRnTypes)
+   try harder: take both the Givens and Wanteds, and expand
+   superclasses again.  See the calls to expandSuperClasses in
+   TcSimplify.simpl_loop and solveWanteds.
+
+   This may succeed in generating (a finite number of) extra Givens,
+   and extra Deriveds. Both may help the proof.
+
+3a An important wrinkle: only expand Givens from the current level.
+   Two reasons:
+      - We only want to expand it once, and that is best done at
+        the level it is bound, rather than repeatedly at the leaves
+        of the implication tree
+      - We may be inside a type where we can't create term-level
+        evidence anyway, so we can't superclass-expand, say,
+        (a ~ b) to get (a ~# b).  This happened in #15290.
+
+4. Go round to (2) again.  This loop (2,3,4) is implemented
+   in TcSimplify.simpl_loop.
+
+The cc_pend_sc flag in a CDictCan records whether the superclasses of
+this constraint have been expanded.  Specifically, in Step 3 we only
+expand superclasses for constraints with cc_pend_sc set to true (i.e.
+isPendingScDict holds).
+
+Why do we do this?  Two reasons:
+
+* To avoid repeated work, by repeatedly expanding the superclasses of
+  same constraint,
+
+* To terminate the above loop, at least in the -XNoRecursiveSuperClasses
+  case.  If there are recursive superclasses we could, in principle,
+  expand forever, always encountering new constraints.
+
+When we take a CNonCanonical or CIrredCan, but end up classifying it
+as a CDictCan, we set the cc_pend_sc flag to False.
+
+Note [Superclass loops]
+~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class C a => D a
+  class D a => C a
+
+Then, when we expand superclasses, we'll get back to the self-same
+predicate, so we have reached a fixpoint in expansion and there is no
+point in fruitlessly expanding further.  This case just falls out from
+our strategy.  Consider
+  f :: C a => a -> Bool
+  f x = x==x
+Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses
+G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)
+When processing d3 we find a match with d1 in the inert set, and we always
+keep the inert item (d1) if possible: see Note [Replacement vs keeping] in
+TcInteract.  So d3 dies a quick, happy death.
+
+Note [Eagerly expand given superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In step (1) of Note [The superclass story], why do we eagerly expand
+Given superclasses by one layer?  (By "one layer" we mean expand transitively
+until you meet the same class again -- the conservative criterion embodied
+in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)
+We do this eagerly for Givens mainly because of some very obscure
+cases like this:
+
+   instance Bad a => Eq (T a)
+
+   f :: (Ord (T a)) => blah
+   f x = ....needs Eq (T a), Ord (T a)....
+
+Here if we can't satisfy (Eq (T a)) from the givens we'll use the
+instance declaration; but then we are stuck with (Bad a).  Sigh.
+This is really a case of non-confluent proofs, but to stop our users
+complaining we expand one layer in advance.
+
+Note [Instance and Given overlap] in TcInteract.
+
+We also want to do this if we have
+
+   f :: F (T a) => blah
+
+where
+   type instance F (T a) = Ord (T a)
+
+So we may need to do a little work on the givens to expose the
+class that has the superclasses.  That's why the superclass
+expansion for Givens happens in canClassNC.
+
+Note [Why adding superclasses can help]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Examples of how adding superclasses can help:
+
+    --- Example 1
+        class C a b | a -> b
+    Suppose we want to solve
+         [G] C a b
+         [W] C a beta
+    Then adding [D] beta~b will let us solve it.
+
+    -- Example 2 (similar but using a type-equality superclass)
+        class (F a ~ b) => C a b
+    And try to sllve:
+         [G] C a b
+         [W] C a beta
+    Follow the superclass rules to add
+         [G] F a ~ b
+         [D] F a ~ beta
+    Now we get [D] beta ~ b, and can solve that.
+
+    -- Example (tcfail138)
+      class L a b | a -> b
+      class (G a, L a b) => C a b
+
+      instance C a b' => G (Maybe a)
+      instance C a b  => C (Maybe a) a
+      instance L (Maybe a) a
+
+    When solving the superclasses of the (C (Maybe a) a) instance, we get
+      [G] C a b, and hance by superclasses, [G] G a, [G] L a b
+      [W] G (Maybe a)
+    Use the instance decl to get
+      [W] C a beta
+    Generate its derived superclass
+      [D] L a beta.  Now using fundeps, combine with [G] L a b to get
+      [D] beta ~ b
+    which is what we want.
+
+Note [Danger of adding superclasses during solving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's a serious, but now out-dated example, from #4497:
+
+   class Num (RealOf t) => Normed t
+   type family RealOf x
+
+Assume the generated wanted constraint is:
+   [W] RealOf e ~ e
+   [W] Normed e
+
+If we were to be adding the superclasses during simplification we'd get:
+   [W] RealOf e ~ e
+   [W] Normed e
+   [D] RealOf e ~ fuv
+   [D] Num fuv
+==>
+   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv
+
+While looks exactly like our original constraint. If we add the
+superclass of (Normed fuv) again we'd loop.  By adding superclasses
+definitely only once, during canonicalisation, this situation can't
+happen.
+
+Mind you, now that Wanteds cannot rewrite Derived, I think this particular
+situation can't happen.
+  -}
+
+makeSuperClasses :: [Ct] -> TcS [Ct]
+-- Returns strict superclasses, transitively, see Note [The superclasses story]
+-- See Note [The superclass story]
+-- The loop-breaking here follows Note [Expanding superclasses] in TcType
+-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s
+--    superclasses, up to /and including/ the first repetition of C
+--
+-- Example:  class D a => C a
+--           class C [a] => D a
+-- makeSuperClasses (C x) will return (D x, C [x])
+--
+-- NB: the incoming constraints have had their cc_pend_sc flag already
+--     flipped to False, by isPendingScDict, so we are /obliged/ to at
+--     least produce the immediate superclasses
+makeSuperClasses cts = concatMapM go cts
+  where
+    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
+      = mkStrictSuperClasses ev [] [] cls tys
+    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
+      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have
+                                               -- class pred heads
+        mkStrictSuperClasses ev tvs theta cls tys
+      where
+        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
+    go ct = pprPanic "makeSuperClasses" (ppr ct)
+
+mkStrictSuperClasses
+    :: CtEvidence
+    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking
+                             -- superclasses of a /quantified/ constraint
+    -> Class -> [Type] -> TcS [Ct]
+-- Return constraints for the strict superclasses of
+--   ev :: forall as. theta => cls tys
+mkStrictSuperClasses ev tvs theta cls tys
+  = mk_strict_superclasses (unitNameSet (className cls))
+                           ev tvs theta cls tys
+
+mk_strict_superclasses :: NameSet -> CtEvidence
+                       -> [TyVar] -> ThetaType
+                       -> Class -> [Type] -> TcS [Ct]
+-- Always return the immediate superclasses of (cls tys);
+-- and expand their superclasses, provided none of them are in rec_clss
+-- nor are repeated
+mk_strict_superclasses rec_clss ev tvs theta cls tys
+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
+  = concatMapM (do_one_given evar (mk_given_loc loc)) $
+    classSCSelIds cls
+  where
+    dict_ids  = mkTemplateLocals theta
+    size      = sizeTypes tys
+
+    do_one_given evar given_loc sel_id
+      | isUnliftedType sc_pred
+      , not (null tvs && null theta)
+      = -- See Note [Equality superclasses in quantified constraints]
+        return []
+      | otherwise
+      = do { given_ev <- newGivenEvVar given_loc $
+                         (given_ty, mk_sc_sel evar sel_id)
+           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
+      where
+        sc_pred  = funResultTy (piResultTys (idType sel_id) tys)
+        given_ty = mkInfSigmaTy tvs theta sc_pred
+
+    mk_sc_sel evar sel_id
+      = EvExpr $ mkLams tvs $ mkLams dict_ids $
+        Var sel_id `mkTyApps` tys `App`
+        (evId evar `mkTyApps` mkTyVarTys tvs `mkVarApps` dict_ids)
+
+    mk_given_loc loc
+       | isCTupleClass cls
+       = loc   -- For tuple predicates, just take them apart, without
+               -- adding their (large) size into the chain.  When we
+               -- get down to a base predicate, we'll include its size.
+               -- #10335
+
+       | GivenOrigin skol_info <- ctLocOrigin loc
+         -- See Note [Solving superclass constraints] in TcInstDcls
+         -- for explantation of this transformation for givens
+       = case skol_info of
+            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }
+            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }
+            _        -> loc
+
+       | otherwise  -- Probably doesn't happen, since this function
+       = loc        -- is only used for Givens, but does no harm
+
+mk_strict_superclasses rec_clss ev tvs theta cls tys
+  | all noFreeVarsOfType tys
+  = return [] -- Wanteds with no variables yield no deriveds.
+              -- See Note [Improvement from Ground Wanteds]
+
+  | otherwise -- Wanted/Derived case, just add Derived superclasses
+              -- that can lead to improvement.
+  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )
+    concatMapM do_one_derived (immSuperClasses cls tys)
+  where
+    loc = ctEvLoc ev
+
+    do_one_derived sc_pred
+      = do { sc_ev <- newDerivedNC loc sc_pred
+           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
+
+mk_superclasses :: NameSet -> CtEvidence
+                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
+-- Return this constraint, plus its superclasses, if any
+mk_superclasses rec_clss ev tvs theta pred
+  | ClassPred cls tys <- classifyPredType pred
+  = mk_superclasses_of rec_clss ev tvs theta cls tys
+
+  | otherwise   -- Superclass is not a class predicate
+  = return [mkNonCanonical ev]
+
+mk_superclasses_of :: NameSet -> CtEvidence
+                   -> [TyVar] -> ThetaType -> Class -> [Type]
+                   -> TcS [Ct]
+-- Always return this class constraint,
+-- and expand its superclasses
+mk_superclasses_of rec_clss ev tvs theta cls tys
+  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
+                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True
+  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
+                                                          , ppr (isCTupleClass cls)
+                                                          , ppr rec_clss
+                                                          ])
+                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
+                    ; return (this_ct : sc_cts) }
+                                   -- cc_pend_sc of this_ct = False
+  where
+    cls_nm     = className cls
+    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
+                 -- Tuples never contribute to recursion, and can be nested
+    rec_clss'  = rec_clss `extendNameSet` cls_nm
+
+    this_ct | null tvs, null theta
+            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
+                       , cc_pend_sc = loop_found }
+                 -- NB: If there is a loop, we cut off, so we have not
+                 --     added the superclasses, hence cc_pend_sc = True
+            | otherwise
+            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
+                             , qci_ev = ev
+                             , qci_pend_sc = loop_found })
+
+
+{- Note [Equality superclasses in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#15359, #15593, #15625)
+  f :: (forall a. theta => a ~ b) => stuff
+
+It's a bit odd to have a local, quantified constraint for `(a~b)`,
+but some people want such a thing (see the tickets). And for
+Coercible it is definitely useful
+  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))
+                 => stuff
+
+Moreover it's not hard to arrange; we just need to look up /equality/
+constraints in the quantified-constraint environment, which we do in
+TcInteract.doTopReactOther.
+
+There is a wrinkle though, in the case where 'theta' is empty, so
+we have
+  f :: (forall a. a~b) => stuff
+
+Now, potentially, the superclass machinery kicks in, in
+makeSuperClasses, giving us a a second quantified constrait
+       (forall a. a ~# b)
+BUT this is an unboxed value!  And nothing has prepared us for
+dictionary "functions" that are unboxed.  Actually it does just
+about work, but the simplier ends up with stuff like
+   case (/\a. eq_sel d) of df -> ...(df @Int)...
+and fails to simplify that any further.  And it doesn't satisfy
+isPredTy any more.
+
+So for now we simply decline to take superclasses in the quantified
+case.  Instead we have a special case in TcInteract.doTopReactOther,
+which looks for primitive equalities specially in the quantified
+constraints.
+
+See also Note [Evidence for quantified constraints] in Type.
+
+
+************************************************************************
+*                                                                      *
+*                      Irreducibles canonicalization
+*                                                                      *
+************************************************************************
+-}
+
+canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
+-- Precondition: ty not a tuple and no other evidence form
+canIrred ev
+  = do { let pred = ctEvPred ev
+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
+       ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+    do { -- Re-classify, in case flattening has improved its shape
+       ; case classifyPredType (ctEvPred new_ev) of
+           ClassPred cls tys     -> canClassNC new_ev cls tys
+           EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2
+           _                     -> continueWith $
+                                    mkIrredCt new_ev } }
+
+canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct)
+canHole ev hole
+  = do { let pred = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+    do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev
+                                             , cc_hole = hole }))
+       ; stopWith new_ev "Emit insoluble hole" } }
+
+
+{- *********************************************************************
+*                                                                      *
+*                      Quantified predicates
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The -XQuantifiedConstraints extension allows type-class contexts like this:
+
+  data Rose f x = Rose x (f (Rose f x))
+
+  instance (Eq a, forall b. Eq b => Eq (f b))
+        => Eq (Rose f a)  where
+    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2
+
+Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
+This quantified constraint is needed to solve the
+ [W] (Eq (f (Rose f x)))
+constraint which arises form the (==) definition.
+
+The wiki page is
+  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints
+which in turn contains a link to the GHC Proposal where the change
+is specified, and a Haskell Symposium paper about it.
+
+We implement two main extensions to the design in the paper:
+
+ 1. We allow a variable in the instance head, e.g.
+      f :: forall m a. (forall b. m b) => D (m a)
+    Notice the 'm' in the head of the quantified constraint, not
+    a class.
+
+ 2. We suport superclasses to quantified constraints.
+    For example (contrived):
+      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool
+      f x y = x==y
+    Here we need (Eq (m a)); but the quantifed constraint deals only
+    with Ord.  But we can make it work by using its superclass.
+
+Here are the moving parts
+  * Language extension {-# LANGUAGE QuantifiedConstraints #-}
+    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension
+
+  * A new form of evidence, EvDFun, that is used to discharge
+    such wanted constraints
+
+  * checkValidType gets some changes to accept forall-constraints
+    only in the right places.
+
+  * Type.PredTree gets a new constructor ForAllPred, and
+    and classifyPredType analyses a PredType to decompose
+    the new forall-constraints
+
+  * TcSMonad.InertCans gets an extra field, inert_insts,
+    which holds all the Given forall-constraints.  In effect,
+    such Given constraints are like local instance decls.
+
+  * When trying to solve a class constraint, via
+    TcInteract.matchInstEnv, use the InstEnv from inert_insts
+    so that we include the local Given forall-constraints
+    in the lookup.  (See TcSMonad.getInstEnvs.)
+
+  * TcCanonical.canForAll deals with solving a
+    forall-constraint.  See
+       Note [Solving a Wanted forall-constraint]
+
+  * We augment the kick-out code to kick out an inert
+    forall constraint if it can be rewritten by a new
+    type equality; see TcSMonad.kick_out_rewritable
+
+Note that a quantified constraint is never /inferred/
+(by TcSimplify.simplifyInfer).  A function can only have a
+quantified constraint in its type if it is given an explicit
+type signature.
+
+Note that we implement
+-}
+
+canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
+-- We have a constraint (forall as. blah => C tys)
+canForAll ev pend_sc
+  = do { -- First rewrite it to apply the current substitution
+         -- Do not bother with type-family reductions; we can't
+         -- do them under a forall anyway (c.f. Flatten.flatten_one
+         -- on a forall type)
+         let pred = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+
+    do { -- Now decompose into its pieces and solve it
+         -- (It takes a lot less code to flatten before decomposing.)
+       ; case classifyPredType (ctEvPred new_ev) of
+           ForAllPred tv_bndrs theta pred
+              -> solveForAll new_ev tv_bndrs theta pred pend_sc
+           _  -> pprPanic "canForAll" (ppr new_ev)
+    } }
+
+solveForAll :: CtEvidence -> [TyVarBinder] -> TcThetaType -> PredType -> Bool
+            -> TcS (StopOrContinue Ct)
+solveForAll ev tv_bndrs theta pred pend_sc
+  | CtWanted { ctev_dest = dest } <- ev
+  = -- See Note [Solving a Wanted forall-constraint]
+    do { let skol_info = QuantCtxtSkol
+             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $
+                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs
+       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)
+
+       ; (w_id, ev_binds)
+             <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $
+                do { wanted_ev <- newWantedEvVarNC loc $
+                                  substTy subst pred
+                   ; return ( ctEvEvId wanted_ev
+                            , unitBag (mkNonCanonical wanted_ev)) }
+
+      ; setWantedEvTerm dest $
+        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
+              , et_binds = ev_binds, et_body = w_id }
+
+      ; stopWith ev "Wanted forall-constraint" }
+
+  | isGiven ev   -- See Note [Solving a Given forall-constraint]
+  = do { addInertForAll qci
+       ; stopWith ev "Given forall-constraint" }
+
+  | otherwise
+  = stopWith ev "Derived forall-constraint"
+  where
+    loc = ctEvLoc ev
+    tvs = binderVars tv_bndrs
+    qci = QCI { qci_ev = ev, qci_tvs = tvs
+              , qci_pred = pred, qci_pend_sc = pend_sc }
+
+{- Note [Solving a Wanted forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving a wanted forall (quantified) constraint
+  [W] df :: forall ab. (Eq a, Ord b) => C x a b
+is delightfully easy.   Just build an implication constraint
+    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a
+and discharge df thus:
+    df = /\ab. \g1 g2. let <binds> in d
+where <binds> is filled in by solving the implication constraint.
+All the machinery is to hand; there is little to do.
+
+Note [Solving a Given forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a Given constraint
+  [G] df :: forall ab. (Eq a, Ord b) => C x a b
+we just add it to TcS's local InstEnv of known instances,
+via addInertForall.  Then, if we look up (C x Int Bool), say,
+we'll find a match in the InstEnv.
+
+
+************************************************************************
+*                                                                      *
+*        Equalities
+*                                                                      *
+************************************************************************
+
+Note [Canonicalising equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In order to canonicalise an equality, we look at the structure of the
+two types at hand, looking for similarities. A difficulty is that the
+types may look dissimilar before flattening but similar after flattening.
+However, we don't just want to jump in and flatten right away, because
+this might be wasted effort. So, after looking for similarities and failing,
+we flatten and then try again. Of course, we don't want to loop, so we
+track whether or not we've already flattened.
+
+It is conceivable to do a better job at tracking whether or not a type
+is flattened, but this is left as future work. (Mar '15)
+
+
+Note [FunTy and decomposing tycon applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked.
+This means that we may very well have a FunTy containing a type of some unknown
+kind. For instance, we may have,
+
+    FunTy (a :: k) Int
+
+Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event
+that it sees such a type as it cannot determine the RuntimeReps which the (->)
+is applied to. Consequently, it is vital that we instead use
+tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case.
+
+When this happens can_eq_nc' will fail to decompose, zonk, and try again.
+Zonking should fill the variable k, meaning that decomposition will succeed the
+second time around.
+-}
+
+canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
+canEqNC ev eq_rel ty1 ty2
+  = do { result <- zonk_eq_types ty1 ty2
+       ; case result of
+           Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2
+           Right ty              -> canEqReflexive ev eq_rel ty }
+
+can_eq_nc
+   :: Bool            -- True => both types are flat
+   -> CtEvidence
+   -> EqRel
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
+   -> TcS (StopOrContinue Ct)
+can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  = do { traceTcS "can_eq_nc" $
+         vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
+       ; rdr_env <- getGlobalRdrEnvTcS
+       ; fam_insts <- getFamInstEnvs
+       ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
+
+can_eq_nc'
+   :: Bool           -- True => both input types are flattened
+   -> GlobalRdrEnv   -- needed to see which newtypes are in scope
+   -> FamInstEnvs    -- needed to unwrap data instances
+   -> CtEvidence
+   -> EqRel
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
+   -> TcS (StopOrContinue Ct)
+
+-- Expand synonyms first; see Note [Type synonyms and canonicalization]
+can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2
+  | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2
+
+-- need to check for reflexivity in the ReprEq case.
+-- See Note [Eager reflexivity check]
+-- Check only when flat because the zonk_eq_types check in canEqNC takes
+-- care of the non-flat case.
+can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
+  | ty1 `tcEqType` ty2
+  = canEqReflexive ev ReprEq ty1
+
+-- When working with ReprEq, unwrap newtypes.
+-- See Note [Unwrap newtypes first]
+can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | ReprEq <- eq_rel
+  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
+
+  | ReprEq <- eq_rel
+  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
+  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1
+
+-- Then, get rid of casts
+can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
+  = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
+can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
+  = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
+
+-- NB: pattern match on True: we want only flat types sent to canEqTyVar.
+-- See also Note [No top-level newtypes on RHS of representational equalities]
+can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
+  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
+  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1
+
+----------------------
+-- Otherwise try to decompose
+----------------------
+
+-- Literals
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
+ | l1 == l2
+  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
+       ; stopWith ev "Equal LitTy" }
+
+-- Try to decompose type constructor applications
+-- Including FunTy (s -> t)
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _
+    --- See Note [FunTy and decomposing type constructor applications].
+  | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1
+  , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2
+  , not (isTypeFamilyTyCon tc1)
+  , not (isTypeFamilyTyCon tc2)
+  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+
+can_eq_nc' _flat _rdr_env _envs ev eq_rel
+           s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
+  = can_eq_nc_forall ev eq_rel s1 s2
+
+-- See Note [Canonicalising type applications] about why we require flat types
+can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _
+  | NomEq <- eq_rel
+  , Just (t2, s2) <- tcSplitAppTy_maybe ty2
+  = can_eq_app ev t1 s1 t2 s2
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
+  | NomEq <- eq_rel
+  , Just (t1, s1) <- tcSplitAppTy_maybe ty1
+  = can_eq_app ev t1 s1 t2 s2
+
+-- No similarity in type structure detected. Flatten and try again.
+can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1
+       ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2
+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+
+-- We've flattened and the types don't match. Give up.
+can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
+  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
+       ; case eq_rel of -- See Note [Unsolved equalities]
+            ReprEq -> continueWith (mkIrredCt ev)
+            NomEq  -> continueWith (mkInsolubleCt ev) }
+          -- No need to call canEqFailure/canEqHardFailure because they
+          -- flatten, and the types involved here are already flat
+
+{- Note [Unsolved equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an unsolved equality like
+  (a b ~R# Int)
+that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.
+So we want to make it a potentially-soluble Irred not an insoluble one.
+Missing this point is what caused #15431
+-}
+
+---------------------------------
+can_eq_nc_forall :: CtEvidence -> EqRel
+                 -> Type -> Type    -- LHS and RHS
+                 -> TcS (StopOrContinue Ct)
+-- (forall as. phi1) ~ (forall bs. phi2)
+-- Check for length match of as, bs
+-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
+-- But remember also to unify the kinds of as and bs
+--  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]
+-- Remember also that we might have forall z (a:z). blah
+--  so we must proceed one binder at a time (#13879)
+
+can_eq_nc_forall ev eq_rel s1 s2
+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev
+ = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]
+            (bndrs1, phi1) = tcSplitForAllVarBndrs s1
+            (bndrs2, phi2) = tcSplitForAllVarBndrs s2
+      ; if not (equalLength bndrs1 bndrs2)
+        then do { traceTcS "Forall failure" $
+                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
+                          , ppr (map binderArgFlag bndrs1)
+                          , ppr (map binderArgFlag bndrs2) ]
+                ; canEqHardFailure ev s1 s2 }
+        else
+   do { traceTcS "Creating implication for polytype equality" $ ppr ev
+      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs
+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $
+                              binderVars bndrs1
+
+      ; let skol_info = UnifyForAllSkol phi1
+            phi1' = substTy subst1 phi1
+
+            -- Unify the kinds, extend the substitution
+            go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]
+               -> TcS (TcCoercion, Cts)
+            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
+              = do { let tv2 = binderVar bndr2
+                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)
+                                                  (substTy subst (tyVarKind tv2))
+                   ; let subst' = extendTvSubst subst tv2
+                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)
+                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2
+                   ; return ( mkTcForAllCo skol_tv kind_co co
+                            , wanteds1 `unionBags` wanteds2 ) }
+
+            -- Done: unify phi1 ~ phi2
+            go [] subst bndrs2
+              = ASSERT( null bndrs2 )
+                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)
+
+            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []
+
+            empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)
+
+      ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $
+                  go skol_tvs empty_subst2 bndrs2
+
+      ; setWantedEq orig_dest all_co
+      ; stopWith ev "Deferred polytype equality" } }
+
+ | otherwise
+ = do { traceTcS "Omitting decomposition of given polytype equality" $
+        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]
+      ; stopWith ev "Discard given polytype equality" }
+
+ where
+    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)
+    -- This version returns the wanted constraint rather
+    -- than putting it in the work list
+    unify loc role ty1 ty2
+      | ty1 `tcEqType` ty2
+      = return (mkTcReflCo role ty1, emptyBag)
+      | otherwise
+      = do { (wanted, co) <- newWantedEq loc role ty1 ty2
+           ; return (co, unitBag (mkNonCanonical wanted)) }
+
+---------------------------------
+-- | Compare types for equality, while zonking as necessary. Gives up
+-- as soon as it finds that two types are not equal.
+-- This is quite handy when some unification has made two
+-- types in an inert Wanted to be equal. We can discover the equality without
+-- flattening, which is sometimes very expensive (in the case of type functions).
+-- In particular, this function makes a ~20% improvement in test case
+-- perf/compiler/T5030.
+--
+-- Returns either the (partially zonked) types in the case of
+-- inequality, or the one type in the case of equality. canEqReflexive is
+-- a good next step in the 'Right' case. Returning 'Left' is always safe.
+--
+-- NB: This does *not* look through type synonyms. In fact, it treats type
+-- synonyms as rigid constructors. In the future, it might be convenient
+-- to look at only those arguments of type synonyms that actually appear
+-- in the synonym RHS. But we're not there yet.
+zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)
+zonk_eq_types = go
+  where
+    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2
+    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2
+    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1
+
+    -- We handle FunTys explicitly here despite the fact that they could also be
+    -- treated as an application. Why? Well, for one it's cheaper to just look
+    -- at two types (the argument and result types) than four (the argument,
+    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,
+    -- so we may run into an unzonked type variable while trying to compute the
+    -- RuntimeReps of the argument and result types. This can be observed in
+    -- testcase tc269.
+    go ty1 ty2
+      | Just (arg1, res1) <- split1
+      , Just (arg2, res2) <- split2
+      = do { res_a <- go arg1 arg2
+           ; res_b <- go res1 res2
+           ; return $ combine_rev mkVisFunTy res_b res_a
+           }
+      | isJust split1 || isJust split2
+      = bale_out ty1 ty2
+      where
+        split1 = tcSplitFunTy_maybe ty1
+        split2 = tcSplitFunTy_maybe ty2
+
+    go ty1 ty2
+      | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1
+      , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2
+      = if tc1 == tc2 && tys1 `equalLength` tys2
+          -- Crucial to check for equal-length args, because
+          -- we cannot assume that the two args to 'go' have
+          -- the same kind.  E.g go (Proxy *      (Maybe Int))
+          --                        (Proxy (*->*) Maybe)
+          -- We'll call (go (Maybe Int) Maybe)
+          -- See #13083
+        then tycon tc1 tys1 tys2
+        else bale_out ty1 ty2
+
+    go ty1 ty2
+      | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1
+      , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2
+      = do { res_a <- go ty1a ty2a
+           ; res_b <- go ty1b ty2b
+           ; return $ combine_rev mkAppTy res_b res_a }
+
+    go ty1@(LitTy lit1) (LitTy lit2)
+      | lit1 == lit2
+      = return (Right ty1)
+
+    go ty1 ty2 = bale_out ty1 ty2
+      -- We don't handle more complex forms here
+
+    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)
+
+    tyvar :: SwapFlag -> TcTyVar -> TcType
+          -> TcS (Either (Pair TcType) TcType)
+      -- Try to do as little as possible, as anything we do here is redundant
+      -- with flattening. In particular, no need to zonk kinds. That's why
+      -- we don't use the already-defined zonking functions
+    tyvar swapped tv ty
+      = case tcTyVarDetails tv of
+          MetaTv { mtv_ref = ref }
+            -> do { cts <- readTcRef ref
+                  ; case cts of
+                      Flexi        -> give_up
+                      Indirect ty' -> do { trace_indirect tv ty'
+                                         ; unSwap swapped go ty' ty } }
+          _ -> give_up
+      where
+        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
+
+    tyvar_tyvar tv1 tv2
+      | tv1 == tv2 = return (Right (mkTyVarTy tv1))
+      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1
+                        ; (ty2', progress2) <- quick_zonk tv2
+                        ; if progress1 || progress2
+                          then go ty1' ty2'
+                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
+
+    trace_indirect tv ty
+       = traceTcS "Following filled tyvar (zonk_eq_types)"
+                  (ppr tv <+> equals <+> ppr ty)
+
+    quick_zonk tv = case tcTyVarDetails tv of
+      MetaTv { mtv_ref = ref }
+        -> do { cts <- readTcRef ref
+              ; case cts of
+                  Flexi        -> return (TyVarTy tv, False)
+                  Indirect ty' -> do { trace_indirect tv ty'
+                                     ; return (ty', True) } }
+      _ -> return (TyVarTy tv, False)
+
+      -- This happens for type families, too. But recall that failure
+      -- here just means to try harder, so it's OK if the type function
+      -- isn't injective.
+    tycon :: TyCon -> [TcType] -> [TcType]
+          -> TcS (Either (Pair TcType) TcType)
+    tycon tc tys1 tys2
+      = do { results <- zipWithM go tys1 tys2
+           ; return $ case combine_results results of
+               Left tys  -> Left (mkTyConApp tc <$> tys)
+               Right tys -> Right (mkTyConApp tc tys) }
+
+    combine_results :: [Either (Pair TcType) TcType]
+                    -> Either (Pair [TcType]) [TcType]
+    combine_results = bimap (fmap reverse) reverse .
+                      foldl' (combine_rev (:)) (Right [])
+
+      -- combine (in reverse) a new result onto an already-combined result
+    combine_rev :: (a -> b -> c)
+                -> Either (Pair b) b
+                -> Either (Pair a) a
+                -> Either (Pair c) c
+    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)
+    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)
+    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)
+    combine_rev f (Right tys) (Right ty) = Right (f ty tys)
+
+{- See Note [Unwrap newtypes first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  newtype N m a = MkN (m a)
+Then N will get a conservative, Nominal role for its second parameter 'a',
+because it appears as an argument to the unknown 'm'. Now consider
+  [W] N Maybe a  ~R#  N Maybe b
+
+If we decompose, we'll get
+  [W] a ~N# b
+
+But if instead we unwrap we'll get
+  [W] Maybe a ~R# Maybe b
+which in turn gives us
+  [W] a ~R# b
+which is easier to satisfy.
+
+Bottom line: unwrap newtypes before decomposing them!
+c.f. #9123 comment:52,53 for a compelling example.
+
+Note [Newtypes can blow the stack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+  newtype X = MkX (Int -> X)
+  newtype Y = MkY (Int -> Y)
+
+and now wish to prove
+
+  [W] X ~R Y
+
+This Wanted will loop, expanding out the newtypes ever deeper looking
+for a solid match or a solid discrepancy. Indeed, there is something
+appropriate to this looping, because X and Y *do* have the same representation,
+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
+coercion will ever witness it. This loop won't actually cause GHC to hang,
+though, because we check our depth when unwrapping newtypes.
+
+Note [Eager reflexivity check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+  newtype X = MkX (Int -> X)
+
+and
+
+  [W] X ~R X
+
+Naively, we would start unwrapping X and end up in a loop. Instead,
+we do this eager reflexivity check. This is necessary only for representational
+equality because the flattener technology deals with the similar case
+(recursive type families) for nominal equality.
+
+Note that this check does not catch all cases, but it will catch the cases
+we're most worried about, types like X above that are actually inhabited.
+
+Here's another place where this reflexivity check is key:
+Consider trying to prove (f a) ~R (f a). The AppTys in there can't
+be decomposed, because representational equality isn't congruent with respect
+to AppTy. So, when canonicalising the equality above, we get stuck and
+would normally produce a CIrredCan. However, we really do want to
+be able to solve (f a) ~R (f a). So, in the representational case only,
+we do a reflexivity check.
+
+(This would be sound in the nominal case, but unnecessary, and I [Richard
+E.] am worried that it would slow down the common case.)
+-}
+
+------------------------
+-- | We're able to unwrap a newtype. Update the bits accordingly.
+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2
+                  -> SwapFlag
+                  -> TcType                                    -- ^ ty1
+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
+                  -> TcType               -- ^ ty2
+                  -> TcType               -- ^ ty2, with type synonyms
+                  -> TcS (StopOrContinue Ct)
+can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
+  = do { traceTcS "can_eq_newtype_nc" $
+         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]
+
+         -- check for blowing our stack:
+         -- See Note [Newtypes can blow the stack]
+       ; checkReductionDepth (ctEvLoc ev) ty1
+       ; addUsedGREs (bagToList gres)
+           -- we have actually used the newtype constructor here, so
+           -- make sure we don't warn about importing it!
+
+       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2
+                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)
+       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
+
+---------
+-- ^ Decompose a type application.
+-- All input types must be flat. See Note [Canonicalising type applications]
+-- Nominal equality only!
+can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
+           -> Xi -> Xi         -- s1 t1
+           -> Xi -> Xi         -- s2 t2
+           -> TcS (StopOrContinue Ct)
+
+-- AppTys only decompose for nominal equality, so this case just leads
+-- to an irreducible constraint; see typecheck/should_compile/T10494
+-- See Note [Decomposing equality], note {4}
+can_eq_app ev s1 t1 s2 t2
+  | CtDerived { ctev_loc = loc } <- ev
+  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
+       ; stopWith ev "Decomposed [D] AppTy" }
+  | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev
+  = do { co_s <- unifyWanted loc Nominal s1 s2
+       ; let arg_loc
+               | isNextArgVisible s1 = loc
+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
+       ; co_t <- unifyWanted arg_loc Nominal t1 t2
+       ; let co = mkAppCo co_s co_t
+       ; setWantedEq dest co
+       ; stopWith ev "Decomposed [W] AppTy" }
+
+    -- If there is a ForAll/(->) mismatch, the use of the Left coercion
+    -- below is ill-typed, potentially leading to a panic in splitTyConApp
+    -- Test case: typecheck/should_run/Typeable1
+    -- We could also include this mismatch check above (for W and D), but it's slow
+    -- and we'll get a better error message not doing it
+  | s1k `mismatches` s2k
+  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
+
+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
+  = do { let co   = mkTcCoVarCo evar
+             co_s = mkTcLRCo CLeft  co
+             co_t = mkTcLRCo CRight co
+       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
+                                     , evCoercion co_s )
+       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
+                                     , evCoercion co_t )
+       ; emitWorkNC [evar_t]
+       ; canEqNC evar_s NomEq s1 s2 }
+
+  where
+    s1k = tcTypeKind s1
+    s2k = tcTypeKind s2
+
+    k1 `mismatches` k2
+      =  isForAllTy k1 && not (isForAllTy k2)
+      || not (isForAllTy k1) && isForAllTy k2
+
+-----------------------
+-- | Break apart an equality over a casted type
+-- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)
+canEqCast :: Bool         -- are both types flat?
+          -> CtEvidence
+          -> EqRel
+          -> SwapFlag
+          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1
+          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty
+          -> TcS (StopOrContinue Ct)
+canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2
+  = do { traceTcS "Decomposing cast" (vcat [ ppr ev
+                                           , ppr ty1 <+> text "|>" <+> ppr co1
+                                           , ppr ps_ty2 ])
+       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2
+                                     (mkTcGReflRightCo role ty1 co1)
+                                     (mkTcReflCo role ps_ty2)
+       ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
+  where
+    role = eqRelRole eq_rel
+
+------------------------
+canTyConApp :: CtEvidence -> EqRel
+            -> TyCon -> [TcType]
+            -> TyCon -> [TcType]
+            -> TcS (StopOrContinue Ct)
+-- See Note [Decomposing TyConApps]
+canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+  | tc1 == tc2
+  , tys1 `equalLength` tys2
+  = do { inerts <- getTcSInerts
+       ; if can_decompose inerts
+         then do { traceTcS "canTyConApp"
+                       (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2)
+                 ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
+                 ; stopWith ev "Decomposed TyConApp" }
+         else canEqFailure ev eq_rel ty1 ty2 }
+
+  -- See Note [Skolem abstract data] (at tyConSkolem)
+  | tyConSkolem tc1 || tyConSkolem tc2
+  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
+       ; continueWith (mkIrredCt ev) }
+
+  -- Fail straight away for better error messages
+  -- See Note [Use canEqFailure in canDecomposableTyConApp]
+  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&
+                             isGenerativeTyCon tc2 Representational)
+  = canEqFailure ev eq_rel ty1 ty2
+  | otherwise
+  = canEqHardFailure ev ty1 ty2
+  where
+    ty1 = mkTyConApp tc1 tys1
+    ty2 = mkTyConApp tc2 tys2
+
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+     -- See Note [Decomposing equality]
+    can_decompose inerts
+      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)
+      || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))
+
+{-
+Note [Use canEqFailure in canDecomposableTyConApp]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must use canEqFailure, not canEqHardFailure here, because there is
+the possibility of success if working with a representational equality.
+Here is one case:
+
+  type family TF a where TF Char = Bool
+  data family DF a
+  newtype instance DF Bool = MkDF Int
+
+Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet
+know `a`. This is *not* a hard failure, because we might soon learn
+that `a` is, in fact, Char, and then the equality succeeds.
+
+Here is another case:
+
+  [G] Age ~R Int
+
+where Age's constructor is not in scope. We don't want to report
+an "inaccessible code" error in the context of this Given!
+
+For example, see typecheck/should_compile/T10493, repeated here:
+
+  import Data.Ord (Down)  -- no constructor
+
+  foo :: Coercible (Down Int) Int => Down Int -> Int
+  foo = coerce
+
+That should compile, but only because we use canEqFailure and not
+canEqHardFailure.
+
+Note [Decomposing equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have a constraint (of any flavour and role) that looks like
+T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,
+of course, is "it depends". This Note spells it all out.
+
+In this Note, "decomposition" refers to taking the constraint
+  [fl] (T tys1 ~X T tys2)
+(for some flavour fl and some role X) and replacing it with
+  [fls'] (tys1 ~Xs' tys2)
+where that notation indicates a list of new constraints, where the
+new constraints may have different flavours and different roles.
+
+The key property to consider is injectivity. When decomposing a Given the
+decomposition is sound if and only if T is injective in all of its type
+arguments. When decomposing a Wanted, the decomposition is sound (assuming the
+correct roles in the produced equality constraints), but it may be a guess --
+that is, an unforced decision by the constraint solver. Decomposing Wanteds
+over injective TyCons does not entail guessing. But sometimes we want to
+decompose a Wanted even when the TyCon involved is not injective! (See below.)
+
+So, in broad strokes, we want this rule:
+
+(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective
+at role X.
+
+Pursuing the details requires exploring three axes:
+* Flavour: Given vs. Derived vs. Wanted
+* Role: Nominal vs. Representational
+* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable
+
+(So a type variable isn't a TyCon, but it's convenient to put the AppTy case
+in the same table.)
+
+Right away, we can say that Derived behaves just as Wanted for the purposes
+of decomposition. The difference between Derived and Wanted is the handling of
+evidence. Since decomposition in these cases isn't a matter of soundness but of
+guessing, we want the same behavior regardless of evidence.
+
+Here is a table (discussion following) detailing where decomposition of
+   (T s1 ... sn) ~r (T t1 .. tn)
+is allowed.  The first four lines (Data types ... type family) refer
+to TyConApps with various TyCons T; the last line is for AppTy, where
+there is presumably a type variable at the head, so it's actually
+   (s s1 ... sn) ~r (t t1 .. tn)
+
+NOMINAL               GIVEN                       WANTED
+
+Datatype               YES                         YES
+Newtype                YES                         YES
+Data family            YES                         YES
+Type family            YES, in injective args{1}   YES, in injective args{1}
+Type variable          YES                         YES
+
+REPRESENTATIONAL      GIVEN                       WANTED
+
+Datatype               YES                         YES
+Newtype                NO{2}                      MAYBE{2}
+Data family            NO{3}                      MAYBE{3}
+Type family             NO                          NO
+Type variable          NO{4}                       NO{4}
+
+{1}: Type families can be injective in some, but not all, of their arguments,
+so we want to do partial decomposition. This is quite different than the way
+other decomposition is done, where the decomposed equalities replace the original
+one. We thus proceed much like we do with superclasses: emitting new Givens
+when "decomposing" a partially-injective type family Given and new Deriveds
+when "decomposing" a partially-injective type family Wanted. (As of the time of
+writing, 13 June 2015, the implementation of injective type families has not
+been merged, but it should be soon. Please delete this parenthetical if the
+implementation is indeed merged.)
+
+{2}: See Note [Decomposing newtypes at representational role]
+
+{3}: Because of the possibility of newtype instances, we must treat
+data families like newtypes. See also Note [Decomposing newtypes at
+representational role]. See #10534 and test case
+typecheck/should_fail/T10534.
+
+{4}: Because type variables can stand in for newtypes, we conservatively do not
+decompose AppTys over representational equality.
+
+In the implementation of can_eq_nc and friends, we don't directly pattern
+match using lines like in the tables above, as those tables don't cover
+all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,
+boiling the tables above down to rule (*). The exceptions to rule (*) are for
+injective type families, which are handled separately from other decompositions,
+and the MAYBE entries above.
+
+Note [Decomposing newtypes at representational role]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note discusses the 'newtype' line in the REPRESENTATIONAL table
+in Note [Decomposing equality]. (At nominal role, newtypes are fully
+decomposable.)
+
+Here is a representative example of why representational equality over
+newtypes is tricky:
+
+  newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,
+  type role Nt representational  -- but the user gives it an R role anyway
+
+If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to
+[W] alpha ~R beta, because it's possible that alpha and beta aren't
+representationally equal. Here's another example.
+
+  newtype Nt a = MkNt (Id a)
+  type family Id a where Id a = a
+
+  [W] Nt Int ~R Nt Age
+
+Because of its use of a type family, Nt's parameter will get inferred to have
+a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which
+is unsatisfiable. Unwrapping, though, leads to a solution.
+
+Conclusion:
+ * Unwrap newtypes before attempting to decompose them.
+   This is done in can_eq_nc'.
+
+It all comes from the fact that newtypes aren't necessarily injective
+w.r.t. representational equality.
+
+Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use
+NthCo on representational coercions over newtypes. NthCo comes into play
+only when decomposing givens.
+
+Conclusion:
+ * Do not decompose [G] N s ~R N t
+
+Is it sensible to decompose *Wanted* constraints over newtypes?  Yes!
+It's the only way we could ever prove (IO Int ~R IO Age), recalling
+that IO is a newtype.
+
+However we must be careful.  Consider
+
+  type role Nt representational
+
+  [G] Nt a ~R Nt b       (1)
+  [W] NT alpha ~R Nt b   (2)
+  [W] alpha ~ a          (3)
+
+If we focus on (3) first, we'll substitute in (2), and now it's
+identical to the given (1), so we succeed.  But if we focus on (2)
+first, and decompose it, we'll get (alpha ~R b), which is not soluble.
+This is exactly like the question of overlapping Givens for class
+constraints: see Note [Instance and Given overlap] in TcInteract.
+
+Conclusion:
+  * Decompose [W] N s ~R N t  iff there no given constraint that could
+    later solve it.
+-}
+
+canDecomposableTyConAppOK :: CtEvidence -> EqRel
+                          -> TyCon -> [TcType] -> [TcType]
+                          -> TcS ()
+-- Precondition: tys1 and tys2 are the same length, hence "OK"
+canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
+  = ASSERT( tys1 `equalLength` tys2 )
+    case ev of
+     CtDerived {}
+        -> unifyDeriveds loc tc_roles tys1 tys2
+
+     CtWanted { ctev_dest = dest }
+                   -- new_locs and tc_roles are both infinite, so
+                   -- we are guaranteed that cos has the same length
+                   -- as tys1 and tys2
+        -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2
+              ; setWantedEq dest (mkTyConAppCo role tc cos) }
+
+     CtGiven { ctev_evar = evar }
+        -> do { let ev_co = mkCoVarCo evar
+              ; given_evs <- newGivenEvVars loc $
+                             [ ( mkPrimEqPredRole r ty1 ty2
+                               , evCoercion $ mkNthCo r i ev_co )
+                             | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
+                             , r /= Phantom
+                             , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
+              ; emitWorkNC given_evs }
+  where
+    loc        = ctEvLoc ev
+    role       = eqRelRole eq_rel
+
+      -- infinite, as tyConRolesX returns an infinite tail of Nominal
+    tc_roles   = tyConRolesX role tc
+
+      -- Add nuances to the location during decomposition:
+      --  * if the argument is a kind argument, remember this, so that error
+      --    messages say "kind", not "type". This is determined based on whether
+      --    the corresponding tyConBinder is named (that is, dependent)
+      --  * if the argument is invisible, note this as well, again by
+      --    looking at the corresponding binder
+      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't
+      -- do either of these changes. (Forgetting to do so led to #16188)
+      --
+      -- NB: infinite in length
+    new_locs = [ new_loc
+               | bndr <- tyConBinders tc
+               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc
+                              | otherwise               = loc
+                     new_loc  | isVisibleTyConBinder bndr
+                              = updateCtLocOrigin new_loc0 toInvisibleOrigin
+                              | otherwise
+                              = new_loc0 ]
+               ++ repeat loc
+
+-- | Call when canonicalizing an equality fails, but if the equality is
+-- representational, there is some hope for the future.
+-- Examples in Note [Use canEqFailure in canDecomposableTyConApp]
+canEqFailure :: CtEvidence -> EqRel
+             -> TcType -> TcType -> TcS (StopOrContinue Ct)
+canEqFailure ev NomEq ty1 ty2
+  = canEqHardFailure ev ty1 ty2
+canEqFailure ev ReprEq ty1 ty2
+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1
+       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2
+            -- We must flatten the types before putting them in the
+            -- inert set, so that we are sure to kick them out when
+            -- new equalities become available
+       ; traceTcS "canEqFailure with ReprEq" $
+         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]
+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+       ; continueWith (mkIrredCt new_ev) }
+
+-- | Call when canonicalizing an equality fails with utterly no hope.
+canEqHardFailure :: CtEvidence
+                 -> TcType -> TcType -> TcS (StopOrContinue Ct)
+-- See Note [Make sure that insolubles are fully rewritten]
+canEqHardFailure ev ty1 ty2
+  = do { (s1, co1) <- flatten FM_SubstOnly ev ty1
+       ; (s2, co2) <- flatten FM_SubstOnly ev ty2
+       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
+       ; continueWith (mkInsolubleCt new_ev) }
+
+{-
+Note [Decomposing TyConApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see (T s1 t1 ~ T s2 t2), then we can just decompose to
+  (s1 ~ s2, t1 ~ t2)
+and push those back into the work list.  But if
+  s1 = K k1    s2 = K k2
+then we will just decomopose s1~s2, and it might be better to
+do so on the spot.  An important special case is where s1=s2,
+and we get just Refl.
+
+So canDecomposableTyCon is a fast-path decomposition that uses
+unifyWanted etc to short-cut that work.
+
+Note [Canonicalising type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (s1 t1) ~ ty2, how should we proceed?
+The simple things is to see if ty2 is of form (s2 t2), and
+decompose.  By this time s1 and s2 can't be saturated type
+function applications, because those have been dealt with
+by an earlier equation in can_eq_nc, so it is always sound to
+decompose.
+
+However, over-eager decomposition gives bad error messages
+for things like
+   a b ~ Maybe c
+   e f ~ p -> q
+Suppose (in the first example) we already know a~Array.  Then if we
+decompose the application eagerly, yielding
+   a ~ Maybe
+   b ~ c
+we get an error        "Can't match Array ~ Maybe",
+but we'd prefer to get "Can't match Array b ~ Maybe c".
+
+So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of
+replacing (a b) by (Array b), before using try_decompose_app to
+decompose it.
+
+Note [Make sure that insolubles are fully rewritten]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When an equality fails, we still want to rewrite the equality
+all the way down, so that it accurately reflects
+ (a) the mutable reference substitution in force at start of solving
+ (b) any ty-binds in force at this point in solving
+See Note [Rewrite insolubles] in TcSMonad.
+And if we don't do this there is a bad danger that
+TcSimplify.applyTyVarDefaulting will find a variable
+that has in fact been substituted.
+
+Note [Do not decompose Given polytype equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?
+No -- what would the evidence look like?  So instead we simply discard
+this given evidence.
+
+
+Note [Combining insoluble constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As this point we have an insoluble constraint, like Int~Bool.
+
+ * If it is Wanted, delete it from the cache, so that subsequent
+   Int~Bool constraints give rise to separate error messages
+
+ * But if it is Derived, DO NOT delete from cache.  A class constraint
+   may get kicked out of the inert set, and then have its functional
+   dependency Derived constraints generated a second time. In that
+   case we don't want to get two (or more) error messages by
+   generating two (or more) insoluble fundep constraints from the same
+   class constraint.
+
+Note [No top-level newtypes on RHS of representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we're in this situation:
+
+ work item:  [W] c1 : a ~R b
+     inert:  [G] c2 : b ~R Id a
+
+where
+  newtype Id a = Id a
+
+We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened
+and the Id newtype is unwrapped. This is assured by requiring only flat
+types in canEqTyVar *and* having the newtype-unwrapping check above
+the tyvar check in can_eq_nc.
+
+Note [Occurs check error]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an occurs check error, are we necessarily hosed? Say our
+tyvar is tv1 and the type it appears in is xi2. Because xi2 is function
+free, then if we're computing w.r.t. nominal equality, then, yes, we're
+hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t.
+representational equality, this is a little subtler. Once again, (a ~R [a])
+is a bad thing, but (a ~R N a) for a newtype N might be just fine. This
+means also that (a ~ b a) might be fine, because `b` might become a newtype.
+
+So, we must check: does tv1 appear in xi2 under any type constructor
+that is generative w.r.t. representational equality? That's what
+isInsolubleOccursCheck does.
+
+See also #10715, which induced this addition.
+
+Note [canCFunEqCan]
+~~~~~~~~~~~~~~~~~~~
+Flattening the arguments to a type family can change the kind of the type
+family application. As an easy example, consider (Any k) where (k ~ Type)
+is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).
+The problem here is that the fsk in the CFunEqCan will have the old kind.
+
+The solution is to come up with a new fsk/fmv of the right kind. For
+givens, this is easy: just introduce a new fsk and update the flat-cache
+with the new one. For wanteds, we want to solve the old one if favor of
+the new one, so we use dischargeFmv. This also kicks out constraints
+from the inert set; this behavior is correct, as the kind-change may
+allow more constraints to be solved.
+
+We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case
+if we really need to.  Of course `flattenArgsNom` should return `Refl`
+whenever possible, but #15577 was an infinite loop because even
+though the coercion was homo-kinded, `kind_co` was not `Refl`, so we
+made a new (identical) CFunEqCan, and then the entire process repeated.
+-}
+
+canCFunEqCan :: CtEvidence
+             -> TyCon -> [TcType]   -- LHS
+             -> TcTyVar             -- RHS
+             -> TcS (StopOrContinue Ct)
+-- ^ Canonicalise a CFunEqCan.  We know that
+--     the arg types are already flat,
+-- and the RHS is a fsk, which we must *not* substitute.
+-- So just substitute in the LHS
+canCFunEqCan ev fn tys fsk
+  = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys
+                        -- cos :: tys' ~ tys
+
+       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos
+                        -- :: F tys' ~ F tys
+             new_lhs = mkTyConApp fn tys'
+
+             flav    = ctEvFlavour ev
+       ; (ev', fsk')
+           <- if isTcReflexiveCo kind_co   -- See Note [canCFunEqCan]
+              then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)
+                      ; let fsk_ty = mkTyVarTy fsk
+                      ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
+                                                 lhs_co (mkTcNomReflCo fsk_ty)
+                      ; return (ev', fsk) }
+              else do { traceTcS "canCFunEqCan: non-refl" $
+                        vcat [ text "Kind co:" <+> ppr kind_co
+                             , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)
+                             , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))
+                                                  2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys)))
+                             , text "New LHS" <+> hang (ppr new_lhs)
+                                                     2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]
+                      ; (ev', new_co, new_fsk)
+                          <- newFlattenSkolem flav (ctEvLoc ev) fn tys'
+                      ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
+                               -- sym lhs_co :: F tys ~ F tys'
+                               -- new_co     :: F tys' ~ new_fsk
+                               -- co         :: F tys ~ (new_fsk |> kind_co)
+                            co = mkTcSymCo lhs_co `mkTcTransCo`
+                                 mkTcCoherenceRightCo Nominal
+                                                      (mkTyVarTy new_fsk)
+                                                      kind_co
+                                                      new_co
+
+                      ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)
+                      ; dischargeFunEq ev fsk co xi
+                      ; return (ev', new_fsk) }
+
+       ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')
+       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
+                                 , cc_tyargs = tys', cc_fsk = fsk' }) }
+
+---------------------
+canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs
+           -> EqRel -> SwapFlag
+           -> TcTyVar               -- tv1
+           -> TcType                -- lhs: pretty lhs, already flat
+           -> TcType -> TcType      -- rhs: already flat
+           -> TcS (StopOrContinue Ct)
+canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
+  | k1 `tcEqType` k2
+  = canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
+
+  -- So the LHS and RHS don't have equal kinds
+  -- Note [Flattening] in TcFlatten gives us (F2), which says that
+  -- flattening is always homogeneous (doesn't change kinds). But
+  -- perhaps by flattening the kinds of the two sides of the equality
+  -- at hand makes them equal. So let's try that.
+  | otherwise
+  = do { (flat_k1, k1_co) <- flattenKind loc flav k1  -- k1_co :: flat_k1 ~N kind(xi1)
+       ; (flat_k2, k2_co) <- flattenKind loc flav k2  -- k2_co :: flat_k2 ~N kind(xi2)
+       ; traceTcS "canEqTyVar tried flattening kinds"
+                  (vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1)
+                              , text "~"
+                              , parens (ppr xi2 <+> dcolon <+> ppr k2) ]
+                        , ppr flat_k1
+                        , ppr k1_co
+                        , ppr flat_k2
+                        , ppr k2_co ])
+
+         -- We know the LHS is a tyvar. So let's dump all the coercions on the RHS
+         -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and
+         -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence
+         -- (as an optimization, so that we don't have to flatten the kinds again)
+         -- and then emit a kind equality in canEqTyVarHetero.
+         -- See Note [Equalities with incompatible kinds]
+
+       ; let role = eqRelRole eq_rel
+       ; if flat_k1 `tcEqType` flat_k2
+         then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co
+                         -- :: kind(xi2) ~N kind(xi1)
+
+                       new_rhs     = xi2 `mkCastTy` rhs_kind_co
+                       ps_rhs      = ps_xi2 `mkCastTy` rhs_kind_co
+                       rhs_co      = mkTcGReflLeftCo role xi2 rhs_kind_co
+
+                 ; new_ev <- rewriteEqEvidence ev swapped xi1 new_rhs
+                                               (mkTcReflCo role xi1) rhs_co
+                       -- NB: rewriteEqEvidence executes a swap, if any, so we're
+                       -- NotSwapped now.
+                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_ty1 new_rhs ps_rhs }
+         else
+    do { let sym_k1_co = mkTcSymCo k1_co  -- :: kind(xi1) ~N flat_k1
+             sym_k2_co = mkTcSymCo k2_co  -- :: kind(xi2) ~N flat_k2
+
+             new_lhs = xi1 `mkCastTy` sym_k1_co  -- :: flat_k1
+             new_rhs = xi2 `mkCastTy` sym_k2_co  -- :: flat_k2
+             ps_rhs  = ps_xi2 `mkCastTy` sym_k2_co
+
+             lhs_co = mkTcGReflLeftCo role xi1 sym_k1_co
+             rhs_co = mkTcGReflLeftCo role xi2 sym_k2_co
+               -- lhs_co :: (xi1 |> sym k1_co) ~ xi1
+               -- rhs_co :: (xi2 |> sym k2_co) ~ xi2
+
+       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+         -- no longer swapped, due to rewriteEqEvidence
+       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_ty1
+                                        new_rhs flat_k2 ps_rhs } }
+  where
+    xi1 = mkTyVarTy tv1
+
+    k1 = tyVarKind tv1
+    k2 = tcTypeKind xi2
+
+    loc  = ctEvLoc ev
+    flav = ctEvFlavour ev
+
+canEqTyVarHetero :: CtEvidence   -- :: (tv1 |> co1 :: ki1) ~ (xi2 :: ki2)
+                 -> EqRel
+                 -> TcTyVar -> TcCoercionN -> TcKind  -- tv1 |> co1 :: ki1
+                 -> TcType            -- pretty tv1 (*without* the coercion)
+                 -> TcType -> TcKind  -- xi2 :: ki2
+                 -> TcType            -- pretty xi2
+                 -> TcS (StopOrContinue Ct)
+canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2
+  -- See Note [Equalities with incompatible kinds]
+  | CtGiven { ctev_evar = evar } <- ev
+    -- unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2)
+    -- swapped  : tm :: (rhs :: ki2) ~ (lhs :: ki1)
+  = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar)
+       ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
+       ; let  -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)   (whether swapped or not)
+              -- co1     :: kind(tv1) ~N ki1
+              -- homo_co :: ki2 ~N kind(tv1)
+             homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1
+             rhs'    = mkCastTy xi2 homo_co     -- :: kind(tv1)
+             ps_rhs' = mkCastTy ps_xi2 homo_co  -- :: kind(tv1)
+             rhs_co  = mkTcGReflLeftCo role xi2 homo_co
+               -- rhs_co :: (xi2 |> homo_co :: kind(tv1)) ~ xi2
+
+             lhs'   = mkTyVarTy tv1       -- :: kind(tv1)
+             lhs_co = mkTcGReflRightCo role lhs' co1
+               -- lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 |> co1 :: ki1)
+
+       ; traceTcS "Hetero equality gives rise to given kind equality"
+           (ppr kind_ev <+> dcolon <+> ppr kind_pty)
+       ; emitWorkNC [kind_ev]
+       ; type_ev <- rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_co
+       ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
+
+  -- See Note [Equalities with incompatible kinds]
+  | otherwise   -- Wanted and Derived
+                -- NB: all kind equalities are Nominal
+  = do { emitNewDerivedEq kind_loc Nominal ki1 ki2
+             -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)
+       ; traceTcS "Hetero equality gives rise to derived kind equality" $
+           ppr ev
+       ; continueWith (mkIrredCt ev) }
+
+  where
+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
+    kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc
+
+    loc  = ctev_loc ev
+    role = eqRelRole eq_rel
+
+-- guaranteed that tcTypeKind lhs == tcTypeKind rhs
+canEqTyVarHomo :: CtEvidence
+               -> EqRel -> SwapFlag
+               -> TcTyVar                -- lhs: tv1
+               -> TcType                 -- pretty lhs
+               -> TcType -> TcType       -- rhs (might not be flat)
+               -> TcS (StopOrContinue Ct)
+canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _
+  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
+  , tv1 == tv2
+  = canEqReflexive ev eq_rel (mkTyVarTy tv1)
+    -- we don't need to check co because it must be reflexive
+
+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
+  , swapOverTyVars tv1 tv2
+  = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
+         -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten
+         -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
+         -- Flatten the RHS less vigorously, to avoid gratuitous flattening
+         -- True <=> xi2 should not itself be a type-function application
+
+       ; let role    = eqRelRole eq_rel
+             sym_co2 = mkTcSymCo co2
+             ty1     = mkTyVarTy tv1
+             new_lhs = ty1 `mkCastTy` sym_co2
+             lhs_co  = mkTcGReflLeftCo role ty1 sym_co2
+
+             new_rhs = mkTyVarTy tv2
+             rhs_co  = mkTcGReflRightCo role new_rhs co2
+
+       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+
+       ; dflags <- getDynFlags
+       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_ty1 `mkCastTy` sym_co2) }
+
+canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2
+  = do { dflags <- getDynFlags
+       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }
+
+-- The RHS here is either not a casted tyvar, or it's a tyvar but we want
+-- to rewrite the LHS to the RHS (as per swapOverTyVars)
+canEqTyVar2 :: DynFlags
+            -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)
+            -> EqRel
+            -> SwapFlag
+            -> TcTyVar                  -- lhs = tv, flat
+            -> TcType                   -- rhs
+            -> TcS (StopOrContinue Ct)
+-- LHS is an inert type variable,
+-- and RHS is fully rewritten, but with type synonyms
+-- preserved as much as possible
+canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
+  | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs  -- No occurs check
+     -- Must do the occurs check even on tyvar/tyvar
+     -- equalities, in case have  x ~ (y :: ..x...)
+     -- #12593
+  = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
+       ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
+                                , cc_rhs = rhs', cc_eq_rel = eq_rel }) }
+
+  | otherwise  -- For some reason (occurs check, or forall) we can't unify
+               -- We must not use it for further rewriting!
+  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)
+       ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
+       ; if isInsolubleOccursCheck eq_rel tv1 rhs
+         then continueWith (mkInsolubleCt new_ev)
+             -- If we have a ~ [a], it is not canonical, and in particular
+             -- we don't want to rewrite existing inerts with it, otherwise
+             -- we'd risk divergence in the constraint solver
+
+         else continueWith (mkIrredCt new_ev) }
+             -- A representational equality with an occurs-check problem isn't
+             -- insoluble! For example:
+             --   a ~R b a
+             -- We might learn that b is the newtype Id.
+             -- But, the occurs-check certainly prevents the equality from being
+             -- canonical, and we might loop if we were to use it in rewriting.
+  where
+    role = eqRelRole eq_rel
+
+    lhs = mkTyVarTy tv1
+
+    rewrite_co1  = mkTcReflCo role lhs
+    rewrite_co2  = mkTcReflCo role rhs
+
+-- | Solve a reflexive equality constraint
+canEqReflexive :: CtEvidence    -- ty ~ ty
+               -> EqRel
+               -> TcType        -- ty
+               -> TcS (StopOrContinue Ct)   -- always Stop
+canEqReflexive ev eq_rel ty
+  = do { setEvBindIfWanted ev (evCoercion $
+                               mkTcReflCo (eqRelRole eq_rel) ty)
+       ; stopWith ev "Solved by reflexivity" }
+
+{-
+Note [Canonical orientation for tyvar/tyvar equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have a ~ b where both 'a' and 'b' are TcTyVars, which way
+round should be oriented in the CTyEqCan?  The rules, implemented by
+canEqTyVarTyVar, are these
+
+ * If either is a flatten-meta-variables, it goes on the left.
+
+ * Put a meta-tyvar on the left if possible
+       alpha[3] ~ r
+
+ * If both are meta-tyvars, put the more touchable one (deepest level
+   number) on the left, so there is the best chance of unifying it
+        alpha[3] ~ beta[2]
+
+ * If both are meta-tyvars and both at the same level, put a TyVarTv
+   on the right if possible
+        alpha[2] ~ beta[2](sig-tv)
+   That way, when we unify alpha := beta, we don't lose the TyVarTv flag.
+
+ * Put a meta-tv with a System Name on the left if possible so it
+   gets eliminated (improves error messages)
+
+ * If one is a flatten-skolem, put it on the left so that it is
+   substituted out  Note [Eliminate flat-skols] in TcUinfy
+        fsk ~ a
+
+Note [Equalities with incompatible kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What do we do when we have an equality
+
+  (tv :: k1) ~ (rhs :: k2)
+
+where k1 and k2 differ? This Note explores this treacherous area.
+
+First off, the question above is slightly the wrong question. Flattening
+a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening
+the kind might introduce a cast. So we might have a casted tyvar on the
+left. We thus revise our test case to
+
+  (tv |> co :: k1) ~ (rhs :: k2)
+
+We must proceed differently here depending on whether we have a Wanted
+or a Given. Consider this:
+
+ [W] w :: (alpha :: k) ~ (Int :: Type)
+
+where k is a skolem. One possible way forward is this:
+
+ [W] co :: k ~ Type
+ [W] w :: (alpha :: k) ~ (Int |> sym co :: k)
+
+The next step will be to unify
+
+  alpha := Int |> sym co
+
+Now, consider what error we'll report if we can't solve the "co"
+wanted. Its CtOrigin is the w wanted... which now reads (after zonking)
+Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which
+is embarrassing. See #11198 for more tales of destruction.
+
+The reason for this odd behavior is much the same as
+Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the
+new `co` is a Wanted.
+
+   The solution is then not to use `co` to "rewrite" -- that is, cast
+   -- `w`, but instead to keep `w` heterogeneous and
+   irreducible. Given that we're not using `co`, there is no reason to
+   collect evidence for it, so `co` is born a Derived, with a CtOrigin
+   of KindEqOrigin.
+
+When the Derived is solved (by unification), the original wanted (`w`)
+will get kicked out.
+
+Note that, if we had [G] co1 :: k ~ Type available, then none of this code would
+trigger, because flattening would have rewritten k to Type. That is,
+`w` would look like [W] (alpha |> co1 :: Type) ~ (Int :: Type), and the tyvar
+case will trigger, correctly rewriting alpha to (Int |> sym co1).
+
+Successive canonicalizations of the same Wanted may produce
+duplicate Deriveds. Similar duplications can happen with fundeps, and there
+seems to be no easy way to avoid. I expect this case to be rare.
+
+For Givens, this problem doesn't bite, so a heterogeneous Given gives
+rise to a Given kind equality. No Deriveds here. We thus homogenise
+the Given (see the "homo_co" in the Given case in canEqTyVar) and
+carry on with a homogeneous equality constraint.
+
+Separately, I (Richard E) spent some time pondering what to do in the case
+that we have [W] (tv |> co1 :: k1) ~ (tv |> co2 :: k2) where k1 and k2
+differ. Note that the tv is the same. (This case is handled as the first
+case in canEqTyVarHomo.) At one point, I thought we could solve this limited
+form of heterogeneous Wanted, but I then reconsidered and now treat this case
+just like any other heterogeneous Wanted.
+
+Note [Type synonyms and canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat type synonym applications as xi types, that is, they do not
+count as type function applications.  However, we do need to be a bit
+careful with type synonyms: like type functions they may not be
+generative or injective.  However, unlike type functions, they are
+parametric, so there is no problem in expanding them whenever we see
+them, since we do not need to know anything about their arguments in
+order to expand them; this is what justifies not having to treat them
+as specially as type function applications.  The thing that causes
+some subtleties is that we prefer to leave type synonym applications
+*unexpanded* whenever possible, in order to generate better error
+messages.
+
+If we encounter an equality constraint with type synonym applications
+on both sides, or a type synonym application on one side and some sort
+of type application on the other, we simply must expand out the type
+synonyms in order to continue decomposing the equality constraint into
+primitive equality constraints.  For example, suppose we have
+
+  type F a = [Int]
+
+and we encounter the equality
+
+  F a ~ [b]
+
+In order to continue we must expand F a into [Int], giving us the
+equality
+
+  [Int] ~ [b]
+
+which we can then decompose into the more primitive equality
+constraint
+
+  Int ~ b.
+
+However, if we encounter an equality constraint with a type synonym
+application on one side and a variable on the other side, we should
+NOT (necessarily) expand the type synonym, since for the purpose of
+good error messages we want to leave type synonyms unexpanded as much
+as possible.  Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar.
+
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                  Evidence transformation
+*                                                                      *
+************************************************************************
+-}
+
+data StopOrContinue a
+  = ContinueWith a    -- The constraint was not solved, although it may have
+                      --   been rewritten
+
+  | Stop CtEvidence   -- The (rewritten) constraint was solved
+         SDoc         -- Tells how it was solved
+                      -- Any new sub-goals have been put on the work list
+
+instance Functor StopOrContinue where
+  fmap f (ContinueWith x) = ContinueWith (f x)
+  fmap _ (Stop ev s)      = Stop ev s
+
+instance Outputable a => Outputable (StopOrContinue a) where
+  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev
+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
+
+continueWith :: a -> TcS (StopOrContinue a)
+continueWith = return . ContinueWith
+
+stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
+stopWith ev s = return (Stop ev (text s))
+
+andWhenContinue :: TcS (StopOrContinue a)
+                -> (a -> TcS (StopOrContinue b))
+                -> TcS (StopOrContinue b)
+andWhenContinue tcs1 tcs2
+  = do { r <- tcs1
+       ; case r of
+           Stop ev s       -> return (Stop ev s)
+           ContinueWith ct -> tcs2 ct }
+infixr 0 `andWhenContinue`    -- allow chaining with ($)
+
+rewriteEvidence :: CtEvidence   -- old evidence
+                -> TcPredType   -- new predicate
+                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>
+                -> TcS (StopOrContinue CtEvidence)
+-- Returns Just new_ev iff either (i)  'co' is reflexivity
+--                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached
+-- In either case, there is nothing new to do with new_ev
+{-
+     rewriteEvidence old_ev new_pred co
+Main purpose: create new evidence for new_pred;
+              unless new_pred is cached already
+* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev
+* If old_ev was wanted, create a binding for old_ev, in terms of new_ev
+* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev
+* Returns Nothing if new_ev is already cached
+
+        Old evidence    New predicate is               Return new evidence
+        flavour                                        of same flavor
+        -------------------------------------------------------------------
+        Wanted          Already solved or in inert     Nothing
+        or Derived      Not                            Just new_evidence
+
+        Given           Already in inert               Nothing
+                        Not                            Just new_evidence
+
+Note [Rewriting with Refl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the coercion is just reflexivity then you may re-use the same
+variable.  But be careful!  Although the coercion is Refl, new_pred
+may reflect the result of unification alpha := ty, so new_pred might
+not _look_ the same as old_pred, and it's vital to proceed from now on
+using new_pred.
+
+qThe flattener preserves type synonyms, so they should appear in new_pred
+as well as in old_pred; that is important for good error messages.
+ -}
+
+
+rewriteEvidence old_ev@(CtDerived {}) new_pred _co
+  = -- If derived, don't even look at the coercion.
+    -- This is very important, DO NOT re-order the equations for
+    -- rewriteEvidence to put the isTcReflCo test first!
+    -- Why?  Because for *Derived* constraints, c, the coercion, which
+    -- was produced by flattening, may contain suspended calls to
+    -- (ctEvExpr c), which fails for Derived constraints.
+    -- (Getting this wrong caused #7384.)
+    continueWith (old_ev { ctev_pred = new_pred })
+
+rewriteEvidence old_ev new_pred co
+  | isTcReflCo co -- See Note [Rewriting with Refl]
+  = continueWith (old_ev { ctev_pred = new_pred })
+
+rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co
+  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
+       ; continueWith new_ev }
+  where
+    -- mkEvCast optimises ReflCo
+    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational
+                                                       (ctEvRole ev)
+                                                       (mkTcSymCo co))
+
+rewriteEvidence ev@(CtWanted { ctev_dest = dest
+                             , ctev_loc = loc }) new_pred co
+  = do { mb_new_ev <- newWanted loc new_pred
+       ; MASSERT( tcCoercionRole co == ctEvRole ev )
+       ; setWantedEvTerm dest
+            (mkEvCast (getEvExpr mb_new_ev)
+                      (tcDowngradeRole Representational (ctEvRole ev) co))
+       ; case mb_new_ev of
+            Fresh  new_ev -> continueWith new_ev
+            Cached _      -> stopWith ev "Cached wanted" }
+
+
+rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
+                                        --              or orhs ~ olhs (swapped)
+                  -> SwapFlag
+                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs
+                                        -- Should be zonked, because we use tcTypeKind on nlhs/nrhs
+                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs
+                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs
+                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs
+-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)
+-- we generate
+-- If not swapped
+--      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co
+-- If 'swapped'
+--      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co
+--
+-- For (Wanted w) we do the dual thing.
+-- New  w1 : nlhs ~ nrhs
+-- If not swapped
+--      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co
+-- If swapped
+--      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co
+--
+-- It's all a form of rewwriteEvidence, specialised for equalities
+rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
+  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived
+  = return (old_ev { ctev_pred = new_pred })
+
+  | NotSwapped <- swapped
+  , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]
+  , isTcReflCo rhs_co
+  = return (old_ev { ctev_pred = new_pred })
+
+  | CtGiven { ctev_evar = old_evar } <- old_ev
+  = do { let new_tm = evCoercion (lhs_co
+                                  `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
+                                  `mkTcTransCo` mkTcSymCo rhs_co)
+       ; newGivenEvVar loc' (new_pred, new_tm) }
+
+  | CtWanted { ctev_dest = dest } <- old_ev
+  = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs
+       ; let co = maybeSym swapped $
+                  mkSymCo lhs_co
+                  `mkTransCo` hole_co
+                  `mkTransCo` rhs_co
+       ; setWantedEq dest co
+       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
+       ; return new_ev }
+
+  | otherwise
+  = panic "rewriteEvidence"
+  where
+    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
+
+      -- equality is like a type class. Bumping the depth is necessary because
+      -- of recursive newtypes, where "reducing" a newtype can actually make
+      -- it bigger. See Note [Newtypes can blow the stack].
+    loc      = ctEvLoc old_ev
+    loc'     = bumpCtLocDepth loc
+
+{- Note [unifyWanted and unifyDerived]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When decomposing equalities we often create new wanted constraints for
+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.
+Similar remarks apply for Derived.
+
+Rather than making an equality test (which traverses the structure of the
+type, perhaps fruitlessly), unifyWanted traverses the common structure, and
+bales out when it finds a difference by creating a new Wanted constraint.
+But where it succeeds in finding common structure, it just builds a coercion
+to reflect it.
+-}
+
+unifyWanted :: CtLoc -> Role
+            -> TcType -> TcType -> TcS Coercion
+-- Return coercion witnessing the equality of the two types,
+-- emitting new work equalities where necessary to achieve that
+-- Very good short-cut when the two types are equal, or nearly so
+-- See Note [unifyWanted and unifyDerived]
+-- The returned coercion's role matches the input parameter
+unifyWanted loc Phantom ty1 ty2
+  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)
+       ; return (mkPhantomCo kind_co ty1 ty2) }
+
+unifyWanted loc role orig_ty1 orig_ty2
+  = go orig_ty1 orig_ty2
+  where
+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'
+
+    go (FunTy _ s1 t1) (FunTy _ s2 t2)
+      = do { co_s <- unifyWanted loc role s1 s2
+           ; co_t <- unifyWanted loc role t1 t2
+           ; return (mkFunCo role co_s co_t) }
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2, tys1 `equalLength` tys2
+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
+      = do { cos <- zipWith3M (unifyWanted loc)
+                              (tyConRolesX role tc1) tys1 tys2
+           ; return (mkTyConAppCo role tc1 cos) }
+
+    go ty1@(TyVarTy tv) ty2
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty1' -> go ty1' ty2
+                Nothing   -> bale_out ty1 ty2}
+    go ty1 ty2@(TyVarTy tv)
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty2' -> go ty1 ty2'
+                Nothing   -> bale_out ty1 ty2 }
+
+    go ty1@(CoercionTy {}) (CoercionTy {})
+      = return (mkReflCo role ty1) -- we just don't care about coercions!
+
+    go ty1 ty2 = bale_out ty1 ty2
+
+    bale_out ty1 ty2
+       | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)
+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
+       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2
+
+unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()
+-- See Note [unifyWanted and unifyDerived]
+unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2
+
+unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()
+-- See Note [unifyWanted and unifyDerived]
+unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2
+
+unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()
+-- Create new Derived and put it in the work list
+-- Should do nothing if the two types are equal
+-- See Note [unifyWanted and unifyDerived]
+unify_derived _   Phantom _        _        = return ()
+unify_derived loc role    orig_ty1 orig_ty2
+  = go orig_ty1 orig_ty2
+  where
+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'
+
+    go (FunTy _ s1 t1) (FunTy _ s2 t2)
+      = do { unify_derived loc role s1 s2
+           ; unify_derived loc role t1 t2 }
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2, tys1 `equalLength` tys2
+      , isInjectiveTyCon tc1 role
+      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2
+    go ty1@(TyVarTy tv) ty2
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty1' -> go ty1' ty2
+                Nothing   -> bale_out ty1 ty2 }
+    go ty1 ty2@(TyVarTy tv)
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty2' -> go ty1 ty2'
+                Nothing   -> bale_out ty1 ty2 }
+    go ty1 ty2 = bale_out ty1 ty2
+
+    bale_out ty1 ty2
+       | ty1 `tcEqType` ty2 = return ()
+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
+       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2
+
+maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
+maybeSym IsSwapped  co = mkTcSymCo co
+maybeSym NotSwapped co = co
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -0,0 +1,551 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Typechecking class declarations
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcClassDcl ( tcClassSigs, tcClassDecl2,
+                    findMethodBind, instantiateMethod,
+                    tcClassMinimalDef,
+                    HsSigFun, mkHsSigFun,
+                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
+                    instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,
+                    tcATDefault
+                  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcEnv
+import TcSigs
+import TcEvidence ( idHsWrapper )
+import TcBinds
+import TcUnify
+import TcHsType
+import TcMType
+import Type     ( getClassPredTys_maybe, piResultTys )
+import TcType
+import TcRnMonad
+import DriverPhases (HscSource(..))
+import BuildTyCl( TcMethInfo )
+import Class
+import Coercion ( pprCoAxiom )
+import DynFlags
+import FamInst
+import FamInstEnv
+import Id
+import Name
+import NameEnv
+import NameSet
+import Var
+import VarEnv
+import Outputable
+import SrcLoc
+import TyCon
+import Maybes
+import BasicTypes
+import Bag
+import FastString
+import BooleanFormula
+import Util
+
+import Control.Monad
+import Data.List ( mapAccumL, partition )
+
+{-
+Dictionary handling
+~~~~~~~~~~~~~~~~~~~
+Every class implicitly declares a new data type, corresponding to dictionaries
+of that class. So, for example:
+
+        class (D a) => C a where
+          op1 :: a -> a
+          op2 :: forall b. Ord b => a -> b -> b
+
+would implicitly declare
+
+        data CDict a = CDict (D a)
+                             (a -> a)
+                             (forall b. Ord b => a -> b -> b)
+
+(We could use a record decl, but that means changing more of the existing apparatus.
+One step at at time!)
+
+For classes with just one superclass+method, we use a newtype decl instead:
+
+        class C a where
+          op :: forallb. a -> b -> b
+
+generates
+
+        newtype CDict a = CDict (forall b. a -> b -> b)
+
+Now DictTy in Type is just a form of type synomym:
+        DictTy c t = TyConTy CDict `AppTy` t
+
+Death to "ExpandingDicts".
+
+
+************************************************************************
+*                                                                      *
+                Type-checking the class op signatures
+*                                                                      *
+************************************************************************
+-}
+
+illegalHsigDefaultMethod :: Name -> SDoc
+illegalHsigDefaultMethod n =
+    text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"
+
+tcClassSigs :: Name                -- Name of the class
+            -> [LSig GhcRn]
+            -> LHsBinds GhcRn
+            -> TcM [TcMethInfo]    -- Exactly one for each method
+tcClassSigs clas sigs def_methods
+  = do { traceTc "tcClassSigs 1" (ppr clas)
+
+       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
+       ; let gen_dm_env :: NameEnv (SrcSpan, Type)
+             gen_dm_env = mkNameEnv gen_dm_prs
+
+       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+
+       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
+       ; sequence_ [ failWithTc (badMethodErr clas n)
+                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
+                   -- Value binding for non class-method (ie no TypeSig)
+
+       ; tcg_env <- getGblEnv
+       ; if tcg_src tcg_env == HsigFile
+            then
+               -- Error if we have value bindings
+               -- (Generic signatures without value bindings indicate
+               -- that a default of this form is expected to be
+               -- provided.)
+               when (not (null def_methods)) $
+                failWithTc (illegalHsigDefaultMethod clas)
+            else
+               -- Error for each generic signature without value binding
+               sequence_ [ failWithTc (badGenericMethod clas n)
+                         | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
+
+       ; traceTc "tcClassSigs 2" (ppr clas)
+       ; return op_info }
+  where
+    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
+    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]
+    dm_bind_names :: [Name] -- These ones have a value binding in the class decl
+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+    skol_info = TyConSkol ClassFlavour clas
+
+    tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
+           -> TcM [TcMethInfo]
+    tc_sig gen_dm_env (op_names, op_hs_ty)
+      = do { traceTc "ClsSig 1" (ppr op_names)
+           ; op_ty <- tcClassSigType skol_info op_names op_hs_ty
+                   -- Class tyvars already in scope
+
+           ; traceTc "ClsSig 2" (ppr op_names)
+           ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
+           where
+             f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
+                  | nm `elem` dm_bind_names                 = Just VanillaDM
+                  | otherwise                               = Nothing
+
+    tc_gen_sig (op_names, gen_hs_ty)
+      = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty
+           ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
+
+{-
+************************************************************************
+*                                                                      *
+                Class Declarations
+*                                                                      *
+************************************************************************
+-}
+
+tcClassDecl2 :: LTyClDecl GhcRn          -- The class declaration
+             -> TcM (LHsBinds GhcTcId)
+
+tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
+                                tcdMeths = default_binds}))
+  = recoverM (return emptyLHsBinds)     $
+    setSrcSpan (getLoc class_name)      $
+    do  { clas <- tcLookupLocatedClass class_name
+
+        -- We make a separate binding for each default method.
+        -- At one time I used a single AbsBinds for all of them, thus
+        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
+        -- But that desugars into
+        --      ds = \d -> (..., ..., ...)
+        --      dm1 = \d -> case ds d of (a,b,c) -> a
+        -- And since ds is big, it doesn't get inlined, so we don't get good
+        -- default methods.  Better to make separate AbsBinds for each
+        ; let (tyvars, _, _, op_items) = classBigSig clas
+              prag_fn     = mkPragEnv sigs default_binds
+              sig_fn      = mkHsSigFun sigs
+              clas_tyvars = snd (tcSuperSkolTyVars tyvars)
+              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
+        ; this_dict <- newEvVar pred
+
+        ; let tc_item = tcDefMeth clas clas_tyvars this_dict
+                                  default_binds sig_fn prag_fn
+        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
+                      mapM tc_item op_items
+
+        ; return (unionManyBags dm_binds) }
+
+tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
+
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
+          -> HsSigFun -> TcPragEnv -> ClassOpItem
+          -> TcM (LHsBinds GhcTcId)
+-- Generate code for default methods
+-- This is incompatible with Hugs, which expects a polymorphic
+-- default method for every class op, regardless of whether or not
+-- the programmer supplied an explicit default decl for the class.
+-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
+
+tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
+  = do { -- No default method
+         mapM_ (addLocM (badDmPrag sel_id))
+               (lookupPragEnv prag_fn (idName sel_id))
+       ; return emptyBag }
+
+tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
+          (sel_id, Just (dm_name, dm_spec))
+  | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
+  = do { -- First look up the default method; it should be there!
+         -- It can be the orinary default method
+         -- or the generic-default method.  E.g of the latter
+         --      class C a where
+         --        op :: a -> a -> Bool
+         --        default op :: Eq a => a -> a -> Bool
+         --        op x y = x==y
+         -- The default method we generate is
+         --    $gm :: (C a, Eq a) => a -> a -> Bool
+         --    $gm x y = x==y
+
+         global_dm_id  <- tcLookupId dm_name
+       ; global_dm_id  <- addInlinePrags global_dm_id prags
+       ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
+            -- Base the local_dm_name on the selector name, because
+            -- type errors from tcInstanceMethodBody come from here
+
+       ; spec_prags <- discardConstraints $
+                       tcSpecPrags global_dm_id prags
+       ; warnTc NoReason
+                (not (null spec_prags))
+                (text "Ignoring SPECIALISE pragmas on default method"
+                 <+> quotes (ppr sel_name))
+
+       ; let hs_ty = hs_sig_fn sel_name
+                     `orElse` pprPanic "tc_dm" (ppr sel_name)
+             -- We need the HsType so that we can bring the right
+             -- type variables into scope
+             --
+             -- Eg.   class C a where
+             --          op :: forall b. Eq b => a -> [b] -> a
+             --          gen_op :: a -> a
+             --          generic gen_op :: D a => a -> a
+             -- The "local_dm_ty" is precisely the type in the above
+             -- type signatures, ie with no "forall a. C a =>" prefix
+
+             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
+
+             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }
+                             -- Substitute the local_meth_name for the binder
+                             -- NB: the binding is always a FunBind
+
+             warn_redundant = case dm_spec of
+                                GenericDM {} -> True
+                                VanillaDM    -> False
+                -- For GenericDM, warn if the user specifies a signature
+                -- with redundant constraints; but not for VanillaDM, where
+                -- the default method may well be 'error' or something
+
+             ctxt = FunSigCtxt sel_name warn_redundant
+
+       ; let local_dm_id = mkLocalId local_dm_name local_dm_ty
+             local_dm_sig = CompleteSig { sig_bndr = local_dm_id
+                                        , sig_ctxt  = ctxt
+                                        , sig_loc   = getLoc (hsSigType hs_ty) }
+
+       ; (ev_binds, (tc_bind, _))
+               <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
+                  tcPolyCheck no_prag_fn local_dm_sig
+                              (L bind_loc lm_bind)
+
+       ; let export = ABE { abe_ext   = noExt
+                          , abe_poly  = global_dm_id
+                          , abe_mono  = local_dm_id
+                          , abe_wrap  = idHsWrapper
+                          , abe_prags = IsDefaultMethod }
+             full_bind = AbsBinds { abs_ext      = noExt
+                                  , abs_tvs      = tyvars
+                                  , abs_ev_vars  = [this_dict]
+                                  , abs_exports  = [export]
+                                  , abs_ev_binds = [ev_binds]
+                                  , abs_binds    = tc_bind
+                                  , abs_sig      = True }
+
+       ; return (unitBag (L bind_loc full_bind)) }
+
+  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
+  where
+    sel_name = idName sel_id
+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
+                                -- they are all for meth_id
+
+---------------
+tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
+tcClassMinimalDef _clas sigs op_info
+  = case findMinimalDef sigs of
+      Nothing -> return defMindef
+      Just mindef -> do
+        -- Warn if the given mindef does not imply the default one
+        -- That is, the given mindef should at least ensure that the
+        -- class ops without default methods are required, since we
+        -- have no way to fill them in otherwise
+        tcg_env <- getGblEnv
+        -- However, only do this test when it's not an hsig file,
+        -- since you can't write a default implementation.
+        when (tcg_src tcg_env /= HsigFile) $
+            whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
+                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
+        return mindef
+  where
+    -- By default require all methods without a default implementation
+    defMindef :: ClassMinimalDef
+    defMindef = mkAnd [ noLoc (mkVar name)
+                      | (name, _, Nothing) <- op_info ]
+
+instantiateMethod :: Class -> TcId -> [TcType] -> TcType
+-- Take a class operation, say
+--      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
+-- Instantiate it at [ty1,ty2]
+-- Return the "local method type":
+--      forall c. Ix x => (ty2,c) -> ty1
+instantiateMethod clas sel_id inst_tys
+  = ASSERT( ok_first_pred ) local_meth_ty
+  where
+    rho_ty = piResultTys (idType sel_id) inst_tys
+    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
+                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+
+    ok_first_pred = case getClassPredTys_maybe first_pred of
+                      Just (clas1, _tys) -> clas == clas1
+                      Nothing -> False
+              -- The first predicate should be of form (C a b)
+              -- where C is the class in question
+
+
+---------------------------
+type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
+
+mkHsSigFun :: [LSig GhcRn] -> HsSigFun
+mkHsSigFun sigs = lookupNameEnv env
+  where
+    env = mkHsSigEnv get_classop_sig sigs
+
+    get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
+    get_classop_sig  (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
+    get_classop_sig  _                               = Nothing
+
+---------------------------
+findMethodBind  :: Name                 -- Selector
+                -> LHsBinds GhcRn       -- A group of bindings
+                -> TcPragEnv
+                -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
+                -- Returns the binding, the binding
+                -- site of the method binder, and any inline or
+                -- specialisation pragmas
+findMethodBind sel_name binds prag_fn
+  = foldlBag mplus Nothing (mapBag f binds)
+  where
+    prags    = lookupPragEnv prag_fn sel_name
+
+    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
+      | op_name == sel_name
+             = Just (bind, bndr_loc, prags)
+    f _other = Nothing
+
+---------------------------
+findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
+findMinimalDef = firstJusts . map toMinimalDef
+  where
+    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
+    toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
+    toMinimalDef _                               = Nothing
+
+{-
+Note [Polymorphic methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    class Foo a where
+        op :: forall b. Ord b => a -> b -> b -> b
+    instance Foo c => Foo [c] where
+        op = e
+
+When typechecking the binding 'op = e', we'll have a meth_id for op
+whose type is
+      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
+
+So tcPolyBinds must be capable of dealing with nested polytypes;
+and so it is. See TcBinds.tcMonoBinds (with type-sig case).
+
+Note [Silly default-method bind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we pass the default method binding to the type checker, it must
+look like    op2 = e
+not          $dmop2 = e
+otherwise the "$dm" stuff comes out error messages.  But we want the
+"$dm" to come out in the interface file.  So we typecheck the former,
+and wrap it in a let, thus
+          $dmop2 = let op2 = e in op2
+This makes the error messages right.
+
+
+************************************************************************
+*                                                                      *
+                Error messages
+*                                                                      *
+************************************************************************
+-}
+
+tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
+tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
+                      text "declaration for", quotes (ppr (tcdName decl))]
+
+tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
+tcAddDeclCtxt decl thing_inside
+  = addErrCtxt (tcMkDeclCtxt decl) thing_inside
+
+badMethodErr :: Outputable a => a -> Name -> SDoc
+badMethodErr clas op
+  = hsep [text "Class", quotes (ppr clas),
+          text "does not have a method", quotes (ppr op)]
+
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+  = hsep [text "Class", quotes (ppr clas),
+          text "has a generic-default signature without a binding", quotes (ppr op)]
+
+{-
+badGenericInstanceType :: LHsBinds Name -> SDoc
+badGenericInstanceType binds
+  = vcat [text "Illegal type pattern in the generic bindings",
+          nest 2 (ppr binds)]
+
+missingGenericInstances :: [Name] -> SDoc
+missingGenericInstances missing
+  = text "Missing type patterns for" <+> pprQuotedList missing
+
+dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
+dupGenericInsts tc_inst_infos
+  = vcat [text "More than one type pattern for a single generic type constructor:",
+          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
+          text "All the type patterns for a generic type constructor must be identical"
+    ]
+  where
+    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
+-}
+badDmPrag :: TcId -> Sig GhcRn -> TcM ()
+badDmPrag sel_id prag
+  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")
+              <+> quotes (ppr sel_id)
+              <+> text "lacks an accompanying binding")
+
+warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
+warningMinimalDefIncomplete mindef
+  = vcat [ text "The MINIMAL pragma does not require:"
+         , nest 2 (pprBooleanFormulaNice mindef)
+         , text "but there is no default implementation." ]
+
+instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 hs_inst_ty
+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+instDeclCtxt2 :: Type -> SDoc
+instDeclCtxt2 dfun_ty
+  = instDeclCtxt3 cls tys
+  where
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+
+instDeclCtxt3 :: Class -> [Type] -> SDoc
+instDeclCtxt3 cls cls_tys
+  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
+
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = hang (text "In the instance declaration for")
+                        2 (quotes doc)
+
+tcATDefault :: SrcSpan
+            -> TCvSubst
+            -> NameSet
+            -> ClassATItem
+            -> TcM [FamInst]
+-- ^ Construct default instances for any associated types that
+-- aren't given a user definition
+-- Returns [] or singleton
+tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
+  -- User supplied instances ==> everything is OK
+  | tyConName fam_tc `elemNameSet` defined_ats
+  = return []
+
+  -- No user instance, have defaults ==> instantiate them
+   -- Example:   class C a where { type F a b :: *; type F a b = () }
+   --            instance C [x]
+   -- Then we want to generate the decl:   type F [x] b = ()
+  | Just (rhs_ty, _loc) <- defs
+  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
+                                            (tyConTyVars fam_tc)
+             rhs'     = substTyUnchecked subst' rhs_ty
+             tcv' = tyCoVarsOfTypesList pat_tys'
+             (tv', cv') = partition isTyVar tcv'
+             tvs'     = scopedSort tv'
+             cvs'     = scopedSort cv'
+       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
+       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
+                                     fam_tc pat_tys' rhs'
+           -- NB: no validity check. We check validity of default instances
+           -- in the class definition. Because type instance arguments cannot
+           -- be type family applications and cannot be polytypes, the
+           -- validity check is redundant.
+
+       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
+                                              , pprCoAxiom axiom ])
+       ; fam_inst <- newFamInst SynFamilyInst axiom
+       ; return [fam_inst] }
+
+   -- No defaults ==> generate a warning
+  | otherwise  -- defs = Nothing
+  = do { warnMissingAT (tyConName fam_tc)
+       ; return [] }
+  where
+    subst_tv subst tc_tv
+      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
+      = (subst, ty)
+      | otherwise
+      = (extendTvSubst subst tc_tv ty', ty')
+      where
+        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
+
+warnMissingAT :: Name -> TcM ()
+warnMissingAT name
+  = do { warn <- woptM Opt_WarnMissingMethods
+       ; traceTc "warn" (ppr name <+> ppr warn)
+       ; hsc_src <- fmap tcg_src getGblEnv
+       -- Warn only if -Wmissing-methods AND not a signature
+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)
+                (text "No explicit" <+> text "associated type"
+                    <+> text "or default declaration for"
+                    <+> quotes (ppr name)) }
diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDefaults.hs
@@ -0,0 +1,110 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[TcDefaults]{Typechecking \tr{default} declarations}
+-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcDefaults ( tcDefaults ) where
+
+import GhcPrelude
+
+import HsSyn
+import Class
+import TcRnMonad
+import TcEnv
+import TcHsType
+import TcHsSyn
+import TcSimplify
+import TcValidity
+import TcType
+import PrelNames
+import SrcLoc
+import Outputable
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+tcDefaults :: [LDefaultDecl GhcRn]
+           -> TcM (Maybe [Type])    -- Defaulting types to heave
+                                    -- into Tc monad for later use
+                                    -- in Disambig.
+
+tcDefaults []
+  = getDeclaredDefaultTys       -- No default declaration, so get the
+                                -- default types from the envt;
+                                -- i.e. use the current ones
+                                -- (the caller will put them back there)
+        -- It's important not to return defaultDefaultTys here (which
+        -- we used to do) because in a TH program, tcDefaults [] is called
+        -- repeatedly, once for each group of declarations between top-level
+        -- splices.  We don't want to carefully set the default types in
+        -- one group, only for the next group to ignore them and install
+        -- defaultDefaultTys
+
+tcDefaults [L _ (DefaultDecl _ [])]
+  = return (Just [])            -- Default declaration specifying no types
+
+tcDefaults [L locn (DefaultDecl _ mono_tys)]
+  = setSrcSpan locn                     $
+    addErrCtxt defaultDeclCtxt          $
+    do  { ovl_str   <- xoptM LangExt.OverloadedStrings
+        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
+        ; num_class    <- tcLookupClass numClassName
+        ; deflt_str <- if ovl_str
+                       then mapM tcLookupClass [isStringClassName]
+                       else return []
+        ; deflt_interactive <- if ext_deflt
+                               then mapM tcLookupClass interactiveClassNames
+                               else return []
+        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
+
+        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
+
+        ; return (Just tau_tys) }
+
+tcDefaults decls@(L locn (DefaultDecl _ _) : _)
+  = setSrcSpan locn $
+    failWithTc (dupDefaultDeclErr decls)
+tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"
+
+
+tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
+tc_default_ty deflt_clss hs_ty
+ = do   { (ty, _kind) <- solveEqualities $
+                         tcLHsType hs_ty
+        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
+        ; checkValidType DefaultDeclCtxt ty
+
+        -- Check that the type is an instance of at least one of the deflt_clss
+        ; oks <- mapM (check_instance ty) deflt_clss
+        ; checkTc (or oks) (badDefaultTy ty deflt_clss)
+        ; return ty }
+
+check_instance :: Type -> Class -> TcM Bool
+  -- Check that ty is an instance of cls
+  -- We only care about whether it worked or not; return a boolean
+check_instance ty cls
+  = do  { (_, success) <- discardErrs $
+                          askNoErrs $
+                          simplifyDefault [mkClassPred cls [ty]]
+        ; return success }
+
+defaultDeclCtxt :: SDoc
+defaultDeclCtxt = text "When checking the types in a default declaration"
+
+dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
+dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
+  = hang (text "Multiple default declarations")
+       2 (vcat (map pp dup_things))
+  where
+    pp (L locn (DefaultDecl _ _))
+      = text "here was another default declaration" <+> ppr locn
+    pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"
+dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"
+dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
+
+badDefaultTy :: Type -> [Class] -> SDoc
+badDefaultTy ty deflt_clss
+  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
+       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDeriv.hs
@@ -0,0 +1,2244 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Handles @deriving@ clauses on @data@ declarations.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import DynFlags
+
+import TcRnMonad
+import FamInst
+import TcDerivInfer
+import TcDerivUtils
+import TcValidity( allDistinctTyVars )
+import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
+import TcEnv
+import TcGenDeriv                       -- Deriv stuff
+import TcValidity( checkValidInstHead )
+import InstEnv
+import Inst
+import FamInstEnv
+import TcHsType
+import TyCoRep
+
+import RnNames( extendGlobalRdrEnvRn )
+import RnBinds
+import RnEnv
+import RnUtils    ( bindLocalNamesFV )
+import RnSource   ( addTcgDUs )
+import Avail
+
+import Unify( tcUnifyTy )
+import Class
+import Type
+import ErrUtils
+import DataCon
+import Maybes
+import RdrName
+import Name
+import NameSet
+import TyCon
+import TcType
+import Var
+import VarEnv
+import VarSet
+import PrelNames
+import SrcLoc
+import Util
+import Outputable
+import FastString
+import Bag
+import Pair
+import FV (fvVarList, unionFV, mkFVs)
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
+import Data.List
+
+{-
+************************************************************************
+*                                                                      *
+                Overview
+*                                                                      *
+************************************************************************
+
+Overall plan
+~~~~~~~~~~~~
+1.  Convert the decls (i.e. data/newtype deriving clauses,
+    plus standalone deriving) to [EarlyDerivSpec]
+
+2.  Infer the missing contexts for the InferTheta's
+
+3.  Add the derived bindings, generating InstInfos
+-}
+
+data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
+                    | GivenTheta (DerivSpec ThetaType)
+        -- InferTheta ds => the context for the instance should be inferred
+        --      In this case ds_theta is the list of all the sets of
+        --      constraints needed, such as (Eq [a], Eq a), together with a
+        --      suitable CtLoc to get good error messages.
+        --      The inference process is to reduce this to a
+        --      simpler form (e.g. Eq a)
+        --
+        -- GivenTheta ds => the exact context for the instance is supplied
+        --                  by the programmer; it is ds_theta
+        -- See Note [Inferring the instance context] in TcDerivInfer
+
+earlyDSLoc :: EarlyDerivSpec -> SrcSpan
+earlyDSLoc (InferTheta spec) = ds_loc spec
+earlyDSLoc (GivenTheta spec) = ds_loc spec
+
+splitEarlyDerivSpec :: [EarlyDerivSpec]
+                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
+splitEarlyDerivSpec [] = ([],[])
+splitEarlyDerivSpec (InferTheta spec : specs) =
+    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
+splitEarlyDerivSpec (GivenTheta spec : specs) =
+    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
+
+instance Outputable EarlyDerivSpec where
+  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
+  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
+
+{-
+Note [Data decl contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
+
+We will need an instance decl like:
+
+        instance (Read a, RealFloat a) => Read (Complex a) where
+          ...
+
+The RealFloat in the context is because the read method for Complex is bound
+to construct a Complex, and doing that requires that the argument type is
+in RealFloat.
+
+But this ain't true for Show, Eq, Ord, etc, since they don't construct
+a Complex; they only take them apart.
+
+Our approach: identify the offending classes, and add the data type
+context to the instance decl.  The "offending classes" are
+
+        Read, Enum?
+
+FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
+pattern matching against a constructor from a data type with a context
+gives rise to the constraints for that context -- or at least the thinned
+version.  So now all classes are "offending".
+
+Note [Newtype deriving]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+    class C a b
+    instance C [a] Char
+    newtype T = T Char deriving( C [a] )
+
+Notice the free 'a' in the deriving.  We have to fill this out to
+    newtype T = T Char deriving( forall a. C [a] )
+
+And then translate it to:
+    instance C [a] Char => C [a] T where ...
+
+
+Note [Newtype deriving superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(See also #1220 for an interesting exchange on newtype
+deriving and superclasses.)
+
+The 'tys' here come from the partial application in the deriving
+clause. The last arg is the new instance type.
+
+We must pass the superclasses; the newtype might be an instance
+of them in a different way than the representation type
+E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
+Then the Show instance is not done via Coercible; it shows
+        Foo 3 as "Foo 3"
+The Num instance is derived via Coercible, but the Show superclass
+dictionary must the Show instance for Foo, *not* the Show dictionary
+gotten from the Num dictionary. So we must build a whole new dictionary
+not just use the Num one.  The instance we want is something like:
+     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
+        (+) = ((+)@a)
+        ...etc...
+There may be a coercion needed which we get from the tycon for the newtype
+when the dict is constructed in TcInstDcls.tcInstDecl2
+
+
+Note [Unused constructors and deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #3221.  Consider
+   data T = T1 | T2 deriving( Show )
+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
+both of them.  So we gather defs/uses from deriving just like anything else.
+
+-}
+
+-- | Stuff needed to process a datatype's `deriving` clauses
+data DerivInfo = DerivInfo { di_rep_tc  :: TyCon
+                             -- ^ The data tycon for normal datatypes,
+                             -- or the *representation* tycon for data families
+                           , di_clauses :: [LHsDerivingClause GhcRn]
+                           , di_ctxt    :: SDoc -- ^ error context
+                           }
+
+-- | Extract `deriving` clauses of proper data type (skips data families)
+mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
+mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
+  where
+
+    mk_deriv decl@(DataDecl { tcdLName = L _ data_name
+                            , tcdDataDefn =
+                                HsDataDefn { dd_derivs = L _ clauses } })
+      = do { tycon <- tcLookupTyCon data_name
+           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses
+                               , di_ctxt = tcMkDeclCtxt decl }] }
+    mk_deriv _ = return []
+
+{-
+
+************************************************************************
+*                                                                      *
+\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
+*                                                                      *
+************************************************************************
+-}
+
+tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
+            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
+            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
+tcDeriving deriv_infos deriv_decls
+  = recoverM (do { g <- getGblEnv
+                 ; return (g, emptyBag, emptyValBindsOut)}) $
+    do  {       -- Fish the "deriving"-related information out of the TcEnv
+                -- And make the necessary "equations".
+          is_boot <- tcIsHsBootOrSig
+        ; traceTc "tcDeriving" (ppr is_boot)
+
+        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
+        ; traceTc "tcDeriving 1" (ppr early_specs)
+
+        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
+        ; insts1 <- mapM genInst given_specs
+        ; insts2 <- mapM genInst infer_specs
+
+        ; dflags <- getDynFlags
+
+        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
+        ; loc <- getSrcSpanM
+        ; let (binds, famInsts) = genAuxBinds dflags loc
+                                    (unionManyBags deriv_stuff)
+
+        ; let mk_inst_infos1 = map fstOf3 insts1
+        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs
+
+          -- We must put all the derived type family instances (from both
+          -- infer_specs and given_specs) in the local instance environment
+          -- before proceeding, or else simplifyInstanceContexts might
+          -- get stuck if it has to reason about any of those family instances.
+          -- See Note [Staging of tcDeriving]
+        ; tcExtendLocalFamInstEnv (bagToList famInsts) $
+          -- NB: only call tcExtendLocalFamInstEnv once, as it performs
+          -- validity checking for all of the family instances you give it.
+          -- If the family instances have errors, calling it twice will result
+          -- in duplicate error messages!
+
+     do {
+        -- the stand-alone derived instances (@inst_infos1@) are used when
+        -- inferring the contexts for "deriving" clauses' instances
+        -- (@infer_specs@)
+        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $
+                         simplifyInstanceContexts infer_specs
+
+        ; let mk_inst_infos2 = map fstOf3 insts2
+        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs
+        ; let inst_infos = inst_infos1 ++ inst_infos2
+
+        ; (inst_info, rn_binds, rn_dus) <-
+            renameDeriv is_boot inst_infos binds
+
+        ; unless (isEmptyBag inst_info) $
+             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                        (ddump_deriving inst_info rn_binds famInsts))
+
+        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
+                                          getGblEnv
+        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
+  where
+    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
+                   -> Bag FamInst             -- ^ Rep type family instances
+                   -> SDoc
+    ddump_deriving inst_infos extra_binds repFamInsts
+      =    hang (text "Derived class instances:")
+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
+                 $$ ppr extra_binds)
+        $$ hangP "Derived type family instances:"
+             (vcat (map pprRepTy (bagToList repFamInsts)))
+
+    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
+
+    -- Apply the suspended computations given by genInst calls.
+    -- See Note [Staging of tcDeriving]
+    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
+                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
+    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))
+
+-- Prints the representable type family instance
+pprRepTy :: FamInst -> SDoc
+pprRepTy fi@(FamInst { fi_tys = lhs })
+  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
+      equals <+> ppr rhs
+  where rhs = famInstRHS fi
+
+renameDeriv :: Bool
+            -> [InstInfo GhcPs]
+            -> Bag (LHsBind GhcPs, LSig GhcPs)
+            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
+renameDeriv is_boot inst_infos bagBinds
+  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
+                -- The inst-info bindings will all be empty, but it's easier to
+                -- just use rn_inst_info to change the type appropriately
+  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
+        ; return ( listToBag rn_inst_infos
+                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
+
+  | otherwise
+  = discardWarnings $
+    -- Discard warnings about unused bindings etc
+    setXOptM LangExt.EmptyCase $
+    -- Derived decls (for empty types) can have
+    --    case x of {}
+    setXOptM LangExt.ScopedTypeVariables $
+    setXOptM LangExt.KindSignatures $
+    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
+    -- KindSignatures
+    setXOptM LangExt.TypeApplications $
+    -- GND/DerivingVia uses TypeApplications in generated code
+    -- (See Note [Newtype-deriving instances] in TcGenDeriv)
+    unsetXOptM LangExt.RebindableSyntax $
+    -- See Note [Avoid RebindableSyntax when deriving]
+    setXOptM LangExt.TemplateHaskellQuotes $
+    -- DeriveLift makes uses of quotes
+    do  {
+        -- Bring the extra deriving stuff into scope
+        -- before renaming the instances themselves
+        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
+        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
+        ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)
+        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
+        ; let bndrs = collectHsValBinders rn_aux_lhs
+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
+        ; setEnvs envs $
+    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
+        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
+        ; return (listToBag rn_inst_infos, rn_aux,
+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
+
+  where
+    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
+    rn_inst_info
+      inst_info@(InstInfo { iSpec = inst
+                          , iBinds = InstBindings
+                            { ib_binds = binds
+                            , ib_tyvars = tyvars
+                            , ib_pragmas = sigs
+                            , ib_extensions = exts -- Only for type-checking
+                            , ib_derived = sa } })
+        =  ASSERT( null sigs )
+           bindLocalNamesFV tyvars $
+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
+              ; let binds' = InstBindings { ib_binds = rn_binds
+                                          , ib_tyvars = tyvars
+                                          , ib_pragmas = []
+                                          , ib_extensions = exts
+                                          , ib_derived = sa }
+              ; return (inst_info { iBinds = binds' }, fvs) }
+
+{-
+Note [Newtype deriving and unused constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (see #1954):
+
+  module Bug(P) where
+  newtype P a = MkP (IO a) deriving Monad
+
+If you compile with -Wunused-binds you do not expect the warning
+"Defined but not used: data constructor MkP". Yet the newtype deriving
+code does not explicitly mention MkP, but it should behave as if you
+had written
+  instance Monad P where
+     return x = MkP (return x)
+     ...etc...
+
+So we want to signal a user of the data constructor 'MkP'.
+This is the reason behind the [Name] part of the return type
+of genInst.
+
+Note [Staging of tcDeriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's a tricky corner case for deriving (adapted from #2721):
+
+    class C a where
+      type T a
+      foo :: a -> T a
+
+    instance C Int where
+      type T Int = Int
+      foo = id
+
+    newtype N = N Int deriving C
+
+This will produce an instance something like this:
+
+    instance C N where
+      type T N = T Int
+      foo = coerce (foo :: Int -> T Int) :: N -> T N
+
+We must be careful in order to typecheck this code. When determining the
+context for the instance (in simplifyInstanceContexts), we need to determine
+that T N and T Int have the same representation, but to do that, the T N
+instance must be in the local family instance environment. Otherwise, GHC
+would be unable to conclude that T Int is representationally equivalent to
+T Int, and simplifyInstanceContexts would get stuck.
+
+Previously, tcDeriving would defer adding any derived type family instances to
+the instance environment until the very end, which meant that
+simplifyInstanceContexts would get called without all the type family instances
+it needed in the environment in order to properly simplify instance like
+the C N instance above.
+
+To avoid this scenario, we carefully structure the order of events in
+tcDeriving. We first call genInst on the standalone derived instance specs and
+the instance specs obtained from deriving clauses. Note that the return type of
+genInst is a triple:
+
+    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)
+
+The type family instances are in the BagDerivStuff. The first field of the
+triple is a suspended computation which, given an instance context, produces
+the rest of the instance. The fact that it is suspended is important, because
+right now, we don't have ThetaTypes for the instances that use deriving clauses
+(only the standalone-derived ones).
+
+Now we can can collect the type family instances and extend the local instance
+environment. At this point, it is safe to run simplifyInstanceContexts on the
+deriving-clause instance specs, which gives us the ThetaTypes for the
+deriving-clause instances. Now we can feed all the ThetaTypes to the
+suspended computations and obtain our InstInfos, at which point
+tcDeriving is done.
+
+An alternative design would be to split up genInst so that the
+family instances are generated separately from the InstInfos. But this would
+require carving up a lot of the GHC deriving internals to accommodate the
+change. On the other hand, we can keep all of the InstInfo and type family
+instance logic together in genInst simply by converting genInst to
+continuation-returning style, so we opt for that route.
+
+Note [Why we don't pass rep_tc into deriveTyData]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
+the rep_tc by means of a lookup. And yet we have the rep_tc right here!
+Why look it up again? Answer: it's just easier this way.
+We drop some number of arguments from the end of the datatype definition
+in deriveTyData. The arguments are dropped from the fam_tc.
+This action may drop a *different* number of arguments
+passed to the rep_tc, depending on how many free variables, etc., the
+dropped patterns have.
+
+Also, this technique carries over the kind substitution from deriveTyData
+nicely.
+
+Note [Avoid RebindableSyntax when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RebindableSyntax extension interacts awkwardly with the derivation of
+any stock class whose methods require the use of string literals. The Show
+class is a simple example (see #12688):
+
+  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
+  newtype Text = Text String
+  fromString :: String -> Text
+  fromString = Text
+
+  data Foo = Foo deriving Show
+
+This will generate code to the effect of:
+
+  instance Show Foo where
+    showsPrec _ Foo = showString "Foo"
+
+But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
+string literal is now of type Text, not String, which showString doesn't
+accept! This causes the generated Show instance to fail to typecheck.
+
+To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
+in derived code.
+
+************************************************************************
+*                                                                      *
+                From HsSyn to DerivSpec
+*                                                                      *
+************************************************************************
+
+@makeDerivSpecs@ fishes around to find the info about needed derived instances.
+-}
+
+makeDerivSpecs :: Bool
+               -> [DerivInfo]
+               -> [LDerivDecl GhcRn]
+               -> TcM [EarlyDerivSpec]
+makeDerivSpecs is_boot deriv_infos deriv_decls
+  = do  { -- We carefully set up uses of recoverM to minimize error message
+          -- cascades. See Note [Flattening deriving clauses].
+        ; eqns1 <- sequenceA
+                     [ recoverM (pure Nothing)
+                                (deriveClause rep_tc (fmap unLoc dcs)
+                                                      pred err_ctxt)
+                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
+                                 , di_ctxt = err_ctxt } <- deriv_infos
+                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs
+                                             , deriv_clause_tys = L _ preds })
+                         <- clauses
+                     , pred <- preds
+                     ]
+        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
+        ; let eqns = catMaybes (eqns1 ++ eqns2)
+
+        ; if is_boot then   -- No 'deriving' at all in hs-boot files
+              do { unless (null eqns) (add_deriv_err (head eqns))
+                 ; return [] }
+          else return eqns }
+  where
+    add_deriv_err eqn
+       = setSrcSpan (earlyDSLoc eqn) $
+         addErr (hang (text "Deriving not permitted in hs-boot file")
+                    2 (text "Use an instance declaration instead"))
+
+{-
+Note [Flattening deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider what happens if you run this program (from #10684) without
+DeriveGeneric enabled:
+
+    data A = A deriving (Show, Generic)
+    data B = B A deriving (Show)
+
+Naturally, you'd expect GHC to give an error to the effect of:
+
+    Can't make a derived instance of `Generic A':
+      You need -XDeriveGeneric to derive an instance for this class
+
+And *only* that error, since the other two derived Show instances appear to be
+independent of this derived Generic instance. Yet GHC also used to give this
+additional error on the program above:
+
+    No instance for (Show A)
+      arising from the 'deriving' clause of a data type declaration
+    When deriving the instance for (Show B)
+
+This was happening because when GHC encountered any error within a single
+data type's set of deriving clauses, it would call recoverM and move on
+to the next data type's deriving clauses. One unfortunate consequence of
+this design is that if A's derived Generic instance failed, so its derived
+Show instance would be skipped entirely, leading to the "No instance for
+(Show A)" error cascade.
+
+The solution to this problem is to "flatten" the set of classes that are
+derived for a particular data type via deriving clauses. That is, if
+you have:
+
+    newtype C = C D
+      deriving (E, F, G)
+      deriving anyclass (H, I, J)
+      deriving newtype  (K, L, M)
+
+Then instead of processing instances E through M under the scope of a single
+recoverM, we flatten these deriving clauses into the list:
+
+    [ E (Nothing)
+    , F (Nothing)
+    , G (Nothing)
+    , H (Just anyclass)
+    , I (Just anyclass)
+    , J (Just anyclass)
+    , K (Just newtype)
+    , L (Just newtype)
+    , M (Just newtype) ]
+
+And then process each class individually, under its own recoverM scope. That
+way, failure to derive one class doesn't cancel out other classes in the
+same set of clause-derived classes.
+-}
+
+------------------------------------------------------------------
+-- | Process a single class in a `deriving` clause.
+deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)
+             -> LHsSigType GhcRn -> SDoc
+             -> TcM (Maybe EarlyDerivSpec)
+deriveClause rep_tc mb_strat pred err_ctxt
+  = addErrCtxt err_ctxt $
+    deriveTyData tvs tc tys mb_strat pred
+  where
+    tvs = tyConTyVars rep_tc
+    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
+                        -- data family:
+                  Just (fam_tc, pats, _) -> (fam_tc, pats)
+      -- NB: deriveTyData wants the *user-specified*
+      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
+
+                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
+
+------------------------------------------------------------------
+deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
+-- Process a single standalone deriving declaration
+--  e.g.   deriving instance Show a => Show (T a)
+-- Rather like tcLocalInstDecl
+--
+-- This returns a Maybe because the user might try to derive Typeable, which is
+-- a no-op nowadays.
+deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
+  = setSrcSpan loc                   $
+    addErrCtxt (standaloneCtxt deriv_ty)  $
+    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
+       ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat
+             ctxt           = TcType.InstDeclCtxt True
+       ; traceTc "Deriving strategy (standalone deriving)" $
+           vcat [ppr mb_deriv_strat, ppr deriv_ty]
+       ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))
+           <- tcDerivStrategy mb_deriv_strat $ do
+                (tvs, deriv_ctxt, cls, inst_tys)
+                  <- tcStandaloneDerivInstType ctxt deriv_ty
+                pure (tvs, (deriv_ctxt, cls, inst_tys))
+       ; checkTc (not (null inst_tys')) derivingNullaryErr
+       ; let inst_ty' = last inst_tys'
+         -- See Note [Unify kinds in deriving]
+       ; (tvs, deriv_ctxt, inst_tys) <-
+           case mb_deriv_strat' of
+             -- Perform an additional unification with the kind of the `via`
+             -- type and the result of the previous kind unification.
+             Just (ViaStrategy via_ty) -> do
+               let via_kind     = tcTypeKind via_ty
+                   inst_ty_kind = tcTypeKind inst_ty'
+                   mb_match     = tcUnifyTy inst_ty_kind via_kind
+
+               checkTc (isJust mb_match)
+                       (derivingViaKindErr cls inst_ty_kind
+                                           via_ty via_kind)
+
+               let Just kind_subst = mb_match
+                   ki_subst_range  = getTCvSubstRangeFVs kind_subst
+                   -- See Note [Unification of two kind variables in deriving]
+                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
+                                        && not (v `elemVarSet` ki_subst_range))
+                                          tvs'
+                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
+                   (final_deriv_ctxt, final_deriv_ctxt_tys)
+                     = case deriv_ctxt' of
+                         InferContext wc -> (InferContext wc, [])
+                         SupplyContext theta ->
+                           let final_theta = substTheta subst theta
+                           in (SupplyContext final_theta, final_theta)
+                   final_inst_tys   = substTys subst inst_tys'
+                   final_tvs        = tyCoVarsOfTypesWellScoped $
+                                      final_deriv_ctxt_tys ++ final_inst_tys
+               pure (final_tvs, final_deriv_ctxt, final_inst_tys)
+
+             _ -> pure (tvs', deriv_ctxt', inst_tys')
+       ; let cls_tys = take (length inst_tys - 1) inst_tys
+             inst_ty = last inst_tys
+       ; traceTc "Standalone deriving;" $ vcat
+              [ text "tvs:" <+> ppr tvs
+              , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'
+              , text "deriv_ctxt:" <+> ppr deriv_ctxt
+              , text "cls:" <+> ppr cls
+              , text "tys:" <+> ppr inst_tys ]
+                -- C.f. TcInstDcls.tcLocalInstDecl1
+       ; traceTc "Standalone deriving:" $ vcat
+              [ text "class:" <+> ppr cls
+              , text "class types:" <+> ppr cls_tys
+              , text "type:" <+> ppr inst_ty ]
+
+       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                              inst_ty mb_deriv_strat' msg)
+
+       ; case tcSplitTyConApp_maybe inst_ty of
+           Just (tc, tc_args)
+              | className cls == typeableClassName
+              -> do warnUselessTypeable
+                    return Nothing
+
+              | otherwise
+              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
+                                    tvs cls cls_tys tc tc_args
+                                    deriv_ctxt mb_deriv_strat'
+
+           _  -> -- Complain about functions, primitive types, etc,
+                 bale_out $
+                 text "The last argument of the instance must be a data or newtype application"
+        }
+deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"
+
+-- Typecheck the type in a standalone deriving declaration.
+--
+-- This may appear dense, but it's mostly huffing and puffing to recognize
+-- the special case of a type with an extra-constraints wildcard context, e.g.,
+--
+--   deriving instance _ => Eq (Foo a)
+--
+-- If there is such a wildcard, we typecheck this as if we had written
+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
+-- as the 'DerivContext', where loc is the location of the wildcard used for
+-- error reporting. This indicates that we should infer the context as if we
+-- were deriving Eq via a deriving clause
+-- (see Note [Inferring the instance context] in TcDerivInfer).
+--
+-- If there is no wildcard, then proceed as normal, and instead return
+-- @'SupplyContext' theta@, where theta is the typechecked context.
+--
+-- Note that this will never return @'InferContext' 'Nothing'@, as that can
+-- only happen with @deriving@ clauses.
+tcStandaloneDerivInstType
+  :: UserTypeCtxt -> LHsSigWcType GhcRn
+  -> TcM ([TyVar], DerivContext, Class, [Type])
+tcStandaloneDerivInstType ctxt
+    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
+                                       , hsib_body   = deriv_ty_body })})
+  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
+  , L _ [wc_pred] <- theta
+  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
+  = do dfun_ty <- tcHsClsInstType ctxt $
+                  HsIB { hsib_ext = vars
+                       , hsib_body
+                           = L (getLoc deriv_ty_body) $
+                             HsForAllTy { hst_fvf = ForallInvis
+                                        , hst_bndrs = tvs
+                                        , hst_xforall = noExt
+                                        , hst_body  = rho }}
+       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
+       pure (tvs, InferContext (Just wc_span), cls, inst_tys)
+  | otherwise
+  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty
+       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
+       pure (tvs, SupplyContext theta, cls, inst_tys)
+
+tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
+  = panic "tcStandaloneDerivInstType"
+tcStandaloneDerivInstType _ (XHsWildCardBndrs _)
+  = panic "tcStandaloneDerivInstType"
+
+warnUselessTypeable :: TcM ()
+warnUselessTypeable
+  = do { warn <- woptM Opt_WarnDerivingTypeable
+       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
+                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
+                     text "has no effect: all types now auto-derive Typeable" }
+
+------------------------------------------------------------------
+deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
+                    -- Can be a data instance, hence [Type] args
+                    -- and in that case the TyCon is the /family/ tycon
+             -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy
+             -> LHsSigType GhcRn             -- The deriving predicate
+             -> TcM (Maybe EarlyDerivSpec)
+-- The deriving clause of a data or newtype declaration
+-- I.e. not standalone deriving
+--
+-- This returns a Maybe because the user might try to derive Typeable, which is
+-- a no-op nowadays.
+deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $
+    -- Use loc of the 'deriving' item
+    do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))
+                <- tcExtendTyVarEnv tvs $
+                -- Deriving preds may (now) mention
+                -- the type variables for the type constructor, hence tcExtendTyVarenv
+                -- The "deriv_pred" is a LHsType to take account of the fact that for
+                -- newtype deriving we allow deriving (forall a. C [a]).
+
+                -- Typeable is special, because Typeable :: forall k. k -> Constraint
+                -- so the argument kind 'k' is not decomposable by splitKindFunTys
+                -- as is the case for all other derivable type classes
+                     tcDerivStrategy mb_deriv_strat $
+                     tcHsDeriv deriv_pred
+
+        ; when (cls_arg_kinds `lengthIsNot` 1) $
+            failWithTc (nonUnaryErr deriv_pred)
+        ; let [cls_arg_kind] = cls_arg_kinds
+        ; if className cls == typeableClassName
+          then do warnUselessTypeable
+                  return Nothing
+          else
+
+     do {  -- Given data T a b c = ... deriving( C d ),
+           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
+          let (arg_kinds, _)  = splitFunTys cls_arg_kind
+              n_args_to_drop  = length arg_kinds
+              n_args_to_keep  = length tc_args - n_args_to_drop
+                                -- See Note [tc_args and tycon arity]
+              (tc_args_to_keep, args_to_drop)
+                              = splitAt n_args_to_keep tc_args
+              inst_ty_kind    = tcTypeKind (mkTyConApp tc tc_args_to_keep)
+
+              -- Match up the kinds, and apply the resulting kind substitution
+              -- to the types.  See Note [Unify kinds in deriving]
+              -- We are assuming the tycon tyvars and the class tyvars are distinct
+              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind
+              enough_args     = n_args_to_keep >= 0
+
+        -- Check that the result really is well-kinded
+        ; checkTc (enough_args && isJust mb_match)
+                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)
+
+        ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'
+                = (final_tkvs, final_cls_tys, final_tc_args)
+                where
+                  ki_subst_range  = getTCvSubstRangeFVs kind_subst
+                  -- See Note [Unification of two kind variables in deriving]
+                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
+                                         && not (v `elemVarSet` ki_subst_range))
+                                           tkvs'
+                  (subst, _)      = substTyVarBndrs kind_subst unmapped_tkvs
+                  final_tc_args   = substTys subst tc_args'
+                  final_cls_tys   = substTys subst cls_tys'
+                  final_tkvs      = tyCoVarsOfTypesWellScoped $
+                                    final_cls_tys ++ final_tc_args
+
+        ; let tkvs = scopedSort $ fvVarList $
+                     unionFV (tyCoFVsOfTypes tc_args_to_keep)
+                             (FV.mkFVs deriv_tvs)
+              Just kind_subst = mb_match
+              (tkvs', final_cls_tys', final_tc_args')
+                = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep
+
+          -- See Note [Unify kinds in deriving]
+        ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-
+            case mb_deriv_strat' of
+              -- Perform an additional unification with the kind of the `via`
+              -- type and the result of the previous kind unification.
+              Just (ViaStrategy via_ty) -> do
+                let final_via_ty   = via_ty
+                    final_via_kind = tcTypeKind final_via_ty
+                    final_inst_ty_kind
+                              = tcTypeKind (mkTyConApp tc final_tc_args')
+                    via_match = tcUnifyTy final_inst_ty_kind final_via_kind
+
+                checkTc (isJust via_match)
+                        (derivingViaKindErr cls final_inst_ty_kind
+                                            final_via_ty final_via_kind)
+
+                let Just via_subst = via_match
+                    (final_tkvs, final_cls_tys, final_tc_args)
+                      = propagate_subst via_subst tkvs'
+                                        final_cls_tys' final_tc_args'
+                pure ( final_tkvs, final_cls_tys, final_tc_args
+                     , Just $ ViaStrategy $ substTy via_subst via_ty
+                     )
+
+              _ -> pure ( tkvs', final_cls_tys', final_tc_args'
+                        , mb_deriv_strat' )
+
+        ; traceTc "Deriving strategy (deriving clause)" $
+            vcat [ppr final_mb_deriv_strat, ppr deriv_pred]
+
+        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args
+                                       , ppr deriv_pred
+                                       , pprTyVars (tyCoVarsOfTypesList tc_args)
+                                       , ppr n_args_to_keep, ppr n_args_to_drop
+                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
+                                       , ppr final_tc_args, ppr final_cls_tys ])
+
+        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
+
+        ; let final_tc_app = mkTyConApp tc final_tc_args
+        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
+                  (derivingEtaErr cls final_cls_tys final_tc_app)
+                -- Check that
+                --  (a) The args to drop are all type variables; eg reject:
+                --              data instance T a Int = .... deriving( Monad )
+                --  (b) The args to drop are all *distinct* type variables; eg reject:
+                --              class C (a :: * -> * -> *) where ...
+                --              data instance T a a = ... deriving( C )
+                --  (c) The type class args, or remaining tycon args,
+                --      do not mention any of the dropped type variables
+                --              newtype T a s = ... deriving( ST s )
+                --              newtype instance K a a = ... deriving( Monad )
+                --
+                -- It is vital that the implementation of allDistinctTyVars
+                -- expand any type synonyms.
+                -- See Note [Eta-reducing type synonyms]
+
+        ; checkValidInstHead DerivClauseCtxt cls $
+                             final_cls_tys ++ [final_tc_app]
+                -- Check that we aren't deriving an instance of a magical
+                -- type like (~) or Coercible (#14916).
+
+        ; spec <- mkEqnHelp Nothing tkvs
+                            cls final_cls_tys tc final_tc_args
+                            (InferContext Nothing) final_mb_deriv_strat
+        ; traceTc "derivTyData" (ppr spec)
+        ; return $ Just spec } }
+
+
+{- Note [tc_args and tycon arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might wonder if we could use (tyConArity tc) at this point, rather
+than (length tc_args).  But for data families the two can differ!  The
+tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which
+in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them
+from DataFamInstTyCon:
+
+| DataFamInstTyCon          -- See Note [Data type families]
+      (CoAxiom Unbranched)
+      TyCon   -- The family TyCon
+      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
+              -- No shorter in length than the tyConTyVars of the family TyCon
+              -- How could it be longer? See [Arity of data families] in FamInstEnv
+
+Notice that the arg tys might not be the same as the family tycon arity
+(= length tyConTyVars).
+
+Note [Unify kinds in deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#8534)
+    data T a b = MkT a deriving( Functor )
+    -- where Functor :: (*->*) -> Constraint
+
+So T :: forall k. * -> k -> *.   We want to get
+    instance Functor (T * (a:*)) where ...
+Notice the '*' argument to T.
+
+Moreover, as well as instantiating T's kind arguments, we may need to instantiate
+C's kind args.  Consider (#8865):
+  newtype T a b = MkT (Either a b) deriving( Category )
+where
+  Category :: forall k. (k -> k -> *) -> Constraint
+We need to generate the instance
+  instance Category * (Either a) where ...
+Notice the '*' argument to Category.
+
+So we need to
+ * drop arguments from (T a b) to match the number of
+   arrows in the (last argument of the) class;
+ * and then *unify* kind of the remaining type against the
+   expected kind, to figure out how to instantiate C's and T's
+   kind arguments.
+
+In the two examples,
+ * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )
+         i.e.      (k -> *) ~ (* -> *)   to find k:=*.
+         yielding  k:=*
+
+ * we unify   kind-of( Either ) ~ kind-of( Category )
+         i.e.      (* -> * -> *)  ~ (k -> k -> k)
+         yielding  k:=*
+
+Now we get a kind substitution.  We then need to:
+
+  1. Remove the substituted-out kind variables from the quantified kind vars
+
+  2. Apply the substitution to the kinds of quantified *type* vars
+     (and extend the substitution to reflect this change)
+
+  3. Apply that extended substitution to the non-dropped args (types and
+     kinds) of the type and class
+
+Forgetting step (2) caused #8893:
+  data V a = V [a] deriving Functor
+  data P (x::k->*) (a:k) = P (x a) deriving Functor
+  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor
+
+When deriving Functor for P, we unify k to *, but we then want
+an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
+and similarly for C.  Notice the modified kind of x, both at binding
+and occurrence sites.
+
+This can lead to some surprising results when *visible* kind binder is
+unified (in contrast to the above examples, in which only non-visible kind
+binders were considered). Consider this example from #11732:
+
+    data T k (a :: k) = MkT deriving Functor
+
+Since unification yields k:=*, this results in a generated instance of:
+
+    instance Functor (T *) where ...
+
+which looks odd at first glance, since one might expect the instance head
+to be of the form Functor (T k). Indeed, one could envision an alternative
+generated instance of:
+
+    instance (k ~ *) => Functor (T k) where
+
+But this does not typecheck by design: kind equalities are not allowed to be
+bound in types, only terms. But in essence, the two instance declarations are
+entirely equivalent, since even though (T k) matches any kind k, the only
+possibly value for k is *, since anything else is ill-typed. As a result, we can
+just as comfortably use (T *).
+
+Another way of thinking about is: deriving clauses often infer constraints.
+For example:
+
+    data S a = S a deriving Eq
+
+infers an (Eq a) constraint in the derived instance. By analogy, when we
+are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
+The only distinction is that GHC instantiates equality constraints directly
+during the deriving process.
+
+Another quirk of this design choice manifests when typeclasses have visible
+kind parameters. Consider this code (also from #11732):
+
+    class Cat k (cat :: k -> k -> *) where
+      catId   :: cat a a
+      catComp :: cat b c -> cat a b -> cat a c
+
+    instance Cat * (->) where
+      catId   = id
+      catComp = (.)
+
+    newtype Fun a b = Fun (a -> b) deriving (Cat k)
+
+Even though we requested a derived instance of the form (Cat k Fun), the
+kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
+the user wrote deriving (Cat *)).
+
+What happens with DerivingVia, when you have yet another type? Consider:
+
+  newtype Foo (a :: Type) = MkFoo (Proxy a)
+    deriving Functor via Proxy
+
+As before, we unify the kind of Foo (* -> *) with the kind of the argument to
+Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
+(k -> *), which is more general than what we want. So we must additionally
+unify (k -> *) with (* -> *).
+
+Currently, all of this unification is implemented kludgily with the pure
+unifier, which is rather tiresome. #14331 lays out a plan for how this
+might be made cleaner.
+
+Note [Unification of two kind variables in deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As a special case of the Note above, it is possible to derive an instance of
+a poly-kinded typeclass for a poly-kinded datatype. For example:
+
+    class Category (cat :: k -> k -> *) where
+    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category
+
+This case is suprisingly tricky. To see why, let's write out what instance GHC
+will attempt to derive (using -fprint-explicit-kinds syntax):
+
+    instance Category k1 (T k2 c) where ...
+
+GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
+that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
+the type variable binder for c, since its kind is (k2 -> k2 -> *).
+
+We used to accomplish this by doing the following:
+
+    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
+    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
+
+Where all_tkvs contains all kind variables in the class and instance types (in
+this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
+this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
+to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
+This is bad, because applying that substitution yields the following instance:
+
+   instance Category k_new (T k1 c) where ...
+
+In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
+in an ill-kinded instance (this caused #11837).
+
+To prevent this, we need to filter out any variable from all_tkvs which either
+
+1. Appears in the domain of kind_subst. notElemTCvSubst checks this.
+2. Appears in the range of kind_subst. To do this, we compute the free
+   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check
+   if a kind variable appears in that set.
+
+Note [Eta-reducing type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One can instantiate a type in a data family instance with a type synonym that
+mentions other type variables:
+
+  type Const a b = a
+  data family Fam (f :: * -> *) (a :: *)
+  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
+
+It is also possible to define kind synonyms, and they can mention other types in
+a datatype declaration. For example,
+
+  type Const a b = a
+  newtype T f (a :: Const * f) = T (f a) deriving Functor
+
+When deriving, we need to perform eta-reduction analysis to ensure that none of
+the eta-reduced type variables are mentioned elsewhere in the declaration. But
+we need to be careful, because if we don't expand through the Const type
+synonym, we will mistakenly believe that f is an eta-reduced type variable and
+fail to derive Functor, even though the code above is correct (see #11416,
+where this was first noticed). For this reason, we expand the type synonyms in
+the eta-reduced types before doing any analysis.
+-}
+
+mkEqnHelp :: Maybe OverlapMode
+          -> [TyVar]
+          -> Class -> [Type]
+          -> TyCon -> [Type]
+          -> DerivContext
+               -- SupplyContext => context supplied (standalone deriving)
+               -- InferContext  => context inferred (deriving on data decl, or
+               --                  standalone deriving decl with a wildcard)
+          -> Maybe (DerivStrategy GhcTc)
+          -> TcRn EarlyDerivSpec
+-- Make the EarlyDerivSpec for an instance
+--      forall tvs. theta => cls (tys ++ [ty])
+-- where the 'theta' is optional (that's the Maybe part)
+-- Assumes that this declaration is well-kinded
+
+mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
+  = do {      -- Find the instance of a data family
+              -- Note [Looking up family instances for deriving]
+         fam_envs <- tcGetFamInstEnvs
+       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
+              -- If it's still a data family, the lookup failed; i.e no instance exists
+       ; when (isDataFamilyTyCon rep_tc)
+              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
+       ; is_boot <- tcIsHsBootOrSig
+       ; when is_boot $
+              bale_out (text "Cannot derive instances in hs-boot files"
+                    $+$ text "Write an instance declaration instead")
+
+       ; let deriv_env = DerivEnv
+                         { denv_overlap_mode = overlap_mode
+                         , denv_tvs          = tvs
+                         , denv_cls          = cls
+                         , denv_cls_tys      = cls_tys
+                         , denv_tc           = tycon
+                         , denv_tc_args      = tc_args
+                         , denv_rep_tc       = rep_tc
+                         , denv_rep_tc_args  = rep_tc_args
+                         , denv_ctxt         = deriv_ctxt
+                         , denv_strat        = deriv_strat }
+       ; flip runReaderT deriv_env $
+         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
+  where
+     bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                      (mkTyConApp tycon tc_args) deriv_strat msg)
+
+{-
+Note [Looking up family instances for deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcLookupFamInstExact is an auxiliary lookup wrapper which requires
+that looked-up family instances exist.  If called with a vanilla
+tycon, the old type application is simply returned.
+
+If we have
+  data instance F () = ... deriving Eq
+  data instance F () = ... deriving Eq
+then tcLookupFamInstExact will be confused by the two matches;
+but that can't happen because tcInstDecls1 doesn't call tcDeriving
+if there are any overlaps.
+
+There are two other things that might go wrong with the lookup.
+First, we might see a standalone deriving clause
+   deriving Eq (F ())
+when there is no data instance F () in scope.
+
+Note that it's OK to have
+  data instance F [a] = ...
+  deriving Eq (F [(a,b)])
+where the match is not exact; the same holds for ordinary data types
+with standalone deriving declarations.
+
+Note [Deriving, type families, and partial applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When there are no type families, it's quite easy:
+
+    newtype S a = MkS [a]
+    -- :CoS :: S  ~ []  -- Eta-reduced
+
+    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
+    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
+
+When type familes are involved it's trickier:
+
+    data family T a b
+    newtype instance T Int a = MkT [a] deriving( Eq, Monad )
+    -- :RT is the representation type for (T Int a)
+    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
+    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!
+
+    instance Eq [a] => Eq (T Int a)     -- easy by coercion
+       -- d1 :: Eq [a]
+       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
+
+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
+       -- d1 :: Monad []
+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
+
+Note the need for the eta-reduced rule axioms.  After all, we can
+write it out
+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
+      return x = MkT [x]
+      ... etc ...
+
+See Note [Eta reduction for data families] in FamInstEnv
+
+%************************************************************************
+%*                                                                      *
+                Deriving data types
+*                                                                      *
+************************************************************************
+-}
+
+-- | Derive an instance for a data type (i.e., non-newtype).
+mkDataTypeEqn :: DerivM EarlyDerivSpec
+mkDataTypeEqn
+  = do mb_strat <- asks denv_strat
+       let bale_out msg = do err <- derivingThingErrM False msg
+                             lift $ failWithTc err
+       case mb_strat of
+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just (ViaStrategy ty) -> mk_eqn_via ty
+         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
+         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr
+         -- Lacking a user-requested deriving strategy, we will try to pick
+         -- between the stock or anyclass strategies
+         Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out
+
+-- Derive an instance by way of an originative deriving strategy
+-- (stock or anyclass).
+--
+-- See Note [Deriving strategies]
+mk_originative_eqn
+  :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or
+                        -- DerivSpecAnyclass
+  -> DerivM EarlyDerivSpec
+mk_originative_eqn mechanism
+  = do DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_tc           = tc
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tc
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt } <- ask
+       let inst_ty  = mkTyConApp tc tc_args
+           inst_tys = cls_tys ++ [inst_ty]
+       doDerivInstErrorChecks1 mechanism
+       loc       <- lift getSrcSpanM
+       dfun_name <- lift $ newDFunName' cls tc
+       case deriv_ctxt of
+        InferContext wildcard ->
+          do { (inferred_constraints, tvs', inst_tys')
+                 <- inferConstraints mechanism
+             ; return $ InferTheta $ DS
+                   { ds_loc = loc
+                   , ds_name = dfun_name, ds_tvs = tvs'
+                   , ds_cls = cls, ds_tys = inst_tys'
+                   , ds_tc = rep_tc
+                   , ds_theta = inferred_constraints
+                   , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = wildcard
+                   , ds_mechanism = mechanism } }
+
+        SupplyContext theta ->
+            return $ GivenTheta $ DS
+                   { ds_loc = loc
+                   , ds_name = dfun_name, ds_tvs = tvs
+                   , ds_cls = cls, ds_tys = inst_tys
+                   , ds_tc = rep_tc
+                   , ds_theta = theta
+                   , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = Nothing
+                   , ds_mechanism = mechanism }
+
+-- Derive an instance by way of a coerce-based deriving strategy
+-- (newtype or via).
+--
+-- See Note [Deriving strategies]
+mk_coerce_based_eqn
+  :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype
+                                  -- or DerivSpecVia
+  -> Type -- The type to coerce
+  -> DerivM EarlyDerivSpec
+mk_coerce_based_eqn mk_mechanism coerced_ty
+  = do DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_tc           = tycon
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tycon
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt } <- ask
+       sa_wildcard <- isStandaloneWildcardDeriv
+       let -- The following functions are polymorphic over the representation
+           -- type, since we might either give it the underlying type of a
+           -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
+           -- (for DerivingVia).
+           rep_tys ty  = cls_tys ++ [ty]
+           rep_pred ty = mkClassPred cls (rep_tys ty)
+           rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)
+                   -- rep_pred is the representation dictionary, from where
+                   -- we are going to get all the methods for the final
+                   -- dictionary
+
+           -- Next we figure out what superclass dictionaries to use
+           -- See Note [Newtype deriving superclasses] above
+           sc_preds   :: [PredOrigin]
+           cls_tyvars = classTyVars cls
+           inst_ty    = mkTyConApp tycon tc_args
+           inst_tys   = cls_tys ++ [inst_ty]
+           sc_preds   = map (mkPredOrigin deriv_origin TypeLevel) $
+                        substTheta (zipTvSubst cls_tyvars inst_tys) $
+                        classSCTheta cls
+           deriv_origin = mkDerivOrigin sa_wildcard
+
+           -- Next we collect constraints for the class methods
+           -- If there are no methods, we don't need any constraints
+           -- Otherwise we need (C rep_ty), for the representation methods,
+           -- and constraints to coerce each individual method
+           meth_preds :: Type -> [PredOrigin]
+           meths = classMethods cls
+           meth_preds ty
+             | null meths = [] -- No methods => no constraints
+                               -- (#12814)
+             | otherwise = rep_pred_o ty : coercible_constraints ty
+           coercible_constraints ty
+             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
+                              TypeLevel (mkReprPrimEqPred t1 t2)
+               | meth <- meths
+               , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
+                                            inst_tys ty meth ]
+
+           all_thetas :: Type -> [ThetaOrigin]
+           all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds]
+
+           inferred_thetas = all_thetas coerced_ty
+       lift $ traceTc "newtype deriving:" $
+         ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas
+       let mechanism = mk_mechanism coerced_ty
+           bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                             lift $ failWithTc err
+       atf_coerce_based_error_checks cls bale_out
+       doDerivInstErrorChecks1 mechanism
+       dfun_name <- lift $ newDFunName' cls tycon
+       loc       <- lift getSrcSpanM
+       case deriv_ctxt of
+        SupplyContext theta -> return $ GivenTheta $ DS
+            { ds_loc = loc
+            , ds_name = dfun_name, ds_tvs = tvs
+            , ds_cls = cls, ds_tys = inst_tys
+            , ds_tc = rep_tycon
+            , ds_theta = theta
+            , ds_overlap = overlap_mode
+            , ds_standalone_wildcard = Nothing
+            , ds_mechanism = mechanism }
+        InferContext wildcard -> return $ InferTheta $ DS
+            { ds_loc = loc
+            , ds_name = dfun_name, ds_tvs = tvs
+            , ds_cls = cls, ds_tys = inst_tys
+            , ds_tc = rep_tycon
+            , ds_theta = inferred_thetas
+            , ds_overlap = overlap_mode
+            , ds_standalone_wildcard = wildcard
+            , ds_mechanism = mechanism }
+
+-- Ensure that a class's associated type variables are suitable for
+-- GeneralizedNewtypeDeriving or DerivingVia.
+--
+-- See Note [GND and associated type families]
+atf_coerce_based_error_checks
+  :: Class
+  -> (SDoc -> DerivM ())
+  -> DerivM ()
+atf_coerce_based_error_checks cls bale_out
+  = let cls_tyvars = classTyVars cls
+
+        ats_look_sensible
+           =  -- Check (a) from Note [GND and associated type families]
+              no_adfs
+              -- Check (b) from Note [GND and associated type families]
+           && isNothing at_without_last_cls_tv
+              -- Check (d) from Note [GND and associated type families]
+           && isNothing at_last_cls_tv_in_kinds
+
+        (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
+        no_adfs            = null adf_tcs
+               -- We cannot newtype-derive data family instances
+
+        at_without_last_cls_tv
+          = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
+        at_last_cls_tv_in_kinds
+          = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
+                             (tyConTyVars tc)
+                      || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
+        at_last_cls_tv_in_kind kind
+          = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
+        at_tcs = classATs cls
+        last_cls_tv = ASSERT( notNull cls_tyvars )
+                      last cls_tyvars
+
+        cant_derive_err
+           = vcat [ ppUnless no_adfs adfs_msg
+                  , maybe empty at_without_last_cls_tv_msg
+                          at_without_last_cls_tv
+                  , maybe empty at_last_cls_tv_in_kinds_msg
+                          at_last_cls_tv_in_kinds
+                  ]
+        adfs_msg  = text "the class has associated data types"
+        at_without_last_cls_tv_msg at_tc = hang
+          (text "the associated type" <+> quotes (ppr at_tc)
+           <+> text "is not parameterized over the last type variable")
+          2 (text "of the class" <+> quotes (ppr cls))
+        at_last_cls_tv_in_kinds_msg at_tc = hang
+          (text "the associated type" <+> quotes (ppr at_tc)
+           <+> text "contains the last type variable")
+         2 (text "of the class" <+> quotes (ppr cls)
+           <+> text "in a kind, which is not (yet) allowed")
+    in unless ats_look_sensible $ bale_out cant_derive_err
+
+mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+             -> (SDoc -> DerivM EarlyDerivSpec)
+             -> DerivM EarlyDerivSpec
+mk_eqn_stock go_for_it bale_out
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_ctxt    = deriv_ctxt } <- ask
+       dflags <- getDynFlags
+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                           tc rep_tc of
+         CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn
+         StockClassError msg   -> bale_out msg
+         _                     -> bale_out (nonStdErr cls)
+
+mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+                -> (SDoc -> DerivM EarlyDerivSpec)
+                -> DerivM EarlyDerivSpec
+mk_eqn_anyclass go_for_it bale_out
+  = do dflags <- getDynFlags
+       case canDeriveAnyClass dflags of
+         IsValid      -> go_for_it DerivSpecAnyClass
+         NotValid msg -> bale_out msg
+
+mk_eqn_newtype :: Type -- The newtype's representation type
+               -> DerivM EarlyDerivSpec
+mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype
+
+mk_eqn_via :: Type -- The @via@ type
+           -> DerivM EarlyDerivSpec
+mk_eqn_via = mk_coerce_based_eqn DerivSpecVia
+
+mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+                    -> (SDoc -> DerivM EarlyDerivSpec)
+                    -> DerivM EarlyDerivSpec
+mk_eqn_no_mechanism go_for_it bale_out
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_ctxt    = deriv_ctxt } <- ask
+       dflags <- getDynFlags
+
+           -- See Note [Deriving instances for classes themselves]
+       let dac_error msg
+             | isClassTyCon rep_tc
+             = quotes (ppr tc) <+> text "is a type class,"
+                               <+> text "and can only have a derived instance"
+                               $+$ text "if DeriveAnyClass is enabled"
+             | otherwise
+             = nonStdErr cls $$ msg
+
+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                           tc rep_tc of
+           -- NB: pass the *representation* tycon to
+           -- checkOriginativeSideConditions
+           NonDerivableClass   msg -> bale_out (dac_error msg)
+           StockClassError msg     -> bale_out msg
+           CanDeriveStock gen_fn   -> go_for_it $ DerivSpecStock gen_fn
+           CanDeriveAnyClass       -> go_for_it DerivSpecAnyClass
+
+{-
+************************************************************************
+*                                                                      *
+            GeneralizedNewtypeDeriving and DerivingVia
+*                                                                      *
+************************************************************************
+-}
+
+-- | Derive an instance for a newtype.
+mkNewTypeEqn :: DerivM EarlyDerivSpec
+mkNewTypeEqn
+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
+  = do DerivEnv { denv_tc           = tycon
+                , denv_rep_tc       = rep_tycon
+                , denv_rep_tc_args  = rep_tc_args
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt
+                , denv_strat        = mb_strat } <- ask
+       dflags <- getDynFlags
+
+       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
+           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags
+           bale_out        = bale_out' newtype_deriving
+           bale_out' b msg = do err <- derivingThingErrM b msg
+                                lift $ failWithTc err
+
+           non_std     = nonStdErr cls
+           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"
+                     <+> text "newtype-deriving extension"
+
+           -- Here is the plan for newtype derivings.  We see
+           --        newtype T a1...an = MkT (t ak+1...an)
+           --          deriving (.., C s1 .. sm, ...)
+           -- where t is a type,
+           --       ak+1...an is a suffix of a1..an, and are all tyvars
+           --       ak+1...an do not occur free in t, nor in the s1..sm
+           --       (C s1 ... sm) is a  *partial applications* of class C
+           --                      with the last parameter missing
+           --       (T a1 .. ak) matches the kind of C's last argument
+           --              (and hence so does t)
+           -- The latter kind-check has been done by deriveTyData already,
+           -- and tc_args are already trimmed
+           --
+           -- We generate the instance
+           --       instance forall ({a1..ak} u fvs(s1..sm)).
+           --                C s1 .. sm t => C s1 .. sm (T a1...ak)
+           -- where T a1...ap is the partial application of
+           --       the LHS of the correct kind and p >= k
+           --
+           --      NB: the variables below are:
+           --              tc_tvs = [a1, ..., an]
+           --              tyvars_to_keep = [a1, ..., ak]
+           --              rep_ty = t ak .. an
+           --              deriv_tvs = fvs(s1..sm) \ tc_tvs
+           --              tys = [s1, ..., sm]
+           --              rep_fn' = t
+           --
+           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
+           -- We generate the instance
+           --      instance Monad (ST s) => Monad (T s) where
+
+           nt_eta_arity = newTyConEtadArity rep_tycon
+                   -- For newtype T a b = MkT (S a a b), the TyCon
+                   -- machinery already eta-reduces the representation type, so
+                   -- we know that
+                   --      T a ~ S a a
+                   -- That's convenient here, because we may have to apply
+                   -- it to fewer than its original complement of arguments
+
+           -- Note [Newtype representation]
+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           -- Need newTyConRhs (*not* a recursive representation finder)
+           -- to get the representation type. For example
+           --      newtype B = MkB Int
+           --      newtype A = MkA B deriving( Num )
+           -- We want the Num instance of B, *not* the Num instance of Int,
+           -- when making the Num instance of A!
+           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
+
+           -------------------------------------------------------------------
+           --  Figuring out whether we can only do this newtype-deriving thing
+
+           -- See Note [Determining whether newtype-deriving is appropriate]
+           might_be_newtype_derivable
+              =  not (non_coercible_class cls)
+              && eta_ok
+--            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
+
+           -- Check that eta reduction is OK
+           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
+             -- The newtype can be eta-reduced to match the number
+             --     of type argument actually supplied
+             --        newtype T a b = MkT (S [a] b) deriving( Monad )
+             --     Here the 'b' must be the same in the rep type (S [a] b)
+             --     And the [a] must not mention 'b'.  That's all handled
+             --     by nt_eta_rity.
+
+           cant_derive_err = ppUnless eta_ok  eta_msg
+           eta_msg = text "cannot eta-reduce the representation type enough"
+
+       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
+       case mb_strat of
+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just NewtypeStrategy  ->
+           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
+           -- we don't need to perform all of the checks we normally would,
+           -- such as if the class being derived is known to produce ill-roled
+           -- coercions (e.g., Traversable), since we can just derive the
+           -- instance and let it error if need be.
+           -- See Note [Determining whether newtype-deriving is appropriate]
+           if eta_ok && newtype_deriving
+             then mk_eqn_newtype rep_inst_ty
+             else bale_out (cant_derive_err $$
+                            if newtype_deriving then empty else suggest_gnd)
+         Just (ViaStrategy via_ty) ->
+           -- NB: For DerivingVia, we don't need to any eta-reduction checking,
+           -- since the @via@ type is already "eta-reduced".
+           mk_eqn_via via_ty
+         Nothing
+           | might_be_newtype_derivable
+             && ((newtype_deriving && not deriveAnyClass)
+                  || std_class_via_coercible cls)
+          -> mk_eqn_newtype rep_inst_ty
+           | otherwise
+          -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                                 tycon rep_tycon of
+               StockClassError msg
+                 -- There's a particular corner case where
+                 --
+                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
+                 --    both enabled at the same time
+                 -- 2. We're deriving a particular stock derivable class
+                 --    (such as Functor)
+                 --
+                 -- and the previous cases won't catch it. This fixes the bug
+                 -- reported in #10598.
+                 | might_be_newtype_derivable && newtype_deriving
+                -> mk_eqn_newtype rep_inst_ty
+                 -- Otherwise, throw an error for a stock class
+                 | might_be_newtype_derivable && not newtype_deriving
+                -> bale_out (msg $$ suggest_gnd)
+                 | otherwise
+                -> bale_out msg
+
+               -- Must use newtype deriving or DeriveAnyClass
+               NonDerivableClass _msg
+                 -- Too hard, even with newtype deriving
+                 | newtype_deriving           -> bale_out cant_derive_err
+                 -- Try newtype deriving!
+                 -- Here we suggest GeneralizedNewtypeDeriving even in cases
+                 -- where it may not be applicable. See #9600.
+                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)
+
+               -- DeriveAnyClass
+               CanDeriveAnyClass -> do
+                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
+                 -- enabled, we take the diplomatic approach of defaulting to
+                 -- DeriveAnyClass, but emitting a warning about the choice.
+                 -- See Note [Deriving strategies]
+                 when (newtype_deriving && deriveAnyClass) $
+                   lift $ addWarnTc NoReason $ sep
+                     [ text "Both DeriveAnyClass and"
+                       <+> text "GeneralizedNewtypeDeriving are enabled"
+                     , text "Defaulting to the DeriveAnyClass strategy"
+                       <+> text "for instantiating" <+> ppr cls
+                     , text "Use DerivingStrategies to pick"
+                       <+> text "a different strategy"
+                      ]
+                 mk_originative_eqn DerivSpecAnyClass
+               -- CanDeriveStock
+               CanDeriveStock gen_fn -> mk_originative_eqn $
+                                        DerivSpecStock gen_fn
+
+{-
+Note [Recursive newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Newtype deriving works fine, even if the newtype is recursive.
+e.g.    newtype S1 = S1 [T1 ()]
+        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
+Remember, too, that type families are currently (conservatively) given
+a recursive flag, so this also allows newtype deriving to work
+for type famillies.
+
+We used to exclude recursive types, because we had a rather simple
+minded way of generating the instance decl:
+   newtype A = MkA [A]
+   instance Eq [A] => Eq A      -- Makes typechecker loop!
+But now we require a simple context, so it's ok.
+
+Note [Determining whether newtype-deriving is appropriate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we see
+  newtype NT = MkNT Foo
+    deriving C
+we have to decide how to perform the deriving. Do we do newtype deriving,
+or do we do normal deriving? In general, we prefer to do newtype deriving
+wherever possible. So, we try newtype deriving unless there's a glaring
+reason not to.
+
+"Glaring reasons not to" include trying to derive a class for which a
+coercion-based instance doesn't make sense. These classes are listed in
+the definition of non_coercible_class. They include Show (since it must
+show the name of the datatype) and Traversable (since a coercion-based
+Traversable instance is ill-roled).
+
+However, non_coercible_class is ignored if the user explicitly requests
+to derive an instance with GeneralizedNewtypeDeriving using the newtype
+deriving strategy. In such a scenario, GHC will unquestioningly try to
+derive the instance via coercions (even if the final generated code is
+ill-roled!). See Note [Deriving strategies].
+
+Note that newtype deriving might fail, even after we commit to it. This
+is because the derived instance uses `coerce`, which must satisfy its
+`Coercible` constraint. This is different than other deriving scenarios,
+where we're sure that the resulting instance will type-check.
+
+Note [GND and associated type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for
+classes with associated type families. A general recipe is:
+
+    class C x y z where
+      type T y z x
+      op :: x -> [y] -> z
+
+    newtype N a = MkN <rep-type> deriving( C )
+
+    =====>
+
+    instance C x y <rep-type> => C x y (N a) where
+      type T y (N a) x = T y <rep-type> x
+      op = coerce (op :: x -> [y] -> <rep-type>)
+
+However, we must watch out for three things:
+
+(a) The class must not contain any data families. If it did, we'd have to
+    generate a fresh data constructor name for the derived data family
+    instance, and it's not clear how to do this.
+
+(b) Each associated type family's type variables must mention the last type
+    variable of the class. As an example, you wouldn't be able to use GND to
+    derive an instance of this class:
+
+      class C a b where
+        type T a
+
+    But you would be able to derive an instance of this class:
+
+      class C a b where
+        type T b
+
+    The difference is that in the latter T mentions the last parameter of C
+    (i.e., it mentions b), but the former T does not. If you tried, e.g.,
+
+      newtype Foo x = Foo x deriving (C a)
+
+    with the former definition of C, you'd end up with something like this:
+
+      instance C a (Foo x) where
+        type T a = T ???
+
+    This T family instance doesn't mention the newtype (or its representation
+    type) at all, so we disallow such constructions with GND.
+
+(c) UndecidableInstances might need to be enabled. Here's a case where it is
+    most definitely necessary:
+
+      class C a where
+        type T a
+      newtype Loop = Loop MkLoop deriving C
+
+      =====>
+
+      instance C Loop where
+        type T Loop = T Loop
+
+    Obviously, T Loop would send the typechecker into a loop. Unfortunately,
+    you might even need UndecidableInstances even in cases where the
+    typechecker would be guaranteed to terminate. For example:
+
+      instance C Int where
+        type C Int = Int
+      newtype MyInt = MyInt Int deriving C
+
+      =====>
+
+      instance C MyInt where
+        type T MyInt = T Int
+
+    GHC's termination checker isn't sophisticated enough to conclude that the
+    definition of T MyInt terminates, so UndecidableInstances is required.
+
+(d) For the time being, we do not allow the last type variable of the class to
+    appear in a /kind/ of an associated type family definition. For instance:
+
+    class C a where
+      type T1 a        -- OK
+      type T2 (x :: a) -- Illegal: a appears in the kind of x
+      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)
+
+    The reason we disallow this is because our current approach to deriving
+    associated type family instances—i.e., by unwrapping the newtype's type
+    constructor as shown above—is ill-equipped to handle the scenario when
+    the last type variable appears as an implicit argument. In the worst case,
+    allowing the last variable to appear in a kind can result in improper Core
+    being generated (see #14728).
+
+    There is hope for this feature being added some day, as one could
+    conceivably take a newtype axiom (which witnesses a coercion between a
+    newtype and its representation type) at lift that through each associated
+    type at the Core level. See #14728, comment:3 for a sketch of how this
+    might work. Until then, we disallow this featurette wholesale.
+
+The same criteria apply to DerivingVia.
+
+************************************************************************
+*                                                                      *
+\subsection[TcDeriv-normal-binds]{Bindings for the various classes}
+*                                                                      *
+************************************************************************
+
+After all the trouble to figure out the required context for the
+derived instance declarations, all that's left is to chug along to
+produce them.  They will then be shoved into @tcInstDecls2@, which
+will do all its usual business.
+
+There are lots of possibilities for code to generate.  Here are
+various general remarks.
+
+PRINCIPLES:
+\begin{itemize}
+\item
+We want derived instances of @Eq@ and @Ord@ (both v common) to be
+``you-couldn't-do-better-by-hand'' efficient.
+
+\item
+Deriving @Show@---also pretty common--- should also be reasonable good code.
+
+\item
+Deriving for the other classes isn't that common or that big a deal.
+\end{itemize}
+
+PRAGMATICS:
+
+\begin{itemize}
+\item
+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
+
+\item
+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
+
+\item
+We {\em normally} generate code only for the non-defaulted methods;
+there are some exceptions for @Eq@ and (especially) @Ord@...
+
+\item
+Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
+constructor's numeric (@Int#@) tag.  These are generated by
+@gen_tag_n_con_binds@, and the heuristic for deciding if one of
+these is around is given by @hasCon2TagFun@.
+
+The examples under the different sections below will make this
+clearer.
+
+\item
+Much less often (really just for deriving @Ix@), we use a
+@_tag2con_<tycon>@ function.  See the examples.
+
+\item
+We use the renamer!!!  Reason: we're supposed to be
+producing @LHsBinds Name@ for the methods, but that means
+producing correctly-uniquified code on the fly.  This is entirely
+possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
+So, instead, we produce @MonoBinds RdrName@ then heave 'em through
+the renamer.  What a great hack!
+\end{itemize}
+-}
+
+-- Generate the InstInfo for the required instance paired with the
+--   *representation* tycon for that instance,
+-- plus any auxiliary bindings required
+--
+-- Representation tycons differ from the tycon in the instance signature in
+-- case of instances for indexed families.
+--
+genInst :: DerivSpec theta
+        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
+-- We must use continuation-returning style here to get the order in which we
+-- typecheck family instances and derived instances right.
+-- See Note [Staging of tcDeriving]
+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
+                 , ds_mechanism = mechanism, ds_tys = tys
+                 , ds_cls = clas, ds_loc = loc
+                 , ds_standalone_wildcard = wildcard })
+  = do (meth_binds, deriv_stuff, unusedNames)
+         <- set_span_and_ctxt $
+            genDerivStuff mechanism loc clas rep_tycon tys tvs
+       let mk_inst_info theta = set_span_and_ctxt $ do
+             inst_spec <- newDerivClsInst theta spec
+             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
+             traceTc "newder" (ppr inst_spec)
+             return $ InstInfo
+                       { iSpec   = inst_spec
+                       , iBinds  = InstBindings
+                                     { ib_binds = meth_binds
+                                     , ib_tyvars = map Var.varName tvs
+                                     , ib_pragmas = []
+                                     , ib_extensions = extensions
+                                     , ib_derived = True } }
+       return (mk_inst_info, deriv_stuff, unusedNames)
+  where
+    extensions :: [LangExt.Extension]
+    extensions
+      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
+        -- Both these flags are needed for higher-rank uses of coerce
+        -- See Note [Newtype-deriving instances] in TcGenDeriv
+      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]
+      | otherwise
+      = []
+
+    set_span_and_ctxt :: TcM a -> TcM a
+    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
+
+doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
+doDerivInstErrorChecks1 mechanism = do
+    DerivEnv { denv_tc      = tc
+             , denv_rep_tc  = rep_tc } <- ask
+    standalone <- isStandaloneDeriv
+    let anyclass_strategy = isDerivSpecAnyClass mechanism
+        via_strategy      = isDerivSpecVia mechanism
+        bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                          lift $ failWithTc err
+
+    -- For standalone deriving, check that all the data constructors are in
+    -- scope...
+    rdr_env <- lift getGlobalRdrEnv
+    let data_con_names = map dataConName (tyConDataCons rep_tc)
+        hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
+                           (isAbstractTyCon rep_tc ||
+                            any not_in_scope data_con_names)
+        not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
+
+    lift $ addUsedDataCons rdr_env rep_tc
+
+    -- ...however, we don't perform this check if we're using DeriveAnyClass,
+    -- since it doesn't generate any code that requires use of a data
+    -- constructor. Nor do we perform this check with @deriving via@, as it
+    -- doesn't explicitly require the constructors to be in scope.
+    unless (anyclass_strategy || via_strategy
+            || not standalone || not hidden_data_cons) $
+           bale_out $ derivingHiddenErr tc
+
+doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
+                        -> DerivSpecMechanism -> TcM ()
+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
+  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
+       ; dflags <- getDynFlags
+       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
+       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
+
+         -- Error if PartialTypeSignatures isn't enabled when a user tries
+         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
+         -- extension is enabled, give a warning if -Wpartial-type-signatures
+         -- is enabled.
+       ; case wildcard of
+           Nothing -> pure ()
+           Just span -> setSrcSpan span $ do
+             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)
+             warnTc (Reason Opt_WarnPartialTypeSignatures)
+                    wpartial_sigs partial_sig_msg
+
+         -- Check for Generic instances that are derived with an exotic
+         -- deriving strategy like DAC
+         -- See Note [Deriving strategies]
+       ; when (exotic_mechanism && className clas `elem` genericClassNames) $
+         do { failIfTc (safeLanguageOn dflags) gen_inst_err
+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
+  where
+    exotic_mechanism = not $ isDerivSpecStock mechanism
+
+    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')
+                  <+> text "standing for" <+> quotes (pprTheta theta)
+
+    pts_suggestion
+      = text "To use the inferred type, enable PartialTypeSignatures"
+
+    gen_inst_err = text "Generic instances can only be derived in"
+               <+> text "Safe Haskell using the stock strategy."
+
+genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
+              -> TyCon -> [Type] -> [TyVar]
+              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
+genDerivStuff mechanism loc clas tycon inst_tys tyvars
+  = case mechanism of
+      -- See Note [Bindings for Generalised Newtype Deriving]
+      DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty
+
+      -- Try a stock deriver
+      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
+
+      -- Try DeriveAnyClass
+      DerivSpecAnyClass -> do
+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
+        dflags <- getDynFlags
+        tyfam_insts <-
+          -- canDeriveAnyClass should ensure that this code can't be reached
+          -- unless -XDeriveAnyClass is enabled.
+          ASSERT2( isValid (canDeriveAnyClass dflags)
+                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+          mapM (tcATDefault loc mini_subst emptyNameSet)
+               (classATItems clas)
+        return ( emptyBag -- No method bindings are needed...
+               , listToBag (map DerivFamInst (concat tyfam_insts))
+               -- ...but we may need to generate binding for associated type
+               -- family default instances.
+               -- See Note [DeriveAnyClass and default family instances]
+               , [] )
+
+      -- Try DerivingVia
+      DerivSpecVia via_ty -> gen_newtype_or_via via_ty
+  where
+    gen_newtype_or_via ty = do
+      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
+      return (binds, faminsts, maybeToList unusedConName)
+
+    unusedConName :: Maybe Name
+    unusedConName
+      | isDerivSpecNewtype mechanism
+        -- See Note [Newtype deriving and unused constructors]
+      = Just $ getName $ head $ tyConDataCons tycon
+      | otherwise
+      = Nothing
+
+{-
+Note [Bindings for Generalised Newtype Deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  class Eq a => C a where
+     f :: a -> a
+  newtype N a = MkN [a] deriving( C )
+  instance Eq (N a) where ...
+
+The 'deriving C' clause generates, in effect
+  instance (C [a], Eq a) => C (N a) where
+     f = coerce (f :: [a] -> [a])
+
+This generates a cast for each method, but allows the superclasse to
+be worked out in the usual way.  In this case the superclass (Eq (N
+a)) will be solved by the explicit Eq (N a) instance.  We do *not*
+create the superclasses by casting the superclass dictionaries for the
+representation type.
+
+See the paper "Safe zero-cost coercions for Haskell".
+
+Note [DeriveAnyClass and default family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When a class has a associated type family with a default instance, e.g.:
+
+  class C a where
+    type T a
+    type T a = Char
+
+then there are a couple of scenarios in which a user would expect T a to
+default to Char. One is when an instance declaration for C is given without
+an implementation for T:
+
+  instance C Int
+
+Another scenario in which this can occur is when the -XDeriveAnyClass extension
+is used:
+
+  data Example = Example deriving (C, Generic)
+
+In the latter case, we must take care to check if C has any associated type
+families with default instances, because -XDeriveAnyClass will never provide
+an implementation for them. We "fill in" the default instances using the
+tcATDefault function from TcClassDcl (which is also used in TcInstDcls to
+handle the empty instance declaration case).
+
+Note [Deriving strategies]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC has a notion of deriving strategies, which allow the user to explicitly
+request which approach to use when deriving an instance (enabled with the
+-XDerivingStrategies language extension). For more information, refer to the
+original issue (#10598) or the associated wiki page:
+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
+
+A deriving strategy can be specified in a deriving clause:
+
+    newtype Foo = MkFoo Bar
+      deriving newtype C
+
+Or in a standalone deriving declaration:
+
+    deriving anyclass instance C Foo
+
+-XDerivingStrategies also allows the use of multiple deriving clauses per data
+declaration so that a user can derive some instance with one deriving strategy
+and other instances with another deriving strategy. For example:
+
+    newtype Baz = Baz Quux
+      deriving          (Eq, Ord)
+      deriving stock    (Read, Show)
+      deriving newtype  (Num, Floating)
+      deriving anyclass C
+
+Currently, the deriving strategies are:
+
+* stock: Have GHC implement a "standard" instance for a data type, if possible
+  (e.g., Eq, Ord, Generic, Data, Functor, etc.)
+
+* anyclass: Use -XDeriveAnyClass
+
+* newtype: Use -XGeneralizedNewtypeDeriving
+
+* via: Use -XDerivingVia
+
+The latter two strategies (newtype and via) are referred to as the
+"coerce-based" strategies, since they generate code that relies on the `coerce`
+function. The former two strategies (stock and anyclass), in contrast, are
+referred to as the "originative" strategies, since they create "original"
+instances instead of "reusing" old instances (by way of `coerce`).
+
+If an explicit deriving strategy is not given, GHC has an algorithm it uses to
+determine which strategy it will actually use. The algorithm is quite long,
+so it lives in the Haskell wiki at
+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
+("The deriving strategy resolution algorithm" section).
+
+Internally, GHC uses the DerivStrategy datatype to denote a user-requested
+deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
+GHC will use to derive the instance after taking the above steps. In other
+words, GHC will always settle on a DerivSpecMechnism, even if the user did not
+ask for a particular DerivStrategy (using the algorithm linked to above).
+
+Note [Deriving instances for classes themselves]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Much of the code in TcDeriv assumes that deriving only works on data types.
+But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
+reasonable to do something like this:
+
+  {-# LANGUAGE DeriveAnyClass #-}
+  class C1 (a :: Constraint) where
+  class C2 where
+  deriving instance C1 C2
+    -- This is equivalent to `instance C1 C2`
+
+If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
+deriving), we throw a special error message indicating that DeriveAnyClass is
+the only way to go. We don't bother throwing this error if an explicit 'stock'
+or 'newtype' keyword is used, since both options have their own perfectly
+sensible error messages in the case of the above code (as C1 isn't a stock
+derivable class, and C2 isn't a newtype).
+
+************************************************************************
+*                                                                      *
+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
+*                                                                      *
+************************************************************************
+-}
+
+nonUnaryErr :: LHsSigType GhcRn -> SDoc
+nonUnaryErr ct = quotes (ppr ct)
+  <+> text "is not a unary constraint, as expected by a deriving clause"
+
+nonStdErr :: Class -> SDoc
+nonStdErr cls =
+      quotes (ppr cls)
+  <+> text "is not a stock derivable class (Eq, Show, etc.)"
+
+gndNonNewtypeErr :: SDoc
+gndNonNewtypeErr =
+  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
+
+derivingNullaryErr :: MsgDoc
+derivingNullaryErr = text "Cannot derive instances for nullary classes"
+
+derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc
+derivingKindErr tc cls cls_tys cls_kind enough_args
+  = sep [ hang (text "Cannot derive well-kinded instance of form"
+                      <+> quotes (pprClassPred cls cls_tys
+                                    <+> parens (ppr tc <+> text "...")))
+               2 gen1_suggestion
+        , nest 2 (text "Class" <+> quotes (ppr cls)
+                      <+> text "expects an argument of kind"
+                      <+> quotes (pprKind cls_kind))
+        ]
+  where
+    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args
+                    = text "(Perhaps you intended to use PolyKinds)"
+                    | otherwise = Outputable.empty
+
+derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc
+derivingViaKindErr cls cls_kind via_ty via_kind
+  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))
+       2 (text "Class" <+> quotes (ppr cls)
+               <+> text "expects an argument of kind"
+               <+> quotes (pprKind cls_kind) <> char ','
+      $+$ text "but" <+> quotes (pprType via_ty)
+               <+> text "has kind" <+> quotes (pprKind via_kind))
+
+derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
+derivingEtaErr cls cls_tys inst_ty
+  = sep [text "Cannot eta-reduce to an instance of form",
+         nest 2 (text "instance (...) =>"
+                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
+
+derivingThingErr :: Bool -> Class -> [Type] -> Type
+                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc
+derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why
+  = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat
+                      (maybe empty derivStrategyName mb_strat) why
+
+derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
+derivingThingErrM newtype_deriving why
+  = do DerivEnv { denv_tc      = tc
+                , denv_tc_args = tc_args
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_strat   = mb_strat } <- ask
+       pure $ derivingThingErr newtype_deriving cls cls_tys
+                               (mkTyConApp tc tc_args) mb_strat why
+
+derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
+derivingThingErrMechanism mechanism why
+  = do DerivEnv { denv_tc      = tc
+                , denv_tc_args = tc_args
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_strat   = mb_strat } <- ask
+       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys
+                (mkTyConApp tc tc_args) mb_strat
+                (derivStrategyName $ derivSpecMechanismToStrategy mechanism)
+                why
+
+derivingThingErr' :: Bool -> Class -> [Type] -> Type
+                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc
+derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why
+  = sep [(hang (text "Can't make a derived instance of")
+             2 (quotes (ppr pred) <+> via_mechanism)
+          $$ nest 2 extra) <> colon,
+         nest 2 why]
+  where
+    strat_used = isJust mb_strat
+    extra | not strat_used, newtype_deriving
+          = text "(even with cunning GeneralizedNewtypeDeriving)"
+          | otherwise = empty
+    pred = mkClassPred cls (cls_tys ++ [inst_ty])
+    via_mechanism | strat_used
+                  = text "with the" <+> strat_msg <+> text "strategy"
+                  | otherwise
+                  = empty
+
+derivingHiddenErr :: TyCon -> SDoc
+derivingHiddenErr tc
+  = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
+       2 (text "so you cannot derive an instance for it")
+
+standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
+standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
+                       2 (quotes (ppr ty))
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -0,0 +1,973 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Functions for inferring (and simplifying) the context for derived instances.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+
+module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Bag
+import BasicTypes
+import Class
+import DataCon
+import ErrUtils
+import Inst
+import Outputable
+import PrelNames
+import TcDerivUtils
+import TcEnv
+import TcGenFunctor
+import TcGenGenerics
+import TcMType
+import TcRnMonad
+import TcType
+import TyCon
+import Type
+import TcSimplify
+import TcValidity (validDerivPred)
+import TcUnify (buildImplicationFor, checkConstraints)
+import Unify (tcUnifyTy)
+import Util
+import Var
+import VarSet
+
+import Control.Monad
+import Control.Monad.Trans.Class  (lift)
+import Control.Monad.Trans.Reader (ask)
+import Data.List
+import Data.Maybe
+
+----------------------
+
+inferConstraints :: DerivSpecMechanism
+                 -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+-- inferConstraints figures out the constraints needed for the
+-- instance declaration generated by a 'deriving' clause on a
+-- data type declaration. It also returns the new in-scope type
+-- variables and instance types, in case they were changed due to
+-- the presence of functor-like constraints.
+-- See Note [Inferring the instance context]
+
+-- e.g. inferConstraints
+--        C Int (T [a])    -- Class and inst_tys
+--        :RTList a        -- Rep tycon and its arg tys
+-- where T [a] ~R :RTList a
+--
+-- Generate a sufficiently large set of constraints that typechecking the
+-- generated method definitions should succeed.   This set will be simplified
+-- before being used in the instance declaration
+inferConstraints mechanism
+  = do { DerivEnv { denv_tc          = tc
+                  , denv_tc_args     = tc_args
+                  , denv_cls         = main_cls
+                  , denv_cls_tys     = cls_tys } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
+       ; let is_anyclass = isDerivSpecAnyClass mechanism
+             infer_constraints
+               | is_anyclass = inferConstraintsDAC inst_tys
+               | otherwise   = inferConstraintsDataConArgs inst_ty inst_tys
+
+             inst_ty  = mkTyConApp tc tc_args
+             inst_tys = cls_tys ++ [inst_ty]
+
+             -- Constraints arising from superclasses
+             -- See Note [Superclasses of derived instance]
+             cls_tvs  = classTyVars main_cls
+             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
+                                     , ppr main_cls <+> ppr inst_tys )
+                              [ mkThetaOrigin (mkDerivOrigin wildcard)
+                                              TypeLevel [] [] [] $
+                                substTheta cls_subst (classSCTheta main_cls) ]
+             cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+                         zipTvSubst cls_tvs inst_tys
+
+       ; (inferred_constraints, tvs', inst_tys') <- infer_constraints
+       ; lift $ traceTc "inferConstraints" $ vcat
+              [ ppr main_cls <+> ppr inst_tys'
+              , ppr inferred_constraints
+              ]
+       ; return ( sc_constraints ++ inferred_constraints
+                , tvs', inst_tys' ) }
+
+-- | Like 'inferConstraints', but used only in the case of deriving strategies
+-- where the constraints are inferred by inspecting the fields of each data
+-- constructor (i.e., stock- and newtype-deriving).
+inferConstraintsDataConArgs :: TcType -> [TcType]
+                            -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDataConArgs inst_ty inst_tys
+  = do DerivEnv { denv_tvs         = tvs
+                , denv_rep_tc      = rep_tc
+                , denv_rep_tc_args = rep_tc_args
+                , denv_cls         = main_cls
+                , denv_cls_tys     = cls_tys } <- ask
+       wildcard <- isStandaloneWildcardDeriv
+
+       let tc_binders = tyConBinders rep_tc
+           choose_level bndr
+             | isNamedTyConBinder bndr = KindLevel
+             | otherwise               = TypeLevel
+           t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
+              -- want to report *kind* errors when possible
+
+              -- Constraints arising from the arguments of each constructor
+           con_arg_constraints
+             :: (CtOrigin -> TypeOrKind
+                          -> Type
+                          -> [([PredOrigin], Maybe TCvSubst)])
+             -> ([ThetaOrigin], [TyVar], [TcType])
+           con_arg_constraints get_arg_constraints
+             = let (predss, mbSubsts) = unzip
+                     [ preds_and_mbSubst
+                     | data_con <- tyConDataCons rep_tc
+                     , (arg_n, arg_t_or_k, arg_ty)
+                         <- zip3 [1..] t_or_ks $
+                            dataConInstOrigArgTys data_con all_rep_tc_args
+                       -- No constraints for unlifted types
+                       -- See Note [Deriving and unboxed types]
+                     , not (isUnliftedType arg_ty)
+                     , let orig = DerivOriginDC data_con arg_n wildcard
+                     , preds_and_mbSubst
+                         <- get_arg_constraints orig arg_t_or_k arg_ty
+                     ]
+                   preds = concat predss
+                   -- If the constraints require a subtype to be of kind
+                   -- (* -> *) (which is the case for functor-like
+                   -- constraints), then we explicitly unify the subtype's
+                   -- kinds with (* -> *).
+                   -- See Note [Inferring the instance context]
+                   subst        = foldl' composeTCvSubst
+                                         emptyTCvSubst (catMaybes mbSubsts)
+                   unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
+                                             && not (v `isInScope` subst)) tvs
+                   (subst', _)  = substTyVarBndrs subst unmapped_tvs
+                   preds'       = map (substPredOrigin subst') preds
+                   inst_tys'    = substTys subst' inst_tys
+                   tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
+               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
+
+           is_generic  = main_cls `hasKey` genClassKey
+           is_generic1 = main_cls `hasKey` gen1ClassKey
+           -- is_functor_like: see Note [Inferring the instance context]
+           is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind
+                          || is_generic1
+
+           get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
+                                -> [([PredOrigin], Maybe TCvSubst)]
+           get_gen1_constraints functor_cls orig t_or_k ty
+              = mk_functor_like_constraints orig t_or_k functor_cls $
+                get_gen1_constrained_tys last_tv ty
+
+           get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
+                                   -> [([PredOrigin], Maybe TCvSubst)]
+           get_std_constrained_tys orig t_or_k ty
+               | is_functor_like
+               = mk_functor_like_constraints orig t_or_k main_cls $
+                 deepSubtypesContaining last_tv ty
+               | otherwise
+               = [( [mk_cls_pred orig t_or_k main_cls ty]
+                  , Nothing )]
+
+           mk_functor_like_constraints :: CtOrigin -> TypeOrKind
+                                       -> Class -> [Type]
+                                       -> [([PredOrigin], Maybe TCvSubst)]
+           -- 'cls' is usually main_cls (Functor or Traversable etc), but if
+           -- main_cls = Generic1, then 'cls' can be Functor; see
+           -- get_gen1_constraints
+           --
+           -- For each type, generate two constraints,
+           -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results
+           -- from unifying  kind(ty) with * -> *. If the unification is
+           -- successful, it will ensure that the resulting instance is well
+           -- kinded. If not, the second constraint will result in an error
+           -- message which points out the kind mismatch.
+           -- See Note [Inferring the instance context]
+           mk_functor_like_constraints orig t_or_k cls
+              = map $ \ty -> let ki = tcTypeKind ty in
+                             ( [ mk_cls_pred orig t_or_k cls ty
+                               , mkPredOrigin orig KindLevel
+                                   (mkPrimEqPred ki typeToTypeKind) ]
+                             , tcUnifyTy ki typeToTypeKind
+                             )
+
+           rep_tc_tvs      = tyConTyVars rep_tc
+           last_tv         = last rep_tc_tvs
+           -- When we first gather up the constraints to solve, most of them
+           -- contain rep_tc_tvs, i.e., the type variables from the derived
+           -- datatype's type constructor. We don't want these type variables
+           -- to appear in the final instance declaration, so we must
+           -- substitute each type variable with its counterpart in the derived
+           -- instance. rep_tc_args lists each of these counterpart types in
+           -- the same order as the type variables.
+           all_rep_tc_args
+             = rep_tc_args ++ map mkTyVarTy
+                                  (drop (length rep_tc_args) rep_tc_tvs)
+
+               -- Stupid constraints
+           stupid_constraints
+             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $
+                 substTheta tc_subst (tyConStupidTheta rep_tc) ]
+           tc_subst = -- See the comment with all_rep_tc_args for an
+                      -- explanation of this assertion
+                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
+                      zipTvSubst rep_tc_tvs all_rep_tc_args
+
+           -- Extra Data constraints
+           -- The Data class (only) requires that for
+           --    instance (...) => Data (T t1 t2)
+           -- IF   t1:*, t2:*
+           -- THEN (Data t1, Data t2) are among the (...) constraints
+           -- Reason: when the IF holds, we generate a method
+           --             dataCast2 f = gcast2 f
+           --         and we need the Data constraints to typecheck the method
+           extra_constraints = [mkThetaOriginFromPreds constrs]
+             where
+               constrs
+                 | main_cls `hasKey` dataClassKey
+                 , all (isLiftedTypeKind . tcTypeKind) rep_tc_args
+                 = [ mk_cls_pred deriv_origin t_or_k main_cls ty
+                   | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
+                 | otherwise
+                 = []
+
+           mk_cls_pred orig t_or_k cls ty
+                -- Don't forget to apply to cls_tys' too
+              = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
+           cls_tys' | is_generic1 = []
+                      -- In the awkward Generic1 case, cls_tys' should be
+                      -- empty, since we are applying the class Functor.
+
+                    | otherwise   = cls_tys
+
+           deriv_origin = mkDerivOrigin wildcard
+
+       if    -- Generic constraints are easy
+          |  is_generic
+           -> return ([], tvs, inst_tys)
+
+             -- Generic1 needs Functor
+             -- See Note [Getting base classes]
+          |  is_generic1
+           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )
+              -- Generic1 has a single kind variable
+              ASSERT( cls_tys `lengthIs` 1 )
+              do { functorClass <- lift $ tcLookupClass functorClassName
+                 ; pure $ con_arg_constraints
+                        $ get_gen1_constraints functorClass }
+
+             -- The others are a bit more complicated
+          |  otherwise
+           -> -- See the comment with all_rep_tc_args for an explanation of
+              -- this assertion
+              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
+                     , ppr main_cls <+> ppr rep_tc
+                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
+                do { let (arg_constraints, tvs', inst_tys')
+                           = con_arg_constraints get_std_constrained_tys
+                   ; lift $ traceTc "inferConstraintsDataConArgs" $ vcat
+                          [ ppr main_cls <+> ppr inst_tys'
+                          , ppr arg_constraints
+                          ]
+                   ; return ( stupid_constraints ++ extra_constraints
+                                                 ++ arg_constraints
+                            , tvs', inst_tys') }
+
+typeToTypeKind :: Kind
+typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
+
+-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,
+-- which gathers its constraints based on the type signatures of the class's
+-- methods instead of the types of the data constructor's field.
+--
+-- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+-- for an explanation of how these constraints are used to determine the
+-- derived instance context.
+inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDAC inst_tys
+  = do { DerivEnv { denv_tvs = tvs
+                  , denv_cls = cls } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
+
+       ; let gen_dms = [ (sel_id, dm_ty)
+                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
+
+             cls_tvs = classTyVars cls
+
+             do_one_meth :: (Id, Type) -> TcM ThetaOrigin
+               -- (Id,Type) are the selector Id and the generic default method type
+               -- NB: the latter is /not/ quantified over the class variables
+               -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+             do_one_meth (sel_id, gen_dm_ty)
+               = do { let (sel_tvs, _cls_pred, meth_ty)
+                                   = tcSplitMethodTy (varType sel_id)
+                          meth_ty' = substTyWith sel_tvs inst_tys meth_ty
+                          (meth_tvs, meth_theta, meth_tau)
+                                   = tcSplitNestedSigmaTys meth_ty'
+
+                          gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty
+                          (dm_tvs, dm_theta, dm_tau)
+                                     = tcSplitNestedSigmaTys gen_dm_ty'
+                          tau_eq     = mkPrimEqPred meth_tau dm_tau
+                    ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel
+                                meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }
+
+       ; theta_origins <- lift $ mapM do_one_meth gen_dms
+       ; return (theta_origins, tvs, inst_tys) }
+
+{- Note [Inferring the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are two sorts of 'deriving', as represented by the two constructors
+for DerivContext:
+
+  * InferContext mb_wildcard: This can either be:
+    - The deriving clause for a data type.
+        (e.g, data T a = T1 a deriving( Eq ))
+      In this case, mb_wildcard = Nothing.
+    - A standalone declaration with an extra-constraints wildcard
+        (e.g., deriving instance _ => Eq (Foo a))
+      In this case, mb_wildcard = Just loc, where loc is the location
+      of the extra-constraints wildcard.
+
+    Here we must infer an instance context,
+    and generate instance declaration
+      instance Eq a => Eq (T a) where ...
+
+  * SupplyContext theta: standalone deriving
+      deriving instance Eq a => Eq (T a)
+    Here we only need to fill in the bindings;
+    the instance context (theta) is user-supplied
+
+For the InferContext case, we must figure out the
+instance context (inferConstraintsDataConArgs). Suppose we are inferring
+the instance context for
+    C t1 .. tn (T s1 .. sm)
+There are two cases
+
+  * (T s1 .. sm) :: *         (the normal case)
+    Then we behave like Eq and guess (C t1 .. tn t)
+    for each data constructor arg of type t.  More
+    details below.
+
+  * (T s1 .. sm) :: * -> *    (the functor-like case)
+    Then we behave like Functor.
+
+In both cases we produce a bunch of un-simplified constraints
+and them simplify them in simplifyInstanceContexts; see
+Note [Simplifying the instance context].
+
+In the functor-like case, we may need to unify some kind variables with * in
+order for the generated instance to be well-kinded. An example from
+#10524:
+
+  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
+    = Compose (f (g a)) deriving Functor
+
+Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
+(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
+alone isn't enough, since k2 wasn't unified with *:
+
+  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
+    Functor (Compose f g) where ...
+
+The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
+
+  1. Collect all of a datatype's subtypes which require functor-like
+     constraints.
+  2. For each subtype, create a substitution by unifying the subtype's kind
+     with (* -> *).
+  3. Compose all the substitutions into one, then apply that substitution to
+     all of the in-scope type variables and the instance types.
+
+Note [Getting base classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Typeable are defined in package 'base', and that is not available
+when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
+ghc-prim does not use Functor or Typeable implicitly via these lookups.
+
+Note [Deriving and unboxed types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have some special hacks to support things like
+   data T = MkT Int# deriving ( Show )
+
+Specifically, we use TcGenDeriv.box to box the Int# into an Int
+(which we know how to show), and append a '#'. Parentheses are not required
+for unboxed values (`MkT -3#` is a valid expression).
+
+Note [Superclasses of derived instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+        data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+        data T a = MkT deriving( Data )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+        instance Typeable a => Data (T a) where ...
+
+
+************************************************************************
+*                                                                      *
+         Finding the fixed point of deriving equations
+*                                                                      *
+************************************************************************
+
+Note [Simplifying the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        data T a b = C1 (Foo a) (Bar b)
+                   | C2 Int (T b a)
+                   | C3 (T a a)
+                   deriving (Eq)
+
+We want to come up with an instance declaration of the form
+
+        instance (Ping a, Pong b, ...) => Eq (T a b) where
+                x == y = ...
+
+It is pretty easy, albeit tedious, to fill in the code "...".  The
+trick is to figure out what the context for the instance decl is,
+namely Ping, Pong and friends.
+
+Let's call the context reqd for the T instance of class C at types
+(a,b, ...)  C (T a b).  Thus:
+
+        Eq (T a b) = (Ping a, Pong b, ...)
+
+Now we can get a (recursive) equation from the data decl.  This part
+is done by inferConstraintsDataConArgs.
+
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+
+Foo and Bar may have explicit instances for Eq, in which case we can
+just substitute for them.  Alternatively, either or both may have
+their Eq instances given by deriving clauses, in which case they
+form part of the system of equations.
+
+Now all we need do is simplify and solve the equations, iterating to
+find the least fixpoint.  This is done by simplifyInstanceConstraints.
+Notice that the order of the arguments can
+switch around, as here in the recursive calls to T.
+
+Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
+
+We start with:
+
+        Eq (T a b) = {}         -- The empty set
+
+Next iteration:
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+        After simplification:
+                   = Eq a u Ping b u {} u {} u {}
+                   = Eq a u Ping b
+
+Next iteration:
+
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+        After simplification:
+                   = Eq a u Ping b
+                   u (Eq b u Ping a)
+                   u (Eq a u Ping a)
+
+                   = Eq a u Ping b u Eq b u Ping a
+
+The next iteration gives the same result, so this is the fixpoint.  We
+need to make a canonical form of the RHS to ensure convergence.  We do
+this by simplifying the RHS to a form in which
+
+        - the classes constrain only tyvars
+        - the list is sorted by tyvar (major key) and then class (minor key)
+        - no duplicates, of course
+
+Note [Deterministic simplifyInstanceContexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting
+with nonDetCmpType puts the returned lists in a nondeterministic order.
+If we were to return them, we'd get class constraints in
+nondeterministic order.
+
+Consider:
+
+  data ADT a b = Z a b deriving Eq
+
+The generated code could be either:
+
+  instance (Eq a, Eq b) => Eq (Z a b) where
+
+Or:
+
+  instance (Eq b, Eq a) => Eq (Z a b) where
+
+To prevent the order from being nondeterministic we only
+canonicalize when comparing and return them in the same order as
+simplifyDeriv returned them.
+See also Note [nonDetCmpType nondeterminism]
+-}
+
+
+simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]
+                         -> TcM [DerivSpec ThetaType]
+-- Used only for deriving clauses or standalone deriving with an
+-- extra-constraints wildcard (InferContext)
+-- See Note [Simplifying the instance context]
+
+simplifyInstanceContexts [] = return []
+
+simplifyInstanceContexts infer_specs
+  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
+        ; iterate_deriv 1 initial_solutions }
+  where
+    ------------------------------------------------------------------
+        -- The initial solutions for the equations claim that each
+        -- instance has an empty context; this solution is certainly
+        -- in canonical form.
+    initial_solutions :: [ThetaType]
+    initial_solutions = [ [] | _ <- infer_specs ]
+
+    ------------------------------------------------------------------
+        -- iterate_deriv calculates the next batch of solutions,
+        -- compares it with the current one; finishes if they are the
+        -- same, otherwise recurses with the new solutions.
+        -- It fails if any iteration fails
+    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
+    iterate_deriv n current_solns
+      | n > 20  -- Looks as if we are in an infinite loop
+                -- This can happen if we have -XUndecidableInstances
+                -- (See TcSimplify.tcSimplifyDeriv.)
+      = pprPanic "solveDerivEqns: probable loop"
+                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
+      | otherwise
+      = do {      -- Extend the inst info from the explicit instance decls
+                  -- with the current set of solutions, and simplify each RHS
+             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs
+           ; new_solns <- checkNoErrs $
+                          extendLocalInstEnv inst_specs $
+                          mapM gen_soln infer_specs
+
+           ; if (current_solns `eqSolution` new_solns) then
+                return [ spec { ds_theta = soln }
+                       | (spec, soln) <- zip infer_specs current_solns ]
+             else
+                iterate_deriv (n+1) new_solns }
+
+    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)
+       -- Canonicalise for comparison
+       -- See Note [Deterministic simplifyInstanceContexts]
+    canSolution = map (sortBy nonDetCmpType)
+    ------------------------------------------------------------------
+    gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType
+    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
+      = setSrcSpan loc  $
+        addErrCtxt (derivInstCtxt the_pred) $
+        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
+                -- checkValidInstance tyvars theta clas inst_tys
+                -- Not necessary; see Note [Exotic derived instance contexts]
+
+           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
+                -- Claim: the result instance declaration is guaranteed valid
+                -- Hence no need to call:
+                --   checkValidInstance tyvars theta clas inst_tys
+           ; return theta }
+      where
+        the_pred = mkClassPred clas inst_tys
+
+derivInstCtxt :: PredType -> MsgDoc
+derivInstCtxt pred
+  = text "When deriving the instance for" <+> parens (ppr pred)
+
+{-
+***********************************************************************************
+*                                                                                 *
+*            Simplify derived constraints
+*                                                                                 *
+***********************************************************************************
+-}
+
+-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much
+-- as possible. Fail if not possible.
+simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are
+                          -- deriving.  Only used for SkolemInfo.
+              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.
+              -> [ThetaOrigin] -- ^ Given and wanted constraints
+              -> TcM ThetaType -- ^ Needed constraints (after simplification),
+                               -- i.e. @['PredType']@.
+simplifyDeriv pred tvs thetas
+  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+                -- The constraint solving machinery
+                -- expects *TcTyVars* not TyVars.
+                -- We use *non-overlappable* (vanilla) skolems
+                -- See Note [Overlap and deriving]
+
+       ; let skol_set  = mkVarSet tvs_skols
+             skol_info = DerivSkol pred
+             doc = text "deriving" <+> parens (ppr pred)
+
+             mk_given_ev :: PredType -> TcM EvVar
+             mk_given_ev given =
+               let given_pred = substTy skol_subst given
+               in newEvVar given_pred
+
+             emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM ()
+             emit_wanted_constraints metas_to_be preds
+               = do { -- We instantiate metas_to_be with fresh meta type
+                      -- variables. Currently, these can only be type variables
+                      -- quantified in generic default type signatures.
+                      -- See Note [Gathering and simplifying constraints for
+                      -- DeriveAnyClass]
+                      (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be
+
+                    -- Now make a constraint for each of the instantiated predicates
+                    ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst
+                          mk_wanted_ct (PredOrigin wanted orig t_or_k)
+                            = do { ev <- newWanted orig (Just t_or_k) $
+                                         substTyUnchecked wanted_subst wanted
+                                 ; return (mkNonCanonical ev) }
+                    ; cts <- mapM mk_wanted_ct preds
+
+                    -- And emit them into the monad
+                    ; emitSimples (listToCts cts) }
+
+             -- Create the implications we need to solve. For stock and newtype
+             -- deriving, these implication constraints will be simple class
+             -- constraints like (C a, Ord b).
+             -- But with DeriveAnyClass, we make an implication constraint.
+             -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+             mk_wanteds :: ThetaOrigin -> TcM WantedConstraints
+             mk_wanteds (ThetaOrigin { to_anyclass_skols  = ac_skols
+                                     , to_anyclass_metas  = ac_metas
+                                     , to_anyclass_givens = ac_givens
+                                     , to_wanted_origins  = preds })
+               = do { ac_given_evs <- mapM mk_given_ev ac_givens
+                    ; (_, wanteds)
+                        <- captureConstraints $
+                           checkConstraints skol_info ac_skols ac_given_evs $
+                              -- The checkConstraints bumps the TcLevel, and
+                              -- wraps the wanted constraints in an implication,
+                              -- when (but only when) necessary
+                           emit_wanted_constraints ac_metas preds
+                    ; pure wanteds }
+
+       -- See [STEP DAC BUILD]
+       -- Generate the implication constraints, one for each method, to solve
+       -- with the skolemized variables.  Start "one level down" because
+       -- we are going to wrap the result in an implication with tvs_skols,
+       -- in step [DAC RESIDUAL]
+       ; (tc_lvl, wanteds) <- pushTcLevelM $
+                              mapM mk_wanteds thetas
+
+       ; traceTc "simplifyDeriv inputs" $
+         vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]
+
+       -- See [STEP DAC SOLVE]
+       -- Simplify the constraints, starting at the same level at which
+       -- they are generated (c.f. the call to runTcSWithEvBinds in
+       -- simplifyInfer)
+       ; solved_wanteds <- setTcLevel tc_lvl   $
+                           runTcSDeriveds      $
+                           solveWantedsAndDrop $
+                           unionsWC wanteds
+
+       -- It's not yet zonked!  Obviously zonk it before peering at it
+       ; solved_wanteds <- zonkWC solved_wanteds
+
+       -- See [STEP DAC HOIST]
+       -- Split the resulting constraints into bad and good constraints,
+       -- building an @unsolved :: WantedConstraints@ representing all
+       -- the constraints we can't just shunt to the predicates.
+       -- See Note [Exotic derived instance contexts]
+       ; let residual_simple = approximateWC True solved_wanteds
+             (bad, good) = partitionBagWith get_good residual_simple
+
+             get_good :: Ct -> Either Ct PredType
+             get_good ct | validDerivPred skol_set p
+                         , isWantedCt ct
+                         = Right p
+                          -- TODO: This is wrong
+                          -- NB re 'isWantedCt': residual_wanted may contain
+                          -- unsolved CtDerived and we stick them into the
+                          -- bad set so that reportUnsolved may decide what
+                          -- to do with them
+                         | otherwise
+                         = Left ct
+                           where p = ctPred ct
+
+       ; traceTc "simplifyDeriv outputs" $
+         vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]
+
+       -- Return the good unsolved constraints (unskolemizing on the way out.)
+       ; let min_theta = mkMinimalBySCs id (bagToList good)
+             -- An important property of mkMinimalBySCs (used above) is that in
+             -- addition to removing constraints that are made redundant by
+             -- superclass relationships, it also removes _duplicate_
+             -- constraints.
+             -- See Note [Gathering and simplifying constraints for
+             --           DeriveAnyClass]
+             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs
+                          -- The reverse substitution (sigh)
+
+       -- See [STEP DAC RESIDUAL]
+       ; min_theta_vars <- mapM newEvVar min_theta
+       ; (leftover_implic, _)
+           <- buildImplicationFor tc_lvl skol_info tvs_skols
+                                  min_theta_vars solved_wanteds
+       -- This call to simplifyTop is purely for error reporting
+       -- See Note [Error reporting for deriving clauses]
+       -- See also Note [Exotic derived instance contexts], which are caught
+       -- in this line of code.
+       ; simplifyTopImplic leftover_implic
+
+       ; return (substTheta subst_skol min_theta) }
+
+{-
+Note [Overlap and deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider some overlapping instances:
+  instance Show a => Show [a] where ..
+  instance Show [Char] where ...
+
+Now a data type with deriving:
+  data T a = MkT [a] deriving( Show )
+
+We want to get the derived instance
+  instance Show [a] => Show (T a) where...
+and NOT
+  instance Show a => Show (T a) where...
+so that the (Show (T Char)) instance does the Right Thing
+
+It's very like the situation when we're inferring the type
+of a function
+   f x = show [x]
+and we want to infer
+   f :: Show [a] => a -> String
+
+BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
+             the context for the derived instance.
+             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
+
+Note [Gathering and simplifying constraints for DeriveAnyClass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DeriveAnyClass works quite differently from stock and newtype deriving in
+the way it gathers and simplifies constraints to be used in a derived
+instance's context. Stock and newtype deriving gather constraints by looking
+at the data constructors of the data type for which we are deriving an
+instance. But DeriveAnyClass doesn't need to know about a data type's
+definition at all!
+
+To see why, consider this example of DeriveAnyClass:
+
+  class Foo a where
+    bar :: forall b. Ix b => a -> b -> String
+    default bar :: (Show a, Ix c) => a -> c -> String
+    bar x y = show x ++ show (range (y,y))
+
+    baz :: Eq a => a -> a -> Bool
+    default baz :: (Ord a, Show a) => a -> a -> Bool
+    baz x y = compare x y == EQ
+
+Because 'bar' and 'baz' have default signatures, this generates a top-level
+definition for these generic default methods
+
+  $gdm_bar :: forall a. Foo a
+           => forall c. (Show a, Ix c)
+           => a -> c -> String
+  $gdm_bar x y = show x ++ show (range (y,y))
+
+(and similarly for baz).  Now consider a 'deriving' clause
+  data Maybe s = ... deriving Foo
+
+This derives an instance of the form:
+  instance (CX) => Foo (Maybe s) where
+    bar = $gdm_bar
+    baz = $gdm_baz
+
+Now it is GHC's job to fill in a suitable instance context (CX).  If
+GHC were typechecking the binding
+   bar = $gdm bar
+it would
+   * skolemise the expected type of bar
+   * instantiate the type of $gdm_bar with meta-type variables
+   * build an implication constraint
+
+[STEP DAC BUILD]
+So that's what we do.  We build the constraint (call it C1)
+
+   forall[2] b. Ix b => (Show (Maybe s), Ix cc,
+                        Maybe s -> b -> String
+                            ~ Maybe s -> cc -> String)
+
+Here:
+* The level of this forall constraint is forall[2], because we are later
+  going to wrap it in a forall[1] in [STEP DAC RESIDUAL]
+
+* The 'b' comes from the quantified type variable in the expected type
+  of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification
+  variable that comes from instantiating the quantified type variable 'c' in
+  $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin).
+
+* The (Ix b) constraint comes from the context of bar's type
+  (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc)
+  constraints come from the context of $gdm_bar's type
+  (i.e., 'to_anyclass_givens' in 'ThetaOrigin').
+
+* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)
+  comes from marrying up the instantiated type of $gdm_bar with the specified
+  type of bar. Notice that the type variables from the instance, 's' in this
+  case, are global to this constraint.
+
+Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new
+unification variable for each iteration of simplifyDeriv. If we re-use the same
+unification variable across multiple iterations, then bad things can happen,
+such as #14933.
+
+Similarly for 'baz', givng the constraint C2
+
+   forall[2]. Eq (Maybe s) => (Ord a, Show a,
+                              Maybe s -> Maybe s -> Bool
+                                ~ Maybe s -> Maybe s -> Bool)
+
+In this case baz has no local quantification, so the implication
+constraint has no local skolems and there are no unification
+variables.
+
+[STEP DAC SOLVE]
+We can combine these two implication constraints into a single
+constraint (C1, C2), and simplify, unifying cc:=b, to get:
+
+   forall[2] b. Ix b => Show a
+   /\
+   forall[2]. Eq (Maybe s) => (Ord a, Show a)
+
+[STEP DAC HOIST]
+Let's call that (C1', C2').  Now we need to hoist the unsolved
+constraints out of the implications to become our candidate for
+(CX). That is done by approximateWC, which will return:
+
+  (Show a, Ord a, Show a)
+
+Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving
+
+  (Show a, Ord a)
+
+And that's what GHC uses for CX.
+
+[STEP DAC RESIDUAL]
+In this case we have solved all the leftover constraints, but what if
+we don't?  Simple!  We just form the final residual constraint
+
+   forall[1] s. CX => (C1',C2')
+
+and simplify that. In simple cases it'll succeed easily, because CX
+literally contains the constraints in C1', C2', but if there is anything
+more complicated it will be reported in a civilised way.
+
+Note [Error reporting for deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A suprisingly tricky aspect of deriving to get right is reporting sensible
+error messages. In particular, if simplifyDeriv reaches a constraint that it
+cannot solve, which might include:
+
+1. Insoluble constraints
+2. "Exotic" constraints (See Note [Exotic derived instance contexts])
+
+Then we report an error immediately in simplifyDeriv.
+
+Another possible choice is to punt and let another part of the typechecker
+(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead
+to worse error messages, so we do it directly in simplifyDeriv.
+
+simplifyDeriv checks for errors in a clever way. If the deriving machinery
+infers the context (Foo a)--that is, if this instance is to be generated:
+
+  instance Foo a => ...
+
+Then we form an implication of the form:
+
+  forall a. Foo a => <residual_wanted_constraints>
+
+And pass it to the simplifier. If the context (Foo a) is enough to discharge
+all the constraints in <residual_wanted_constraints>, then everything is
+hunky-dory. But if <residual_wanted_constraints> contains, say, an insoluble
+constraint, then (Foo a) won't be able to solve it, causing GHC to error.
+
+Note [Exotic derived instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a 'derived' instance declaration, we *infer* the context.  It's a
+bit unclear what rules we should apply for this; the Haskell report is
+silent.  Obviously, constraints like (Eq a) are fine, but what about
+        data T f a = MkT (f a) deriving( Eq )
+where we'd get an Eq (f a) constraint.  That's probably fine too.
+
+One could go further: consider
+        data T a b c = MkT (Foo a b c) deriving( Eq )
+        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
+
+Notice that this instance (just) satisfies the Paterson termination
+conditions.  Then we *could* derive an instance decl like this:
+
+        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
+even though there is no instance for (C Int a), because there just
+*might* be an instance for, say, (C Int Bool) at a site where we
+need the equality instance for T's.
+
+However, this seems pretty exotic, and it's quite tricky to allow
+this, and yet give sensible error messages in the (much more common)
+case where we really want that instance decl for C.
+
+So for now we simply require that the derived instance context
+should have only type-variable constraints.
+
+Here is another example:
+        data Fix f = In (f (Fix f)) deriving( Eq )
+Here, if we are prepared to allow -XUndecidableInstances we
+could derive the instance
+        instance Eq (f (Fix f)) => Eq (Fix f)
+but this is so delicate that I don't think it should happen inside
+'deriving'. If you want this, write it yourself!
+
+NB: if you want to lift this condition, make sure you still meet the
+termination conditions!  If not, the deriving mechanism generates
+larger and larger constraints.  Example:
+  data Succ a = S a
+  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
+
+Note the lack of a Show instance for Succ.  First we'll generate
+  instance (Show (Succ a), Show a) => Show (Seq a)
+and then
+  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
+and so on.  Instead we want to complain of no instance for (Show (Succ a)).
+
+The bottom line
+~~~~~~~~~~~~~~~
+Allow constraints which consist only of type variables, with no repeats.
+-}
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -0,0 +1,976 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Error-checking and other utilities for @deriving@ clauses or declarations.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+
+module TcDerivUtils (
+        DerivM, DerivEnv(..),
+        DerivSpec(..), pprDerivSpec,
+        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
+        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
+        DerivContext(..), OriginativeDerivStatus(..),
+        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
+        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
+        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
+        checkOriginativeSideConditions, hasStockDeriving,
+        canDeriveAnyClass,
+        std_class_via_coercible, non_coercible_class,
+        newDerivClsInst, extendLocalInstEnv
+    ) where
+
+import GhcPrelude
+
+import Bag
+import BasicTypes
+import Class
+import DataCon
+import DynFlags
+import ErrUtils
+import HscTypes (lookupFixity, mi_fix)
+import HsSyn
+import Inst
+import InstEnv
+import LoadIface (loadInterfaceForName)
+import Module (getModule)
+import Name
+import Outputable
+import PrelNames
+import SrcLoc
+import TcGenDeriv
+import TcGenFunctor
+import TcGenGenerics
+import TcRnMonad
+import TcType
+import THNames (liftClassKey)
+import TyCon
+import Type
+import Util
+import VarSet
+
+import Control.Monad.Trans.Reader
+import Data.Maybe
+import qualified GHC.LanguageExtensions as LangExt
+import ListSetOps (assocMaybe)
+
+-- | To avoid having to manually plumb everything in 'DerivEnv' throughout
+-- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which
+-- is a simple reader around 'TcRn'.
+type DerivM = ReaderT DerivEnv TcRn
+
+-- | Is GHC processing a standalone deriving declaration?
+isStandaloneDeriv :: DerivM Bool
+isStandaloneDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = True
+
+-- | Is GHC processing a standalone deriving declaration with an
+-- extra-constraints wildcard as the context?
+-- (e.g., @deriving instance _ => Eq (Foo a)@)
+isStandaloneWildcardDeriv :: DerivM Bool
+isStandaloneWildcardDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = False
+
+-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
+-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
+mkDerivOrigin :: Bool -> CtOrigin
+mkDerivOrigin standalone_wildcard
+  | standalone_wildcard = StandAloneDerivOrigin
+  | otherwise           = DerivClauseOrigin
+
+-- | Contains all of the information known about a derived instance when
+-- determining what its @EarlyDerivSpec@ should be.
+data DerivEnv = DerivEnv
+  { denv_overlap_mode :: Maybe OverlapMode
+    -- ^ Is this an overlapping instance?
+  , denv_tvs          :: [TyVar]
+    -- ^ Universally quantified type variables in the instance
+  , denv_cls          :: Class
+    -- ^ Class for which we need to derive an instance
+  , denv_cls_tys      :: [Type]
+    -- ^ Other arguments to the class except the last
+  , denv_tc           :: TyCon
+    -- ^ Type constructor for which the instance is requested
+    --   (last arguments to the type class)
+  , denv_tc_args      :: [Type]
+    -- ^ Arguments to the type constructor
+  , denv_rep_tc       :: TyCon
+    -- ^ The representation tycon for 'denv_tc'
+    --   (for data family instances)
+  , denv_rep_tc_args  :: [Type]
+    -- ^ The representation types for 'denv_tc_args'
+    --   (for data family instances)
+  , denv_ctxt         :: DerivContext
+    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
+    --   context of the instance).
+    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
+    --   uses a wildcard constraint.
+    --   See @Note [Inferring the instance context]@.
+  , denv_strat        :: Maybe (DerivStrategy GhcTc)
+    -- ^ 'Just' if user requests a particular deriving strategy.
+    --   Otherwise, 'Nothing'.
+  }
+
+instance Outputable DerivEnv where
+  ppr (DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_tc           = tc
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tc
+                , denv_rep_tc_args  = rep_tc_args
+                , denv_ctxt         = ctxt
+                , denv_strat        = mb_strat })
+    = hang (text "DerivEnv")
+         2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
+                 , text "denv_tvs"          <+> ppr tvs
+                 , text "denv_cls"          <+> ppr cls
+                 , text "denv_cls_tys"      <+> ppr cls_tys
+                 , text "denv_tc"           <+> ppr tc
+                 , text "denv_tc_args"      <+> ppr tc_args
+                 , text "denv_rep_tc"       <+> ppr rep_tc
+                 , text "denv_rep_tc_args"  <+> ppr rep_tc_args
+                 , text "denv_ctxt"         <+> ppr ctxt
+                 , text "denv_strat"        <+> ppr mb_strat ])
+
+data DerivSpec theta = DS { ds_loc                 :: SrcSpan
+                          , ds_name                :: Name         -- DFun name
+                          , ds_tvs                 :: [TyVar]
+                          , ds_theta               :: theta
+                          , ds_cls                 :: Class
+                          , ds_tys                 :: [Type]
+                          , ds_tc                  :: TyCon
+                          , ds_overlap             :: Maybe OverlapMode
+                          , ds_standalone_wildcard :: Maybe SrcSpan
+                              -- See Note [Inferring the instance context]
+                              -- in TcDerivInfer
+                          , ds_mechanism           :: DerivSpecMechanism }
+        -- This spec implies a dfun declaration of the form
+        --       df :: forall tvs. theta => C tys
+        -- The Name is the name for the DFun we'll build
+        -- The tyvars bind all the variables in the theta
+        -- For type families, the tycon in
+        --       in ds_tys is the *family* tycon
+        --       in ds_tc is the *representation* type
+        -- For non-family tycons, both are the same
+
+        -- the theta is either the given and final theta, in standalone deriving,
+        -- or the not-yet-simplified list of constraints together with their origin
+
+        -- ds_mechanism specifies the means by which GHC derives the instance.
+        -- See Note [Deriving strategies] in TcDeriv
+
+{-
+Example:
+
+     newtype instance T [a] = MkT (Tree a) deriving( C s )
+==>
+     axiom T [a] = :RTList a
+     axiom :RTList a = Tree a
+
+     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
+        , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
+-}
+
+pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
+pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
+                   ds_tys = tys, ds_theta = rhs,
+                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })
+  = hang (text "DerivSpec")
+       2 (vcat [ text "ds_loc                  =" <+> ppr l
+               , text "ds_name                 =" <+> ppr n
+               , text "ds_tvs                  =" <+> ppr tvs
+               , text "ds_cls                  =" <+> ppr c
+               , text "ds_tys                  =" <+> ppr tys
+               , text "ds_theta                =" <+> ppr rhs
+               , text "ds_standalone_wildcard  =" <+> ppr wildcard
+               , text "ds_mechanism            =" <+> ppr mech ])
+
+instance Outputable theta => Outputable (DerivSpec theta) where
+  ppr = pprDerivSpec
+
+-- What action to take in order to derive a class instance.
+-- See Note [Deriving strategies] in TcDeriv
+data DerivSpecMechanism
+  = DerivSpecStock   -- "Standard" classes
+      (SrcSpan -> TyCon
+               -> [Type]
+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+      -- This function returns three things:
+      --
+      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
+      --    (e.g., @compare (T x) (T y) = compare x y@)
+      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived
+      --    instance. As examples, derived 'Generic' instances require
+      --    associated type family instances, and derived 'Eq' and 'Ord'
+      --    instances require top-level @con2tag@ functions.
+      --    See Note [Auxiliary binders] in TcGenDeriv.
+      -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be
+      --    suppressed. This is used to suppress unused warnings for record
+      --    selectors when deriving 'Read', 'Show', or 'Generic'.
+      --    See Note [Deriving and unused record selectors].
+
+  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
+      Type -- The newtype rep type
+
+  | DerivSpecAnyClass -- -XDeriveAnyClass
+
+  | DerivSpecVia -- -XDerivingVia
+      Type -- The @via@ type
+
+-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
+derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
+derivSpecMechanismToStrategy DerivSpecStock{}   = StockStrategy
+derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy
+derivSpecMechanismToStrategy DerivSpecAnyClass  = AnyclassStrategy
+derivSpecMechanismToStrategy (DerivSpecVia t)   = ViaStrategy t
+
+isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
+  :: DerivSpecMechanism -> Bool
+isDerivSpecStock (DerivSpecStock{}) = True
+isDerivSpecStock _                  = False
+
+isDerivSpecNewtype (DerivSpecNewtype{}) = True
+isDerivSpecNewtype _                    = False
+
+isDerivSpecAnyClass DerivSpecAnyClass = True
+isDerivSpecAnyClass _                 = False
+
+isDerivSpecVia (DerivSpecVia{}) = True
+isDerivSpecVia _                = False
+
+instance Outputable DerivSpecMechanism where
+  ppr (DerivSpecStock{})   = text "DerivSpecStock"
+  ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t
+  ppr DerivSpecAnyClass    = text "DerivSpecAnyClass"
+  ppr (DerivSpecVia t)     = text "DerivSpecVia" <> colon <+> ppr t
+
+-- | Whether GHC is processing a @deriving@ clause or a standalone deriving
+-- declaration.
+data DerivContext
+  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
+                                 --
+                                 -- * A @deriving@ clause (in which case
+                                 --   @mb_wildcard@ is 'Nothing').
+                                 --
+                                 -- * A standalone deriving declaration with
+                                 --   an extra-constraints wildcard as the
+                                 --   context (in which case @mb_wildcard@ is
+                                 --   @'Just' loc@, where @loc@ is the location
+                                 --   of the wildcard.
+                                 --
+                                 -- GHC should infer the context.
+
+  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
+                                 -- deriving declaration, where @theta@ is the
+                                 -- context supplied by the user.
+
+instance Outputable DerivContext where
+  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone
+  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta
+
+-- | Records whether a particular class can be derived by way of an
+-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).
+--
+-- See @Note [Deriving strategies]@ in "TcDeriv".
+data OriginativeDerivStatus
+  = CanDeriveStock            -- Stock class, can derive
+      (SrcSpan -> TyCon -> [Type]
+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+  | StockClassError SDoc      -- Stock class, but can't do it
+  | CanDeriveAnyClass         -- See Note [Deriving any class]
+  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass
+
+-- A stock class is one either defined in the Haskell report or for which GHC
+-- otherwise knows how to generate code for (possibly requiring the use of a
+-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)
+
+-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
+-- and whether or the constraint deals in types or kinds.
+data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
+
+-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to
+-- simplify when inferring a derived instance's context. These are used in all
+-- deriving strategies, but in the particular case of @DeriveAnyClass@, we
+-- need extra information. In particular, we need:
+--
+-- * 'to_anyclass_skols', the list of type variables bound by a class method's
+--   regular type signature, which should be rigid.
+--
+-- * 'to_anyclass_metas', the list of type variables bound by a class method's
+--   default type signature. These can be unified as necessary.
+--
+-- * 'to_anyclass_givens', the list of constraints from a class method's
+--   regular type signature, which can be used to help solve constraints
+--   in the 'to_wanted_origins'.
+--
+-- (Note that 'to_wanted_origins' will likely contain type variables from the
+-- derived type class or data type, neither of which will appear in
+-- 'to_anyclass_skols' or 'to_anyclass_metas'.)
+--
+-- For all other deriving strategies, it is always the case that
+-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are
+-- empty.
+--
+-- Here is an example to illustrate this:
+--
+-- @
+-- class Foo a where
+--   bar :: forall b. Ix b => a -> b -> String
+--   default bar :: forall y. (Show a, Ix y) => a -> y -> String
+--   bar x y = show x ++ show (range (y, y))
+--
+--   baz :: Eq a => a -> a -> Bool
+--   default baz :: Ord a => a -> a -> Bool
+--   baz x y = compare x y == EQ
+--
+-- data Quux q = Quux deriving anyclass Foo
+-- @
+--
+-- Then it would generate two 'ThetaOrigin's, one for each method:
+--
+-- @
+-- [ ThetaOrigin { to_anyclass_skols  = [b]
+--               , to_anyclass_metas  = [y]
+--               , to_anyclass_givens = [Ix b]
+--               , to_wanted_origins  = [ Show (Quux q), Ix y
+--                                      , (Quux q -> b -> String) ~
+--                                        (Quux q -> y -> String)
+--                                      ] }
+-- , ThetaOrigin { to_anyclass_skols  = []
+--               , to_anyclass_metas  = []
+--               , to_anyclass_givens = [Eq (Quux q)]
+--               , to_wanted_origins  = [ Ord (Quux q)
+--                                      , (Quux q -> Quux q -> Bool) ~
+--                                        (Quux q -> Quux q -> Bool)
+--                                      ] }
+-- ]
+-- @
+--
+-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
+-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)
+--
+-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
+-- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are
+-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',
+-- 'to_anyclass_metas', and 'to_anyclass_givens' are used.
+data ThetaOrigin
+  = ThetaOrigin { to_anyclass_skols  :: [TyVar]
+                , to_anyclass_metas  :: [TyVar]
+                , to_anyclass_givens :: ThetaType
+                , to_wanted_origins  :: [PredOrigin] }
+
+instance Outputable PredOrigin where
+  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
+
+instance Outputable ThetaOrigin where
+  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols
+                   , to_anyclass_metas  = ac_metas
+                   , to_anyclass_givens = ac_givens
+                   , to_wanted_origins  = wanted_origins })
+    = hang (text "ThetaOrigin")
+         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols
+                 , text "to_anyclass_metas  =" <+> ppr ac_metas
+                 , text "to_anyclass_givens =" <+> ppr ac_givens
+                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])
+
+mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
+mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
+
+mkThetaOrigin :: CtOrigin -> TypeOrKind
+              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType
+              -> ThetaOrigin
+mkThetaOrigin origin t_or_k skols metas givens
+  = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k)
+
+-- A common case where the ThetaOrigin only contains wanted constraints, with
+-- no givens or locally scoped type variables.
+mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
+mkThetaOriginFromPreds = ThetaOrigin [] [] []
+
+substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
+substPredOrigin subst (PredOrigin pred origin t_or_k)
+  = PredOrigin (substTy subst pred) origin t_or_k
+
+{-
+************************************************************************
+*                                                                      *
+                Class deriving diagnostics
+*                                                                      *
+************************************************************************
+
+Only certain blessed classes can be used in a deriving clause (without the
+assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
+are listed below in the definition of hasStockDeriving. The stockSideConditions
+function determines the criteria that needs to be met in order for a particular
+stock class to be able to be derived successfully.
+
+A class might be able to be used in a deriving clause if -XDeriveAnyClass
+is willing to support it. The canDeriveAnyClass function checks if this is the
+case.
+-}
+
+hasStockDeriving
+  :: Class -> Maybe (SrcSpan
+                     -> TyCon
+                     -> [Type]
+                     -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+hasStockDeriving clas
+  = assocMaybe gen_list (getUnique clas)
+  where
+    gen_list
+      :: [(Unique, SrcSpan
+                   -> TyCon
+                   -> [Type]
+                   -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
+    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
+               , (ordClassKey,         simpleM gen_Ord_binds)
+               , (enumClassKey,        simpleM gen_Enum_binds)
+               , (boundedClassKey,     simple gen_Bounded_binds)
+               , (ixClassKey,          simpleM gen_Ix_binds)
+               , (showClassKey,        read_or_show gen_Show_binds)
+               , (readClassKey,        read_or_show gen_Read_binds)
+               , (dataClassKey,        simpleM gen_Data_binds)
+               , (functorClassKey,     simple gen_Functor_binds)
+               , (foldableClassKey,    simple gen_Foldable_binds)
+               , (traversableClassKey, simple gen_Traversable_binds)
+               , (liftClassKey,        simple gen_Lift_binds)
+               , (genClassKey,         generic (gen_Generic_binds Gen0))
+               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]
+
+    simple gen_fn loc tc _
+      = let (binds, deriv_stuff) = gen_fn loc tc
+        in return (binds, deriv_stuff, [])
+
+    simpleM gen_fn loc tc _
+      = do { (binds, deriv_stuff) <- gen_fn loc tc
+           ; return (binds, deriv_stuff, []) }
+
+    read_or_show gen_fn loc tc _
+      = do { fix_env <- getDataConFixityFun tc
+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+                 field_names          = all_field_names tc
+           ; return (binds, deriv_stuff, field_names) }
+
+    generic gen_fn _ tc inst_tys
+      = do { (binds, faminst) <- gen_fn tc inst_tys
+           ; let field_names = all_field_names tc
+           ; return (binds, unitBag (DerivFamInst faminst), field_names) }
+
+    -- See Note [Deriving and unused record selectors]
+    all_field_names = map flSelector . concatMap dataConFieldLabels
+                                     . tyConDataCons
+
+{-
+Note [Deriving and unused record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (see #13919):
+
+  module Main (main) where
+
+  data Foo = MkFoo {bar :: String} deriving Show
+
+  main :: IO ()
+  main = print (Foo "hello")
+
+Strictly speaking, the record selector `bar` is unused in this module, since
+neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
+However, the behavior of `main` is affected by the presence of `bar`, since
+it will print different output depending on whether `MkFoo` is defined using
+record selectors or not. Therefore, we do not to issue a
+"Defined but not used: ‘bar’" warning for this module, since removing `bar`
+changes the program's behavior. This is the reason behind the [Name] part of
+the return type of `hasStockDeriving`—it tracks all of the record selector
+`Name`s for which -Wunused-binds should be suppressed.
+
+Currently, the only three stock derived classes that require this are Read,
+Show, and Generic, as their derived code all depend on the record selectors
+of the derived data type's constructors.
+
+See also Note [Newtype deriving and unused constructors] in TcDeriv for
+another example of a similar trick.
+-}
+
+getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
+-- If the TyCon is locally defined, we want the local fixity env;
+-- but if it is imported (which happens for standalone deriving)
+-- we need to get the fixity env from the interface file
+-- c.f. RnEnv.lookupFixity, and #9830
+getDataConFixityFun tc
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name
+         then do { fix_env <- getFixityEnv
+                 ; return (lookupFixity fix_env) }
+         else do { iface <- loadInterfaceForName doc name
+                            -- Should already be loaded!
+                 ; return (mi_fix iface . nameOccName) } }
+  where
+    name = tyConName tc
+    doc = text "Data con fixities for" <+> ppr name
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for the originative
+-- deriving strategies (stock and anyclass).
+-- See Note [Deriving strategies] in TcDeriv for an explanation of what
+-- "originative" means.
+--
+-- This is *apart* from the coerce-based strategies, newtype and via.
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
+
+checkOriginativeSideConditions
+  :: DynFlags -> DerivContext -> Class -> [TcType]
+  -> TyCon -> TyCon
+  -> OriginativeDerivStatus
+checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc
+    -- First, check if stock deriving is possible...
+  | Just cond <- stockSideConditions deriv_ctxt cls
+  = case (cond dflags tc rep_tc) of
+        NotValid err -> StockClassError err  -- Class-specific error
+        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
+                   -- All stock derivable classes are unary in the sense that
+                   -- there should be not types in cls_tys (i.e., no type args
+                   -- other than last). Note that cls_types can contain
+                   -- invisible types as well (e.g., for Generic1, which is
+                   -- poly-kinded), so make sure those are not counted.
+                 , Just gen_fn <- hasStockDeriving cls
+                   -> CanDeriveStock gen_fn
+                 | otherwise -> StockClassError (classArgsErr cls cls_tys)
+                   -- e.g. deriving( Eq s )
+
+    -- ...if not, try falling back on DeriveAnyClass.
+  | NotValid err <- canDeriveAnyClass dflags
+  = NonDerivableClass err  -- Neither anyclass nor stock work
+
+  | otherwise
+  = CanDeriveAnyClass   -- DeriveAnyClass should work
+
+classArgsErr :: Class -> [Type] -> SDoc
+classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
+
+-- Side conditions (whether the datatype must have at least one constructor,
+-- required language extensions, etc.) for using GHC's stock deriving
+-- mechanism on certain classes (as opposed to classes that require
+-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
+-- class for which stock deriving isn't possible.
+stockSideConditions :: DerivContext -> Class -> Maybe Condition
+stockSideConditions deriv_ctxt cls
+  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
+  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
+  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
+  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
+  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
+  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK True False)
+  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK False True)
+                                           -- Functor/Fold/Trav works ok
+                                           -- for rank-n types
+  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK False False)
+  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_RepresentableOk)
+  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_Representable1Ok)
+  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
+  | otherwise                      = Nothing
+  where
+    cls_key = getUnique cls
+    cond_std     = cond_stdOK deriv_ctxt False
+      -- Vanilla data constructors, at least one, and monotype arguments
+    cond_vanilla = cond_stdOK deriv_ctxt True
+      -- Vanilla data constructors but allow no data cons or polytype arguments
+
+canDeriveAnyClass :: DynFlags -> Validity
+-- IsValid: we can (try to) derive it via an empty instance declaration
+-- NotValid s:  we can't, reason s
+canDeriveAnyClass dflags
+  | not (xopt LangExt.DeriveAnyClass dflags)
+  = NotValid (text "Try enabling DeriveAnyClass")
+  | otherwise
+  = IsValid   -- OK!
+
+type Condition
+   = DynFlags
+
+  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the
+              -- family 'TyCon'.
+
+  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.
+              -- Otherwise, this is the same as the other 'TyCon' argument.
+
+  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
+              -- possible. Otherwise, it's @'NotValid' err@, where @err@
+              -- explains what went wrong.
+
+orCond :: Condition -> Condition -> Condition
+orCond c1 c2 dflags tc rep_tc
+  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of
+     (IsValid,    _)          -> IsValid    -- c1 succeeds
+     (_,          IsValid)    -> IsValid    -- c21 succeeds
+     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)
+                                            -- Both fail
+
+andCond :: Condition -> Condition -> Condition
+andCond c1 c2 dflags tc rep_tc
+  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc
+
+-- | Some common validity checks shared among stock derivable classes. One
+-- check that absolutely must hold is that if an instance @C (T a)@ is being
+-- derived, then @T@ must be a tycon for a data type or a newtype. The
+-- remaining checks are only performed if using a @deriving@ clause (i.e.,
+-- they're ignored if using @StandaloneDeriving@):
+--
+-- 1. The data type must have at least one constructor (this check is ignored
+--    if using @EmptyDataDeriving@).
+--
+-- 2. The data type cannot have any GADT constructors.
+--
+-- 3. The data type cannot have any constructors with existentially quantified
+--    type variables.
+--
+-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
+--
+-- 5. The data type cannot have fields with higher-rank types.
+cond_stdOK
+  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
+                  -- user-supplied context, 'InferContext' if not.
+                  -- If it is the former, we relax some of the validity checks
+                  -- we would otherwise perform (i.e., "just go for it").
+
+  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
+                  -- types (with no data constructors) even in the absence of
+                  -- the -XEmptyDataDeriving extension.
+
+  -> Condition
+cond_stdOK deriv_ctxt permissive dflags tc rep_tc
+  = valid_ADT `andValid` valid_misc
+  where
+    valid_ADT, valid_misc :: Validity
+    valid_ADT
+      | isAlgTyCon tc || isDataFamilyTyCon tc
+      = IsValid
+      | otherwise
+        -- Complain about functions, primitive types, and other tycons that
+        -- stock deriving can't handle.
+      = NotValid $ text "The last argument of the instance must be a"
+               <+> text "data or newtype application"
+
+    valid_misc
+      = case deriv_ctxt of
+         SupplyContext _ -> IsValid
+                -- Don't check these conservative conditions for
+                -- standalone deriving; just generate the code
+                -- and let the typechecker handle the result
+         InferContext wildcard
+           | null data_cons -- 1.
+           , not permissive
+           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
+              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
+           | not (null con_whys)
+           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)
+           | otherwise
+           -> IsValid
+
+    empty_data_suggestion =
+      text "Use EmptyDataDeriving to enable deriving for empty data types"
+    possible_fix_suggestion wildcard
+      = case wildcard of
+          Just _ ->
+            text "Possible fix: fill in the wildcard constraint yourself"
+          Nothing ->
+            text "Possible fix: use a standalone deriving declaration instead"
+    data_cons  = tyConDataCons rep_tc
+    con_whys   = getInvalids (map check_con data_cons)
+
+    check_con :: DataCon -> Validity
+    check_con con
+      | not (null eq_spec) -- 2.
+      = bad "is a GADT"
+      | not (null ex_tvs) -- 3.
+      = bad "has existential type variables in its type"
+      | not (null theta) -- 4.
+      = bad "has constraints in its type"
+      | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5.
+      = bad "has a higher-rank type"
+      | otherwise
+      = IsValid
+      where
+        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
+        bad msg = NotValid (badCon con (text msg))
+
+no_cons_why :: TyCon -> SDoc
+no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
+                     text "must have at least one data constructor"
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc
+
+cond_Representable1Ok :: Condition
+cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc
+
+cond_enumOrProduct :: Class -> Condition
+cond_enumOrProduct cls = cond_isEnumeration `orCond`
+                         (cond_isProduct `andCond` cond_args cls)
+
+cond_args :: Class -> Condition
+-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
+-- by generating specialised code.  For others (eg 'Data') we don't.
+-- For even others (eg 'Lift'), unlifted types aren't even a special
+-- consideration!
+cond_args cls _ _ rep_tc
+  = case bad_args of
+      []     -> IsValid
+      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
+                             2 (text "for type" <+> quotes (ppr ty)))
+  where
+    bad_args = [ arg_ty | con <- tyConDataCons rep_tc
+                        , arg_ty <- dataConOrigArgTys con
+                        , isLiftedType_maybe arg_ty /= Just True
+                        , not (ok_ty arg_ty) ]
+
+    cls_key = classKey cls
+    ok_ty arg_ty
+     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
+     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
+     | cls_key == showClassKey = check_in arg_ty boxConTbl
+     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic
+     | otherwise               = False    -- Read, Ix etc
+
+    check_in :: Type -> [(Type,a)] -> Bool
+    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
+
+
+cond_isEnumeration :: Condition
+cond_isEnumeration _ _ rep_tc
+  | isEnumerationTyCon rep_tc = IsValid
+  | otherwise                 = NotValid why
+  where
+    why = sep [ quotes (pprSourceTyCon rep_tc) <+>
+                  text "must be an enumeration type"
+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
+                  -- See Note [Enumeration types] in TyCon
+
+cond_isProduct :: Condition
+cond_isProduct _ _ rep_tc
+  | isProductTyCon rep_tc = IsValid
+  | otherwise             = NotValid why
+  where
+    why = quotes (pprSourceTyCon rep_tc) <+>
+          text "must have precisely one constructor"
+
+cond_functorOK :: Bool -> Bool -> Condition
+-- OK for Functor/Foldable/Traversable class
+-- Currently: (a) at least one argument
+--            (b) don't use argument contravariantly
+--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
+--            (d) optionally: don't use function types
+--            (e) no "stupid context" on data type
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc
+  | null tc_tvs
+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
+              <+> text "must have some type parameters")
+
+  | not (null bad_stupid_theta)
+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
+              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
+
+  | otherwise
+  = allValid (map check_con data_cons)
+  where
+    tc_tvs            = tyConTyVars rep_tc
+    last_tv           = last tc_tvs
+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
+    is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred
+      -- See Note [Check that the type variable is truly universal]
+
+    data_cons = tyConDataCons rep_tc
+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
+
+    check_universal :: DataCon -> Validity
+    check_universal con
+      | allowExQuantifiedLastTyVar
+      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
+                -- in TcGenFunctor
+      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
+      , tv `elem` dataConUnivTyVars con
+      , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))
+      = IsValid   -- See Note [Check that the type variable is truly universal]
+      | otherwise
+      = NotValid (badCon con existential)
+
+    ft_check :: DataCon -> FFoldType Validity
+    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
+                      , ft_co_var = NotValid (badCon con covariant)
+                      , ft_fun = \x y -> if allowFunctions then x `andValid` y
+                                                           else NotValid (badCon con functions)
+                      , ft_tup = \_ xs  -> allValid xs
+                      , ft_ty_app = \_ x   -> x
+                      , ft_bad_app = NotValid (badCon con wrong_arg)
+                      , ft_forall = \_ x   -> x }
+
+    existential = text "must be truly polymorphic in the last argument of the data type"
+    covariant   = text "must not use the type variable in a function argument"
+    functions   = text "must not contain function types"
+    wrong_arg   = text "must use the type variable only as the last argument of a data type"
+
+checkFlag :: LangExt.Extension -> Condition
+checkFlag flag dflags _ _
+  | xopt flag dflags = IsValid
+  | otherwise        = NotValid why
+  where
+    why = text "You need " <> text flag_str
+          <+> text "to derive an instance for this class"
+    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of
+                 [s]   -> s
+                 other -> pprPanic "checkFlag" (ppr other)
+
+std_class_via_coercible :: Class -> Bool
+-- These standard classes can be derived for a newtype
+-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
+-- because giving so gives the same results as generating the boilerplate
+std_class_via_coercible clas
+  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+        -- Not Read/Show because they respect the type
+        -- Not Enum, because newtypes are never in Enum
+
+
+non_coercible_class :: Class -> Bool
+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
+-- by Coercible, even with -XGeneralizedNewtypeDeriving
+-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
+-- instance behave differently if there's a non-lawful Applicative out there.
+-- Besides, with roles, Coercible-deriving Traversable is ill-roled.
+non_coercible_class cls
+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+                         , genClassKey, gen1ClassKey, typeableClassKey
+                         , traversableClassKey, liftClassKey ])
+
+badCon :: DataCon -> SDoc -> SDoc
+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
+
+------------------------------------------------------------------
+
+newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
+newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
+                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
+  = newClsInst overlap_mode dfun_name tvs theta clas tys
+
+extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
+-- Add new locally-defined instances; don't bother to check
+-- for functional dependency errors -- that'll happen in TcInstDcls
+extendLocalInstEnv dfuns thing_inside
+ = do { env <- getGblEnv
+      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
+             env'      = env { tcg_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside }
+
+{-
+Note [Deriving any class]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Classic uses of a deriving clause, or a standalone-deriving declaration, are
+for:
+  * a stock class like Eq or Show, for which GHC knows how to generate
+    the instance code
+  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
+
+The DeriveAnyClass extension adds a third way to derive instances, based on
+empty instance declarations.
+
+The canonical use case is in combination with GHC.Generics and default method
+signatures. These allow us to have instance declarations being empty, but still
+useful, e.g.
+
+  data T a = ...blah..blah... deriving( Generic )
+  instance C a => C (T a)  -- No 'where' clause
+
+where C is some "random" user-defined class.
+
+This boilerplate code can be replaced by the more compact
+
+  data T a = ...blah..blah... deriving( Generic, C )
+
+if DeriveAnyClass is enabled.
+
+This is not restricted to Generics; any class can be derived, simply giving
+rise to an empty instance.
+
+Unfortunately, it is not clear how to determine the context (when using a
+deriving clause; in standalone deriving, the user provides the context).
+GHC uses the same heuristic for figuring out the class context that it uses for
+Eq in the case of *-kinded classes, and for Functor in the case of
+* -> *-kinded classes. That may not be optimal or even wrong. But in such
+cases, standalone deriving can still be used.
+
+Note [Check that the type variable is truly universal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For Functor and Traversable instances, we must check that the *last argument*
+of the type constructor is used truly universally quantified.  Example
+
+   data T a b where
+     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
+     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
+     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
+     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
+     T5 :: b -> T b b           -- No!  'b' is constrained
+     T6 :: T a (b,b)            -- No!  'b' is constrained
+
+Notice that only the first of these constructors is vanilla H-98. We only
+need to take care about the last argument (b in this case).  See #8678.
+Eg. for T1-T3 we can write
+
+     fmap f (T1 a b) = T1 a (f b)
+     fmap f (T2 b c) = T2 (f b) c
+     fmap f (T3 x)   = T3 (f x)
+
+We need not perform these checks for Foldable instances, however, since
+functions in Foldable can only consume existentially quantified type variables,
+rather than produce them (as is the case in Functor and Traversable functions.)
+As a result, T can have a derived Foldable instance:
+
+    foldr f z (T1 a b) = f b z
+    foldr f z (T2 b c) = f b z
+    foldr f z (T3 x)   = f x z
+    foldr f z (T4 x)   = f x z
+    foldr f z (T5 x)   = f x z
+    foldr _ z T6       = z
+
+See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.
+
+For Functor and Traversable, we must take care not to let type synonyms
+unfairly reject a type for not being truly universally quantified. An
+example of this is:
+
+    type C (a :: Constraint) b = a
+    data T a b = C (Show a) b => MkT b
+
+Here, the existential context (C (Show a) b) does technically mention the last
+type variable b. But this is OK, because expanding the type synonym C would
+give us the context (Show a), which doesn't mention b. Therefore, we must make
+sure to expand type synonyms before performing this check. Not doing so led to
+#13813.
+-}
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcEnv.hs
@@ -0,0 +1,1149 @@
+-- (c) The University of Glasgow 2006
+{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
+                                       -- orphan
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE TypeFamilies #-}
+
+module TcEnv(
+        TyThing(..), TcTyThing(..), TcId,
+
+        -- Instance environment, and InstInfo type
+        InstInfo(..), iDFunId, pprInstInfoDetails,
+        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
+        InstBindings(..),
+
+        -- Global environment
+        tcExtendGlobalEnv, tcExtendTyConEnv,
+        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
+        tcExtendGlobalValEnv,
+        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
+        tcLookupTyCon, tcLookupClass,
+        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
+        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
+        tcLookupLocatedClass, tcLookupAxiom,
+        lookupGlobal, ioLookupDataCon,
+
+        -- Local environment
+        tcExtendKindEnv, tcExtendKindEnvList,
+        tcExtendTyVarEnv, tcExtendNameTyVarEnv,
+        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
+        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
+        tcExtendBinderStack, tcExtendLocalTypeEnv,
+        isTypeClosedLetBndr,
+
+        tcLookup, tcLookupLocated, tcLookupLocalIds,
+        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
+        tcLookupLcl_maybe,
+        getInLocalScope,
+        wrongThingErr, pprBinders,
+
+        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
+        getTypeSigNames,
+        tcExtendRecEnv,         -- For knot-tying
+
+        -- Tidying
+        tcInitTidyEnv, tcInitOpenTidyEnv,
+
+        -- Instances
+        tcLookupInstance, tcGetInstEnvs,
+
+        -- Rules
+        tcExtendRules,
+
+        -- Defaults
+        tcGetDefaultTys,
+
+        -- Global type variables
+        tcGetGlobalTyCoVars,
+
+        -- Template Haskell stuff
+        checkWellStaged, tcMetaTy, thLevel,
+        topIdLvl, isBrackStage,
+
+        -- New Ids
+        newDFunName, newDFunName', newFamInstTyConName,
+        newFamInstAxiomName,
+        mkStableIdFromString, mkStableIdFromName,
+        mkWrapperName
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import IfaceEnv
+import TcRnMonad
+import TcMType
+import TcType
+import LoadIface
+import PrelNames
+import TysWiredIn
+import Id
+import Var
+import VarSet
+import RdrName
+import InstEnv
+import DataCon ( DataCon )
+import PatSyn  ( PatSyn )
+import ConLike
+import TyCon
+import Type
+import CoAxiom
+import Class
+import Name
+import NameSet
+import NameEnv
+import VarEnv
+import HscTypes
+import DynFlags
+import SrcLoc
+import BasicTypes hiding( SuccessFlag(..) )
+import Module
+import Outputable
+import Encoding
+import FastString
+import ListSetOps
+import ErrUtils
+import Util
+import Maybes( MaybeErr(..), orElse )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.IORef
+import Data.List
+import Control.Monad
+
+{- *********************************************************************
+*                                                                      *
+            An IO interface to looking up globals
+*                                                                      *
+********************************************************************* -}
+
+lookupGlobal :: HscEnv -> Name -> IO TyThing
+-- A variant of lookupGlobal_maybe for the clients which are not
+-- interested in recovering from lookup failure and accept panic.
+lookupGlobal hsc_env name
+  = do  {
+          mb_thing <- lookupGlobal_maybe hsc_env name
+        ; case mb_thing of
+            Succeeded thing -> return thing
+            Failed msg      -> pprPanic "lookupGlobal" msg
+        }
+
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- This may look up an Id that one one has previously looked up.
+-- If so, we are going to read its interface file, and add its bindings
+-- to the ExternalPackageTable.
+lookupGlobal_maybe hsc_env name
+  = do  {    -- Try local envt
+          let mod = icInteractiveModule (hsc_IC hsc_env)
+              dflags = hsc_dflags hsc_env
+              tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+
+        ; if nameIsLocalOrFrom tcg_semantic_mod name
+              then (return
+                (Failed (text "Can't find local name: " <+> ppr name)))
+                  -- Internal names can happen in GHCi
+              else
+           -- Try home package table and external package table
+          lookupImported_maybe hsc_env name
+        }
+
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+lookupImported_maybe hsc_env name
+  = do  { mb_thing <- lookupTypeHscEnv hsc_env name
+        ; case mb_thing of
+            Just thing -> return (Succeeded thing)
+            Nothing    -> importDecl_maybe hsc_env name
+            }
+
+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+importDecl_maybe hsc_env name
+  | Just thing <- wiredInNameTyThing_maybe name
+  = do  { when (needWiredInHomeIface thing)
+               (initIfaceLoad hsc_env (loadWiredInHomeIface name))
+                -- See Note [Loading instances for wired-in things]
+        ; return (Succeeded thing) }
+  | otherwise
+  = initIfaceLoad hsc_env (importDecl name)
+
+ioLookupDataCon :: HscEnv -> Name -> IO DataCon
+ioLookupDataCon hsc_env name = do
+  mb_thing <- ioLookupDataCon_maybe hsc_env name
+  case mb_thing of
+    Succeeded thing -> return thing
+    Failed msg      -> pprPanic "lookupDataConIO" msg
+
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
+ioLookupDataCon_maybe hsc_env name = do
+    thing <- lookupGlobal hsc_env name
+    return $ case thing of
+        AConLike (RealDataCon con) -> Succeeded con
+        _                          -> Failed $
+          pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
+                text "used as a data constructor"
+
+{-
+************************************************************************
+*                                                                      *
+*                      tcLookupGlobal                                  *
+*                                                                      *
+************************************************************************
+
+Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
+unless you know that the SrcSpan in the monad is already set to the
+span of the Name.
+-}
+
+
+tcLookupLocatedGlobal :: Located Name -> TcM TyThing
+-- c.f. IfaceEnvEnv.tcIfaceGlobal
+tcLookupLocatedGlobal name
+  = addLocM tcLookupGlobal name
+
+tcLookupGlobal :: Name -> TcM TyThing
+-- The Name is almost always an ExternalName, but not always
+-- In GHCi, we may make command-line bindings (ghci> let x = True)
+-- that bind a GlobalId, but with an InternalName
+tcLookupGlobal name
+  = do  {    -- Try local envt
+          env <- getGblEnv
+        ; case lookupNameEnv (tcg_type_env env) name of {
+                Just thing -> return thing ;
+                Nothing    ->
+
+                -- Should it have been in the local envt?
+                -- (NB: use semantic mod here, since names never use
+                -- identity module, see Note [Identity versus semantic module].)
+          if nameIsLocalOrFrom (tcg_semantic_mod env) name
+          then notFound name  -- Internal names can happen in GHCi
+          else
+
+           -- Try home package table and external package table
+    do  { mb_thing <- tcLookupImported_maybe name
+        ; case mb_thing of
+            Succeeded thing -> return thing
+            Failed msg      -> failWithTc msg
+        }}}
+
+-- Look up only in this module's global env't. Don't look in imports, etc.
+-- Panic if it's not there.
+tcLookupGlobalOnly :: Name -> TcM TyThing
+tcLookupGlobalOnly name
+  = do { env <- getGblEnv
+       ; return $ case lookupNameEnv (tcg_type_env env) name of
+                    Just thing -> thing
+                    Nothing    -> pprPanic "tcLookupGlobalOnly" (ppr name) }
+
+tcLookupDataCon :: Name -> TcM DataCon
+tcLookupDataCon name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        AConLike (RealDataCon con) -> return con
+        _                          -> wrongThingErr "data constructor" (AGlobal thing) name
+
+tcLookupPatSyn :: Name -> TcM PatSyn
+tcLookupPatSyn name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        AConLike (PatSynCon ps) -> return ps
+        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name
+
+tcLookupConLike :: Name -> TcM ConLike
+tcLookupConLike name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        AConLike cl -> return cl
+        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name
+
+tcLookupClass :: Name -> TcM Class
+tcLookupClass name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
+        _                                           -> wrongThingErr "class" (AGlobal thing) name
+
+tcLookupTyCon :: Name -> TcM TyCon
+tcLookupTyCon name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ATyCon tc -> return tc
+        _         -> wrongThingErr "type constructor" (AGlobal thing) name
+
+tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
+tcLookupAxiom name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ACoAxiom ax -> return ax
+        _           -> wrongThingErr "axiom" (AGlobal thing) name
+
+tcLookupLocatedGlobalId :: Located Name -> TcM Id
+tcLookupLocatedGlobalId = addLocM tcLookupId
+
+tcLookupLocatedClass :: Located Name -> TcM Class
+tcLookupLocatedClass = addLocM tcLookupClass
+
+tcLookupLocatedTyCon :: Located Name -> TcM TyCon
+tcLookupLocatedTyCon = addLocM tcLookupTyCon
+
+-- Find the instance that exactly matches a type class application.  The class arguments must be precisely
+-- the same as in the instance declaration (modulo renaming & casts).
+--
+tcLookupInstance :: Class -> [Type] -> TcM ClsInst
+tcLookupInstance cls tys
+  = do { instEnv <- tcGetInstEnvs
+       ; case lookupUniqueInstEnv instEnv cls tys of
+           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err
+           Right (inst, tys)
+             | uniqueTyVars tys -> return inst
+             | otherwise        -> failWithTc errNotExact
+       }
+  where
+    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
+
+    uniqueTyVars tys = all isTyVarTy tys
+                    && hasNoDups (map (getTyVar "tcLookupInstance") tys)
+
+tcGetInstEnvs :: TcM InstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetInstEnvs = do { eps <- getEps
+                   ; env <- getGblEnv
+                   ; return (InstEnvs { ie_global  = eps_inst_env eps
+                                      , ie_local   = tcg_inst_env env
+                                      , ie_visible = tcVisibleOrphanMods env }) }
+
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+    lookupThing = tcLookupGlobal
+
+{-
+************************************************************************
+*                                                                      *
+                Extending the global environment
+*                                                                      *
+************************************************************************
+-}
+
+setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
+-- Use this to update the global type env
+-- It updates both  * the normal tcg_type_env field
+--                  * the tcg_type_env_var field seen by interface files
+setGlobalTypeEnv tcg_env new_type_env
+  = do  {     -- Sync the type-envt variable seen by interface files
+           writeMutVar (tcg_type_env_var tcg_env) new_type_env
+         ; return (tcg_env { tcg_type_env = new_type_env }) }
+
+
+tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
+  -- Just extend the global environment with some TyThings
+  -- Do not extend tcg_tcs, tcg_patsyns etc
+tcExtendGlobalEnvImplicit things thing_inside
+   = do { tcg_env <- getGblEnv
+        ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
+        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+        ; setGblEnv tcg_env' thing_inside }
+
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
+  -- module being compiled, extend the global environment
+tcExtendGlobalEnv things thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
+                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
+       ; setGblEnv env' $
+            tcExtendGlobalEnvImplicit things thing_inside
+       }
+
+tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
+  -- module being compiled, extend the global environment
+tcExtendTyConEnv tycons thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
+       ; setGblEnv env' $
+         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
+       }
+
+tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
+  -- Same deal as tcExtendGlobalEnv, but for Ids
+tcExtendGlobalValEnv ids thing_inside
+  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
+
+tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
+-- Extend the global environments for the type/class knot tying game
+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
+tcExtendRecEnv gbl_stuff thing_inside
+ = do  { tcg_env <- getGblEnv
+       ; let ge'      = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
+             tcg_env' = tcg_env { tcg_type_env = ge' }
+         -- No need for setGlobalTypeEnv (which side-effects the
+         -- tcg_type_env_var); tcExtendRecEnv is used just
+         -- when kind-check a group of type/class decls. It would
+         -- in any case be wrong for an interface-file decl to end up
+         -- with a TcTyCon in it!
+       ; setGblEnv tcg_env' thing_inside }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The local environment}
+*                                                                      *
+************************************************************************
+-}
+
+tcLookupLocated :: Located Name -> TcM TcTyThing
+tcLookupLocated = addLocM tcLookup
+
+tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
+tcLookupLcl_maybe name
+  = do { local_env <- getLclTypeEnv
+       ; return (lookupNameEnv local_env name) }
+
+tcLookup :: Name -> TcM TcTyThing
+tcLookup name = do
+    local_env <- getLclTypeEnv
+    case lookupNameEnv local_env name of
+        Just thing -> return thing
+        Nothing    -> AGlobal <$> tcLookupGlobal name
+
+tcLookupTyVar :: Name -> TcM TcTyVar
+tcLookupTyVar name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATyVar _ tv -> return tv
+           _           -> pprPanic "tcLookupTyVar" (ppr name) }
+
+tcLookupId :: Name -> TcM Id
+-- Used when we aren't interested in the binding level, nor refinement.
+-- The "no refinement" part means that we return the un-refined Id regardless
+--
+-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
+tcLookupId name = do
+    thing <- tcLookupIdMaybe name
+    case thing of
+        Just id -> return id
+        _       -> pprPanic "tcLookupId" (ppr name)
+
+tcLookupIdMaybe :: Name -> TcM (Maybe Id)
+tcLookupIdMaybe name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATcId { tct_id = id} -> return $ Just id
+           AGlobal (AnId id)    -> return $ Just id
+           _                    -> return Nothing }
+
+tcLookupLocalIds :: [Name] -> TcM [TcId]
+-- We expect the variables to all be bound, and all at
+-- the same level as the lookup.  Only used in one place...
+tcLookupLocalIds ns
+  = do { env <- getLclEnv
+       ; return (map (lookup (tcl_env env)) ns) }
+  where
+    lookup lenv name
+        = case lookupNameEnv lenv name of
+                Just (ATcId { tct_id = id }) ->  id
+                _ -> pprPanic "tcLookupLocalIds" (ppr name)
+
+getInLocalScope :: TcM (Name -> Bool)
+getInLocalScope = do { lcl_env <- getLclTypeEnv
+                     ; return (`elemNameEnv` lcl_env) }
+
+tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
+-- Used only during kind checking, for TcThings that are
+--      ATcTyCon or APromotionErr
+-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
+tcExtendKindEnvList things thing_inside
+  = do { traceTc "tcExtendKindEnvList" (ppr things)
+       ; updLclEnv upd_env thing_inside }
+  where
+    upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
+
+tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
+-- A variant of tcExtendKindEvnList
+tcExtendKindEnv extra_env thing_inside
+  = do { traceTc "tcExtendKindEnv" (ppr extra_env)
+       ; updLclEnv upd_env thing_inside }
+  where
+    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
+
+-----------------------
+-- Scoped type and kind variables
+tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
+tcExtendTyVarEnv tvs thing_inside
+  = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
+
+tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
+tcExtendNameTyVarEnv binds thing_inside
+  -- this should be used only for explicitly mentioned scoped variables.
+  -- thus, no coercion variables
+  = do { tc_extend_local_env NotTopLevel
+                    [(name, ATyVar name tv) | (name, tv) <- binds] $
+         tcExtendBinderStack tv_binds $
+         thing_inside }
+  where
+    tv_binds :: [TcBinder]
+    tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
+
+isTypeClosedLetBndr :: Id -> Bool
+-- See Note [Bindings with closed types] in TcRnTypes
+isTypeClosedLetBndr = noFreeVarsOfType . idType
+
+tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
+-- Used for binding the recurive uses of Ids in a binding
+-- both top-level value bindings and and nested let/where-bindings
+-- Does not extend the TcBinderStack
+tcExtendRecIds pairs thing_inside
+  = tc_extend_local_env NotTopLevel
+          [ (name, ATcId { tct_id   = let_id
+                         , tct_info = NonClosedLet emptyNameSet False })
+          | (name, let_id) <- pairs ] $
+    thing_inside
+
+tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
+-- Used for binding the Ids that have a complete user type signature
+-- Does not extend the TcBinderStack
+tcExtendSigIds top_lvl sig_ids thing_inside
+  = tc_extend_local_env top_lvl
+          [ (idName id, ATcId { tct_id   = id
+                              , tct_info = info })
+          | id <- sig_ids
+          , let closed = isTypeClosedLetBndr id
+                info   = NonClosedLet emptyNameSet closed ]
+     thing_inside
+
+
+tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
+                  -> [TcId] -> TcM a -> TcM a
+-- Used for both top-level value bindings and and nested let/where-bindings
+-- Adds to the TcBinderStack too
+tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
+               ids thing_inside
+  = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
+    tc_extend_local_env top_lvl
+          [ (idName id, ATcId { tct_id   = id
+                              , tct_info = mk_tct_info id })
+          | id <- ids ]
+    thing_inside
+  where
+    mk_tct_info id
+      | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
+      | otherwise                             = NonClosedLet rhs_fvs type_closed
+      where
+        name        = idName id
+        rhs_fvs     = lookupNameEnv fvs name `orElse` emptyNameSet
+        type_closed = isTypeClosedLetBndr id &&
+                      (fv_type_closed || hasCompleteSig sig_fn name)
+
+tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
+-- For lambda-bound and case-bound Ids
+-- Extends the TcBinderStack as well
+tcExtendIdEnv ids thing_inside
+  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
+
+tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
+-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
+tcExtendIdEnv1 name id thing_inside
+  = tcExtendIdEnv2 [(name,id)] thing_inside
+
+tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
+tcExtendIdEnv2 names_w_ids thing_inside
+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+                        | (_,mono_id) <- names_w_ids ] $
+    tc_extend_local_env NotTopLevel
+            [ (name, ATcId { tct_id = id
+                           , tct_info    = NotLetBound })
+            | (name,id) <- names_w_ids]
+    thing_inside
+
+tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
+tc_extend_local_env top_lvl extra_env thing_inside
+-- Precondition: the argument list extra_env has TcTyThings
+--               that ATcId or ATyVar, but nothing else
+--
+-- Invariant: the ATcIds are fully zonked. Reasons:
+--      (a) The kinds of the forall'd type variables are defaulted
+--          (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
+--      (b) There are no via-Indirect occurrences of the bound variables
+--          in the types, because instantiation does not look through such things
+--      (c) The call to tyCoVarsOfTypes is ok without looking through refs
+
+-- The second argument of type TyVarSet is a set of type variables
+-- that are bound together with extra_env and should not be regarded
+-- as free in the types of extra_env.
+  = do  { traceTc "tc_extend_local_env" (ppr extra_env)
+        ; env0 <- getLclEnv
+        ; env1 <- tcExtendLocalTypeEnv env0 extra_env
+        ; stage <- getStage
+        ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
+        ; setLclEnv env2 thing_inside }
+  where
+    extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
+    -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
+    -- Reason for extending LocalRdrEnv: after running a TH splice we need
+    -- to do renaming.
+    extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env
+                                               , tcl_th_bndrs = th_bndrs })
+      = env { tcl_rdr      = extendLocalRdrEnvList rdr_env
+                                [ n | (n, _) <- pairs, isInternalName n ]
+                                -- The LocalRdrEnv contains only non-top-level names
+                                -- (GlobalRdrEnv handles the top level)
+            , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs
+                                 [(n, thlvl) | (n, ATcId {}) <- pairs] }
+
+tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv
+tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
+  | isEmptyVarSet extra_tvs
+  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })
+  | otherwise
+  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)
+       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)
+       ; return (lcl_env { tcl_tyvars = new_g_var
+                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
+  where
+    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
+
+    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
+      = case closed of
+          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )
+                       tvs
+          _other    -> tvs `unionVarSet` id_tvs
+        where
+           id_ty          = idType id
+           id_tvs         = tyCoVarsOfType id_ty
+           id_co_tvs      = closeOverKinds (coVarsOfType id_ty)
+           is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))
+           -- We only care about being closed wrt /type/ variables
+           -- E.g. a top-level binding might have a type like
+           --          foo :: t |> co
+           -- where co :: * ~ *
+           -- or some other as-yet-unsolved kind coercion
+
+    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]
+      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
+
+    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
+
+    get_tvs (_, AGlobal {})       tvs = tvs
+    get_tvs (_, APromotionErr {}) tvs = tvs
+
+        -- Note [Global TyVars]
+        -- It's important to add the in-scope tyvars to the global tyvar set
+        -- as well.  Consider
+        --      f (_::r) = let g y = y::r in ...
+        -- Here, g mustn't be generalised.  This is also important during
+        -- class and instance decls, when we mustn't generalise the class tyvars
+        -- when typechecking the methods.
+        --
+        -- Nor must we generalise g over any kind variables free in r's kind
+
+
+{- *********************************************************************
+*                                                                      *
+             The TcBinderStack
+*                                                                      *
+********************************************************************* -}
+
+tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
+tcExtendBinderStack bndrs thing_inside
+  = do { traceTc "tcExtendBinderStack" (ppr bndrs)
+       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
+                   thing_inside }
+
+tcInitTidyEnv :: TcM TidyEnv
+-- We initialise the "tidy-env", used for tidying types before printing,
+-- by building a reverse map from the in-scope type variables to the
+-- OccName that the programmer originally used for them
+tcInitTidyEnv
+  = do  { lcl_env <- getLclEnv
+        ; go emptyTidyEnv (tcl_bndrs lcl_env) }
+  where
+    go (env, subst) []
+      = return (env, subst)
+    go (env, subst) (b : bs)
+      | TcTvBndr name tyvar <- b
+       = do { let (env', occ') = tidyOccName env (nameOccName name)
+                  name'  = tidyNameOcc name occ'
+                  tyvar1 = setTyVarName tyvar name'
+            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
+              -- Be sure to zonk here!  Tidying applies to zonked
+              -- types, so if we don't zonk we may create an
+              -- ill-kinded type (#14175)
+            ; go (env', extendVarEnv subst tyvar tyvar2) bs }
+      | otherwise
+      = go (env, subst) bs
+
+-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
+-- type. Useful when tidying open types.
+tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
+tcInitOpenTidyEnv tvs
+  = do { env1 <- tcInitTidyEnv
+       ; let env2 = tidyFreeTyCoVars env1 tvs
+       ; return env2 }
+
+
+
+{- *********************************************************************
+*                                                                      *
+             Adding placeholders
+*                                                                      *
+********************************************************************* -}
+
+tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
+-- See Note [AFamDataCon: not promoting data family constructors]
+tcAddDataFamConPlaceholders inst_decls thing_inside
+  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
+                        | lid <- inst_decls, con <- get_cons lid ]
+      thing_inside
+      -- Note [AFamDataCon: not promoting data family constructors]
+  where
+    -- get_cons extracts the *constructor* bindings of the declaration
+    get_cons :: LInstDecl GhcRn -> [Name]
+    get_cons (L _ (TyFamInstD {}))                     = []
+    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
+    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
+      = concatMap (get_fi_cons . unLoc) fids
+    get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons"
+    get_cons (L _ (XInstDecl _)) = panic "get_cons"
+
+    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
+      = map unLoc $ concatMap (getConNames . unLoc) cons
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = XHsDataDefn _ }}})
+      = panic "get_fi_cons"
+    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons"
+    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons"
+
+
+tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
+-- See Note [Don't promote pattern synonyms]
+tcAddPatSynPlaceholders pat_syns thing_inside
+  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
+                        | PSB{ psb_id = L _ name } <- pat_syns ]
+       thing_inside
+
+getTypeSigNames :: [LSig GhcRn] -> NameSet
+-- Get the names that have a user type sig
+getTypeSigNames sigs
+  = foldr get_type_sig emptyNameSet sigs
+  where
+    get_type_sig :: LSig GhcRn -> NameSet -> NameSet
+    get_type_sig sig ns =
+      case sig of
+        L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
+        L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
+        _ -> ns
+
+
+{- Note [AFamDataCon: not promoting data family constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data family T a
+  data instance T Int = MkT
+  data Proxy (a :: k)
+  data S = MkS (Proxy 'MkT)
+
+Is it ok to use the promoted data family instance constructor 'MkT' in
+the data declaration for S (where both declarations live in the same module)?
+No, we don't allow this. It *might* make sense, but at least it would mean that
+we'd have to interleave typechecking instances and data types, whereas at
+present we do data types *then* instances.
+
+So to check for this we put in the TcLclEnv a binding for all the family
+constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
+type checking 'S' we'll produce a decent error message.
+
+#12088 describes this limitation. Of course, when MkT and S live in
+different modules then all is well.
+
+Note [Don't promote pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never promote pattern synonyms.
+
+Consider this (#11265):
+  pattern A = True
+  instance Eq A
+We want a civilised error message from the occurrence of 'A'
+in the instance, yet 'A' really has not yet been type checked.
+
+Similarly (#9161)
+  {-# LANGUAGE PatternSynonyms, DataKinds #-}
+  pattern A = ()
+  b :: A
+  b = undefined
+Here, the type signature for b mentions A.  But A is a pattern
+synonym, which is typechecked as part of a group of bindings (for very
+good reasons; a view pattern in the RHS may mention a value binding).
+It is entirely reasonable to reject this, but to do so we need A to be
+in the kind environment when kind-checking the signature for B.
+
+Hence tcAddPatSynPlaceholers adds a binding
+    A -> APromotionErr PatSynPE
+to the environment. Then TcHsType.tcTyVar will find A in the kind
+environment, and will give a 'wrongThingErr' as a result.  But the
+lookup of A won't fail.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Rules}
+*                                                                      *
+************************************************************************
+-}
+
+tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
+        -- Just pop the new rules into the EPS and envt resp
+        -- All the rules come from an interface file, not source
+        -- Nevertheless, some may be for this module, if we read
+        -- its interface instead of its source code
+tcExtendRules lcl_rules thing_inside
+ = do { env <- getGblEnv
+      ; let
+          env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
+      ; setGblEnv env' thing_inside }
+
+{-
+************************************************************************
+*                                                                      *
+                Meta level
+*                                                                      *
+************************************************************************
+-}
+
+checkWellStaged :: SDoc         -- What the stage check is for
+                -> ThLevel      -- Binding level (increases inside brackets)
+                -> ThLevel      -- Use stage
+                -> TcM ()       -- Fail if badly staged, adding an error
+checkWellStaged pp_thing bind_lvl use_lvl
+  | use_lvl >= bind_lvl         -- OK! Used later than bound
+  = return ()                   -- E.g.  \x -> [| $(f x) |]
+
+  | bind_lvl == outerLevel      -- GHC restriction on top level splices
+  = stageRestrictionError pp_thing
+
+  | otherwise                   -- Badly staged
+  = failWithTc $                -- E.g.  \x -> $(f x)
+    text "Stage error:" <+> pp_thing <+>
+        hsep   [text "is bound at stage" <+> ppr bind_lvl,
+                text "but used at stage" <+> ppr use_lvl]
+
+stageRestrictionError :: SDoc -> TcM a
+stageRestrictionError pp_thing
+  = failWithTc $
+    sep [ text "GHC stage restriction:"
+        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
+                       , text "and must be imported, not defined locally"])]
+
+topIdLvl :: Id -> ThLevel
+-- Globals may either be imported, or may be from an earlier "chunk"
+-- (separated by declaration splices) of this module.  The former
+--  *can* be used inside a top-level splice, but the latter cannot.
+-- Hence we give the former impLevel, but the latter topLevel
+-- E.g. this is bad:
+--      x = [| foo |]
+--      $( f x )
+-- By the time we are prcessing the $(f x), the binding for "x"
+-- will be in the global env, not the local one.
+topIdLvl id | isLocalId id = outerLevel
+            | otherwise    = impLevel
+
+tcMetaTy :: Name -> TcM Type
+-- Given the name of a Template Haskell data type,
+-- return the type
+-- E.g. given the name "Expr" return the type "Expr"
+tcMetaTy tc_name = do
+    t <- tcLookupTyCon tc_name
+    return (mkTyConApp t [])
+
+isBrackStage :: ThStage -> Bool
+isBrackStage (Brack {}) = True
+isBrackStage _other     = False
+
+{-
+************************************************************************
+*                                                                      *
+                 getDefaultTys
+*                                                                      *
+************************************************************************
+-}
+
+tcGetDefaultTys :: TcM ([Type], -- Default types
+                        (Bool,  -- True <=> Use overloaded strings
+                         Bool)) -- True <=> Use extended defaulting rules
+tcGetDefaultTys
+  = do  { dflags <- getDynFlags
+        ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
+              extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
+                                        -- See also #1974
+              flags = (ovl_strings, extended_defaults)
+
+        ; mb_defaults <- getDeclaredDefaultTys
+        ; case mb_defaults of {
+           Just tys -> return (tys, flags) ;
+                                -- User-supplied defaults
+           Nothing  -> do
+
+        -- No use-supplied default
+        -- Use [Integer, Double], plus modifications
+        { integer_ty <- tcMetaTy integerTyConName
+        ; list_ty <- tcMetaTy listTyConName
+        ; checkWiredInTyCon doubleTyCon
+        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
+                          -- Note [Extended defaults]
+                          ++ [integer_ty, doubleTy]
+                          ++ opt_deflt ovl_strings [stringTy]
+        ; return (deflt_tys, flags) } } }
+  where
+    opt_deflt True  xs = xs
+    opt_deflt False _  = []
+
+{-
+Note [Extended defaults]
+~~~~~~~~~~~~~~~~~~~~~
+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
+try when defaulting.  This has very little real impact, except in the following case.
+Consider:
+        Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
+() to the list of defaulting types.  See #1200.
+
+Additionally, the list type [] is added as a default specialization for
+Traversable and Foldable. As such the default default list now has types of
+varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).
+
+************************************************************************
+*                                                                      *
+\subsection{The InstInfo type}
+*                                                                      *
+************************************************************************
+
+The InstInfo type summarises the information in an instance declaration
+
+    instance c => k (t tvs) where b
+
+It is used just for *local* instance decls (not ones from interface files).
+But local instance decls includes
+        - derived ones
+        - generic ones
+as well as explicit user written ones.
+-}
+
+data InstInfo a
+  = InstInfo
+      { iSpec   :: ClsInst          -- Includes the dfun id
+      , iBinds  :: InstBindings a
+      }
+
+iDFunId :: InstInfo a -> DFunId
+iDFunId info = instanceDFunId (iSpec info)
+
+data InstBindings a
+  = InstBindings
+      { ib_tyvars  :: [Name]   -- Names of the tyvars from the instance head
+                               -- that are lexically in scope in the bindings
+                               -- Must correspond 1-1 with the forall'd tyvars
+                               -- of the dfun Id.  When typechecking, we are
+                               -- going to extend the typechecker's envt with
+                               --     ib_tyvars -> dfun_forall_tyvars
+
+      , ib_binds   :: LHsBinds a    -- Bindings for the instance methods
+
+      , ib_pragmas :: [LSig a]      -- User pragmas recorded for generating
+                                    -- specialised instances
+
+      , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
+                                             -- be enabled when type-checking
+                                             -- this instance; needed for
+                                             -- GeneralizedNewtypeDeriving
+
+      , ib_derived :: Bool
+           -- True <=> This code was generated by GHC from a deriving clause
+           --          or standalone deriving declaration
+           --          Used only to improve error messages
+      }
+
+instance (OutputableBndrId (GhcPass a))
+       => Outputable (InstInfo (GhcPass a)) where
+    ppr = pprInstInfoDetails
+
+pprInstInfoDetails :: (OutputableBndrId (GhcPass a))
+                   => InstInfo (GhcPass a) -> SDoc
+pprInstInfoDetails info
+   = hang (pprInstanceHdr (iSpec info) <+> text "where")
+        2 (details (iBinds info))
+  where
+    details (InstBindings { ib_binds = b }) = pprLHsBinds b
+
+simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
+simpleInstInfoClsTy info = case instanceHead (iSpec info) of
+                           (_, cls, [ty]) -> (cls, ty)
+                           _ -> panic "simpleInstInfoClsTy"
+
+simpleInstInfoTy :: InstInfo a -> Type
+simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
+
+simpleInstInfoTyCon :: InstInfo a -> TyCon
+  -- Gets the type constructor for a simple instance declaration,
+  -- i.e. one of the form       instance (...) => C (T a b c) where ...
+simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
+
+-- | Make a name for the dict fun for an instance decl.  It's an *external*
+-- name, like other top-level names, and hence must be made with
+-- newGlobalBinder.
+newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
+newDFunName clas tys loc
+  = do  { is_boot <- tcIsHsBootOrSig
+        ; mod     <- getModule
+        ; let info_string = occNameString (getOccName clas) ++
+                            concatMap (occNameString.getDFunTyKey) tys
+        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
+        ; newGlobalBinder mod dfun_occ loc }
+
+-- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.
+newDFunName' :: Class -> TyCon -> TcM Name
+newDFunName' clas tycon        -- Just a simple wrapper
+  = do { loc <- getSrcSpanM     -- The location of the instance decl,
+                                -- not of the tycon
+       ; newDFunName clas [mkTyConApp tycon []] loc }
+       -- The type passed to newDFunName is only used to generate
+       -- a suitable string; hence the empty type arg list
+
+{-
+Make a name for the representation tycon of a family instance.  It's an
+*external* name, like other top-level names, and hence must be made with
+newGlobalBinder.
+-}
+
+newFamInstTyConName :: Located Name -> [Type] -> TcM Name
+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
+
+newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
+newFamInstAxiomName (L loc name) branches
+  = mk_fam_inst_name mkInstTyCoOcc loc name branches
+
+mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
+mk_fam_inst_name adaptOcc loc tc_name tyss
+  = do  { mod   <- getModule
+        ; let info_string = occNameString (getOccName tc_name) ++
+                            intercalate "|" ty_strings
+        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+        ; newGlobalBinder mod (adaptOcc occ) loc }
+  where
+    ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
+
+{-
+Stable names used for foreign exports and annotations.
+For stable names, the name must be unique (see #1533).  If the
+same thing has several stable Ids based on it, the
+top-level bindings generated must not have the same name.
+Hence we create an External name (doesn't change), and we
+append a Unique to the string right here.
+-}
+
+mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromString str sig_ty loc occ_wrapper = do
+    uniq <- newUnique
+    mod <- getModule
+    name <- mkWrapperName "stable" str
+    let occ = mkVarOccFS name :: OccName
+        gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
+        id  = mkExportedVanillaId gnm sig_ty :: Id
+    return id
+
+mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
+
+mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
+              => String -> String -> m FastString
+mkWrapperName what nameBase
+    = do dflags <- getDynFlags
+         thisMod <- getModule
+         let -- Note [Generating fresh names for ccall wrapper]
+             wrapperRef = nextWrapperNum dflags
+             pkg = unitIdString  (moduleUnitId thisMod)
+             mod = moduleNameString (moduleName      thisMod)
+         wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
+             let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
+                 mod_env' = extendModuleEnv mod_env thisMod (num+1)
+             in (mod_env', num)
+         let components = [what, show wrapperNum, pkg, mod, nameBase]
+         return $ mkFastString $ zEncodeString $ intercalate ":" components
+
+{-
+Note [Generating fresh names for FFI wrappers]
+
+We used to use a unique, rather than nextWrapperNum, to distinguish
+between FFI wrapper functions. However, the wrapper names that we
+generate are external names. This means that if a call to them ends up
+in an unfolding, then we can't alpha-rename them, and thus if the
+unique randomly changes from one compile to another then we get a
+spurious ABI change (#4012).
+
+The wrapper counter has to be per-module, not global, so that the number we end
+up using is not dependent on the modules compiled before the current one.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+pprBinders :: [Name] -> SDoc
+-- Used in error messages
+-- Use quotes for a single one; they look a bit "busy" for several
+pprBinders [bndr] = quotes (ppr bndr)
+pprBinders bndrs  = pprWithCommas ppr bndrs
+
+notFound :: Name -> TcM TyThing
+notFound name
+  = do { lcl_env <- getLclEnv
+       ; let stage = tcl_th_ctxt lcl_env
+       ; case stage of   -- See Note [Out of scope might be a staging error]
+           Splice {}
+             | isUnboundName name -> failM  -- If the name really isn't in scope
+                                            -- don't report it again (#11941)
+             | otherwise -> stageRestrictionError (quotes (ppr name))
+           _ -> failWithTc $
+                vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
+                     text "is not in scope during type checking, but it passed the renamer",
+                     text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
+                       -- Take care: printing the whole gbl env can
+                       -- cause an infinite loop, in the case where we
+                       -- are in the middle of a recursive TyCon/Class group;
+                       -- so let's just not print it!  Getting a loop here is
+                       -- very unhelpful, because it hides one compiler bug with another
+       }
+
+wrongThingErr :: String -> TcTyThing -> Name -> TcM a
+-- It's important that this only calls pprTcTyThingCategory, which in
+-- turn does not look at the details of the TcTyThing.
+-- See Note [Placeholder PatSyn kinds] in TcBinds
+wrongThingErr expected thing name
+  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
+                text "used as a" <+> text expected)
+
+{- Note [Out of scope might be a staging error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  x = 3
+  data T = MkT $(foo x)
+
+where 'foo' is imported from somewhere.
+
+This is really a staging error, because we can't run code involving 'x'.
+But in fact the type checker processes types first, so 'x' won't even be
+in the type envt when we look for it in $(foo x).  So inside splices we
+report something missing from the type env as a staging error.
+See #5752 and #5795.
+-}
diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcEnv.hs-boot
@@ -0,0 +1,10 @@
+module TcEnv where
+
+import TcRnTypes( TcM )
+import VarEnv( TidyEnv )
+
+-- Annoyingly, there's a recursion between tcInitTidyEnv
+-- (which does zonking and hence needs TcMType) and
+-- addErrTc etc which live in TcRnMonad.  Rats.
+tcInitTidyEnv :: TcM TidyEnv
+
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcErrors.hs
@@ -0,0 +1,3112 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcErrors(
+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,
+       warnDefaulting,
+
+       solverDepthErrorTcS
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import TcRnMonad
+import TcMType
+import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) )
+import TcEnv( tcInitTidyEnv )
+import TcType
+import RnUnbound ( unknownNameSuggestions )
+import Type
+import TyCoRep
+import Unify            ( tcMatchTys )
+import Module
+import FamInst
+import FamInstEnv       ( flattenTys )
+import Inst
+import InstEnv
+import TyCon
+import Class
+import DataCon
+import TcEvidence
+import TcEvTerm
+import HsExpr  ( UnboundVar(..) )
+import HsBinds ( PatSynBind(..) )
+import Name
+import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
+               , mkRdrUnqual, isLocalGRE, greSrcSpan )
+import PrelNames ( typeableClassName )
+import Id
+import Var
+import VarSet
+import VarEnv
+import NameSet
+import Bag
+import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )
+import BasicTypes
+import ConLike          ( ConLike(..))
+import Util
+import FastString
+import Outputable
+import SrcLoc
+import DynFlags
+import ListSetOps       ( equivClasses )
+import Maybes
+import Pair
+import qualified GHC.LanguageExtensions as LangExt
+import FV ( fvVarList, unionFV )
+
+import Control.Monad    ( when )
+import Data.Foldable    ( toList )
+import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )
+import qualified Data.Set as Set
+
+import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )
+
+-- import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+
+
+{-
+************************************************************************
+*                                                                      *
+\section{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+ToDo: for these error messages, should we note the location as coming
+from the insts, or just whatever seems to be around in the monad just
+now?
+
+Note [Deferring coercion errors to runtime]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While developing, sometimes it is desirable to allow compilation to succeed even
+if there are type errors in the code. Consider the following case:
+
+  module Main where
+
+  a :: Int
+  a = 'a'
+
+  main = print "b"
+
+Even though `a` is ill-typed, it is not used in the end, so if all that we're
+interested in is `main` it is handy to be able to ignore the problems in `a`.
+
+Since we treat type equalities as evidence, this is relatively simple. Whenever
+we run into a type mismatch in TcUnify, we normally just emit an error. But it
+is always safe to defer the mismatch to the main constraint solver. If we do
+that, `a` will get transformed into
+
+  co :: Int ~ Char
+  co = ...
+
+  a :: Int
+  a = 'a' `cast` co
+
+The constraint solver would realize that `co` is an insoluble constraint, and
+emit an error with `reportUnsolved`. But we can also replace the right-hand side
+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
+to compile, and it will run fine unless we evaluate `a`. This is what
+`deferErrorsToRuntime` does.
+
+It does this by keeping track of which errors correspond to which coercion
+in TcErrors. TcErrors.reportTidyWanteds does not print the errors
+and does not fail if -fdefer-type-errors is on, so that we can continue
+compilation. The errors are turned into warnings in `reportUnsolved`.
+-}
+
+-- | Report unsolved goals as errors or warnings. We may also turn some into
+-- deferred run-time errors if `-fdefer-type-errors` is on.
+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
+reportUnsolved wanted
+  = do { binds_var <- newTcEvBinds
+       ; defer_errors <- goptM Opt_DeferTypeErrors
+       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
+       ; let type_errors | not defer_errors = TypeError
+                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)
+                         | otherwise        = TypeDefer
+
+       ; defer_holes <- goptM Opt_DeferTypedHoles
+       ; warn_holes  <- woptM Opt_WarnTypedHoles
+       ; let expr_holes | not defer_holes = HoleError
+                        | warn_holes      = HoleWarn
+                        | otherwise       = HoleDefer
+
+       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures
+       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
+       ; let type_holes | not partial_sigs  = HoleError
+                        | warn_partial_sigs = HoleWarn
+                        | otherwise         = HoleDefer
+
+       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
+       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables
+       ; let out_of_scope_holes | not defer_out_of_scope = HoleError
+                                | warn_out_of_scope      = HoleWarn
+                                | otherwise              = HoleDefer
+
+       ; report_unsolved type_errors expr_holes
+                         type_holes out_of_scope_holes
+                         binds_var wanted
+
+       ; ev_binds <- getTcEvBindsMap binds_var
+       ; return (evBindMapBinds ev_binds)}
+
+-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
+-- However, do not make any evidence bindings, because we don't
+-- have any convenient place to put them.
+-- See Note [Deferring coercion errors to runtime]
+-- Used by solveEqualities for kind equalities
+--      (see Note [Fail fast on kind errors] in TcSimplify]
+-- and for simplifyDefault.
+reportAllUnsolved :: WantedConstraints -> TcM ()
+reportAllUnsolved wanted
+  = do { ev_binds <- newNoTcEvBinds
+       ; report_unsolved TypeError HoleError HoleError HoleError
+                         ev_binds wanted }
+
+-- | Report all unsolved goals as warnings (but without deferring any errors to
+-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
+-- TcSimplify
+warnAllUnsolved :: WantedConstraints -> TcM ()
+warnAllUnsolved wanted
+  = do { ev_binds <- newTcEvBinds
+       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn
+                         ev_binds wanted }
+
+-- | Report unsolved goals as errors or warnings.
+report_unsolved :: TypeErrorChoice   -- Deferred type errors
+                -> HoleChoice        -- Expression holes
+                -> HoleChoice        -- Type holes
+                -> HoleChoice        -- Out of scope holes
+                -> EvBindsVar        -- cec_binds
+                -> WantedConstraints -> TcM ()
+report_unsolved type_errors expr_holes
+    type_holes out_of_scope_holes binds_var wanted
+  | isEmptyWC wanted
+  = return ()
+  | otherwise
+  = do { traceTc "reportUnsolved {" $
+         vcat [ text "type errors:" <+> ppr type_errors
+              , text "expr holes:" <+> ppr expr_holes
+              , text "type holes:" <+> ppr type_holes
+              , text "scope holes:" <+> ppr out_of_scope_holes ]
+       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
+
+       ; wanted <- zonkWC wanted   -- Zonk to reveal all information
+       ; env0 <- tcInitTidyEnv
+            -- If we are deferring we are going to need /all/ evidence around,
+            -- including the evidence produced by unflattening (zonkWC)
+       ; let tidy_env = tidyFreeTyCoVars env0 free_tvs
+             free_tvs = tyCoVarsOfWCList wanted
+
+       ; traceTc "reportUnsolved (after zonking):" $
+         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
+              , text "Tidy env:" <+> ppr tidy_env
+              , text "Wanted:" <+> ppr wanted ]
+
+       ; warn_redundant <- woptM Opt_WarnRedundantConstraints
+       ; let err_ctxt = CEC { cec_encl  = []
+                            , cec_tidy  = tidy_env
+                            , cec_defer_type_errors = type_errors
+                            , cec_expr_holes = expr_holes
+                            , cec_type_holes = type_holes
+                            , cec_out_of_scope_holes = out_of_scope_holes
+                            , cec_suppress = insolubleWC wanted
+                                 -- See Note [Suppressing error messages]
+                                 -- Suppress low-priority errors if there
+                                 -- are insolule errors anywhere;
+                                 -- See #15539 and c.f. setting ic_status
+                                 -- in TcSimplify.setImplicationStatus
+                            , cec_warn_redundant = warn_redundant
+                            , cec_binds    = binds_var }
+
+       ; tc_lvl <- getTcLevel
+       ; reportWanteds err_ctxt tc_lvl wanted
+       ; traceTc "reportUnsolved }" empty }
+
+--------------------------------------------
+--      Internal functions
+--------------------------------------------
+
+-- | An error Report collects messages categorised by their importance.
+-- See Note [Error report] for details.
+data Report
+  = Report { report_important :: [SDoc]
+           , report_relevant_bindings :: [SDoc]
+           , report_valid_hole_fits :: [SDoc]
+           }
+
+instance Outputable Report where   -- Debugging only
+  ppr (Report { report_important = imp
+              , report_relevant_bindings = rel
+              , report_valid_hole_fits = val })
+    = vcat [ text "important:" <+> vcat imp
+           , text "relevant:"  <+> vcat rel
+           , text "valid:"  <+> vcat val ]
+
+{- Note [Error report]
+The idea is that error msgs are divided into three parts: the main msg, the
+context block (\"In the second argument of ...\"), and the relevant bindings
+block, which are displayed in that order, with a mark to divide them.  The
+idea is that the main msg ('report_important') varies depending on the error
+in question, but context and relevant bindings are always the same, which
+should simplify visual parsing.
+
+The context is added when the Report is passed off to 'mkErrorReport'.
+Unfortunately, unlike the context, the relevant bindings are added in
+multiple places so they have to be in the Report.
+-}
+
+instance Semigroup Report where
+    Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
+
+instance Monoid Report where
+    mempty = Report [] [] []
+    mappend = (Semigroup.<>)
+
+-- | Put a doc into the important msgs block.
+important :: SDoc -> Report
+important doc = mempty { report_important = [doc] }
+
+-- | Put a doc into the relevant bindings block.
+relevant_bindings :: SDoc -> Report
+relevant_bindings doc = mempty { report_relevant_bindings = [doc] }
+
+-- | Put a doc into the valid hole fits block.
+valid_hole_fits :: SDoc -> Report
+valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }
+
+data TypeErrorChoice   -- What to do for type errors found by the type checker
+  = TypeError     -- A type error aborts compilation with an error message
+  | TypeWarn WarnReason
+                  -- A type error is deferred to runtime, plus a compile-time warning
+                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)
+                  -- but it isn't for the Safe Haskell Overlapping Instances warnings
+                  -- see warnAllUnsolved
+  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time
+
+data HoleChoice
+  = HoleError     -- A hole is a compile-time error
+  | HoleWarn      -- Defer to runtime, emit a compile-time warning
+  | HoleDefer     -- Defer to runtime, no warning
+
+instance Outputable HoleChoice where
+  ppr HoleError = text "HoleError"
+  ppr HoleWarn  = text "HoleWarn"
+  ppr HoleDefer = text "HoleDefer"
+
+instance Outputable TypeErrorChoice  where
+  ppr TypeError         = text "TypeError"
+  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason
+  ppr TypeDefer         = text "TypeDefer"
+
+data ReportErrCtxt
+    = CEC { cec_encl :: [Implication]  -- Enclosing implications
+                                       --   (innermost first)
+                                       -- ic_skols and givens are tidied, rest are not
+          , cec_tidy  :: TidyEnv
+
+          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)
+                                       -- into warnings, and emit evidence bindings
+                                       -- into 'cec_binds' for unsolved constraints
+
+          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
+
+          -- cec_expr_holes is a union of:
+          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'
+          --   cec_out_of_scope_holes - a set of variables which are
+          --                            out of scope: 'x', 'y', 'bar'
+          , cec_expr_holes :: HoleChoice           -- Holes in expressions
+          , cec_type_holes :: HoleChoice           -- Holes in types
+          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes
+
+          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints
+
+          , cec_suppress :: Bool    -- True <=> More important errors have occurred,
+                                    --          so create bindings if need be, but
+                                    --          don't issue any more errors/warnings
+                                    -- See Note [Suppressing error messages]
+      }
+
+instance Outputable ReportErrCtxt where
+  ppr (CEC { cec_binds              = bvar
+           , cec_defer_type_errors  = dte
+           , cec_expr_holes         = eh
+           , cec_type_holes         = th
+           , cec_out_of_scope_holes = osh
+           , cec_warn_redundant     = wr
+           , cec_suppress           = sup })
+    = text "CEC" <+> braces (vcat
+         [ text "cec_binds"              <+> equals <+> ppr bvar
+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte
+         , text "cec_expr_holes"         <+> equals <+> ppr eh
+         , text "cec_type_holes"         <+> equals <+> ppr th
+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh
+         , text "cec_warn_redundant"     <+> equals <+> ppr wr
+         , text "cec_suppress"           <+> equals <+> ppr sup ])
+
+-- | Returns True <=> the ReportErrCtxt indicates that something is deferred
+deferringAnyBindings :: ReportErrCtxt -> Bool
+  -- Don't check cec_type_holes, as these don't cause bindings to be deferred
+deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError
+                          , cec_expr_holes         = HoleError
+                          , cec_out_of_scope_holes = HoleError }) = False
+deferringAnyBindings _                                            = True
+
+-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings
+-- at all.
+noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
+noDeferredBindings ctxt = ctxt { cec_defer_type_errors  = TypeError
+                               , cec_expr_holes         = HoleError
+                               , cec_out_of_scope_holes = HoleError }
+
+{- Note [Suppressing error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The cec_suppress flag says "don't report any errors".  Instead, just create
+evidence bindings (as usual).  It's used when more important errors have occurred.
+
+Specifically (see reportWanteds)
+  * If there are insoluble Givens, then we are in unreachable code and all bets
+    are off.  So don't report any further errors.
+  * If there are any insolubles (eg Int~Bool), here or in a nested implication,
+    then suppress errors from the simple constraints here.  Sometimes the
+    simple-constraint errors are a knock-on effect of the insolubles.
+
+This suppression behaviour is controlled by the Bool flag in
+ReportErrorSpec, as used in reportWanteds.
+
+But we need to take care: flags can turn errors into warnings, and we
+don't want those warnings to suppress subsequent errors (including
+suppressing the essential addTcEvBind for them: #15152). So in
+tryReporter we use askNoErrs to see if any error messages were
+/actually/ produced; if not, we don't switch on suppression.
+
+A consequence is that warnings never suppress warnings, so turning an
+error into a warning may allow subsequent warnings to appear that were
+previously suppressed.   (e.g. partial-sigs/should_fail/T14584)
+-}
+
+reportImplic :: ReportErrCtxt -> Implication -> TcM ()
+reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
+                                 , ic_given = given
+                                 , ic_wanted = wanted, ic_binds = evb
+                                 , ic_status = status, ic_info = info
+                                 , ic_tclvl = tc_lvl })
+  | BracketSkol <- info
+  , not insoluble
+  = return ()        -- For Template Haskell brackets report only
+                     -- definite errors. The whole thing will be re-checked
+                     -- later when we plug it in, and meanwhile there may
+                     -- certainly be un-satisfied constraints
+
+  | otherwise
+  = do { traceTc "reportImplic" (ppr implic')
+       ; reportWanteds ctxt' tc_lvl wanted
+       ; when (cec_warn_redundant ctxt) $
+         warnRedundantConstraints ctxt' tcl_env info' dead_givens
+       ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
+  where
+    tcl_env      = implicLclEnv implic
+    insoluble    = isInsolubleStatus status
+    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs
+    info'        = tidySkolemInfo env1 info
+    implic' = implic { ic_skols = tvs'
+                     , ic_given = map (tidyEvVar env1) given
+                     , ic_info  = info' }
+    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt
+          | otherwise                = ctxt
+          -- If we go inside an implication that has no term
+          -- evidence (e.g. unifying under a forall), we can't defer
+          -- type errors.  You could imagine using the /enclosing/
+          -- bindings (in cec_binds), but that may not have enough stuff
+          -- in scope for the bindings to be well typed.  So we just
+          -- switch off deferred type errors altogether.  See #14605.
+
+    ctxt' = ctxt1 { cec_tidy     = env1
+                  , cec_encl     = implic' : cec_encl ctxt
+
+                  , cec_suppress = insoluble || cec_suppress ctxt
+                        -- Suppress inessential errors if there
+                        -- are insolubles anywhere in the
+                        -- tree rooted here, or we've come across
+                        -- a suppress-worthy constraint higher up (#11541)
+
+                  , cec_binds    = evb }
+
+    dead_givens = case status of
+                    IC_Solved { ics_dead = dead } -> dead
+                    _                             -> []
+
+    bad_telescope = case status of
+              IC_BadTelescope -> True
+              _               -> False
+
+warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
+-- See Note [Tracking redundant constraints] in TcSimplify
+warnRedundantConstraints ctxt env info ev_vars
+ | null redundant_evs
+ = return ()
+
+ | SigSkol {} <- info
+ = setLclEnv env $  -- We want to add "In the type signature for f"
+                    -- to the error context, which is a bit tiresome
+   addErrCtxt (text "In" <+> ppr info) $
+   do { env <- getLclEnv
+      ; msg <- mkErrorReport ctxt env (important doc)
+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
+
+ | otherwise  -- But for InstSkol there already *is* a surrounding
+              -- "In the instance declaration for Eq [a]" context
+              -- and we don't want to say it twice. Seems a bit ad-hoc
+ = do { msg <- mkErrorReport ctxt env (important doc)
+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
+ where
+   doc = text "Redundant constraint" <> plural redundant_evs <> colon
+         <+> pprEvVarTheta redundant_evs
+
+   redundant_evs =
+       filterOut is_type_error $
+       case info of -- See Note [Redundant constraints in instance decls]
+         InstSkol -> filterOut (improving . idType) ev_vars
+         _        -> ev_vars
+
+   -- See #15232
+   is_type_error = isJust . userTypeError_maybe . idType
+
+   improving pred -- (transSuperClasses p) does not include p
+     = any isImprovementPred (pred : transSuperClasses pred)
+
+reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
+reportBadTelescope ctxt env (Just telescope) skols
+  = do { msg <- mkErrorReport ctxt env (important doc)
+       ; reportError msg }
+  where
+    doc = hang (text "These kind and type variables:" <+> telescope $$
+                text "are out of dependency order. Perhaps try this ordering:")
+             2 (pprTyVars sorted_tvs)
+
+    sorted_tvs = scopedSort skols
+
+reportBadTelescope _ _ Nothing skols
+  = pprPanic "reportBadTelescope" (ppr skols)
+
+{- Note [Redundant constraints in instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For instance declarations, we don't report unused givens if
+they can give rise to improvement.  Example (#10100):
+    class Add a b ab | a b -> ab, a ab -> b
+    instance Add Zero b b
+    instance Add a b ab => Add (Succ a) b (Succ ab)
+The context (Add a b ab) for the instance is clearly unused in terms
+of evidence, since the dictionary has no fields.  But it is still
+needed!  With the context, a wanted constraint
+   Add (Succ Zero) beta (Succ Zero)
+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
+But without the context we won't find beta := Zero.
+
+This only matters in instance declarations..
+-}
+
+reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
+reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
+  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
+                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)])
+       ; traceTc "rw2" (ppr tidy_cts)
+
+         -- First deal with things that are utterly wrong
+         -- Like Int ~ Bool (incl nullary TyCons)
+         -- or  Int ~ t a   (AppTy on one side)
+         -- These /ones/ are not suppressed by the incoming context
+       ; let ctxt_for_insols = ctxt { cec_suppress = False }
+       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts
+
+         -- Now all the other constraints.  We suppress errors here if
+         -- any of the first batch failed, or if the enclosing context
+         -- says to suppress
+       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
+       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1
+       ; MASSERT2( null leftovers, ppr leftovers )
+
+            -- All the Derived ones have been filtered out of simples
+            -- by the constraint solver. This is ok; we don't want
+            -- to report unsolved Derived goals as errors
+            -- See Note [Do not report derived but soluble errors]
+
+     ; mapBagM_ (reportImplic ctxt2) implics }
+            -- NB ctxt1: don't suppress inner insolubles if there's only a
+            -- wanted insoluble here; but do suppress inner insolubles
+            -- if there's a *given* insoluble here (= inaccessible code)
+ where
+    env = cec_tidy ctxt
+    tidy_cts = bagToList (mapBag (tidyCt env) simples)
+
+    -- report1: ones that should *not* be suppresed by
+    --          an insoluble somewhere else in the tree
+    -- It's crucial that anything that is considered insoluble
+    -- (see TcRnTypes.insolubleCt) is caught here, otherwise
+    -- we might suppress its error message, and proceed on past
+    -- type checking to get a Lint error later
+    report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)
+              , ("Holes",        is_hole,            False, mkHoleReporter tidy_cts)
+              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)
+
+              , given_eq_spec
+              , ("insoluble2",   utterly_wrong,  True, mkGroupReporter mkEqErr)
+              , ("skolem eq1",   very_wrong,     True, mkSkolReporter)
+              , ("skolem eq2",   skolem_eq,      True, mkSkolReporter)
+              , ("non-tv eq",    non_tv_eq,      True, mkSkolReporter)
+
+                  -- The only remaining equalities are alpha ~ ty,
+                  -- where alpha is untouchable; and representational equalities
+                  -- Prefer homogeneous equalities over hetero, because the
+                  -- former might be holding up the latter.
+                  -- See Note [Equalities with incompatible kinds] in TcCanonical
+              , ("Homo eqs",      is_homo_equality, True,  mkGroupReporter mkEqErr)
+              , ("Other eqs",     is_equality,      False, mkGroupReporter mkEqErr) ]
+
+    -- report2: we suppress these if there are insolubles elsewhere in the tree
+    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)
+              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)
+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]
+
+    -- rigid_nom_eq, rigid_nom_tv_eq,
+    is_hole, is_dict,
+      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
+
+    is_given_eq ct pred
+       | EqPred {} <- pred = arisesFromGivens ct
+       | otherwise         = False
+       -- I think all given residuals are equalities
+
+    -- Things like (Int ~N Bool)
+    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
+    utterly_wrong _ _                      = False
+
+    -- Things like (a ~N Int)
+    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
+    very_wrong _ _                      = False
+
+    -- Things like (a ~N b) or (a  ~N  F Bool)
+    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
+    skolem_eq _ _                    = False
+
+    -- Things like (F a  ~N  Int)
+    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
+    non_tv_eq _ _                    = False
+
+    is_out_of_scope ct _ = isOutOfScopeCt ct
+    is_hole         ct _ = isHoleCt ct
+
+    is_user_type_error ct _ = isUserTypeErrorCt ct
+
+    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2
+    is_homo_equality _ _                  = False
+
+    is_equality _ (EqPred {}) = True
+    is_equality _ _           = False
+
+    is_dict _ (ClassPred {}) = True
+    is_dict _ _              = False
+
+    is_ip _ (ClassPred cls _) = isIPClass cls
+    is_ip _ _                 = False
+
+    is_irred _ (IrredPred {}) = True
+    is_irred _ _              = False
+
+    given_eq_spec  -- See Note [Given errors]
+      | has_gadt_match (cec_encl ctxt)
+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)
+      | otherwise
+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
+          -- False means don't suppress subsequent errors
+          -- Reason: we don't report all given errors
+          --         (see mkGivenErrorReporter), and we should only suppress
+          --         subsequent errors if we actually report this one!
+          --         #13446 is an example
+
+    -- See Note [Given errors]
+    has_gadt_match [] = False
+    has_gadt_match (implic : implics)
+      | PatSkol {} <- ic_info implic
+      , not (ic_no_eqs implic)
+      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)
+          -- Don't bother doing this if -Winaccessible-code isn't enabled.
+          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
+      = True
+      | otherwise
+      = has_gadt_match implics
+
+---------------
+isSkolemTy :: TcLevel -> Type -> Bool
+-- The type is a skolem tyvar
+isSkolemTy tc_lvl ty
+  | Just tv <- getTyVar_maybe ty
+  =  isSkolemTyVar tv
+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)
+     -- The last case is for touchable TyVarTvs
+     -- we postpone untouchables to a latter test (too obscure)
+
+  | otherwise
+  = False
+
+isTyFun_maybe :: Type -> Maybe TyCon
+isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
+                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
+                      _ -> Nothing
+
+--------------------------------------------
+--      Reporters
+--------------------------------------------
+
+type Reporter
+  = ReportErrCtxt -> [Ct] -> TcM ()
+type ReporterSpec
+  = ( String                     -- Name
+    , Ct -> PredTree -> Bool     -- Pick these ones
+    , Bool                       -- True <=> suppress subsequent reporters
+    , Reporter)                  -- The reporter itself
+
+mkSkolReporter :: Reporter
+-- Suppress duplicates with either the same LHS, or same location
+mkSkolReporter ctxt cts
+  = mapM_ (reportGroup mkEqErr ctxt) (group cts)
+  where
+     group [] = []
+     group (ct:cts) = (ct : yeses) : group noes
+        where
+          (yeses, noes) = partition (group_with ct) cts
+
+     group_with ct1 ct2
+       | EQ <- cmp_loc ct1 ct2 = True
+       | eq_lhs_type   ct1 ct2 = True
+       | otherwise             = False
+
+mkHoleReporter :: [Ct] -> Reporter
+-- Reports errors one at a time
+mkHoleReporter tidy_simples ctxt
+  = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct
+                      ; maybeReportHoleError ctxt ct err
+                      ; maybeAddDeferredHoleBinding ctxt err ct }
+
+mkUserTypeErrorReporter :: Reporter
+mkUserTypeErrorReporter ctxt
+  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
+                      ; maybeReportError ctxt err
+                      ; addDeferredBinding ctxt err ct }
+
+mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
+                        $ important
+                        $ pprUserTypeErrorTy
+                        $ case getUserTypeErrorMsg ct of
+                            Just msg -> msg
+                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
+
+
+mkGivenErrorReporter :: Reporter
+-- See Note [Given errors]
+mkGivenErrorReporter ctxt cts
+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+       ; dflags <- getDynFlags
+       ; let (implic:_) = cec_encl ctxt
+                 -- Always non-empty when mkGivenErrorReporter is called
+             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))
+                   -- For given constraints we overwrite the env (and hence src-loc)
+                   -- with one from the immediately-enclosing implication.
+                   -- See Note [Inaccessible code]
+
+             inaccessible_msg = hang (text "Inaccessible code in")
+                                   2 (ppr (ic_info implic))
+             report = important inaccessible_msg `mappend`
+                      relevant_bindings binds_msg
+
+       ; err <- mkEqErr_help dflags ctxt report ct'
+                             Nothing ty1 ty2
+
+       ; traceTc "mkGivenErrorReporter" (ppr ct)
+       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }
+  where
+    (ct : _ )  = cts    -- Never empty
+    (ty1, ty2) = getEqPredTys (ctPred ct)
+
+ignoreErrorReporter :: Reporter
+-- Discard Given errors that don't come from
+-- a pattern match; maybe we should warn instead?
+ignoreErrorReporter ctxt cts
+  = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))
+       ; return () }
+
+
+{- Note [Given errors]
+~~~~~~~~~~~~~~~~~~~~~~
+Given constraints represent things for which we have (or will have)
+evidence, so they aren't errors.  But if a Given constraint is
+insoluble, this code is inaccessible, and we might want to at least
+warn about that.  A classic case is
+
+   data T a where
+     T1 :: T Int
+     T2 :: T a
+     T3 :: T Bool
+
+   f :: T Int -> Bool
+   f T1 = ...
+   f T2 = ...
+   f T3 = ...  -- We want to report this case as inaccessible
+
+We'd like to point out that the T3 match is inaccessible. It
+will have a Given constraint [G] Int ~ Bool.
+
+But we don't want to report ALL insoluble Given constraints.  See Trac
+#12466 for a long discussion.  For example, if we aren't careful
+we'll complain about
+   f :: ((Int ~ Bool) => a -> a) -> Int
+which arguably is OK.  It's more debatable for
+   g :: (Int ~ Bool) => Int -> Int
+but it's tricky to distinguish these cases so we don't report
+either.
+
+The bottom line is this: has_gadt_match looks for an enclosing
+pattern match which binds some equality constraints.  If we
+find one, we report the insoluble Given.
+-}
+
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
+                             -- Make error message for a group
+                -> Reporter  -- Deal with lots of constraints
+-- Group together errors from same location,
+-- and report only the first (to avoid a cascade)
+mkGroupReporter mk_err ctxt cts
+  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
+
+eq_lhs_type :: Ct -> Ct -> Bool
+eq_lhs_type ct1 ct2
+  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
+       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
+         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
+       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
+
+cmp_loc :: Ct -> Ct -> Ordering
+cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
+
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
+            -> [Ct] -> TcM ()
+reportGroup mk_err ctxt cts =
+  case partition isMonadFailInstanceMissing cts of
+        -- Only warn about missing MonadFail constraint when
+        -- there are no other missing constraints!
+        (monadFailCts, []) ->
+            do { err <- mk_err ctxt monadFailCts
+               ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }
+
+        (_, cts') -> do { err <- mk_err ctxt cts'
+                        ; traceTc "About to maybeReportErr" $
+                          vcat [ text "Constraint:"             <+> ppr cts'
+                               , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)
+                               , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
+                        ; maybeReportError ctxt err
+                            -- But see Note [Always warn with -fdefer-type-errors]
+                        ; traceTc "reportGroup" (ppr cts')
+                        ; mapM_ (addDeferredBinding ctxt err) cts' }
+                            -- Add deferred bindings for all
+                            -- Redundant if we are going to abort compilation,
+                            -- but that's hard to know for sure, and if we don't
+                            -- abort, we need bindings for all (e.g. #12156)
+  where
+    isMonadFailInstanceMissing ct =
+        case ctLocOrigin (ctLoc ct) of
+            FailablePattern _pat -> True
+            _otherwise           -> False
+
+maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
+-- Unlike maybeReportError, these "hole" errors are
+-- /not/ suppressed by cec_suppress.  We want to see them!
+maybeReportHoleError ctxt ct err
+  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
+  -- generated for holes in partial type signatures.
+  -- Unless -fwarn-partial-type-signatures is not on,
+  -- in which case the messages are discarded.
+  | isTypeHoleCt ct
+  = -- For partial type signatures, generate warnings only, and do that
+    -- only if -fwarn-partial-type-signatures is on
+    case cec_type_holes ctxt of
+       HoleError -> reportError err
+       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err
+       HoleDefer -> return ()
+
+  -- Always report an error for out-of-scope variables
+  -- Unless -fdefer-out-of-scope-variables is on,
+  -- in which case the messages are discarded.
+  -- See #12170, #12406
+  | isOutOfScopeCt ct
+  = -- If deferring, report a warning only if -Wout-of-scope-variables is on
+    case cec_out_of_scope_holes ctxt of
+      HoleError -> reportError err
+      HoleWarn  ->
+        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err
+      HoleDefer -> return ()
+
+  -- Otherwise this is a typed hole in an expression,
+  -- but not for an out-of-scope variable
+  | otherwise
+  = -- If deferring, report a warning only if -Wtyped-holes is on
+    case cec_expr_holes ctxt of
+       HoleError -> reportError err
+       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err
+       HoleDefer -> return ()
+
+maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
+-- Report the error and/or make a deferred binding for it
+maybeReportError ctxt err
+  | cec_suppress ctxt    -- Some worse error has occurred;
+  = return ()            -- so suppress this error/warning
+
+  | otherwise
+  = case cec_defer_type_errors ctxt of
+      TypeDefer       -> return ()
+      TypeWarn reason -> reportWarning reason err
+      TypeError       -> reportError err
+
+addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
+-- See Note [Deferring coercion errors to runtime]
+addDeferredBinding ctxt err ct
+  | deferringAnyBindings ctxt
+  , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
+    -- Only add deferred bindings for Wanted constraints
+  = do { dflags <- getDynFlags
+       ; let err_msg = pprLocErrMsg err
+             err_fs  = mkFastString $ showSDoc dflags $
+                       err_msg $$ text "(deferred type error)"
+             err_tm  = evDelayedError pred err_fs
+             ev_binds_var = cec_binds ctxt
+
+       ; case dest of
+           EvVarDest evar
+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
+           HoleDest hole
+             -> do { -- See Note [Deferred errors for coercion holes]
+                     let co_var = coHoleCoVar hole
+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }}
+
+  | otherwise   -- Do not set any evidence for Given/Derived
+  = return ()
+
+maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
+maybeAddDeferredHoleBinding ctxt err ct
+  | isExprHoleCt ct
+  = addDeferredBinding ctxt err ct  -- Only add bindings for holes in expressions
+  | otherwise                       -- not for holes in partial type signatures
+  = return ()
+
+tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
+-- Use the first reporter in the list whose predicate says True
+tryReporters ctxt reporters cts
+  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts
+       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)
+       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts
+       ; traceTc "tryReporters }" (ppr cts')
+       ; return (ctxt', cts') }
+  where
+    go ctxt [] vis_cts invis_cts
+      = return (ctxt, vis_cts ++ invis_cts)
+
+    go ctxt (r : rs) vis_cts invis_cts
+       -- always look at *visible* Origins before invisible ones
+       -- this is the whole point of isVisibleOrigin
+      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts
+           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts
+           ; go ctxt'' rs vis_cts' invis_cts' }
+                -- Carry on with the rest, because we must make
+                -- deferred bindings for them if we have -fdefer-type-errors
+                -- But suppress their error messages
+
+tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
+tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts
+  | null yeses
+  = return (ctxt, cts)
+  | otherwise
+  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
+       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)
+       ; let suppress_now = not no_errs && suppress_after
+                            -- See Note [Suppressing error messages]
+             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }
+       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
+       ; return (ctxt', nos) }
+  where
+    (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
+
+
+pprArising :: CtOrigin -> SDoc
+-- Used for the main, top-level error message
+-- We've done special processing for TypeEq, KindEq, Given
+pprArising (TypeEqOrigin {}) = empty
+pprArising (KindEqOrigin {}) = empty
+pprArising (GivenOrigin {})  = empty
+pprArising orig              = pprCtOrigin orig
+
+-- Add the "arising from..." part to a message about bunch of dicts
+addArising :: CtOrigin -> SDoc -> SDoc
+addArising orig msg = hang msg 2 (pprArising orig)
+
+pprWithArising :: [Ct] -> (CtLoc, SDoc)
+-- Print something like
+--    (Eq a) arising from a use of x at y
+--    (Show a) arising from a use of p at q
+-- Also return a location for the error message
+-- Works for Wanted/Derived only
+pprWithArising []
+  = panic "pprWithArising"
+pprWithArising (ct:cts)
+  | null cts
+  = (loc, addArising (ctLocOrigin loc)
+                     (pprTheta [ctPred ct]))
+  | otherwise
+  = (loc, vcat (map ppr_one (ct:cts)))
+  where
+    loc = ctLoc ct
+    ppr_one ct' = hang (parens (pprType (ctPred ct')))
+                     2 (pprCtLoc (ctLoc ct'))
+
+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
+mkErrorMsgFromCt ctxt ct report
+  = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
+
+mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
+mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)
+  = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
+       ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))
+            (errDoc important [context] (relevant_bindings ++ valid_subs))
+       }
+
+type UserGiven = Implication
+
+getUserGivens :: ReportErrCtxt -> [UserGiven]
+-- One item for each enclosing implication
+getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics
+
+getUserGivensFromImplics :: [Implication] -> [UserGiven]
+getUserGivensFromImplics implics
+  = reverse (filterOut (null . ic_given) implics)
+
+{- Note [Always warn with -fdefer-type-errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When -fdefer-type-errors is on we warn about *all* type errors, even
+if cec_suppress is on.  This can lead to a lot more warnings than you
+would get errors without -fdefer-type-errors, but if we suppress any of
+them you might get a runtime error that wasn't warned about at compile
+time.
+
+This is an easy design choice to change; just flip the order of the
+first two equations for maybeReportError
+
+To be consistent, we should also report multiple warnings from a single
+location in mkGroupReporter, when -fdefer-type-errors is on.  But that
+is perhaps a bit *over*-consistent! Again, an easy choice to change.
+
+With #10283, you can now opt out of deferred type error warnings.
+
+Note [Deferred errors for coercion holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we need to defer a type error where the destination for the evidence
+is a coercion hole. We can't just put the error in the hole, because we can't
+make an erroneous coercion. (Remember that coercions are erased for runtime.)
+Instead, we invent a new EvVar, bind it to an error and then make a coercion
+from that EvVar, filling the hole with that coercion. Because coercions'
+types are unlifted, the error is guaranteed to be hit before we get to the
+coercion.
+
+Note [Do not report derived but soluble errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The wc_simples include Derived constraints that have not been solved,
+but are not insoluble (in that case they'd be reported by 'report1').
+We do not want to report these as errors:
+
+* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
+  an unsolved [D] Eq a, and we do not want to report that; it's just noise.
+
+* Functional dependencies.  For givens, consider
+      class C a b | a -> b
+      data T a where
+         MkT :: C a d => [d] -> T a
+      f :: C a b => T a -> F Int
+      f (MkT xs) = length xs
+  Then we get a [D] b~d.  But there *is* a legitimate call to
+  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should
+  not reject the program.
+
+  For wanteds, something similar
+      data T a where
+        MkT :: C Int b => a -> b -> T a
+      g :: C Int c => c -> ()
+      f :: T a -> ()
+      f (MkT x y) = g x
+  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
+  But again f (MkT True True) is a legitimate call.
+
+(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
+derived superclasses between iterations of the solver.)
+
+For functional dependencies, here is a real example,
+stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
+
+  class C a b | a -> b
+  g :: C a b => a -> b -> ()
+  f :: C a b => a -> b -> ()
+  f xa xb =
+      let loop = g xa
+      in loop xb
+
+We will first try to infer a type for loop, and we will succeed:
+    C a b' => b' -> ()
+Subsequently, we will type check (loop xb) and all is good. But,
+recall that we have to solve a final implication constraint:
+    C a b => (C a b' => .... cts from body of loop .... ))
+And now we have a problem as we will generate an equality b ~ b' and fail to
+solve it.
+
+
+************************************************************************
+*                                                                      *
+                Irreducible predicate errors
+*                                                                      *
+************************************************************************
+-}
+
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkIrredErr ctxt cts
+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
+       ; let orig = ctOrigin ct1
+             msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
+       ; mkErrorMsgFromCt ctxt ct1 $
+            important msg `mappend` relevant_bindings binds_msg }
+  where
+    (ct1:_) = cts
+
+----------------
+mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
+mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
+  -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible
+  -- in-scope variables in the message, and note inaccessible exact matches
+  = do { dflags   <- getDynFlags
+       ; imp_info <- getImports
+       ; curr_mod <- getModule
+       ; hpt <- getHpt
+       ; let suggs_msg = unknownNameSuggestions dflags hpt curr_mod rdr_env0
+                                                (tcl_rdr lcl_env) imp_info rdr
+       ; rdr_env     <- getGlobalRdrEnv
+       ; splice_locs <- getTopLevelSpliceLocs
+       ; let match_msgs = mk_match_msgs rdr_env splice_locs
+       ; mkErrDocAt (RealSrcSpan err_loc) $
+                    errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }
+
+  where
+    rdr         = mkRdrUnqual occ
+    ct_loc      = ctLoc ct
+    lcl_env     = ctLocEnv ct_loc
+    err_loc     = tcl_loc lcl_env
+    hole_ty     = ctEvPred (ctEvidence ct)
+    boring_type = isTyVarTy hole_ty
+
+    out_of_scope_msg -- Print v :: ty only if the type has structure
+      | boring_type = hang herald 2 (ppr occ)
+      | otherwise   = hang herald 2 (pp_with_type occ hole_ty)
+
+    herald | isDataOcc occ = text "Data constructor not in scope:"
+           | otherwise     = text "Variable not in scope:"
+
+    -- Indicate if the out-of-scope variable exactly (and unambiguously) matches
+    -- a top-level binding in a later inter-splice group; see Note [OutOfScope
+    -- exact matches]
+    mk_match_msgs rdr_env splice_locs
+      = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)
+        in case gres of
+             [gre]
+               |  RealSrcSpan bind_loc <- greSrcSpan gre
+                  -- Find splice between the unbound variable and the match; use
+                  -- lookupLE, not lookupLT, since match could be in the splice
+               ,  Just th_loc <- Set.lookupLE bind_loc splice_locs
+               ,  err_loc < th_loc
+               -> [mk_bind_scope_msg bind_loc th_loc]
+             _ -> []
+
+    mk_bind_scope_msg bind_loc th_loc
+      | is_th_bind
+      = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))
+           2 (text "is not in scope before line" <+> int th_start_ln)
+      | otherwise
+      = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")
+           2 (text "before the splice on" <+> th_rng)
+      where
+        bind_rng = parens (text "line" <+> int bind_ln)
+        th_rng
+          | th_start_ln == th_end_ln = single
+          | otherwise                = multi
+        single = text "line"  <+> int th_start_ln
+        multi  = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln
+        bind_ln     = srcSpanStartLine bind_loc
+        th_start_ln = srcSpanStartLine th_loc
+        th_end_ln   = srcSpanEndLine   th_loc
+        is_th_bind = th_loc `containsSpan` bind_loc
+
+mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })
+  -- Explicit holes, like "_" or "_f"
+  = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct
+               -- The 'False' means "don't filter the bindings"; see #8191
+
+       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints
+       ; let constraints_msg
+               | isExprHoleCt ct, show_hole_constraints
+                  = givenConstraintsMsg ctxt
+               | otherwise = empty
+
+       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits
+       ; (ctxt, sub_msg) <- if show_valid_hole_fits
+                            then validHoleFits ctxt tidy_simples ct
+                            else return (ctxt, empty)
+       ; mkErrorMsgFromCt ctxt ct $
+            important hole_msg `mappend`
+            relevant_bindings (binds_msg $$ constraints_msg) `mappend`
+            valid_hole_fits sub_msg}
+
+  where
+    occ       = holeOcc hole
+    hole_ty   = ctEvPred (ctEvidence ct)
+    hole_kind = tcTypeKind hole_ty
+    tyvars    = tyCoVarsOfTypeList hole_ty
+
+    hole_msg = case hole of
+      ExprHole {} -> vcat [ hang (text "Found hole:")
+                               2 (pp_with_type occ hole_ty)
+                          , tyvars_msg, expr_hole_hint ]
+      TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>
+                                  quotes (ppr occ))
+                               2 (text "standing for" <+>
+                                  quotes pp_hole_type_with_kind)
+                          , tyvars_msg, type_hole_hint ]
+
+    pp_hole_type_with_kind
+      | isLiftedTypeKind hole_kind
+        || isCoVarType hole_ty -- Don't print the kind of unlifted
+                               -- equalities (#15039)
+      = pprType hole_ty
+      | otherwise
+      = pprType hole_ty <+> dcolon <+> pprKind hole_kind
+
+    tyvars_msg = ppUnless (null tyvars) $
+                 text "Where:" <+> (vcat (map loc_msg other_tvs)
+                                    $$ pprSkols ctxt skol_tvs)
+       where
+         (skol_tvs, other_tvs) = partition is_skol tyvars
+         is_skol tv = isTcTyVar tv && isSkolemTyVar tv
+                      -- Coercion variables can be free in the
+                      -- hole, via kind casts
+
+    type_hole_hint
+         | HoleError <- cec_type_holes ctxt
+         = text "To use the inferred type, enable PartialTypeSignatures"
+         | otherwise
+         = empty
+
+    expr_hole_hint                       -- Give hint for, say,   f x = _x
+         | lengthFS (occNameFS occ) > 1  -- Don't give this hint for plain "_"
+         = text "Or perhaps" <+> quotes (ppr occ)
+           <+> text "is mis-spelled, or not in scope"
+         | otherwise
+         = empty
+
+    loc_msg tv
+       | isTyVar tv
+       = case tcTyVarDetails tv of
+           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
+           _         -> empty  -- Skolems dealt with already
+       | otherwise  -- A coercion variable can be free in the hole type
+       = sdocWithDynFlags $ \dflags ->
+         if gopt Opt_PrintExplicitCoercions dflags
+         then quotes (ppr tv) <+> text "is a coercion variable"
+         else empty
+
+mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct)
+
+-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module
+-- imports
+validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the
+                                        -- implications and the tidy environment
+                       -> [Ct]          -- Unsolved simple constraints
+                       -> Ct            -- The hole constraint.
+                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context
+                                                    -- with a possibly updated
+                                                    -- tidy environment, and
+                                                    -- the message.
+validHoleFits ctxt@(CEC {cec_encl = implics
+                             , cec_tidy = lcl_env}) simps ct
+  = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct
+       ; return (ctxt {cec_tidy = tidy_env}, msg) }
+
+-- See Note [Constraints include ...]
+givenConstraintsMsg :: ReportErrCtxt -> SDoc
+givenConstraintsMsg ctxt =
+    let constraints :: [(Type, RealSrcSpan)]
+        constraints =
+          do { implic@Implic{ ic_given = given } <- cec_encl ctxt
+             ; constraint <- given
+             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }
+
+        pprConstraint (constraint, loc) =
+          ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
+
+    in ppUnless (null constraints) $
+         hang (text "Constraints include")
+            2 (vcat $ map pprConstraint constraints)
+
+pp_with_type :: OccName -> Type -> SDoc
+pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)
+
+----------------
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkIPErr ctxt cts
+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
+       ; let orig    = ctOrigin ct1
+             preds   = map ctPred cts
+             givens  = getUserGivens ctxt
+             msg | null givens
+                 = addArising orig $
+                   sep [ text "Unbound implicit parameter" <> plural cts
+                       , nest 2 (pprParendTheta preds) ]
+                 | otherwise
+                 = couldNotDeduce givens (preds, orig)
+
+       ; mkErrorMsgFromCt ctxt ct1 $
+            important msg `mappend` relevant_bindings binds_msg }
+  where
+    (ct1:_) = cts
+
+{-
+
+Note [Constraints include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'givenConstraintsMsg' returns the "Constraints include ..." message enabled by
+-fshow-hole-constraints. For example, the following hole:
+
+    foo :: (Eq a, Show a) => a -> String
+    foo x = _
+
+would generate the message:
+
+    Constraints include
+      Eq a (from foo.hs:1:1-36)
+      Show a (from foo.hs:1:1-36)
+
+Constraints are displayed in order from innermost (closest to the hole) to
+outermost. There's currently no filtering or elimination of duplicates.
+
+
+Note [OutOfScope exact matches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When constructing an out-of-scope error message, we not only generate a list of
+possible in-scope alternatives but also search for an exact, unambiguous match
+in a later inter-splice group.  If we find such a match, we report its presence
+(and indirectly, its scope) in the message.  For example, if a module A contains
+the following declarations,
+
+   foo :: Int
+   foo = x
+
+   $(return [])  -- Empty top-level splice
+
+   x :: Int
+   x = 23
+
+we will issue an error similar to
+
+   A.hs:6:7: error:
+       • Variable not in scope: x :: Int
+       • ‘x’ (line 11) is not in scope before the splice on line 8
+
+By providing information about the match, we hope to clarify why declaring a
+variable after a top-level splice but using it before the splice generates an
+out-of-scope error (a situation which is often confusing to Haskell newcomers).
+
+Note that if we find multiple exact matches to the out-of-scope variable
+(hereafter referred to as x), we report nothing.  Such matches can only be
+duplicate record fields, as the presence of any other duplicate top-level
+declarations would have already halted compilation.  But if these record fields
+are declared in a later inter-splice group, then so too are their corresponding
+types.  Thus, these types must not occur in the inter-splice group containing x
+(any unknown types would have already been reported), and so the matches to the
+record fields are most likely coincidental.
+
+One oddity of the exact match portion of the error message is that we specify
+where the match to x is NOT in scope.  Why not simply state where the match IS
+in scope?  It most cases, this would be just as easy and perhaps a little
+clearer for the user.  But now consider the following example:
+
+    {-# LANGUAGE TemplateHaskell #-}
+
+    module A where
+
+    import Language.Haskell.TH
+    import Language.Haskell.TH.Syntax
+
+    foo = x
+
+    $(do -------------------------------------------------
+        ds <- [d| ok1 = x
+                |]
+        addTopDecls ds
+        return [])
+
+    bar = $(do
+            ds <- [d| x = 23
+                      ok2 = x
+                    |]
+            addTopDecls ds
+            litE $ stringL "hello")
+
+    $(return []) -----------------------------------------
+
+    ok3 = x
+
+Here, x is out-of-scope in the declaration of foo, and so we report
+
+    A.hs:8:7: error:
+        • Variable not in scope: x
+        • ‘x’ (line 16) is not in scope before the splice on lines 10-14
+
+If we instead reported where x IS in scope, we would have to state that it is in
+scope after the second top-level splice as well as among all the top-level
+declarations added by both calls to addTopDecls.  But doing so would not only
+add complexity to the code but also overwhelm the user with unneeded
+information.
+
+The logic which determines where x is not in scope is straightforward: it simply
+finds the last top-level splice which occurs after x but before (or at) the
+match to x (assuming such a splice exists).  In most cases, the check that the
+splice occurs after x acts only as a sanity check.  For example, when the match
+to x is a non-TH top-level declaration and a splice S occurs before the match,
+then x must precede S; otherwise, it would be in scope.  But when dealing with
+addTopDecls, this check serves a practical purpose.  Consider the following
+declarations:
+
+    $(do
+        ds <- [d| ok = x
+                  x = 23
+                |]
+        addTopDecls ds
+        return [])
+
+    foo = x
+
+In this case, x is not in scope in the declaration for foo.  Since x occurs
+AFTER the splice containing the match, the logic does not find any splices after
+x but before or at its match, and so we report nothing about x's scope.  If we
+had not checked whether x occurs before the splice, we would have instead
+reported that x is not in scope before the splice.  While correct, such an error
+message is more likely to confuse than to enlighten.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                Equality errors
+*                                                                      *
+************************************************************************
+
+Note [Inaccessible code]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a where
+     T1 :: T a
+     T2 :: T Bool
+
+   f :: (a ~ Int) => T a -> Int
+   f T1 = 3
+   f T2 = 4   -- Unreachable code
+
+Here the second equation is unreachable. The original constraint
+(a~Int) from the signature gets rewritten by the pattern-match to
+(Bool~Int), so the danger is that we report the error as coming from
+the *signature* (#7293).  So, for Given errors we replace the
+env (and hence src-loc) on its CtLoc with that from the immediately
+enclosing implication.
+
+Note [Error messages for untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#9109)
+  data G a where { GBool :: G Bool }
+  foo x = case x of GBool -> True
+
+Here we can't solve (t ~ Bool), where t is the untouchable result
+meta-var 't', because of the (a ~ Bool) from the pattern match.
+So we infer the type
+   f :: forall a t. G a -> t
+making the meta-var 't' into a skolem.  So when we come to report
+the unsolved (t ~ Bool), t won't look like an untouchable meta-var
+any more.  So we don't assert that it is.
+-}
+
+-- Don't have multiple equality errors from the same location
+-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
+mkEqErr _ [] = panic "mkEqErr"
+
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkEqErr1 ctxt ct   -- Wanted or derived;
+                   -- givens handled in mkGivenErrorReporter
+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+       ; rdr_env <- getGlobalRdrEnv
+       ; fam_envs <- tcGetFamInstEnvs
+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms
+       ; let (keep_going, is_oriented, wanted_msg)
+                           = mk_wanted_extra (ctLoc ct) exp_syns
+             coercible_msg = case ctEqRel ct of
+               NomEq  -> empty
+               ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
+       ; dflags <- getDynFlags
+       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going)
+       ; let report = mconcat [important wanted_msg, important coercible_msg,
+                               relevant_bindings binds_msg]
+       ; if keep_going
+         then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2
+         else mkErrorMsgFromCt ctxt ct report }
+  where
+    (ty1, ty2) = getEqPredTys (ctPred ct)
+
+       -- If the types in the error message are the same as the types
+       -- we are unifying, don't add the extra expected/actual message
+    mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
+    mk_wanted_extra loc expandSyns
+      = case ctLocOrigin loc of
+          orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig
+                                                      t_or_k expandSyns
+            where
+              t_or_k = ctLocTypeOrKind_maybe loc
+
+          KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k
+            -> (True, Nothing, msg1 $$ msg2)
+            where
+              sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"
+                                            _              -> text "types"
+              msg1 = sdocWithDynFlags $ \dflags ->
+                     case mb_cty2 of
+                       Just cty2
+                         |  gopt Opt_PrintExplicitCoercions dflags
+                         || not (cty1 `pickyEqType` cty2)
+                         -> hang (text "When matching" <+> sub_what)
+                               2 (vcat [ ppr cty1 <+> dcolon <+>
+                                         ppr (tcTypeKind cty1)
+                                       , ppr cty2 <+> dcolon <+>
+                                         ppr (tcTypeKind cty2) ])
+                       _ -> text "When matching the kind of" <+> quotes (ppr cty1)
+              msg2 = case sub_o of
+                       TypeEqOrigin {}
+                         | Just cty2 <- mb_cty2 ->
+                         thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k
+                                                     expandSyns)
+                       _ -> empty
+          _ -> (True, Nothing, empty)
+
+-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
+-- is left over.
+mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
+                       -> TcType -> TcType -> SDoc
+mkCoercibleExplanation rdr_env fam_envs ty1 ty2
+  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
+  , Just msg <- coercible_msg_for_tycon rep_tc
+  = msg
+  | Just (tc, tys) <- splitTyConApp_maybe ty2
+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
+  , Just msg <- coercible_msg_for_tycon rep_tc
+  = msg
+  | Just (s1, _) <- tcSplitAppTy_maybe ty1
+  , Just (s2, _) <- tcSplitAppTy_maybe ty2
+  , s1 `eqType` s2
+  , has_unknown_roles s1
+  = hang (text "NB: We cannot know what roles the parameters to" <+>
+          quotes (ppr s1) <+> text "have;")
+       2 (text "we must assume that the role is nominal")
+  | otherwise
+  = empty
+  where
+    coercible_msg_for_tycon tc
+        | isAbstractTyCon tc
+        = Just $ hsep [ text "NB: The type constructor"
+                      , quotes (pprSourceTyCon tc)
+                      , text "is abstract" ]
+        | isNewTyCon tc
+        , [data_con] <- tyConDataCons tc
+        , let dc_name = dataConName data_con
+        , isNothing (lookupGRE_Name rdr_env dc_name)
+        = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
+                    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
+                           , text "is not in scope" ])
+        | otherwise = Nothing
+
+    has_unknown_roles ty
+      | Just (tc, tys) <- tcSplitTyConApp_maybe ty
+      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon
+      | Just (s, _) <- tcSplitAppTy_maybe ty
+      = has_unknown_roles s
+      | isTyVarTy ty
+      = True
+      | otherwise
+      = False
+
+{-
+-- | Make a listing of role signatures for all the parameterised tycons
+-- used in the provided types
+
+
+-- SLPJ Jun 15: I could not convince myself that these hints were really
+-- useful.  Maybe they are, but I think we need more work to make them
+-- actually helpful.
+mkRoleSigs :: Type -> Type -> SDoc
+mkRoleSigs ty1 ty2
+  = ppUnless (null role_sigs) $
+    hang (text "Relevant role signatures:")
+       2 (vcat role_sigs)
+  where
+    tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
+    role_sigs = mapMaybe ppr_role_sig tcs
+
+    ppr_role_sig tc
+      | null roles  -- if there are no parameters, don't bother printing
+      = Nothing
+      | isBuiltInSyntax (tyConName tc)  -- don't print roles for (->), etc.
+      = Nothing
+      | otherwise
+      = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
+      where
+        roles = tyConRoles tc
+-}
+
+mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
+             -> Ct
+             -> Maybe SwapFlag   -- Nothing <=> not sure
+             -> TcType -> TcType -> TcM ErrMsg
+mkEqErr_help dflags ctxt report ct oriented ty1 ty2
+  | Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1
+  = mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
+  = mkTyVarEqErr dflags ctxt report ct swapped  tv2 co2 ty1
+  | otherwise
+  = reportEqErr ctxt report ct oriented ty1 ty2
+  where
+    swapped = fmap flipSwap oriented
+
+reportEqErr :: ReportErrCtxt -> Report
+            -> Ct
+            -> Maybe SwapFlag   -- Nothing <=> not sure
+            -> TcType -> TcType -> TcM ErrMsg
+reportEqErr ctxt report ct oriented ty1 ty2
+  = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])
+  where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2
+        eqInfo = important $ mkEqInfoMsg ct ty1 ty2
+
+mkTyVarEqErr, mkTyVarEqErr'
+  :: DynFlags -> ReportErrCtxt -> Report -> Ct
+             -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
+-- tv1 and ty2 are already tidied
+mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
+  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)
+       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }
+
+mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
+  | not insoluble_occurs_check   -- See Note [Occurs check wins]
+  , isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
+                            -- be oriented the other way round;
+                            -- see TcCanonical.canEqTyVarTyVar
+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)
+    || ctEqRel ct == ReprEq
+     -- the cases below don't really apply to ReprEq (except occurs check)
+  = mkErrorMsgFromCt ctxt ct $ mconcat
+        [ important $ misMatchOrCND ctxt ct oriented ty1 ty2
+        , important $ extraTyVarEqInfo ctxt tv1 ty2
+        , report
+        ]
+
+  | MTVU_Occurs <- occ_check_expand
+    -- We report an "occurs check" even for  a ~ F t a, where F is a type
+    -- function; it's not insoluble (because in principle F could reduce)
+    -- but we have certainly been unable to solve it
+    -- See Note [Occurs check error] in TcCanonical
+  = do { let main_msg = addArising (ctOrigin ct) $
+                        hang (text "Occurs check: cannot construct the infinite" <+> what <> colon)
+                              2 (sep [ppr ty1, char '~', ppr ty2])
+
+             extra2 = important $ mkEqInfoMsg ct ty1 ty2
+
+             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
+                                  filter isTyVar $
+                                  fvVarList $
+                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
+             extra3 = relevant_bindings $
+                      ppWhen (not (null interesting_tyvars)) $
+                      hang (text "Type variable kinds:") 2 $
+                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
+                                interesting_tyvars)
+
+             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+       ; mkErrorMsgFromCt ctxt ct $
+         mconcat [important main_msg, extra2, extra3, report] }
+
+  | MTVU_Bad <- occ_check_expand
+  = do { let msg = vcat [ text "Cannot instantiate unification variable"
+                          <+> quotes (ppr tv1)
+                        , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2)
+                        , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]
+       -- Unlike the other reports, this discards the old 'report_important'
+       -- instead of augmenting it.  This is because the details are not likely
+       -- to be helpful since this is just an unimplemented feature.
+       ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
+
+   -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]
+   -- in TcCanonical
+  | not (k1 `tcEqType` k2)
+  = do { let main_msg = addArising (ctOrigin ct) $
+                        vcat [ hang (text "Kind mismatch: cannot unify" <+>
+                                     parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>
+                                     text "with:")
+                                  2 (sep [ppr ty2, dcolon, ppr k2])
+                             , text "Their kinds differ." ]
+             cast_msg
+               | isTcReflexiveCo co1 = empty
+               | otherwise           = text "NB:" <+> ppr tv1 <+>
+                                       text "was casted to have kind" <+>
+                                       quotes (ppr k1)
+
+       ; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) }
+
+  -- If the immediately-enclosing implication has 'tv' a skolem, and
+  -- we know by now its an InferSkol kind of skolem, then presumably
+  -- it started life as a TyVarTv, else it'd have been unified, given
+  -- that there's no occurs-check or forall problem
+  | (implic:_) <- cec_encl ctxt
+  , Implic { ic_skols = skols } <- implic
+  , tv1 `elem` skols
+  = mkErrorMsgFromCt ctxt ct $ mconcat
+        [ important $ misMatchMsg ct oriented ty1 ty2
+        , important $ extraTyVarEqInfo ctxt tv1 ty2
+        , report
+        ]
+
+  -- Check for skolem escape
+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
+  , Implic { ic_skols = skols, ic_info = skol_info } <- implic
+  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
+  , not (null esc_skols)
+  = do { let msg = important $ misMatchMsg ct oriented ty1 ty2
+             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
+                             <+> pprQuotedList esc_skols
+                           , text "would escape" <+>
+                             if isSingleton esc_skols then text "its scope"
+                                                      else text "their scope" ]
+             tv_extra = important $
+                        vcat [ nest 2 $ esc_doc
+                             , sep [ (if isSingleton esc_skols
+                                      then text "This (rigid, skolem)" <+>
+                                           what <+> text "variable is"
+                                      else text "These (rigid, skolem)" <+>
+                                           what <+> text "variables are")
+                               <+> text "bound by"
+                             , nest 2 $ ppr skol_info
+                             , nest 2 $ text "at" <+>
+                               ppr (tcl_loc (implicLclEnv implic)) ] ]
+       ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
+
+  -- Nastiest case: attempt to unify an untouchable variable
+  -- So tv is a meta tyvar (or started that way before we
+  -- generalised it).  So presumably it is an *untouchable*
+  -- meta tyvar or a TyVarTv, else it'd have been unified
+  -- See Note [Error messages for untouchables]
+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
+  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
+  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
+           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
+    do { let msg = important $ misMatchMsg ct oriented ty1 ty2
+             tclvl_extra = important $
+                  nest 2 $
+                  sep [ quotes (ppr tv1) <+> text "is untouchable"
+                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
+                      , nest 2 $ text "bound by" <+> ppr skol_info
+                      , nest 2 $ text "at" <+>
+                        ppr (tcl_loc (implicLclEnv implic)) ]
+             tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
+             add_sig  = important $ suggestAddSig ctxt ty1 ty2
+       ; mkErrorMsgFromCt ctxt ct $ mconcat
+            [msg, tclvl_extra, tv_extra, add_sig, report] }
+
+  | otherwise
+  = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2
+        -- This *can* happen (#6123, and test T2627b)
+        -- Consider an ambiguous top-level constraint (a ~ F a)
+        -- Not an occurs check, because F is a type function.
+  where
+    Pair _ k1 = tcCoercionKind co1
+    k2        = tcTypeKind ty2
+
+    ty1 = mkTyVarTy tv1
+    occ_check_expand       = occCheckForErrors dflags tv1 ty2
+    insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2
+
+    what = case ctLocTypeOrKind_maybe (ctLoc ct) of
+      Just KindLevel -> text "kind"
+      _              -> text "type"
+
+mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
+-- Report (a) ambiguity if either side is a type function application
+--            e.g. F a0 ~ Int
+--        (b) warning about injectivity if both sides are the same
+--            type function application   F a ~ F b
+--            See Note [Non-injective type functions]
+mkEqInfoMsg ct ty1 ty2
+  = tyfun_msg $$ ambig_msg
+  where
+    mb_fun1 = isTyFun_maybe ty1
+    mb_fun2 = isTyFun_maybe ty2
+
+    ambig_msg | isJust mb_fun1 || isJust mb_fun2
+              = snd (mkAmbigMsg False ct)
+              | otherwise = empty
+
+    tyfun_msg | Just tc1 <- mb_fun1
+              , Just tc2 <- mb_fun2
+              , tc1 == tc2
+              , not (isInjectiveTyCon tc1 Nominal)
+              = text "NB:" <+> quotes (ppr tc1)
+                <+> text "is a non-injective type family"
+              | otherwise = empty
+
+isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
+-- See Note [Reporting occurs-check errors]
+isUserSkolem ctxt tv
+  = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
+  where
+    is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
+      = tv `elem` sks && is_user_skol_info skol_info
+
+    is_user_skol_info (InferSkol {}) = False
+    is_user_skol_info _ = True
+
+misMatchOrCND :: ReportErrCtxt -> Ct
+              -> Maybe SwapFlag -> TcType -> TcType -> SDoc
+-- If oriented then ty1 is actual, ty2 is expected
+misMatchOrCND ctxt ct oriented ty1 ty2
+  | null givens ||
+    (isRigidTy ty1 && isRigidTy ty2) ||
+    isGivenCt ct
+       -- If the equality is unconditionally insoluble
+       -- or there is no context, don't report the context
+  = misMatchMsg ct oriented ty1 ty2
+  | otherwise
+  = couldNotDeduce givens ([eq_pred], orig)
+  where
+    ev      = ctEvidence ct
+    eq_pred = ctEvPred ev
+    orig    = ctEvOrigin ev
+    givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
+              -- Keep only UserGivens that have some equalities.
+              -- See Note [Suppress redundant givens during error reporting]
+
+couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
+couldNotDeduce givens (wanteds, orig)
+  = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)
+         , vcat (pp_givens givens)]
+
+pp_givens :: [UserGiven] -> [SDoc]
+pp_givens givens
+   = case givens of
+         []     -> []
+         (g:gs) ->      ppr_given (text "from the context:") g
+                 : map (ppr_given (text "or from:")) gs
+    where
+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })
+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))
+             -- See Note [Suppress redundant givens during error reporting]
+             -- for why we use mkMinimalBySCs above.
+                2 (sep [ text "bound by" <+> ppr skol_info
+                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])
+
+{-
+Note [Suppress redundant givens during error reporting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When GHC is unable to solve a constraint and prints out an error message, it
+will print out what given constraints are in scope to provide some context to
+the programmer. But we shouldn't print out /every/ given, since some of them
+are not terribly helpful to diagnose type errors. Consider this example:
+
+  foo :: Int :~: Int -> a :~: b -> a :~: c
+  foo Refl Refl = Refl
+
+When reporting that GHC can't solve (a ~ c), there are two givens in scope:
+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,
+redundant), so it's not terribly useful to report it in an error message.
+To accomplish this, we discard any Implications that do not bind any
+equalities by filtering the `givens` selected in `misMatchOrCND` (based on
+the `ic_no_eqs` field of the Implication).
+
+But this is not enough to avoid all redundant givens! Consider this example,
+from #15361:
+
+  goo :: forall (a :: Type) (b :: Type) (c :: Type).
+         a :~~: b -> a :~~: c
+  goo HRefl = HRefl
+
+Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
+The (* ~ *) part arises due the kinds of (:~~:) being unified. More
+importantly, (* ~ *) is redundant, so we'd like not to report it. However,
+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
+ic_no_eqs field), so the test above will keep it wholesale.
+
+To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
+part. This works because mkMinimalBySCs eliminates reflexive equalities in
+addition to superclasses (see Note [Remove redundant provided dicts]
+in TcPatSyn).
+-}
+
+extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
+-- Add on extra info about skolem constants
+-- NB: The types themselves are already tidied
+extraTyVarEqInfo ctxt tv1 ty2
+  = extraTyVarInfo ctxt tv1 $$ ty_extra ty2
+  where
+    ty_extra ty = case tcGetTyVar_maybe ty of
+                    Just tv -> extraTyVarInfo ctxt tv
+                    Nothing -> empty
+
+extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
+extraTyVarInfo ctxt tv
+  = ASSERT2( isTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+          SkolemTv {}   -> pprSkols ctxt [tv]
+          RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"
+          MetaTv {}     -> empty
+
+suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
+-- See Note [Suggest adding a type signature]
+suggestAddSig ctxt ty1 ty2
+  | null inferred_bndrs
+  = empty
+  | [bndr] <- inferred_bndrs
+  = text "Possible fix: add a type signature for" <+> quotes (ppr bndr)
+  | otherwise
+  = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)
+  where
+    inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
+    get_inf ty | Just tv <- tcGetTyVar_maybe ty
+               , isSkolemTyVar tv
+               , (implic, _) : _ <- getSkolemInfo (cec_encl ctxt) [tv]
+               , InferSkol prs <- ic_info implic
+               = map fst prs
+               | otherwise
+               = []
+
+--------------------
+misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
+-- Types are already tidy
+-- If oriented then ty1 is actual, ty2 is expected
+misMatchMsg ct oriented ty1 ty2
+  | Just NotSwapped <- oriented
+  = misMatchMsg ct (Just IsSwapped) ty2 ty1
+
+  -- These next two cases are when we're about to report, e.g., that
+  -- 'LiftedRep doesn't match 'VoidRep. Much better just to say
+  -- lifted vs. unlifted
+  | isLiftedRuntimeRep ty1
+  = lifted_vs_unlifted
+
+  | isLiftedRuntimeRep ty2
+  = lifted_vs_unlifted
+
+  | otherwise  -- So now we have Nothing or (Just IsSwapped)
+               -- For some reason we treat Nothing like IsSwapped
+  = addArising orig $
+    pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $
+    sep [ text herald1 <+> quotes (ppr ty1)
+        , nest padding $
+          text herald2 <+> quotes (ppr ty2)
+        , sameOccExtra ty2 ty1 ]
+  where
+    herald1 = conc [ "Couldn't match"
+                   , if is_repr     then "representation of" else ""
+                   , if is_oriented then "expected"          else ""
+                   , what ]
+    herald2 = conc [ "with"
+                   , if is_repr     then "that of"           else ""
+                   , if is_oriented then ("actual " ++ what) else "" ]
+    padding = length herald1 - length herald2
+
+    is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }
+    is_oriented = isJust oriented
+
+    orig = ctOrigin ct
+    what = case ctLocTypeOrKind_maybe (ctLoc ct) of
+      Just KindLevel -> "kind"
+      _              -> "type"
+
+    conc :: [String] -> String
+    conc = foldr1 add_space
+
+    add_space :: String -> String -> String
+    add_space s1 s2 | null s1   = s2
+                    | null s2   = s1
+                    | otherwise = s1 ++ (' ' : s2)
+
+    lifted_vs_unlifted
+      = addArising orig $
+        text "Couldn't match a lifted type with an unlifted type"
+
+-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a
+-- type mismatch occurs to due invisible kind arguments.
+--
+-- This function first checks to see if the 'CtOrigin' argument is a
+-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to
+-- check for a kind mismatch (as these types typically have more surrounding
+-- types and are likelier to be able to glean information about whether a
+-- mismatch occurred in an invisible argument position or not). If the
+-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types
+-- themselves.
+pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
+                                 -> SDoc -> SDoc
+pprWithExplicitKindsWhenMismatch ty1 ty2 ct
+  = pprWithExplicitKindsWhen show_kinds
+  where
+    (act_ty, exp_ty) = case ct of
+      TypeEqOrigin { uo_actual = act
+                   , uo_expected = exp } -> (act, exp)
+      _                                  -> (ty1, ty2)
+    show_kinds = tcEqTypeVis act_ty exp_ty
+                 -- True when the visible bit of the types look the same,
+                 -- so we want to show the kinds in the displayed type
+
+mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
+                    -> (Bool, Maybe SwapFlag, SDoc)
+-- NotSwapped means (actual, expected), IsSwapped is the reverse
+-- First return val is whether or not to print a herald above this msg
+mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act
+                                             , uo_expected = exp
+                                             , uo_thing = maybe_thing })
+                    m_level printExpanded
+  | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)
+  | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)
+  | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)
+  | tcIsLiftedTypeKind exp                       = (False, Nothing, msg4)
+  | Just msg <- num_args_msg                     = (False, Nothing, msg $$ msg1)
+  | KindLevel <- level, Just th <- maybe_thing   = (False, Nothing, msg5 th)
+  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)
+  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty)
+  | otherwise                                    = (True, Nothing, msg1)
+  where
+    level = m_level `orElse` TypeLevel
+
+    occurs_check_error
+      | Just act_tv <- tcGetTyVar_maybe act
+      , act_tv `elemVarSet` tyCoVarsOfType exp
+      = True
+      | Just exp_tv <- tcGetTyVar_maybe exp
+      , exp_tv `elemVarSet` tyCoVarsOfType act
+      = True
+      | otherwise
+      = False
+
+    sort = case level of
+      TypeLevel -> text "type"
+      KindLevel -> text "kind"
+
+    msg1 = case level of
+      KindLevel
+        | Just th <- maybe_thing
+        -> msg5 th
+
+      _ | not (act `pickyEqType` exp)
+        -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $
+           vcat [ text "Expected" <+> sort <> colon <+> ppr exp
+                , text "  Actual" <+> sort <> colon <+> ppr act
+                , if printExpanded then expandedTys else empty ]
+
+        | otherwise
+        -> empty
+
+    thing_msg = case maybe_thing of
+                  Just thing -> \_ -> quotes thing <+> text "is"
+                  Nothing    -> \vowel -> text "got a" <>
+                                          if vowel then char 'n' else empty
+    msg2 = sep [ text "Expecting a lifted type, but"
+               , thing_msg True, text "unlifted" ]
+    msg3 = sep [ text "Expecting an unlifted type, but"
+               , thing_msg False, text "lifted" ]
+    msg4 = maybe_num_args_msg $$
+           sep [ text "Expected a type, but"
+               , maybe (text "found something with kind")
+                       (\thing -> quotes thing <+> text "has kind")
+                       maybe_thing
+               , quotes (pprWithTYPE act) ]
+
+    msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $
+              hang (text "Expected" <+> kind_desc <> comma)
+                 2 (text "but" <+> quotes th <+> text "has kind" <+>
+                    quotes (ppr act))
+      where
+        kind_desc | tcIsConstraintKind exp = text "a constraint"
+
+                    -- TYPE t0
+                  | Just arg <- kindRep_maybe exp
+                  , tcIsTyVarTy arg = sdocWithDynFlags $ \dflags ->
+                                      if gopt Opt_PrintExplicitRuntimeReps dflags
+                                      then text "kind" <+> quotes (ppr exp)
+                                      else text "a type"
+
+                  | otherwise       = text "kind" <+> quotes (ppr exp)
+
+    num_args_msg = case level of
+      KindLevel
+        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)
+           -- if one is a meta-tyvar, then it's possible that the user
+           -- has asked for something impredicative, and we couldn't unify.
+           -- Don't bother with counting arguments.
+        -> let n_act = count_args act
+               n_exp = count_args exp in
+           case n_act - n_exp of
+             n | n > 0   -- we don't know how many args there are, so don't
+                         -- recommend removing args that aren't
+               , Just thing <- maybe_thing
+               -> Just $ text "Expecting" <+> speakN (abs n) <+>
+                         more <+> quotes thing
+               where
+                 more
+                  | n == 1    = text "more argument to"
+                  | otherwise = text "more arguments to"  -- n > 1
+             _ -> Nothing
+
+      _ -> Nothing
+
+    maybe_num_args_msg = case num_args_msg of
+      Nothing -> empty
+      Just m  -> m
+
+    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty
+
+    expandedTys =
+      ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
+        [ text "Type synonyms expanded:"
+        , text "Expected type:" <+> ppr expTy1
+        , text "  Actual type:" <+> ppr expTy2
+        ]
+
+    (expTy1, expTy2) = expandSynonymsToMatch exp act
+
+mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"
+
+{- Note [Insoluble occurs check wins]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble
+so we don't use it for rewriting.  The Wanted is also insoluble, and
+we don't solve it from the Given.  It's very confusing to say
+    Cannot solve a ~ [a] from given constraints a ~ [a]
+
+And indeed even thinking about the Givens is silly; [W] a ~ [a] is
+just as insoluble as Int ~ Bool.
+
+Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)
+then report it first.
+
+(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't
+want to be as draconian with them.)
+
+Note [Expanding type synonyms to make types similar]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In type error messages, if -fprint-expanded-types is used, we want to expand
+type synonyms to make expected and found types as similar as possible, but we
+shouldn't expand types too much to make type messages even more verbose and
+harder to understand. The whole point here is to make the difference in expected
+and found types clearer.
+
+`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
+only as much as necessary. Given two types t1 and t2:
+
+  * If they're already same, it just returns the types.
+
+  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
+    type constructors), it expands C1 and C2 if they're different type synonyms.
+    Then it recursively does the same thing on expanded types. If C1 and C2 are
+    same, then it applies the same procedure to arguments of C1 and arguments of
+    C2 to make them as similar as possible.
+
+    Most important thing here is to keep number of synonym expansions at
+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,
+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and
+    `T (T3, T3, Bool)`.
+
+  * Otherwise types don't have same shapes and so the difference is clearly
+    visible. It doesn't do any expansions and show these types.
+
+Note that we only expand top-layer type synonyms. Only when top-layer
+constructors are the same we start expanding inner type synonyms.
+
+Suppose top-layer type synonyms of t1 and t2 can expand N and M times,
+respectively. If their type-synonym-expanded forms will meet at some point (i.e.
+will have same shapes according to `sameShapes` function), it's possible to find
+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))
+comparisons. We first collect all the top-layer expansions of t1 and t2 in two
+lists, then drop the prefix of the longer list so that they have same lengths.
+Then we search through both lists in parallel, and return the first pair of
+types that have same shapes. Inner types of these two types with same shapes
+are then expanded using the same algorithm.
+
+In case they don't meet, we return the last pair of types in the lists, which
+has top-layer type synonyms completely expanded. (in this case the inner types
+are not expanded at all, as the current form already shows the type error)
+-}
+
+-- | Expand type synonyms in given types only enough to make them as similar as
+-- possible. Returned types are the same in terms of used type synonyms.
+--
+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.
+--
+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for
+-- some examples of how this should work.
+expandSynonymsToMatch :: Type -> Type -> (Type, Type)
+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
+  where
+    (ty1_ret, ty2_ret) = go ty1 ty2
+
+    -- | Returns (type synonym expanded version of first type,
+    --            type synonym expanded version of second type)
+    go :: Type -> Type -> (Type, Type)
+    go t1 t2
+      | t1 `pickyEqType` t2 =
+        -- Types are same, nothing to do
+        (t1, t2)
+
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2 =
+        -- Type constructors are same. They may be synonyms, but we don't
+        -- expand further.
+        let (tys1', tys2') =
+              unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)
+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')
+
+    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
+      let (t1_1', t2_1') = go t1_1 t2_1
+          (t1_2', t2_2') = go t1_2 t2_2
+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
+
+    go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) =
+      let (t1_1', t2_1') = go t1_1 t2_1
+          (t1_2', t2_2') = go t1_2 t2_2
+       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }
+          , ty2 { ft_arg = t2_1', ft_res = t2_2' })
+
+    go (ForAllTy b1 t1) (ForAllTy b2 t2) =
+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.
+      -- See D1016 comments for details and our attempts at producing a test
+      -- case. Short version: We probably need RnEnv2 to really get this right.
+      let (t1', t2') = go t1 t2
+       in (ForAllTy b1 t1', ForAllTy b2 t2')
+
+    go (CastTy ty1 _) ty2 = go ty1 ty2
+    go ty1 (CastTy ty2 _) = go ty1 ty2
+
+    go t1 t2 =
+      -- See Note [Expanding type synonyms to make types similar] for how this
+      -- works
+      let
+        t1_exp_tys = t1 : tyExpansions t1
+        t2_exp_tys = t2 : tyExpansions t2
+        t1_exps    = length t1_exp_tys
+        t2_exps    = length t2_exp_tys
+        dif        = abs (t1_exps - t2_exps)
+      in
+        followExpansions $
+          zipEqual "expandSynonymsToMatch.go"
+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)
+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)
+
+    -- | Expand the top layer type synonyms repeatedly, collect expansions in a
+    -- list. The list does not include the original type.
+    --
+    -- Example, if you have:
+    --
+    --   type T10 = T9
+    --   type T9  = T8
+    --   ...
+    --   type T0  = Int
+    --
+    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]
+    --
+    -- This only expands the top layer, so if you have:
+    --
+    --   type M a = Maybe a
+    --
+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)
+    tyExpansions :: Type -> [Type]
+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)
+
+    -- | Drop the type pairs until types in a pair look alike (i.e. the outer
+    -- constructors are the same).
+    followExpansions :: [(Type, Type)] -> (Type, Type)
+    followExpansions [] = pprPanic "followExpansions" empty
+    followExpansions [(t1, t2)]
+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees
+      | otherwise        = (t1, t2) -- the difference is already visible
+    followExpansions ((t1, t2) : tss)
+      -- Traverse subtrees when the outer shapes are the same
+      | sameShapes t1 t2 = go t1 t2
+      -- Otherwise follow the expansions until they look alike
+      | otherwise = followExpansions tss
+
+    sameShapes :: Type -> Type -> Bool
+    sameShapes AppTy{}          AppTy{}          = True
+    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2
+    sameShapes (FunTy {})       (FunTy {})       = True
+    sameShapes (ForAllTy {})    (ForAllTy {})    = True
+    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2
+    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2
+    sameShapes _                _                = False
+
+sameOccExtra :: TcType -> TcType -> SDoc
+-- See Note [Disambiguating (X ~ X) errors]
+sameOccExtra ty1 ty2
+  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
+  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
+  , let n1 = tyConName tc1
+        n2 = tyConName tc2
+        same_occ = nameOccName n1                   == nameOccName n2
+        same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
+  , n1 /= n2   -- Different Names
+  , same_occ   -- but same OccName
+  = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
+  | otherwise
+  = empty
+  where
+    ppr_from same_pkg nm
+      | isGoodSrcSpan loc
+      = hang (quotes (ppr nm) <+> text "is defined at")
+           2 (ppr loc)
+      | otherwise  -- Imported things have an UnhelpfulSrcSpan
+      = hang (quotes (ppr nm))
+           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))
+                  , ppUnless (same_pkg || pkg == mainUnitId) $
+                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])
+       where
+         pkg = moduleUnitId mod
+         mod = nameModule nm
+         loc = nameSrcSpan nm
+
+{-
+Note [Suggest adding a type signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The OutsideIn algorithm rejects GADT programs that don't have a principal
+type, and indeed some that do.  Example:
+   data T a where
+     MkT :: Int -> T Int
+
+   f (MkT n) = n
+
+Does this have type f :: T a -> a, or f :: T a -> Int?
+The error that shows up tends to be an attempt to unify an
+untouchable type variable.  So suggestAddSig sees if the offending
+type variable is bound by an *inferred* signature, and suggests
+adding a declared signature instead.
+
+This initially came up in #8968, concerning pattern synonyms.
+
+Note [Disambiguating (X ~ X) errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #8278
+
+Note [Reporting occurs-check errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
+type signature, then the best thing is to report that we can't unify
+a with [a], because a is a skolem variable.  That avoids the confusing
+"occur-check" error message.
+
+But nowadays when inferring the type of a function with no type signature,
+even if there are errors inside, we still generalise its signature and
+carry on. For example
+   f x = x:x
+Here we will infer something like
+   f :: forall a. a -> [a]
+with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint
+'a' is now a skolem, but not one bound by the programmer in the context!
+Here we really should report an occurs check.
+
+So isUserSkolem distinguishes the two.
+
+Note [Non-injective type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very confusing to get a message like
+     Couldn't match expected type `Depend s'
+            against inferred type `Depend s1'
+so mkTyFunInfoMsg adds:
+       NB: `Depend' is type function, and hence may not be injective
+
+Warn of loopy local equalities that were dropped.
+
+
+************************************************************************
+*                                                                      *
+                 Type-class errors
+*                                                                      *
+************************************************************************
+-}
+
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkDictErr ctxt cts
+  = ASSERT( not (null cts) )
+    do { inst_envs <- tcGetInstEnvs
+       ; let (ct1:_) = cts  -- ct1 just for its location
+             min_cts = elim_superclasses cts
+             lookups = map (lookup_cls_inst inst_envs) min_cts
+             (no_inst_cts, overlap_cts) = partition is_no_inst lookups
+
+       -- Report definite no-instance errors,
+       -- or (iff there are none) overlap errors
+       -- But we report only one of them (hence 'head') because they all
+       -- have the same source-location origin, to try avoid a cascade
+       -- of error from one location
+       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
+       ; mkErrorMsgFromCt ctxt ct1 (important err) }
+  where
+    no_givens = null (getUserGivens ctxt)
+
+    is_no_inst (ct, (matches, unifiers, _))
+      =  no_givens
+      && null matches
+      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
+
+    lookup_cls_inst inst_envs ct
+                -- Note [Flattening in error message generation]
+      = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))
+      where
+        (clas, tys) = getClassPredTys (ctPred ct)
+
+
+    -- When simplifying [W] Ord (Set a), we need
+    --    [W] Eq a, [W] Ord a
+    -- but we really only want to report the latter
+    elim_superclasses cts = mkMinimalBySCs ctPred cts
+
+mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
+            -> TcM (ReportErrCtxt, SDoc)
+-- Report an overlap error if this class constraint results
+-- from an overlap (returning Left clas), otherwise return (Right pred)
+mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
+  | null matches  -- No matches but perhaps several unifiers
+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+       ; candidate_insts <- get_candidate_instances
+       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
+
+  | null unsafe_overlapped   -- Some matches => overlap errors
+  = return (ctxt, overlap_msg)
+
+  | otherwise
+  = return (ctxt, safe_haskell_msg)
+  where
+    orig          = ctOrigin ct
+    pred          = ctPred ct
+    (clas, tys)   = getClassPredTys pred
+    ispecs        = [ispec | (ispec, _) <- matches]
+    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)
+         -- useful_givens are the enclosing implications with non-empty givens,
+         -- modulo the horrid discardProvCtxtGivens
+
+    get_candidate_instances :: TcM [ClsInst]
+    -- See Note [Report candidate instances]
+    get_candidate_instances
+      | [ty] <- tys   -- Only try for single-parameter classes
+      = do { instEnvs <- tcGetInstEnvs
+           ; return (filter (is_candidate_inst ty)
+                            (classInstances instEnvs clas)) }
+      | otherwise = return []
+
+    is_candidate_inst ty inst -- See Note [Report candidate instances]
+      | [other_ty] <- is_tys inst
+      , Just (tc1, _) <- tcSplitTyConApp_maybe ty
+      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty
+      = let n1 = tyConName tc1
+            n2 = tyConName tc2
+            different_names = n1 /= n2
+            same_occ_names = nameOccName n1 == nameOccName n2
+        in different_names && same_occ_names
+      | otherwise = False
+
+    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc
+    cannot_resolve_msg ct candidate_insts binds_msg
+      = vcat [ no_inst_msg
+             , nest 2 extra_note
+             , vcat (pp_givens useful_givens)
+             , mb_patsyn_prov `orElse` empty
+             , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))
+               (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
+
+             , ppWhen (isNothing mb_patsyn_prov) $
+                   -- Don't suggest fixes for the provided context of a pattern
+                   -- synonym; the right fix is to bind more in the pattern
+               show_fixes (ctxtFixes has_ambig_tvs pred implics
+                           ++ drv_fixes)
+             , ppWhen (not (null candidate_insts))
+               (hang (text "There are instances for similar types:")
+                   2 (vcat (map ppr candidate_insts))) ]
+                   -- See Note [Report candidate instances]
+      where
+        orig = ctOrigin ct
+        -- See Note [Highlighting ambiguous type variables]
+        lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
+                        && not (null unifiers) && null useful_givens
+
+        (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
+        ambig_tvs = uncurry (++) (getAmbigTkvs ct)
+
+        no_inst_msg
+          | lead_with_ambig
+          = ambig_msg <+> pprArising orig
+              $$ text "prevents the constraint" <+>  quotes (pprParendType pred)
+              <+> text "from being solved."
+
+          | null useful_givens
+          = addArising orig $ text "No instance for"
+            <+> pprParendType pred
+
+          | otherwise
+          = addArising orig $ text "Could not deduce"
+            <+> pprParendType pred
+
+        potential_msg
+          = ppWhen (not (null unifiers) && want_potential orig) $
+            sdocWithDynFlags $ \dflags ->
+            getPprStyle $ \sty ->
+            pprPotentials dflags sty potential_hdr unifiers
+
+        potential_hdr
+          = vcat [ ppWhen lead_with_ambig $
+                     text "Probable fix: use a type annotation to specify what"
+                     <+> pprQuotedList ambig_tvs <+> text "should be."
+                 , text "These potential instance" <> plural unifiers
+                   <+> text "exist:"]
+
+        mb_patsyn_prov :: Maybe SDoc
+        mb_patsyn_prov
+          | not lead_with_ambig
+          , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig
+          = Just (vcat [ text "In other words, a successful match on the pattern"
+                       , nest 2 $ ppr pat
+                       , text "does not provide the constraint" <+> pprParendType pred ])
+          | otherwise = Nothing
+
+    -- Report "potential instances" only when the constraint arises
+    -- directly from the user's use of an overloaded function
+    want_potential (TypeEqOrigin {}) = False
+    want_potential _                 = True
+
+    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
+               = text "(maybe you haven't applied a function to enough arguments?)"
+               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)
+               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))
+               , Just (tc,_) <- tcSplitTyConApp_maybe ty
+               , not (isTypeFamilyTyCon tc)
+               = hang (text "GHC can't yet do polykinded")
+                    2 (text "Typeable" <+>
+                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))
+               | otherwise
+               = empty
+
+    drv_fixes = case orig of
+                   DerivClauseOrigin                  -> [drv_fix False]
+                   StandAloneDerivOrigin              -> [drv_fix True]
+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]
+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]
+                   _                -> []
+
+    drv_fix standalone_wildcard
+      | standalone_wildcard
+      = text "fill in the wildcard constraint yourself"
+      | otherwise
+      = hang (text "use a standalone 'deriving instance' declaration,")
+           2 (text "so you can specify the instance context yourself")
+
+    -- Normal overlap error
+    overlap_msg
+      = ASSERT( not (null matches) )
+        vcat [  addArising orig (text "Overlapping instances for"
+                                <+> pprType (mkClassPred clas tys))
+
+             ,  ppUnless (null matching_givens) $
+                  sep [text "Matching givens (or their superclasses):"
+                      , nest 2 (vcat matching_givens)]
+
+             ,  sdocWithDynFlags $ \dflags ->
+                getPprStyle $ \sty ->
+                pprPotentials dflags sty (text "Matching instances:") $
+                ispecs ++ unifiers
+
+             ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $
+                -- Intuitively, some given matched the wanted in their
+                -- flattened or rewritten (from given equalities) form
+                -- but the matcher can't figure that out because the
+                -- constraints are non-flat and non-rewritten so we
+                -- simply report back the whole given
+                -- context. Accelerate Smart.hs showed this problem.
+                  sep [ text "There exists a (perhaps superclass) match:"
+                      , nest 2 (vcat (pp_givens useful_givens))]
+
+             ,  ppWhen (isSingleton matches) $
+                parens (vcat [ text "The choice depends on the instantiation of" <+>
+                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))
+                             , ppWhen (null (matching_givens)) $
+                               vcat [ text "To pick the first instance above, use IncoherentInstances"
+                                    , text "when compiling the other instance declarations"]
+                        ])]
+
+    matching_givens = mapMaybe matchable useful_givens
+
+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })
+      = case ev_vars_matching of
+             [] -> Nothing
+             _  -> Just $ hang (pprTheta ev_vars_matching)
+                            2 (sep [ text "bound by" <+> ppr skol_info
+                                   , text "at" <+>
+                                     ppr (tcl_loc (implicLclEnv implic)) ])
+        where ev_vars_matching = [ pred
+                                 | ev_var <- evvars
+                                 , let pred = evVarPred ev_var
+                                 , any can_match (pred : transSuperClasses pred) ]
+              can_match pred
+                 = case getClassPredTys_maybe pred of
+                     Just (clas', tys') -> clas' == clas
+                                          && isJust (tcMatchTys tys tys')
+                     Nothing -> False
+
+    -- Overlap error because of Safe Haskell (first
+    -- match should be the most specific match)
+    safe_haskell_msg
+     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )
+       vcat [ addArising orig (text "Unsafe overlapping instances for"
+                       <+> pprType (mkClassPred clas tys))
+            , sep [text "The matching instance is:",
+                   nest 2 (pprInstance $ head ispecs)]
+            , vcat [ text "It is compiled in a Safe module and as such can only"
+                   , text "overlap instances from the same module, however it"
+                   , text "overlaps the following instances from different" <+>
+                     text "modules:"
+                   , nest 2 (vcat [pprInstances $ unsafe_ispecs])
+                   ]
+            ]
+
+
+ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]
+ctxtFixes has_ambig_tvs pred implics
+  | not has_ambig_tvs
+  , isTyVarClassPred pred
+  , (skol:skols) <- usefulContext implics pred
+  , let what | null skols
+             , SigSkol (PatSynCtxt {}) _ _ <- skol
+             = text "\"required\""
+             | otherwise
+             = empty
+  = [sep [ text "add" <+> pprParendType pred
+           <+> text "to the" <+> what <+> text "context of"
+         , nest 2 $ ppr_skol skol $$
+                    vcat [ text "or" <+> ppr_skol skol
+                         | skol <- skols ] ] ]
+  | otherwise = []
+  where
+    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)
+    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)
+    ppr_skol skol_info = ppr skol_info
+
+discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
+discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]
+  | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig
+  = filterOut (discard name) givens
+  | otherwise
+  = givens
+  where
+    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'
+    discard _ _                                                  = False
+
+usefulContext :: [Implication] -> PredType -> [SkolemInfo]
+-- usefulContext picks out the implications whose context
+-- the programmer might plausibly augment to solve 'pred'
+usefulContext implics pred
+  = go implics
+  where
+    pred_tvs = tyCoVarsOfType pred
+    go [] = []
+    go (ic : ics)
+       | implausible ic = rest
+       | otherwise      = ic_info ic : rest
+       where
+          -- Stop when the context binds a variable free in the predicate
+          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
+               | otherwise                                 = go ics
+
+    implausible ic
+      | null (ic_skols ic)            = True
+      | implausible_info (ic_info ic) = True
+      | otherwise                     = False
+
+    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True
+    implausible_info _                             = False
+    -- Do not suggest adding constraints to an *inferred* type signature
+
+{- Note [Report candidate instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
+but comes from some other module, then it may be helpful to point out
+that there are some similarly named instances elsewhere.  So we get
+something like
+    No instance for (Num Int) arising from the literal ‘3’
+    There are instances for similar types:
+      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’
+Discussion in #9611.
+
+Note [Highlighting ambiguous type variables]
+~-------------------------------------------
+When we encounter ambiguous type variables (i.e. type variables
+that remain metavariables after type inference), we need a few more
+conditions before we can reason that *ambiguity* prevents constraints
+from being solved:
+  - We can't have any givens, as encountering a typeclass error
+    with given constraints just means we couldn't deduce
+    a solution satisfying those constraints and as such couldn't
+    bind the type variable to a known type.
+  - If we don't have any unifiers, we don't even have potential
+    instances from which an ambiguity could arise.
+  - Lastly, I don't want to mess with error reporting for
+    unknown runtime types so we just fall back to the old message there.
+Once these conditions are satisfied, we can safely say that ambiguity prevents
+the constraint from being solved.
+
+Note [discardProvCtxtGivens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In most situations we call all enclosing implications "useful". There is one
+exception, and that is when the constraint that causes the error is from the
+"provided" context of a pattern synonym declaration:
+
+  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a
+             --  required      => provided => type
+  pattern Pat x <- (Just x, 4)
+
+When checking the pattern RHS we must check that it does actually bind all
+the claimed "provided" constraints; in this case, does the pattern (Just x, 4)
+bind the (Show a) constraint.  Answer: no!
+
+But the implication we generate for this will look like
+   forall a. (Num a, Eq a) => [W] Show a
+because when checking the pattern we must make the required
+constraints available, since they are needed to match the pattern (in
+this case the literal '4' needs (Num a, Eq a)).
+
+BUT we don't want to suggest adding (Show a) to the "required" constraints
+of the pattern synonym, thus:
+  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a
+It would then typecheck but it's silly.  We want the /pattern/ to bind
+the alleged "provided" constraints, Show a.
+
+So we suppress that Implication in discardProvCtxtGivens.  It's
+painfully ad-hoc but the truth is that adding it to the "required"
+constraints would work.  Suppressing it solves two problems.  First,
+we never tell the user that we could not deduce a "provided"
+constraint from the "required" context. Second, we never give a
+possible fix that suggests to add a "provided" constraint to the
+"required" context.
+
+For example, without this distinction the above code gives a bad error
+message (showing both problems):
+
+  error: Could not deduce (Show a) ... from the context: (Eq a)
+         ... Possible fix: add (Show a) to the context of
+         the signature for pattern synonym `Pat' ...
+
+-}
+
+show_fixes :: [SDoc] -> SDoc
+show_fixes []     = empty
+show_fixes (f:fs) = sep [ text "Possible fix:"
+                        , nest 2 (vcat (f : map (text "or" <+>) fs))]
+
+pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
+-- See Note [Displaying potential instances]
+pprPotentials dflags sty herald insts
+  | null insts
+  = empty
+
+  | null show_these
+  = hang herald
+       2 (vcat [ not_in_scope_msg empty
+               , flag_hint ])
+
+  | otherwise
+  = hang herald
+       2 (vcat [ pprInstances show_these
+               , ppWhen (n_in_scope_hidden > 0) $
+                 text "...plus"
+                   <+> speakNOf n_in_scope_hidden (text "other")
+               , not_in_scope_msg (text "...plus")
+               , flag_hint ])
+  where
+    n_show = 3 :: Int
+    show_potentials = gopt Opt_PrintPotentialInstances dflags
+
+    (in_scope, not_in_scope) = partition inst_in_scope insts
+    sorted = sortBy fuzzyClsInstCmp in_scope
+    show_these | show_potentials = sorted
+               | otherwise       = take n_show sorted
+    n_in_scope_hidden = length sorted - length show_these
+
+       -- "in scope" means that all the type constructors
+       -- are lexically in scope; these instances are likely
+       -- to be more useful
+    inst_in_scope :: ClsInst -> Bool
+    inst_in_scope cls_inst = nameSetAll name_in_scope $
+                             orphNamesOfTypes (is_tys cls_inst)
+
+    name_in_scope name
+      | isBuiltInSyntax name
+      = True -- E.g. (->)
+      | Just mod <- nameModule_maybe name
+      = qual_in_scope (qualName sty mod (nameOccName name))
+      | otherwise
+      = True
+
+    qual_in_scope :: QualifyName -> Bool
+    qual_in_scope NameUnqual    = True
+    qual_in_scope (NameQual {}) = True
+    qual_in_scope _             = False
+
+    not_in_scope_msg herald
+      | null not_in_scope
+      = empty
+      | otherwise
+      = hang (herald <+> speakNOf (length not_in_scope) (text "instance")
+                     <+> text "involving out-of-scope types")
+           2 (ppWhen show_potentials (pprInstances not_in_scope))
+
+    flag_hint = ppUnless (show_potentials || equalLength show_these insts) $
+                text "(use -fprint-potential-instances to see them all)"
+
+{- Note [Displaying potential instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When showing a list of instances for
+  - overlapping instances (show ones that match)
+  - no such instance (show ones that could match)
+we want to give it a bit of structure.  Here's the plan
+
+* Say that an instance is "in scope" if all of the
+  type constructors it mentions are lexically in scope.
+  These are the ones most likely to be useful to the programmer.
+
+* Show at most n_show in-scope instances,
+  and summarise the rest ("plus 3 others")
+
+* Summarise the not-in-scope instances ("plus 4 not in scope")
+
+* Add the flag -fshow-potential-instances which replaces the
+  summary with the full list
+-}
+
+{-
+Note [Flattening in error message generation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (C (Maybe (F x))), where F is a type function, and we have
+instances
+                C (Maybe Int) and C (Maybe a)
+Since (F x) might turn into Int, this is an overlap situation, and
+indeed (because of flattening) the main solver will have refrained
+from solving.  But by the time we get to error message generation, we've
+un-flattened the constraint.  So we must *re*-flatten it before looking
+up in the instance environment, lest we only report one matching
+instance when in fact there are two.
+
+Re-flattening is pretty easy, because we don't need to keep track of
+evidence.  We don't re-use the code in TcCanonical because that's in
+the TcS monad, and we are in TcM here.
+
+Note [Kind arguments in error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It can be terribly confusing to get an error message like (#9171)
+
+    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
+                with actual type ‘GetParam Base (GetParam Base Int)’
+
+The reason may be that the kinds don't match up.  Typically you'll get
+more useful information, but not when it's as a result of ambiguity.
+
+To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag
+whenever any error message arises due to a kind mismatch. This means that
+the above error message would instead be displayed as:
+
+    Couldn't match expected type
+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
+                with actual type
+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’
+
+Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
+-}
+
+mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
+           -> Ct -> (Bool, SDoc)
+mkAmbigMsg prepend_msg ct
+  | null ambig_kvs && null ambig_tvs = (False, empty)
+  | otherwise                        = (True,  msg)
+  where
+    (ambig_kvs, ambig_tvs) = getAmbigTkvs ct
+
+    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]
+        || any isRuntimeUnkSkol ambig_tvs
+        = vcat [ text "Cannot resolve unknown runtime type"
+                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs
+               , text "Use :print or :force to determine these types"]
+
+        | not (null ambig_tvs)
+        = pp_ambig (text "type") ambig_tvs
+
+        | otherwise
+        = pp_ambig (text "kind") ambig_kvs
+
+    pp_ambig what tkvs
+      | prepend_msg -- "Ambiguous type variable 't0'"
+      = text "Ambiguous" <+> what <+> text "variable"
+        <> plural tkvs <+> pprQuotedList tkvs
+
+      | otherwise -- "The type variable 't0' is ambiguous"
+      = text "The" <+> what <+> text "variable" <> plural tkvs
+        <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"
+
+    is_or_are [_] = text "is"
+    is_or_are _   = text "are"
+
+pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc
+pprSkols ctxt tvs
+  = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))
+  where
+    pp_one (Implic { ic_info = skol_info }, tvs)
+      | UnkSkol <- skol_info
+      = hang (pprQuotedList tvs)
+           2 (is_or_are tvs "an" "unknown")
+      | otherwise
+      = vcat [ hang (pprQuotedList tvs)
+                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")
+             , nest 2 (pprSkolInfo skol_info)
+             , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]
+
+    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective
+                                      <+> text "type variable"
+    is_or_are _   _       adjective = text "are" <+> text adjective
+                                      <+> text "type variables"
+
+getAmbigTkvs :: Ct -> ([Var],[Var])
+getAmbigTkvs ct
+  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs
+  where
+    tkvs       = tyCoVarsOfCtList ct
+    ambig_tkvs = filter isAmbiguousTyVar tkvs
+    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
+
+getSkolemInfo :: [Implication] -> [TcTyVar]
+              -> [(Implication, [TcTyVar])]
+-- Get the skolem info for some type variables
+-- from the implication constraints that bind them
+--
+-- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty
+getSkolemInfo _ []
+  = []
+
+getSkolemInfo [] tvs
+  = pprPanic "No skolem info:" (ppr tvs)
+
+getSkolemInfo (implic:implics) tvs
+  | null tvs_here =                      getSkolemInfo implics tvs
+  | otherwise     = (implic, tvs_here) : getSkolemInfo implics tvs_other
+  where
+    (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs
+
+-----------------------
+-- relevantBindings looks at the value environment and finds values whose
+-- types mention any of the offending type variables.  It has to be
+-- careful to zonk the Id's type first, so it has to be in the monad.
+-- We must be careful to pass it a zonked type variable, too.
+--
+-- We always remove closed top-level bindings, though,
+-- since they are never relevant (cf #8233)
+
+relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
+                          -- See #8191
+                 -> ReportErrCtxt -> Ct
+                 -> TcM (ReportErrCtxt, SDoc, Ct)
+-- Also returns the zonked and tidied CtOrigin of the constraint
+relevantBindings want_filtering ctxt ct
+  = do { dflags <- getDynFlags
+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
+       ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs
+
+             -- For *kind* errors, report the relevant bindings of the
+             -- enclosing *type* equality, because that's more useful for the programmer
+             extra_tvs = case tidy_orig of
+                             KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $
+                                                         t1 : maybeToList m_t2
+                             _                        -> emptyVarSet
+       ; traceTc "relevantBindings" $
+           vcat [ ppr ct
+                , pprCtOrigin (ctLocOrigin loc)
+                , ppr ct_tvs
+                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)
+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]
+                , pprWithCommas id
+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
+
+       ; (tidy_env', docs, discards)
+              <- go dflags env1 ct_tvs (maxRelevantBinds dflags)
+                    emptyVarSet [] False
+                    (removeBindingShadowing $ tcl_bndrs lcl_env)
+         -- tcl_bndrs has the innermost bindings first,
+         -- which are probably the most relevant ones
+
+       ; let doc = ppUnless (null docs) $
+                   hang (text "Relevant bindings include")
+                      2 (vcat docs $$ ppWhen discards discardMsg)
+
+             -- Put a zonked, tidied CtOrigin into the Ct
+             loc'  = setCtLocOrigin loc tidy_orig
+             ct'   = setCtLoc ct loc'
+             ctxt' = ctxt { cec_tidy = tidy_env' }
+
+       ; return (ctxt', doc, ct') }
+  where
+    ev      = ctEvidence ct
+    loc     = ctEvLoc ev
+    lcl_env = ctLocEnv loc
+
+    run_out :: Maybe Int -> Bool
+    run_out Nothing = False
+    run_out (Just n) = n <= 0
+
+    dec_max :: Maybe Int -> Maybe Int
+    dec_max = fmap (\n -> n - 1)
+
+
+    go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
+       -> Bool                          -- True <=> some filtered out due to lack of fuel
+       -> [TcBinder]
+       -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
+                                        -- because of lack of fuel
+    go _ tidy_env _ _ _ docs discards []
+      = return (tidy_env, reverse docs, discards)
+    go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
+      = case tc_bndr of
+          TcTvBndr {} -> discard_it
+          TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
+          TcIdBndr_ExpType name et top_lvl ->
+            do { mb_ty <- readExpType_maybe et
+                   -- et really should be filled in by now. But there's a chance
+                   -- it hasn't, if, say, we're reporting a kind error en route to
+                   -- checking a term. See test indexed-types/should_fail/T8129
+                   -- Or we are reporting errors from the ambiguity check on
+                   -- a local type signature
+               ; case mb_ty of
+                   Just ty -> go2 name ty top_lvl
+                   Nothing -> discard_it  -- No info; discard
+               }
+      where
+        discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs
+                        discards tc_bndrs
+        go2 id_name id_type top_lvl
+          = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
+               ; let id_tvs = tyCoVarsOfType tidy_ty
+                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty
+                               , nest 2 (parens (text "bound at"
+                                    <+> ppr (getSrcLoc id_name)))]
+                     new_seen = tvs_seen `unionVarSet` id_tvs
+
+               ; if (want_filtering && not (hasPprDebug dflags)
+                                    && id_tvs `disjointVarSet` ct_tvs)
+                          -- We want to filter out this binding anyway
+                          -- so discard it silently
+                 then discard_it
+
+                 else if isTopLevel top_lvl && not (isNothing n_left)
+                          -- It's a top-level binding and we have not specified
+                          -- -fno-max-relevant-bindings, so discard it silently
+                 then discard_it
+
+                 else if run_out n_left && id_tvs `subVarSet` tvs_seen
+                          -- We've run out of n_left fuel and this binding only
+                          -- mentions already-seen type variables, so discard it
+                 then go dflags tidy_env ct_tvs n_left tvs_seen docs
+                         True      -- Record that we have now discarded something
+                         tc_bndrs
+
+                          -- Keep this binding, decrement fuel
+                 else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen
+                         (doc:docs) discards tc_bndrs }
+
+
+discardMsg :: SDoc
+discardMsg = text "(Some bindings suppressed;" <+>
+             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
+
+-----------------------
+warnDefaulting :: [Ct] -> Type -> TcM ()
+warnDefaulting wanteds default_ty
+  = do { warn_default <- woptM Opt_WarnTypeDefaults
+       ; env0 <- tcInitTidyEnv
+       ; let tidy_env = tidyFreeTyCoVars env0 $
+                        tyCoVarsOfCtsList (listToBag wanteds)
+             tidy_wanteds = map (tidyCt tidy_env) wanteds
+             (loc, ppr_wanteds) = pprWithArising tidy_wanteds
+             warn_msg =
+                hang (hsep [ text "Defaulting the following"
+                           , text "constraint" <> plural tidy_wanteds
+                           , text "to type"
+                           , quotes (ppr default_ty) ])
+                     2
+                     ppr_wanteds
+       ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }
+
+{-
+Note [Runtime skolems]
+~~~~~~~~~~~~~~~~~~~~~~
+We want to give a reasonably helpful error message for ambiguity
+arising from *runtime* skolems in the debugger.  These
+are created by in RtClosureInspect.zonkRTTIType.
+
+************************************************************************
+*                                                                      *
+                 Error from the canonicaliser
+         These ones are called *during* constraint simplification
+*                                                                      *
+************************************************************************
+-}
+
+solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
+solverDepthErrorTcS loc ty
+  = setCtLocM loc $
+    do { ty <- zonkTcType ty
+       ; env0 <- tcInitTidyEnv
+       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)
+             tidy_ty      = tidyType tidy_env ty
+             msg
+               = vcat [ text "Reduction stack overflow; size =" <+> ppr depth
+                      , hang (text "When simplifying the following type:")
+                           2 (ppr tidy_ty)
+                      , note ]
+       ; failWithTcM (tidy_env, msg) }
+  where
+    depth = ctLocDepth loc
+    note = vcat
+      [ text "Use -freduction-depth=0 to disable this check"
+      , text "(any upper bound you could choose might fail unpredictably with"
+      , text " minor updates to GHC, so disabling the check is recommended if"
+      , text " you're sure that type checking should terminate)" ]
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -0,0 +1,70 @@
+
+-- (those who have too heavy dependencies for TcEvidence)
+module TcEvTerm
+    ( evDelayedError, evCallStack )
+where
+
+import GhcPrelude
+
+import FastString
+import Type
+import CoreSyn
+import MkCore
+import Literal ( Literal(..) )
+import TcEvidence
+import HscTypes
+import DynFlags
+import Name
+import Module
+import CoreUtils
+import PrelNames
+import SrcLoc
+
+-- Used with Opt_DeferTypeErrors
+-- See Note [Deferring coercion errors to runtime]
+-- in TcSimplify
+evDelayedError :: Type -> FastString -> EvTerm
+evDelayedError ty msg
+  = EvExpr $
+    Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
+  where
+    errorId = tYPE_ERROR_ID
+    litMsg  = Lit (LitString (bytesFS msg))
+
+-- Dictionary for CallStack implicit parameters
+evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
+    EvCallStack -> m EvExpr
+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
+evCallStack cs = do
+  df            <- getDynFlags
+  m             <- getModule
+  srcLocDataCon <- lookupDataCon srcLocDataConName
+  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
+               sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
+                        , mkStringExprFS (moduleNameFS $ moduleName m)
+                        , mkStringExprFS (srcSpanFile l)
+                        , return $ mkIntExprInt df (srcSpanStartLine l)
+                        , return $ mkIntExprInt df (srcSpanStartCol l)
+                        , return $ mkIntExprInt df (srcSpanEndLine l)
+                        , return $ mkIntExprInt df (srcSpanEndCol l)
+                        ]
+
+  emptyCS <- Var <$> lookupId emptyCallStackName
+
+  pushCSVar <- lookupId pushCallStackName
+  let pushCS name loc rest =
+        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
+
+  let mkPush name loc tm = do
+        nameExpr <- mkStringExprFS name
+        locExpr <- mkSrcLoc loc
+        -- at this point tm :: IP sym CallStack
+        -- but we need the actual CallStack to pass to pushCS,
+        -- so we use unwrapIP to strip the dictionary wrapper
+        -- See Note [Overview of implicit CallStacks]
+        let ip_co = unwrapIP (exprType tm)
+        return (pushCS nameExpr locExpr (Cast tm ip_co))
+
+  case cs of
+    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
+    EvCsEmpty -> return emptyCS
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcExpr.hs
@@ -0,0 +1,2919 @@
+{-
+%
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcExpr]{Typecheck an expression}
+-}
+
+{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
+                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
+                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
+                tcCheckId,
+                addExprErrCtxt,
+                getFixedTyVars ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
+import THNames( liftStringName, liftName )
+
+import HsSyn
+import TcHsSyn
+import TcRnMonad
+import TcUnify
+import BasicTypes
+import Inst
+import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )
+import TcSigs           ( tcUserTypeSig, tcInstSig )
+import TcSimplify       ( simplifyInfer, InferMode(..) )
+import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
+import FamInstEnv       ( FamInstEnvs )
+import RnEnv            ( addUsedGRE )
+import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )
+import TcEnv
+import TcArrows
+import TcMatches
+import TcHsType
+import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
+import TcPat
+import TcMType
+import TcType
+import Id
+import IdInfo
+import ConLike
+import DataCon
+import PatSyn
+import Name
+import NameEnv
+import NameSet
+import RdrName
+import TyCon
+import TyCoRep
+import Type
+import TcEvidence
+import VarSet
+import MkId( seqId )
+import TysWiredIn
+import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )
+import PrimOp( tagToEnumKey )
+import PrelNames
+import DynFlags
+import SrcLoc
+import Util
+import VarEnv  ( emptyTidyEnv, mkInScopeSet )
+import ListSetOps
+import Maybes
+import Outputable
+import FastString
+import Control.Monad
+import Class(classTyCon)
+import UniqSet ( nonDetEltsUniqSet )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Function
+import Data.List
+import qualified Data.Set as Set
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Main wrappers}
+*                                                                      *
+************************************************************************
+-}
+
+tcPolyExpr, tcPolyExprNC
+  :: LHsExpr GhcRn         -- Expression to type check
+  -> TcSigmaType           -- Expected type (could be a polytype)
+  -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type
+
+-- tcPolyExpr is a convenient place (frequent but not too frequent)
+-- place to add context information.
+-- The NC version does not do so, usually because the caller wants
+-- to do so himself.
+
+tcPolyExpr   expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
+tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)
+
+-- these versions take an ExpType
+tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType
+                              -> TcM (LHsExpr GhcTcId)
+tc_poly_expr expr res_ty
+  = addExprErrCtxt expr $
+    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
+
+tc_poly_expr_nc (L loc expr) res_ty
+  = setSrcSpan loc $
+    do { traceTc "tcPolyExprNC" (ppr res_ty)
+       ; (wrap, expr')
+           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
+              tcExpr expr res_ty
+       ; return $ L loc (mkHsWrap wrap expr') }
+
+---------------
+tcMonoExpr, tcMonoExprNC
+    :: LHsExpr GhcRn     -- Expression to type check
+    -> ExpRhoType        -- Expected type
+                         -- Definitely no foralls at the top
+    -> TcM (LHsExpr GhcTcId)
+
+tcMonoExpr expr res_ty
+  = addErrCtxt (exprCtxt expr) $
+    tcMonoExprNC expr res_ty
+
+tcMonoExprNC (L loc expr) res_ty
+  = setSrcSpan loc $
+    do  { expr' <- tcExpr expr res_ty
+        ; return (L loc expr') }
+
+---------------
+tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId
+                                                    , TcSigmaType )
+-- Infer a *sigma*-type.
+tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)
+
+tcInferSigmaNC (L loc expr)
+  = setSrcSpan loc $
+    do { (expr', sigma) <- tcInferNoInst (tcExpr expr)
+       ; return (L loc expr', sigma) }
+
+tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType)
+-- Infer a *rho*-type. The return type is always (shallowly) instantiated.
+tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
+
+tcInferRhoNC expr
+  = do { (expr', sigma) <- tcInferSigmaNC expr
+       ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma
+       ; return (mkLHsWrap wrap expr', rho) }
+
+
+{-
+************************************************************************
+*                                                                      *
+        tcExpr: the main expression typechecker
+*                                                                      *
+************************************************************************
+
+NB: The res_ty is always deeply skolemised.
+-}
+
+tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcExpr (HsVar _ (L _ name))   res_ty = tcCheckId name res_ty
+tcExpr e@(HsUnboundVar _ uv)  res_ty = tcUnboundId e uv res_ty
+
+tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty
+tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
+
+tcExpr e@(HsLit x lit) res_ty
+  = do { let lit_ty = hsLitType lit
+       ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
+
+tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
+                                  ; return (HsPar x expr') }
+
+tcExpr (HsSCC x src lbl expr) res_ty
+  = do { expr' <- tcMonoExpr expr res_ty
+       ; return (HsSCC x src lbl expr') }
+
+tcExpr (HsTickPragma x src info srcInfo expr) res_ty
+  = do { expr' <- tcMonoExpr expr res_ty
+       ; return (HsTickPragma x src info srcInfo expr') }
+
+tcExpr (HsCoreAnn x src lbl expr) res_ty
+  = do  { expr' <- tcMonoExpr expr res_ty
+        ; return (HsCoreAnn x src lbl expr') }
+
+tcExpr (HsOverLit x lit) res_ty
+  = do  { lit' <- newOverloadedLit lit res_ty
+        ; return (HsOverLit x lit') }
+
+tcExpr (NegApp x expr neg_expr) res_ty
+  = do  { (expr', neg_expr')
+            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
+               \[arg_ty] ->
+               tcMonoExpr expr (mkCheckExpType arg_ty)
+        ; return (NegApp x expr' neg_expr') }
+
+tcExpr e@(HsIPVar _ x) res_ty
+  = do {   {- Implicit parameters must have a *tau-type* not a
+              type scheme.  We enforce this by creating a fresh
+              type variable as its type.  (Because res_ty may not
+              be a tau-type.) -}
+         ip_ty <- newOpenFlexiTyVarTy
+       ; let ip_name = mkStrLitTy (hsIPNameFS x)
+       ; ipClass <- tcLookupClass ipClassName
+       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
+       ; tcWrapResult e
+                   (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))
+                   ip_ty res_ty }
+  where
+  -- Coerces a dictionary for `IP "x" t` into `t`.
+  fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
+                          unwrapIP $ mkClassPred ipClass [x,ty]
+  origin = IPOccOrigin x
+
+tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
+  = do { -- See Note [Type-checking overloaded labels]
+         loc <- getSrcSpanM
+       ; case mb_fromLabel of
+           Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
+           Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
+                         ; alpha <- newFlexiTyVarTy liftedTypeKind
+                         ; let pred = mkClassPred isLabelClass [lbl, alpha]
+                         ; loc <- getSrcSpanM
+                         ; var <- emitWantedEvVar origin pred
+                         ; tcWrapResult e
+                                       (fromDict pred (HsVar noExt (L loc var)))
+                                        alpha res_ty } }
+  where
+  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
+  -- or `HasField "x" r a into `r -> a`.
+  fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred
+  origin = OverLabelOrigin l
+  lbl = mkStrLitTy l
+
+  applyFromLabel loc fromLabel =
+    HsAppType noExt
+         (L loc (HsVar noExt (L loc fromLabel)))
+         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
+
+tcExpr (HsLam x match) res_ty
+  = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
+        ; return (mkHsWrap wrap (HsLam x match')) }
+  where
+    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
+    herald = sep [ text "The lambda expression" <+>
+                   quotes (pprSetDepth (PartWay 1) $
+                           pprMatches match),
+                        -- The pprSetDepth makes the abstraction print briefly
+                   text "has"]
+
+tcExpr e@(HsLamCase x matches) res_ty
+  = do { (matches', wrap)
+           <- tcMatchLambda msg match_ctxt matches res_ty
+           -- The laziness annotation is because we don't want to fail here
+           -- if there are multiple arguments
+       ; return (mkHsWrap wrap $ HsLamCase x matches') }
+  where
+    msg = sep [ text "The function" <+> quotes (ppr e)
+              , text "requires"]
+    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
+
+tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty
+  = do { let loc = getLoc (hsSigWcType sig_ty)
+       ; sig_info <- checkNoErrs $  -- Avoid error cascade
+                     tcUserTypeSig loc sig_ty Nothing
+       ; (expr', poly_ty) <- tcExprSig expr sig_info
+       ; let expr'' = ExprWithTySig noExt expr' sig_ty
+       ; tcWrapResult e expr'' poly_ty res_ty }
+
+{-
+Note [Type-checking overloaded labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Recall that we have
+
+  module GHC.OverloadedLabels where
+    class IsLabel (x :: Symbol) a where
+      fromLabel :: a
+
+We translate `#foo` to `fromLabel @"foo"`, where we use
+
+ * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
+ * `GHC.OverloadedLabels.fromLabel`.
+
+In the `RebindableSyntax` case, the renamer will have filled in the
+first field of `HsOverLabel` with the `fromLabel` function to use, and
+we simply apply it to the appropriate visible type argument.
+
+In the `OverloadedLabels` case, when we see an overloaded label like
+`#foo`, we generate a fresh variable `alpha` for the type and emit an
+`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a
+single method, it is represented by a newtype, so we can coerce
+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
+
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+                Infix operators and sections
+*                                                                      *
+************************************************************************
+
+Note [Left sections]
+~~~~~~~~~~~~~~~~~~~~
+Left sections, like (4 *), are equivalent to
+        \ x -> (*) 4 x,
+or, if PostfixOperators is enabled, just
+        (*) 4
+With PostfixOperators we don't actually require the function to take
+two arguments at all.  For example, (x `not`) means (not x); you get
+postfix operators!  Not Haskell 98, but it's less work and kind of
+useful.
+
+Note [Typing rule for ($)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+People write
+   runST $ blah
+so much, where
+   runST :: (forall s. ST s a) -> a
+that I have finally given in and written a special type-checking
+rule just for saturated applications of ($).
+  * Infer the type of the first argument
+  * Decompose it; should be of form (arg2_ty -> res_ty),
+       where arg2_ty might be a polytype
+  * Use arg2_ty to typecheck arg2
+
+Note [Typing rule for seq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to allow
+       x `seq` (# p,q #)
+which suggests this type for seq:
+   seq :: forall (a:*) (b:Open). a -> b -> b,
+with (b:Open) meaning that be can be instantiated with an unboxed
+tuple.  The trouble is that this might accept a partially-applied
+'seq', and I'm just not certain that would work.  I'm only sure it's
+only going to work when it's fully applied, so it turns into
+    case x of _ -> (# p,q #)
+
+So it seems more uniform to treat 'seq' as if it was a language
+construct.
+
+See also Note [seqId magic] in MkId
+-}
+
+tcExpr expr@(OpApp fix arg1 op arg2) res_ty
+  | (L loc (HsVar _ (L lv op_name))) <- op
+  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
+  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
+       ; let arg2_exp_ty = res_ty
+       ; arg1' <- tcArg op arg1 arg1_ty 1
+       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
+                  tc_poly_expr_nc arg2 arg2_exp_ty
+       ; arg2_ty <- readExpType arg2_exp_ty
+       ; op_id <- tcLookupId op_name
+       ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])
+                                   (HsVar noExt (L lv op_id)))
+       ; return $ OpApp fix arg1' op' arg2' }
+
+  | (L loc (HsVar _ (L lv op_name))) <- op
+  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
+  = do { traceTc "Application rule" (ppr op)
+       ; (arg1', arg1_ty) <- tcInferSigma arg1
+
+       ; let doc   = text "The first argument of ($) takes"
+             orig1 = lexprCtOrigin arg1
+       ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
+           matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty
+
+         -- We have (arg1 $ arg2)
+         -- So: arg1_ty = arg2_ty -> op_res_ty
+         -- where arg2_sigma maybe polymorphic; that's the point
+
+       ; arg2'  <- tcArg op arg2 arg2_sigma 2
+
+       -- Make sure that the argument type has kind '*'
+       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
+       -- Eg we do not want to allow  (D#  $  4.0#)   #5570
+       --    (which gives a seg fault)
+       --
+       -- The *result* type can have any kind (#8739),
+       -- so we don't need to check anything for that
+       ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma))
+                        (tcTypeKind arg2_sigma) liftedTypeKind
+           -- ignore the evidence. arg2_sigma must have type * or #,
+           -- because we know arg2_sigma -> or_res_ty is well-kinded
+           -- (because otherwise matchActualFunTys would fail)
+           -- There's no possibility here of, say, a kind family reducing to *.
+
+       ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
+                       -- op_res -> res
+
+       ; op_id  <- tcLookupId op_name
+       ; res_ty <- readExpType res_ty
+       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty
+                                               , arg2_sigma
+                                               , res_ty])
+                                   (HsVar noExt (L lv op_id)))
+             -- arg1' :: arg1_ty
+             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
+             -- wrap_res :: op_res_ty "->" res_ty
+             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
+
+             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
+             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc
+                     <.> wrap_arg1
+             doc = text "When looking at the argument to ($)"
+
+       ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') }
+
+  | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op
+  , Just sig_ty <- obviousSig (unLoc arg1)
+    -- See Note [Disambiguating record fields]
+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+       ; sel_name <- disambiguateSelector lbl sig_tc_ty
+       ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))
+       ; tcExpr (OpApp fix arg1 op' arg2) res_ty
+       }
+
+  | otherwise
+  = do { traceTc "Non Application rule" (ppr op)
+       ; (wrap, op', [HsValArg arg1', HsValArg arg2'])
+           <- tcApp (Just $ mk_op_msg op)
+                     op [HsValArg arg1, HsValArg arg2] res_ty
+       ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') }
+
+-- Right sections, equivalent to \ x -> x `op` expr, or
+--      \ x -> op x expr
+
+tcExpr expr@(SectionR x op arg2) res_ty
+  = do { (op', op_ty) <- tcInferFun op
+       ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
+                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
+                                 (mkVisFunTy arg1_ty op_res_ty) res_ty
+       ; arg2' <- tcArg op arg2 arg2_ty 2
+       ; return ( mkHsWrap wrap_res $
+                  SectionR x (mkLHsWrap wrap_fun op') arg2' ) }
+  where
+    fn_orig = lexprCtOrigin op
+    -- It's important to use the origin of 'op', so that call-stacks
+    -- come out right; they are driven by the OccurrenceOf CtOrigin
+    -- See #13285
+
+tcExpr expr@(SectionL x arg1 op) res_ty
+  = do { (op', op_ty) <- tcInferFun op
+       ; dflags <- getDynFlags      -- Note [Left sections]
+       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
+                         | otherwise                            = 2
+
+       ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
+           <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))
+                                n_reqd_args op_ty
+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
+                                 (mkVisFunTys arg_tys op_res_ty) res_ty
+       ; arg1' <- tcArg op arg1 arg1_ty 1
+       ; return ( mkHsWrap wrap_res $
+                  SectionL x arg1' (mkLHsWrap wrap_fn op') ) }
+  where
+    fn_orig = lexprCtOrigin op
+    -- It's important to use the origin of 'op', so that call-stacks
+    -- come out right; they are driven by the OccurrenceOf CtOrigin
+    -- See #13285
+
+tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
+  | all tupArgPresent tup_args
+  = do { let arity  = length tup_args
+             tup_tc = tupleTyCon boxity arity
+       ; res_ty <- expTypeToType res_ty
+       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
+                           -- Unboxed tuples have RuntimeRep vars, which we
+                           -- don't care about here
+                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
+                                       Boxed   -> arg_tys
+       ; tup_args1 <- tcTupArgs tup_args arg_tys'
+       ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
+
+  | otherwise
+  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
+    do { let arity = length tup_args
+
+       ; arg_tys <- case boxity of
+           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
+           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
+       ; let actual_res_ty
+                 = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
+                            (mkTupleTy boxity arg_tys)
+
+       ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
+                             (Just expr)
+                             actual_res_ty res_ty
+
+       -- Handle tuple sections where
+       ; tup_args1 <- tcTupArgs tup_args arg_tys
+
+       ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) }
+
+tcExpr (ExplicitSum _ alt arity expr) res_ty
+  = do { let sum_tc = sumTyCon arity
+       ; res_ty <- expTypeToType res_ty
+       ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
+       ; -- Drop levity vars, we don't care about them here
+         let arg_tys' = drop arity arg_tys
+       ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
+       ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
+
+tcExpr (ExplicitList _ witness exprs) res_ty
+  = case witness of
+      Nothing   -> do  { res_ty <- expTypeToType res_ty
+                       ; (coi, elt_ty) <- matchExpectedListTy res_ty
+                       ; exprs' <- mapM (tc_elt elt_ty) exprs
+                       ; return $
+                         mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
+
+      Just fln -> do { ((exprs', elt_ty), fln')
+                         <- tcSyntaxOp ListOrigin fln
+                                       [synKnownType intTy, SynList] res_ty $
+                            \ [elt_ty] ->
+                            do { exprs' <-
+                                    mapM (tc_elt elt_ty) exprs
+                               ; return (exprs', elt_ty) }
+
+                     ; return $ ExplicitList elt_ty (Just fln') exprs' }
+     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+
+{-
+************************************************************************
+*                                                                      *
+                Let, case, if, do
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr (HsLet x (L l binds) expr) res_ty
+  = do  { (binds', expr') <- tcLocalBinds binds $
+                             tcMonoExpr expr res_ty
+        ; return (HsLet x (L l binds') expr') }
+
+tcExpr (HsCase x scrut matches) res_ty
+  = do  {  -- We used to typecheck the case alternatives first.
+           -- The case patterns tend to give good type info to use
+           -- when typechecking the scrutinee.  For example
+           --   case (map f) of
+           --     (x:xs) -> ...
+           -- will report that map is applied to too few arguments
+           --
+           -- But now, in the GADT world, we need to typecheck the scrutinee
+           -- first, to get type info that may be refined in the case alternatives
+          (scrut', scrut_ty) <- tcInferRho scrut
+
+        ; traceTc "HsCase" (ppr scrut_ty)
+        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
+        ; return (HsCase x scrut' matches') }
+ where
+    match_ctxt = MC { mc_what = CaseAlt,
+                      mc_body = tcBody }
+
+tcExpr (HsIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
+       ; res_ty <- tauifyExpType res_ty
+           -- Just like Note [Case branches must never infer a non-tau type]
+           -- in TcMatches (See #10619)
+
+       ; b1' <- tcMonoExpr b1 res_ty
+       ; b2' <- tcMonoExpr b2 res_ty
+       ; return (HsIf x Nothing pred' b1' b2') }
+
+tcExpr (HsIf x (Just fun) pred b1 b2) res_ty
+  = do { ((pred', b1', b2'), fun')
+           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
+              \ [pred_ty, b1_ty, b2_ty] ->
+              do { pred' <- tcPolyExpr pred pred_ty
+                 ; b1'   <- tcPolyExpr b1   b1_ty
+                 ; b2'   <- tcPolyExpr b2   b2_ty
+                 ; return (pred', b1', b2') }
+       ; return (HsIf x (Just fun') pred' b1' b2') }
+
+tcExpr (HsMultiIf _ alts) res_ty
+  = do { res_ty <- if isSingleton alts
+                   then return res_ty
+                   else tauifyExpType res_ty
+             -- Just like TcMatches
+             -- Note [Case branches must never infer a non-tau type]
+
+       ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+       ; res_ty <- readExpType res_ty
+       ; return (HsMultiIf res_ty alts') }
+  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+
+tcExpr (HsDo _ do_or_lc stmts) res_ty
+  = do { expr' <- tcDoStmts do_or_lc stmts res_ty
+       ; return expr' }
+
+tcExpr (HsProc x pat cmd) res_ty
+  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
+        ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
+
+-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
+-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+-- To type check
+--      (static e) :: p a
+-- we want to check (e :: a),
+-- and wrap (static e) in a call to
+--    fromStaticPtr :: IsStatic p => StaticPtr a -> p a
+
+tcExpr (HsStatic fvs expr) res_ty
+  = do  { res_ty          <- expTypeToType res_ty
+        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
+        ; (expr', lie)    <- captureConstraints $
+            addErrCtxt (hang (text "In the body of a static form:")
+                             2 (ppr expr)
+                       ) $
+            tcPolyExprNC expr expr_ty
+
+        -- Check that the free variables of the static form are closed.
+        -- It's OK to use nonDetEltsUniqSet here as the only side effects of
+        -- checkClosedInStaticForm are error messages.
+        ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
+
+        -- Require the type of the argument to be Typeable.
+        -- The evidence is not used, but asking the constraint ensures that
+        -- the current implementation is as restrictive as future versions
+        -- of the StaticPointers extension.
+        ; typeableClass <- tcLookupClass typeableClassName
+        ; _ <- emitWantedEvVar StaticOrigin $
+                  mkTyConApp (classTyCon typeableClass)
+                             [liftedTypeKind, expr_ty]
+
+        -- Insert the constraints of the static form in a global list for later
+        -- validation.
+        ; emitStaticConstraints lie
+
+        -- Wrap the static form with the 'fromStaticPtr' call.
+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
+                                             [p_ty]
+        ; let wrap = mkWpTyApps [expr_ty]
+        ; loc <- getSrcSpanM
+        ; return $ mkHsWrapCo co $ HsApp noExt
+                                         (L loc $ mkHsWrap wrap fromStaticPtr)
+                                         (L loc (HsStatic fvs expr'))
+        }
+
+{-
+************************************************************************
+*                                                                      *
+                Record construction and update
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
+                       , rcon_flds = rbinds }) res_ty
+  = do  { con_like <- tcLookupConLike con_name
+
+        -- Check for missing fields
+        ; checkMissingFields con_like rbinds
+
+        ; (con_expr, con_sigma) <- tcInferId con_name
+        ; (con_wrap, con_tau) <-
+            topInstantiate (OccurrenceOf con_name) con_sigma
+              -- a shallow instantiation should really be enough for
+              -- a data constructor.
+        ; let arity = conLikeArity con_like
+              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
+        ; case conLikeWrapId_maybe con_like of
+               Nothing -> nonBidirectionalErr (conLikeName con_like)
+               Just con_id -> do {
+                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
+                                          (Just expr) actual_res_ty res_ty
+                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
+                ; return $
+                  mkHsWrap res_wrap $
+                  RecordCon { rcon_ext = RecordConTc
+                                 { rcon_con_like = con_like
+                                 , rcon_con_expr = mkHsWrap con_wrap con_expr }
+                            , rcon_con_name = L loc con_id
+                            , rcon_flds = rbinds' } } }
+
+{-
+Note [Type of a record update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The main complication with RecordUpd is that we need to explicitly
+handle the *non-updated* fields.  Consider:
+
+        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
+                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
+                     | MkT3 { fd :: a }
+
+        upd :: T a b c -> (b',c) -> T a b' c
+        upd t x = t { fb = x}
+
+The result type should be (T a b' c)
+not (T a b c),   because 'b' *is not* mentioned in a non-updated field
+not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
+NB that it's not good enough to look at just one constructor; we must
+look at them all; cf #3219
+
+After all, upd should be equivalent to:
+        upd t x = case t of
+                        MkT1 p q -> MkT1 p x
+                        MkT2 a b -> MkT2 p b
+                        MkT3 d   -> error ...
+
+So we need to give a completely fresh type to the result record,
+and then constrain it by the fields that are *not* updated ("p" above).
+We call these the "fixed" type variables, and compute them in getFixedTyVars.
+
+Note that because MkT3 doesn't contain all the fields being updated,
+its RHS is simply an error, so it doesn't impose any type constraints.
+Hence the use of 'relevant_cont'.
+
+Note [Implicit type sharing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We also take into account any "implicit" non-update fields.  For example
+        data T a b where { MkT { f::a } :: T a a; ... }
+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
+
+Then consider
+        upd t x = t { f=x }
+We infer the type
+        upd :: T a b -> a -> T a b
+        upd (t::T a b) (x::a)
+           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
+We can't give it the more general type
+        upd :: T a b -> c -> T c b
+
+Note [Criteria for update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to allow update for existentials etc, provided the updated
+field isn't part of the existential. For example, this should be ok.
+  data T a where { MkT { f1::a, f2::b->b } :: T a }
+  f :: T a -> b -> T b
+  f t b = t { f1=b }
+
+The criterion we use is this:
+
+  The types of the updated fields
+  mention only the universally-quantified type variables
+  of the data constructor
+
+NB: this is not (quite) the same as being a "naughty" record selector
+(See Note [Naughty record selectors]) in TcTyClsDecls), at least
+in the case of GADTs. Consider
+   data T a where { MkT :: { f :: a } :: T [a] }
+Then f is not "naughty" because it has a well-typed record selector.
+But we don't allow updates for 'f'.  (One could consider trying to
+allow this, but it makes my head hurt.  Badly.  And no one has asked
+for it.)
+
+In principle one could go further, and allow
+  g :: T a -> T a
+  g t = t { f2 = \x -> x }
+because the expression is polymorphic...but that seems a bridge too far.
+
+Note [Data family example]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+    data instance T (a,b) = MkT { x::a, y::b }
+  --->
+    data :TP a b = MkT { a::a, y::b }
+    coTP a b :: T (a,b) ~ :TP a b
+
+Suppose r :: T (t1,t2), e :: t3
+Then  r { x=e } :: T (t3,t1)
+  --->
+      case r |> co1 of
+        MkT x y -> MkT e y |> co2
+      where co1 :: T (t1,t2) ~ :TP t1 t2
+            co2 :: :TP t3 t2 ~ T (t3,t2)
+The wrapping with co2 is done by the constructor wrapper for MkT
+
+Outgoing invariants
+~~~~~~~~~~~~~~~~~~~
+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
+
+  * cons are the data constructors to be updated
+
+  * in_inst_tys, out_inst_tys have same length, and instantiate the
+        *representation* tycon of the data cons.  In Note [Data
+        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
+
+Note [Mixed Record Field Updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following pattern synonym.
+
+  data MyRec = MyRec { foo :: Int, qux :: String }
+
+  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
+
+This allows updates such as the following
+
+  updater :: MyRec -> MyRec
+  updater a = a {f1 = 1 }
+
+It would also make sense to allow the following update (which we reject).
+
+  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
+
+This leads to confusing behaviour when the selectors in fact refer the same
+field.
+
+  updater a = a {f1 = 1, foo = 2} ==? ???
+
+For this reason, we reject a mixture of pattern synonym and normal record
+selectors in the same update block. Although of course we still allow the
+following.
+
+  updater a = (a {f1 = 1}) {foo = 2}
+
+  > updater (MyRec 0 "str")
+  MyRec 2 "str"
+
+-}
+
+tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
+  = ASSERT( notNull rbnds )
+    do  { -- STEP -2: typecheck the record_expr, the record to be updated
+          (record_expr', record_rho) <- tcInferRho record_expr
+
+        -- STEP -1  See Note [Disambiguating record fields]
+        -- After this we know that rbinds is unambiguous
+        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
+        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
+              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
+              sel_ids      = map selectorAmbiguousFieldOcc upd_flds
+        -- STEP 0
+        -- Check that the field names are really field names
+        -- and they are all field names for proper records or
+        -- all field names for pattern synonyms.
+        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
+                         | fld <- rbinds,
+                           -- Excludes class ops
+                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
+                           not (isRecordSelector sel_id),
+                           let fld_name = idName sel_id ]
+        ; unless (null bad_guys) (sequence bad_guys >> failM)
+        -- See note [Mixed Record Selectors]
+        ; let (data_sels, pat_syn_sels) =
+                partition isDataConRecordSelector sel_ids
+        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
+        ; checkTc ( null data_sels || null pat_syn_sels )
+                  ( mixedSelectors data_sels pat_syn_sels )
+
+        -- STEP 1
+        -- Figure out the tycon and data cons from the first field name
+        ; let   -- It's OK to use the non-tc splitters here (for a selector)
+              sel_id : _  = sel_ids
+
+              mtycon :: Maybe TyCon
+              mtycon = case idDetails sel_id of
+                          RecSelId (RecSelData tycon) _ -> Just tycon
+                          _ -> Nothing
+
+              con_likes :: [ConLike]
+              con_likes = case idDetails sel_id of
+                             RecSelId (RecSelData tc) _
+                                -> map RealDataCon (tyConDataCons tc)
+                             RecSelId (RecSelPatSyn ps) _
+                                -> [PatSynCon ps]
+                             _  -> panic "tcRecordUpd"
+                -- NB: for a data type family, the tycon is the instance tycon
+
+              relevant_cons = conLikesWithFields con_likes upd_fld_occs
+                -- A constructor is only relevant to this process if
+                -- it contains *all* the fields that are being updated
+                -- Other ones will cause a runtime error if they occur
+
+        -- Step 2
+        -- Check that at least one constructor has all the named fields
+        -- i.e. has an empty set of bad fields returned by badFields
+        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
+
+        -- Take apart a representative constructor
+        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
+              (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)
+                 = conLikeFullSig con1
+              con1_flds   = map flLabel $ conLikeFieldLabels con1
+              con1_tv_tys = mkTyVarTys con1_tvs
+              con1_res_ty = case mtycon of
+                              Just tc -> mkFamilyTyConApp tc con1_tv_tys
+                              Nothing -> conLikeResTy con1 con1_tv_tys
+
+        -- Check that we're not dealing with a unidirectional pattern
+        -- synonym
+        ; unless (isJust $ conLikeWrapId_maybe con1)
+                  (nonBidirectionalErr (conLikeName con1))
+
+        -- STEP 3    Note [Criteria for update]
+        -- Check that each updated field is polymorphic; that is, its type
+        -- mentions only the universally-quantified variables of the data con
+        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
+              bad_upd_flds = filter bad_fld flds1_w_tys
+              con1_tv_set  = mkVarSet con1_tvs
+              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
+                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
+        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
+
+        -- STEP 4  Note [Type of a record update]
+        -- Figure out types for the scrutinee and result
+        -- Both are of form (T a b c), with fresh type variables, but with
+        -- common variables where the scrutinee and result must have the same type
+        -- These are variables that appear in *any* arg of *any* of the
+        -- relevant constructors *except* in the updated fields
+        --
+        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
+              is_fixed_tv tv = tv `elemVarSet` fixed_tvs
+
+              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
+              -- Deals with instantiation of kind variables
+              --   c.f. TcMType.newMetaTyVars
+              mk_inst_ty subst (tv, result_inst_ty)
+                | is_fixed_tv tv   -- Same as result type
+                = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
+                | otherwise        -- Fresh type, of correct kind
+                = do { (subst', new_tv) <- newMetaTyVarX subst tv
+                     ; return (subst', mkTyVarTy new_tv) }
+
+        ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
+        ; let result_inst_tys = mkTyVarTys con1_tvs'
+              init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
+
+        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
+                                                      (con1_tvs `zip` result_inst_tys)
+
+        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty
+              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty
+              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
+
+        ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
+                                  (Just expr) rec_res_ty res_ty
+        ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty
+                -- NB: normal unification is OK here (as opposed to subsumption),
+                -- because for this to work out, both record_rho and scrut_ty have
+                -- to be normal datatypes -- no contravariant stuff can go on
+
+        -- STEP 5
+        -- Typecheck the bindings
+        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds
+
+        -- STEP 6: Deal with the stupid theta
+        ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)
+        ; instStupidTheta RecordUpdOrigin theta'
+
+        -- Step 7: make a cast for the scrutinee, in the
+        --         case that it's from a data family
+        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty
+              fam_co | Just tycon <- mtycon
+                     , Just co_con <- tyConFamilyCoercion_maybe tycon
+                     = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])
+                     | otherwise
+                     = idHsWrapper
+
+        -- Step 8: Check that the req constraints are satisfied
+        -- For normal data constructors req_theta is empty but we must do
+        -- this check for pattern synonyms.
+        ; let req_theta' = substThetaUnchecked scrut_subst req_theta
+        ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
+
+        -- Phew!
+        ; return $
+          mkHsWrap wrap_res $
+          RecordUpd { rupd_expr
+                          = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
+                    , rupd_flds = rbinds'
+                    , rupd_ext = RecordUpdTc
+                        { rupd_cons = relevant_cons
+                        , rupd_in_tys = scrut_inst_tys
+                        , rupd_out_tys = result_inst_tys
+                        , rupd_wrap = req_wrap }} }
+
+tcExpr e@(HsRecFld _ f) res_ty
+    = tcCheckRecSelId e f res_ty
+
+{-
+************************************************************************
+*                                                                      *
+        Arithmetic sequences                    e.g. [a,b..]
+        and their parallel-array counterparts   e.g. [: a,b.. :]
+
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr (ArithSeq _ witness seq) res_ty
+  = tcArithSeq witness seq res_ty
+
+{-
+************************************************************************
+*                                                                      *
+                Template Haskell
+*                                                                      *
+************************************************************************
+-}
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
+-- Here we get rid of it and add the finalizers to the global environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
+       res_ty
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tcExpr expr res_ty
+tcExpr (HsSpliceE _ splice)          res_ty
+  = tcSpliceExpr splice res_ty
+tcExpr e@(HsBracket _ brack)         res_ty
+  = tcTypedBracket e brack res_ty
+tcExpr e@(HsRnBracketOut _ brack ps) res_ty
+  = tcUntypedBracket e brack ps res_ty
+
+{-
+************************************************************************
+*                                                                      *
+                Catch-all
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
+  -- Include ArrForm, ArrApp, which shouldn't appear at all
+  -- Also HsTcBracketOut, HsQuasiQuoteE
+
+{-
+************************************************************************
+*                                                                      *
+                Arithmetic sequences [a..b] etc
+*                                                                      *
+************************************************************************
+-}
+
+tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
+           -> TcM (HsExpr GhcTcId)
+
+tcArithSeq witness seq@(From expr) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr' <- tcPolyExpr expr elt_ty
+       ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromName [elt_ty]
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from wit' (From expr') }
+
+tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr1' <- tcPolyExpr expr1 elt_ty
+       ; expr2' <- tcPolyExpr expr2 elt_ty
+       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromThenName [elt_ty]
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
+
+tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr1' <- tcPolyExpr expr1 elt_ty
+       ; expr2' <- tcPolyExpr expr2 elt_ty
+       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromToName [elt_ty]
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
+
+tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+        ; expr1' <- tcPolyExpr expr1 elt_ty
+        ; expr2' <- tcPolyExpr expr2 elt_ty
+        ; expr3' <- tcPolyExpr expr3 elt_ty
+        ; eft <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromThenToName [elt_ty]
+        ; return $ mkHsWrap wrap $
+          ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
+
+-----------------
+arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
+                -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc))
+arithSeqEltType Nothing res_ty
+  = do { res_ty <- expTypeToType res_ty
+       ; (coi, elt_ty) <- matchExpectedListTy res_ty
+       ; return (mkWpCastN coi, elt_ty, Nothing) }
+arithSeqEltType (Just fl) res_ty
+  = do { (elt_ty, fl')
+           <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
+              \ [elt_ty] -> return elt_ty
+       ; return (idHsWrapper, elt_ty, Just fl') }
+
+{-
+************************************************************************
+*                                                                      *
+                Applications
+*                                                                      *
+************************************************************************
+-}
+
+-- HsArg is defined in HsTypes.hs
+
+wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
+           => LHsExpr (GhcPass id)
+           -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
+           -> LHsExpr (GhcPass id)
+wrapHsArgs f []                     = f
+wrapHsArgs f (HsValArg  a : args)   = wrapHsArgs (mkHsApp f a)          args
+wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t)      args
+wrapHsArgs f (HsArgPar sp : args)   = wrapHsArgs (L sp $ HsPar noExt f) args
+
+isHsValArg :: HsArg tm ty -> Bool
+isHsValArg (HsValArg {})  = True
+isHsValArg (HsTypeArg {}) = False
+isHsValArg (HsArgPar {})  = False
+
+isArgPar :: HsArg tm ty -> Bool
+isArgPar (HsArgPar {})  = True
+isArgPar (HsValArg {})  = False
+isArgPar (HsTypeArg {}) = False
+
+isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
+isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp
+isArgPar_maybe _ = Nothing
+
+type LHsExprArgIn  = HsArg (LHsExpr GhcRn)   (LHsWcType GhcRn)
+type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)
+
+tcApp1 :: HsExpr GhcRn  -- either HsApp or HsAppType
+       -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcApp1 e res_ty
+  = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
+       ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) }
+
+tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
+                     -- or leave out to get exactly that message
+      -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args
+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+           -- (wrap, fun, args). For an ordinary function application,
+           -- these should be assembled as (wrap (fun args)).
+           -- But OpApp is slightly different, so that's why the caller
+           -- must assemble
+
+tcApp m_herald (L sp (HsPar _ fun)) args res_ty
+  = tcApp m_herald fun (HsArgPar sp : args) res_ty
+
+tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
+  = tcApp m_herald fun (HsValArg arg1 : args) res_ty
+
+tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty
+  = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty
+
+tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
+  | Ambiguous _ lbl        <- fld_lbl  -- Still ambiguous
+  , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first
+  , Just sig_ty     <- obviousSig arg  -- A type sig on the arg disambiguates
+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+       ; sel_name  <- disambiguateSelector lbl sig_tc_ty
+       ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)
+       ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty }
+
+tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty
+  -- Special typing rule for tagToEnum#
+  | fun_id `hasKey` tagToEnumKey
+  , n_val_args == 1
+  = tcTagToEnum loc fun_id args res_ty
+
+  -- Special typing rule for 'seq'
+  -- In the saturated case, behave as if seq had type
+  --    forall a (b::TYPE r). a -> b -> b
+  -- for some type r.  See Note [Typing rule for seq]
+  | fun_id `hasKey` seqIdKey
+  , n_val_args == 2
+  = do { rep <- newFlexiTyVarTy runtimeRepTy
+       ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep]
+             seq_ty = mkSpecForAllTys [alpha,beta]
+                      (mkTyVarTy alpha `mkVisFunTy` mkTyVarTy beta `mkVisFunTy` mkTyVarTy beta)
+             seq_fun = L loc (HsVar noExt (L loc seqId))
+             -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b
+             -- where 'r' is a meta type variable
+        ; tcFunApp m_herald fun seq_fun seq_ty args res_ty }
+  where
+    n_val_args = count isHsValArg args
+
+tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg] res_ty
+  -- See Note [Visible type application for the empty list constructor]
+  = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
+       ; let list_ty = TyConApp listTyCon [ty_arg']
+       ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt
+                          list_ty res_ty
+       ; let expr :: LHsExpr GhcTcId
+             expr = L loc $ ExplicitList ty_arg' Nothing []
+       ; return (idHsWrapper, expr, []) }
+
+tcApp m_herald fun args res_ty
+  = do { (tc_fun, fun_ty) <- tcInferFun fun
+       ; tcFunApp m_herald fun tc_fun fun_ty args res_ty }
+
+---------------------
+tcFunApp :: Maybe SDoc  -- like "The function `f' is applied to"
+                        -- or leave out to get exactly that message
+         -> LHsExpr GhcRn                  -- Renamed function
+         -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type
+         -> [LHsExprArgIn]                 -- Arguments
+         -> ExpRhoType                     -- Overall result type
+         -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+            -- (wrapper-for-result, fun, args)
+            -- For an ordinary function application,
+            -- these should be assembled as wrap_res[ fun args ]
+            -- But OpApp is slightly different, so that's why the caller
+            -- must assemble
+
+-- tcFunApp deals with the general case;
+-- the special cases are handled by tcApp
+tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty
+  = do { let orig = lexprCtOrigin rn_fun
+
+       ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty)
+       ; (wrap_fun, tc_args, actual_res_ty)
+           <- tcArgs rn_fun fun_sigma orig rn_args
+                     (m_herald `orElse` mk_app_msg rn_fun rn_args)
+
+            -- this is just like tcWrapResult, but the types don't line
+            -- up to call that function
+       ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $
+                     tcSubTypeDS_NC_O orig GenSigCtxt
+                       (Just $ unLoc $ wrapHsArgs rn_fun rn_args)
+                       actual_res_ty res_ty
+
+       ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) }
+
+mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
+mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr)
+                          , text "is applied to"]
+  where
+    what | null type_app_args = "function"
+         | otherwise          = "expression"
+    -- Include visible type arguments (but not other arguments) in the herald.
+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
+    expr = mkHsAppTypes fun type_app_args
+    type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args]
+
+mk_op_msg :: LHsExpr GhcRn -> SDoc
+mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
+
+{-
+Note [Visible type application for the empty list constructor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Getting the expression [] @Int to typecheck is slightly tricky since [] isn't
+an ordinary data constructor. By default, when tcExpr typechecks a list
+expression, it wraps the expression in a coercion, which gives it a type to the
+effect of p[a]. It isn't until later zonking that the type becomes
+forall a. [a], but that's too late for visible type application.
+
+The workaround is to check for empty list expressions that have a visible type
+argument in tcApp, and if so, directly typecheck [] @ty data constructor name.
+This avoids the intermediate coercion and produces an expression of type [ty],
+as one would intuitively expect.
+
+Unfortunately, this workaround isn't terribly robust, since more involved
+expressions such as (let in []) @Int won't work. Until a more elegant fix comes
+along, however, this at least allows direct type application on [] to work,
+which is better than before.
+-}
+
+----------------
+tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
+-- Infer type of a function
+tcInferFun (L loc (HsVar _ (L _ name)))
+  = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
+               -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
+tcInferFun (L loc (HsRecFld _ f))
+  = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
+               -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
+tcInferFun fun
+  = tcInferSigma fun
+      -- NB: tcInferSigma; see TcUnify
+      -- Note [Deep instantiation of InferResult] in TcUnify
+
+
+----------------
+-- | Type-check the arguments to a function, possibly including visible type
+-- applications
+tcArgs :: LHsExpr GhcRn   -- ^ The function itself (for err msgs only)
+       -> TcSigmaType    -- ^ the (uninstantiated) type of the function
+       -> CtOrigin       -- ^ the origin for the function's type
+       -> [LHsExprArgIn] -- ^ the args
+       -> SDoc           -- ^ the herald for matchActualFunTys
+       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
+          -- ^ (a wrapper for the function, the tc'd args, result type)
+tcArgs fun orig_fun_ty fun_orig orig_args herald
+  = go [] 1 orig_fun_ty orig_args
+  where
+    -- Don't count visible type arguments when determining how many arguments
+    -- an expression is given in an arity mismatch error, since visible type
+    -- arguments reported as a part of the expression herald itself.
+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
+    orig_expr_args_arity = count isHsValArg orig_args
+
+    go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
+
+    go acc_args n fun_ty (HsArgPar sp : args)
+      = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args
+           ; return (inner_wrap, HsArgPar sp : args', res_ty)
+           }
+
+    go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args)
+      = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
+               -- wrap1 :: fun_ty "->" upsilon_ty
+           ; case tcSplitForAllTy_maybe upsilon_ty of
+               Just (tvb, inner_ty)
+                 | binderArgFlag tvb == Specified ->
+                   -- It really can't be Inferred, because we've justn
+                   -- instantiated those. But, oddly, it might just be Required.
+                   -- See Note [Required quantifiers in the type of a term]
+                 do { let tv   = binderVar tvb
+                          kind = tyVarKind tv
+                    ; ty_arg <- tcHsTypeApp hs_ty_arg kind
+
+                    ; inner_ty <- zonkTcType inner_ty
+                          -- See Note [Visible type application zonk]
+                    ; let in_scope  = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg])
+
+                          insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty
+                                      -- NB: tv and ty_arg have the same kind, so this
+                                      --     substitution is kind-respecting
+                    ; traceTc "VTA" (vcat [ppr tv, debugPprType kind
+                                          , debugPprType ty_arg
+                                          , debugPprType (tcTypeKind ty_arg)
+                                          , debugPprType inner_ty
+                                          , debugPprType insted_ty ])
+
+                    ; (inner_wrap, args', res_ty)
+                        <- go acc_args (n+1) insted_ty args
+                   -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
+                    ; let inst_wrap = mkWpTyApps [ty_arg]
+                    ; return ( inner_wrap <.> inst_wrap <.> wrap1
+                             , HsTypeArg l hs_ty_arg : args'
+                             , res_ty ) }
+               _ -> ty_app_err upsilon_ty hs_ty_arg }
+
+    go acc_args n fun_ty (HsValArg arg : args)
+      = do { (wrap, [arg_ty], res_ty)
+               <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty
+                                        acc_args orig_expr_args_arity
+               -- wrap :: fun_ty "->" arg_ty -> res_ty
+           ; arg' <- tcArg fun arg arg_ty n
+           ; (inner_wrap, args', inner_res_ty)
+               <- go (arg_ty : acc_args) (n+1) res_ty args
+               -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
+           ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap
+                    , HsValArg arg' : args'
+                    , inner_res_ty ) }
+      where
+        doc = text "When checking the" <+> speakNth n <+>
+              text "argument to" <+> quotes (ppr fun)
+
+    ty_app_err ty arg
+      = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty
+           ; failWith $
+               text "Cannot apply expression of type" <+> quotes (ppr ty) $$
+               text "to a visible type argument" <+> quotes (ppr arg) }
+
+{- Note [Required quantifiers in the type of a term]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#15859)
+
+  data A k :: k -> Type      -- A      :: forall k -> k -> Type
+  type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type
+  a = (undefind :: KindOf A) @Int
+
+With ImpredicativeTypes (thin ice, I know), we instantiate
+KindOf at type (forall k -> k -> Type), so
+  KindOf A = forall k -> k -> Type
+whose first argument is Required
+
+We want to reject this type application to Int, but in earlier
+GHCs we had an ASSERT that Required could not occur here.
+
+The ice is thin; c.f. Note [No Required TyCoBinder in terms]
+in TyCoRep.
+
+Note [Visible type application zonk]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).
+
+* tcHsTypeApp only guarantees that
+    - ty_arg is zonked
+    - kind(zonk(tv)) = kind(ty_arg)
+  (checkExpectedKind zonks as it goes).
+
+So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)
+and inner_ty.  Otherwise we can build an ill-kinded type.  An example was
+#14158, where we had:
+   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a
+and we had the visible type application
+  id @(->)
+
+* We instantiated k := kappa, yielding
+    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a
+* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).
+* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,
+  Here q1 :: RuntimeRep
+* Now we substitute
+     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *
+  but we must first zonk the inner_ty to get
+      forall (a :: TYPE q1). cat a a
+  so that the result of substitution is well-kinded
+  Failing to do so led to #14158.
+-}
+
+----------------
+tcArg :: LHsExpr GhcRn                   -- The function (for error messages)
+      -> LHsExpr GhcRn                   -- Actual arguments
+      -> TcRhoType                       -- expected arg type
+      -> Int                             -- # of argument
+      -> TcM (LHsExpr GhcTcId)           -- Resulting argument
+tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $
+                          tcPolyExprNC arg ty
+
+----------------
+tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
+tcTupArgs args tys
+  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
+  where
+    go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))
+    go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                           ; return (L l (Present x expr')) }
+    go (L _ (XTupArg{}), _) = panic "tcTupArgs"
+
+---------------------------
+-- See TcType.SyntaxOpType also for commentary
+tcSyntaxOp :: CtOrigin
+           -> SyntaxExpr GhcRn
+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
+           -> ExpRhoType               -- ^ overall result type
+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
+           -> TcM (a, SyntaxExpr GhcTcId)
+-- ^ Typecheck a syntax operator
+-- The operator is a variable or a lambda at this stage (i.e. renamer
+-- output)
+tcSyntaxOp orig expr arg_tys res_ty
+  = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
+
+-- | Slightly more general version of 'tcSyntaxOp' that allows the caller
+-- to specify the shape of the result of the syntax operator
+tcSyntaxOpGen :: CtOrigin
+              -> SyntaxExpr GhcRn
+              -> [SyntaxOpType]
+              -> SyntaxOpType
+              -> ([TcSigmaType] -> TcM a)
+              -> TcM (a, SyntaxExpr GhcTcId)
+tcSyntaxOpGen orig op arg_tys res_ty thing_inside
+  = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op
+       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
+       ; (result, expr_wrap, arg_wraps, res_wrap)
+           <- tcSynArgA orig sigma arg_tys res_ty $
+              thing_inside
+       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
+       ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr
+                                    , syn_arg_wraps = arg_wraps
+                                    , syn_res_wrap  = res_wrap }) }
+
+{-
+Note [tcSynArg]
+~~~~~~~~~~~~~~~
+Because of the rich structure of SyntaxOpType, we must do the
+contra-/covariant thing when working down arrows, to get the
+instantiation vs. skolemisation decisions correct (and, more
+obviously, the orientation of the HsWrappers). We thus have
+two tcSynArgs.
+-}
+
+-- works on "expected" types, skolemising where necessary
+-- See Note [tcSynArg]
+tcSynArgE :: CtOrigin
+          -> TcSigmaType
+          -> SyntaxOpType                -- ^ shape it is expected to have
+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments
+          -> TcM (a, HsWrapper)
+           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
+tcSynArgE orig sigma_ty syn_ty thing_inside
+  = do { (skol_wrap, (result, ty_wrapper))
+           <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->
+              go rho_ty syn_ty
+       ; return (result, skol_wrap <.> ty_wrapper) }
+    where
+    go rho_ty SynAny
+      = do { result <- thing_inside [rho_ty]
+           ; return (result, idHsWrapper) }
+
+    go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly
+      = do { result <- thing_inside [rho_ty]
+           ; return (result, idHsWrapper) }
+
+    go rho_ty SynList
+      = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
+           ; result <- thing_inside [elt_ty]
+           ; return (result, mkWpCastN list_co) }
+
+    go rho_ty (SynFun arg_shape res_shape)
+      = do { ( ( ( (result, arg_ty, res_ty)
+                 , res_wrapper )                   -- :: res_ty_out "->" res_ty
+               , arg_wrapper1, [], arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out
+             , match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty
+               <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $
+                  \ [arg_ty] res_ty ->
+                  do { arg_tc_ty <- expTypeToType arg_ty
+                     ; res_tc_ty <- expTypeToType res_ty
+
+                         -- another nested arrow is too much for now,
+                         -- but I bet we'll never need this
+                     ; MASSERT2( case arg_shape of
+                                   SynFun {} -> False;
+                                   _         -> True
+                               , text "Too many nested arrows in SyntaxOpType" $$
+                                 pprCtOrigin orig )
+
+                     ; tcSynArgA orig arg_tc_ty [] arg_shape $
+                       \ arg_results ->
+                       tcSynArgE orig res_tc_ty res_shape $
+                       \ res_results ->
+                       do { result <- thing_inside (arg_results ++ res_results)
+                          ; return (result, arg_tc_ty, res_tc_ty) }}
+
+           ; return ( result
+                    , match_wrapper <.>
+                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
+                              arg_ty res_ty doc ) }
+      where
+        herald = text "This rebindable syntax expects a function with"
+        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig
+
+    go rho_ty (SynType the_ty)
+      = do { wrap   <- tcSubTypeET orig GenSigCtxt the_ty rho_ty
+           ; result <- thing_inside []
+           ; return (result, wrap) }
+
+-- works on "actual" types, instantiating where necessary
+-- See Note [tcSynArg]
+tcSynArgA :: CtOrigin
+          -> TcSigmaType
+          -> [SyntaxOpType]              -- ^ argument shapes
+          -> SyntaxOpType                -- ^ result shape
+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments
+          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
+            -- ^ returns a wrapper to be applied to the original function,
+            -- wrappers to be applied to arguments
+            -- and a wrapper to be applied to the overall expression
+tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
+  = do { (match_wrapper, arg_tys, res_ty)
+           <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty
+              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
+       ; ((result, res_wrapper), arg_wrappers)
+           <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
+              tc_syn_arg    res_ty  res_shape  $ \ res_results ->
+              thing_inside (arg_results ++ res_results)
+       ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
+  where
+    herald = text "This rebindable syntax expects a function with"
+
+    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
+                  -> ([TcSigmaType] -> TcM a)
+                  -> TcM (a, [HsWrapper])
+                    -- the wrappers are for arguments
+    tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
+      = do { ((result, arg_wraps), arg_wrap)
+               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results ->
+                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results ->
+                  thing_inside (arg1_results ++ args_results)
+           ; return (result, arg_wrap : arg_wraps) }
+    tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []
+
+    tc_syn_arg :: TcSigmaType -> SyntaxOpType
+               -> ([TcSigmaType] -> TcM a)
+               -> TcM (a, HsWrapper)
+                  -- the wrapper applies to the overall result
+    tc_syn_arg res_ty SynAny thing_inside
+      = do { result <- thing_inside [res_ty]
+           ; return (result, idHsWrapper) }
+    tc_syn_arg res_ty SynRho thing_inside
+      = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty
+               -- inst_wrap :: res_ty "->" rho_ty
+           ; result <- thing_inside [rho_ty]
+           ; return (result, inst_wrap) }
+    tc_syn_arg res_ty SynList thing_inside
+      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
+               -- inst_wrap :: res_ty "->" rho_ty
+           ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
+               -- list_co :: [elt_ty] ~N rho_ty
+           ; result <- thing_inside [elt_ty]
+           ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
+    tc_syn_arg _ (SynFun {}) _
+      = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
+    tc_syn_arg res_ty (SynType the_ty) thing_inside
+      = do { wrap   <- tcSubTypeO orig GenSigCtxt res_ty the_ty
+           ; result <- thing_inside []
+           ; return (result, wrap) }
+
+{-
+Note [Push result type in]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unify with expected result before type-checking the args so that the
+info from res_ty percolates to args.  This is when we might detect a
+too-few args situation.  (One can think of cases when the opposite
+order would give a better error message.)
+experimenting with putting this first.
+
+Here's an example where it actually makes a real difference
+
+   class C t a b | t a -> b
+   instance C Char a Bool
+
+   data P t a = forall b. (C t a b) => MkP b
+   data Q t   = MkQ (forall a. P t a)
+
+   f1, f2 :: Q Char;
+   f1 = MkQ (MkP True)
+   f2 = MkQ (MkP True :: forall a. P Char a)
+
+With the change, f1 will type-check, because the 'Char' info from
+the signature is propagated into MkQ's argument. With the check
+in the other order, the extra signature in f2 is reqd.
+
+************************************************************************
+*                                                                      *
+                Expressions with a type signature
+                        expr :: type
+*                                                                      *
+********************************************************************* -}
+
+tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType)
+tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+  = setSrcSpan loc $   -- Sets the location for the implication constraint
+    do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
+       ; given <- newEvVars theta
+       ; traceTc "tcExprSig: CompleteSig" $
+         vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id)
+              , text "tv_prs:" <+> ppr tv_prs ]
+
+       ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs
+             skol_tvs  = map snd tv_prs
+       ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
+                              tcExtendNameTyVarEnv tv_prs $
+                              tcPolyExprNC expr tau
+
+       ; let poly_wrap = mkWpTyLams   skol_tvs
+                         <.> mkWpLams given
+                         <.> mkWpLet  ev_binds
+       ; return (mkLHsWrap poly_wrap expr', idType poly_id) }
+
+tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
+  = setSrcSpan loc $   -- Sets the location for the implication constraint
+    do { (tclvl, wanted, (expr', sig_inst))
+             <- pushLevelAndCaptureConstraints  $
+                do { sig_inst <- tcInstSig sig
+                   ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $
+                              tcExtendNameTyVarEnv (sig_inst_wcs   sig_inst) $
+                              tcPolyExprNC expr (sig_inst_tau sig_inst)
+                   ; return (expr', sig_inst) }
+       -- See Note [Partial expression signatures]
+       ; let tau = sig_inst_tau sig_inst
+             infer_mode | null (sig_inst_theta sig_inst)
+                        , isNothing (sig_inst_wcx sig_inst)
+                        = ApplyMR
+                        | otherwise
+                        = NoRestrictions
+       ; (qtvs, givens, ev_binds, residual, _)
+                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
+       ; emitConstraints residual
+
+       ; tau <- zonkTcType tau
+       ; let inferred_theta = map evVarPred givens
+             tau_tvs        = tyCoVarsOfType tau
+       ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
+                                   tau_tvs qtvs (Just sig_inst)
+       ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
+             my_sigma       = mkForAllTys binders (mkPhiTy  my_theta tau)
+       ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
+                 then return idHsWrapper  -- Fast path; also avoids complaint when we infer
+                                          -- an ambiguous type and have AllowAmbiguousType
+                                          -- e..g infer  x :: forall a. F a -> Int
+                 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma
+
+       ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
+       ; let poly_wrap = wrap
+                         <.> mkWpTyLams qtvs
+                         <.> mkWpLams givens
+                         <.> mkWpLet  ev_binds
+       ; return (mkLHsWrap poly_wrap expr', my_sigma) }
+
+
+{- Note [Partial expression signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Partial type signatures on expressions are easy to get wrong.  But
+here is a guiding principile
+    e :: ty
+should behave like
+    let x :: ty
+        x = e
+    in x
+
+So for partial signatures we apply the MR if no context is given.  So
+   e :: IO _          apply the MR
+   e :: _ => IO _     do not apply the MR
+just like in TcBinds.decideGeneralisationPlan
+
+This makes a difference (#11670):
+   peek :: Ptr a -> IO CLong
+   peek ptr = peekElemOff undefined 0 :: _
+from (peekElemOff undefined 0) we get
+          type: IO w
+   constraints: Storable w
+
+We must NOT try to generalise over 'w' because the signature specifies
+no constraints so we'll complain about not being able to solve
+Storable w.  Instead, don't generalise; then _ gets instantiated to
+CLong, as it should.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                 tcInferId
+*                                                                      *
+********************************************************************* -}
+
+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcCheckId name res_ty
+  = do { (expr, actual_res_ty) <- tcInferId name
+       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
+       ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $
+         tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr
+                                                          actual_res_ty res_ty }
+
+tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty
+  = do { (expr, actual_res_ty) <- tcInferRecSelId f
+       ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $
+         tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty }
+tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty
+  = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
+      Nothing       -> ambiguousSelector lbl
+      Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
+                          ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)
+                                                    res_ty }
+tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"
+
+------------------------
+tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
+tcInferRecSelId (Unambiguous sel (L _ lbl))
+  = do { (expr', ty) <- tc_infer_id lbl sel
+       ; return (expr', ty) }
+tcInferRecSelId (Ambiguous _ lbl)
+  = ambiguousSelector lbl
+tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"
+
+------------------------
+tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
+-- Look up an occurrence of an Id
+-- Do not instantiate its type
+tcInferId id_name
+  | id_name `hasKey` tagToEnumKey
+  = failWithTc (text "tagToEnum# must appear applied to one argument")
+        -- tcApp catches the case (tagToEnum# arg)
+
+  | id_name `hasKey` assertIdKey
+  = do { dflags <- getDynFlags
+       ; if gopt Opt_IgnoreAsserts dflags
+         then tc_infer_id (nameRdrName id_name) id_name
+         else tc_infer_assert id_name }
+
+  | otherwise
+  = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name
+       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
+       ; return (expr, ty) }
+
+tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
+-- Deal with an occurrence of 'assert'
+-- See Note [Adding the implicit parameter to 'assert']
+tc_infer_assert assert_name
+  = do { assert_error_id <- tcLookupId assertErrorName
+       ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
+                                          (idType assert_error_id)
+       ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)
+       }
+
+tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
+tc_infer_id lbl id_name
+ = do { thing <- tcLookup id_name
+      ; case thing of
+             ATcId { tct_id = id }
+               -> do { check_naughty id        -- Note [Local record selectors]
+                     ; checkThLocalId id
+                     ; return_id id }
+
+             AGlobal (AnId id)
+               -> do { check_naughty id
+                     ; return_id id }
+                    -- A global cannot possibly be ill-staged
+                    -- nor does it need the 'lifting' treatment
+                    -- hence no checkTh stuff here
+
+             AGlobal (AConLike cl) -> case cl of
+                 RealDataCon con -> return_data_con con
+                 PatSynCon ps    -> tcPatSynBuilderOcc ps
+
+             _ -> failWithTc $
+                  ppr thing <+> text "used where a value identifier was expected" }
+  where
+    return_id id = return (HsVar noExt (noLoc id), idType id)
+
+    return_data_con con
+       -- For data constructors, must perform the stupid-theta check
+      | null stupid_theta
+      = return (HsConLikeOut noExt (RealDataCon con), con_ty)
+
+      | otherwise
+       -- See Note [Instantiating stupid theta]
+      = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty
+           ; (subst, tvs') <- newMetaTyVars tvs
+           ; let tys'   = mkTyVarTys tvs'
+                 theta' = substTheta subst theta
+                 rho'   = substTy subst rho
+           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'
+           ; addDataConStupidTheta con tys'
+           ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))
+                    , rho') }
+
+      where
+        con_ty         = dataConUserType con
+        stupid_theta   = dataConStupidTheta con
+
+    check_naughty id
+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
+      | otherwise                  = return ()
+
+
+tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
+-- Typecheck an occurrence of an unbound Id
+--
+-- Some of these started life as a true expression hole "_".
+-- Others might simply be variables that accidentally have no binding site
+--
+-- We turn all of them into HsVar, since HsUnboundVar can't contain an
+-- Id; and indeed the evidence for the CHoleCan does bind it, so it's
+-- not unbound any more!
+tcUnboundId rn_expr unbound res_ty
+ = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (#12531)
+      ; let occ = unboundVarOcc unbound
+      ; name <- newSysName occ
+      ; let ev = mkLocalId name ty
+      ; can <- newHoleCt (ExprHole unbound) ev ty
+      ; emitInsoluble can
+      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))
+                                                                     ty res_ty }
+
+
+{-
+Note [Adding the implicit parameter to 'assert']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker transforms (assert e1 e2) to (assertError e1 e2).
+This isn't really the Right Thing because there's no way to "undo"
+if you want to see the original source code in the typechecker
+output.  We'll have fix this in due course, when we care more about
+being able to reconstruct the exact original program.
+
+Note [tagToEnum#]
+~~~~~~~~~~~~~~~~~
+Nasty check to ensure that tagToEnum# is applied to a type that is an
+enumeration TyCon.  Unification may refine the type later, but this
+check won't see that, alas.  It's crude, because it relies on our
+knowing *now* that the type is ok, which in turn relies on the
+eager-unification part of the type checker pushing enough information
+here.  In theory the Right Thing to do is to have a new form of
+constraint but I definitely cannot face that!  And it works ok as-is.
+
+Here's are two cases that should fail
+        f :: forall a. a
+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
+
+        g :: Int
+        g = tagToEnum# 0        -- Int is not an enumeration
+
+When data type families are involved it's a bit more complicated.
+     data family F a
+     data instance F [Int] = A | B | C
+Then we want to generate something like
+     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
+Usually that coercion is hidden inside the wrappers for
+constructors of F [Int] but here we have to do it explicitly.
+
+It's all grotesquely complicated.
+
+Note [Instantiating stupid theta]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, when we infer the type of an Id, we don't instantiate,
+because we wish to allow for visible type application later on.
+But if a datacon has a stupid theta, we're a bit stuck. We need
+to emit the stupid theta constraints with instantiated types. It's
+difficult to defer this to the lazy instantiation, because a stupid
+theta has no spot to put it in a type. So we just instantiate eagerly
+in this case. Thus, users cannot use visible type application with
+a data constructor sporting a stupid theta. I won't feel so bad for
+the users that complain.
+
+-}
+
+tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
+            -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+-- tagToEnum# :: forall a. Int# -> a
+-- See Note [tagToEnum#]   Urgh!
+tcTagToEnum loc fun_name args res_ty
+  = do { fun <- tcLookupId fun_name
+
+       ; let pars1 = mapMaybe isArgPar_maybe before
+             pars2 = mapMaybe isArgPar_maybe after
+             -- args contains exactly one HsValArg
+             (before, _:after) = break isHsValArg args
+
+       ; arg <- case filterOut isArgPar args of
+           [HsTypeArg _ hs_ty_arg, HsValArg term_arg]
+             -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
+                   ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty
+                     -- other than influencing res_ty, we just
+                     -- don't care about a type arg passed in.
+                     -- So drop the evidence.
+                   ; return term_arg }
+           [HsValArg term_arg] -> do { _ <- expTypeToType res_ty
+                                     ; return term_arg }
+           _          -> too_many_args "tagToEnum#" args
+
+       ; res_ty <- readExpType res_ty
+       ; ty'    <- zonkTcType res_ty
+
+       -- Check that the type is algebraic
+       ; let mb_tc_app = tcSplitTyConApp_maybe ty'
+             Just (tc, tc_args) = mb_tc_app
+       ; checkTc (isJust mb_tc_app)
+                 (mk_error ty' doc1)
+
+       -- Look through any type family
+       ; fam_envs <- tcGetFamInstEnvs
+       ; let (rep_tc, rep_args, coi)
+               = tcLookupDataFamInst fam_envs tc tc_args
+            -- coi :: tc tc_args ~R rep_tc rep_args
+
+       ; checkTc (isEnumerationTyCon rep_tc)
+                 (mk_error ty' doc2)
+
+       ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
+       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))
+             rep_ty = mkTyConApp rep_tc rep_args
+             out_args = concat
+              [ pars1
+              , [HsValArg arg']
+              , pars2
+              ]
+
+       ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) }
+                 -- coi is a Representational coercion
+  where
+    doc1 = vcat [ text "Specify the type by giving a type signature"
+                , text "e.g. (tagToEnum# x) :: Bool" ]
+    doc2 = text "Result type must be an enumeration type"
+
+    mk_error :: TcType -> SDoc -> SDoc
+    mk_error ty what
+      = hang (text "Bad call to tagToEnum#"
+               <+> text "at type" <+> ppr ty)
+           2 what
+
+too_many_args :: String -> [LHsExprArgIn] -> TcM a
+too_many_args fun args
+  = failWith $
+    hang (text "Too many type arguments to" <+> text fun <> colon)
+       2 (sep (map pp args))
+  where
+    pp (HsValArg e)                             = ppr e
+    pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t
+    pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args"
+    pp (HsArgPar _) = empty
+
+
+{-
+************************************************************************
+*                                                                      *
+                 Template Haskell checks
+*                                                                      *
+************************************************************************
+-}
+
+checkThLocalId :: Id -> TcM ()
+checkThLocalId id
+  = do  { mb_local_use <- getStageAndBindLevel (idName id)
+        ; case mb_local_use of
+             Just (top_lvl, bind_lvl, use_stage)
+                | thLevel use_stage > bind_lvl
+                -> checkCrossStageLifting top_lvl id use_stage
+             _  -> return ()   -- Not a locally-bound thing, or
+                               -- no cross-stage link
+    }
+
+--------------------------------------
+checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
+-- If we are inside typed brackets, and (use_lvl > bind_lvl)
+-- we must check whether there's a cross-stage lift to do
+-- Examples   \x -> [|| x ||]
+--            [|| map ||]
+-- There is no error-checking to do, because the renamer did that
+--
+-- This is similar to checkCrossStageLifting in RnSplice, but
+-- this code is applied to *typed* brackets.
+
+checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
+  | isTopLevel top_lvl
+  = when (isExternalName id_name) (keepAlive id_name)
+    -- See Note [Keeping things alive for Template Haskell] in RnSplice
+
+  | otherwise
+  =     -- Nested identifiers, such as 'x' in
+        -- E.g. \x -> [|| h x ||]
+        -- We must behave as if the reference to x was
+        --      h $(lift x)
+        -- We use 'x' itself as the splice proxy, used by
+        -- the desugarer to stitch it all back together.
+        -- If 'x' occurs many times we may get many identical
+        -- bindings of the same splice proxy, but that doesn't
+        -- matter, although it's a mite untidy.
+    do  { let id_ty = idType id
+        ; checkTc (isTauTy id_ty) (polySpliceErr id)
+               -- If x is polymorphic, its occurrence sites might
+               -- have different instantiations, so we can't use plain
+               -- 'x' as the splice proxy name.  I don't know how to
+               -- solve this, and it's probably unimportant, so I'm
+               -- just going to flag an error for now
+
+        ; lift <- if isStringTy id_ty then
+                     do { sid <- tcLookupId THNames.liftStringName
+                                     -- See Note [Lifting strings]
+                        ; return (HsVar noExt (noLoc sid)) }
+                  else
+                     setConstraintVar lie_var   $
+                          -- Put the 'lift' constraint into the right LIE
+                     newMethodFromName (OccurrenceOf id_name)
+                                       THNames.liftName
+                                       [getRuntimeRep id_ty, id_ty]
+
+                   -- Update the pending splices
+        ; ps <- readMutVar ps_var
+        ; let pending_splice = PendingTcSplice id_name
+                                 (nlHsApp (noLoc lift) (nlHsVar id))
+        ; writeMutVar ps_var (pending_splice : ps)
+
+        ; return () }
+  where
+    id_name = idName id
+
+checkCrossStageLifting _ _ _ = return ()
+
+polySpliceErr :: Id -> SDoc
+polySpliceErr id
+  = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
+
+{-
+Note [Lifting strings]
+~~~~~~~~~~~~~~~~~~~~~~
+If we see $(... [| s |] ...) where s::String, we don't want to
+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
+So this conditional short-circuits the lifting mechanism to generate
+(liftString "xy") in that case.  I didn't want to use overlapping instances
+for the Lift class in TH.Syntax, because that can lead to overlapping-instance
+errors in a polymorphic situation.
+
+If this check fails (which isn't impossible) we get another chance; see
+Note [Converting strings] in Convert.hs
+
+Local record selectors
+~~~~~~~~~~~~~~~~~~~~~~
+Record selectors for TyCons in this module are ordinary local bindings,
+which show up as ATcIds rather than AGlobals.  So we need to check for
+naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Record bindings}
+*                                                                      *
+************************************************************************
+-}
+
+getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
+-- These tyvars must not change across the updates
+getFixedTyVars upd_fld_occs univ_tvs cons
+      = mkVarSet [tv1 | con <- cons
+                      , let (u_tvs, _, eqspec, prov_theta
+                             , req_theta, arg_tys, _)
+                              = conLikeFullSig con
+                            theta = eqSpecPreds eqspec
+                                     ++ prov_theta
+                                     ++ req_theta
+                            flds = conLikeFieldLabels con
+                            fixed_tvs = exactTyCoVarsOfTypes fixed_tys
+                                    -- fixed_tys: See Note [Type of a record update]
+                                        `unionVarSet` tyCoVarsOfTypes theta
+                                    -- Universally-quantified tyvars that
+                                    -- appear in any of the *implicit*
+                                    -- arguments to the constructor are fixed
+                                    -- See Note [Implicit type sharing]
+
+                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
+                                            , not (flLabel fl `elem` upd_fld_occs)]
+                      , (tv1,tv) <- univ_tvs `zip` u_tvs
+                      , tv `elemVarSet` fixed_tvs ]
+
+{-
+Note [Disambiguating record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the -XDuplicateRecordFields extension is used, and the renamer
+encounters a record selector or update that it cannot immediately
+disambiguate (because it involves fields that belong to multiple
+datatypes), it will defer resolution of the ambiguity to the
+typechecker.  In this case, the `Ambiguous` constructor of
+`AmbiguousFieldOcc` is used.
+
+Consider the following definitions:
+
+        data S = MkS { foo :: Int }
+        data T = MkT { foo :: Int, bar :: Int }
+        data U = MkU { bar :: Int, baz :: Int }
+
+When the renamer sees `foo` as a selector or an update, it will not
+know which parent datatype is in use.
+
+For selectors, there are two possible ways to disambiguate:
+
+1. Check if the pushed-in type is a function whose domain is a
+   datatype, for example:
+
+       f s = (foo :: S -> Int) s
+
+       g :: T -> Int
+       g = foo
+
+    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
+
+2. Check if the selector is applied to an argument that has a type
+   signature, for example:
+
+       h = foo (s :: S)
+
+    This is checked by `tcApp`.
+
+
+Updates are slightly more complex.  The `disambiguateRecordBinds`
+function tries to determine the parent datatype in three ways:
+
+1. Check for types that have all the fields being updated. For example:
+
+        f x = x { foo = 3, bar = 2 }
+
+   Here `f` must be updating `T` because neither `S` nor `U` have
+   both fields. This may also discover that no possible type exists.
+   For example the following will be rejected:
+
+        f' x = x { foo = 3, baz = 3 }
+
+2. Use the type being pushed in, if it is already a TyConApp. The
+   following are valid updates to `T`:
+
+        g :: T -> T
+        g x = x { foo = 3 }
+
+        g' x = x { foo = 3 } :: T
+
+3. Use the type signature of the record expression, if it exists and
+   is a TyConApp. Thus this is valid update to `T`:
+
+        h x = (x :: T) { foo = 3 }
+
+
+Note that we do not look up the types of variables being updated, and
+no constraint-solving is performed, so for example the following will
+be rejected as ambiguous:
+
+     let bad (s :: S) = foo s
+
+     let r :: T
+         r = blah
+     in r { foo = 3 }
+
+     \r. (r { foo = 3 },  r :: T )
+
+We could add further tests, of a more heuristic nature. For example,
+rather than looking for an explicit signature, we could try to infer
+the type of the argument to a selector or the record expression being
+updated, in case we are lucky enough to get a TyConApp straight
+away. However, it might be hard for programmers to predict whether a
+particular update is sufficiently obvious for the signature to be
+omitted. Moreover, this might change the behaviour of typechecker in
+non-obvious ways.
+
+See also Note [HsRecField and HsRecUpdField] in HsPat.
+-}
+
+-- Given a RdrName that refers to multiple record fields, and the type
+-- of its argument, try to determine the name of the selector that is
+-- meant.
+disambiguateSelector :: Located RdrName -> Type -> TcM Name
+disambiguateSelector lr@(L _ rdr) parent_type
+ = do { fam_inst_envs <- tcGetFamInstEnvs
+      ; case tyConOf fam_inst_envs parent_type of
+          Nothing -> ambiguousSelector lr
+          Just p  ->
+            do { xs <- lookupParents rdr
+               ; let parent = RecSelData p
+               ; case lookup parent xs of
+                   Just gre -> do { addUsedGRE True gre
+                                  ; return (gre_name gre) }
+                   Nothing  -> failWithTc (fieldNotInType parent rdr) } }
+
+-- This field name really is ambiguous, so add a suitable "ambiguous
+-- occurrence" error, then give up.
+ambiguousSelector :: Located RdrName -> TcM a
+ambiguousSelector (L _ rdr)
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGRE_RdrName rdr env
+       ; setErrCtxt [] $ addNameClashErrRn rdr gres
+       ; failM }
+
+-- Disambiguate the fields in a record update.
+-- See Note [Disambiguating record fields]
+disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
+                 -> [LHsRecUpdField GhcRn] -> ExpRhoType
+                 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
+disambiguateRecordBinds record_expr record_rho rbnds res_ty
+    -- Are all the fields unambiguous?
+  = case mapM isUnambiguous rbnds of
+                     -- If so, just skip to looking up the Ids
+                     -- Always the case if DuplicateRecordFields is off
+      Just rbnds' -> mapM lookupSelector rbnds'
+      Nothing     -> -- If not, try to identify a single parent
+        do { fam_inst_envs <- tcGetFamInstEnvs
+             -- Look up the possible parents for each field
+           ; rbnds_with_parents <- getUpdFieldsParents
+           ; let possible_parents = map (map fst . snd) rbnds_with_parents
+             -- Identify a single parent
+           ; p <- identifyParent fam_inst_envs possible_parents
+             -- Pick the right selector with that parent for each field
+           ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
+  where
+    -- Extract the selector name of a field update if it is unambiguous
+    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
+    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
+                        Unambiguous sel_name _ -> Just (x, sel_name)
+                        Ambiguous{}            -> Nothing
+                        XAmbiguousFieldOcc{}   -> Nothing
+
+    -- Look up the possible parents and selector GREs for each field
+    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
+                                , [(RecSelParent, GlobalRdrElt)])]
+    getUpdFieldsParents
+      = fmap (zip rbnds) $ mapM
+          (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
+          rbnds
+
+    -- Given a the lists of possible parents for each field,
+    -- identify a single parent
+    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
+    identifyParent fam_inst_envs possible_parents
+      = case foldr1 intersect possible_parents of
+        -- No parents for all fields: record update is ill-typed
+        []  -> failWithTc (noPossibleParents rbnds)
+
+        -- Exactly one datatype with all the fields: use that
+        [p] -> return p
+
+        -- Multiple possible parents: try harder to disambiguate
+        -- Can we get a parent TyCon from the pushed-in type?
+        _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)
+
+        -- Does the expression being updated have a type signature?
+        -- If so, try to extract a parent TyCon from it
+            | Just {} <- obviousSig (unLoc record_expr)
+            , Just tc <- tyConOf fam_inst_envs record_rho
+            -> return (RecSelData tc)
+
+        -- Nothing else we can try...
+        _ -> failWithTc badOverloadedUpdate
+
+    -- Make a field unambiguous by choosing the given parent.
+    -- Emits an error if the field cannot have that parent,
+    -- e.g. if the user writes
+    --     r { x = e } :: T
+    -- where T does not have field x.
+    pickParent :: RecSelParent
+               -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
+               -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
+    pickParent p (upd, xs)
+      = case lookup p xs of
+                      -- Phew! The parent is valid for this field.
+                      -- Previously ambiguous fields must be marked as
+                      -- used now that we know which one is meant, but
+                      -- unambiguous ones shouldn't be recorded again
+                      -- (giving duplicate deprecation warnings).
+          Just gre -> do { unless (null (tail xs)) $ do
+                             let L loc _ = hsRecFieldLbl (unLoc upd)
+                             setSrcSpan loc $ addUsedGRE True gre
+                         ; lookupSelector (upd, gre_name gre) }
+                      -- The field doesn't belong to this parent, so report
+                      -- an error but keep going through all the fields
+          Nothing  -> do { addErrTc (fieldNotInType p
+                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))
+                         ; lookupSelector (upd, gre_name (snd (head xs))) }
+
+    -- Given a (field update, selector name) pair, look up the
+    -- selector to give a field update with an unambiguous Id
+    lookupSelector :: (LHsRecUpdField GhcRn, Name)
+                 -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
+    lookupSelector (L l upd, n)
+      = do { i <- tcLookupId n
+           ; let L loc af = hsRecFieldLbl upd
+                 lbl      = rdrNameAmbiguousFieldOcc af
+           ; return $ L l upd { hsRecFieldLbl
+                                  = L loc (Unambiguous i (L loc lbl)) } }
+
+
+-- Extract the outermost TyCon of a type, if there is one; for
+-- data families this is the representation tycon (because that's
+-- where the fields live).
+tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
+tyConOf fam_inst_envs ty0
+  = case tcSplitTyConApp_maybe ty of
+      Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
+      Nothing        -> Nothing
+  where
+    (_, _, ty) = tcSplitSigmaTy ty0
+
+-- Variant of tyConOf that works for ExpTypes
+tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
+tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
+
+-- For an ambiguous record field, find all the candidate record
+-- selectors (as GlobalRdrElts) and their parents.
+lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
+lookupParents rdr
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGRE_RdrName rdr env
+       ; mapM lookupParent gres }
+  where
+    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
+    lookupParent gre = do { id <- tcLookupId (gre_name gre)
+                          ; if isRecordSelector id
+                              then return (recordSelectorTyCon id, gre)
+                              else failWithTc (notSelector (gre_name gre)) }
+
+-- A type signature on the argument of an ambiguous record selector or
+-- the record expression in an update must be "obvious", i.e. the
+-- outermost constructor ignoring parentheses.
+obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
+obviousSig (ExprWithTySig _ _ ty) = Just ty
+obviousSig (HsPar _ p)          = obviousSig (unLoc p)
+obviousSig _                    = Nothing
+
+
+{-
+Game plan for record bindings
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1. Find the TyCon for the bindings, from the first field label.
+
+2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
+
+For each binding field = value
+
+3. Instantiate the field type (from the field label) using the type
+   envt from step 2.
+
+4  Type check the value using tcArg, passing the field type as
+   the expected argument type.
+
+This extends OK when the field types are universally quantified.
+-}
+
+tcRecordBinds
+        :: ConLike
+        -> [TcType]     -- Expected type for each field
+        -> HsRecordBinds GhcRn
+        -> TcM (HsRecordBinds GhcTcId)
+
+tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
+  = do  { mb_binds <- mapM do_bind rbinds
+        ; return (HsRecFields (catMaybes mb_binds) dd) }
+  where
+    fields = map flSelector $ conLikeFieldLabels con_like
+    flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
+
+    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
+            -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
+                                 , hsRecFieldArg = rhs }))
+
+      = do { mb <- tcRecordField con_like flds_w_tys f rhs
+           ; case mb of
+               Nothing         -> return Nothing
+               Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
+                                                          , hsRecFieldArg = rhs' }))) }
+
+tcRecordUpd
+        :: ConLike
+        -> [TcType]     -- Expected type for each field
+        -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
+        -> TcM [LHsRecUpdField GhcTcId]
+
+tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
+  where
+    fields = map flSelector $ conLikeFieldLabels con_like
+    flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
+
+    do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
+            -> TcM (Maybe (LHsRecUpdField GhcTcId))
+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
+                                 , hsRecFieldArg = rhs }))
+      = do { let lbl = rdrNameAmbiguousFieldOcc af
+                 sel_id = selectorAmbiguousFieldOcc af
+                 f = L loc (FieldOcc (idName sel_id) (L loc lbl))
+           ; mb <- tcRecordField con_like flds_w_tys f rhs
+           ; case mb of
+               Nothing         -> return Nothing
+               Just (f', rhs') ->
+                 return (Just
+                         (L l (fld { hsRecFieldLbl
+                                      = L loc (Unambiguous
+                                               (extFieldOcc (unLoc f'))
+                                               (L loc lbl))
+                                   , hsRecFieldArg = rhs' }))) }
+
+tcRecordField :: ConLike -> Assoc Name Type
+              -> LFieldOcc GhcRn -> LHsExpr GhcRn
+              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
+tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
+  | Just field_ty <- assocMaybe flds_w_tys sel_name
+      = addErrCtxt (fieldCtxt field_lbl) $
+        do { rhs' <- tcPolyExprNC rhs field_ty
+           ; let field_id = mkUserLocal (nameOccName sel_name)
+                                        (nameUnique sel_name)
+                                        field_ty loc
+                -- Yuk: the field_id has the *unique* of the selector Id
+                --          (so we can find it easily)
+                --      but is a LocalId with the appropriate type of the RHS
+                --          (so the desugarer knows the type of local binder to make)
+           ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
+      | otherwise
+      = do { addErrTc (badFieldCon con_like field_lbl)
+           ; return Nothing }
+  where
+        field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
+tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"
+
+
+checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()
+checkMissingFields con_like rbinds
+  | null field_labels   -- Not declared as a record;
+                        -- But C{} is still valid if no strict fields
+  = if any isBanged field_strs then
+        -- Illegal if any arg is strict
+        addErrTc (missingStrictFields con_like [])
+    else do
+        warn <- woptM Opt_WarnMissingFields
+        when (warn && notNull field_strs && null field_labels)
+             (warnTc (Reason Opt_WarnMissingFields) True
+                 (missingFields con_like []))
+
+  | otherwise = do              -- A record
+    unless (null missing_s_fields)
+           (addErrTc (missingStrictFields con_like missing_s_fields))
+
+    warn <- woptM Opt_WarnMissingFields
+    when (warn && notNull missing_ns_fields)
+         (warnTc (Reason Opt_WarnMissingFields) True
+             (missingFields con_like missing_ns_fields))
+
+  where
+    missing_s_fields
+        = [ flLabel fl | (fl, str) <- field_info,
+                 isBanged str,
+                 not (fl `elemField` field_names_used)
+          ]
+    missing_ns_fields
+        = [ flLabel fl | (fl, str) <- field_info,
+                 not (isBanged str),
+                 not (fl `elemField` field_names_used)
+          ]
+
+    field_names_used = hsRecFields rbinds
+    field_labels     = conLikeFieldLabels con_like
+
+    field_info = zipEqual "missingFields"
+                          field_labels
+                          field_strs
+
+    field_strs = conLikeImplBangs con_like
+
+    fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+Boring and alphabetical:
+-}
+
+addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a
+addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
+
+exprCtxt :: LHsExpr GhcRn -> SDoc
+exprCtxt expr
+  = hang (text "In the expression:") 2 (ppr expr)
+
+fieldCtxt :: FieldLabelString -> SDoc
+fieldCtxt field_name
+  = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
+
+addFunResCtxt :: Bool  -- There is at least one argument
+              -> HsExpr GhcRn -> TcType -> ExpRhoType
+              -> TcM a -> TcM a
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+--
+-- Used for naked variables too; but with has_args = False
+addFunResCtxt has_args fun fun_res_ty env_ty
+  = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)
+      -- NB: use a landmark error context, so that an empty context
+      -- doesn't suppress some more useful context
+  where
+    mk_msg
+      = do { mb_env_ty <- readExpType_maybe env_ty
+                     -- by the time the message is rendered, the ExpType
+                     -- will be filled in (except if we're debugging)
+           ; fun_res' <- zonkTcType fun_res_ty
+           ; env'     <- case mb_env_ty of
+                           Just env_ty -> zonkTcType env_ty
+                           Nothing     ->
+                             do { dumping <- doptM Opt_D_dump_tc_trace
+                                ; MASSERT( dumping )
+                                ; newFlexiTyVarTy liftedTypeKind }
+           ; let -- See Note [Splitting nested sigma types in mismatched
+                 --           function types]
+                 (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
+                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
+                 -- an ExpRhoTy, i.e., it's already deeply instantiated.
+                 (_, _, env_tau) = tcSplitSigmaTy env'
+                 (args_fun, res_fun) = tcSplitFunTys fun_tau
+                 (args_env, res_env) = tcSplitFunTys env_tau
+                 n_fun = length args_fun
+                 n_env = length args_env
+                 info  | n_fun == n_env = Outputable.empty
+                       | n_fun > n_env
+                       , not_fun res_env
+                       = text "Probable cause:" <+> quotes (ppr fun)
+                         <+> text "is applied to too few arguments"
+
+                       | has_args
+                       , not_fun res_fun
+                       = text "Possible cause:" <+> quotes (ppr fun)
+                         <+> text "is applied to too many arguments"
+
+                       | otherwise
+                       = Outputable.empty  -- Never suggest that a naked variable is                                         -- applied to too many args!
+           ; return info }
+      where
+        not_fun ty   -- ty is definitely not an arrow type,
+                     -- and cannot conceivably become one
+          = case tcSplitTyConApp_maybe ty of
+              Just (tc, _) -> isAlgTyCon tc
+              Nothing      -> False
+
+{-
+Note [Splitting nested sigma types in mismatched function types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When one applies a function to too few arguments, GHC tries to determine this
+fact if possible so that it may give a helpful error message. It accomplishes
+this by checking if the type of the applied function has more argument types
+than supplied arguments.
+
+Previously, GHC computed the number of argument types through tcSplitSigmaTy.
+This is incorrect in the face of nested foralls, however! This caused Trac
+#13311, for instance:
+
+  f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b
+
+If one uses `f` like so:
+
+  do { f; putChar 'a' }
+
+Then tcSplitSigmaTy will decompose the type of `f` into:
+
+  Tyvars: [a]
+  Context: (Monoid a)
+  Argument types: []
+  Return type: forall b. Monoid b => Maybe a -> Maybe b
+
+That is, it will conclude that there are *no* argument types, and since `f`
+was given no arguments, it won't print a helpful error message. On the other
+hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:
+
+  Tyvars: [a, b]
+  Context: (Monoid a, Monoid b)
+  Argument types: [Maybe a]
+  Return type: Maybe b
+
+So now GHC recognizes that `f` has one more argument type than it was actually
+provided.
+-}
+
+badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
+badFieldTypes prs
+  = hang (text "Record update for insufficiently polymorphic field"
+                         <> plural prs <> colon)
+       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
+
+badFieldsUpd
+  :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
+               -- Field names that don't belong to a single datacon
+  -> [ConLike] -- Data cons of the type which the first field name belongs to
+  -> SDoc
+badFieldsUpd rbinds data_cons
+  = hang (text "No constructor has all these fields:")
+       2 (pprQuotedList conflictingFields)
+          -- See Note [Finding the conflicting fields]
+  where
+    -- A (preferably small) set of fields such that no constructor contains
+    -- all of them.  See Note [Finding the conflicting fields]
+    conflictingFields = case nonMembers of
+        -- nonMember belongs to a different type.
+        (nonMember, _) : _ -> [aMember, nonMember]
+        [] -> let
+            -- All of rbinds belong to one type. In this case, repeatedly add
+            -- a field to the set until no constructor contains the set.
+
+            -- Each field, together with a list indicating which constructors
+            -- have all the fields so far.
+            growingSets :: [(FieldLabelString, [Bool])]
+            growingSets = scanl1 combine membership
+            combine (_, setMem) (field, fldMem)
+              = (field, zipWith (&&) setMem fldMem)
+            in
+            -- Fields that don't change the membership status of the set
+            -- are redundant and can be dropped.
+            map (fst . head) $ groupBy ((==) `on` snd) growingSets
+
+    aMember = ASSERT( not (null members) ) fst (head members)
+    (members, nonMembers) = partition (or . snd) membership
+
+    -- For each field, which constructors contain the field?
+    membership :: [(FieldLabelString, [Bool])]
+    membership = sortMembership $
+        map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
+
+    fieldLabelSets :: [Set.Set FieldLabelString]
+    fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
+
+    -- Sort in order of increasing number of True, so that a smaller
+    -- conflicting set can be found.
+    sortMembership =
+      map snd .
+      sortBy (compare `on` fst) .
+      map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
+
+    countTrue = count id
+
+{-
+Note [Finding the conflicting fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  data A = A {a0, a1 :: Int}
+         | B {b0, b1 :: Int}
+and we see a record update
+  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
+Then we'd like to find the smallest subset of fields that no
+constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
+We don't really want to report that no constructor has all of
+{a0,a1,b0,b1}, because when there are hundreds of fields it's
+hard to see what was really wrong.
+
+We may need more than two fields, though; eg
+  data T = A { x,y :: Int, v::Int }
+          | B { y,z :: Int, v::Int }
+          | C { z,x :: Int, v::Int }
+with update
+   r { x=e1, y=e2, z=e3 }, we
+
+Finding the smallest subset is hard, so the code here makes
+a decent stab, no more.  See #7989.
+-}
+
+naughtyRecordSel :: RdrName -> SDoc
+naughtyRecordSel sel_id
+  = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>
+    text "as a function due to escaped type variables" $$
+    text "Probable fix: use pattern-matching syntax instead"
+
+notSelector :: Name -> SDoc
+notSelector field
+  = hsep [quotes (ppr field), text "is not a record selector"]
+
+mixedSelectors :: [Id] -> [Id] -> SDoc
+mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
+  = ptext
+      (sLit "Cannot use a mixture of pattern synonym and record selectors") $$
+    text "Record selectors defined by"
+      <+> quotes (ppr (tyConName rep_dc))
+      <> text ":"
+      <+> pprWithCommas ppr data_sels $$
+    text "Pattern synonym selectors defined by"
+      <+> quotes (ppr (patSynName rep_ps))
+      <> text ":"
+      <+> pprWithCommas ppr pat_syn_sels
+  where
+    RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
+    RecSelData rep_dc = recordSelectorTyCon dc_rep_id
+mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
+
+
+missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
+missingStrictFields con fields
+  = header <> rest
+  where
+    rest | null fields = Outputable.empty  -- Happens for non-record constructors
+                                           -- with strict fields
+         | otherwise   = colon <+> pprWithCommas ppr fields
+
+    header = text "Constructor" <+> quotes (ppr con) <+>
+             text "does not have the required strict field(s)"
+
+missingFields :: ConLike -> [FieldLabelString] -> SDoc
+missingFields con fields
+  = header <> rest
+  where
+    rest | null fields = Outputable.empty
+         | otherwise = colon <+> pprWithCommas ppr fields
+    header = text "Fields of" <+> quotes (ppr con) <+>
+             text "not initialised"
+
+-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))
+
+noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
+noPossibleParents rbinds
+  = hang (text "No type has all these fields:")
+       2 (pprQuotedList fields)
+  where
+    fields = map (hsRecFieldLbl . unLoc) rbinds
+
+badOverloadedUpdate :: SDoc
+badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"
+
+fieldNotInType :: RecSelParent -> RdrName -> SDoc
+fieldNotInType p rdr
+  = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Static Pointers}
+*                                                                      *
+************************************************************************
+-}
+
+-- | A data type to describe why a variable is not closed.
+data NotClosedReason = NotLetBoundReason
+                     | NotTypeClosed VarSet
+                     | NotClosed Name NotClosedReason
+
+-- | Checks if the given name is closed and emits an error if not.
+--
+-- See Note [Not-closed error messages].
+checkClosedInStaticForm :: Name -> TcM ()
+checkClosedInStaticForm name = do
+    type_env <- getLclTypeEnv
+    case checkClosed type_env name of
+      Nothing -> return ()
+      Just reason -> addErrTc $ explain name reason
+  where
+    -- See Note [Checking closedness].
+    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
+    checkClosed type_env n = checkLoop type_env (unitNameSet n) n
+
+    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
+    checkLoop type_env visited n = do
+      -- The @visited@ set is an accumulating parameter that contains the set of
+      -- visited nodes, so we avoid repeating cycles in the traversal.
+      case lookupNameEnv type_env n of
+        Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
+          ClosedLet   -> Nothing
+          NotLetBound -> Just NotLetBoundReason
+          NonClosedLet fvs type_closed -> listToMaybe $
+            -- Look for a non-closed variable in fvs
+            [ NotClosed n' reason
+            | n' <- nameSetElemsStable fvs
+            , not (elemNameSet n' visited)
+            , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
+            ] ++
+            if type_closed then
+              []
+            else
+              -- We consider non-let-bound variables easier to figure out than
+              -- non-closed types, so we report non-closed types to the user
+              -- only if we cannot spot the former.
+              [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
+        -- The binding is closed.
+        _ -> Nothing
+
+    -- Converts a reason into a human-readable sentence.
+    --
+    -- @explain name reason@ starts with
+    --
+    -- "<name> is used in a static form but it is not closed because it"
+    --
+    -- and then follows a list of causes. For each id in the path, the text
+    --
+    -- "uses <id> which"
+    --
+    -- is appended, yielding something like
+    --
+    -- "uses <id> which uses <id1> which uses <id2> which"
+    --
+    -- until the end of the path is reached, which is reported as either
+    --
+    -- "is not let-bound"
+    --
+    -- when the final node is not let-bound, or
+    --
+    -- "has a non-closed type because it contains the type variables:
+    -- v1, v2, v3"
+    --
+    -- when the final node has a non-closed type.
+    --
+    explain :: Name -> NotClosedReason -> SDoc
+    explain name reason =
+      quotes (ppr name) <+> text "is used in a static form but it is not closed"
+                        <+> text "because it"
+                        $$
+                        sep (causes reason)
+
+    causes :: NotClosedReason -> [SDoc]
+    causes NotLetBoundReason = [text "is not let-bound."]
+    causes (NotTypeClosed vs) =
+      [ text "has a non-closed type because it contains the"
+      , text "type variables:" <+>
+        pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))
+      ]
+    causes (NotClosed n reason) =
+      let msg = text "uses" <+> quotes (ppr n) <+> text "which"
+       in case reason of
+            NotClosed _ _ -> msg : causes reason
+            _   -> let (xs0, xs1) = splitAt 1 $ causes reason
+                    in fmap (msg <+>) xs0 ++ xs1
+
+-- Note [Not-closed error messages]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- When variables in a static form are not closed, we go through the trouble
+-- of explaining why they aren't.
+--
+-- Thus, the following program
+--
+-- > {-# LANGUAGE StaticPointers #-}
+-- > module M where
+-- >
+-- > f x = static g
+-- >   where
+-- >     g = h
+-- >     h = x
+--
+-- produces the error
+--
+--    'g' is used in a static form but it is not closed because it
+--    uses 'h' which uses 'x' which is not let-bound.
+--
+-- And a program like
+--
+-- > {-# LANGUAGE StaticPointers #-}
+-- > module M where
+-- >
+-- > import Data.Typeable
+-- > import GHC.StaticPtr
+-- >
+-- > f :: Typeable a => a -> StaticPtr TypeRep
+-- > f x = const (static (g undefined)) (h x)
+-- >   where
+-- >     g = h
+-- >     h = typeOf
+--
+-- produces the error
+--
+--    'g' is used in a static form but it is not closed because it
+--    uses 'h' which has a non-closed type because it contains the
+--    type variables: 'a'
+--
+
+-- Note [Checking closedness]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- @checkClosed@ checks if a binding is closed and returns a reason if it is
+-- not.
+--
+-- The bindings define a graph where the nodes are ids, and there is an edge
+-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
+-- variables.
+--
+-- When @n@ is not closed, it has to exist in the graph some node reachable
+-- from @n@ that it is not a let-bound variable or that it has a non-closed
+-- type. Thus, the "reason" is a path from @n@ to this offending node.
+--
+-- When @n@ is not closed, we traverse the graph reachable from @n@ to build
+-- the reason.
+--
diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcExpr.hs-boot
@@ -0,0 +1,41 @@
+module TcExpr where
+import Name
+import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )
+import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )
+import TcRnTypes( TcM, CtOrigin )
+import HsExtension ( GhcRn, GhcTcId )
+
+tcPolyExpr ::
+          LHsExpr GhcRn
+       -> TcSigmaType
+       -> TcM (LHsExpr GhcTcId)
+
+tcMonoExpr, tcMonoExprNC ::
+          LHsExpr GhcRn
+       -> ExpRhoType
+       -> TcM (LHsExpr GhcTcId)
+
+tcInferSigma, tcInferSigmaNC ::
+          LHsExpr GhcRn
+       -> TcM (LHsExpr GhcTcId, TcSigmaType)
+
+tcInferRho ::
+          LHsExpr GhcRn
+       -> TcM (LHsExpr GhcTcId, TcRhoType)
+
+tcSyntaxOp :: CtOrigin
+           -> SyntaxExpr GhcRn
+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
+           -> ExpType                  -- ^ overall result type
+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
+           -> TcM (a, SyntaxExpr GhcTcId)
+
+tcSyntaxOpGen :: CtOrigin
+              -> SyntaxExpr GhcRn
+              -> [SyntaxOpType]
+              -> SyntaxOpType
+              -> ([TcSigmaType] -> TcM a)
+              -> TcM (a, SyntaxExpr GhcTcId)
+
+
+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcFlatten.hs
@@ -0,0 +1,1879 @@
+{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-}
+
+module TcFlatten(
+   FlattenMode(..),
+   flatten, flattenKind, flattenArgsNom,
+
+   unflattenWanteds
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import TcType
+import Type
+import TcEvidence
+import TyCon
+import TyCoRep   -- performs delicate algorithm on types
+import Coercion
+import Var
+import VarSet
+import VarEnv
+import Outputable
+import TcSMonad as TcS
+import BasicTypes( SwapFlag(..) )
+
+import Util
+import Bag
+import Control.Monad
+import MonadUtils    ( zipWith3M )
+
+import Control.Arrow ( first )
+
+{-
+Note [The flattening story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* A CFunEqCan is either of form
+     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkolTv
+     [W]       x : F xis ~ fmv   -- fmv is a FlatMetaTv
+  where
+     x is the witness variable
+     xis are function-free
+     fsk/fmv is a flatten skolem;
+        it is always untouchable (level 0)
+
+* CFunEqCans can have any flavour: [G], [W], [WD] or [D]
+
+* KEY INSIGHTS:
+
+   - A given flatten-skolem, fsk, is known a-priori to be equal to
+     F xis (the LHS), with <F xis> evidence.  The fsk is still a
+     unification variable, but it is "owned" by its CFunEqCan, and
+     is filled in (unflattened) only by unflattenGivens.
+
+   - A unification flatten-skolem, fmv, stands for the as-yet-unknown
+     type to which (F xis) will eventually reduce.  It is filled in
+
+
+   - All fsk/fmv variables are "untouchable".  To make it simple to test,
+     we simply give them TcLevel=0.  This means that in a CTyVarEq, say,
+       fmv ~ Int
+     we NEVER unify fmv.
+
+   - A unification flatten-skolem, fmv, ONLY gets unified when either
+       a) The CFunEqCan takes a step, using an axiom
+       b) By unflattenWanteds
+    They are never unified in any other form of equality.
+    For example [W] ffmv ~ Int  is stuck; it does not unify with fmv.
+
+* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.
+  That would destroy the invariant about the shape of a CFunEqCan,
+  and it would risk wanted/wanted interactions. The only way we
+  learn information about fsk is when the CFunEqCan takes a step.
+
+  However we *do* substitute in the LHS of a CFunEqCan (else it
+  would never get to fire!)
+
+* Unflattening:
+   - We unflatten Givens when leaving their scope (see unflattenGivens)
+   - We unflatten Wanteds at the end of each attempt to simplify the
+     wanteds; see unflattenWanteds, called from solveSimpleWanteds.
+
+* Ownership of fsk/fmv.  Each canonical [G], [W], or [WD]
+       CFunEqCan x : F xis ~ fsk/fmv
+  "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.
+  Why? We make a fresh fsk/fmv when the constraint is born;
+  and we never rewrite the RHS of a CFunEqCan.
+
+  In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],
+  but does not "own" it.  If we reduce a [D] F Int ~ fmv, where
+  say type instance F Int = ty, then we don't discharge fmv := ty.
+  Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq,
+  and dischargeFmv)
+
+* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
+                       then xis1 /= xis2
+  i.e. at most one CFunEqCan with a particular LHS
+
+* Function applications can occur in the RHS of a CTyEqCan.  No reason
+  not allow this, and it reduces the amount of flattening that must occur.
+
+* Flattening a type (F xis):
+    - If we are flattening in a Wanted/Derived constraint
+      then create new [W] x : F xis ~ fmv
+      else create new [G] x : F xis ~ fsk
+      with fresh evidence variable x and flatten-skolem fsk/fmv
+
+    - Add it to the work list
+
+    - Replace (F xis) with fsk/fmv in the type you are flattening
+
+    - You can also add the CFunEqCan to the "flat cache", which
+      simply keeps track of all the function applications you
+      have flattened.
+
+    - If (F xis) is in the cache already, just
+      use its fsk/fmv and evidence x, and emit nothing.
+
+    - No need to substitute in the flat-cache. It's not the end
+      of the world if we start with, say (F alpha ~ fmv1) and
+      (F Int ~ fmv2) and then find alpha := Int.  Athat will
+      simply give rise to fmv1 := fmv2 via [Interacting rule] below
+
+* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv
+    - Flatten xis (to substitute any tyvars; there are already no functions)
+                  cos :: xis ~ flat_xis
+    - New wanted  x2 :: F flat_xis ~ fsk/fmv
+    - Add new wanted to flat cache
+    - Discharge x = F cos ; x2
+
+* [Interacting rule]
+    (inert)     [W] x1 : F tys ~ fmv1
+    (work item) [W] x2 : F tys ~ fmv2
+  Just solve one from the other:
+    x2 := x1
+    fmv2 := fmv1
+  This just unites the two fsks into one.
+  Always solve given from wanted if poss.
+
+* For top-level reductions, see Note [Top-level reductions for type functions]
+  in TcInteract
+
+
+Why given-fsks, alone, doesn't work
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.
+
+  [W] w : alpha ~ [F alpha Int]
+
+---> flatten
+  w = ...w'...
+  [W] w' : alpha ~ [fsk]
+  [G] <F alpha Int> : F alpha Int ~ fsk
+
+--> unify (no occurs check)
+  alpha := [fsk]
+
+But since fsk = F alpha Int, this is really an occurs check error.  If
+that is all we know about alpha, we will succeed in constraint
+solving, producing a program with an infinite type.
+
+Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)
+using axiom, zonking would not see it, so (x::alpha) sitting in the
+tree will get zonked to an infinite type.  (Zonking always only does
+refl stuff.)
+
+Why flatten-meta-vars, alone doesn't work
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look at Simple13, with unification-fmvs only
+
+  [G] g : a ~ [F a]
+
+---> Flatten given
+  g' = g;[x]
+  [G] g'  : a ~ [fmv]
+  [W] x : F a ~ fmv
+
+--> subst a in x
+  g' = g;[x]
+  x = F g' ; x2
+  [W] x2 : F [fmv] ~ fmv
+
+And now we have an evidence cycle between g' and x!
+
+If we used a given instead (ie current story)
+
+  [G] g : a ~ [F a]
+
+---> Flatten given
+  g' = g;[x]
+  [G] g'  : a ~ [fsk]
+  [G] <F a> : F a ~ fsk
+
+---> Substitute for a
+  [G] g'  : a ~ [fsk]
+  [G] F (sym g'); <F a> : F [fsk] ~ fsk
+
+
+Why is it right to treat fmv's differently to ordinary unification vars?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  f :: forall a. a -> a -> Bool
+  g :: F Int -> F Int -> Bool
+
+Consider
+  f (x:Int) (y:Bool)
+This gives alpha~Int, alpha~Bool.  There is an inconsistency,
+but really only one error.  SherLoc may tell you which location
+is most likely, based on other occurrences of alpha.
+
+Consider
+  g (x:Int) (y:Bool)
+Here we get (F Int ~ Int, F Int ~ Bool), which flattens to
+  (fmv ~ Int, fmv ~ Bool)
+But there are really TWO separate errors.
+
+  ** We must not complain about Int~Bool. **
+
+Moreover these two errors could arise in entirely unrelated parts of
+the code.  (In the alpha case, there must be *some* connection (eg
+v:alpha in common envt).)
+
+Note [Unflattening can force the solver to iterate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look at #10340:
+   type family Any :: *   -- No instances
+   get :: MonadState s m => m s
+   instance MonadState s (State s) where ...
+
+   foo :: State Any Any
+   foo = get
+
+For 'foo' we instantiate 'get' at types mm ss
+   [WD] MonadState ss mm, [WD] mm ss ~ State Any Any
+Flatten, and decompose
+   [WD] MonadState ss mm, [WD] Any ~ fmv
+   [WD] mm ~ State fmv, [WD] fmv ~ ss
+Unify mm := State fmv:
+   [WD] MonadState ss (State fmv)
+   [WD] Any ~ fmv, [WD] fmv ~ ss
+Now we are stuck; the instance does not match!!  So unflatten:
+   fmv := Any
+   ss := Any    (*)
+   [WD] MonadState Any (State Any)
+
+The unification (*) represents progress, so we must do a second
+round of solving; this time it succeeds. This is done by the 'go'
+loop in solveSimpleWanteds.
+
+This story does not feel right but it's the best I can do; and the
+iteration only happens in pretty obscure circumstances.
+
+
+************************************************************************
+*                                                                      *
+*                  Examples
+     Here is a long series of examples I had to work through
+*                                                                      *
+************************************************************************
+
+Simple20
+~~~~~~~~
+axiom F [a] = [F a]
+
+ [G] F [a] ~ a
+-->
+ [G] fsk ~ a
+ [G] [F a] ~ fsk  (nc)
+-->
+ [G] F a ~ fsk2
+ [G] fsk ~ [fsk2]
+ [G] fsk ~ a
+-->
+ [G] F a ~ fsk2
+ [G] a ~ [fsk2]
+ [G] fsk ~ a
+
+----------------------------------------
+indexed-types/should_compile/T44984
+
+  [W] H (F Bool) ~ H alpha
+  [W] alpha ~ F Bool
+-->
+  F Bool  ~ fmv0
+  H fmv0  ~ fmv1
+  H alpha ~ fmv2
+
+  fmv1 ~ fmv2
+  fmv0 ~ alpha
+
+flatten
+~~~~~~~
+  fmv0  := F Bool
+  fmv1  := H (F Bool)
+  fmv2  := H alpha
+  alpha := F Bool
+plus
+  fmv1 ~ fmv2
+
+But these two are equal under the above assumptions.
+Solve by Refl.
+
+
+--- under plan B, namely solve fmv1:=fmv2 eagerly ---
+  [W] H (F Bool) ~ H alpha
+  [W] alpha ~ F Bool
+-->
+  F Bool  ~ fmv0
+  H fmv0  ~ fmv1
+  H alpha ~ fmv2
+
+  fmv1 ~ fmv2
+  fmv0 ~ alpha
+-->
+  F Bool  ~ fmv0
+  H fmv0  ~ fmv1
+  H alpha ~ fmv2    fmv2 := fmv1
+
+  fmv0 ~ alpha
+
+flatten
+  fmv0 := F Bool
+  fmv1 := H fmv0 = H (F Bool)
+  retain   H alpha ~ fmv2
+    because fmv2 has been filled
+  alpha := F Bool
+
+
+----------------------------
+indexed-types/should_failt/T4179
+
+after solving
+  [W] fmv_1 ~ fmv_2
+  [W] A3 (FCon x)           ~ fmv_1    (CFunEqCan)
+  [W] A3 (x (aoa -> fmv_2)) ~ fmv_2    (CFunEqCan)
+
+----------------------------------------
+indexed-types/should_fail/T7729a
+
+a)  [W]   BasePrimMonad (Rand m) ~ m1
+b)  [W]   tt m1 ~ BasePrimMonad (Rand m)
+
+--->  process (b) first
+    BasePrimMonad (Ramd m) ~ fmv_atH
+    fmv_atH ~ tt m1
+
+--->  now process (a)
+    m1 ~ s_atH ~ tt m1    -- An obscure occurs check
+
+
+----------------------------------------
+typecheck/TcTypeNatSimple
+
+Original constraint
+  [W] x + y ~ x + alpha  (non-canonical)
+==>
+  [W] x + y     ~ fmv1   (CFunEqCan)
+  [W] x + alpha ~ fmv2   (CFuneqCan)
+  [W] fmv1 ~ fmv2        (CTyEqCan)
+
+(sigh)
+
+----------------------------------------
+indexed-types/should_fail/GADTwrong1
+
+  [G] Const a ~ ()
+==> flatten
+  [G] fsk ~ ()
+  work item: Const a ~ fsk
+==> fire top rule
+  [G] fsk ~ ()
+  work item fsk ~ ()
+
+Surely the work item should rewrite to () ~ ()?  Well, maybe not;
+it'a very special case.  More generally, our givens look like
+F a ~ Int, where (F a) is not reducible.
+
+
+----------------------------------------
+indexed_types/should_fail/T8227:
+
+Why using a different can-rewrite rule in CFunEqCan heads
+does not work.
+
+Assuming NOT rewriting wanteds with wanteds
+
+   Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk
+          [W] fmv_aBk ~ fsk_aBh
+
+          [G] Scalar fsk_aBg ~ fsk_aBh
+          [G] V a ~ f_aBg
+
+   Worklist includes  [W] Scalar fmv_aBi ~ fmv_aBk
+   fmv_aBi, fmv_aBk are flatten unification variables
+
+   Work item: [W] V fsk_aBh ~ fmv_aBi
+
+Note that the inert wanteds are cyclic, because we do not rewrite
+wanteds with wanteds.
+
+
+Then we go into a loop when normalise the work-item, because we
+use rewriteOrSame on the argument of V.
+
+Conclusion: Don't make canRewrite context specific; instead use
+[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.
+
+
+----------------------------------------
+
+Here is a somewhat similar case:
+
+   type family G a :: *
+
+   blah :: (G a ~ Bool, Eq (G a)) => a -> a
+   blah = error "urk"
+
+   foo x = blah x
+
+For foo we get
+   [W] Eq (G a), G a ~ Bool
+Flattening
+   [W] G a ~ fmv, Eq fmv, fmv ~ Bool
+We can't simplify away the Eq Bool unless we substitute for fmv.
+Maybe that doesn't matter: we would still be left with unsolved
+G a ~ Bool.
+
+--------------------------
+#9318 has a very simple program leading to
+
+  [W] F Int ~ Int
+  [W] F Int ~ Bool
+
+We don't want to get "Error Int~Bool".  But if fmv's can rewrite
+wanteds, we will
+
+  [W] fmv ~ Int
+  [W] fmv ~ Bool
+--->
+  [W] Int ~ Bool
+
+
+************************************************************************
+*                                                                      *
+*                FlattenEnv & FlatM
+*             The flattening environment & monad
+*                                                                      *
+************************************************************************
+
+-}
+
+type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]
+
+data FlattenEnv
+  = FE { fe_mode    :: !FlattenMode
+       , fe_loc     :: !CtLoc             -- See Note [Flattener CtLoc]
+       , fe_flavour :: !CtFlavour
+       , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]
+       , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]
+
+data FlattenMode  -- Postcondition for all three: inert wrt the type substitution
+  = FM_FlattenAll          -- Postcondition: function-free
+  | FM_SubstOnly           -- See Note [Flattening under a forall]
+
+--  | FM_Avoid TcTyVar Bool  -- See Note [Lazy flattening]
+--                           -- Postcondition:
+--                           --  * tyvar is only mentioned in result under a rigid path
+--                           --    e.g.   [a] is ok, but F a won't happen
+--                           --  * If flat_top is True, top level is not a function application
+--                           --   (but under type constructors is ok e.g. [F a])
+
+instance Outputable FlattenMode where
+  ppr FM_FlattenAll = text "FM_FlattenAll"
+  ppr FM_SubstOnly  = text "FM_SubstOnly"
+
+eqFlattenMode :: FlattenMode -> FlattenMode -> Bool
+eqFlattenMode FM_FlattenAll FM_FlattenAll = True
+eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True
+--  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2
+eqFlattenMode _  _ = False
+
+-- | The 'FlatM' monad is a wrapper around 'TcS' with the following
+-- extra capabilities: (1) it offers access to a 'FlattenEnv';
+-- and (2) it maintains the flattening worklist.
+-- See Note [The flattening work list].
+newtype FlatM a
+  = FlatM { runFlatM :: FlattenEnv -> TcS a }
+
+instance Monad FlatM where
+  m >>= k  = FlatM $ \env ->
+             do { a  <- runFlatM m env
+                ; runFlatM (k a) env }
+
+instance Functor FlatM where
+  fmap = liftM
+
+instance Applicative FlatM where
+  pure x = FlatM $ const (pure x)
+  (<*>) = ap
+
+liftTcS :: TcS a -> FlatM a
+liftTcS thing_inside
+  = FlatM $ const thing_inside
+
+emitFlatWork :: Ct -> FlatM ()
+-- See Note [The flattening work list]
+emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)
+
+-- convenient wrapper when you have a CtEvidence describing
+-- the flattening operation
+runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
+runFlattenCtEv mode ev
+  = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
+
+-- Run thing_inside (which does flattening), and put all
+-- the work it generates onto the main work list
+-- See Note [The flattening work list]
+runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
+runFlatten mode loc flav eq_rel thing_inside
+  = do { flat_ref <- newTcRef []
+       ; let fmode = FE { fe_mode = mode
+                        , fe_loc  = loc
+                        , fe_flavour = flav
+                        , fe_eq_rel = eq_rel
+                        , fe_work = flat_ref }
+       ; res <- runFlatM thing_inside fmode
+       ; new_flats <- readTcRef flat_ref
+       ; updWorkListTcS (add_flats new_flats)
+       ; return res }
+  where
+    add_flats new_flats wl
+      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }
+
+    add_funeqs []     wl = wl
+    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)
+      -- add_funeqs fs ws = reverse fs ++ ws
+      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]
+      --        = [f3,f2,f1,w1,w2,w3,w4]
+
+traceFlat :: String -> SDoc -> FlatM ()
+traceFlat herald doc = liftTcS $ traceTcS herald doc
+
+getFlatEnvField :: (FlattenEnv -> a) -> FlatM a
+getFlatEnvField accessor
+  = FlatM $ \env -> return (accessor env)
+
+getEqRel :: FlatM EqRel
+getEqRel = getFlatEnvField fe_eq_rel
+
+getRole :: FlatM Role
+getRole = eqRelRole <$> getEqRel
+
+getFlavour :: FlatM CtFlavour
+getFlavour = getFlatEnvField fe_flavour
+
+getFlavourRole :: FlatM CtFlavourRole
+getFlavourRole
+  = do { flavour <- getFlavour
+       ; eq_rel <- getEqRel
+       ; return (flavour, eq_rel) }
+
+getMode :: FlatM FlattenMode
+getMode = getFlatEnvField fe_mode
+
+getLoc :: FlatM CtLoc
+getLoc = getFlatEnvField fe_loc
+
+checkStackDepth :: Type -> FlatM ()
+checkStackDepth ty
+  = do { loc <- getLoc
+       ; liftTcS $ checkReductionDepth loc ty }
+
+-- | Change the 'EqRel' in a 'FlatM'.
+setEqRel :: EqRel -> FlatM a -> FlatM a
+setEqRel new_eq_rel thing_inside
+  = FlatM $ \env ->
+    if new_eq_rel == fe_eq_rel env
+    then runFlatM thing_inside env
+    else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })
+
+-- | Change the 'FlattenMode' in a 'FlattenEnv'.
+setMode :: FlattenMode -> FlatM a -> FlatM a
+setMode new_mode thing_inside
+  = FlatM $ \env ->
+    if new_mode `eqFlattenMode` fe_mode env
+    then runFlatM thing_inside env
+    else runFlatM thing_inside (env { fe_mode = new_mode })
+
+-- | Make sure that flattening actually produces a coercion (in other
+-- words, make sure our flavour is not Derived)
+-- Note [No derived kind equalities]
+noBogusCoercions :: FlatM a -> FlatM a
+noBogusCoercions thing_inside
+  = FlatM $ \env ->
+    -- No new thunk is made if the flavour hasn't changed (note the bang).
+    let !env' = case fe_flavour env of
+          Derived -> env { fe_flavour = Wanted WDeriv }
+          _       -> env
+    in
+    runFlatM thing_inside env'
+
+bumpDepth :: FlatM a -> FlatM a
+bumpDepth (FlatM thing_inside)
+  = FlatM $ \env -> do
+      -- bumpDepth can be called a lot during flattening so we force the
+      -- new env to avoid accumulating thunks.
+      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }
+      ; thing_inside env' }
+
+{-
+Note [The flattening work list]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The "flattening work list", held in the fe_work field of FlattenEnv,
+is a list of CFunEqCans generated during flattening.  The key idea
+is this.  Consider flattening (Eq (F (G Int) (H Bool)):
+  * The flattener recursively calls itself on sub-terms before building
+    the main term, so it will encounter the terms in order
+              G Int
+              H Bool
+              F (G Int) (H Bool)
+    flattening to sub-goals
+              w1: G Int ~ fuv0
+              w2: H Bool ~ fuv1
+              w3: F fuv0 fuv1 ~ fuv2
+
+  * Processing w3 first is BAD, because we can't reduce i t,so it'll
+    get put into the inert set, and later kicked out when w1, w2 are
+    solved.  In #9872 this led to inert sets containing hundreds
+    of suspended calls.
+
+  * So we want to process w1, w2 first.
+
+  * So you might think that we should just use a FIFO deque for the work-list,
+    so that putting adding goals in order w1,w2,w3 would mean we processed
+    w1 first.
+
+  * BUT suppose we have 'type instance G Int = H Char'.  Then processing
+    w1 leads to a new goal
+                w4: H Char ~ fuv0
+    We do NOT want to put that on the far end of a deque!  Instead we want
+    to put it at the *front* of the work-list so that we continue to work
+    on it.
+
+So the work-list structure is this:
+
+  * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on
+    top (extendWorkListFunEq), and take new work from the top
+    (selectWorkItem).
+
+  * When flattening, emitFlatWork pushes new flattening goals (like
+    w1,w2,w3) onto the flattening work list, fe_work, another
+    push-down stack.
+
+  * When we finish flattening, we *reverse* the fe_work stack
+    onto the wl_funeqs stack (which brings w1 to the top).
+
+The function runFlatten initialises the fe_work stack, and reverses
+it onto wl_fun_eqs at the end.
+
+Note [Flattener EqRels]
+~~~~~~~~~~~~~~~~~~~~~~~
+When flattening, we need to know which equality relation -- nominal
+or representation -- we should be respecting. The only difference is
+that we rewrite variables by representational equalities when fe_eq_rel
+is ReprEq, and that we unwrap newtypes when flattening w.r.t.
+representational equality.
+
+Note [Flattener CtLoc]
+~~~~~~~~~~~~~~~~~~~~~~
+The flattener does eager type-family reduction.
+Type families might loop, and we
+don't want GHC to do so. A natural solution is to have a bounded depth
+to these processes. A central difficulty is that such a solution isn't
+quite compositional. For example, say it takes F Int 10 steps to get to Bool.
+How many steps does it take to get from F Int -> F Int to Bool -> Bool?
+10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to
+know and hard to track. So, we punt, essentially. We store a CtLoc in
+the FlattenEnv and just update the environment when recurring. In the
+TyConApp case, where there may be multiple type families to flatten,
+we just copy the current CtLoc into each branch. If any branch hits the
+stack limit, then the whole thing fails.
+
+A consequence of this is that setting the stack limits appropriately
+will be essentially impossible. So, the official recommendation if a
+stack limit is hit is to disable the check entirely. Otherwise, there
+will be baffling, unpredictable errors.
+
+Note [Lazy flattening]
+~~~~~~~~~~~~~~~~~~~~~~
+The idea of FM_Avoid mode is to flatten less aggressively.  If we have
+       a ~ [F Int]
+there seems to be no great merit in lifting out (F Int).  But if it was
+       a ~ [G a Int]
+then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,
+which gets rid of the occurs-check problem.  (For the flat_top Bool, see
+comments above and at call sites.)
+
+HOWEVER, the lazy flattening actually seems to make type inference go
+*slower*, not faster.  perf/compiler/T3064 is a case in point; it gets
+*dramatically* worse with FM_Avoid.  I think it may be because
+floating the types out means we normalise them, and that often makes
+them smaller and perhaps allows more re-use of previously solved
+goals.  But to be honest I'm not absolutely certain, so I am leaving
+FM_Avoid in the code base.  What I'm removing is the unique place
+where it is *used*, namely in TcCanonical.canEqTyVar.
+
+See also Note [Conservative unification check] in TcUnify, which gives
+other examples where lazy flattening caused problems.
+
+Bottom line: FM_Avoid is unused for now (Nov 14).
+Note: T5321Fun got faster when I disabled FM_Avoid
+      T5837 did too, but it's pathalogical anyway
+
+Note [Phantoms in the flattener]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+data Proxy p = Proxy
+
+and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`
+is really irrelevant -- it will be ignored when solving for representational
+equality later on. So, we omit flattening `ty` entirely. This may
+violate the expectation of "xi"s for a bit, but the canonicaliser will
+soon throw out the phantoms when decomposing a TyConApp. (Or, the
+canonicaliser will emit an insoluble, in which case the unflattened version
+yields a better error message anyway.)
+
+Note [No derived kind equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A kind-level coercion can appear in types, via mkCastTy. So, whenever
+we are generating a coercion in a dependent context (in other words,
+in a kind) we need to make sure that our flavour is never Derived
+(as Derived constraints have no evidence). The noBogusCoercions function
+changes the flavour from Derived just for this purpose.
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+*      Externally callable flattening functions                        *
+*                                                                      *
+*  They are all wrapped in runFlatten, so their                        *
+*  flattening work gets put into the work list                         *
+*                                                                      *
+********************************************************************* -}
+
+flatten :: FlattenMode -> CtEvidence -> TcType
+        -> TcS (Xi, TcCoercion)
+flatten mode ev ty
+  = do { traceTcS "flatten {" (ppr mode <+> ppr ty)
+       ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)
+       ; traceTcS "flatten }" (ppr ty')
+       ; return (ty', co) }
+
+-- specialized to flattening kinds: never Derived, always Nominal
+-- See Note [No derived kind equalities]
+flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)
+flattenKind loc flav ty
+  = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)
+       ; let flav' = case flav of
+                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not
+                       _       -> flav
+       ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)
+       ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic
+       ; return (ty', co) }
+
+flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)
+-- Externally-callable, hence runFlatten
+-- Flatten a vector of types all at once; in fact they are
+-- always the arguments of type family or class, so
+--      ctEvFlavour ev = Nominal
+-- and we want to flatten all at nominal role
+-- The kind passed in is the kind of the type family or class, call it T
+-- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys))
+--
+-- For Derived constraints the returned coercion may be undefined
+-- because flattening may use a Derived equality ([D] a ~ ty)
+flattenArgsNom ev tc tys
+  = do { traceTcS "flatten_args {" (vcat (map ppr tys))
+       ; (tys', cos, kind_co)
+           <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)
+       ; traceTcS "flatten }" (vcat (map ppr tys'))
+       ; return (tys', cos, kind_co) }
+
+
+{- *********************************************************************
+*                                                                      *
+*           The main flattening functions
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Flattening]
+~~~~~~~~~~~~~~~~~~~~
+  flatten ty  ==>   (xi, co)
+    where
+      xi has no type functions, unless they appear under ForAlls
+         has no skolems that are mapped in the inert set
+         has no filled-in metavariables
+      co :: xi ~ ty
+
+Key invariants:
+  (F0) co :: xi ~ zonk(ty)
+  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind
+  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))
+
+Note that it is flatten's job to flatten *every type function it sees*.
+flatten is only called on *arguments* to type functions, by canEqGiven.
+
+Flattening also:
+  * zonks, removing any metavariables, and
+  * applies the substitution embodied in the inert set
+
+Because flattening zonks and the returned coercion ("co" above) is also
+zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,
+we can rely on this fact:
+
+  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind
+
+Note that the left-hand type of co is *always* precisely xi. The right-hand
+type may or may not be ty, however: if ty has unzonked filled-in metavariables,
+then the right-hand type of co will be the zonked version of ty.
+It is for this reason that we
+occasionally have to explicitly zonk, when (co :: xi ~ ty) is important
+even before we zonk the whole program. For example, see the FTRNotFollowed
+case in flattenTyVar.
+
+Why have these invariants on flattening? Because we sometimes use tcTypeKind
+during canonicalisation, and we want this kind to be zonked (e.g., see
+TcCanonical.canEqTyVar).
+
+Flattening is always homogeneous. That is, the kind of the result of flattening is
+always the same as the kind of the input, modulo zonking. More formally:
+
+  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))
+
+This invariant means that the kind of a flattened type might not itself be flat.
+
+Recall that in comments we use alpha[flat = ty] to represent a
+flattening skolem variable alpha which has been generated to stand in
+for ty.
+
+----- Example of flattening a constraint: ------
+  flatten (List (F (G Int)))  ==>  (xi, cc)
+    where
+      xi  = List alpha
+      cc  = { G Int ~ beta[flat = G Int],
+              F beta ~ alpha[flat = F beta] }
+Here
+  * alpha and beta are 'flattening skolem variables'.
+  * All the constraints in cc are 'given', and all their coercion terms
+    are the identity.
+
+NB: Flattening Skolems only occur in canonical constraints, which
+are never zonked, so we don't need to worry about zonking doing
+accidental unflattening.
+
+Note that we prefer to leave type synonyms unexpanded when possible,
+so when the flattener encounters one, it first asks whether its
+transitive expansion contains any type function applications.  If so,
+it expands the synonym and proceeds; if not, it simply returns the
+unexpanded synonym.
+
+Note [flatten_args performance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In programs with lots of type-level evaluation, flatten_args becomes
+part of a tight loop. For example, see test perf/compiler/T9872a, which
+calls flatten_args a whopping 7,106,808 times. It is thus important
+that flatten_args be efficient.
+
+Performance testing showed that the current implementation is indeed
+efficient. It's critically important that zipWithAndUnzipM be
+specialized to TcS, and it's also quite helpful to actually `inline`
+it. On test T9872a, here are the allocation stats (Dec 16, 2014):
+
+ * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap
+ * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap
+ * Specialized, inlined:         6,281,539,792 bytes allocated in the heap
+
+To improve performance even further, flatten_args_nom is split off
+from flatten_args, as nominal equality is the common case. This would
+be natural to write using mapAndUnzipM, but even inlined, that function
+is not as performant as a hand-written loop.
+
+ * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap
+ * hand-written recursion:       5,848,602,848 bytes allocated in the heap
+
+If you make any change here, pay close attention to the T9872{a,b,c} tests
+and T5321Fun.
+
+If we need to make this yet more performant, a possible way forward is to
+duplicate the flattener code for the nominal case, and make that case
+faster. This doesn't seem quite worth it, yet.
+
+Note [flatten_exact_fam_app_fully performance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and #15192 for the current state.
+
+The explicit pattern match in homogenise_result helps with T9872a, b, c.
+
+Still, it increases the expected allocation of T9872d by ~2%.
+
+TODO: a step-by-step replay of the refactor to analyze the performance.
+
+-}
+
+{-# INLINE flatten_args_tc #-}
+flatten_args_tc
+  :: TyCon         -- T
+  -> [Role]        -- Role r
+  -> [Type]        -- Arg types [t1,..,tn]
+  -> FlatM ( [Xi]  -- List of flattened args [x1,..,xn]
+                   -- 1-1 corresp with [t1,..,tn]
+           , [Coercion]  -- List of arg coercions [co1,..,con]
+                         -- 1-1 corresp with [t1,..,tn]
+                         --    coi :: xi ~r ti
+           , CoercionN)  -- Result coercion, rco
+                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))
+flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
+  -- NB: TyCon kinds are always closed
+  where
+    (bndrs, named)
+      = ty_con_binders_ty_binders' (tyConBinders tc)
+    -- it's possible that the result kind has arrows (for, e.g., a type family)
+    -- so we must split it
+    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)
+    !all_bndrs                           = bndrs `chkAppend` inner_bndrs
+    !any_named_bndrs                     = named || inner_named
+    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.
+
+{-# INLINE flatten_args #-}
+flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
+                                     -- named.
+             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars
+             -> [Role] -> [Type]     -- these are in 1-to-1 correspondence
+             -> FlatM ([Xi], [Coercion], CoercionN)
+-- Coercions :: Xi ~ Type, at roles given
+-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)
+-- That is, the third coercion relates the kind of some function (whose kind is
+-- passed as the first parameter) instantiated at xis to the kind of that
+-- function instantiated at the tys. This is useful in keeping flattening
+-- homoegeneous. The list of roles must be at least as long as the list of
+-- types.
+flatten_args orig_binders
+             any_named_bndrs
+             orig_inner_ki
+             orig_fvs
+             orig_roles
+             orig_tys
+  = if any_named_bndrs
+    then flatten_args_slow orig_binders
+                           orig_inner_ki
+                           orig_fvs
+                           orig_roles
+                           orig_tys
+    else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+
+{-# INLINE flatten_args_fast #-}
+-- | fast path flatten_args, in which none of the binders are named and
+-- therefore we can avoid tracking a lifting context.
+-- There are many bang patterns in here. It's been observed that they
+-- greatly improve performance of an optimized build.
+-- The T9872 test cases are good witnesses of this fact.
+flatten_args_fast :: [TyCoBinder]
+                  -> Kind
+                  -> [Role]
+                  -> [Type]
+                  -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+  = fmap finish (iterate orig_tys orig_roles orig_binders)
+  where
+
+    iterate :: [Type]
+            -> [Role]
+            -> [TyCoBinder]
+            -> FlatM ([Xi], [Coercion], [TyCoBinder])
+    iterate (ty:tys) (role:roles) (_:binders) = do
+      (xi, co) <- go role ty
+      (xis, cos, binders) <- iterate tys roles binders
+      pure (xi : xis, co : cos, binders)
+    iterate [] _ binders = pure ([], [], binders)
+    iterate _ _ _ = pprPanic
+        "flatten_args wandered into deeper water than usual" (vcat [])
+           -- This debug information is commented out because leaving it in
+           -- causes a ~2% increase in allocations in T9872{a,c,d}.
+           {-
+             (vcat [ppr orig_binders,
+                    ppr orig_inner_ki,
+                    ppr (take 10 orig_roles), -- often infinite!
+                    ppr orig_tys])
+           -}
+
+    {-# INLINE go #-}
+    go :: Role
+       -> Type
+       -> FlatM (Xi, Coercion)
+    go role ty
+      = case role of
+          -- In the slow path we bind the Xi and Coercion from the recursive
+          -- call and then use it such
+          --
+          --   let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)
+          --       casted_xi = xi `mkCastTy` kind_co
+          --       casted_co = xi |> kind_co ~r xi ; co
+          --
+          -- but this isn't necessary:
+          --   mkTcSymCo (Refl a b) = Refl a b,
+          --   mkCastTy x (Refl _ _) = x
+          --   mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co
+          --
+          -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since
+          -- we've already established that they're all anonymous.
+          Nominal          -> setEqRel NomEq  $ flatten_one ty
+          Representational -> setEqRel ReprEq $ flatten_one ty
+          Phantom          -> -- See Note [Phantoms in the flattener]
+                              do { ty <- liftTcS $ zonkTcType ty
+                                 ; return (ty, mkReflCo Phantom ty) }
+
+
+    {-# INLINE finish #-}
+    finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)
+    finish (xis, cos, binders) = (xis, cos, kind_co)
+      where
+        final_kind = mkPiTys binders orig_inner_ki
+        kind_co    = mkNomReflCo final_kind
+
+{-# INLINE flatten_args_slow #-}
+-- | Slow path, compared to flatten_args_fast, because this one must track
+-- a lifting context.
+flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
+                  -> [Role] -> [Type]
+                  -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_args_slow binders inner_ki fvs roles tys
+-- Arguments used dependently must be flattened with proper coercions, but
+-- we're not guaranteed to get a proper coercion when flattening with the
+-- "Derived" flavour. So we must call noBogusCoercions when flattening arguments
+-- corresponding to binders that are dependent. However, we might legitimately
+-- have *more* arguments than binders, in the case that the inner_ki is a variable
+-- that gets instantiated with a Π-type. We conservatively choose not to produce
+-- bogus coercions for these, too. Note that this might miss an opportunity for
+-- a Derived rewriting a Derived. The solution would be to generate evidence for
+-- Deriveds, thus avoiding this whole noBogusCoercions idea. See also
+-- Note [No derived kind equalities]
+  = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)
+                                        roles tys
+       ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) }
+  where
+    {-# INLINE fl #-}
+    fl :: Bool   -- must we ensure to produce a real coercion here?
+                  -- see comment at top of function
+       -> Role -> Type -> FlatM (Xi, Coercion)
+    fl True  r ty = noBogusCoercions $ fl1 r ty
+    fl False r ty =                    fl1 r ty
+
+    {-# INLINE fl1 #-}
+    fl1 :: Role -> Type -> FlatM (Xi, Coercion)
+    fl1 Nominal ty
+      = setEqRel NomEq $
+        flatten_one ty
+
+    fl1 Representational ty
+      = setEqRel ReprEq $
+        flatten_one ty
+
+    fl1 Phantom ty
+    -- See Note [Phantoms in the flattener]
+      = do { ty <- liftTcS $ zonkTcType ty
+           ; return (ty, mkReflCo Phantom ty) }
+
+------------------
+flatten_one :: TcType -> FlatM (Xi, Coercion)
+-- Flatten a type to get rid of type function applications, returning
+-- the new type-function-free type, and a collection of new equality
+-- constraints.  See Note [Flattening] for more detail.
+--
+-- Postcondition: Coercion :: Xi ~ TcType
+-- The role on the result coercion matches the EqRel in the FlattenEnv
+
+flatten_one xi@(LitTy {})
+  = do { role <- getRole
+       ; return (xi, mkReflCo role xi) }
+
+flatten_one (TyVarTy tv)
+  = flattenTyVar tv
+
+flatten_one (AppTy ty1 ty2)
+  = flatten_app_tys ty1 [ty2]
+
+flatten_one (TyConApp tc tys)
+  -- Expand type synonyms that mention type families
+  -- on the RHS; see Note [Flattening synonyms]
+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
+  = do { mode <- getMode
+       ; case mode of
+           FM_FlattenAll | not (isFamFreeTyCon tc)
+                         -> flatten_one expanded_ty
+           _             -> flatten_ty_con_app tc tys }
+
+  -- Otherwise, it's a type function application, and we have to
+  -- flatten it away as well, and generate a new given equality constraint
+  -- between the application and a newly generated flattening skolem variable.
+  | isTypeFamilyTyCon tc
+  = flatten_fam_app tc tys
+
+  -- For * a normal data type application
+  --     * data family application
+  -- we just recursively flatten the arguments.
+  | otherwise
+-- FM_Avoid stuff commented out; see Note [Lazy flattening]
+--  , let fmode' = case fmode of  -- Switch off the flat_top bit in FM_Avoid
+--                   FE { fe_mode = FM_Avoid tv _ }
+--                     -> fmode { fe_mode = FM_Avoid tv False }
+--                   _ -> fmode
+  = flatten_ty_con_app tc tys
+
+flatten_one ty@(FunTy _ ty1 ty2)
+  = do { (xi1,co1) <- flatten_one ty1
+       ; (xi2,co2) <- flatten_one ty2
+       ; role <- getRole
+       ; return (ty { ft_arg = xi1, ft_res = xi2 }
+                , mkFunCo role co1 co2) }
+
+flatten_one ty@(ForAllTy {})
+-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of
+-- the bound tyvar. Doing so will require carrying around a substitution
+-- and the usual substTyVarBndr-like silliness. Argh.
+
+-- We allow for-alls when, but only when, no type function
+-- applications inside the forall involve the bound type variables.
+  = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty
+             tvs           = binderVars bndrs
+       ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho
+                         -- Substitute only under a forall
+                         -- See Note [Flattening under a forall]
+       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }
+
+flatten_one (CastTy ty g)
+  = do { (xi, co) <- flatten_one ty
+       ; (g', _)   <- flatten_co g
+
+       ; role <- getRole
+       ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) }
+
+flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co
+
+-- | "Flatten" a coercion. Really, just zonk it so we can uphold
+-- (F1) of Note [Flattening]
+flatten_co :: Coercion -> FlatM (Coercion, Coercion)
+flatten_co co
+  = do { co <- liftTcS $ zonkCo co
+       ; env_role <- getRole
+       ; let co' = mkTcReflCo env_role (mkCoercionTy co)
+       ; return (co, co') }
+
+-- flatten (nested) AppTys
+flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion)
+-- commoning up nested applications allows us to look up the function's kind
+-- only once. Without commoning up like this, we would spend a quadratic amount
+-- of time looking up functions' types
+flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys)
+flatten_app_tys fun_ty arg_tys
+  = do { (fun_xi, fun_co) <- flatten_one fun_ty
+       ; flatten_app_ty_args fun_xi fun_co arg_tys }
+
+-- Given a flattened function (with the coercion produced by flattening) and
+-- a bunch of unflattened arguments, flatten the arguments and apply.
+-- The coercion argument's role matches the role stored in the FlatM monad.
+--
+-- The bang patterns used here were observed to improve performance. If you
+-- wish to remove them, be sure to check for regeressions in allocations.
+flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion)
+flatten_app_ty_args fun_xi fun_co []
+  -- this will be a common case when called from flatten_fam_app, so shortcut
+  = return (fun_xi, fun_co)
+flatten_app_ty_args fun_xi fun_co arg_tys
+  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of
+           Just (tc, xis) ->
+             do { let tc_roles  = tyConRolesRepresentational tc
+                      arg_roles = dropList xis tc_roles
+                ; (arg_xis, arg_cos, kind_co)
+                    <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys
+
+                  -- Here, we have fun_co :: T xi1 xi2 ~ ty
+                  -- and we need to apply fun_co to the arg_cos. The problem is
+                  -- that using mkAppCo is wrong because that function expects
+                  -- its second coercion to be Nominal, and the arg_cos might
+                  -- not be. The solution is to use transitivity:
+                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>
+                ; eq_rel <- getEqRel
+                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)
+                      app_co = case eq_rel of
+                        NomEq  -> mkAppCos fun_co arg_cos
+                        ReprEq -> mkTcTyConAppCo Representational tc
+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)
+                                  `mkTcTransCo`
+                                  mkAppCos fun_co (map mkNomReflCo arg_tys)
+                ; return (app_xi, app_co, kind_co) }
+           Nothing ->
+             do { (arg_xis, arg_cos, kind_co)
+                    <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys
+                ; let arg_xi = mkAppTys fun_xi arg_xis
+                      arg_co = mkAppCos fun_co arg_cos
+                ; return (arg_xi, arg_co, kind_co) }
+
+       ; role <- getRole
+       ; return (homogenise_result xi co role kind_co) }
+
+flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+flatten_ty_con_app tc tys
+  = do { role <- getRole
+       ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys
+       ; let tyconapp_xi = mkTyConApp tc xis
+             tyconapp_co = mkTyConAppCo role tc cos
+       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }
+
+-- Make the result of flattening homogeneous (Note [Flattening] (F2))
+homogenise_result :: Xi              -- a flattened type
+                  -> Coercion        -- :: xi ~r original ty
+                  -> Role            -- r
+                  -> CoercionN       -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)
+                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)
+                                     --   ~r original ty)
+homogenise_result xi co r kind_co
+  -- the explicit pattern match here improves the performance of T9872a, b, c by
+  -- ~2%
+  | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)
+  | otherwise         = (xi `mkCastTy` kind_co
+                        , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)
+{-# INLINE homogenise_result #-}
+
+-- Flatten a vector (list of arguments).
+flatten_vector :: Kind   -- of the function being applied to these arguments
+               -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the
+                         -- args have?
+               -> [Type] -- the args to flatten
+               -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_vector ki roles tys
+  = do { eq_rel <- getEqRel
+       ; case eq_rel of
+           NomEq  -> flatten_args bndrs
+                                  any_named_bndrs
+                                  inner_ki
+                                  fvs
+                                  (repeat Nominal)
+                                  tys
+           ReprEq -> flatten_args bndrs
+                                  any_named_bndrs
+                                  inner_ki
+                                  fvs
+                                  roles
+                                  tys
+       }
+  where
+    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki
+    fvs                                = tyCoVarsOfType ki
+{-# INLINE flatten_vector #-}
+
+{-
+Note [Flattening synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Not expanding synonyms aggressively improves error messages, and
+keeps types smaller. But we need to take care.
+
+Suppose
+   type T a = a -> a
+and we want to flatten the type (T (F a)).  Then we can safely flatten
+the (F a) to a skolem, and return (T fsk).  We don't need to expand the
+synonym.  This works because TcTyConAppCo can deal with synonyms
+(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence.
+
+But (#8979) for
+   type T a = (F a, a)    where F is a type function
+we must expand the synonym in (say) T Int, to expose the type function
+to the flattener.
+
+
+Note [Flattening under a forall]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Under a forall, we
+  (a) MUST apply the inert substitution
+  (b) MUST NOT flatten type family applications
+Hence FMSubstOnly.
+
+For (a) consider   c ~ a, a ~ T (forall b. (b, [c]))
+If we don't apply the c~a substitution to the second constraint
+we won't see the occurs-check error.
+
+For (b) consider  (a ~ forall b. F a b), we don't want to flatten
+to     (a ~ forall b.fsk, F a b ~ fsk)
+because now the 'b' has escaped its scope.  We'd have to flatten to
+       (a ~ forall b. fsk b, forall b. F a b ~ fsk b)
+and we have not begun to think about how to make that work!
+
+************************************************************************
+*                                                                      *
+             Flattening a type-family application
+*                                                                      *
+************************************************************************
+-}
+
+flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+  --   flatten_fam_app            can be over-saturated
+  --   flatten_exact_fam_app       is exactly saturated
+  --   flatten_exact_fam_app_fully lifts out the application to top level
+  -- Postcondition: Coercion :: Xi ~ F tys
+flatten_fam_app tc tys  -- Can be over-saturated
+    = ASSERT2( tys `lengthAtLeast` tyConArity tc
+             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
+
+      do { mode <- getMode
+         ; case mode of
+             { FM_SubstOnly  -> flatten_ty_con_app tc tys
+             ; FM_FlattenAll ->
+
+                 -- Type functions are saturated
+                 -- The type function might be *over* saturated
+                 -- in which case the remaining arguments should
+                 -- be dealt with by AppTys
+      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
+         ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1
+               -- co1 :: xi1 ~ F tys1
+
+         ; flatten_app_ty_args xi1 co1 tys_rest } } }
+
+-- the [TcType] exactly saturate the TyCon
+-- See note [flatten_exact_fam_app_fully performance]
+flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+flatten_exact_fam_app_fully tc tys
+  -- See Note [Reduce type family applications eagerly]
+     -- the following tcTypeKind should never be evaluated, as it's just used in
+     -- casting, and casts by refl are dropped
+  = do { mOut <- try_to_reduce_nocache tc tys
+       ; case mOut of
+           Just out -> pure out
+           Nothing -> do
+               { -- First, flatten the arguments
+               ; (xis, cos, kind_co)
+                   <- setEqRel NomEq $  -- just do this once, instead of for
+                                        -- each arg
+                      flatten_args_tc tc (repeat Nominal) tys
+                      -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)
+               ; eq_rel   <- getEqRel
+               ; cur_flav <- getFlavour
+               ; let role   = eqRelRole eq_rel
+                     ret_co = mkTyConAppCo role tc cos
+                      -- ret_co :: F xis ~ F tys; might be heterogeneous
+
+                -- Now, look in the cache
+               ; mb_ct <- liftTcS $ lookupFlatCache tc xis
+               ; case mb_ct of
+                   Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk
+                        -- flav is [G] or [WD]
+                        -- See Note [Type family equations] in TcSMonad
+                     | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav
+                     ->  -- Usable hit in the flat-cache
+                        do { traceFlat "flatten/flat-cache hit" $
+                               (ppr tc <+> ppr xis $$ ppr rhs_ty)
+                           ; (fsk_xi, fsk_co) <- flatten_one rhs_ty
+                                  -- The fsk may already have been unified, so
+                                  -- flatten it
+                                  -- fsk_co :: fsk_xi ~ fsk
+                           ; let xi  = fsk_xi `mkCastTy` kind_co
+                                 co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co
+                                       `mkTransCo`
+                                       maybeSubCo eq_rel (mkSymCo co)
+                                       `mkTransCo` ret_co
+                           ; return (xi, co')
+                           }
+                                            -- :: fsk_xi ~ F xis
+
+                   -- Try to reduce the family application right now
+                   -- See Note [Reduce type family applications eagerly]
+                   _ -> do { mOut <- try_to_reduce tc
+                                                   xis
+                                                   kind_co
+                                                   (`mkTransCo` ret_co)
+                           ; case mOut of
+                               Just out -> pure out
+                               Nothing -> do
+                                 { loc <- getLoc
+                                 ; (ev, co, fsk) <- liftTcS $
+                                     newFlattenSkolem cur_flav loc tc xis
+
+                                 -- The new constraint (F xis ~ fsk) is not
+                                 -- necessarily inert (e.g. the LHS may be a
+                                 -- redex) so we must put it in the work list
+                                 ; let ct = CFunEqCan { cc_ev     = ev
+                                                      , cc_fun    = tc
+                                                      , cc_tyargs = xis
+                                                      , cc_fsk    = fsk }
+                                 ; emitFlatWork ct
+
+                                 ; traceFlat "flatten/flat-cache miss" $
+                                     (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)
+
+                                 -- NB: fsk's kind is already flattened because
+                                 --     the xis are flattened
+                                 ; let fsk_ty = mkTyVarTy fsk
+                                       xi = fsk_ty `mkCastTy` kind_co
+                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeSubCo eq_rel (mkSymCo co))
+                                             `mkTransCo` ret_co
+                                 ; return (xi, co')
+                                 }
+                           }
+               }
+        }
+
+  where
+
+    -- try_to_reduce and try_to_reduce_nocache (below) could be unified into
+    -- a more general definition, but it was observed that separating them
+    -- gives better performance (lower allocation numbers in T9872x).
+
+    try_to_reduce :: TyCon   -- F, family tycon
+                  -> [Type]  -- args, not necessarily flattened
+                  -> CoercionN -- kind_co :: tcTypeKind(F args) ~N
+                               --            tcTypeKind(F orig_args)
+                               -- where
+                               -- orig_args is what was passed to the outer
+                               -- function
+                  -> (   Coercion     -- :: (xi |> kind_co) ~ F args
+                      -> Coercion )   -- what to return from outer function
+                  -> FlatM (Maybe (Xi, Coercion))
+    try_to_reduce tc tys kind_co update_co
+      = do { checkStackDepth (mkTyConApp tc tys)
+           ; mb_match <- liftTcS $ matchFam tc tys
+           ; case mb_match of
+                 -- NB: norm_co will always be homogeneous. All type families
+                 -- are homogeneous.
+               Just (norm_co, norm_ty)
+                 -> do { traceFlat "Eager T.F. reduction success" $
+                         vcat [ ppr tc, ppr tys, ppr norm_ty
+                              , ppr norm_co <+> dcolon
+                                            <+> ppr (coercionKind norm_co)
+                              ]
+                       ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty
+                       ; eq_rel <- getEqRel
+                       ; let co = maybeSubCo eq_rel norm_co
+                                   `mkTransCo` mkSymCo final_co
+                       ; flavour <- getFlavour
+                           -- NB: only extend cache with nominal equalities
+                       ; when (eq_rel == NomEq) $
+                         liftTcS $
+                         extendFlatCache tc tys ( co, xi, flavour )
+                       ; let role = eqRelRole eq_rel
+                             xi' = xi `mkCastTy` kind_co
+                             co' = update_co $
+                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
+                       ; return $ Just (xi', co') }
+               Nothing -> pure Nothing }
+
+    try_to_reduce_nocache :: TyCon   -- F, family tycon
+                          -> [Type]  -- args, not necessarily flattened
+                          -> FlatM (Maybe (Xi, Coercion))
+    try_to_reduce_nocache tc tys
+      = do { checkStackDepth (mkTyConApp tc tys)
+           ; mb_match <- liftTcS $ matchFam tc tys
+           ; case mb_match of
+                 -- NB: norm_co will always be homogeneous. All type families
+                 -- are homogeneous.
+               Just (norm_co, norm_ty)
+                 -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
+                       ; eq_rel <- getEqRel
+                       ; let co  = mkSymCo (maybeSubCo eq_rel norm_co
+                                            `mkTransCo` mkSymCo final_co)
+                       ; return $ Just (xi, co) }
+               Nothing -> pure Nothing }
+
+{- Note [Reduce type family applications eagerly]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we come across a type-family application like (Append (Cons x Nil) t),
+then, rather than flattening to a skolem etc, we may as well just reduce
+it on the spot to (Cons x t).  This saves a lot of intermediate steps.
+Examples that are helped are tests T9872, and T5321Fun.
+
+Performance testing indicates that it's best to try this *twice*, once
+before flattening arguments and once after flattening arguments.
+Adding the extra reduction attempt before flattening arguments cut
+the allocation amounts for the T9872{a,b,c} tests by half.
+
+An example of where the early reduction appears helpful:
+
+  type family Last x where
+    Last '[x]     = x
+    Last (h ': t) = Last t
+
+  workitem: (x ~ Last '[1,2,3,4,5,6])
+
+Flattening the argument never gets us anywhere, but trying to flatten
+it at every step is quadratic in the length of the list. Reducing more
+eagerly makes simplifying the right-hand type linear in its length.
+
+Testing also indicated that the early reduction should *not* use the
+flat-cache, but that the later reduction *should*. (Although the
+effect was not large.)  Hence the Bool argument to try_to_reduce.  To
+me (SLPJ) this seems odd; I get that eager reduction usually succeeds;
+and if don't use the cache for eager reduction, we will miss most of
+the opportunities for using it at all.  More exploration would be good
+here.
+
+At the end, once we've got a flat rhs, we extend the flatten-cache to record
+the result. Doing so can save lots of work when the same redex shows up more
+than once. Note that we record the link from the redex all the way to its
+*final* value, not just the single step reduction. Interestingly, using the
+flat-cache for the first reduction resulted in an increase in allocations
+of about 3% for the four T9872x tests. However, using the flat-cache in
+the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)
+have any knowledge as to *why* these facts are true.
+
+************************************************************************
+*                                                                      *
+             Flattening a type variable
+*                                                                      *
+********************************************************************* -}
+
+-- | The result of flattening a tyvar "one step".
+data FlattenTvResult
+  = FTRNotFollowed
+      -- ^ The inert set doesn't make the tyvar equal to anything else
+
+  | FTRFollowed TcType Coercion
+      -- ^ The tyvar flattens to a not-necessarily flat other type.
+      -- co :: new type ~r old type, where the role is determined by
+      -- the FlattenEnv
+
+flattenTyVar :: TyVar -> FlatM (Xi, Coercion)
+flattenTyVar tv
+  = do { mb_yes <- flatten_tyvar1 tv
+       ; case mb_yes of
+           FTRFollowed ty1 co1  -- Recur
+             -> do { (ty2, co2) <- flatten_one ty1
+                   -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2)
+                   ; return (ty2, co2 `mkTransCo` co1) }
+
+           FTRNotFollowed   -- Done, but make sure the kind is zonked
+                            -- Note [Flattening] invariant (F1)
+             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv
+                   ; role <- getRole
+                   ; let ty' = mkTyVarTy tv'
+                   ; return (ty', mkTcReflCo role ty') } }
+
+flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult
+-- "Flattening" a type variable means to apply the substitution to it
+-- Specifically, look up the tyvar in
+--   * the internal MetaTyVar box
+--   * the inerts
+-- See also the documentation for FlattenTvResult
+
+flatten_tyvar1 tv
+  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv
+       ; case mb_ty of
+           Just ty -> do { traceFlat "Following filled tyvar"
+                             (ppr tv <+> equals <+> ppr ty)
+                         ; role <- getRole
+                         ; return (FTRFollowed ty (mkReflCo role ty)) } ;
+           Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)
+                         ; fr <- getFlavourRole
+                         ; flatten_tyvar2 tv fr } }
+
+flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult
+-- The tyvar is not a filled-in meta-tyvar
+-- Try in the inert equalities
+-- See Definition [Applying a generalised substitution] in TcSMonad
+-- See Note [Stability of flattening] in TcSMonad
+
+flatten_tyvar2 tv fr@(_, eq_rel)
+  = do { ieqs <- liftTcS $ getInertEqs
+       ; mode <- getMode
+       ; case lookupDVarEnv ieqs tv of
+           Just (ct:_)   -- If the first doesn't work,
+                         -- the subsequent ones won't either
+             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv
+                        , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
+             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)
+             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR
+             ->  do { traceFlat "Following inert tyvar"
+                        (ppr mode <+>
+                         ppr tv <+>
+                         equals <+>
+                         ppr rhs_ty $$ ppr ctev)
+                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
+                          rewrite_co  = case (ct_eq_rel, eq_rel) of
+                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )
+                                    -- if this ASSERT fails, then
+                                    -- eqCanRewriteFR answered incorrectly
+                                               rewrite_co1
+                            (NomEq, NomEq)  -> rewrite_co1
+                            (NomEq, ReprEq) -> mkSubCo rewrite_co1
+
+                    ; return (FTRFollowed rhs_ty rewrite_co) }
+                    -- NB: ct is Derived then fmode must be also, hence
+                    -- we are not going to touch the returned coercion
+                    -- so ctEvCoercion is fine.
+
+           _other -> return FTRNotFollowed }
+
+{-
+Note [An alternative story for the inert substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This entire note is just background, left here in case we ever want
+ to return the previous state of affairs)
+
+We used (GHC 7.8) to have this story for the inert substitution inert_eqs
+
+ * 'a' is not in fvs(ty)
+ * They are *inert* in the weaker sense that there is no infinite chain of
+   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc
+
+This means that flattening must be recursive, but it does allow
+  [G] a ~ [b]
+  [G] b ~ Maybe c
+
+This avoids "saturating" the Givens, which can save a modest amount of work.
+It is easy to implement, in TcInteract.kick_out, by only kicking out an inert
+only if (a) the work item can rewrite the inert AND
+        (b) the inert cannot rewrite the work item
+
+This is significantly harder to think about. It can save a LOT of work
+in occurs-check cases, but we don't care about them much.  #5837
+is an example; all the constraints here are Givens
+
+             [G] a ~ TF (a,Int)
+    -->
+    work     TF (a,Int) ~ fsk
+    inert    fsk ~ a
+
+    --->
+    work     fsk ~ (TF a, TF Int)
+    inert    fsk ~ a
+
+    --->
+    work     a ~ (TF a, TF Int)
+    inert    fsk ~ a
+
+    ---> (attempting to flatten (TF a) so that it does not mention a
+    work     TF a ~ fsk2
+    inert    a ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    ---> (substitute for a)
+    work     TF (fsk2, TF Int) ~ fsk2
+    inert    a ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    ---> (top-level reduction, re-orient)
+    work     fsk2 ~ (TF fsk2, TF Int)
+    inert    a ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    ---> (attempt to flatten (TF fsk2) to get rid of fsk2
+    work     TF fsk2 ~ fsk3
+    work     fsk2 ~ (fsk3, TF Int)
+    inert    a   ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    --->
+    work     TF fsk2 ~ fsk3
+    inert    fsk2 ~ (fsk3, TF Int)
+    inert    a   ~ ((fsk3, TF Int), TF Int)
+    inert    fsk ~ ((fsk3, TF Int), TF Int)
+
+Because the incoming given rewrites all the inert givens, we get more and
+more duplication in the inert set.  But this really only happens in pathalogical
+casee, so we don't care.
+
+
+************************************************************************
+*                                                                      *
+             Unflattening
+*                                                                      *
+************************************************************************
+
+An unflattening example:
+    [W] F a ~ alpha
+flattens to
+    [W] F a ~ fmv   (CFunEqCan)
+    [W] fmv ~ alpha (CTyEqCan)
+We must solve both!
+-}
+
+unflattenWanteds :: Cts -> Cts -> TcS Cts
+unflattenWanteds tv_eqs funeqs
+ = do { tclvl    <- getTcLevel
+
+      ; traceTcS "Unflattening" $ braces $
+        vcat [ text "Funeqs =" <+> pprCts funeqs
+             , text "Tv eqs =" <+> pprCts tv_eqs ]
+
+         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check
+         -- Occurs check: consider  [W] alpha ~ [F alpha]
+         --                 ==> (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
+      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
+
+          -- Step 2: unify the tv_eqs, if possible
+      ; tv_eqs  <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs
+      ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
+
+          -- Step 3: fill any remaining fmvs with fresh unification variables
+      ; funeqs <- mapBagM finalise_funeq funeqs
+      ; 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
+
+      ; let all_flat = tv_eqs `andCts` funeqs
+      ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
+
+      ; return all_flat }
+  where
+    ----------------
+    unflatten_funeq :: Ct -> Cts -> TcS Cts
+    unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis
+                                  , cc_fsk = fmv, cc_ev = ev }) rest
+      = do {   -- fmv should be an un-filled flatten meta-tv;
+               -- we now fix its final value by filling it, being careful
+               -- to observe the occurs check.  Zonking will eliminate it
+               -- altogether in due course
+             rhs' <- zonkTcType (mkTyConApp tc xis)
+           ; case occCheckExpand [fmv] rhs' of
+               Just rhs''    -- Normal case: fill the tyvar
+                 -> do { setReflEvidence ev NomEq rhs''
+                       ; unflattenFmv fmv rhs''
+                       ; return rest }
+
+               Nothing ->  -- Occurs check
+                          return (ct `consCts` rest) }
+
+    unflatten_funeq other_ct _
+      = pprPanic "unflatten_funeq" (ppr other_ct)
+
+    ----------------
+    finalise_funeq :: Ct -> TcS Ct
+    finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })
+      = do { demoteUnfilledFmv fmv
+           ; return (mkNonCanonical ev) }
+    finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)
+
+    ----------------
+    unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts
+    unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv
+                                    , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
+
+      | NomEq <- eq_rel -- See Note [Do not unify representational equalities]
+                        --     in TcInteract
+      , isFmvTyVar tv   -- Previously these fmvs were untouchable,
+                        -- but now they are touchable
+                        -- NB: unlike unflattenFmv, filling a fmv here /does/
+                        --     bump the unification count; it is "improvement"
+                        -- Note [Unflattening can force the solver to iterate]
+      = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )
+           -- CTyEqCan invariant should ensure this is true
+        do { is_filled <- isFilledMetaTyVar tv
+           ; elim <- case is_filled of
+               False -> do { traceTcS "unflatten_eq 2" (ppr ct)
+                           ; tryFill ev tv rhs }
+               True  -> do { traceTcS "unflatten_eq 3" (ppr ct)
+                           ; try_fill_rhs ev tclvl tv rhs }
+           ; if elim
+             then do { setReflEvidence ev eq_rel (mkTyVarTy tv)
+                     ; return rest }
+             else return (ct `consCts` rest) }
+
+      | otherwise
+      = return (ct `consCts` rest)
+
+    unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)
+
+    ----------------
+    try_fill_rhs ev tclvl lhs_tv rhs
+         -- Constraint is lhs_tv ~ rhs_tv,
+         -- and lhs_tv is filled, so try RHS
+      | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs
+                             -- co :: kind(rhs_tv) ~ kind(lhs_tv)
+      , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv
+                              && not (isTyVarTyVar rhs_tv))
+                              -- LHS is a filled fmv, and so is a type
+                              -- family application, which a TyVarTv should
+                              -- not unify with
+      = do { is_filled <- isFilledMetaTyVar rhs_tv
+           ; if is_filled then return False
+             else tryFill ev rhs_tv
+                          (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }
+
+      | otherwise
+      = return False
+
+    ----------------
+    finalise_eq :: Ct -> Cts -> TcS Cts
+    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv
+                          , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
+      | isFmvTyVar tv
+      = do { ty1 <- zonkTcTyVar tv
+           ; rhs' <- zonkTcType rhs
+           ; if ty1 `tcEqType` rhs'
+             then do { setReflEvidence ev eq_rel rhs'
+                     ; return rest }
+             else return (mkNonCanonical ev `consCts` rest) }
+
+      | otherwise
+      = return (mkNonCanonical ev `consCts` rest)
+
+    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
+
+tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool
+-- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv
+-- If tv does not appear in 'rhs', it set tv := rhs,
+-- binds the evidence (which should be a CtWanted) to Refl<rhs>
+-- and return True.  Otherwise returns False
+tryFill ev tv rhs
+  = ASSERT2( not (isGiven ev), ppr ev )
+    do { rhs' <- zonkTcType rhs
+       ; case () of
+            _ | Just tv' <- tcGetTyVar_maybe rhs'
+              , tv == tv'   -- tv == rhs
+              -> return True
+
+            _ | Just rhs'' <- occCheckExpand [tv] rhs'
+              -> do {       -- Fill the tyvar
+                      unifyTyVar tv rhs''
+                    ; return True }
+
+            _ | otherwise   -- Occurs check
+              -> return False
+    }
+
+setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()
+setReflEvidence ev eq_rel rhs
+  = setEvBindIfWanted ev (evCoercion refl_co)
+  where
+    refl_co = mkTcReflCo (eqRelRole eq_rel) rhs
+
+{-
+Note [Unflatten using funeqs first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    [W] G a ~ Int
+    [W] F (G a) ~ G a
+
+do not want to end up with
+    [W] F Int ~ Int
+because that might actually hold!  Better to end up with the two above
+unsolved constraints.  The flat form will be
+
+    G a ~ fmv1     (CFunEqCan)
+    F fmv1 ~ fmv2  (CFunEqCan)
+    fmv1 ~ Int     (CTyEqCan)
+    fmv1 ~ fmv2    (CTyEqCan)
+
+Flatten using the fun-eqs first.
+-}
+
+-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at
+-- least one named binder.
+split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)
+split_pi_tys' ty = split ty ty
+  where
+  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
+  split _       (ForAllTy b res) = let (bs, ty, _) = split res res
+                                   in  (Named b : bs, ty, True)
+  split _       (FunTy { ft_af = af, ft_arg = arg, ft_res = res })
+                                 = let (bs, ty, named) = split res res
+                                   in  (Anon af arg : bs, ty, named)
+  split orig_ty _                = ([], orig_ty, False)
+{-# INLINE split_pi_tys' #-}
+
+-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff
+-- there is at least one named binder.
+ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)
+ty_con_binders_ty_binders' = foldr go ([], False)
+  where
+    go (Bndr tv (NamedTCB vis)) (bndrs, _)
+      = (Named (Bndr tv vis) : bndrs, True)
+    go (Bndr tv (AnonTCB af))   (bndrs, n)
+      = (Anon af (tyVarKind tv)   : bndrs, n)
+    {-# INLINE go #-}
+{-# INLINE ty_con_binders_ty_binders' #-}
diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcForeign.hs
@@ -0,0 +1,569 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1998
+
+\section[TcForeign]{Typechecking \tr{foreign} declarations}
+
+A foreign declaration is used to either give an externally
+implemented function a Haskell type (and calling interface) or
+give a Haskell function an external calling interface. Either way,
+the range of argument and result types these functions can accommodate
+is restricted to what the outside world understands (read C), and this
+module checks to see if a foreign declaration has got a legal type.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcForeign
+        ( tcForeignImports
+        , tcForeignExports
+
+        -- Low-level exports for hooks
+        , isForeignImport, isForeignExport
+        , tcFImport, tcFExport
+        , tcForeignImports'
+        , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
+        , normaliseFfiType
+        , nonIOok, mustBeIO
+        , checkSafe, noCheckSafe
+        , tcForeignExports'
+        , tcCheckFEType
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+
+import TcRnMonad
+import TcHsType
+import TcExpr
+import TcEnv
+
+import FamInst
+import FamInstEnv
+import Coercion
+import Type
+import ForeignCall
+import ErrUtils
+import Id
+import Name
+import RdrName
+import DataCon
+import TyCon
+import TcType
+import PrelNames
+import DynFlags
+import Outputable
+import Platform
+import SrcLoc
+import Bag
+import Hooks
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Maybe
+
+-- Defines a binding
+isForeignImport :: LForeignDecl name -> Bool
+isForeignImport (L _ (ForeignImport {})) = True
+isForeignImport _                        = False
+
+-- Exports a binding
+isForeignExport :: LForeignDecl name -> Bool
+isForeignExport (L _ (ForeignExport {})) = True
+isForeignExport _                        = False
+
+{-
+Note [Don't recur in normaliseFfiType']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+normaliseFfiType' is the workhorse for normalising a type used in a foreign
+declaration. If we have
+
+newtype Age = MkAge Int
+
+we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
+need to recur on any type parameters, because no paramaterized types (with
+interesting parameters) are marshalable! The full list of marshalable types
+is in the body of boxedMarshalableTyCon in TcType. The only members of that
+list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
+the same way regardless of type parameter. So, no need to recur into
+parameters.
+
+Similarly, we don't need to look in AppTy's, because nothing headed by
+an AppTy will be marshalable.
+
+Note [FFI type roles]
+~~~~~~~~~~~~~~~~~~~~~
+The 'go' helper function within normaliseFfiType' always produces
+representational coercions. But, in the "children_only" case, we need to
+use these coercions in a TyConAppCo. Accordingly, the roles on the coercions
+must be twiddled to match the expectation of the enclosing TyCon. However,
+we cannot easily go from an R coercion to an N one, so we forbid N roles
+on FFI type constructors. Currently, only two such type constructors exist:
+IO and FunPtr. Thus, this is not an onerous burden.
+
+If we ever want to lift this restriction, we would need to make 'go' take
+the target role as a parameter. This wouldn't be hard, but it's a complication
+not yet necessary and so is not yet implemented.
+-}
+
+-- normaliseFfiType takes the type from an FFI declaration, and
+-- evaluates any type synonyms, type functions, and newtypes. However,
+-- we are only allowed to look through newtypes if the constructor is
+-- in scope.  We return a bag of all the newtype constructors thus found.
+-- Always returns a Representational coercion
+normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
+normaliseFfiType ty
+    = do fam_envs <- tcGetFamInstEnvs
+         normaliseFfiType' fam_envs ty
+
+normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
+normaliseFfiType' env ty0 = go initRecTc ty0
+  where
+    go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
+    go rec_nts ty
+      | Just ty' <- tcView ty     -- Expand synonyms
+      = go rec_nts ty'
+
+      | Just (tc, tys) <- splitTyConApp_maybe ty
+      = go_tc_app rec_nts tc tys
+
+      | (bndrs, inner_ty) <- splitForAllVarBndrs ty
+      , not (null bndrs)
+      = do (coi, nty1, gres1) <- go rec_nts inner_ty
+           return ( mkHomoForAllCos (binderVars bndrs) coi
+                  , mkForAllTys bndrs nty1, gres1 )
+
+      | otherwise -- see Note [Don't recur in normaliseFfiType']
+      = return (mkRepReflCo ty, ty, emptyBag)
+
+    go_tc_app :: RecTcChecker -> TyCon -> [Type]
+              -> TcM (Coercion, Type, Bag GlobalRdrElt)
+    go_tc_app rec_nts tc tys
+        -- We don't want to look through the IO newtype, even if it is
+        -- in scope, so we have a special case for it:
+        | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]
+                  -- These *must not* have nominal roles on their parameters!
+                  -- See Note [FFI type roles]
+        = children_only
+
+        | isNewTyCon tc         -- Expand newtypes
+        , Just rec_nts' <- checkRecTc rec_nts tc
+                   -- See Note [Expanding newtypes] in TyCon.hs
+                   -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
+                   --     newtype T = T (Ptr T)
+                   --   Here, we don't reject the type for being recursive.
+                   -- If this is a recursive newtype then it will normally
+                   -- be rejected later as not being a valid FFI type.
+        = do { rdr_env <- getGlobalRdrEnv
+             ; case checkNewtypeFFI rdr_env tc of
+                 Nothing  -> nothing
+                 Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
+                                ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
+
+        | isFamilyTyCon tc              -- Expand open tycons
+        , (co, ty) <- normaliseTcApp env Representational tc tys
+        , not (isReflexiveCo co)
+        = do (co', ty', gres) <- go rec_nts ty
+             return (mkTransCo co co', ty', gres)
+
+        | otherwise
+        = nothing -- see Note [Don't recur in normaliseFfiType']
+        where
+          tc_key = getUnique tc
+          children_only
+            = do xs <- mapM (go rec_nts) tys
+                 let (cos, tys', gres) = unzip3 xs
+                        -- the (repeat Representational) is because 'go' always
+                        -- returns R coercions
+                     cos' = zipWith3 downgradeRole (tyConRoles tc)
+                                     (repeat Representational) cos
+                 return ( mkTyConAppCo Representational tc cos'
+                        , mkTyConApp tc tys', unionManyBags gres)
+          nt_co  = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys []
+          nt_rhs = newTyConInstRhs tc tys
+
+          ty      = mkTyConApp tc tys
+          nothing = return (mkRepReflCo ty, ty, emptyBag)
+
+checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
+checkNewtypeFFI rdr_env tc
+  | Just con <- tyConSingleDataCon_maybe tc
+  , Just gre <- lookupGRE_Name rdr_env (dataConName con)
+  = Just gre    -- See Note [Newtype constructor usage in foreign declarations]
+  | otherwise
+  = Nothing
+
+{-
+Note [Newtype constructor usage in foreign declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC automatically "unwraps" newtype constructors in foreign import/export
+declarations.  In effect that means that a newtype data constructor is
+used even though it is not mentioned expclitly in the source, so we don't
+want to report it as "defined but not used" or "imported but not used".
+eg     newtype D = MkD Int
+       foreign import foo :: D -> IO ()
+Here 'MkD' us used.  See #7408.
+
+GHC also expands type functions during this process, so it's not enough
+just to look at the free variables of the declaration.
+eg     type instance F Bool = D
+       foreign import bar :: F Bool -> IO ()
+Here again 'MkD' is used.
+
+So we really have wait until the type checker to decide what is used.
+That's why tcForeignImports and tecForeignExports return a (Bag GRE)
+for the newtype constructors they see. Then TcRnDriver can add them
+to the module's usages.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Imports}
+*                                                                      *
+************************************************************************
+-}
+
+tcForeignImports :: [LForeignDecl GhcRn]
+                 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
+tcForeignImports decls
+  = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
+
+tcForeignImports' :: [LForeignDecl GhcRn]
+                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
+-- For the (Bag GlobalRdrElt) result,
+-- see Note [Newtype constructor usage in foreign declarations]
+tcForeignImports' decls
+  = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
+                               filter isForeignImport decls
+       ; return (ids, decls, unionManyBags gres) }
+
+tcFImport :: LForeignDecl GhcRn
+          -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
+tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
+                                    , fd_fi = imp_decl }))
+  = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $
+    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+       ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
+       ; let
+           -- Drop the foralls before inspecting the
+           -- structure of the foreign type.
+             (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty
+             arg_tys           = mapMaybe binderRelevantType_maybe bndrs
+             id                = mkLocalId nm sig_ty
+                 -- Use a LocalId to obey the invariant that locally-defined
+                 -- things are LocalIds.  However, it does not need zonking,
+                 -- (so TcHsSyn.zonkForeignExports ignores it).
+
+       ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
+          -- Can't use sig_ty here because sig_ty :: Type and
+          -- we need HsType Id hence the undefined
+       ; let fi_decl = ForeignImport { fd_name = L nloc id
+                                     , fd_sig_ty = undefined
+                                     , fd_i_ext = mkSymCo norm_co
+                                     , fd_fi = imp_decl' }
+       ; return (id, L dloc fi_decl, gres) }
+tcFImport d = pprPanic "tcFImport" (ppr d)
+
+-- ------------ Checking types for foreign import ----------------------
+
+tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
+
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
+  -- Foreign import label
+  = do checkCg checkCOrAsmOrLlvmOrInterp
+       -- NB check res_ty not sig_ty!
+       --    In case sig_ty is (forall a. ForeignPtr a)
+       check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
+       cconv' <- checkCConv cconv
+       return (CImport (L lc cconv') safety mh l src)
+
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
+        -- Foreign wrapper (former f.e.d.)
+        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
+        -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
+        -- The use of the latter form is DEPRECATED, though.
+    checkCg checkCOrAsmOrLlvmOrInterp
+    cconv' <- checkCConv cconv
+    case arg_tys of
+        [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
+                        checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
+                        checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
+                  where
+                     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
+        _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))
+    return (CImport (L lc cconv') safety mh CWrapper src)
+
+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
+                                            (CFunction target) src)
+  | isDynamicTarget target = do -- Foreign import dynamic
+      checkCg checkCOrAsmOrLlvmOrInterp
+      cconv' <- checkCConv cconv
+      case arg_tys of           -- The first arg must be Ptr or FunPtr
+        []                ->
+          addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))
+        (arg1_ty:arg_tys) -> do
+          dflags <- getDynFlags
+          let curried_res_ty = mkVisFunTys arg_tys res_ty
+          check (isFFIDynTy curried_res_ty arg1_ty)
+                (illegalForeignTyErr argument)
+          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
+          checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
+  | cconv == PrimCallConv = do
+      dflags <- getDynFlags
+      checkTc (xopt LangExt.GHCForeignImportPrim dflags)
+              (text "Use GHCForeignImportPrim to allow `foreign import prim'.")
+      checkCg checkCOrAsmOrLlvmOrInterp
+      checkCTarget target
+      checkTc (playSafe safety)
+              (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
+      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
+      -- prim import result is more liberal, allows (#,,#)
+      checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
+      return idecl
+  | otherwise = do              -- Normal foreign import
+      checkCg checkCOrAsmOrLlvmOrInterp
+      cconv' <- checkCConv cconv
+      checkCTarget target
+      dflags <- getDynFlags
+      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
+      checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
+      checkMissingAmpersand dflags arg_tys res_ty
+      case target of
+          StaticTarget _ _ _ False
+           | not (null arg_tys) ->
+              addErrTc (text "`value' imports cannot have function types")
+          _ -> return ()
+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
+
+
+-- This makes a convenient place to check
+-- that the C identifier is valid for C
+checkCTarget :: CCallTarget -> TcM ()
+checkCTarget (StaticTarget _ str _ _) = do
+    checkCg checkCOrAsmOrLlvmOrInterp
+    checkTc (isCLabelString str) (badCName str)
+
+checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
+
+
+checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
+checkMissingAmpersand dflags arg_tys res_ty
+  | null arg_tys && isFunPtrTy res_ty &&
+    wopt Opt_WarnDodgyForeignImports dflags
+  = addWarn (Reason Opt_WarnDodgyForeignImports)
+        (text "possible missing & in foreign import of FunPtr")
+  | otherwise
+  = return ()
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Exports}
+*                                                                      *
+************************************************************************
+-}
+
+tcForeignExports :: [LForeignDecl GhcRn]
+             -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)
+tcForeignExports decls =
+  getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
+
+tcForeignExports' :: [LForeignDecl GhcRn]
+             -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)
+-- For the (Bag GlobalRdrElt) result,
+-- see Note [Newtype constructor usage in foreign declarations]
+tcForeignExports' decls
+  = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
+  where
+   combine (binds, fs, gres1) (L loc fe) = do
+       (b, f, gres2) <- setSrcSpan loc (tcFExport fe)
+       return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
+
+tcFExport :: ForeignDecl GhcRn
+          -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
+tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
+  = addErrCtxt (foreignDeclCtxt fo) $ do
+
+    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+
+    (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
+
+    spec' <- tcCheckFEType norm_sig_ty spec
+
+           -- we're exporting a function, but at a type possibly more
+           -- constrained than its declared/inferred type. Hence the need
+           -- to create a local binding which will call the exported function
+           -- at a particular type (and, maybe, overloading).
+
+
+    -- We need to give a name to the new top-level binding that
+    -- is *stable* (i.e. the compiler won't change it later),
+    -- because this name will be referred to by the C code stub.
+    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+    return ( mkVarBind id rhs
+           , ForeignExport { fd_name = L loc id
+                           , fd_sig_ty = undefined
+                           , fd_e_ext = norm_co, fd_fe = spec' }
+           , gres)
+tcFExport d = pprPanic "tcFExport" (ppr d)
+
+-- ------------ Checking argument types for foreign export ----------------------
+
+tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
+tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
+    checkCg checkCOrAsmOrLlvm
+    checkTc (isCLabelString str) (badCName str)
+    cconv' <- checkCConv cconv
+    checkForeignArgs isFFIExternalTy arg_tys
+    checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
+    return (CExport (L l (CExportStatic esrc str cconv')) src)
+  where
+      -- Drop the foralls before inspecting n
+      -- the structure of the foreign type.
+    (bndrs, res_ty) = tcSplitPiTys sig_ty
+    arg_tys         = mapMaybe binderRelevantType_maybe bndrs
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Miscellaneous}
+*                                                                      *
+************************************************************************
+-}
+
+------------ Checking argument types for foreign import ----------------------
+checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()
+checkForeignArgs pred tys = mapM_ go tys
+  where
+    go ty = check (pred ty) (illegalForeignTyErr argument)
+
+------------ Checking result types for foreign calls ----------------------
+-- | Check that the type has the form
+--    (IO t) or (t) , and that t satisfies the given predicate.
+-- When calling this function, any newtype wrappers (should) have been
+-- already dealt with by normaliseFfiType.
+--
+-- We also check that the Safe Haskell condition of FFI imports having
+-- results in the IO monad holds.
+--
+checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
+checkForeignRes non_io_result_ok check_safe pred_res_ty ty
+  | Just (_, res_ty) <- tcSplitIOType_maybe ty
+  =     -- Got an IO result type, that's always fine!
+     check (pred_res_ty res_ty) (illegalForeignTyErr result)
+
+  -- Case for non-IO result type with FFI Import
+  | not non_io_result_ok
+  = addErrTc $ illegalForeignTyErr result (text "IO result type expected")
+
+  | otherwise
+  = do { dflags <- getDynFlags
+       ; case pred_res_ty ty of
+                -- Handle normal typecheck fail, we want to handle this first and
+                -- only report safe haskell errors if the normal type check is OK.
+           NotValid msg -> addErrTc $ illegalForeignTyErr result msg
+
+           -- handle safe infer fail
+           _ | check_safe && safeInferOn dflags
+               -> recordUnsafeInfer emptyBag
+
+           -- handle safe language typecheck fail
+           _ | check_safe && safeLanguageOn dflags
+               -> addErrTc (illegalForeignTyErr result safeHsErr)
+
+           -- success! non-IO return is fine
+           _ -> return () }
+  where
+    safeHsErr =
+      text "Safe Haskell is on, all FFI imports must be in the IO monad"
+
+nonIOok, mustBeIO :: Bool
+nonIOok  = True
+mustBeIO = False
+
+checkSafe, noCheckSafe :: Bool
+checkSafe   = True
+noCheckSafe = False
+
+-- Checking a supported backend is in use
+
+checkCOrAsmOrLlvm :: HscTarget -> Validity
+checkCOrAsmOrLlvm HscC    = IsValid
+checkCOrAsmOrLlvm HscAsm  = IsValid
+checkCOrAsmOrLlvm HscLlvm = IsValid
+checkCOrAsmOrLlvm _
+  = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
+
+checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity
+checkCOrAsmOrLlvmOrInterp HscC           = IsValid
+checkCOrAsmOrLlvmOrInterp HscAsm         = IsValid
+checkCOrAsmOrLlvmOrInterp HscLlvm        = IsValid
+checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid
+checkCOrAsmOrLlvmOrInterp _
+  = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
+
+checkCg :: (HscTarget -> Validity) -> TcM ()
+checkCg check = do
+    dflags <- getDynFlags
+    let target = hscTarget dflags
+    case target of
+      HscNothing -> return ()
+      _ ->
+        case check target of
+          IsValid      -> return ()
+          NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+
+-- Calling conventions
+
+checkCConv :: CCallConv -> TcM CCallConv
+checkCConv CCallConv    = return CCallConv
+checkCConv CApiConv     = return CApiConv
+checkCConv StdCallConv  = do dflags <- getDynFlags
+                             let platform = targetPlatform dflags
+                             if platformArch platform == ArchX86
+                                 then return StdCallConv
+                                 else do -- This is a warning, not an error. see #3336
+                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
+                                             addWarnTc (Reason Opt_WarnUnsupportedCallingConventions)
+                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
+                                         return CCallConv
+checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
+                             return PrimCallConv
+checkCConv JavaScriptCallConv = do dflags <- getDynFlags
+                                   if platformArch (targetPlatform dflags) == ArchJavaScript
+                                       then return JavaScriptCallConv
+                                       else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")
+                                               return JavaScriptCallConv
+
+-- Warnings
+
+check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
+check IsValid _             = return ()
+check (NotValid doc) err_fn = addErrTc (err_fn doc)
+
+illegalForeignTyErr :: SDoc -> SDoc -> SDoc
+illegalForeignTyErr arg_or_res extra
+  = hang msg 2 extra
+  where
+    msg = hsep [ text "Unacceptable", arg_or_res
+               , text "type in foreign declaration:"]
+
+-- Used for 'arg_or_res' argument to illegalForeignTyErr
+argument, result :: SDoc
+argument = text "argument"
+result   = text "result"
+
+badCName :: CLabelString -> MsgDoc
+badCName target
+  = sep [quotes (ppr target) <+> text "is not a valid C identifier"]
+
+foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
+foreignDeclCtxt fo
+  = hang (text "When checking declaration:")
+       2 (ppr fo)
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -0,0 +1,2391 @@
+{-
+    %
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcGenDeriv: Generating derived instance declarations
+
+This module is nominally ``subordinate'' to @TcDeriv@, which is the
+``official'' interface to deriving-related things.
+
+This is where we do all the grimy bindings' generation.
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcGenDeriv (
+        BagDerivStuff, DerivStuff(..),
+
+        gen_Eq_binds,
+        gen_Ord_binds,
+        gen_Enum_binds,
+        gen_Bounded_binds,
+        gen_Ix_binds,
+        gen_Show_binds,
+        gen_Read_binds,
+        gen_Data_binds,
+        gen_Lift_binds,
+        gen_Newtype_binds,
+        mkCoerceClassMethEqn,
+        genAuxBinds,
+        ordOpTbl, boxConTbl, litConTbl,
+        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import HsSyn
+import RdrName
+import BasicTypes
+import DataCon
+import Name
+import Fingerprint
+import Encoding
+
+import DynFlags
+import PrelInfo
+import FamInst
+import FamInstEnv
+import PrelNames
+import THNames
+import MkId ( coerceId )
+import PrimOp
+import SrcLoc
+import TyCon
+import TcEnv
+import TcType
+import TcValidity ( checkValidCoAxBranch )
+import CoAxiom    ( coAxiomSingleBranch )
+import TysPrim
+import TysWiredIn
+import Type
+import Class
+import VarSet
+import VarEnv
+import Util
+import Var
+import Outputable
+import Lexeme
+import FastString
+import Pair
+import Bag
+
+import Data.List  ( find, partition, intersperse )
+
+type BagDerivStuff = Bag DerivStuff
+
+data AuxBindSpec
+  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
+  | DerivTag2Con TyCon  -- ...ditto tag2Con
+  | DerivMaxTag  TyCon  -- ...and maxTag
+  deriving( Eq )
+  -- All these generate ZERO-BASED tag operations
+  -- I.e first constructor has tag 0
+
+data DerivStuff     -- Please add this auxiliary stuff
+  = DerivAuxBind AuxBindSpec
+
+  -- Generics and DeriveAnyClass
+  | DerivFamInst FamInst               -- New type family instances
+
+  -- New top-level auxiliary bindings
+  | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB
+
+
+{-
+************************************************************************
+*                                                                      *
+                Eq instances
+*                                                                      *
+************************************************************************
+
+Here are the heuristics for the code we generate for @Eq@. Let's
+assume we have a data type with some (possibly zero) nullary data
+constructors and some ordinary, non-nullary ones (the rest, also
+possibly zero of them).  Here's an example, with both \tr{N}ullary and
+\tr{O}rdinary data cons.
+
+  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
+
+* For the ordinary constructors (if any), we emit clauses to do The
+  Usual Thing, e.g.,:
+
+    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
+    (==) (O2 a1)       (O2 a2)       = a1 == a2
+    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
+
+  Note: if we're comparing unlifted things, e.g., if 'a1' and
+  'a2' are Float#s, then we have to generate
+       case (a1 `eqFloat#` a2) of r -> r
+  for that particular test.
+
+* If there are a lot of (more than ten) nullary constructors, we emit a
+  catch-all clause of the form:
+
+      (==) a b  = case (con2tag_Foo a) of { a# ->
+                  case (con2tag_Foo b) of { b# ->
+                  case (a# ==# b#)     of {
+                    r -> r }}}
+
+  If con2tag gets inlined this leads to join point stuff, so
+  it's better to use regular pattern matching if there aren't too
+  many nullary constructors.  "Ten" is arbitrary, of course
+
+* If there aren't any nullary constructors, we emit a simpler
+  catch-all:
+
+     (==) a b  = False
+
+* For the @(/=)@ method, we normally just use the default method.
+  If the type is an enumeration type, we could/may/should? generate
+  special code that calls @con2tag_Foo@, much like for @(==)@ shown
+  above.
+
+We thought about doing this: If we're also deriving 'Ord' for this
+tycon, we generate:
+  instance ... Eq (Foo ...) where
+    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
+    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
+However, that requires that (Ord <whatever>) was put in the context
+for the instance decl, which it probably wasn't, so the decls
+produced don't get through the typechecker.
+-}
+
+gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon = do
+    dflags <- getDynFlags
+    return (method_binds dflags, aux_binds)
+  where
+    all_cons = tyConDataCons tycon
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
+
+    -- If there are ten or more (arbitrary number) nullary constructors,
+    -- use the con2tag stuff.  For small types it's better to use
+    -- ordinary pattern matching.
+    (tag_match_cons, pat_match_cons)
+       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
+       | otherwise                       = ([],           all_cons)
+
+    no_tag_match_cons = null tag_match_cons
+
+    fall_through_eqn dflags
+      | no_tag_match_cons   -- All constructors have arguments
+      = case pat_match_cons of
+          []  -> []   -- No constructors; no fall-though case
+          [_] -> []   -- One constructor; no fall-though case
+          _   ->      -- Two or more constructors; add fall-through of
+                      --       (==) _ _ = False
+                 [([nlWildPat, nlWildPat], false_Expr)]
+
+      | otherwise -- One or more tag_match cons; add fall-through of
+                  -- extract tags compare for equality
+      = [([a_Pat, b_Pat],
+         untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
+
+    aux_binds | no_tag_match_cons = emptyBag
+              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+
+    method_binds dflags = unitBag (eq_bind dflags)
+    eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
+                                 (map pats_etc pat_match_cons
+                                   ++ fall_through_eqn dflags)
+
+    ------------------------------------------------------------------
+    pats_etc data_con
+      = let
+            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
+            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
+
+            data_con_RDR = getRdrName data_con
+            con_arity   = length tys_needed
+            as_needed   = take con_arity as_RDRs
+            bs_needed   = take con_arity bs_RDRs
+            tys_needed  = dataConOrigArgTys data_con
+        in
+        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
+      where
+        nested_eq_expr []  [] [] = true_Expr
+        nested_eq_expr tys as bs
+          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+          -- Using 'foldr1' here ensures that the derived code is correctly
+          -- associated. See #10859.
+          where
+            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
+
+{-
+************************************************************************
+*                                                                      *
+        Ord instances
+*                                                                      *
+************************************************************************
+
+Note [Generating Ord instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose constructors are K1..Kn, and some are nullary.
+The general form we generate is:
+
+* Do case on first argument
+        case a of
+          K1 ... -> rhs_1
+          K2 ... -> rhs_2
+          ...
+          Kn ... -> rhs_n
+          _ -> nullary_rhs
+
+* To make rhs_i
+     If i = 1, 2, n-1, n, generate a single case.
+        rhs_2    case b of
+                   K1 {}  -> LT
+                   K2 ... -> ...eq_rhs(K2)...
+                   _      -> GT
+
+     Otherwise do a tag compare against the bigger range
+     (because this is the one most likely to succeed)
+        rhs_3    case tag b of tb ->
+                 if 3 <# tg then GT
+                 else case b of
+                         K3 ... -> ...eq_rhs(K3)....
+                         _      -> LT
+
+* To make eq_rhs(K), which knows that
+    a = K a1 .. av
+    b = K b1 .. bv
+  we just want to compare (a1,b1) then (a2,b2) etc.
+  Take care on the last field to tail-call into comparing av,bv
+
+* To make nullary_rhs generate this
+     case con2tag a of a# ->
+     case con2tag b of ->
+     a# `compare` b#
+
+Several special cases:
+
+* Two or fewer nullary constructors: don't generate nullary_rhs
+
+* Be careful about unlifted comparisons.  When comparing unboxed
+  values we can't call the overloaded functions.
+  See function unliftedOrdOp
+
+Note [Game plan for deriving Ord]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's a bad idea to define only 'compare', and build the other binary
+comparisons on top of it; see #2130, #4019.  Reason: we don't
+want to laboriously make a three-way comparison, only to extract a
+binary result, something like this:
+     (>) (I# x) (I# y) = case <# x y of
+                            True -> False
+                            False -> case ==# x y of
+                                       True  -> False
+                                       False -> True
+
+This being said, we can get away with generating full code only for
+'compare' and '<' thus saving us generation of other three operators.
+Other operators can be cheaply expressed through '<':
+a <= b = not $ b < a
+a > b = b < a
+a >= b = not $ a < b
+
+So for sufficiently small types (few constructors, or all nullary)
+we generate all methods; for large ones we just use 'compare'.
+
+-}
+
+data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
+
+------------
+ordMethRdr :: OrdOp -> RdrName
+ordMethRdr op
+  = case op of
+       OrdCompare -> compare_RDR
+       OrdLT      -> lt_RDR
+       OrdLE      -> le_RDR
+       OrdGE      -> ge_RDR
+       OrdGT      -> gt_RDR
+
+------------
+ltResult :: OrdOp -> LHsExpr GhcPs
+-- Knowing a<b, what is the result for a `op` b?
+ltResult OrdCompare = ltTag_Expr
+ltResult OrdLT      = true_Expr
+ltResult OrdLE      = true_Expr
+ltResult OrdGE      = false_Expr
+ltResult OrdGT      = false_Expr
+
+------------
+eqResult :: OrdOp -> LHsExpr GhcPs
+-- Knowing a=b, what is the result for a `op` b?
+eqResult OrdCompare = eqTag_Expr
+eqResult OrdLT      = false_Expr
+eqResult OrdLE      = true_Expr
+eqResult OrdGE      = true_Expr
+eqResult OrdGT      = false_Expr
+
+------------
+gtResult :: OrdOp -> LHsExpr GhcPs
+-- Knowing a>b, what is the result for a `op` b?
+gtResult OrdCompare = gtTag_Expr
+gtResult OrdLT      = false_Expr
+gtResult OrdLE      = false_Expr
+gtResult OrdGE      = true_Expr
+gtResult OrdGT      = true_Expr
+
+------------
+gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon = do
+    dflags <- getDynFlags
+    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
+      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
+           , emptyBag)
+      else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
+           , aux_binds)
+  where
+    aux_binds | single_con_type = emptyBag
+              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+
+        -- Note [Game plan for deriving Ord]
+    other_ops dflags
+      | (last_tag - first_tag) <= 2     -- 1-3 constructors
+        || null non_nullary_cons        -- Or it's an enumeration
+      = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]
+      | otherwise
+      = emptyBag
+
+    negate_expr = nlHsApp (nlHsVar not_RDR)
+    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
+    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
+        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
+    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
+
+    get_tag con = dataConTag con - fIRST_TAG
+        -- We want *zero-based* tags, because that's what
+        -- con2Tag returns (generated by untag_Expr)!
+
+    tycon_data_cons = tyConDataCons tycon
+    single_con_type = isSingleton tycon_data_cons
+    (first_con : _) = tycon_data_cons
+    (last_con : _)  = reverse tycon_data_cons
+    first_tag       = get_tag first_con
+    last_tag        = get_tag last_con
+
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
+
+
+    mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
+    -- Returns a binding   op a b = ... compares a and b according to op ....
+    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
+                                        (mkOrdOpRhs dflags op)
+
+    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
+    mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op
+      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
+      = nlHsCase (nlHsVar a_RDR) $
+        map (mkOrdOpAlt dflags op) tycon_data_cons
+        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
+        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
+
+      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
+      = mkTagCmp dflags op
+
+      | otherwise                -- Mixed nullary and non-nullary
+      = nlHsCase (nlHsVar a_RDR) $
+        (map (mkOrdOpAlt dflags op) non_nullary_cons
+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])
+
+
+    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
+                  -> LMatch GhcPs (LHsExpr GhcPs)
+    -- Make the alternative  (Ki a1 a2 .. av ->
+    mkOrdOpAlt dflags op data_con
+      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
+                    (mkInnerRhs dflags op data_con)
+      where
+        as_needed    = take (dataConSourceArity data_con) as_RDRs
+        data_con_RDR = getRdrName data_con
+
+    mkInnerRhs dflags op data_con
+      | single_con_type
+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
+
+      | tag == first_tag
+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
+      | tag == last_tag
+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
+
+      | tag == first_tag + 1
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
+                                             (gtResult op)
+                                 , mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
+      | tag == last_tag - 1
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
+                                             (ltResult op)
+                                 , mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
+
+      | tag > last_tag `div` 2  -- lower range is larger
+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
+               (gtResult op) $  -- Definitely GT
+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
+
+      | otherwise               -- upper range is larger
+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
+               (ltResult op) $  -- Definitely LT
+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
+      where
+        tag     = get_tag data_con
+        tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))
+
+    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
+    -- First argument 'a' known to be built with K
+    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
+    mkInnerEqAlt op data_con
+      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
+        mkCompareFields op (dataConOrigArgTys data_con)
+      where
+        data_con_RDR = getRdrName data_con
+        bs_needed    = take (dataConSourceArity data_con) bs_RDRs
+
+    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
+    -- Both constructors known to be nullary
+    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
+    mkTagCmp dflags op =
+      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
+        unliftedOrdOp intPrimTy op ah_RDR bh_RDR
+
+mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
+-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
+-- where the ai,bi have the given types
+mkCompareFields op tys
+  = go tys as_RDRs bs_RDRs
+  where
+    go []   _      _          = eqResult op
+    go [ty] (a:_)  (b:_)
+      | isUnliftedType ty     = unliftedOrdOp ty op a b
+      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
+    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
+                                  (ltResult op)
+                                  (go tys as bs)
+                                  (gtResult op)
+    go _ _ _ = panic "mkCompareFields"
+
+    -- (mk_compare ty a b) generates
+    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
+    -- but with suitable special cases for
+    mk_compare ty a b lt eq gt
+      | isUnliftedType ty
+      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
+      | otherwise
+      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
+          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
+           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
+           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
+      where
+        a_expr = nlHsVar a
+        b_expr = nlHsVar b
+        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
+
+unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
+unliftedOrdOp ty op a b
+  = case op of
+       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
+                                     ltTag_Expr eqTag_Expr gtTag_Expr
+       OrdLT      -> wrap lt_op
+       OrdLE      -> wrap le_op
+       OrdGE      -> wrap ge_op
+       OrdGT      -> wrap gt_op
+  where
+   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
+   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
+   a_expr = nlHsVar a
+   b_expr = nlHsVar b
+
+unliftedCompare :: RdrName -> RdrName
+                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to cmpare
+                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+                                                    -- Three results
+                -> LHsExpr GhcPs
+-- Return (if a < b then lt else if a == b then eq else gt)
+unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
+  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
+                        -- Test (<) first, not (==), because the latter
+                        -- is true less often, so putting it first would
+                        -- mean more tests (dynamically)
+        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
+  where
+    ascribeBool e = nlExprWithTySig e boolTy
+
+nlConWildPat :: DataCon -> LPat GhcPs
+-- The pattern (K {})
+nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
+                                   (RecCon (HsRecFields { rec_flds = []
+                                                        , rec_dotdot = Nothing })))
+
+{-
+************************************************************************
+*                                                                      *
+        Enum instances
+*                                                                      *
+************************************************************************
+
+@Enum@ can only be derived for enumeration types.  For a type
+\begin{verbatim}
+data Foo ... = N1 | N2 | ... | Nn
+\end{verbatim}
+
+we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
+@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
+
+\begin{verbatim}
+instance ... Enum (Foo ...) where
+    succ x   = toEnum (1 + fromEnum x)
+    pred x   = toEnum (fromEnum x - 1)
+
+    toEnum i = tag2con_Foo i
+
+    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
+
+    -- or, really...
+    enumFrom a
+      = case con2tag_Foo a of
+          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
+
+   enumFromThen a b
+     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
+
+    -- or, really...
+    enumFromThen a b
+      = case con2tag_Foo a of { a# ->
+        case con2tag_Foo b of { b# ->
+        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
+        }}
+\end{verbatim}
+
+For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
+-}
+
+gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon = do
+    dflags <- getDynFlags
+    return (method_binds dflags, aux_binds)
+  where
+    method_binds dflags = listToBag
+      [ succ_enum      dflags
+      , pred_enum      dflags
+      , to_enum        dflags
+      , enum_from      dflags
+      , enum_from_then dflags
+      , from_enum      dflags
+      ]
+    aux_binds = listToBag $ map DerivAuxBind
+                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
+
+    occ_nm = getOccString tycon
+
+    succ_enum dflags
+      = mk_easy_FunBind loc succ_RDR [a_Pat] $
+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
+                               nlHsVarApps intDataCon_RDR [ah_RDR]])
+             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
+                                        nlHsIntLit 1]))
+
+    pred_enum dflags
+      = mk_easy_FunBind loc pred_RDR [a_Pat] $
+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
+                               nlHsVarApps intDataCon_RDR [ah_RDR]])
+             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+                      (nlHsApps plus_RDR
+                            [ nlHsVarApps intDataCon_RDR [ah_RDR]
+                            , nlHsLit (HsInt noExt
+                                                (mkIntegralLit (-1 :: Int)))]))
+
+    to_enum dflags
+      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
+        nlHsIf (nlHsApps and_RDR
+                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
+                 nlHsApps le_RDR [ nlHsVar a_RDR
+                                 , nlHsVar (maxtag_RDR dflags tycon)]])
+             (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
+             (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
+
+    enum_from dflags
+      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          nlHsApps map_RDR
+                [nlHsVar (tag2con_RDR dflags tycon),
+                 nlHsPar (enum_from_to_Expr
+                            (nlHsVarApps intDataCon_RDR [ah_RDR])
+                            (nlHsVar (maxtag_RDR dflags tycon)))]
+
+    enum_from_then dflags
+      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
+            nlHsPar (enum_from_then_to_Expr
+                    (nlHsVarApps intDataCon_RDR [ah_RDR])
+                    (nlHsVarApps intDataCon_RDR [bh_RDR])
+                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
+                                               nlHsVarApps intDataCon_RDR [bh_RDR]])
+                           (nlHsIntLit 0)
+                           (nlHsVar (maxtag_RDR dflags tycon))
+                           ))
+
+    from_enum dflags
+      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          (nlHsVarApps intDataCon_RDR [ah_RDR])
+
+{-
+************************************************************************
+*                                                                      *
+        Bounded instances
+*                                                                      *
+************************************************************************
+-}
+
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc tycon
+  | isEnumerationTyCon tycon
+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
+  | otherwise
+  = ASSERT(isSingleton data_cons)
+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    ----- enum-flavored: ---------------------------
+    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
+    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
+
+    data_con_1     = head data_cons
+    data_con_N     = last data_cons
+    data_con_1_RDR = getRdrName data_con_1
+    data_con_N_RDR = getRdrName data_con_N
+
+    ----- single-constructor-flavored: -------------
+    arity          = dataConSourceArity data_con_1
+
+    min_bound_1con = mkHsVarBind loc minBound_RDR $
+                     nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)
+    max_bound_1con = mkHsVarBind loc maxBound_RDR $
+                     nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)
+
+{-
+************************************************************************
+*                                                                      *
+        Ix instances
+*                                                                      *
+************************************************************************
+
+Deriving @Ix@ is only possible for enumeration types and
+single-constructor types.  We deal with them in turn.
+
+For an enumeration type, e.g.,
+\begin{verbatim}
+    data Foo ... = N1 | N2 | ... | Nn
+\end{verbatim}
+things go not too differently from @Enum@:
+\begin{verbatim}
+instance ... Ix (Foo ...) where
+    range (a, b)
+      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
+
+    -- or, really...
+    range (a, b)
+      = case (con2tag_Foo a) of { a# ->
+        case (con2tag_Foo b) of { b# ->
+        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
+        }}
+
+    -- Generate code for unsafeIndex, because using index leads
+    -- to lots of redundant range tests
+    unsafeIndex c@(a, b) d
+      = case (con2tag_Foo d -# con2tag_Foo a) of
+               r# -> I# r#
+
+    inRange (a, b) c
+      = let
+            p_tag = con2tag_Foo c
+        in
+        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
+
+    -- or, really...
+    inRange (a, b) c
+      = case (con2tag_Foo a)   of { a_tag ->
+        case (con2tag_Foo b)   of { b_tag ->
+        case (con2tag_Foo c)   of { c_tag ->
+        if (c_tag >=# a_tag) then
+          c_tag <=# b_tag
+        else
+          False
+        }}}
+\end{verbatim}
+(modulo suitable case-ification to handle the unlifted tags)
+
+For a single-constructor type (NB: this includes all tuples), e.g.,
+\begin{verbatim}
+    data Foo ... = MkFoo a b Int Double c c
+\end{verbatim}
+we follow the scheme given in Figure~19 of the Haskell~1.2 report
+(p.~147).
+-}
+
+gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+
+gen_Ix_binds loc tycon = do
+    dflags <- getDynFlags
+    return $ if isEnumerationTyCon tycon
+      then (enum_ixes dflags, listToBag $ map DerivAuxBind
+                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
+      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+  where
+    --------------------------------------------------------------
+    enum_ixes dflags = listToBag
+      [ enum_range   dflags
+      , enum_index   dflags
+      , enum_inRange dflags
+      ]
+
+    enum_range dflags
+      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
+              nlHsPar (enum_from_to_Expr
+                        (nlHsVarApps intDataCon_RDR [ah_RDR])
+                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
+
+    enum_index dflags
+      = mk_easy_FunBind loc unsafeIndex_RDR
+                [noLoc (AsPat noExt (noLoc c_RDR)
+                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
+                                d_Pat] (
+           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
+           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
+           let
+                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
+           in
+           nlHsCase
+             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
+             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
+           ))
+        )
+
+    -- This produces something like `(ch >= ah) && (ch <= bh)`
+    enum_inRange dflags
+      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
+          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
+          -- This used to use `if`, which interacts badly with RebindableSyntax.
+          -- See #11396.
+          nlHsApps and_RDR
+              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
+              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
+              ]
+          )))
+
+    --------------------------------------------------------------
+    single_con_ixes
+      = listToBag [single_con_range, single_con_index, single_con_inRange]
+
+    data_con
+      = case tyConSingleDataCon_maybe tycon of -- just checking...
+          Nothing -> panic "get_Ix_binds"
+          Just dc -> dc
+
+    con_arity    = dataConSourceArity data_con
+    data_con_RDR = getRdrName data_con
+
+    as_needed = take con_arity as_RDRs
+    bs_needed = take con_arity bs_RDRs
+    cs_needed = take con_arity cs_RDRs
+
+    con_pat  xs  = nlConVarPat data_con_RDR xs
+    con_expr     = nlHsVarApps data_con_RDR cs_needed
+
+    --------------------------------------------------------------
+    single_con_range
+      = mk_easy_FunBind loc range_RDR
+          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
+        noLoc (mkHsComp ListComp stmts con_expr)
+      where
+        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
+
+        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
+                                 (nlHsApp (nlHsVar range_RDR)
+                                          (mkLHsVarTuple [a,b]))
+
+    ----------------
+    single_con_index
+      = mk_easy_FunBind loc unsafeIndex_RDR
+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
+                 con_pat cs_needed]
+        -- We need to reverse the order we consider the components in
+        -- so that
+        --     range (l,u) !! index (l,u) i == i   -- when i is in range
+        -- (from http://haskell.org/onlinereport/ix.html) holds.
+                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
+      where
+        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
+        mk_index []        = nlHsIntLit 0
+        mk_index [(l,u,i)] = mk_one l u i
+        mk_index ((l,u,i) : rest)
+          = genOpApp (
+                mk_one l u i
+            ) plus_RDR (
+                genOpApp (
+                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)
+                             (mkLHsVarTuple [l,u]))
+                ) times_RDR (mk_index rest)
+           )
+        mk_one l u i
+          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
+
+    ------------------
+    single_con_inRange
+      = mk_easy_FunBind loc inRange_RDR
+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
+                 con_pat cs_needed] $
+          if con_arity == 0
+             -- If the product type has no fields, inRange is trivially true
+             -- (see #12853).
+             then true_Expr
+             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
+                    as_needed bs_needed cs_needed)
+      where
+        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
+
+{-
+************************************************************************
+*                                                                      *
+        Read instances
+*                                                                      *
+************************************************************************
+
+Example
+
+  infix 4 %%
+  data T = Int %% Int
+         | T1 { f1 :: Int }
+         | T2 T
+
+instance Read T where
+  readPrec =
+    parens
+    ( prec 4 (
+        do x <- ReadP.step Read.readPrec
+           expectP (Symbol "%%")
+           y <- ReadP.step Read.readPrec
+           return (x %% y))
+      +++
+      prec (appPrec+1) (
+        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
+        -- Record construction binds even more tightly than application
+        do expectP (Ident "T1")
+           expectP (Punc '{')
+           x          <- Read.readField "f1" (ReadP.reset readPrec)
+           expectP (Punc '}')
+           return (T1 { f1 = x }))
+      +++
+      prec appPrec (
+        do expectP (Ident "T2")
+           x <- ReadP.step Read.readPrec
+           return (T2 x))
+    )
+
+  readListPrec = readListPrecDefault
+  readList     = readListDefault
+
+
+Note [Use expectP]
+~~~~~~~~~~~~~~~~~~
+Note that we use
+   expectP (Ident "T1")
+rather than
+   Ident "T1" <- lexP
+The latter desugares to inline code for matching the Ident and the
+string, and this can be very voluminous. The former is much more
+compact.  Cf #7258, although that also concerned non-linearity in
+the occurrence analyser, a separate issue.
+
+Note [Read for empty data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we get for this?  (#7931)
+   data Emp deriving( Read )   -- No data constructors
+
+Here we want
+  read "[]" :: [Emp]   to succeed, returning []
+So we do NOT want
+   instance Read Emp where
+     readPrec = error "urk"
+Rather we want
+   instance Read Emp where
+     readPred = pfail   -- Same as choose []
+
+Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
+These instances are also useful for Read (Either Int Emp), where
+we want to be able to parse (Left 3) just fine.
+-}
+
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+               -> (LHsBinds GhcPs, BagDerivStuff)
+
+gen_Read_binds get_fixity loc tycon
+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
+  where
+    -----------------------------------------------------------------------
+    default_readlist
+        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
+
+    default_readlistprec
+        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
+    -----------------------------------------------------------------------
+
+    data_cons = tyConDataCons tycon
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
+
+    read_prec = mkHsVarBind loc readPrec_RDR rhs
+      where
+        rhs | null data_cons -- See Note [Read for empty data types]
+            = nlHsVar pfail_RDR
+            | otherwise
+            = nlHsApp (nlHsVar parens_RDR)
+                      (foldr1 mk_alt (read_nullary_cons ++
+                                      read_non_nullary_cons))
+
+    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
+
+    read_nullary_cons
+      = case nullary_cons of
+            []    -> []
+            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
+            _     -> [nlHsApp (nlHsVar choose_RDR)
+                              (nlList (map mk_pair nullary_cons))]
+        -- NB For operators the parens around (:=:) are matched by the
+        -- enclosing "parens" call, so here we must match the naked
+        -- data_con_str con
+
+    match_con con | isSym con_str = [symbol_pat con_str]
+                  | otherwise     = ident_h_pat  con_str
+                  where
+                    con_str = data_con_str con
+        -- For nullary constructors we must match Ident s for normal constrs
+        -- and   Symbol s   for operators
+
+    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
+                                  result_expr con []]
+
+    read_non_nullary_con data_con
+      | is_infix  = mk_parser infix_prec  infix_stmts  body
+      | is_record = mk_parser record_prec record_stmts body
+--              Using these two lines instead allows the derived
+--              read for infix and record bindings to read the prefix form
+--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
+--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
+      | otherwise = prefix_parser
+      where
+        body = result_expr data_con as_needed
+        con_str = data_con_str data_con
+
+        prefix_parser = mk_parser prefix_prec prefix_stmts body
+
+        read_prefix_con
+            | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
+            | otherwise     = ident_h_pat con_str
+
+        read_infix_con
+            | isSym con_str = [symbol_pat con_str]
+            | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
+
+        prefix_stmts            -- T a b c
+          = read_prefix_con ++ read_args
+
+        infix_stmts             -- a %% b, or  a `T` b
+          = [read_a1]
+            ++ read_infix_con
+            ++ [read_a2]
+
+        record_stmts            -- T { f1 = a, f2 = b }
+          = read_prefix_con
+            ++ [read_punc "{"]
+            ++ concat (intersperse [read_punc ","] field_stmts)
+            ++ [read_punc "}"]
+
+        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
+
+        con_arity    = dataConSourceArity data_con
+        labels       = map flLabel $ dataConFieldLabels data_con
+        dc_nm        = getName data_con
+        is_infix     = dataConIsInfix data_con
+        is_record    = labels `lengthExceeds` 0
+        as_needed    = take con_arity as_RDRs
+        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
+        (read_a1:read_a2:_) = read_args
+
+        prefix_prec = appPrecedence
+        infix_prec  = getPrecedence get_fixity dc_nm
+        record_prec = appPrecedence + 1 -- Record construction binds even more tightly
+                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
+
+    ------------------------------------------------------------------------
+    --          Helpers
+    ------------------------------------------------------------------------
+    mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2
+    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })
+                                           , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+    con_app con as     = nlHsVarApps (getRdrName con) as                -- con as
+    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
+
+    -- For constructors and field labels ending in '#', we hackily
+    -- let the lexer generate two tokens, and look for both in sequence
+    -- Thus [Ident "I"; Symbol "#"].  See #5041
+    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
+                  | otherwise                    = [ ident_pat s ]
+
+    bindLex pat  = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))  -- expectP p
+                   -- See Note [Use expectP]
+    ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")
+    symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")
+    read_punc c  = bindLex $ nlHsApps punc_RDR   [nlHsLit (mkHsString c)]  -- expectP (Punc "<")
+
+    data_con_str con = occNameString (getOccName con)
+
+    read_arg a ty = ASSERT( not (isUnliftedType ty) )
+                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
+
+    -- When reading field labels we might encounter
+    --      a  = 3
+    --      _a = 3
+    -- or   (#) = 4
+    -- Note the parens!
+    read_field lbl a =
+        [noLoc
+          (mkBindStmt
+            (nlVarPat a)
+            (nlHsApp
+              read_field
+              (nlHsVarApps reset_RDR [readPrec_RDR])
+            )
+          )
+        ]
+        where
+          lbl_str = unpackFS lbl
+          mk_read_field read_field_rdr lbl
+              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
+          read_field
+              | isSym lbl_str
+              = mk_read_field readSymField_RDR lbl_str
+              | Just (ss, '#') <- snocView lbl_str -- #14918
+              = mk_read_field readFieldHash_RDR ss
+              | otherwise
+              = mk_read_field readField_RDR lbl_str
+
+{-
+************************************************************************
+*                                                                      *
+        Show instances
+*                                                                      *
+************************************************************************
+
+Example
+
+    infixr 5 :^:
+
+    data Tree a =  Leaf a  |  Tree a :^: Tree a
+
+    instance (Show a) => Show (Tree a) where
+
+        showsPrec d (Leaf m) = showParen (d > app_prec) showStr
+          where
+             showStr = showString "Leaf " . showsPrec (app_prec+1) m
+
+        showsPrec d (u :^: v) = showParen (d > up_prec) showStr
+          where
+             showStr = showsPrec (up_prec+1) u .
+                       showString " :^: "      .
+                       showsPrec (up_prec+1) v
+                -- Note: right-associativity of :^: ignored
+
+    up_prec  = 5    -- Precedence of :^:
+    app_prec = 10   -- Application has precedence one more than
+                    -- the most tightly-binding operator
+-}
+
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+               -> (LHsBinds GhcPs, BagDerivStuff)
+
+gen_Show_binds get_fixity loc tycon
+  = (unitBag shows_prec, emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+    shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
+    comma_space = nlHsVar showCommaSpace_RDR
+
+    pats_etc data_con
+      | nullary_con =  -- skip the showParen junk...
+         ASSERT(null bs_needed)
+         ([nlWildPat, con_pat], mk_showString_app op_con_str)
+      | otherwise   =
+         ([a_Pat, con_pat],
+          showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
+                         (HsInt noExt (mkIntegralLit con_prec_plus_one))))
+                         (nlHsPar (nested_compose_Expr show_thingies)))
+        where
+             data_con_RDR  = getRdrName data_con
+             con_arity     = dataConSourceArity data_con
+             bs_needed     = take con_arity bs_RDRs
+             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
+             con_pat       = nlConVarPat data_con_RDR bs_needed
+             nullary_con   = con_arity == 0
+             labels        = map flLabel $ dataConFieldLabels data_con
+             lab_fields    = length labels
+             record_syntax = lab_fields > 0
+
+             dc_nm          = getName data_con
+             dc_occ_nm      = getOccName data_con
+             con_str        = occNameString dc_occ_nm
+             op_con_str     = wrapOpParens con_str
+             backquote_str  = wrapOpBackquotes con_str
+
+             show_thingies
+                | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
+                | record_syntax = mk_showString_app (op_con_str ++ " {") :
+                                  show_record_args ++ [mk_showString_app "}"]
+                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
+
+             show_label l = mk_showString_app (nm ++ " = ")
+                        -- Note the spaces around the "=" sign.  If we
+                        -- don't have them then we get Foo { x=-1 } and
+                        -- the "=-" parses as a single lexeme.  Only the
+                        -- space after the '=' is necessary, but it
+                        -- seems tidier to have them both sides.
+                 where
+                   nm       = wrapOpParens (unpackFS l)
+
+             show_args               = zipWith show_arg bs_needed arg_tys
+             (show_arg1:show_arg2:_) = show_args
+             show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
+
+                -- Assumption for record syntax: no of fields == no of
+                -- labelled fields (and in same order)
+             show_record_args = concat $
+                                intersperse [comma_space] $
+                                [ [show_label lbl, arg]
+                                | (lbl,arg) <- zipEqual "gen_Show_binds"
+                                                        labels show_args ]
+
+             show_arg :: RdrName -> Type -> LHsExpr GhcPs
+             show_arg b arg_ty
+                 | isUnliftedType arg_ty
+                 -- See Note [Deriving and unboxed types] in TcDerivInfer
+                 = with_conv $
+                    nlHsApps compose_RDR
+                        [mk_shows_app boxed_arg, mk_showString_app postfixMod]
+                 | otherwise
+                 = mk_showsPrec_app arg_prec arg
+               where
+                 arg        = nlHsVar b
+                 boxed_arg  = box "Show" arg arg_ty
+                 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
+                 with_conv expr
+                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
+                        nested_compose_Expr
+                            [ mk_showString_app ("(" ++ conv ++ " ")
+                            , expr
+                            , mk_showString_app ")"
+                            ]
+                    | otherwise = expr
+
+                -- Fixity stuff
+             is_infix = dataConIsInfix data_con
+             con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
+             arg_prec | record_syntax = 0  -- Record fields don't need parens
+                      | otherwise     = con_prec_plus_one
+
+wrapOpParens :: String -> String
+wrapOpParens s | isSym s   = '(' : s ++ ")"
+               | otherwise = s
+
+wrapOpBackquotes :: String -> String
+wrapOpBackquotes s | isSym s   = s
+                   | otherwise = '`' : s ++ "`"
+
+isSym :: String -> Bool
+isSym ""      = False
+isSym (c : _) = startsVarSym c || startsConSym c
+
+-- | showString :: String -> ShowS
+mk_showString_app :: String -> LHsExpr GhcPs
+mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
+
+-- | showsPrec :: Show a => Int -> a -> ShowS
+mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
+mk_showsPrec_app p x
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]
+
+-- | shows :: Show a => a -> ShowS
+mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
+mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
+
+getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
+getPrec is_infix get_fixity nm
+  | not is_infix   = appPrecedence
+  | otherwise      = getPrecedence get_fixity nm
+
+appPrecedence :: Integer
+appPrecedence = fromIntegral maxPrecedence + 1
+  -- One more than the precedence of the most
+  -- tightly-binding operator
+
+getPrecedence :: (Name -> Fixity) -> Name -> Integer
+getPrecedence get_fixity nm
+   = case get_fixity nm of
+        Fixity _ x _assoc -> fromIntegral x
+          -- NB: the Report says that associativity is not taken
+          --     into account for either Read or Show; hence we
+          --     ignore associativity here
+
+{-
+************************************************************************
+*                                                                      *
+        Data instances
+*                                                                      *
+************************************************************************
+
+From the data type
+
+  data T a b = T1 a b | T2
+
+we generate
+
+  $cT1 = mkDataCon $dT "T1" Prefix
+  $cT2 = mkDataCon $dT "T2" Prefix
+  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
+  -- the [] is for field labels.
+
+  instance (Data a, Data b) => Data (T a b) where
+    gfoldl k z (T1 a b) = z T `k` a `k` b
+    gfoldl k z T2           = z T2
+    -- ToDo: add gmapT,Q,M, gfoldr
+
+    gunfold k z c = case conIndex c of
+                        I# 1# -> k (k (z T1))
+                        I# 2# -> z T2
+
+    toConstr (T1 _ _) = $cT1
+    toConstr T2       = $cT2
+
+    dataTypeOf _ = $dT
+
+    dataCast1 = gcast1   -- If T :: * -> *
+    dataCast2 = gcast2   -- if T :: * -> * -> *
+-}
+
+gen_Data_binds :: SrcSpan
+               -> TyCon                 -- For data families, this is the
+                                        --  *representation* TyCon
+               -> TcM (LHsBinds GhcPs,  -- The method bindings
+                       BagDerivStuff)   -- Auxiliary bindings
+gen_Data_binds loc rep_tc
+  = do { dflags  <- getDynFlags
+
+       -- Make unique names for the data type and constructor
+       -- auxiliary bindings.  Start with the name of the TyCon/DataCon
+       -- but that might not be unique: see #12245.
+       ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
+       ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
+                         (tyConDataCons rep_tc)
+       ; let dt_rdr  = mkRdrUnqual dt_occ
+             dc_rdrs = map mkRdrUnqual dc_occs
+
+       -- OK, now do the work
+       ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
+
+gen_data :: DynFlags -> RdrName -> [RdrName]
+         -> SrcSpan -> TyCon
+         -> (LHsBinds GhcPs,      -- The method bindings
+             BagDerivStuff)       -- Auxiliary bindings
+gen_data dflags data_type_name constr_names loc rep_tc
+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
+     `unionBags` gcast_binds,
+                -- Auxiliary definitions: the data type and constructors
+     listToBag ( genDataTyCon
+               : zipWith genDataDataCon data_cons constr_names ) )
+  where
+    data_cons  = tyConDataCons rep_tc
+    n_cons     = length data_cons
+    one_constr = n_cons == 1
+    genDataTyCon :: DerivStuff
+    genDataTyCon        --  $dT
+      = DerivHsBind (mkHsVarBind loc data_type_name rhs,
+                     L loc (TypeSig noExt [L loc data_type_name] sig_ty))
+
+    sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
+    rhs    = nlHsVar mkDataType_RDR
+             `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+             `nlHsApp` nlList (map nlHsVar constr_names)
+
+    genDataDataCon :: DataCon -> RdrName -> DerivStuff
+    genDataDataCon dc constr_name       --  $cT1 etc
+      = DerivHsBind (mkHsVarBind loc constr_name rhs,
+                     L loc (TypeSig noExt [L loc constr_name] sig_ty))
+      where
+        sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
+        rhs      = nlHsApps mkConstr_RDR constr_args
+
+        constr_args
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag
+               nlHsVar (data_type_name)                     -- DataType
+             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name
+             , nlList  labels                               -- Field labels
+             , nlHsVar fixity ]                             -- Fixity
+
+        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)
+                       (dataConFieldLabels dc)
+        dc_occ   = getOccName dc
+        is_infix = isDataSymOcc dc_occ
+        fixity | is_infix  = infix_RDR
+               | otherwise = prefix_RDR
+
+        ------------ gfoldl
+    gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
+
+    gfoldl_eqn con
+      = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
+                   foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
+                   where
+                     con_name ::  RdrName
+                     con_name = getRdrName con
+                     as_needed = take (dataConSourceArity con) as_RDRs
+                     mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
+
+        ------------ gunfold
+    gunfold_bind = mk_easy_FunBind loc
+                     gunfold_RDR
+                     [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
+                     gunfold_rhs
+
+    gunfold_rhs
+        | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
+        | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
+                                (map gunfold_alt data_cons)
+
+    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
+    mk_unfold_rhs dc = foldr nlHsApp
+                           (z_Expr `nlHsApp` nlHsVar (getRdrName dc))
+                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
+
+    mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
+                        -- redundant test, and annoying warning
+      | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
+      | otherwise = nlConPat intDataCon_RDR
+                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
+      where
+        tag = dataConTag dc
+
+        ------------ toConstr
+    toCon_bind = mkFunBindEC 1 loc toConstr_RDR id
+                     (zipWith to_con_eqn data_cons constr_names)
+    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
+
+        ------------ dataTypeOf
+    dataTypeOf_bind = mk_easy_FunBind
+                        loc
+                        dataTypeOf_RDR
+                        [nlWildPat]
+                        (nlHsVar data_type_name)
+
+        ------------ gcast1/2
+        -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *
+        --               or    dataCast2 x = gcast2 s  -- if T :: * -> * -> *
+        -- (or nothing if T has neither of these two types)
+
+        -- But care is needed for data families:
+        -- If we have   data family D a
+        --              data instance D (a,b,c) = A | B deriving( Data )
+        -- and we want  instance ... => Data (D [(a,b,c)]) where ...
+        -- then we need     dataCast1 x = gcast1 x
+        -- because D :: * -> *
+        -- even though rep_tc has kind * -> * -> * -> *
+        -- Hence looking for the kind of fam_tc not rep_tc
+        -- See #4896
+    tycon_kind = case tyConFamInst_maybe rep_tc of
+                    Just (fam_tc, _) -> tyConKind fam_tc
+                    Nothing          -> tyConKind rep_tc
+    gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
+                | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
+                | otherwise                 = emptyBag
+    mk_gcast dataCast_RDR gcast_RDR
+      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
+                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
+
+
+kind1, kind2 :: Kind
+kind1 = liftedTypeKind `mkVisFunTy` liftedTypeKind
+kind2 = liftedTypeKind `mkVisFunTy` kind1
+
+gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
+    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
+    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
+    constr_RDR, dataType_RDR,
+    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
+    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
+    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
+    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
+    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
+    eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
+    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
+    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
+    extendWord8_RDR, extendInt8_RDR,
+    extendWord16_RDR, extendInt16_RDR :: RdrName
+gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
+gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
+toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
+dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
+dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
+dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
+gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
+gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
+mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")
+constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
+mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
+dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
+conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
+prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
+infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
+
+eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")
+ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")
+leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")
+gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")
+geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")
+
+eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")
+ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )
+leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
+gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
+geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
+
+eqInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqInt8#")
+ltInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltInt8#" )
+leInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leInt8#")
+gtInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtInt8#" )
+geInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geInt8#")
+
+eqInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt16#")
+ltInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt16#" )
+leInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt16#")
+gtInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt16#" )
+geInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt16#")
+
+eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
+ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
+leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
+gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
+geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
+
+eqWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqWord8#")
+ltWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltWord8#" )
+leWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "leWord8#")
+gtWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtWord8#" )
+geWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "geWord8#")
+
+eqWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord16#")
+ltWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord16#" )
+leWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord16#")
+gtWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord16#" )
+geWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord16#")
+
+eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
+ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
+leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
+gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")
+geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")
+
+eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")
+ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")
+leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")
+gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")
+geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")
+
+eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")
+ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )
+leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
+gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
+geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
+
+extendWord8_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord8#")
+extendInt8_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt8#")
+
+extendWord16_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord16#")
+extendInt16_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt16#")
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Lift instances
+*                                                                      *
+************************************************************************
+
+Example:
+
+    data Foo a = Foo a | a :^: a deriving Lift
+
+    ==>
+
+    instance (Lift a) => Lift (Foo a) where
+        lift (Foo a) = [| Foo a |]
+        lift ((:^:) u v) = [| (:^:) u v |]
+
+        liftTyped (Foo a) = [|| Foo a ||]
+        liftTyped ((:^:) u v) = [|| (:^:) u v ||]
+-}
+
+
+gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
+  where
+    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+                                 (map (pats_etc mk_exp) data_cons)
+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)
+                                 (map (pats_etc mk_texp) data_cons)
+
+    mk_exp = ExpBr NoExt
+    mk_texp = TExpBr NoExt
+    data_cons = tyConDataCons tycon
+
+    pats_etc mk_bracket data_con
+      = ([con_pat], lift_Expr)
+       where
+            con_pat      = nlConVarPat data_con_RDR as_needed
+            data_con_RDR = getRdrName data_con
+            con_arity    = dataConSourceArity data_con
+            as_needed    = take con_arity as_RDRs
+            lift_Expr    = noLoc (HsBracket NoExt (mk_bracket br_body))
+            br_body      = nlHsApps (Exact (dataConName data_con))
+                                    (map nlHsVar as_needed)
+
+{-
+************************************************************************
+*                                                                      *
+                     Newtype-deriving instances
+*                                                                      *
+************************************************************************
+
+Note [Newtype-deriving instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take every method in the original instance and `coerce` it to fit
+into the derived instance. We need type applications on the argument
+to `coerce` to make it obvious what instantiation of the method we're
+coercing from.  So from, say,
+
+  class C a b where
+    op :: forall c. a -> [b] -> c -> Int
+
+  newtype T x = MkT <rep-ty>
+
+  instance C a <rep-ty> => C a (T x) where
+    op = coerce @ (a -> [<rep-ty>] -> c -> Int)
+                @ (a -> [T x]      -> c -> Int)
+                op :: forall c. a -> [T x] -> c -> Int
+
+In addition to the type applications, we also have an explicit
+type signature on the entire RHS. This brings the method-bound variable
+`c` into scope over the two type applications.
+See Note [GND and QuantifiedConstraints] for more information on why this
+is important.
+
+Giving 'coerce' two explicitly-visible type arguments grants us finer control
+over how it should be instantiated. Recall
+
+  coerce :: Coercible a b => a -> b
+
+By giving it explicit type arguments we deal with the case where
+'op' has a higher rank type, and so we must instantiate 'coerce' with
+a polytype.  E.g.
+
+   class C a where op :: a -> forall b. b -> b
+   newtype T x = MkT <rep-ty>
+   instance C <rep-ty> => C (T x) where
+     op = coerce @ (<rep-ty> -> forall b. b -> b)
+                 @ (T x      -> forall b. b -> b)
+                op :: T x -> forall b. b -> b
+
+The use of type applications is crucial here. If we had tried using only
+explicit type signatures, like so:
+
+   instance C <rep-ty> => C (T x) where
+     op = coerce (op :: <rep-ty> -> forall b. b -> b)
+                     :: T x      -> forall b. b -> b
+
+Then GHC will attempt to deeply skolemize the two type signatures, which will
+wreak havoc with the Coercible solver. Therefore, we instead use type
+applications, which do not deeply skolemize and thus avoid this issue.
+The downside is that we currently require -XImpredicativeTypes to permit this
+polymorphic type instantiation, so we have to switch that flag on locally in
+TcDeriv.genInst. See #8503 for more discussion.
+
+Note [Newtype-deriving trickiness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#12768):
+  class C a where { op :: D a => a -> a }
+
+  instance C a  => C [a] where { op = opList }
+
+  opList :: (C a, D [a]) => [a] -> [a]
+  opList = ...
+
+Now suppose we try GND on this:
+  newtype N a = MkN [a] deriving( C )
+
+The GND is expecting to get an implementation of op for N by
+coercing opList, thus:
+
+  instance C a => C (N a) where { op = opN }
+
+  opN :: (C a, D (N a)) => N a -> N a
+  opN = coerce @([a]   -> [a])
+               @([N a] -> [N a]
+               opList :: D (N a) => [N a] -> [N a]
+
+But there is no reason to suppose that (D [a]) and (D (N a))
+are inter-coercible; these instances might completely different.
+So GHC rightly rejects this code.
+
+Note [GND and QuantifiedConstraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example from #15290:
+
+  class C m where
+    join :: m (m a) -> m a
+
+  newtype T m a = MkT (m a)
+
+  deriving instance
+    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+    C (T m)
+
+The code that GHC used to generate for this was:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(forall a.   m   (m a) ->   m a)
+                  @(forall a. T m (T m a) -> T m a)
+                  join
+
+This instantiates `coerce` at a polymorphic type, a form of impredicative
+polymorphism, so we're already on thin ice. And in fact the ice breaks,
+as we'll explain:
+
+The call to `coerce` gives rise to:
+
+  Coercible (forall a.   m   (m a) ->   m a)
+            (forall a. T m (T m a) -> T m a)
+
+And that simplified to the following implication constraint:
+
+  forall a <no-ev>. m (T m a) ~R# m (m a)
+
+But because this constraint is under a `forall`, inside a type, we have to
+prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
+*must* generate a term-level evidence binding in order to instantiate the
+quantified constraint! In response, GHC currently chooses not to use such
+a quantified constraint.
+See Note [Instances in no-evidence implications] in TcInteract.
+
+But this isn't the death knell for combining QuantifiedConstraints with GND.
+On the contrary, if we generate GND bindings in a slightly different way, then
+we can avoid this situation altogether. Instead of applying `coerce` to two
+polymorphic types, we instead let an explicit type signature do the polymorphic
+instantiation, and omit the `forall`s in the type applications.
+More concretely, we generate the following code instead:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(  m   (m a) ->   m a)
+                  @(T m (T m a) -> T m a)
+                  join :: forall a. T m (T m a) -> T m a
+
+Now the visible type arguments are both monotypes, so we need do any of this
+funny quantified constraint instantiation business.
+
+You might think that that second @(T m (T m a) -> T m a) argument is redundant
+in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
+signature, but in fact leaving it off will break this example (from the
+T15290d test case):
+
+  class C a where
+    c :: Int -> forall b. b -> a
+
+  instance C Int
+
+  instance C Age where
+    c = coerce @(Int -> forall b. b -> Int)
+               c :: Int -> forall b. b -> Age
+
+That is because the explicit type signature deeply skolemizes the forall-bound
+`b`, which wreaks havoc with the `Coercible` solver. An additional visible type
+argument of @(Int -> forall b. b -> Age) is enough to prevent this.
+
+Be aware that the use of an explicit type signature doesn't /solve/ this
+problem; it just makes it less likely to occur. For example, if a class has
+a truly higher-rank type like so:
+
+  class CProblem m where
+    op :: (forall b. ... (m b) ...) -> Int
+
+Then the same situation will arise again. But at least it won't arise for the
+common case of methods with ordinary, prenex-quantified types.
+
+Note [GND and ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We make an effort to make the code generated through GND be robust w.r.t.
+ambiguous type variables. As one example, consider the following example
+(from #15637):
+
+  class C a where f :: String
+  instance C () where f = "foo"
+  newtype T = T () deriving C
+
+A naïve attempt and generating a C T instance would be:
+
+  instance C T where
+    f = coerce @String @String f
+          :: String
+
+This isn't going to typecheck, however, since GHC doesn't know what to
+instantiate the type variable `a` with in the call to `f` in the method body.
+(Note that `f :: forall a. String`!) To compensate for the possibility of
+ambiguity here, we explicitly instantiate `a` like so:
+
+  instance C T where
+    f = coerce @String @String (f @())
+          :: String
+
+All better now.
+-}
+
+gen_Newtype_binds :: SrcSpan
+                  -> Class   -- the class being derived
+                  -> [TyVar] -- the tvs in the instance head (this includes
+                             -- the tvs from both the class types and the
+                             -- newtype itself)
+                  -> [Type]  -- instance head parameters (incl. newtype)
+                  -> Type    -- the representation type
+                  -> TcM (LHsBinds GhcPs, BagDerivStuff)
+-- See Note [Newtype-deriving instances]
+gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
+  = do let ats = classATs cls
+       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
+                    mapM mk_atf_inst ats
+       return ( listToBag $ map mk_bind (classMethods cls)
+              , listToBag $ map DerivFamInst atf_insts )
+  where
+    mk_bind :: Id -> LHsBind GhcPs
+    mk_bind meth_id
+      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
+                                          (mkPrefixFunRhs (L loc meth_RDR))
+                                          [] rhs_expr]
+      where
+        Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
+        (_, _, from_tau) = tcSplitSigmaTy from_ty
+        (_, _, to_tau)   = tcSplitSigmaTy to_ty
+
+        meth_RDR = getRdrName meth_id
+
+        rhs_expr = nlHsVar (getRdrName coerceId)
+                                      `nlHsAppType`     from_tau
+                                      `nlHsAppType`     to_tau
+                                      `nlHsApp`         meth_app
+                                      `nlExprWithTySig` to_ty
+
+        -- The class method, applied to all of the class instance types
+        -- (including the representation type) to avoid potential ambiguity.
+        -- See Note [GND and ambiguity]
+        meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $
+                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys
+                     -- Filter out any inferred arguments, since they can't be
+                     -- applied with visible type application.
+
+    mk_atf_inst :: TyCon -> TcM FamInst
+    mk_atf_inst fam_tc = do
+        rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
+                                           rep_lhs_tys
+        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
+                                    fam_tc rep_lhs_tys rep_rhs_ty
+        -- Check (c) from Note [GND and associated type families] in TcDeriv
+        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
+        newFamInst SynFamilyInst axiom
+      where
+        cls_tvs     = classTyVars cls
+        in_scope    = mkInScopeSet $ mkVarSet inst_tvs
+        lhs_env     = zipTyEnv cls_tvs inst_tys
+        lhs_subst   = mkTvSubst in_scope lhs_env
+        rhs_env     = zipTyEnv cls_tvs underlying_inst_tys
+        rhs_subst   = mkTvSubst in_scope rhs_env
+        fam_tvs     = tyConTyVars fam_tc
+        rep_lhs_tys = substTyVars lhs_subst fam_tvs
+        rep_rhs_tys = substTyVars rhs_subst fam_tvs
+        rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys
+        rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys
+        (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
+        rep_tvs'    = scopedSort rep_tvs
+        rep_cvs'    = scopedSort rep_cvs
+
+    -- Same as inst_tys, but with the last argument type replaced by the
+    -- representation type.
+    underlying_inst_tys :: [Type]
+    underlying_inst_tys = changeLast inst_tys rhs_ty
+
+nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)
+  where
+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
+
+nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty
+  where
+    hs_ty = mkLHsSigWcType (typeToLHsType s)
+
+mkCoerceClassMethEqn :: Class   -- the class being derived
+                     -> [TyVar] -- the tvs in the instance head (this includes
+                                -- the tvs from both the class types and the
+                                -- newtype itself)
+                     -> [Type]  -- instance head parameters (incl. newtype)
+                     -> Type    -- the representation type
+                     -> Id      -- the method to look at
+                     -> Pair Type
+-- See Note [Newtype-deriving instances]
+-- See also Note [Newtype-deriving trickiness]
+-- The pair is the (from_type, to_type), where to_type is
+-- the type of the method we are trying to get
+mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
+  = Pair (substTy rhs_subst user_meth_ty)
+         (substTy lhs_subst user_meth_ty)
+  where
+    cls_tvs = classTyVars cls
+    in_scope = mkInScopeSet $ mkVarSet inst_tvs
+    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
+    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
+    (_class_tvs, _class_constraint, user_meth_ty)
+      = tcSplitMethodTy (varType id)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
+*                                                                      *
+************************************************************************
+
+\begin{verbatim}
+data Foo ... = ...
+
+con2tag_Foo :: Foo ... -> Int#
+tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
+maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
+\end{verbatim}
+
+The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
+fiddling around.
+-}
+
+genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
+                  -> (LHsBind GhcPs, LSig GhcPs)
+genAuxBindSpec dflags loc (DerivCon2Tag tycon)
+  = (mkFunBindSE 0 loc rdr_name eqns,
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
+  where
+    rdr_name = con2tag_RDR dflags tycon
+
+    sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
+             mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
+             mkParentType tycon `mkVisFunTy` intPrimTy
+
+    lots_of_constructors = tyConFamilySize tycon > 8
+                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+                        -- but we don't do vectored returns any more.
+
+    eqns | lots_of_constructors = [get_tag_eqn]
+         | otherwise = map mk_eqn (tyConDataCons tycon)
+
+    get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
+
+    mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
+    mk_eqn con = ([nlWildConPat con],
+                  nlHsLit (HsIntPrim NoSourceText
+                                    (toInteger ((dataConTag con) - fIRST_TAG))))
+
+genAuxBindSpec dflags loc (DerivTag2Con tycon)
+  = (mkFunBindSE 0 loc rdr_name
+        [([nlConVarPat intDataCon_RDR [a_RDR]],
+           nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
+  where
+    sig_ty = mkLHsSigWcType $ L loc $
+             XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+             intTy `mkVisFunTy` mkParentType tycon
+
+    rdr_name = tag2con_RDR dflags tycon
+
+genAuxBindSpec dflags loc (DerivMaxTag tycon)
+  = (mkHsVarBind loc rdr_name rhs,
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
+  where
+    rdr_name = maxtag_RDR dflags tycon
+    sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
+    rhs = nlHsApp (nlHsVar intDataCon_RDR)
+                  (nlHsLit (HsIntPrim NoSourceText max_tag))
+    max_tag =  case (tyConDataCons tycon) of
+                 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
+
+type SeparateBagsDerivStuff =
+  -- AuxBinds and SYB bindings
+  ( Bag (LHsBind GhcPs, LSig GhcPs)
+  -- Extra family instances (used by Generic and DeriveAnyClass)
+  , Bag (FamInst) )
+
+genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
+genAuxBinds dflags loc b = genAuxBinds' b2 where
+  (b1,b2) = partitionBagWith splitDerivAuxBind b
+  splitDerivAuxBind (DerivAuxBind x) = Left x
+  splitDerivAuxBind  x               = Right x
+
+  rm_dups = foldrBag 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)
+                            , emptyBag )
+  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
+  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
+  f (DerivHsBind  b) = add1 b
+  f (DerivFamInst t) = add2 t
+
+  add1 x (a,b) = (x `consBag` a,b)
+  add2 x (a,b) = (a,x `consBag` b)
+
+mkParentType :: TyCon -> Type
+-- Turn the representation tycon of a family into
+-- a use of its family constructor
+mkParentType tc
+  = case tyConFamInst_maybe tc of
+       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
+       Just (fam_tc,tys) -> mkTyConApp fam_tc tys
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Utility bits for generating bindings}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that produces a stock error.
+mkFunBindSE :: Arity -> SrcSpan -> RdrName
+             -> [([LPat GhcPs], LHsExpr GhcPs)]
+             -> LHsBind GhcPs
+mkFunBindSE arity loc fun pats_and_exprs
+  = mkRdrFunBindSE arity (L loc fun) matches
+  where
+    matches = [mkMatch (mkPrefixFunRhs (L loc fun))
+                               (map (parenthesizePat appPrec) p) e
+                               (noLoc emptyLocalBinds)
+              | (p,e) <-pats_and_exprs]
+
+mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+             -> LHsBind GhcPs
+mkRdrFunBind fun@(L loc _fun_rdr) matches
+  = L loc (mkFunBind fun matches)
+
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that uses an empty case expression for the last
+-- argument that is passes to the given function to produce the right-hand
+-- side.
+mkFunBindEC :: Arity -> SrcSpan -> RdrName
+            -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+            -> [([LPat GhcPs], LHsExpr GhcPs)]
+            -> LHsBind GhcPs
+mkFunBindEC arity loc fun catch_all pats_and_exprs
+  = mkRdrFunBindEC arity catch_all (L loc fun) matches
+  where
+    matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
+                                (map (parenthesizePat appPrec) p) e
+                                (noLoc emptyLocalBinds)
+              | (p,e) <- pats_and_exprs ]
+
+-- | Produces a function binding. When no equations are given, it generates
+-- a binding of the given arity and an empty case expression
+-- for the last argument that it passes to the given function to produce
+-- the right-hand side.
+mkRdrFunBindEC :: Arity
+               -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+               -> Located RdrName
+               -> [LMatch GhcPs (LHsExpr GhcPs)]
+               -> LHsBind GhcPs
+mkRdrFunBindEC arity catch_all
+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
+ where
+   -- Catch-all eqn looks like
+   --     fmap _ z = case z of {}
+   -- or
+   --     traverse _ z = pure (case z of)
+   -- or
+   --     foldMap _ z = mempty
+   -- It's needed if there no data cons at all,
+   -- which can happen with -XEmptyDataDecls
+   -- See #4302
+   matches' = if null matches
+              then [mkMatch (mkPrefixFunRhs fun)
+                            (replicate (arity - 1) nlWildPat ++ [z_Pat])
+                            (catch_all $ nlHsCase z_Expr [])
+                            (noLoc emptyLocalBinds)]
+              else matches
+
+-- | Produces a function binding. When there are no equations, it generates
+-- a binding with the given arity that produces an error based on the name of
+-- the type of the last argument.
+mkRdrFunBindSE :: Arity -> Located RdrName ->
+                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
+mkRdrFunBindSE arity
+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
+ where
+   -- Catch-all eqn looks like
+   --     compare _ _ = error "Void compare"
+   -- It's needed if there no data cons at all,
+   -- which can happen with -XEmptyDataDecls
+   -- See #4302
+   matches' = if null matches
+              then [mkMatch (mkPrefixFunRhs fun)
+                            (replicate arity nlWildPat)
+                            (error_Expr str) (noLoc emptyLocalBinds)]
+              else matches
+   str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
+
+
+box ::         String           -- The class involved
+            -> LHsExpr GhcPs    -- The argument
+            -> Type             -- The argument type
+            -> LHsExpr GhcPs    -- Boxed version of the arg
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
+
+---------------------
+primOrdOps :: String    -- The class involved
+           -> Type      -- The type
+           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+primOrdOps str ty = assoc_ty_id str ordOpTbl ty
+
+ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
+ordOpTbl
+ =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR
+     , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
+    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR
+     , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
+    ,(int8PrimTy  , (ltInt8_RDR  , leInt8_RDR
+     , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))
+    ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR
+     , eqInt16_RDR , geInt16_RDR , gtInt16_RDR   ))
+    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR
+     , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
+    ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR
+     , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))
+    ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR
+     , eqWord16_RDR, geWord16_RDR, gtWord16_RDR  ))
+    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR
+     , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
+    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR
+     , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
+    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR
+     , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
+
+-- A mapping from a primitive type to a function that constructs its boxed
+-- version.
+-- NOTE: Int8#/Word8# will become Int/Word.
+boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+boxConTbl =
+    [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))
+    , (intPrimTy   , nlHsApp (nlHsVar $ getRdrName intDataCon))
+    , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
+    , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
+    , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
+    , (int8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt8_RDR))
+    , (word8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord8_RDR))
+    , (int16PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt16_RDR))
+    , (word16PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord16_RDR))
+    ]
+
+
+-- | A table of postfix modifiers for unboxed values.
+postfixModTbl :: [(Type, String)]
+postfixModTbl
+  = [(charPrimTy  , "#" )
+    ,(intPrimTy   , "#" )
+    ,(wordPrimTy  , "##")
+    ,(floatPrimTy , "#" )
+    ,(doublePrimTy, "##")
+    ,(int8PrimTy, "#")
+    ,(word8PrimTy, "##")
+    ,(int16PrimTy, "#")
+    ,(word16PrimTy, "##")
+    ]
+
+primConvTbl :: [(Type, String)]
+primConvTbl =
+    [ (int8PrimTy, "narrowInt8#")
+    , (word8PrimTy, "narrowWord8#")
+    , (int16PrimTy, "narrowInt16#")
+    , (word16PrimTy, "narrowWord16#")
+    ]
+
+litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+litConTbl
+  = [(charPrimTy  , nlHsApp (nlHsVar charPrimL_RDR))
+    ,(intPrimTy   , nlHsApp (nlHsVar intPrimL_RDR)
+                      . nlHsApp (nlHsVar toInteger_RDR))
+    ,(wordPrimTy  , nlHsApp (nlHsVar wordPrimL_RDR)
+                      . nlHsApp (nlHsVar toInteger_RDR))
+    ,(addrPrimTy  , nlHsApp (nlHsVar stringPrimL_RDR)
+                      . nlHsApp (nlHsApp
+                          (nlHsVar map_RDR)
+                          (compose_RDR `nlHsApps`
+                            [ nlHsVar fromIntegral_RDR
+                            , nlHsVar fromEnum_RDR
+                            ])))
+    ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
+                      . nlHsApp (nlHsVar toRational_RDR))
+    ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
+                      . nlHsApp (nlHsVar toRational_RDR))
+    ]
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id :: HasCallStack => String           -- The class involved
+            -> [(Type,a)]       -- The table
+            -> Type             -- The type
+            -> a                -- The result of the lookup
+assoc_ty_id cls_str tbl ty
+  | Just a <- assoc_ty_id_maybe tbl ty = a
+  | otherwise =
+      pprPanic "Error in deriving:"
+          (text "Can't derive" <+> text cls_str <+>
+           text "for primitive type" <+> ppr ty)
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
+assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
+
+-----------------------------------------------------------------------
+
+and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+and_Expr a b = genOpApp a and_RDR    b
+
+-----------------------------------------------------------------------
+
+eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+eq_Expr ty a b
+    | not (isUnliftedType ty) = genOpApp a eq_RDR b
+    | otherwise               = genPrimOpApp a prim_eq b
+ where
+   (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
+
+untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]
+              -> LHsExpr GhcPs -> LHsExpr GhcPs
+untag_Expr _ _ [] expr = expr
+untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
+  = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
+                                   [untag_this])) {-of-}
+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
+
+enum_from_to_Expr
+        :: LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
+enum_from_then_to_Expr
+        :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
+
+enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
+enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
+
+showParen_Expr
+        :: LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
+
+showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
+
+nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+
+nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
+nested_compose_Expr [e] = parenify e
+nested_compose_Expr (e:es)
+  = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
+
+-- impossible_Expr is used in case RHSs that should never happen.
+-- We generate these to keep the desugarer from complaining that they *might* happen!
+error_Expr :: String -> LHsExpr GhcPs
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
+
+-- illegal_Expr is used when signalling error conditions in the RHS of a derived
+-- method. It is currently only used by Enum.{succ,pred}
+illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
+illegal_Expr meth tp msg =
+   nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
+
+-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
+-- to include the value of a_RDR in the error string.
+illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
+illegal_toEnum_tag tp maxtag =
+   nlHsApp (nlHsVar error_RDR)
+           (nlHsApp (nlHsApp (nlHsVar append_RDR)
+                       (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
+                    (nlHsApp (nlHsApp (nlHsApp
+                           (nlHsVar showsPrec_RDR)
+                           (nlHsIntLit 0))
+                           (nlHsVar a_RDR))
+                           (nlHsApp (nlHsApp
+                               (nlHsVar append_RDR)
+                               (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
+                               (nlHsApp (nlHsApp (nlHsApp
+                                        (nlHsVar showsPrec_RDR)
+                                        (nlHsIntLit 0))
+                                        (nlHsVar maxtag))
+                                        (nlHsLit (mkHsString ")"))))))
+
+parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
+parenify e@(L _ (HsVar _ _)) = e
+parenify e                   = mkHsPar e
+
+-- genOpApp wraps brackets round the operator application, so that the
+-- renamer won't subsequently try to re-associate it.
+genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
+genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
+
+genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
+genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
+
+a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
+    :: RdrName
+a_RDR           = mkVarUnqual (fsLit "a")
+b_RDR           = mkVarUnqual (fsLit "b")
+c_RDR           = mkVarUnqual (fsLit "c")
+d_RDR           = mkVarUnqual (fsLit "d")
+f_RDR           = mkVarUnqual (fsLit "f")
+k_RDR           = mkVarUnqual (fsLit "k")
+z_RDR           = mkVarUnqual (fsLit "z")
+ah_RDR          = mkVarUnqual (fsLit "a#")
+bh_RDR          = mkVarUnqual (fsLit "b#")
+ch_RDR          = mkVarUnqual (fsLit "c#")
+dh_RDR          = mkVarUnqual (fsLit "d#")
+
+as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
+as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
+
+a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
+    true_Expr, pure_Expr :: LHsExpr GhcPs
+a_Expr          = nlHsVar a_RDR
+b_Expr          = nlHsVar b_RDR
+c_Expr          = nlHsVar c_RDR
+z_Expr          = nlHsVar z_RDR
+ltTag_Expr      = nlHsVar ltTag_RDR
+eqTag_Expr      = nlHsVar eqTag_RDR
+gtTag_Expr      = nlHsVar gtTag_RDR
+false_Expr      = nlHsVar false_RDR
+true_Expr       = nlHsVar true_RDR
+pure_Expr       = nlHsVar pure_RDR
+
+a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
+a_Pat           = nlVarPat a_RDR
+b_Pat           = nlVarPat b_RDR
+c_Pat           = nlVarPat c_RDR
+d_Pat           = nlVarPat d_RDR
+k_Pat           = nlVarPat k_RDR
+z_Pat           = nlVarPat z_RDR
+
+minusInt_RDR, tagToEnum_RDR :: RdrName
+minusInt_RDR  = getRdrName (primOpId IntSubOp   )
+tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
+
+con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
+-- Generates Orig s RdrName, for the binding positions
+con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
+tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
+maxtag_RDR  dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
+
+mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
+mk_tc_deriv_name dflags tycon occ_fun =
+   mkAuxBinderName dflags (tyConName tycon) occ_fun
+
+mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
+-- ^ Make a top-level binder name for an auxiliary binding for a parent name
+-- See Note [Auxiliary binders]
+mkAuxBinderName dflags parent occ_fun
+  = mkRdrUnqual (occ_fun stable_parent_occ)
+  where
+    stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
+    stable_string
+      | hasPprDebug dflags = parent_stable
+      | otherwise          = parent_stable_hash
+    parent_stable = nameStableString parent
+    parent_stable_hash =
+      let Fingerprint high low = fingerprintString parent_stable
+      in toBase62 high ++ toBase62Padded low
+      -- See Note [Base 62 encoding 128-bit integers] in Encoding
+    parent_occ  = nameOccName parent
+
+
+{-
+Note [Auxiliary binders]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We often want to make a top-level auxiliary binding.  E.g. for comparison we haev
+
+  instance Ord T where
+    compare a b = $con2tag a `compare` $con2tag b
+
+  $con2tag :: T -> Int
+  $con2tag = ...code....
+
+Of course these top-level bindings should all have distinct name, and we are
+generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish
+because with standalone deriving two imported TyCons might both be called T!
+(See #7947.)
+
+So we use package name, module name and the name of the parent
+(T in this example) as part of the OccName we generate for the new binding.
+To make the symbol names short we take a base62 hash of the full name.
+
+In the past we used the *unique* from the parent, but that's not stable across
+recompilations as uniques are nondeterministic.
+-}
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -0,0 +1,1293 @@
+{-
+(c) The University of Glasgow 2011
+
+
+The deriving code for the Functor, Foldable, and Traversable classes
+(equivalent to the code in TcGenDeriv, for other classes)
+-}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+
+module TcGenFunctor (
+        FFoldType(..), functorLikeTraverse,
+        deepSubtypesContaining, foldDataConArgs,
+
+        gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
+    ) where
+
+import GhcPrelude
+
+import Bag
+import DataCon
+import FastString
+import HsSyn
+import Panic
+import PrelNames
+import RdrName
+import SrcLoc
+import State
+import TcGenDeriv
+import TcType
+import TyCon
+import TyCoRep
+import Type
+import Util
+import Var
+import VarSet
+import MkId (coerceId)
+import TysWiredIn (true_RDR, false_RDR)
+
+import Data.Maybe (catMaybes, isJust)
+
+{-
+************************************************************************
+*                                                                      *
+                        Functor instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
+*                                                                      *
+************************************************************************
+
+For the data type:
+
+  data T a = T1 Int a | T2 (T a)
+
+We generate the instance:
+
+  instance Functor T where
+      fmap f (T1 b1 a) = T1 b1 (f a)
+      fmap f (T2 ta)   = T2 (fmap f ta)
+
+Notice that we don't simply apply 'fmap' to the constructor arguments.
+Rather
+  - Do nothing to an argument whose type doesn't mention 'a'
+  - Apply 'f' to an argument of type 'a'
+  - Apply 'fmap f' to other arguments
+That's why we have to recurse deeply into the constructor argument types,
+rather than just one level, as we typically do.
+
+What about types with more than one type parameter?  In general, we only
+derive Functor for the last position:
+
+  data S a b = S1 [b] | S2 (a, T a b)
+  instance Functor (S a) where
+    fmap f (S1 bs)    = S1 (fmap f bs)
+    fmap f (S2 (p,q)) = S2 (a, fmap f q)
+
+However, we have special cases for
+         - tuples
+         - functions
+
+More formally, we write the derivation of fmap code over type variable
+'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
+instance for T is:
+
+  instance Functor T where
+      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
+      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
+
+  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
+  $(fmap 'a 'a)          =  f
+  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
+  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
+  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
+
+For functions, the type parameter 'a can occur in a contravariant position,
+which means we need to derive a function like:
+
+  cofmap :: (a -> b) -> (f b -> f a)
+
+This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
+
+  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
+  $(cofmap 'a 'a)          =  error "type variable in contravariant position"
+  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
+  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
+  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
+  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
+
+Note that the code produced by $(fmap _ _) is always a higher order function,
+with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
+matching on the type, this means create a lambda function (see the (,) case above).
+The resulting code for fmap can look a bit weird, for example:
+
+  data X a = X (a,Int)
+  -- generated instance
+  instance Functor X where
+      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
+
+The optimizer should be able to simplify this code by simple inlining.
+
+An older version of the deriving code tried to avoid these applied
+lambda functions by producing a meta level function. But the function to
+be mapped, `f`, is a function on the code level, not on the meta level,
+so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
+It is better to produce too many lambdas than to eta expand, see ticket #7436.
+-}
+
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+-- When the argument is phantom, we can use  fmap _ = coerce
+-- See Note [Phantom types with Functor, Foldable, and Traversable]
+gen_Functor_binds loc tycon
+  | Phantom <- last (tyConRoles tycon)
+  = (unitBag fmap_bind, emptyBag)
+  where
+    fmap_name = L loc fmap_RDR
+    fmap_bind = mkRdrFunBind fmap_name fmap_eqns
+    fmap_eqns = [mkSimpleMatch fmap_match_ctxt
+                               [nlWildPat]
+                               coerce_Expr]
+    fmap_match_ctxt = mkPrefixFunRhs fmap_name
+
+gen_Functor_binds loc tycon
+  = (listToBag [fmap_bind, replace_bind], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+    fmap_name = L loc fmap_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
+    fmap_match_ctxt = mkPrefixFunRhs fmap_name
+
+    fmap_eqn con = flip evalState bs_RDRs $
+                     match_for_con fmap_match_ctxt [f_Pat] con =<< parts
+      where
+        parts = sequence $ foldDataConArgs ft_fmap con
+
+    fmap_eqns = map fmap_eqn data_cons
+
+    ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs))
+    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
+                   -- fmap f = \x -> x
+                 , ft_var  = return f_Expr
+                   -- fmap f = f
+                 , ft_fun  = \g h -> do
+                     gg <- g
+                     hh <- h
+                     mkSimpleLam2 $ \x b -> return $
+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
+                   -- fmap f = \x b -> h (x (g b))
+                 , ft_tup = \t gs -> do
+                     gg <- sequence gs
+                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg
+                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
+                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
+                   -- fmap f = fmap g
+                 , ft_forall = \_ g -> g
+                 , ft_bad_app = panic "in other argument in ft_fmap"
+                 , ft_co_var = panic "contravariant in ft_fmap" }
+
+    -- See Note [Deriving <$]
+    replace_name = L loc replace_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
+    replace_match_ctxt = mkPrefixFunRhs replace_name
+
+    replace_eqn con = flip evalState bs_RDRs $
+        match_for_con replace_match_ctxt [z_Pat] con =<< parts
+      where
+        parts = traverse (fmap replace) $ foldDataConArgs ft_replace con
+
+    replace_eqns = map replace_eqn data_cons
+
+    ft_replace :: FFoldType (State [RdrName] Replacer)
+    ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x
+                   -- (p <$) = \x -> x
+                 , ft_var  = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr
+                   -- (p <$) = const p
+                 , ft_fun  = \g h -> do
+                     gg <- replace <$> g
+                     hh <- replace <$> h
+                     fmap Nested $ mkSimpleLam2 $ \x b -> return $
+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
+                   -- (<$) p = \x b -> h (x (g b))
+                 , ft_tup = \t gs -> do
+                     gg <- traverse (fmap replace) gs
+                     fmap Nested . mkSimpleLam $
+                          mkSimpleTupleCase (match_for_con CaseAlt) t gg
+                   -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
+                 , ft_ty_app = \_ gm -> do
+                       g <- gm
+                       case g of
+                         Nested g' -> pure . Nested $
+                                          nlHsApp fmap_Expr $ g'
+                         Immediate _ -> pure . Nested $
+                                          nlHsApp replace_Expr z_Expr
+                   -- (p <$) = fmap (p <$)
+                 , ft_forall = \_ g -> g
+                 , ft_bad_app = panic "in other argument in ft_replace"
+                 , ft_co_var = panic "contravariant in ft_replace" }
+
+    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
+    match_for_con :: HsMatchContext RdrName
+                  -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_for_con ctxt = mkSimpleConMatch ctxt $
+        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
+
+-- See Note [Deriving <$]
+data Replacer = Immediate {replace :: LHsExpr GhcPs}
+              | Nested {replace :: LHsExpr GhcPs}
+
+{- Note [Deriving <$]
+   ~~~~~~~~~~~~~~~~~~
+
+We derive the definition of <$. Allowing this to take the default definition
+can lead to memory leaks: mapping over a structure with a constant function can
+fill the result structure with trivial thunks that retain the values from the
+original structure. The simplifier seems to handle this all right for simple
+types, but not for recursive ones. Consider
+
+data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor
+
+-- fmap _ Tip = Tip
+-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)
+
+Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
+simplifies no further. Why is that? `fmap` is defined recursively, so GHC
+cannot inline it. The static argument transformation would turn the definition
+into a non-recursive one
+
+-- fmap f = go where
+--   go Tip = Tip
+--   go (Bin l v r) = Bin (go l) (f v) (go r)
+
+which GHC could inline, producing an efficient definion of `<$`. But there are
+several problems. First, GHC does not perform the static argument transformation
+by default, even with -O2. Second, even when it does perform the static argument
+transformation, it does so only when there are at least two static arguments,
+which is not the case for fmap. Finally, when the type in question is
+non-regular, such as
+
+data Nesty a = Z a | S (Nesty a) (Nest (a, a))
+
+the function argument is no longer (entirely) static, so the static argument
+transformation will do nothing for us.
+
+Applying the default definition of `<$` will produce a tree full of thunks that
+look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
+also retention of the previous value, potentially leaking memory. Instead, we
+derive <$ separately. Two aspects are different from fmap: the case of the
+sought type variable (ft_var) and the case of a type application (ft_ty_app).
+The interesting one is ft_ty_app. We have to distinguish two cases: the
+"immediate" case where the type argument *is* the sought type variable, and
+the "nested" case where the type argument *contains* the sought type variable.
+
+The immediate case:
+
+Suppose we have
+
+data Imm a = Imm (F ... a)
+
+Then we want to define
+
+x <$ Imm q = Imm (x <$ q)
+
+The nested case:
+
+Suppose we have
+
+data Nes a = Nes (F ... (G a))
+
+Then we want to define
+
+x <$ Nes q = Nes (fmap (x <$) q)
+
+We use the Replacer type to tag whether the expression derived for applying
+<$ to the last type variable was the ft_var case (immediate) or one of the
+others (letting ft_forall pass through as usual).
+
+We could, but do not, give tuples special treatment to improve efficiency
+in some cases. Suppose we have
+
+data Nest a = Z a | S (Nest (a,a))
+
+The optimal definition would be
+
+x <$ Z _ = Z x
+x <$ S t = S ((x, x) <$ t)
+
+which produces a result with maximal internal sharing. The reason we do not
+attempt to treat this case specially is that we have no way to give
+user-provided tuple-like types similar treatment. If the user changed the
+definition to
+
+data Pair a = Pair a a
+data Nest a = Z a | S (Nest (Pair a))
+
+they would experience a surprising degradation in performance. -}
+
+
+{-
+Utility functions related to Functor deriving.
+
+Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
+This function works like a fold: it makes a value of type 'a' in a bottom up way.
+-}
+
+-- Generic traversal for Functor deriving
+-- See Note [FFoldType and functorLikeTraverse]
+data FFoldType a      -- Describes how to fold over a Type in a functor like way
+   = FT { ft_triv    :: a
+          -- ^ Does not contain variable
+        , ft_var     :: a
+          -- ^ The variable itself
+        , ft_co_var  :: a
+          -- ^ The variable itself, contravariantly
+        , ft_fun     :: a -> a -> a
+          -- ^ Function type
+        , ft_tup     :: TyCon -> [a] -> a
+          -- ^ Tuple type
+        , ft_ty_app  :: Type -> a -> a
+          -- ^ Type app, variable only in last argument
+        , ft_bad_app :: a
+          -- ^ Type app, variable other than in last argument
+        , ft_forall  :: TcTyVar -> a -> a
+          -- ^ Forall type
+     }
+
+functorLikeTraverse :: forall a.
+                       TyVar         -- ^ Variable to look for
+                    -> FFoldType a   -- ^ How to fold
+                    -> Type          -- ^ Type to process
+                    -> a
+functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
+                            , ft_co_var = caseCoVar,     ft_fun = caseFun
+                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp
+                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
+                    ty
+  = fst (go False ty)
+  where
+    go :: Bool        -- Covariant or contravariant context
+       -> Type
+       -> (a, Bool)   -- (result of type a, does type contain var)
+
+    go co ty | Just ty' <- tcView ty = go co ty'
+    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
+    go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })
+       | InvisArg <- af = go co y
+       | xc || yc       = (caseFun xr yr,True)
+       where (xr,xc) = go (not co) x
+             (yr,yc) = go co       y
+    go co (AppTy    x y) | xc = (caseWrongArg,   True)
+                         | yc = (caseTyApp x yr, True)
+        where (_, xc) = go co x
+              (yr,yc) = go co y
+    go co ty@(TyConApp con args)
+       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
+       -- At this point we know that xrs, xcs is not empty,
+       -- and at least one xr is True
+       | isTupleTyCon con = (caseTuple con xrs, True)
+       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
+       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty
+                          = (caseTyApp fun_ty (last xrs), True)
+       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
+       where
+         -- When folding over an unboxed tuple, we must explicitly drop the
+         -- runtime rep arguments, or else GHC will generate twice as many
+         -- variables in a unboxed tuple pattern match and expression as it
+         -- actually needs. See #12399
+         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
+    go co (ForAllTy (Bndr v vis) x)
+       | isVisibleArgFlag vis = panic "unexpected visible binder"
+       | v /= var && xc       = (caseForAll v xr,True)
+       where (xr,xc) = go co x
+
+    go _ _ = (caseTrivial,False)
+
+-- Return all syntactic subterms of ty that contain var somewhere
+-- These are the things that should appear in instance constraints
+deepSubtypesContaining :: TyVar -> Type -> [TcType]
+deepSubtypesContaining tv
+  = functorLikeTraverse tv
+        (FT { ft_triv = []
+            , ft_var = []
+            , ft_fun = (++)
+            , ft_tup = \_ xs -> concat xs
+            , ft_ty_app = (:)
+            , ft_bad_app = panic "in other argument in deepSubtypesContaining"
+            , ft_co_var = panic "contravariant in deepSubtypesContaining"
+            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
+
+
+foldDataConArgs :: FFoldType a -> DataCon -> [a]
+-- Fold over the arguments of the datacon
+foldDataConArgs ft con
+  = map foldArg (dataConOrigArgTys con)
+  where
+    foldArg
+      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
+             Just tv -> functorLikeTraverse tv ft
+             Nothing -> const (ft_triv ft)
+    -- If we are deriving Foldable for a GADT, there is a chance that the last
+    -- type variable in the data type isn't actually a type variable at all.
+    -- (for example, this can happen if the last type variable is refined to
+    -- be a concrete type such as Int). If the last type variable is refined
+    -- to be a specific type, then getTyVar_maybe will return Nothing.
+    -- See Note [DeriveFoldable with ExistentialQuantification]
+    --
+    -- The kind checks have ensured the last type parameter is of kind *.
+
+-- Make a HsLam using a fresh variable from a State monad
+mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
+            -> State [RdrName] (LHsExpr GhcPs)
+-- (mkSimpleLam fn) returns (\x. fn(x))
+mkSimpleLam lam =
+    get >>= \case
+      n:names -> do
+        put names
+        body <- lam (nlHsVar n)
+        return (mkHsLam [nlVarPat n] body)
+      _ -> panic "mkSimpleLam"
+
+mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
+             -> State [RdrName] (LHsExpr GhcPs))
+             -> State [RdrName] (LHsExpr GhcPs)
+mkSimpleLam2 lam =
+    get >>= \case
+      n1:n2:names -> do
+        put names
+        body <- lam (nlHsVar n1) (nlHsVar n2)
+        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+      _ -> panic "mkSimpleLam2"
+
+-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
+--
+-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the
+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
+-- and its arguments, applying an expression (from @insides@) to each of the
+-- respective arguments of @con@.
+mkSimpleConMatch :: Monad m => HsMatchContext RdrName
+                 -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
+                 -> [LPat GhcPs]
+                 -> DataCon
+                 -> [LHsExpr GhcPs]
+                 -> m (LMatch GhcPs (LHsExpr GhcPs))
+mkSimpleConMatch ctxt fold extra_pats con insides = do
+    let con_name = getRdrName con
+    let vars_needed = takeList insides as_RDRs
+    let bare_pat = nlConVarPat con_name vars_needed
+    let pat = if null vars_needed
+          then bare_pat
+          else nlParPat bare_pat
+    rhs <- fold con_name
+                (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed)
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
+
+-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
+--
+-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
+-- 'mkSimpleConMatch', with two key differences:
+--
+-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
+--    @[LHsExpr RdrName]@. This is because it filters out the expressions
+--    corresponding to arguments whose types do not mention the last type
+--    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
+--    'Nothing' elements of @insides@).
+--
+-- 2. @fold@ takes an expression as its first argument instead of a
+--    constructor name. This is because it uses a specialized
+--    constructor function expression that only takes as many parameters as
+--    there are argument types that mention the last type variable.
+--
+-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
+mkSimpleConMatch2 :: Monad m
+                  => HsMatchContext RdrName
+                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
+                                      -> m (LHsExpr GhcPs))
+                  -> [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> m (LMatch GhcPs (LHsExpr GhcPs))
+mkSimpleConMatch2 ctxt fold extra_pats con insides = do
+    let con_name = getRdrName con
+        vars_needed = takeList insides as_RDRs
+        pat = nlConVarPat con_name vars_needed
+        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
+        -- indicies in each expression to match up with the argument indices
+        -- in con_expr (defined below).
+        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
+                                   insides vars_needed
+        -- An element of argTysTyVarInfo is True if the constructor argument
+        -- with the same index has a type which mentions the last type
+        -- variable.
+        argTysTyVarInfo = map isJust insides
+        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
+
+        con_expr
+          | null asWithTyVar = nlHsApps con_name asWithoutTyVar
+          | otherwise =
+              let bs   = filterByList  argTysTyVarInfo bs_RDRs
+                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
+              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
+
+    rhs <- fold con_expr exps
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
+
+-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
+mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
+                                 -> m (LMatch GhcPs (LHsExpr GhcPs)))
+                  -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
+mkSimpleTupleCase match_for_con tc insides x
+  = do { let data_con = tyConSingleDataCon tc
+       ; match <- match_for_con [] data_con insides
+       ; return $ nlHsCase x [match] }
+
+{-
+************************************************************************
+*                                                                      *
+                        Foldable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
+*                                                                      *
+************************************************************************
+
+Deriving Foldable instances works the same way as Functor instances,
+only Foldable instances are not possible for function types at all.
+Given (data T a = T a a (T a) deriving Foldable), we get:
+
+  instance Foldable T where
+      foldr f z (T x1 x2 x3) =
+        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
+
+-XDeriveFoldable is different from -XDeriveFunctor in that it filters out
+arguments to the constructor that would produce useless code in a Foldable
+instance. For example, the following datatype:
+
+  data Foo a = Foo Int a Int deriving Foldable
+
+would have the following generated Foldable instance:
+
+  instance Foldable Foo where
+    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
+
+since neither of the two Int arguments are folded over.
+
+The cases are:
+
+  $(foldr 'a 'a)         =  f
+  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
+  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
+
+Note that the arguments to the real foldr function are the wrong way around,
+since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
+
+One can envision a case for types that don't contain the last type variable:
+
+  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
+
+But this case will never materialize, since the aforementioned filtering
+removes all such types from consideration.
+See Note [Generated code for DeriveFoldable and DeriveTraversable].
+
+Foldable instances differ from Functor and Traversable instances in that
+Foldable instances can be derived for data types in which the last type
+variable is existentially quantified. In particular, if the last type variable
+is refined to a more specific type in a GADT:
+
+  data GADT a where
+      G :: a ~ Int => a -> G Int
+
+then the deriving machinery does not attempt to check that the type a contains
+Int, since it is not syntactically equal to a type variable. That is, the
+derived Foldable instance for GADT is:
+
+  instance Foldable GADT where
+      foldr _ z (GADT _) = z
+
+See Note [DeriveFoldable with ExistentialQuantification].
+
+Note [Deriving null]
+~~~~~~~~~~~~~~~~~~~~
+
+In some cases, deriving the definition of 'null' can produce much better
+results than the default definition. For example, with
+
+  data SnocList a = Nil | Snoc (SnocList a) a
+
+the default definition of 'null' would walk the entire spine of a
+nonempty snoc-list before concluding that it is not null. But looking at
+the Snoc constructor, we can immediately see that it contains an 'a', and
+so 'null' can return False immediately if it matches on Snoc. When we
+derive 'null', we keep track of things that cannot be null. The interesting
+case is type application. Given
+
+  data Wrap a = Wrap (Foo (Bar a))
+
+we use
+
+  null (Wrap fba) = all null fba
+
+but if we see
+
+  data Wrap a = Wrap (Foo a)
+
+we can just use
+
+  null (Wrap fa) = null fa
+
+Indeed, we allow this to happen even for tuples:
+
+  data Wrap a = Wrap (Foo (a, Int))
+
+produces
+
+  null (Wrap fa) = null fa
+
+As explained in Note [Deriving <$], giving tuples special performance treatment
+could surprise users if they switch to other types, but Ryan Scott seems to
+think it's okay to do it for now.
+-}
+
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+-- When the parameter is phantom, we can use foldMap _ _ = mempty
+-- See Note [Phantom types with Functor, Foldable, and Traversable]
+gen_Foldable_binds loc tycon
+  | Phantom <- last (tyConRoles tycon)
+  = (unitBag foldMap_bind, emptyBag)
+  where
+    foldMap_name = L loc foldMap_RDR
+    foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
+    foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
+                                  [nlWildPat, nlWildPat]
+                                  mempty_Expr]
+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
+
+gen_Foldable_binds loc tycon
+  | null data_cons  -- There's no real point producing anything but
+                    -- foldMap for a type with no constructors.
+  = (unitBag foldMap_bind, emptyBag)
+
+  | otherwise
+  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
+    eqns = map foldr_eqn data_cons
+    foldr_eqn con
+      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_foldr con
+
+    foldMap_name = L loc foldMap_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
+                      foldMap_name foldMap_eqns
+
+    foldMap_eqns = map foldMap_eqn data_cons
+
+    foldMap_eqn con
+      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_foldMap con
+
+    -- Given a list of NullM results, produce Nothing if any of
+    -- them is NotNull, and otherwise produce a list of Maybes
+    -- with Justs representing unknowns and Nothings representing
+    -- things that are definitely null.
+    convert :: [NullM a] -> Maybe [Maybe a]
+    convert = traverse go where
+      go IsNull = Just Nothing
+      go NotNull = Nothing
+      go (NullM a) = Just (Just a)
+
+    null_name = L loc null_RDR
+    null_match_ctxt = mkPrefixFunRhs null_name
+    null_bind = mkRdrFunBind null_name null_eqns
+    null_eqns = map null_eqn data_cons
+    null_eqn con
+      = flip evalState bs_RDRs $ do
+          parts <- sequence $ foldDataConArgs ft_null con
+          case convert parts of
+            Nothing -> return $
+              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
+                false_Expr (noLoc emptyLocalBinds)
+            Just cp -> match_null [] con cp
+
+    -- Yields 'Just' an expression if we're folding over a type that mentions
+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
+    ft_foldr
+      = FT { ft_triv    = return Nothing
+             -- foldr f = \x z -> z
+           , ft_var     = return $ Just f_Expr
+             -- foldr f = f
+           , ft_tup     = \t g -> do
+               gg  <- sequence g
+               lam <- mkSimpleLam2 $ \x z ->
+                 mkSimpleTupleCase (match_foldr z) t gg x
+               return (Just lam)
+             -- foldr f = (\x z -> case x of ...)
+           , ft_ty_app  = \_ g -> do
+               gg <- g
+               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
+                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
+             -- foldr f = (\x z -> foldr g z x)
+           , ft_forall  = \_ g -> g
+           , ft_co_var  = panic "contravariant in ft_foldr"
+           , ft_fun     = panic "function in ft_foldr"
+           , ft_bad_app = panic "in other argument in ft_foldr" }
+
+    match_foldr :: LHsExpr GhcPs
+                -> [LPat GhcPs]
+                -> DataCon
+                -> [Maybe (LHsExpr GhcPs)]
+                -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
+      where
+        -- g1 v1 (g2 v2 (.. z))
+        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkFoldr = foldr nlHsApp z
+
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
+    ft_foldMap
+      = FT { ft_triv = return Nothing
+             -- foldMap f = \x -> mempty
+           , ft_var  = return (Just f_Expr)
+             -- foldMap f = f
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
+               return (Just lam)
+             -- foldMap f = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
+             -- foldMap f = foldMap g
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant in ft_foldMap"
+           , ft_fun = panic "function in ft_foldMap"
+           , ft_bad_app = panic "in other argument in ft_foldMap" }
+
+    match_foldMap :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
+      where
+        -- mappend v1 (mappend v2 ..)
+        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkFoldMap [] = mempty_Expr
+        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
+
+    -- See Note [FFoldType and functorLikeTraverse]
+    -- Yields NullM an expression if we're folding over an expression
+    -- that may or may not be null. Yields IsNull if it's certainly
+    -- null, and yields NotNull if it's certainly not null.
+    -- See Note [Deriving null]
+    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
+    ft_null
+      = FT { ft_triv = return IsNull
+             -- null = \_ -> True
+           , ft_var  = return NotNull
+             -- null = \_ -> False
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               case convert gg of
+                 Nothing -> pure NotNull
+                 Just ggg ->
+                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
+             -- null = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->
+                              case nestedResult of
+                                -- If e definitely contains the parameter,
+                                -- then we can test if (G e) contains it by
+                                -- simply checking if (G e) is null
+                                NotNull -> NullM null_Expr
+                                -- This case is unreachable--it will actually be
+                                -- caught by ft_triv
+                                IsNull -> IsNull
+                                -- The general case uses (all null),
+                                -- (all (all null)), etc.
+                                NullM nestedTest -> NullM $
+                                                    nlHsApp all_Expr nestedTest
+             -- null fa = null fa, or null fa = all null fa, or null fa = True
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant in ft_null"
+           , ft_fun = panic "function in ft_null"
+           , ft_bad_app = panic "in other argument in ft_null" }
+
+    match_null :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
+      where
+        -- v1 && v2 && ..
+        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkNull [] = true_Expr
+        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
+
+data NullM a =
+    IsNull   -- Definitely null
+  | NotNull  -- Definitely not null
+  | NullM a  -- Unknown
+
+{-
+************************************************************************
+*                                                                      *
+                        Traversable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+*                                                                      *
+************************************************************************
+
+Again, Traversable is much like Functor and Foldable.
+
+The cases are:
+
+  $(traverse 'a 'a)          =  f
+  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->
+     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
+  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
+
+Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
+do not mention the last type parameter. Therefore, the following datatype:
+
+  data Foo a = Foo Int a Int
+
+would have the following derived Traversable instance:
+
+  instance Traversable Foo where
+    traverse f (Foo x1 x2 x3) =
+      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
+
+since the two Int arguments do not produce any effects in a traversal.
+
+One can envision a case for types that do not mention the last type parameter:
+
+  $(traverse 'a 'b)          =  pure     -- when b does not contain a
+
+But this case will never materialize, since the aforementioned filtering
+removes all such types from consideration.
+See Note [Generated code for DeriveFoldable and DeriveTraversable].
+-}
+
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+-- When the argument is phantom, we can use traverse = pure . coerce
+-- See Note [Phantom types with Functor, Foldable, and Traversable]
+gen_Traversable_binds loc tycon
+  | Phantom <- last (tyConRoles tycon)
+  = (unitBag traverse_bind, emptyBag)
+  where
+    traverse_name = L loc traverse_RDR
+    traverse_bind = mkRdrFunBind traverse_name traverse_eqns
+    traverse_eqns =
+        [mkSimpleMatch traverse_match_ctxt
+                       [nlWildPat, z_Pat]
+                       (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
+    traverse_match_ctxt = mkPrefixFunRhs traverse_name
+
+gen_Traversable_binds loc tycon
+  = (unitBag traverse_bind, emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    traverse_name = L loc traverse_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
+                                   traverse_name traverse_eqns
+    traverse_eqns = map traverse_eqn data_cons
+    traverse_eqn con
+      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_trav con
+
+    -- Yields 'Just' an expression if we're folding over a type that mentions
+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
+    ft_trav
+      = FT { ft_triv    = return Nothing
+             -- traverse f = pure x
+           , ft_var     = return (Just f_Expr)
+             -- traverse f = f x
+           , ft_tup     = \t gs -> do
+               gg  <- sequence gs
+               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
+               return (Just lam)
+             -- traverse f = \x -> case x of (a1,a2,..) ->
+             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..
+           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
+             -- traverse f = traverse g
+           , ft_forall  = \_ g -> g
+           , ft_co_var  = panic "contravariant in ft_trav"
+           , ft_fun     = panic "function in ft_trav"
+           , ft_bad_app = panic "in other argument in ft_trav" }
+
+    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
+    --                    (g2 a2) <*> ...
+    match_for_con :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_for_con = mkSimpleConMatch2 CaseAlt $
+                                             \con xs -> return (mkApCon con xs)
+      where
+        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
+        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkApCon con [] = nlHsApps pure_RDR [con]
+        mkApCon con [x] = nlHsApps fmap_RDR [con,x]
+        mkApCon con (x1:x2:xs) =
+            foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
+          where appAp x y = nlHsApps ap_RDR [x,y]
+
+-----------------------------------------------------------------------
+
+f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
+    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
+    all_Expr, null_Expr :: LHsExpr GhcPs
+f_Expr        = nlHsVar f_RDR
+z_Expr        = nlHsVar z_RDR
+fmap_Expr     = nlHsVar fmap_RDR
+replace_Expr  = nlHsVar replace_RDR
+mempty_Expr   = nlHsVar mempty_RDR
+foldMap_Expr  = nlHsVar foldMap_RDR
+traverse_Expr = nlHsVar traverse_RDR
+coerce_Expr   = nlHsVar (getRdrName coerceId)
+pure_Expr     = nlHsVar pure_RDR
+true_Expr     = nlHsVar true_RDR
+false_Expr    = nlHsVar false_RDR
+all_Expr      = nlHsVar all_RDR
+null_Expr     = nlHsVar null_RDR
+
+f_RDR, z_RDR :: RdrName
+f_RDR = mkVarUnqual (fsLit "f")
+z_RDR = mkVarUnqual (fsLit "z")
+
+as_RDRs, bs_RDRs :: [RdrName]
+as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
+
+as_Vars, bs_Vars :: [LHsExpr GhcPs]
+as_Vars = map nlHsVar as_RDRs
+bs_Vars = map nlHsVar bs_RDRs
+
+f_Pat, z_Pat :: LPat GhcPs
+f_Pat = nlVarPat f_RDR
+z_Pat = nlVarPat z_RDR
+
+{-
+Note [DeriveFoldable with ExistentialQuantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Traversable instances can only be derived for data types whose
+last type parameter is truly universally polymorphic. For example:
+
+  data T a b where
+    T1 ::                 b   -> T a b   -- YES, b is unconstrained
+    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
+    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
+    T4 ::                 Int -> T a Int -- NO, this is just like T3
+    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
+                                         -- though a is existential
+    T6 ::                 Int -> T Int b -- YES, b is unconstrained
+
+For Foldable instances, however, we can completely lift the constraint that
+the last type parameter be truly universally polymorphic. This means that T
+(as defined above) can have a derived Foldable instance:
+
+  instance Foldable (T a) where
+    foldr f z (T1 b)   = f b z
+    foldr f z (T2 b)   = f b z
+    foldr f z (T3 b)   = f b z
+    foldr f z (T4 b)   = z
+    foldr f z (T5 a b) = f b z
+    foldr f z (T6 a)   = z
+
+    foldMap f (T1 b)   = f b
+    foldMap f (T2 b)   = f b
+    foldMap f (T3 b)   = f b
+    foldMap f (T4 b)   = mempty
+    foldMap f (T5 a b) = f b
+    foldMap f (T6 a)   = mempty
+
+In a Foldable instance, it is safe to fold over an occurrence of the last type
+parameter that is not truly universally polymorphic. However, there is a bit
+of subtlety in determining what is actually an occurrence of a type parameter.
+T3 and T4, as defined above, provide one example:
+
+  data T a b where
+    ...
+    T3 :: b ~ Int => b   -> T a b
+    T4 ::            Int -> T a Int
+    ...
+
+  instance Foldable (T a) where
+    ...
+    foldr f z (T3 b) = f b z
+    foldr f z (T4 b) = z
+    ...
+    foldMap f (T3 b) = f b
+    foldMap f (T4 b) = mempty
+    ...
+
+Notice that the argument of T3 is folded over, whereas the argument of T4 is
+not. This is because we only fold over constructor arguments that
+syntactically mention the universally quantified type parameter of that
+particular data constructor. See foldDataConArgs for how this is implemented.
+
+As another example, consider the following data type. The argument of each
+constructor has the same type as the last type parameter:
+
+  data E a where
+    E1 :: (a ~ Int) => a   -> E a
+    E2 ::              Int -> E Int
+    E3 :: (a ~ Int) => a   -> E Int
+    E4 :: (a ~ Int) => Int -> E a
+
+Only E1's argument is an occurrence of a universally quantified type variable
+that is syntactically equivalent to the last type parameter, so only E1's
+argument will be folded over in a derived Foldable instance.
+
+See #10447 for the original discussion on this feature. Also see
+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor
+for a more in-depth explanation.
+
+Note [FFoldType and functorLikeTraverse]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deriving Functor, Foldable, and Traversable all require generating expressions
+which perform an operation on each argument of a data constructor depending
+on the argument's type. In particular, a generated operation can be different
+depending on whether the type mentions the last type variable of the datatype
+(e.g., if you have data T a = MkT a Int, then a generated foldr expression would
+fold over the first argument of MkT, but not the second).
+
+This pattern is abstracted with the FFoldType datatype, which provides hooks
+for the user to specify how a constructor argument should be folded when it
+has a type with a particular "shape". The shapes are as follows (assume that
+a is the last type variable in a given datatype):
+
+* ft_triv:    The type does not mention the last type variable at all.
+              Examples: Int, b
+
+* ft_var:     The type is syntactically equal to the last type variable.
+              Moreover, the type appears in a covariant position (see
+              the Deriving Functor instances section of the user's guide
+              for an in-depth explanation of covariance vs. contravariance).
+              Example: a (covariantly)
+
+* ft_co_var:  The type is syntactically equal to the last type variable.
+              Moreover, the type appears in a contravariant position.
+              Example: a (contravariantly)
+
+* ft_fun:     A function type which mentions the last type variable in
+              the argument position, result position or both.
+              Examples: a -> Int, Int -> a, Maybe a -> [a]
+
+* ft_tup:     A tuple type which mentions the last type variable in at least
+              one of its fields. The TyCon argument of ft_tup represents the
+              particular tuple's type constructor.
+              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
+
+* ft_ty_app:  A type is being applied to the last type parameter, where the
+              applied type does not mention the last type parameter (if it
+              did, it would fall under ft_bad_app). The Type argument to
+              ft_ty_app represents the applied type.
+
+              Note that functions, tuples, and foralls are distinct cases
+              and take precedence of ft_ty_app. (For example, (Int -> a) would
+              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
+              Examples: Maybe a, Either b a
+
+* ft_bad_app: A type application uses the last type parameter in a position
+              other than the last argument. This case is singled out because
+              Functor, Foldable, and Traversable instances cannot be derived
+              for datatypes containing arguments with such types.
+              Examples: Either a Int, Const a b
+
+* ft_forall:  A forall'd type mentions the last type parameter on its right-
+              hand side (and is not quantified on the left-hand side). This
+              case is present mostly for plumbing purposes.
+              Example: forall b. Either b a
+
+If FFoldType describes a strategy for folding subcomponents of a Type, then
+functorLikeTraverse is the function that applies that strategy to the entirety
+of a Type, returning the final folded-up result.
+
+foldDataConArgs applies functorLikeTraverse to every argument type of a
+constructor, returning a list of the fold results. This makes foldDataConArgs
+a natural way to generate the subexpressions in a generated fmap, foldr,
+foldMap, or traverse definition (the subexpressions must then be combined in
+a method-specific fashion to form the final generated expression).
+
+Deriving Generic1 also does validity checking by looking for the last type
+variable in certain positions of a constructor's argument types, so it also
+uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
+
+Note [Generated code for DeriveFoldable and DeriveTraversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
+that of -XDeriveFunctor. However, there an important difference between deriving
+the former two typeclasses and the latter one, which is best illustrated by the
+following scenario:
+
+  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
+
+The generated code for the Functor instance is straightforward:
+
+  instance Functor WithInt where
+    fmap f (WithInt a i) = WithInt (f a) i
+
+But if we use too similar of a strategy for deriving the Foldable and
+Traversable instances, we end up with this code:
+
+  instance Foldable WithInt where
+    foldMap f (WithInt a i) = f a <> mempty
+
+  instance Traversable WithInt where
+    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
+
+This is unsatisfying for two reasons:
+
+1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
+   expects an argument whose type is of kind *. This effectively prevents
+   Traversable from being derived for any datatype with an unlifted argument
+   type (#11174).
+
+2. The generated code contains superfluous expressions. By the Monoid laws,
+   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
+   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
+
+We can fix both of these issues by incorporating a slight twist to the usual
+algorithm that we use for -XDeriveFunctor. The differences can be summarized
+as follows:
+
+1. In the generated expression, we only fold over arguments whose types
+   mention the last type parameter. Any other argument types will simply
+   produce useless 'mempty's or 'pure's, so they can be safely ignored.
+
+2. In the case of -XDeriveTraversable, instead of applying ConName,
+   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
+
+   * ConName has n arguments
+   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
+     to the arguments whose types mention the last type parameter. As a
+     consequence, taking the difference of {a_1, ..., a_n} and
+     {b_i, ..., b_k} yields the all the argument values of ConName whose types
+     do not mention the last type parameter. Note that [i, ..., k] is a
+     strictly increasing—but not necessarily consecutive—integer sequence.
+
+     For example, the datatype
+
+       data Foo a = Foo Int a Int a
+
+     would generate the following Traversable instance:
+
+       instance Traversable Foo where
+         traverse f (Foo a1 a2 a3 a4) =
+           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
+
+Technically, this approach would also work for -XDeriveFunctor as well, but we
+decide not to do so because:
+
+1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
+   instead of (WithInt (f a) i).
+
+2. There would be certain datatypes for which the above strategy would
+   generate Functor code that would fail to typecheck. For example:
+
+     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
+
+   With the conventional algorithm, it would generate something like:
+
+     fmap f (Bar a) = Bar (fmap f a)
+
+   which typechecks. But with the strategy mentioned above, it would generate:
+
+     fmap f (Bar a) = (\b -> Bar b) (fmap f a)
+
+   which does not typecheck, since GHC cannot unify the rank-2 type variables
+   in the types of b and (fmap f a).
+
+Note [Phantom types with Functor, Foldable, and Traversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given a type F :: * -> * whose type argument has a phantom role, we can always
+produce lawful Functor and Traversable instances using
+
+    fmap _ = coerce
+    traverse _ = pure . coerce
+
+Indeed, these are equivalent to any *strictly lawful* instances one could
+write, except that this definition of 'traverse' may be lazier.  That is, if
+instances obey the laws under true equality (rather than up to some equivalence
+relation), then they will be essentially equivalent to these. These definitions
+are incredibly cheap, so we want to use them even if it means ignoring some
+non-strictly-lawful instance in an embedded type.
+
+Foldable has far fewer laws to work with, which leaves us unwelcome
+freedom in implementing it. At a minimum, we would like to ensure that
+a derived foldMap is always at least as good as foldMapDefault with a
+derived traverse. To accomplish that, we must define
+
+   foldMap _ _ = mempty
+
+in these cases.
+
+This may have different strictness properties from a standard derivation.
+Consider
+
+   data NotAList a = Nil | Cons (NotAList a) deriving Foldable
+
+The usual deriving mechanism would produce
+
+   foldMap _ Nil = mempty
+   foldMap f (Cons x) = foldMap f x
+
+which is strict in the entire spine of the NotAList.
+
+Final point: why do we even care about such types? Users will rarely if ever
+map, fold, or traverse over such things themselves, but other derived
+instances may:
+
+   data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable
+
+Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are some slightly tricky decisions to make about how to handle
+Functor, Foldable, and Traversable instances for types with no constructors.
+For fmap, the two basic options are
+
+   fmap _ _ = error "Sorry, no constructors"
+
+or
+
+   fmap _ z = case z of
+
+In most cases, the latter is more helpful: if the thunk passed to fmap
+throws an exception, we're generally going to be much more interested in
+that exception than in the fact that there aren't any constructors.
+
+In order to match the semantics for phantoms (see note above), we need to
+be a bit careful about 'traverse'. The obvious definition would be
+
+   traverse _ z = case z of
+
+but this is stricter than the one for phantoms. We instead use
+
+   traverse _ z = pure $ case z of
+
+For foldMap, the obvious choices are
+
+   foldMap _ _ = mempty
+
+or
+
+   foldMap _ z = case z of
+
+We choose the first one to be consistent with what foldMapDefault does for
+a derived Traversable instance.
+-}
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -0,0 +1,1043 @@
+{-
+(c) The University of Glasgow 2011
+
+
+The deriving code for the Generic class
+(equivalent to the code in TcGenDeriv, for other classes)
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcGenGenerics (canDoGenerics, canDoGenerics1,
+                      GenericKind(..),
+                      gen_Generic_binds, get_gen1_constrained_tys) where
+
+import GhcPrelude
+
+import HsSyn
+import Type
+import TcType
+import TcGenDeriv
+import TcGenFunctor
+import DataCon
+import TyCon
+import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
+import FamInst
+import Module           ( moduleName, moduleNameFS
+                        , moduleUnitId, unitIdFS, getModule )
+import IfaceEnv         ( newGlobalBinder )
+import Name      hiding ( varName )
+import RdrName
+import BasicTypes
+import TysPrim
+import TysWiredIn
+import PrelNames
+import TcEnv
+import TcRnMonad
+import HscTypes
+import ErrUtils( Validity(..), andValid )
+import SrcLoc
+import Bag
+import VarEnv
+import VarSet (elemVarSet)
+import Outputable
+import FastString
+import Util
+
+import Control.Monad (mplus)
+import Data.List (zip4, partition)
+import Data.Maybe (isJust)
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings for the new generic deriving mechanism}
+*                                                                      *
+************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+-}
+
+gen_Generic_binds :: GenericKind -> TyCon -> [Type]
+                 -> TcM (LHsBinds GhcPs, FamInst)
+gen_Generic_binds gk tc inst_tys = do
+  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
+  return (mkBindsRep gk tc, repTyInsts)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generating representation types}
+*                                                                      *
+************************************************************************
+-}
+
+get_gen1_constrained_tys :: TyVar -> Type -> [Type]
+-- called by TcDeriv.inferConstraints; generates a list of types, each of which
+-- must be a Functor in order for the Generic1 instance to work.
+get_gen1_constrained_tys argVar
+  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
+                                , ata_par1 = [], ata_rec1 = const []
+                                , ata_comp = (:) }
+
+{-
+
+Note [Requirements for deriving Generic and Rep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the following, T, Tfun, and Targ are "meta-variables" ranging over type
+expressions.
+
+(Generic T) and (Rep T) are derivable for some type expression T if the
+following constraints are satisfied.
+
+  (a) D is a type constructor *value*. In other words, D is either a type
+      constructor or it is equivalent to the head of a data family instance (up to
+      alpha-renaming).
+
+  (b) D cannot have a "stupid context".
+
+  (c) The right-hand side of D cannot include existential types, universally
+      quantified types, or "exotic" unlifted types. An exotic unlifted type
+      is one which is not listed in the definition of allowedUnliftedTy
+      (i.e., one for which we have no representation type).
+      See Note [Generics and unlifted types]
+
+  (d) T :: *.
+
+(Generic1 T) and (Rep1 T) are derivable for some type expression T if the
+following constraints are satisfied.
+
+  (a),(b),(c) As above.
+
+  (d) T must expect arguments, and its last parameter must have kind *.
+
+      We use `a' to denote the parameter of D that corresponds to the last
+      parameter of T.
+
+  (e) For any type-level application (Tfun Targ) in the right-hand side of D
+      where the head of Tfun is not a tuple constructor:
+
+      (b1) `a' must not occur in Tfun.
+
+      (b2) If `a' occurs in Targ, then Tfun :: * -> *.
+
+-}
+
+canDoGenerics :: TyCon -> Validity
+-- canDoGenerics determines if Generic/Rep can be derived.
+--
+-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
+-- care of because canDoGenerics is applied to rep tycons.
+--
+-- It returns IsValid if deriving is possible. It returns (NotValid reason)
+-- if not.
+canDoGenerics tc
+  = mergeErrors (
+          -- Check (b) from Note [Requirements for deriving Generic and Rep].
+              (if (not (null (tyConStupidTheta tc)))
+                then (NotValid (tc_name <+> text "must not have a datatype context"))
+                else IsValid)
+          -- See comment below
+            : (map bad_con (tyConDataCons tc)))
+  where
+    -- The tc can be a representation tycon. When we want to display it to the
+    -- user (in an error message) we should print its parent
+    tc_name = ppr $ case tyConFamInst_maybe tc of
+        Just (ptc, _) -> ptc
+        _             -> tc
+
+        -- Check (c) from Note [Requirements for deriving Generic and Rep].
+        --
+        -- If any of the constructors has an exotic unlifted type as argument,
+        -- then we can't build the embedding-projection pair, because
+        -- it relies on instantiating *polymorphic* sum and product types
+        -- at the argument types of the constructors
+    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+                  then (NotValid (ppr dc <+> text
+                    "must not have exotic unlifted or polymorphic arguments"))
+                  else (if (not (isVanillaDataCon dc))
+                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
+                          else IsValid)
+
+        -- Nor can we do the job if it's an existential data constructor,
+        -- Nor if the args are polymorphic types (I don't think)
+    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))
+                      || not (isTauTy ty)
+
+-- Returns True the Type argument is an unlifted type which has a
+-- corresponding generic representation type. For example,
+-- (allowedUnliftedTy Int#) would return True since there is the UInt
+-- representation type.
+allowedUnliftedTy :: Type -> Bool
+allowedUnliftedTy = isJust . unboxedRepRDRs
+
+mergeErrors :: [Validity] -> Validity
+mergeErrors []             = IsValid
+mergeErrors (NotValid s:t) = case mergeErrors t of
+  IsValid     -> NotValid s
+  NotValid s' -> NotValid (s <> text ", and" $$ s')
+mergeErrors (IsValid : t) = mergeErrors t
+
+-- A datatype used only inside of canDoGenerics1. It's the result of analysing
+-- a type term.
+data Check_for_CanDoGenerics1 = CCDG1
+  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in
+                                  -- this type?
+  , _ccdg1_errors   :: Validity   -- errors generated by this type
+  }
+
+{-
+
+Note [degenerate use of FFoldType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We use foldDataConArgs here only for its ability to treat tuples
+specially. foldDataConArgs also tracks covariance (though it assumes all
+higher-order type parameters are covariant) and has hooks for special handling
+of functions and polytypes, but we do *not* use those.
+
+The key issue is that Generic1 deriving currently offers no sophisticated
+support for functions. For example, we cannot handle
+
+  data F a = F ((a -> Int) -> Int)
+
+even though a is occurring covariantly.
+
+In fact, our rule is harsh: a is simply not allowed to occur within the first
+argument of (->). We treat (->) the same as any other non-tuple tycon.
+
+Unfortunately, this means we have to track "the parameter occurs in this type"
+explicitly, even though foldDataConArgs is also doing this internally.
+
+-}
+
+-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
+--
+-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
+-- are taken care of by the call to canDoGenerics.
+--
+-- It returns IsValid if deriving is possible. It returns (NotValid reason)
+-- if not.
+canDoGenerics1 :: TyCon -> Validity
+canDoGenerics1 rep_tc =
+  canDoGenerics rep_tc `andValid` additionalChecks
+  where
+    additionalChecks
+        -- check (d) from Note [Requirements for deriving Generic and Rep]
+      | null (tyConTyVars rep_tc) = NotValid $
+          text "Data type" <+> quotes (ppr rep_tc)
+      <+> text "must have some type parameters"
+
+      | otherwise = mergeErrors $ concatMap check_con data_cons
+
+    data_cons = tyConDataCons rep_tc
+    check_con con = case check_vanilla con of
+      j@(NotValid {}) -> [j]
+      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
+
+    bad :: DataCon -> SDoc -> SDoc
+    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg
+
+    check_vanilla :: DataCon -> Validity
+    check_vanilla con | isVanillaDataCon con = IsValid
+                      | otherwise            = NotValid (bad con existential)
+
+    bmzero      = CCDG1 False IsValid
+    bmbad con s = CCDG1 True $ NotValid $ bad con s
+    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
+
+    -- check (e) from Note [Requirements for deriving Generic and Rep]
+    -- See also Note [degenerate use of FFoldType]
+    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
+    ft_check con = FT
+      { ft_triv = bmzero
+
+      , ft_var = caseVar, ft_co_var = caseVar
+
+      -- (component_0,component_1,...,component_n)
+      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
+                                  then bmbad con wrong_arg
+                                  else foldr bmplus bmzero components
+
+      -- (dom -> rng), where the head of ty is not a tuple tycon
+      , ft_fun = \dom rng -> -- cf #8516
+          if _ccdg1_hasParam dom
+          then bmbad con wrong_arg
+          else bmplus dom rng
+
+      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
+      -- the parameter of interest does not occur in ty
+      , ft_ty_app = \_ arg -> arg
+
+      , ft_bad_app = bmbad con wrong_arg
+      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere
+      }
+      where
+        caseVar = CCDG1 True IsValid
+
+
+    existential = text "must not have existential arguments"
+    wrong_arg   = text "applies a type to an argument involving the last parameter"
+               $$ text "but the applied type is not of kind * -> *"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generating the RHS of a generic default method}
+*                                                                      *
+************************************************************************
+-}
+
+type US = Int   -- Local unique supply, just a plain Int
+type Alt = (LPat GhcPs, LHsExpr GhcPs)
+
+-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
+-- Generic1 (Gen1).
+data GenericKind = Gen0 | Gen1
+
+-- as above, but with a payload of the TyCon's name for "the" parameter
+data GenericKind_ = Gen0_ | Gen1_ TyVar
+
+-- as above, but using a single datacon's name for "the" parameter
+data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
+
+forgetArgVar :: GenericKind_DC -> GenericKind
+forgetArgVar Gen0_DC   = Gen0
+forgetArgVar Gen1_DC{} = Gen1
+
+-- When working only within a single datacon, "the" parameter's name should
+-- match that datacon's name for it.
+gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
+gk2gkDC Gen0_   _ = Gen0_DC
+gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
+
+
+-- Bindings for the Generic instance
+mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
+mkBindsRep gk tycon =
+    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
+  `unionBags`
+    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
+      where
+        -- The topmost M1 (the datatype metadata) has the exact same type
+        -- across all cases of a from/to definition, and can be factored out
+        -- to save some allocations during typechecking.
+        -- See Note [Generics compilation speed tricks]
+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
+                                       $ nlHsPar $ nlHsCase x_Expr from_matches
+        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
+
+        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
+        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
+        loc           = srcLocSpan (getSrcLoc tycon)
+        datacons      = tyConDataCons tycon
+
+        (from01_RDR, to01_RDR) = case gk of
+                                   Gen0 -> (from_RDR,  to_RDR)
+                                   Gen1 -> (from1_RDR, to1_RDR)
+
+        -- Recurse over the sum first
+        from_alts, to_alts :: [Alt]
+        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
+          where gk_ = case gk of
+                  Gen0 -> Gen0_
+                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
+                          Gen1_ (last tyvars)
+                    where tyvars = tyConTyVars tycon
+
+--------------------------------------------------------------------------------
+-- The type synonym instance and synonym
+--       type instance Rep (D a b) = Rep_D a b
+--       type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
+                 -> TyCon         -- The type to generate representation for
+                 -> [Type]        -- The type(s) to which Generic(1) is applied
+                                  -- in the generated instance
+                 -> TcM FamInst   -- Generated representation0 coercion
+tc_mkRepFamInsts gk tycon inst_tys =
+       -- Consider the example input tycon `D`, where data D a b = D_ a
+       -- Also consider `R:DInt`, where { data family D x y :: * -> *
+       --                               ; data instance D Int a b = D_ a }
+  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
+       fam_tc <- case gk of
+         Gen0 -> tcLookupTyCon repTyConName
+         Gen1 -> tcLookupTyCon rep1TyConName
+
+     ; fam_envs <- tcGetFamInstEnvs
+
+     ; let -- If the derived instance is
+           --   instance Generic (Foo x)
+           -- then:
+           --   `arg_ki` = *, `inst_ty` = Foo x :: *
+           --
+           -- If the derived instance is
+           --   instance Generic1 (Bar x :: k -> *)
+           -- then:
+           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
+           (arg_ki, inst_ty) = case (gk, inst_tys) of
+             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)
+             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)
+             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
+
+     ; let mbFamInst         = tyConFamInst_maybe tycon
+           -- If we're examining a data family instance, we grab the parent
+           -- TyCon (ptc) and use it to determine the type arguments
+           -- (inst_args) for the data family *instance*'s type variables.
+           ptc               = maybe tycon fst mbFamInst
+           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd
+                                 $ tcSplitTyConApp inst_ty
+
+     ; let -- `tyvars` = [a,b]
+           (tyvars, gk_) = case gk of
+             Gen0 -> (all_tyvars, Gen0_)
+             Gen1 -> ASSERT(not $ null all_tyvars)
+                     (init all_tyvars, Gen1_ $ last all_tyvars)
+             where all_tyvars = tyConTyVars tycon
+
+       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+     ; repTy <- tc_mkRepTy gk_ tycon arg_ki
+
+       -- `rep_name` is a name we generate for the synonym
+     ; mod <- getModule
+     ; loc <- getSrcSpanM
+     ; let tc_occ  = nameOccName (tyConName tycon)
+           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
+     ; rep_name <- newGlobalBinder mod rep_occ loc
+
+       -- We make sure to substitute the tyvars with their user-supplied
+       -- type arguments before generating the Rep/Rep1 instance, since some
+       -- of the tyvars might have been instantiated when deriving.
+       -- See Note [Generating a correctly typed Rep instance].
+     ; let (env_tyvars, env_inst_args)
+             = case gk_ of
+                 Gen0_ -> (tyvars, inst_args)
+                 Gen1_ last_tv
+                          -- See the "wrinkle" in
+                          -- Note [Generating a correctly typed Rep instance]
+                       -> ( last_tv : tyvars
+                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )
+           env        = zipTyEnv env_tyvars env_inst_args
+           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
+           subst      = mkTvSubst in_scope env
+           repTy'     = substTyUnchecked  subst repTy
+           tcv'       = tyCoVarsOfTypeList inst_ty
+           (tv', cv') = partition isTyVar tcv'
+           tvs'       = scopedSort tv'
+           cvs'       = scopedSort cv'
+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'
+                                        fam_tc inst_tys repTy'
+
+     ; newFamInst SynFamilyInst axiom  }
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+-- | See documentation of 'argTyFold'; that function uses the fields of this
+-- type to interpret the structure of a type when that type is considered as an
+-- argument to a constructor that is being represented with 'Rep1'.
+data ArgTyAlg a = ArgTyAlg
+  { ata_rec0 :: (Type -> a)
+  , ata_par1 :: a, ata_rec1 :: (Type -> a)
+  , ata_comp :: (Type -> a -> a)
+  }
+
+-- | @argTyFold@ implements a generalised and safer variant of the @arg@
+-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
+-- is conceptually equivalent to:
+--
+-- > arg t = case t of
+-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
+-- >   App f [t'] |
+-- >     representable1 f &&
+-- >     t' == argVar        -> Rec1 f
+-- >   App f [t'] |
+-- >     representable1 f &&
+-- >     t' has tyvars       -> f :.: (arg t')
+-- >   _                     -> Rec0 t
+--
+-- where @argVar@ is the last type variable in the data type declaration we are
+-- finding the representation for.
+--
+-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
+-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
+-- @:.:@.
+--
+-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
+-- some data types. The problematic case is when @t@ is an application of a
+-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
+-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
+-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
+-- representable1 checks have been relaxed, and others were moved to
+-- @canDoGenerics1@.
+argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
+argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
+                            ata_par1 = mkPar1, ata_rec1 = mkRec1,
+                            ata_comp = mkComp}) =
+  -- mkRec0 is the default; use it if there is no interesting structure
+  -- (e.g. occurrences of parameters or recursive occurrences)
+  \t -> maybe (mkRec0 t) id $ go t where
+  go :: Type -> -- type to fold through
+        Maybe a -- the result (e.g. representation type), unless it's trivial
+  go t = isParam `mplus` isApp where
+
+    isParam = do -- handles parameters
+      t' <- getTyVar_maybe t
+      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
+             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
+
+    isApp = do -- handles applications
+      (phi, beta) <- tcSplitAppTy_maybe t
+
+      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
+
+      -- Does it have no interesting structure to represent?
+      if not interesting then Nothing
+        else -- Is the argument the parameter? Special case for mkRec1.
+          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
+            else mkComp phi `fmap` go beta -- It must be a composition.
+
+
+tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
+               GenericKind_
+              -- The type to generate representation for
+            -> TyCon
+              -- The kind of the representation type's argument
+              -- See Note [Handling kinds in a Rep instance]
+            -> Kind
+               -- Generated representation0 type
+            -> TcM Type
+tc_mkRepTy gk_ tycon k =
+  do
+    d1      <- tcLookupTyCon d1TyConName
+    c1      <- tcLookupTyCon c1TyConName
+    s1      <- tcLookupTyCon s1TyConName
+    rec0    <- tcLookupTyCon rec0TyConName
+    rec1    <- tcLookupTyCon rec1TyConName
+    par1    <- tcLookupTyCon par1TyConName
+    u1      <- tcLookupTyCon u1TyConName
+    v1      <- tcLookupTyCon v1TyConName
+    plus    <- tcLookupTyCon sumTyConName
+    times   <- tcLookupTyCon prodTyConName
+    comp    <- tcLookupTyCon compTyConName
+    uAddr   <- tcLookupTyCon uAddrTyConName
+    uChar   <- tcLookupTyCon uCharTyConName
+    uDouble <- tcLookupTyCon uDoubleTyConName
+    uFloat  <- tcLookupTyCon uFloatTyConName
+    uInt    <- tcLookupTyCon uIntTyConName
+    uWord   <- tcLookupTyCon uWordTyConName
+
+    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
+
+    md         <- tcLookupPromDataCon metaDataDataConName
+    mc         <- tcLookupPromDataCon metaConsDataConName
+    ms         <- tcLookupPromDataCon metaSelDataConName
+    pPrefix    <- tcLookupPromDataCon prefixIDataConName
+    pInfix     <- tcLookupPromDataCon infixIDataConName
+    pLA        <- tcLookupPromDataCon leftAssociativeDataConName
+    pRA        <- tcLookupPromDataCon rightAssociativeDataConName
+    pNA        <- tcLookupPromDataCon notAssociativeDataConName
+    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName
+    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName
+    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
+    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName
+    pSStr      <- tcLookupPromDataCon sourceStrictDataConName
+    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
+    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName
+    pDStr      <- tcLookupPromDataCon decidedStrictDataConName
+    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName
+
+    fix_env <- getFixityEnv
+
+    let mkSum' a b = mkTyConApp plus  [k,a,b]
+        mkProd a b = mkTyConApp times [k,a,b]
+        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
+        mkRec1 a   = mkTyConApp rec1  [k,a]
+        mkPar1     = mkTyConTy  par1
+        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
+        mkC      a = mkTyConApp c1 [ k
+                                   , metaConsTy a
+                                   , prod (dataConInstOrigArgTys a
+                                            . mkTyVarTys . tyConTyVars $ tycon)
+                                          (dataConSrcBangs    a)
+                                          (dataConImplBangs   a)
+                                          (dataConFieldLabels a)]
+        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]
+
+        -- Sums and products are done in the same way for both Rep and Rep1
+        sumP [] = mkTyConApp v1 [k]
+        sumP l  = foldBal mkSum' . map mkC  $ l
+        -- The Bool is True if this constructor has labelled fields
+        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
+        prod [] _  _  _  = mkTyConApp u1 [k]
+        prod l  sb ib fl = foldBal mkProd
+                                   [ ASSERT(null fl || lengthExceeds fl j)
+                                     arg t sb' ib' (if null fl
+                                                       then Nothing
+                                                       else Just (fl !! j))
+                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
+
+        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
+        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
+            -- Here we previously used Par0 if t was a type variable, but we
+            -- realized that we can't always guarantee that we are wrapping-up
+            -- all type variables in Par0. So we decided to stop using Par0
+            -- altogether, and use Rec0 all the time.
+                      Gen0_        -> mkRec0 t
+                      Gen1_ argVar -> argPar argVar t
+          where
+            -- Builds argument representation for Rep1 (more complicated due to
+            -- the presence of composition).
+            argPar argVar = argTyFold argVar $ ArgTyAlg
+              {ata_rec0 = mkRec0, ata_par1 = mkPar1,
+               ata_rec1 = mkRec1, ata_comp = mkComp comp k}
+
+        tyConName_user = case tyConFamInst_maybe tycon of
+                           Just (ptycon, _) -> tyConName ptycon
+                           Nothing          -> tyConName tycon
+
+        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
+        mdName  = mkStrLitTy . moduleNameFS . moduleName
+                . nameModule . tyConName $ tycon
+        pkgName = mkStrLitTy . unitIdFS . moduleUnitId
+                . nameModule . tyConName $ tycon
+        isNT    = mkTyConTy $ if isNewTyCon tycon
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
+        ctFix c
+            | dataConIsInfix c
+            = case lookupFixity fix_env (dataConName c) of
+                   Fixity _ n InfixL -> buildFix n pLA
+                   Fixity _ n InfixR -> buildFix n pRA
+                   Fixity _ n InfixN -> buildFix n pNA
+            | otherwise = mkTyConTy pPrefix
+        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
+                                             , mkNumLitTy (fromIntegral n)]
+
+        isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        selName = mkStrLitTy . flLabel
+
+        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]
+        mbSel (Just s) = mkTyConApp promotedJustDataCon
+                                    [typeSymbolKind, selName s]
+
+        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]
+        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
+        metaSelTy mlbl su ss ib =
+            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
+          where
+            pSUpkness = mkTyConTy $ case su of
+                                         SrcUnpack   -> pSUpk
+                                         SrcNoUnpack -> pSNUpk
+                                         NoSrcUnpack -> pNSUpkness
+
+            pSStrness = mkTyConTy $ case ss of
+                                         SrcLazy     -> pSLzy
+                                         SrcStrict   -> pSStr
+                                         NoSrcStrict -> pNSStrness
+
+            pDStrness = mkTyConTy $ case ib of
+                                         HsLazy      -> pDLzy
+                                         HsStrict    -> pDStr
+                                         HsUnpack{}  -> pDUpk
+
+    return (mkD tycon)
+
+mkComp :: TyCon -> Kind -> Type -> Type -> Type
+mkComp comp k f g
+  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]
+  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]
+  where
+    -- Which of these is the case?
+    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
+    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
+    -- We want to instantiate with k1=k, and k2=*
+    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]
+    -- But we need to know which way round!
+    k1_first = k_first == p_kind_var
+    [k_first,_,_,_,p] = tyConTyVars comp
+    Just p_kind_var = getTyVar_maybe (tyVarKind p)
+
+-- Given the TyCons for each URec-related type synonym, check to see if the
+-- given type is an unlifted type that generics understands. If so, return
+-- its representation type. Otherwise, return Rec0.
+-- See Note [Generics and unlifted types]
+mkBoxTy :: TyCon -- UAddr
+        -> TyCon -- UChar
+        -> TyCon -- UDouble
+        -> TyCon -- UFloat
+        -> TyCon -- UInt
+        -> TyCon -- UWord
+        -> TyCon -- Rec0
+        -> Kind  -- What to instantiate Rec0's kind variable with
+        -> Type
+        -> Type
+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
+  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]
+  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]
+  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
+  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]
+  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]
+  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]
+  | otherwise                = mkTyConApp rec0    [k,ty]
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: GenericKind_ -- Generic or Generic1?
+      -> US          -- Base for generating unique names
+      -> [DataCon]   -- The data constructors
+      -> ([Alt],     -- Alternatives for the T->Trep "from" function
+          [Alt])     -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _ _ [] = ([from_alt], [to_alt])
+  where
+    from_alt = (x_Pat, nlHsCase x_Expr [])
+    to_alt   = (x_Pat, nlHsCase x_Expr [])
+               -- These M1s are meta-information for the datatype
+
+-- Datatype with at least one constructor
+mkSum gk_ us datacons =
+  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
+ unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
+           | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: GenericKind_DC -- Generic or Generic1?
+       -> US        -- Base for generating unique names
+       -> Int       -- The index of this constructor
+       -> Int       -- Total number of constructors
+       -> DataCon   -- The data constructor
+       -> (Alt,     -- Alternative for the T->Trep "from" function
+           Alt)     -- Alternative for the Trep->T "to" function
+mk1Sum gk_ us i n datacon = (from_alt, to_alt)
+  where
+    gk = forgetArgVar gk_
+
+    -- Existentials already excluded
+    argTys = dataConOrigArgTys datacon
+    n_args = dataConSourceArity datacon
+
+    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
+    datacon_vars = map fst datacon_varTys
+    us'          = us + n_args
+
+    datacon_rdr  = getRdrName datacon
+
+    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)
+
+    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)
+                 , to_alt_rhs
+                 ) -- These M1s are meta-information for the datatype
+    to_alt_rhs = case gk_ of
+      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
+      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
+        where
+          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
+            converter = argTyFold argVar $ ArgTyAlg
+              {ata_rec0 = nlHsVar . unboxRepRDR,
+               ata_par1 = nlHsVar unPar1_RDR,
+               ata_rec1 = const $ nlHsVar unRec1_RDR,
+               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
+                                    `nlHsCompose` nlHsVar unComp1_RDR}
+
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
+genLR_P i n p
+  | n == 0       = error "impossible"
+  | n == 1       = p
+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+                     where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
+genLR_E i n e
+  | n == 0       = error "impossible"
+  | n == 1       = e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E i     (div n 2) e)
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E (i-m) (n-m)     e)
+                     where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: GenericKind_DC    -- Generic or Generic1?
+         -> US                -- Base for unique names
+         -> [(RdrName, Type)]
+                       -- List of variables matched on the lhs and their types
+         -> LHsExpr GhcPs   -- Resulting product expression
+mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
+                     -- These M1s are meta-information for the constructor
+  where
+    appVars = map (wrapArg_E gk_) varTys
+    prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
+wrapArg_E Gen0_DC          (var, ty) = mkM1_E $
+                            boxRepRDR ty `nlHsVarApps` [var]
+                         -- This M1 is meta-information for the selector
+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
+                            converter ty `nlHsApp` nlHsVar var
+                         -- This M1 is meta-information for the selector
+  where converter = argTyFold argVar $ ArgTyAlg
+          {ata_rec0 = nlHsVar . boxRepRDR,
+           ata_par1 = nlHsVar par1DataCon_RDR,
+           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
+           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
+                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}
+
+boxRepRDR :: Type -> RdrName
+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
+
+unboxRepRDR :: Type -> RdrName
+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
+
+-- Retrieve the RDRs associated with each URec data family instance
+-- constructor. See Note [Generics and unlifted types]
+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
+unboxedRepRDRs ty
+  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)
+  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)
+  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
+  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)
+  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)
+  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)
+  | otherwise          = Nothing
+
+-- Build a product pattern
+mkProd_P :: GenericKind       -- Gen0 or Gen1
+         -> US                -- Base for unique names
+         -> [(RdrName, Type)] -- List of variables to match,
+                              --   along with their types
+         -> LPat GhcPs      -- Resulting product pattern
+mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
+                     -- These M1s are meta-information for the constructor
+  where
+    appVars = unzipWith (wrapArg_P gk) varTys
+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
+
+wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
+                   -- This M1 is meta-information for the selector
+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
+
+mkGenericLocal :: US -> RdrName
+mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
+
+x_RDR :: RdrName
+x_RDR = mkVarUnqual (fsLit "x")
+
+x_Expr :: LHsExpr GhcPs
+x_Expr = nlHsVar x_RDR
+
+x_Pat :: LPat GhcPs
+x_Pat = nlVarPat x_RDR
+
+mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
+
+mkM1_P :: LPat GhcPs -> LPat GhcPs
+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
+
+nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
+
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
+
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _  x []  = x
+foldBal' _  _ [y] = y
+foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
+                    in foldBal' op x a `op` foldBal' op x b
+
+{-
+Note [Generics and unlifted types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, all constants are marked with K1/Rec0. The exception to this rule is
+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
+that case, we must use a data family instance of URec (from GHC.Generics) to
+mark it. As a result, before we can generate K1 or unK1, we must first check
+to see if the type is actually one of the unlifted types for which URec has a
+data family instance; if so, we generate that instead.
+
+See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more
+details on why URec is implemented the way it is.
+
+Note [Generating a correctly typed Rep instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
+Generic(1). That is, it derives the ellipsis in the following:
+
+    instance Generic Foo where
+      type Rep Foo = ...
+
+However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
+a Generic(1) instance is being derived, not the fully instantiated type. As a
+result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
+the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
+can cause problems when the instance has instantiated type variables
+(see #11732). As an example:
+
+    data T a = MkT a
+    deriving instance Generic (T Int)
+    ==>
+    instance Generic (T Int) where
+      type Rep (T Int) = (... (Rec0 a)) -- wrong!
+
+-XStandaloneDeriving is one way for the type variables to become instantiated.
+Another way is when Generic1 is being derived for a datatype with a visible
+kind binder, e.g.,
+
+   data P k (a :: k) = MkP k deriving Generic1
+   ==>
+   instance Generic1 (P *) where
+     type Rep1 (P *) = (... (Rec0 k)) -- wrong!
+
+See Note [Unify kinds in deriving] in TcDeriv.
+
+In any such scenario, we must prevent a discrepancy between the LHS and RHS of
+a Rep(1) instance. To do so, we create a type variable substitution that maps
+the tyConTyVars of the TyCon to their counterparts in the fully instantiated
+type. (For example, using T above as example, you'd map a :-> Int.) We then
+apply the substitution to the RHS before generating the instance.
+
+A wrinkle in all of this: when forming the type variable substitution for
+Generic1 instances, we map the last type variable of the tycon to Any. Why?
+It's because of wily data types like this one (#15012):
+
+   data T a = MkT (FakeOut a)
+   type FakeOut a = Int
+
+If we ignore a, then we'll produce the following Rep1 instance:
+
+   instance Generic1 T where
+     type Rep1 T = ... (Rec0 (FakeOut a))
+     ...
+
+Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we
+ensure that `a` is mapped to Any:
+
+   instance Generic1 T where
+     type Rep1 T = ... (Rec0 (FakeOut Any))
+     ...
+
+And now all is good.
+
+Alternatively, we could have avoided this problem by expanding all type
+synonyms on the RHSes of Rep1 instances. But we might blow up the size of
+these types even further by doing this, so we choose not to do so.
+
+Note [Handling kinds in a Rep instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because Generic1 is poly-kinded, the representation types were generalized to
+be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
+the kind of the instance being derived to all the representation type
+constructors. For instance, if you have
+
+    data Empty (a :: k) = Empty deriving Generic1
+
+Then the generated code is now approximately (with -fprint-explicit-kinds
+syntax):
+
+    instance Generic1 k (Empty k) where
+      type Rep1 k (Empty k) = U1 k
+
+Most representation types have only one kind variable, making them easy to deal
+with. The only non-trivial case is (:.:), which is only used in Generic1
+instances:
+
+    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
+        Comp1 { unComp1 :: f (g p) }
+
+Here, we do something a bit counter-intuitive: we make k1 be the kind of the
+instance being derived, and we always make k2 be *. Why *? It's because
+the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
+for some types x and y. In other words, the second type to which (:.:) is
+applied always has kind k -> *, for some kind k, so k2 cannot possibly be
+anything other than * in a generated Generic1 instance.
+
+Note [Generics compilation speed tricks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deriving Generic(1) is known to have a large constant factor during
+compilation, which contributes to noticeable compilation slowdowns when
+deriving Generic(1) for large datatypes (see #5642).
+
+To ease the pain, there is a trick one can play when generating definitions for
+to(1) and from(1). If you have a datatype like:
+
+  data Letter = A | B | C | D
+
+then a naïve Generic instance for Letter would be:
+
+  instance Generic Letter where
+    type Rep Letter = D1 ('MetaData ...) ...
+
+    to (M1 (L1 (L1 (M1 U1)))) = A
+    to (M1 (L1 (R1 (M1 U1)))) = B
+    to (M1 (R1 (L1 (M1 U1)))) = C
+    to (M1 (R1 (R1 (M1 U1)))) = D
+
+    from A = M1 (L1 (L1 (M1 U1)))
+    from B = M1 (L1 (R1 (M1 U1)))
+    from C = M1 (R1 (L1 (M1 U1)))
+    from D = M1 (R1 (R1 (M1 U1)))
+
+Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
+expression in the 'from' definition, the topmost constructor is M1. This
+corresponds to the datatype-specific metadata (the D1 in the Rep Letter
+instance). But this is wasteful from a typechecking perspective, since this
+definition requires GHC to typecheck an application of M1 in every single case,
+leading to an O(n) increase in the number of coercions the typechecker has to
+solve, which in turn increases allocations and degrades compilation speed.
+
+Luckily, since the topmost M1 has the exact same type across every case, we can
+factor it out reduce the typechecker's burden:
+
+  instance Generic Letter where
+    type Rep Letter = D1 ('MetaData ...) ...
+
+    to (M1 x) = case x of
+      L1 (L1 (M1 U1)) -> A
+      L1 (R1 (M1 U1)) -> B
+      R1 (L1 (M1 U1)) -> C
+      R1 (R1 (M1 U1)) -> D
+
+    from x = M1 (case x of
+      A -> L1 (L1 (M1 U1))
+      B -> L1 (R1 (M1 U1))
+      C -> R1 (L1 (M1 U1))
+      D -> R1 (R1 (M1 U1)))
+
+A simple change, but one that pays off, since it goes turns an O(n) amount of
+coercions to an O(1) amount.
+-}
diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHoleErrors.hs
@@ -0,0 +1,1028 @@
+module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)
+                    , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes
+                    , withoutUnification ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import TcRnMonad
+import TcMType
+import TcEvidence
+import TcType
+import Type
+import DataCon
+import Name
+import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )
+import PrelNames ( gHC_ERR )
+import Id
+import VarSet
+import VarEnv
+import Bag
+import ConLike          ( ConLike(..) )
+import Util
+import TcEnv (tcLookup)
+import Outputable
+import DynFlags
+import Maybes
+import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )
+
+import Control.Arrow ( (&&&) )
+
+import Control.Monad    ( filterM, replicateM )
+import Data.List        ( partition, sort, sortOn, nubBy )
+import Data.Graph       ( graphFromEdges, topSort )
+import Data.Function    ( on )
+
+
+import TcSimplify    ( simpl_top, runTcSDeriveds )
+import TcUnify       ( tcSubType_NC )
+
+import ExtractDocs ( extractDocs )
+import qualified Data.Map as Map
+import HsDoc           ( HsDocString, unpackHDS, DeclDocMap(..) )
+import HscTypes        ( ModIface(..) )
+import LoadIface       ( loadInterfaceForNameMaybe )
+
+import PrelInfo (knownKeyNames)
+
+
+{-
+Note [Valid hole fits include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+`findValidHoleFits` returns the "Valid hole fits include ..." message.
+For example, look at the following definitions in a file called test.hs:
+
+   import Data.List (inits)
+
+   f :: [String]
+   f = _ "hello, world"
+
+The hole in `f` would generate the message:
+
+  • Found hole: _ :: [Char] -> [String]
+  • In the expression: _
+    In the expression: _ "hello, world"
+    In an equation for ‘f’: f = _ "hello, world"
+  • Relevant bindings include f :: [String] (bound at test.hs:6:1)
+    Valid hole fits include
+      lines :: String -> [String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      words :: String -> [String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      inits :: forall a. [a] -> [[a]]
+        with inits @Char
+        (imported from ‘Data.List’ at mpt.hs:4:19-23
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      repeat :: forall a. a -> [a]
+        with repeat @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.List’))
+      fail :: forall (m :: * -> *). Monad m => forall a. String -> m a
+        with fail @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      return :: forall (m :: * -> *). Monad m => forall a. a -> m a
+        with return @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a
+        with pure @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      read :: forall a. Read a => String -> a
+        with read @[String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘Text.Read’))
+      mempty :: forall a. Monoid a => a
+        with mempty @([Char] -> [String])
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+
+Valid hole fits are found by checking top level identifiers and local bindings
+in scope for whether their type can be instantiated to the the type of the hole.
+Additionally, we also need to check whether all relevant constraints are solved
+by choosing an identifier of that type as well, see Note [Relevant Constraints]
+
+Since checking for subsumption results in the side-effect of type variables
+being unified by the simplifier, we need to take care to restore them after
+to being flexible type variables after we've checked for subsumption.
+This is to avoid affecting the hole and later checks by prematurely having
+unified one of the free unification variables.
+
+When outputting, we sort the hole fits by the size of the types we'd need to
+apply by type application to the type of the fit to to make it fit. This is done
+in order to display "more relevant" suggestions first. Another option is to
+sort by building a subsumption graph of fits, i.e. a graph of which fits subsume
+what other fits, and then outputting those fits which are are subsumed by other
+fits (i.e. those more specific than other fits) first. This results in the ones
+"closest" to the type of the hole to be displayed first.
+
+To help users understand how the suggested fit works, we also display the values
+that the quantified type variables would take if that fit is used, like
+`mempty @([Char] -> [String])` and `pure @[] @String` in the example above.
+If -XTypeApplications is enabled, this can even be copied verbatim as a
+replacement for the hole.
+
+
+Note [Nested implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For the simplifier to be able to use any givens present in the enclosing
+implications to solve relevant constraints, we nest the wanted subsumption
+constraints and relevant constraints within the enclosing implications.
+
+As an example, let's look at the following code:
+
+  f :: Show a => a -> String
+  f x = show _
+
+The hole will result in the hole constraint:
+
+  [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_))
+
+Here the nested implications are just one level deep, namely:
+
+  [Implic {
+      TcLevel = 2
+      Skolems = a_a1pa[sk:2]
+      No-eqs = True
+      Status = Unsolved
+      Given = $dShow_a1pc :: Show a_a1pa[sk:2]
+      Wanted =
+        WC {wc_simple =
+              [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_))
+              [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))}
+      Binds = EvBindsVar<a1pi>
+      Needed inner = []
+      Needed outer = []
+      the type signature for:
+        f :: forall a. Show a => a -> String }]
+
+As we can see, the givens say that the information about the skolem
+`a_a1pa[sk:2]` fulfills the Show constraint.
+
+The simples are:
+
+  [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)),
+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)]
+
+I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must
+fulfill `Show a0_a1pd[tau:2])`.
+
+So when we run the check, we need to make sure that the
+
+  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)
+
+Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits
+the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the
+meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted
+constraints needed by tcSubType_NC and the relevant constraints (see
+Note [Relevant Constraints] for more details) in the nested implications, we
+can pass the information in the givens along to the simplifier. For our example,
+we end up needing to check whether the following constraints are soluble.
+
+  WC {wc_impl =
+        Implic {
+          TcLevel = 2
+          Skolems = a_a1pa[sk:2]
+          No-eqs = True
+          Status = Unsolved
+          Given = $dShow_a1pc :: Show a_a1pa[sk:2]
+          Wanted =
+            WC {wc_simple =
+                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}
+          Binds = EvBindsVar<a1pl>
+          Needed inner = []
+          Needed outer = []
+          the type signature for:
+            f :: forall a. Show a => a -> String }}
+
+But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested
+implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up
+with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match.
+
+To avoid side-effects on the nested implications, we create a new EvBindsVar so
+that any changes to the ev binds during a check remains localised to that check.
+
+
+Note [Valid refinement hole fits include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the `-frefinement-level-hole-fits=N` flag is given, we additionally look
+for "valid refinement hole fits"", i.e. valid hole fits with up to N
+additional holes in them.
+
+With `-frefinement-level-hole-fits=0` (the default), GHC will find all
+identifiers 'f' (top-level or nested) that will fit in the hole.
+
+With `-frefinement-level-hole-fits=1`, GHC will additionally find all
+applications 'f _' that will fit in the hole, where 'f' is an in-scope
+identifier, applied to single argument.  It will also report the type of the
+needed argument (a new hole).
+
+And similarly as the number of arguments increases
+
+As an example, let's look at the following code:
+
+  f :: [Integer] -> Integer
+  f = _
+
+with `-frefinement-level-hole-fits=1`, we'd get:
+
+  Valid refinement hole fits include
+
+    foldl1 (_ :: Integer -> Integer -> Integer)
+      with foldl1 @[] @Integer
+      where foldl1 :: forall (t :: * -> *).
+                      Foldable t =>
+                      forall a. (a -> a -> a) -> t a -> a
+    foldr1 (_ :: Integer -> Integer -> Integer)
+      with foldr1 @[] @Integer
+      where foldr1 :: forall (t :: * -> *).
+                      Foldable t =>
+                      forall a. (a -> a -> a) -> t a -> a
+    const (_ :: Integer)
+      with const @Integer @[Integer]
+      where const :: forall a b. a -> b -> a
+    ($) (_ :: [Integer] -> Integer)
+      with ($) @'GHC.Types.LiftedRep @[Integer] @Integer
+      where ($) :: forall a b. (a -> b) -> a -> b
+    fail (_ :: String)
+      with fail @((->) [Integer]) @Integer
+      where fail :: forall (m :: * -> *).
+                    Monad m =>
+                    forall a. String -> m a
+    return (_ :: Integer)
+      with return @((->) [Integer]) @Integer
+      where return :: forall (m :: * -> *). Monad m => forall a. a -> m a
+    (Some refinement hole fits suppressed;
+      use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits)
+
+Which are hole fits with holes in them. This allows e.g. beginners to
+discover the fold functions and similar, but also allows for advanced users
+to figure out the valid functions in the Free monad, e.g.
+
+  instance Functor f => Monad (Free f) where
+      Pure a >>= f = f a
+      Free f >>= g = Free (fmap _a f)
+
+Will output (with -frefinment-level-hole-fits=1):
+    Found hole: _a :: Free f a -> Free f b
+          Where: ‘a’, ‘b’ are rigid type variables bound by
+                  the type signature for:
+                    (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b
+                  at fms.hs:25:12-14
+                ‘f’ is a rigid type variable bound by
+    ...
+    Relevant bindings include
+      g :: a -> Free f b (bound at fms.hs:27:16)
+      f :: f (Free f a) (bound at fms.hs:27:10)
+      (>>=) :: Free f a -> (a -> Free f b) -> Free f b
+        (bound at fms.hs:25:12)
+    ...
+    Valid refinement hole fits include
+      ...
+      (=<<) (_ :: a -> Free f b)
+        with (=<<) @(Free f) @a @b
+        where (=<<) :: forall (m :: * -> *) a b.
+                      Monad m =>
+                      (a -> m b) -> m a -> m b
+        (imported from ‘Prelude’ at fms.hs:5:18-22
+        (and originally defined in ‘GHC.Base’))
+      ...
+
+Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`).
+
+We find these refinement suggestions by considering hole fits that don't
+fit the type of the hole, but ones that would fit if given an additional
+argument. We do this by creating a new type variable with `newOpenFlexiTyVar`
+(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type
+`t_a1/m[tau:1] -> v` where `v` is the type of the hole.
+
+Since the simplifier is free to unify this new type variable with any type, we
+can discover any identifiers that would fit if given another identifier of a
+suitable type. This is then generalized so that we can consider any number of
+additional arguments by setting the `-frefinement-level-hole-fits` flag to any
+number, and then considering hole fits like e.g. `foldl _ _` with two additional
+arguments.
+
+To make sure that the refinement hole fits are useful, we check that the types
+of the additional holes have a concrete value and not just an invented type
+variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`,
+and limits the number of less than useful refinement hole fits.
+
+Additionally, to further aid the user in their implementation, we show the
+types of the holes the binding would have to be applied to in order to work.
+In the free monad example above, this is demonstrated with
+`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to
+be applied to an expression of type `a -> Free f b` in order to match.
+If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim.
+
+
+Note [Relevant Constraints]
+~~~~~~~~~~~~~~~~~~~
+
+As highlighted by #14273, we need to check any relevant constraints as well
+as checking for subsumption. Relevant constraints are the simple constraints
+whose free unification variables are mentioned in the type of the hole.
+
+In the simplest case, these are all non-hole constraints in the simples, such
+as is the case in
+
+  f :: String
+  f = show _
+
+Where the simples will be :
+
+  [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)),
+    [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)]
+
+However, when there are multiple holes, we need to be more careful. As an
+example, Let's take a look at the following code:
+
+  f :: Show a => a -> String
+  f x = show (_b (show _a))
+
+Here there are two holes, `_a` and `_b`, and the simple constraints passed to
+findValidHoleFits are:
+
+  [[WD] _a_a1pi {0}:: String
+                        -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)),
+    [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)),
+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),
+    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]
+
+
+Here we have the two hole constraints for `_a` and `_b`, but also additional
+constraints that these holes must fulfill. When we are looking for a match for
+the hole `_a`, we filter the simple constraints to the "Relevant constraints",
+by throwing out all hole constraints and any constraints which do not mention
+a variable mentioned in the type of the hole. For hole `_a`, we will then
+only require that the `$dShow_a1pp` constraint is solved, since that is
+the only non-hole constraint that mentions any free type variables mentioned in
+the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the
+hole `_b` we only require that the `$dShow_a1pe` constraint is solved.
+
+Note [Leaking errors]
+~~~~~~~~~~~~~~~~~~~
+
+When considering candidates, GHC believes that we're checking for validity in
+actual source. However, As evidenced by #15321, #15007 and #15202, this can
+cause bewildering error messages. The solution here is simple: if a candidate
+would cause the type checker to error, it is not a valid hole fit, and thus it
+is discarded.
+
+-}
+
+
+data HoleFitDispConfig = HFDC { showWrap :: Bool
+                              , showWrapVars :: Bool
+                              , showType :: Bool
+                              , showProv :: Bool
+                              , showMatches :: Bool }
+
+debugHoleFitDispConfig :: HoleFitDispConfig
+debugHoleFitDispConfig = HFDC True True True False False
+
+
+-- We read the various -no-show-*-of-hole-fits flags
+-- and set the display config accordingly.
+getHoleFitDispConfig :: TcM HoleFitDispConfig
+getHoleFitDispConfig
+  = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits
+       ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits
+       ; sType <- goptM Opt_ShowTypeOfHoleFits
+       ; sProv <- goptM Opt_ShowProvOfHoleFits
+       ; sMatc <- goptM Opt_ShowMatchesOfHoleFits
+       ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars
+                    , showProv = sProv, showType = sType
+                    , showMatches = sMatc } }
+
+-- Which sorting algorithm to use
+data SortingAlg = NoSorting      -- Do not sort the fits at all
+                | BySize         -- Sort them by the size of the match
+                | BySubsumption  -- Sort by full subsumption
+                deriving (Eq, Ord)
+
+getSortingAlg :: TcM SortingAlg
+getSortingAlg =
+    do { shouldSort <- goptM Opt_SortValidHoleFits
+       ; subsumSort <- goptM Opt_SortBySubsumHoleFits
+       ; sizeSort <- goptM Opt_SortBySizeHoleFits
+       -- We default to sizeSort unless it has been explicitly turned off
+       -- or subsumption sorting has been turned on.
+       ; return $ if not shouldSort
+                    then NoSorting
+                    else if subsumSort
+                         then BySubsumption
+                         else if sizeSort
+                              then BySize
+                              else NoSorting }
+
+
+-- | HoleFitCandidates are passed to the filter and checked whether they can be
+-- made to fit.
+data HoleFitCandidate = IdHFCand Id             -- An id, like locals.
+                      | NameHFCand Name         -- A name, like built-in syntax.
+                      | GreHFCand GlobalRdrElt  -- A global, like imported ids.
+                      deriving (Eq)
+instance Outputable HoleFitCandidate where
+  ppr = pprHoleFitCand
+
+pprHoleFitCand :: HoleFitCandidate -> SDoc
+pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id
+pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name
+pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre
+
+instance HasOccName HoleFitCandidate where
+  occName hfc = case hfc of
+                  IdHFCand id -> occName id
+                  NameHFCand name -> occName name
+                  GreHFCand gre -> occName (gre_name gre)
+
+-- | HoleFit is the type we use for valid hole fits. It contains the
+-- element that was checked, the Id of that element as found by `tcLookup`,
+-- and the refinement level of the fit, which is the number of extra argument
+-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
+data HoleFit =
+  HoleFit { hfId   :: Id       -- The elements id in the TcM
+          , hfCand :: HoleFitCandidate  -- The candidate that was checked.
+          , hfType :: TcType -- The type of the id, possibly zonked.
+          , hfRefLvl :: Int  -- The number of holes in this fit.
+          , hfWrap :: [TcType] -- The wrapper for the match.
+          , hfMatches :: [TcType]  -- What the refinement variables got matched
+                                   -- with, if anything
+          , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if
+                                         -- available.
+
+
+hfName :: HoleFit -> Name
+hfName hf = case hfCand hf of
+              IdHFCand id -> idName id
+              NameHFCand name -> name
+              GreHFCand gre -> gre_name gre
+
+hfIsLcl :: HoleFit -> Bool
+hfIsLcl hf = case hfCand hf of
+               IdHFCand _    -> True
+               NameHFCand _  -> False
+               GreHFCand gre -> gre_lcl gre
+
+-- We define an Eq and Ord instance to be able to build a graph.
+instance Eq HoleFit where
+   (==) = (==) `on` hfId
+
+-- We compare HoleFits by their name instead of their Id, since we don't
+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
+-- which is used to compare Ids. When comparing, we want HoleFits with a lower
+-- refinement level to come first.
+instance Ord HoleFit where
+  compare a b = cmp a b
+    where cmp  = if hfRefLvl a == hfRefLvl b
+                 then compare `on` hfName
+                 else compare `on` hfRefLvl
+
+instance Outputable HoleFit where
+    ppr = pprHoleFit debugHoleFitDispConfig
+
+-- If enabled, we go through the fits and add any associated documentation,
+-- by looking it up in the module or the environment (for local fits)
+addDocs :: [HoleFit] -> TcM [HoleFit]
+addDocs fits =
+  do { showDocs <- goptM Opt_ShowDocsOfHoleFits
+     ; if showDocs
+       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv
+               ; mapM (upd lclDocs) fits }
+       else return fits }
+  where
+   msg = text "TcHoleErrors addDocs"
+   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
+     = Map.lookup name dmap
+   upd lclDocs fit =
+     let name = hfName fit in
+     do { doc <- if hfIsLcl fit
+                 then pure (Map.lookup name lclDocs)
+                 else do { mbIface <- loadInterfaceForNameMaybe msg name
+                         ; return $ mbIface >>= lookupInIface name }
+        ; return $ fit {hfDoc = doc} }
+
+-- For pretty printing hole fits, we display the name and type of the fit,
+-- with added '_' to represent any extra arguments in case of a non-zero
+-- refinement level.
+pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance
+    where name = hfName hf
+          ty = hfType hf
+          matches =  hfMatches hf
+          wrap = hfWrap hf
+          tyApp = sep $ map ((text "@" <>) . pprParendType) wrap
+          tyAppVars = sep $ punctuate comma $
+              map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $
+                zip vars wrap
+            where
+              vars = unwrapTypeVars ty
+              -- Attempts to get all the quantified type variables in a type,
+              -- e.g.
+              -- return :: forall (m :: * -> *) Monad m => (forall a . a) -> m a
+              -- into [m, a]
+              unwrapTypeVars :: Type -> [TyVar]
+              unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
+                                  Just (_, unfunned) -> unwrapTypeVars unfunned
+                                  _ -> []
+                where (vars, unforalled) = splitForAllTys t
+          holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches
+          holeDisp = if sMs then holeVs
+                     else sep $ replicate (length matches) $ text "_"
+          occDisp = pprPrefixOcc name
+          tyDisp = ppWhen sTy $ dcolon <+> ppr ty
+          has = not . null
+          wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars))
+                      $ text "with" <+> if sWrp || not sTy
+                                        then occDisp <+> tyApp
+                                        else tyAppVars
+          docs = case hfDoc hf of
+                   Just d -> text "{-^" <>
+                             (vcat . map text . lines . unpackHDS) d
+                             <> text "-}"
+                   _ -> empty
+          funcInfo = ppWhen (has matches && sTy) $
+                       text "where" <+> occDisp <+> tyDisp
+          subDisp = occDisp <+> if has matches then holeDisp else tyDisp
+          display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
+          provenance = ppWhen sProv $ parens $
+                case hfCand hf of
+                    GreHFCand gre -> pprNameProvenance gre
+                    _ -> text "bound at" <+> ppr (getSrcLoc name)
+
+getLocalBindings :: TidyEnv -> Ct -> TcM [Id]
+getLocalBindings tidy_orig ct
+ = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc)
+      ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) }
+  where
+    loc     = ctEvLoc (ctEvidence ct)
+    lcl_env = ctLocEnv loc
+
+    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
+    go _ sofar [] = return (reverse sofar)
+    go env sofar (tc_bndr : tc_bndrs) =
+        case tc_bndr of
+          TcIdBndr id _ -> keep_it id
+          _ -> discard_it
+     where
+        discard_it = go env sofar tc_bndrs
+        keep_it id = go env (id:sofar) tc_bndrs
+
+
+
+-- See Note [Valid hole fits include ...]
+findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking
+                  -> [Implication]  -- ^ Enclosing implications for givens
+                  -> [Ct]
+                  -- ^ The  unsolved simple constraints in the implication for
+                  -- the hole.
+                  -> Ct -- ^ The hole constraint itself
+                  -> TcM (TidyEnv, SDoc)
+findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
+  do { rdr_env <- getGlobalRdrEnv
+     ; lclBinds <- getLocalBindings tidy_env ct
+     ; maxVSubs <- maxValidHoleFits <$> getDynFlags
+     ; hfdc <- getHoleFitDispConfig
+     ; sortingAlg <- getSortingAlg
+     ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs
+     ; refLevel <- refLevelHoleFits <$> getDynFlags
+     ; traceTc "findingValidHoleFitsFor { " $ ppr ct
+     ; traceTc "hole_lvl is:" $ ppr hole_lvl
+     ; traceTc "implics are: " $ ppr implics
+     ; traceTc "simples are: " $ ppr simples
+     ; traceTc "locals are: " $ ppr lclBinds
+     ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)
+           -- We remove binding shadowings here, but only for the local level.
+           -- this is so we e.g. suggest the global fmap from the Functor class
+           -- even though there is a local definition as well, such as in the
+           -- Free monad example.
+           locals = removeBindingShadowing $
+                      map IdHFCand lclBinds ++ map GreHFCand lcl
+           globals = map GreHFCand gbl
+           syntax = map NameHFCand builtIns
+           to_check = locals ++ syntax ++ globals
+     ; (searchDiscards, subs) <-
+        tcFilterHoleFits findVLimit implics relevantCts (hole_ty, []) to_check
+     ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs
+     ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs
+     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs
+           vDiscards = pVDisc || searchDiscards
+     ; subs_with_docs <- addDocs limited_subs
+     ; let vMsg = ppUnless (null subs_with_docs) $
+                    hang (text "Valid hole fits include") 2 $
+                      vcat (map (pprHoleFit hfdc) subs_with_docs)
+                        $$ ppWhen vDiscards subsDiscardMsg
+     -- Refinement hole fits. See Note [Valid refinement hole fits include ...]
+     ; (tidy_env, refMsg) <- if refLevel >= Just 0 then
+         do { maxRSubs <- maxRefHoleFits <$> getDynFlags
+            -- We can use from just, since we know that Nothing >= _ is False.
+            ; let refLvls = [1..(fromJust refLevel)]
+            -- We make a new refinement type for each level of refinement, where
+            -- the level of refinement indicates number of additional arguments
+            -- to allow.
+            ; ref_tys <- mapM mkRefTy refLvls
+            ; traceTc "ref_tys are" $ ppr ref_tys
+            ; let findRLimit = if sortingAlg > NoSorting then Nothing
+                                                         else maxRSubs
+            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit implics
+                                     relevantCts) to_check) ref_tys
+            ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs
+            ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs
+            -- For refinement substitutions we want matches
+            -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),
+            -- and others in that vein to appear last, since these are
+            -- unlikely to be the most relevant fits.
+            ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty
+            ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap
+                  (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs
+                  (pRDisc, exact_last_rfits) =
+                    possiblyDiscard maxRSubs $ not_exact ++ exact
+                  rDiscards = pRDisc || any fst refDs
+            ; rsubs_with_docs <- addDocs exact_last_rfits
+            ; return (tidy_env,
+                ppUnless (null rsubs_with_docs) $
+                  hang (text "Valid refinement hole fits include") 2 $
+                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)
+                    $$ ppWhen rDiscards refSubsDiscardMsg) }
+       else return (tidy_env, empty)
+     ; traceTc "findingValidHoleFitsFor }" empty
+     ; return (tidy_env, vMsg $$ refMsg) }
+  where
+    -- We extract the type, the tcLevel and the types free variables
+    -- from from the constraint.
+    hole_ty :: TcPredType
+    hole_ty = ctPred ct
+    hole_fvs :: FV
+    hole_fvs = tyCoFVsOfType hole_ty
+    hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct
+
+    -- BuiltInSyntax names like (:) and []
+    builtIns :: [Name]
+    builtIns = filter isBuiltInSyntax knownKeyNames
+
+    -- We make a refinement type by adding a new type variable in front
+    -- of the type of t h hole, going from e.g. [Integer] -> Integer
+    -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier
+    -- to unify the new type variable with any type, allowing us
+    -- to suggest a "refinement hole fit", like `(foldl1 _)` instead
+    -- of only concrete hole fits like `sum`.
+    mkRefTy :: Int -> TcM (TcType, [TcTyVar])
+    mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars
+      where newTyVars = replicateM refLvl $ setLvl <$>
+                            (newOpenTypeKind >>= newFlexiTyVar)
+            setLvl = flip setMetaTyVarTcLevel hole_lvl
+            wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty
+
+    sortFits :: SortingAlg    -- How we should sort the hole fits
+             -> [HoleFit]     -- The subs to sort
+             -> TcM [HoleFit]
+    sortFits NoSorting subs = return subs
+    sortFits BySize subs
+        = (++) <$> sortBySize (sort lclFits)
+               <*> sortBySize (sort gblFits)
+        where (lclFits, gblFits) = span hfIsLcl subs
+
+    -- To sort by subsumption, we invoke the sortByGraph function, which
+    -- builds the subsumption graph for the fits and then sorts them using a
+    -- graph sort.  Since we want locals to come first anyway, we can sort
+    -- them separately. The substitutions are already checked in local then
+    -- global order, so we can get away with using span here.
+    -- We use (<*>) to expose the parallelism, in case it becomes useful later.
+    sortFits BySubsumption subs
+        = (++) <$> sortByGraph (sort lclFits)
+               <*> sortByGraph (sort gblFits)
+        where (lclFits, gblFits) = span hfIsLcl subs
+
+    -- See Note [Relevant Constraints]
+    relevantCts :: [Ct]
+    relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then []
+                  else filter isRelevant simples
+      where ctFreeVarSet :: Ct -> VarSet
+            ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred
+            hole_fv_set = fvVarSet hole_fvs
+            anyFVMentioned :: Ct -> Bool
+            anyFVMentioned ct = not $ isEmptyVarSet $
+                                  ctFreeVarSet ct `intersectVarSet` hole_fv_set
+            -- We filter out those constraints that have no variables (since
+            -- they won't be solved by finding a type for the type variable
+            -- representing the hole) and also other holes, since we're not
+            -- trying to find hole fits for many holes at once.
+            isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))
+                            && anyFVMentioned ct
+                            && not (isHoleCt ct)
+
+    -- We zonk the hole fits so that the output aligns with the rest
+    -- of the typed hole error message output.
+    zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
+    zonkSubs = zonkSubs' []
+      where zonkSubs' zs env [] = return (env, reverse zs)
+            zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf
+                                           ; zonkSubs' (z:zs) env' hfs }
+            zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}
+              = do { (env, ty') <- zonkTidyTcType env ty
+                   ; (env, m') <- zonkTidyTcTypes env m
+                   ; (env, wrp') <- zonkTidyTcTypes env wrp
+                   ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}
+                   ; return (env, zFit ) }
+
+    -- Based on the flags, we might possibly discard some or all the
+    -- fits we've found.
+    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
+    possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)
+    possiblyDiscard Nothing fits = (False, fits)
+
+    -- Sort by size uses as a measure for relevance the sizes of the
+    -- different types needed to instantiate the fit to the type of the hole.
+    -- This is much quicker than sorting by subsumption, and gives reasonable
+    -- results in most cases.
+    sortBySize :: [HoleFit] -> TcM [HoleFit]
+    sortBySize = return . sortOn sizeOfFit
+      where sizeOfFit :: HoleFit -> TypeSize
+            sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap
+
+    -- Based on a suggestion by phadej on #ghc, we can sort the found fits
+    -- by constructing a subsumption graph, and then do a topological sort of
+    -- the graph. This makes the most specific types appear first, which are
+    -- probably those most relevant. This takes a lot of work (but results in
+    -- much more useful output), and can be disabled by
+    -- '-fno-sort-valid-hole-fits'.
+    sortByGraph :: [HoleFit] -> TcM [HoleFit]
+    sortByGraph fits = go [] fits
+      where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool
+            tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)
+              where fvs = tyCoFVsOfTypes [ht,ty]
+            go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
+            go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar
+                             ; return $ uncurry (++)
+                                         $ partition hfIsLcl topSorted }
+              where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)
+                    (graph, fromV, _) = graphFromEdges $ map toV sofar
+                    topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph
+            go sofar (hf:hfs) =
+              do { adjs <-
+                     filterM (tcSubsumesWCloning (hfType hf) . hfType) fits
+                 ; go ((hf, adjs):sofar) hfs }
+
+-- We don't (as of yet) handle holes in types, only in expressions.
+findValidHoleFits env _ _ _ = return (env, empty)
+
+
+-- | tcFilterHoleFits filters the candidates by whether, given the implications
+-- and the relevant constraints, they can be made to match the type by
+-- running the type checker. Stops after finding limit matches.
+tcFilterHoleFits :: Maybe Int
+               -- ^ How many we should output, if limited
+               -> [Implication]
+               -- ^ Enclosing implications for givens
+               -> [Ct]
+               -- ^ Any relevant unsolved simple constraints
+               -> (TcType, [TcTyVar])
+               -- ^ The type to check for fits and a list of refinement
+               -- variables (free type variables in the type) for emulating
+               -- additional holes.
+               -> [HoleFitCandidate]
+               -- ^ The candidates to check whether fit.
+               -> TcM (Bool, [HoleFit])
+               -- ^ We return whether or not we stopped due to hitting the limit
+               -- and the fits we found.
+tcFilterHoleFits (Just 0) _ _ _ _ = return (False, []) -- Stop right away on 0
+tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =
+  do { traceTc "checkingFitsFor {" $ ppr hole_ty
+     ; (discards, subs) <- go [] emptyVarSet limit ht candidates
+     ; traceTc "checkingFitsFor }" empty
+     ; return (discards, subs) }
+  where
+    hole_fvs :: FV
+    hole_fvs = tyCoFVsOfType hole_ty
+    -- Kickoff the checking of the elements.
+    -- We iterate over the elements, checking each one in turn for whether
+    -- it fits, and adding it to the results if it does.
+    go :: [HoleFit]           -- What we've found so far.
+       -> VarSet              -- Ids we've already checked
+       -> Maybe Int           -- How many we're allowed to find, if limited
+       -> (TcType, [TcTyVar]) -- The type, and its refinement variables.
+       -> [HoleFitCandidate]  -- The elements we've yet to check.
+       -> TcM (Bool, [HoleFit])
+    go subs _ _ _ [] = return (False, reverse subs)
+    go subs _ (Just 0) _ _ = return (True, reverse subs)
+    go subs seen maxleft ty (el:elts) =
+        -- See Note [Leaking errors]
+        tryTcDiscardingErrs discard_it $
+        do { traceTc "lookingUp" $ ppr el
+           ; maybeThing <- lookup el
+           ; case maybeThing of
+               Just id | not_trivial id ->
+                       do { fits <- fitsHole ty (idType id)
+                          ; case fits of
+                              Just (wrp, matches) -> keep_it id wrp matches
+                              _ -> discard_it }
+               _ -> discard_it }
+        where
+          -- We want to filter out undefined and the likes from GHC.Err
+          not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR
+
+          lookup :: HoleFitCandidate -> TcM (Maybe Id)
+          lookup (IdHFCand id) = return (Just id)
+          lookup hfc = do { thing <- tcLookup name
+                          ; return $ case thing of
+                                       ATcId {tct_id = id} -> Just id
+                                       AGlobal (AnId id)   -> Just id
+                                       AGlobal (AConLike (RealDataCon con)) ->
+                                           Just (dataConWrapId con)
+                                       _ -> Nothing }
+            where name = case hfc of
+                           IdHFCand id -> idName id
+                           GreHFCand gre -> gre_name gre
+                           NameHFCand name -> name
+          discard_it = go subs seen maxleft ty elts
+          keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid)
+                                 ((\n -> n - 1) <$> maxleft) ty elts
+            where
+              fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid)
+                            , hfRefLvl = length (snd ty)
+                            , hfWrap = wrp, hfMatches = ms
+                            , hfDoc = Nothing }
+
+
+
+
+    unfoldWrapper :: HsWrapper -> [Type]
+    unfoldWrapper = reverse . unfWrp'
+      where unfWrp' (WpTyApp ty) = [ty]
+            unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
+            unfWrp' _ = []
+
+
+    -- The real work happens here, where we invoke the type checker using
+    -- tcCheckHoleFit to see whether the given type fits the hole.
+    fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the
+                                    -- refinement variables created to simulate
+                                    -- additional holes (if any), and the list
+                                    -- of those variables (possibly empty).
+                                    -- As an example: If the actual type of the
+                                    -- hole (as specified by the hole
+                                    -- constraint CHoleExpr passed to
+                                    -- findValidHoleFits) is t and we want to
+                                    -- simulate N additional holes, h_ty will
+                                    -- be  r_1 -> ... -> r_N -> t, and
+                                    -- ref_vars will be [r_1, ... , r_N].
+                                    -- In the base case with no additional
+                                    -- holes, h_ty will just be t and ref_vars
+                                    -- will be [].
+             -> TcType -- The type we're checking to whether it can be
+                       -- instantiated to the type h_ty.
+             -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we
+                                                 -- return Nothing. Otherwise,
+                                                 -- we Just return the list of
+                                                 -- types that quantified type
+                                                 -- variables in ty would take
+                                                 -- if used in place of h_ty,
+                                                 -- and the list types of any
+                                                 -- additional holes simulated
+                                                 -- with the refinement
+                                                 -- variables in ref_vars.
+    fitsHole (h_ty, ref_vars) ty =
+    -- We wrap this with the withoutUnification to avoid having side-effects
+    -- beyond the check, but we rely on the side-effects when looking for
+    -- refinement hole fits, so we can't wrap the side-effects deeper than this.
+      withoutUnification fvs $
+      do { traceTc "checkingFitOf {" $ ppr ty
+         ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty
+         ; traceTc "Did it fit?" $ ppr fits
+         ; traceTc "wrap is: " $ ppr wrp
+         ; traceTc "checkingFitOf }" empty
+         ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)
+         -- We'd like to avoid refinement suggestions like `id _ _` or
+         -- `head _ _`, and only suggest refinements where our all phantom
+         -- variables got unified during the checking. This can be disabled
+         -- with the `-fabstract-refinement-hole-fits` flag.
+         -- Here we do the additional handling when there are refinement
+         -- variables, i.e. zonk them to read their final value to check for
+         -- abstract refinements, and to report what the type of the simulated
+         -- holes must be for this to be a match.
+         ; if fits
+           then if null ref_vars
+                then return (Just (z_wrp_tys, []))
+                else do { let -- To be concrete matches, matches have to
+                              -- be more than just an invented type variable.
+                              fvSet = fvVarSet fvs
+                              notAbstract :: TcType -> Bool
+                              notAbstract t = case getTyVar_maybe t of
+                                                Just tv -> tv `elemVarSet` fvSet
+                                                _ -> True
+                              allConcrete = all notAbstract z_wrp_tys
+                        ; z_vars  <- zonkTcTyVars ref_vars
+                        ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars
+                        ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs
+                        ; allowAbstract <- goptM Opt_AbstractRefHoleFits
+                        ; if allowAbstract || (allFilled && allConcrete )
+                          then return $ Just (z_wrp_tys, z_vars)
+                          else return Nothing }
+           else return Nothing }
+     where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty
+
+
+subsDiscardMsg :: SDoc
+subsDiscardMsg =
+    text "(Some hole fits suppressed;" <+>
+    text "use -fmax-valid-hole-fits=N" <+>
+    text "or -fno-max-valid-hole-fits)"
+
+refSubsDiscardMsg :: SDoc
+refSubsDiscardMsg =
+    text "(Some refinement hole fits suppressed;" <+>
+    text "use -fmax-refinement-hole-fits=N" <+>
+    text "or -fno-max-refinement-hole-fits)"
+
+
+-- | Checks whether a MetaTyVar is flexible or not.
+isFlexiTyVar :: TcTyVar -> TcM Bool
+isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv
+isFlexiTyVar _ = return False
+
+-- | Takes a list of free variables and restores any Flexi type variables in
+-- free_vars after the action is run.
+withoutUnification :: FV -> TcM a -> TcM a
+withoutUnification free_vars action =
+  do { flexis <- filterM isFlexiTyVar fuvs
+     ; result <- action
+          -- Reset any mutated free variables
+     ; mapM_ restore flexis
+     ; return result }
+  where restore = flip writeTcRef Flexi . metaTyVarRef
+        fuvs = fvVarList free_vars
+
+-- | Reports whether first type (ty_a) subsumes the second type (ty_b),
+-- discarding any errors. Subsumption here means that the ty_b can fit into the
+-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.
+tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
+tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b
+
+
+-- | A tcSubsumes which takes into account relevant constraints, to fix trac
+-- #14273. This makes sure that when checking whether a type fits the hole,
+-- the type has to be subsumed by type of the hole as well as fulfill all
+-- constraints on the type of the hole.
+-- Note: The simplifier may perform unification, so make sure to restore any
+-- free type variables to avoid side-effects.
+tcCheckHoleFit :: Cts                   -- ^  Any relevant Cts to the hole.
+               -> [Implication]
+               -- ^ The nested implications of the hole with the innermost
+               -- implication first.
+               -> TcSigmaType           -- ^ The type of the hole.
+               -> TcSigmaType           -- ^ The type to check whether fits.
+               -> TcM (Bool, HsWrapper)
+               -- ^ Whether it was a match, and the wrapper from hole_ty to ty.
+tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty
+    = return (True, idHsWrapper)
+tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $
+  do { -- We wrap the subtype constraint in the implications to pass along the
+       -- givens, and so we must ensure that any nested implications and skolems
+       -- end up with the correct level. The implications are ordered so that
+       -- the innermost (the one with the highest level) is first, so it
+       -- suffices to get the level of the first one (or the current level, if
+       -- there are no implications involved).
+       innermost_lvl <- case implics of
+                          [] -> getTcLevel
+                          -- imp is the innermost implication
+                          (imp:_) -> return (ic_tclvl imp)
+     ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $
+                          tcSubType_NC ExprSigCtxt ty hole_ty
+     ; traceTc "Checking hole fit {" empty
+     ; traceTc "wanteds are: " $ ppr wanted
+     ; if isEmptyWC wanted && isEmptyBag relevantCts
+       then traceTc "}" empty >> return (True, wrp)
+       else do { fresh_binds <- newTcEvBinds
+                -- The relevant constraints may contain HoleDests, so we must
+                -- take care to clone them as well (to avoid #15370).
+               ; cloned_relevants <- mapBagM cloneWanted relevantCts
+                 -- We wrap the WC in the nested implications, see
+                 -- Note [Nested Implications]
+               ; let outermost_first = reverse implics
+                     setWC = setWCAndBinds fresh_binds
+                    -- We add the cloned relevants to the wanteds generated by
+                    -- the call to tcSubType_NC, see Note [Relevant Constraints]
+                    -- There's no need to clone the wanteds, because they are
+                    -- freshly generated by `tcSubtype_NC`.
+                     w_rel_cts = addSimples wanted cloned_relevants
+                     w_givens = foldr setWC w_rel_cts outermost_first
+               ; traceTc "w_givens are: " $ ppr w_givens
+               ; rem <- runTcSDeriveds $ simpl_top w_givens
+               -- We don't want any insoluble or simple constraints left, but
+               -- solved implications are ok (and neccessary for e.g. undefined)
+               ; traceTc "rems was:" $ ppr rem
+               ; traceTc "}" empty
+               ; return (isSolvedWC rem, wrp) } }
+     where
+       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.
+                     -> Implication        -- The implication to put WC in.
+                     -> WantedConstraints  -- The WC constraints to put implic.
+                     -> WantedConstraints  -- The new constraints.
+       setWCAndBinds binds imp wc
+         = WC { wc_simple = emptyBag
+              , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
diff --git a/compiler/typecheck/TcHoleErrors.hs-boot b/compiler/typecheck/TcHoleErrors.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHoleErrors.hs-boot
@@ -0,0 +1,12 @@
+-- This boot file is in place to break the loop where:
+-- + TcSimplify calls 'TcErrors.reportUnsolved',
+-- + which calls 'TcHoleErrors.findValidHoleFits`
+-- + which calls 'TcSimplify.simpl_top'
+module TcHoleErrors where
+
+import TcRnTypes  ( TcM, Ct, Implication )
+import Outputable ( SDoc )
+import VarEnv     ( TidyEnv )
+
+findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct
+                  -> TcM (TidyEnv, SDoc)
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -0,0 +1,1954 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
+
+TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
+
+This module is an extension of @HsSyn@ syntax, for use in the type
+checker.
+-}
+
+{-# LANGUAGE CPP, TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcHsSyn (
+        -- * Extracting types from HsSyn
+        hsLitType, hsLPatType, hsPatType,
+
+        -- * Other HsSyn functions
+        mkHsDictLet, mkHsApp,
+        mkHsAppTy, mkHsCaseAlt,
+        shortCutLit, hsOverLitName,
+        conLikeResTy,
+
+        -- * re-exported from TcMonad
+        TcId, TcIdSet,
+
+        -- * Zonking
+        -- | For a description of "zonking", see Note [What is zonking?]
+        -- in TcMType
+        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
+        zonkTopBndrs,
+        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
+        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
+        zonkTyBndrs, zonkTyBndrsX, zonkRecTyVarBndrs,
+        zonkTcTypeToType,  zonkTcTypeToTypeX,
+        zonkTcTypesToTypes, zonkTcTypesToTypesX,
+        zonkTyVarOcc,
+        zonkCoToCo,
+        zonkEvBinds, zonkTcEvBinds,
+        zonkTcMethInfoToMethInfoX,
+        lookupTyVarOcc
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import Id
+import IdInfo
+import TcRnMonad
+import PrelNames
+import BuildTyCl ( TcMethInfo, MethInfo )
+import TcType
+import TcMType
+import TcEnv   ( tcLookupGlobalOnly )
+import TcEvidence
+import TysPrim
+import TyCon
+import TysWiredIn
+import Type
+import Coercion
+import ConLike
+import DataCon
+import HscTypes
+import Name
+import NameEnv
+import Var
+import VarEnv
+import DynFlags
+import Literal
+import BasicTypes
+import Maybes
+import SrcLoc
+import Bag
+import Outputable
+import Util
+import UniqFM
+import CoreSyn
+
+import {-# SOURCE #-} TcSplice (runTopSplice)
+
+import Control.Monad
+import Data.List  ( partition )
+import Control.Arrow ( second )
+
+{-
+************************************************************************
+*                                                                      *
+       Extracting the type from HsSyn
+*                                                                      *
+************************************************************************
+
+-}
+
+hsLPatType :: OutPat GhcTc -> Type
+hsLPatType lpat = hsPatType (unLoc lpat)
+
+hsPatType :: Pat GhcTc -> Type
+hsPatType (ParPat _ pat)                = hsLPatType pat
+hsPatType (WildPat ty)                  = ty
+hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
+hsPatType (BangPat _ pat)               = hsLPatType pat
+hsPatType (LazyPat _ pat)               = hsLPatType pat
+hsPatType (LitPat _ lit)                = hsLitType lit
+hsPatType (AsPat _ var _)               = idType (unLoc var)
+hsPatType (ViewPat ty _ _)              = ty
+hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
+hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
+hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
+hsPatType (ConPatOut { pat_con = lcon
+                     , pat_arg_tys = tys })
+                                        = conLikeResTy (unLoc lcon) tys
+hsPatType (SigPat ty _ _)               = ty
+hsPatType (NPat ty _ _ _)               = ty
+hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
+hsPatType (CoPat _ _ _ ty)              = ty
+hsPatType p                             = pprPanic "hsPatType" (ppr p)
+
+hsLitType :: HsLit (GhcPass p) -> TcType
+hsLitType (HsChar _ _)       = charTy
+hsLitType (HsCharPrim _ _)   = charPrimTy
+hsLitType (HsString _ _)     = stringTy
+hsLitType (HsStringPrim _ _) = addrPrimTy
+hsLitType (HsInt _ _)        = intTy
+hsLitType (HsIntPrim _ _)    = intPrimTy
+hsLitType (HsWordPrim _ _)   = wordPrimTy
+hsLitType (HsInt64Prim _ _)  = int64PrimTy
+hsLitType (HsWord64Prim _ _) = word64PrimTy
+hsLitType (HsInteger _ _ ty) = ty
+hsLitType (HsRat _ _ ty)     = ty
+hsLitType (HsFloatPrim _ _)  = floatPrimTy
+hsLitType (HsDoublePrim _ _) = doublePrimTy
+hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)
+
+-- Overloaded literals. Here mainly because it uses isIntTy etc
+
+shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
+shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))
+  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
+  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
+  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
+        -- The 'otherwise' case is important
+        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
+        -- so we'll call shortCutIntLit, but of course it's a float
+        -- This can make a big difference for programs with a lot of
+        -- literals, compiled without -O
+
+shortCutLit _ (HsFractional f) ty
+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
+  | otherwise     = Nothing
+
+shortCutLit _ (HsIsString src s) ty
+  | isStringTy ty = Just (HsLit noExt (HsString src s))
+  | otherwise     = Nothing
+
+mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
+mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
+
+------------------------------
+hsOverLitName :: OverLitVal -> Name
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {})   = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {})   = fromStringName
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
+*                                                                      *
+************************************************************************
+
+The rest of the zonking is done *after* typechecking.
+The main zonking pass runs over the bindings
+
+ a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
+ b) convert unbound TcTyVar to Void
+ c) convert each TcId to an Id by zonking its type
+
+The type variables are converted by binding mutable tyvars to immutable ones
+and then zonking as normal.
+
+The Ids are converted by binding them in the normal Tc envt; that
+way we maintain sharing; eg an Id is zonked at its binding site and they
+all occurrences of that Id point to the common zonked copy
+
+It's all pretty boring stuff, because HsSyn is such a large type, and
+the environment manipulation is tiresome.
+-}
+
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+
+-- | See Note [The ZonkEnv]
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+data ZonkEnv  -- See Note [The ZonkEnv]
+  = ZonkEnv { ze_flexi  :: ZonkFlexi
+            , ze_tv_env :: TyCoVarEnv TyCoVar
+            , ze_id_env :: IdEnv      Id
+            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
+
+{- Note [The ZonkEnv]
+~~~~~~~~~~~~~~~~~~~~~
+* ze_flexi :: ZonkFlexi says what to do with a
+  unification variable that is still un-unified.
+  See Note [Un-unified unification variables]
+
+* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
+  of a tyvar or covar, we zonk the kind right away and add a mapping
+  to the env. This prevents re-zonking the kind at every
+  occurrence. But this is *just* an optimisation.
+
+* ze_id_env : IdEnv Id promotes sharing among Ids, by making all
+  occurrences of the Id point to a single zonked copy, built at the
+  binding site.
+
+  Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
+  In a mutually recusive group
+     rec { f = ...g...; g = ...f... }
+  we want the occurrence of g to point to the one zonked Id for g,
+  and the same for f.
+
+  Because it is knot-tied, we must be careful to consult it lazily.
+  Specifically, zonkIdOcc is not monadic.
+
+* ze_meta_tv_env: see Note [Sharing when zonking to Type]
+
+
+Notes:
+  * We must be careful never to put coercion variables (which are Ids,
+    after all) in the knot-tied ze_id_env, because coercions can
+    appear in types, and we sometimes inspect a zonked type in this
+    module.  [Question: where, precisely?]
+
+  * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
+    a second reason that ze_tv_env can't be monadic.
+
+  * An obvious suggestion would be to have one VarEnv Var to
+    replace both ze_id_env and ze_tv_env, but that doesn't work
+    because of the knot-tying stuff mentioned above.
+
+Note [Un-unified unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we do if we find a Flexi unification variable?
+There are three possibilities:
+
+* DefaultFlexi: this is the common case, in situations like
+     length @alpha ([] @alpha)
+  It really doesn't matter what type we choose for alpha.  But
+  we must choose a type!  We can't leae mutable unification
+  variables floating around: after typecheck is complete, every
+  type variable occurrence must have a bindign site.
+
+  So we default it to 'Any' of the right kind.
+
+  All this works for both type and kind variables (indeed
+  the two are the same thign).
+
+* SkolemiseFlexi: is a special case for the LHS of RULES.
+  See Note [Zonking the LHS of a RULE]
+
+* RuntimeUnkFlexi: is a special case for the GHCi debugger.
+  It's a way to have a variable that is not a mutuable
+  unification variable, but doesn't have a binding site
+  either.
+-}
+
+data ZonkFlexi   -- See Note [Un-unified unification variables]
+  = DefaultFlexi    -- Default unbound unificaiton variables to Any
+  | SkolemiseFlexi  -- Skolemise unbound unification variables
+                    -- See Note [Zonking the LHS of a RULE]
+  | RuntimeUnkFlexi -- Used in the GHCi debugger
+
+instance Outputable ZonkEnv where
+  ppr (ZonkEnv { ze_tv_env = tv_env
+               , ze_id_env = id_env })
+    = text "ZE" <+> braces (vcat
+         [ text "ze_tv_env =" <+> ppr tv_env
+         , text "ze_id_env =" <+> ppr id_env ])
+
+-- The EvBinds have to already be zonked, but that's usually the case.
+emptyZonkEnv :: TcM ZonkEnv
+emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
+
+mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
+mkEmptyZonkEnv flexi
+  = do { mtv_env_ref <- newTcRef emptyVarEnv
+       ; return (ZonkEnv { ze_flexi = flexi
+                         , ze_tv_env = emptyVarEnv
+                         , ze_id_env = emptyVarEnv
+                         , ze_meta_tv_env = mtv_env_ref }) }
+
+initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
+initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi
+                              ; thing_inside ze }
+
+-- | Extend the knot-tied environment.
+extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
+extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
+    -- NB: Don't look at the var to decide which env't to put it in. That
+    -- would end up knot-tying all the env'ts.
+  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
+  -- Given coercion variables will actually end up here. That's OK though:
+  -- coercion variables are never looked up in the knot-tied env't, so zonking
+  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
+  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
+  -- recursive groups. But perhaps the time it takes to do the analysis is
+  -- more than the savings.
+
+extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
+extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
+  = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
+       , ze_id_env = extendVarEnvList id_env   [(id,id) | id <- ids] }
+  where
+    (tycovars, ids) = partition isTyCoVar vars
+
+extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
+extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id
+  = ze { ze_id_env = extendVarEnv id_env id id }
+
+extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
+extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv
+  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
+
+extendTyZonkEnvN :: ZonkEnv -> [(Name,TyVar)] -> ZonkEnv
+extendTyZonkEnvN ze@(ZonkEnv { ze_tv_env = ty_env }) pairs
+  = ze { ze_tv_env = foldl add ty_env pairs }
+  where
+    add env (name, tv) = extendVarEnv_Directly env (getUnique name) tv
+
+setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
+setZonkType ze flexi = ze { ze_flexi = flexi }
+
+zonkEnvIds :: ZonkEnv -> TypeEnv
+zonkEnvIds (ZonkEnv { ze_id_env = id_env})
+  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
+  -- It's OK to use nonDetEltsUFM here because we forget the ordering
+  -- immediately by creating a TypeEnv
+
+zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
+zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)
+
+zonkIdOcc :: ZonkEnv -> TcId -> Id
+-- Ids defined in this module should be in the envt;
+-- ignore others.  (Actually, data constructors are also
+-- not LocalVars, even when locally defined, but that is fine.)
+-- (Also foreign-imported things aren't currently in the ZonkEnv;
+--  that's ok because they don't need zonking.)
+--
+-- Actually, Template Haskell works in 'chunks' of declarations, and
+-- an earlier chunk won't be in the 'env' that the zonking phase
+-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
+-- zonked.  There's no point in looking it up there (except for error
+-- checking), and it's not conveniently to hand; hence the simple
+-- 'orElse' case in the LocalVar branch.
+--
+-- Even without template splices, in module Main, the checking of
+-- 'main' is done as a separate chunk.
+zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
+  | isLocalVar id = lookupVarEnv id_env id `orElse`
+                    id
+  | otherwise     = id
+
+zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
+zonkIdOccs env ids = map (zonkIdOcc env) ids
+
+-- zonkIdBndr is used *after* typechecking to get the Id's type
+-- to its final form.  The TyVarEnv give
+zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
+zonkIdBndr env v
+  = do ty' <- zonkTcTypeToTypeX env (idType v)
+       ensureNotLevPoly ty'
+         (text "In the type of binder" <+> quotes (ppr v))
+
+       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
+
+zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
+zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
+
+zonkTopBndrs :: [TcId] -> TcM [Id]
+zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
+
+zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
+zonkFieldOcc env (FieldOcc sel lbl)
+  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
+zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
+
+zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
+zonkEvBndrsX = mapAccumLM zonkEvBndrX
+
+zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
+-- Works for dictionaries and coercions
+zonkEvBndrX env var
+  = do { var' <- zonkEvBndr env var
+       ; return (extendZonkEnv env [var'], var') }
+
+zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
+-- Works for dictionaries and coercions
+-- Does not extend the ZonkEnv
+zonkEvBndr env var
+  = do { let var_ty = varType var
+       ; ty <-
+           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
+           zonkTcTypeToTypeX env var_ty
+       ; return (setVarType var ty) }
+
+{-
+zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
+zonkEvVarOcc env v
+  | isCoVar v
+  = EvCoercion <$> zonkCoVarOcc env v
+  | otherwise
+  = return (EvId $ zonkIdOcc env v)
+-}
+
+zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
+zonkCoreBndrX env v
+  | isId v = do { v' <- zonkIdBndr env v
+                ; return (extendIdZonkEnv1 env v', v') }
+  | otherwise = zonkTyBndrX env v
+
+zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
+zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
+
+zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
+
+zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrsX = mapAccumLM zonkTyBndrX
+
+zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
+-- This guarantees to return a TyVar (not a TcTyVar)
+-- then we add it to the envt, so all occurrences are replaced
+zonkTyBndrX env tv
+  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
+    do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
+               -- Internal names tidy up better, for iface files.
+       ; let tv' = mkTyVar (tyVarName tv) ki
+       ; return (extendTyZonkEnv1 env tv', tv') }
+
+zonkTyVarBinders ::  [VarBndr TcTyVar vis]
+                 -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs
+
+zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
+                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
+
+zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
+                            -> TcM (ZonkEnv, VarBndr TyVar vis)
+-- Takes a TcTyVar and guarantees to return a TyVar
+zonkTyVarBinderX env (Bndr tv vis)
+  = do { (env', tv') <- zonkTyBndrX env tv
+       ; return (env', Bndr tv' vis) }
+
+zonkRecTyVarBndrs :: [Name] -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+-- This rather specialised function is used in exactly one place.
+-- See Note [Tricky scoping in generaliseTcTyCon] in TcTyClsDecls.
+zonkRecTyVarBndrs names tc_tvs
+  = initZonkEnv $ \ ze ->
+    fixM $ \ ~(_, rec_new_tvs) ->
+    do { let ze' = extendTyZonkEnvN ze $
+                   zipWithLazy (\ tc_tv new_tv -> (getName tc_tv, new_tv))
+                               tc_tvs rec_new_tvs
+       ; new_tvs <- zipWithM (zonk_one ze') names tc_tvs
+       ; return (ze', new_tvs) }
+  where
+    zonk_one ze name tc_tv
+      = do { ki <- zonkTcTypeToTypeX ze (tyVarKind tc_tv)
+           ; return (mkTyVar name ki) }
+
+zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
+zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e
+
+zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
+zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e
+
+zonkTopDecls :: Bag EvBind
+             -> LHsBinds GhcTcId
+             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
+             -> [LForeignDecl GhcTcId]
+             -> TcM (TypeEnv,
+                     Bag EvBind,
+                     LHsBinds GhcTc,
+                     [LForeignDecl GhcTc],
+                     [LTcSpecPrag],
+                     [LRuleDecl    GhcTc])
+zonkTopDecls ev_binds binds rules imp_specs fords
+  = do  { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds
+        ; (env2, binds')    <- zonkRecMonoBinds env1 binds
+                        -- Top level is implicitly recursive
+        ; rules' <- zonkRules env2 rules
+        ; specs' <- zonkLTcSpecPrags env2 imp_specs
+        ; fords' <- zonkForeignExports env2 fords
+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
+
+---------------------------------------------
+zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
+               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
+zonkLocalBinds env (EmptyLocalBinds x)
+  = return (env, (EmptyLocalBinds x))
+
+zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
+  = panic "zonkLocalBinds" -- Not in typechecker output
+
+zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
+  = do  { (env1, new_binds) <- go env binds
+        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
+  where
+    go env []
+      = return (env, [])
+    go env ((r,b):bs)
+      = do { (env1, b')  <- zonkRecMonoBinds env b
+           ; (env2, bs') <- go env1 bs
+           ; return (env2, (r,b'):bs') }
+
+zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
+    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
+    let
+        env1 = extendIdZonkEnvRec env
+                 [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds]
+    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
+    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
+  where
+    zonk_ip_bind (IPBind x n e)
+        = do n' <- mapIPNameTc (zonkIdBndr env) n
+             e' <- zonkLExpr env e
+             return (IPBind x n' e')
+    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"
+
+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))
+  = panic "zonkLocalBinds" -- Not in typechecker output
+zonkLocalBinds _ (XHsLocalBindsLR _)
+  = panic "zonkLocalBinds" -- Not in typechecker output
+
+---------------------------------------------
+zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
+zonkRecMonoBinds env binds
+ = fixM (\ ~(_, new_binds) -> do
+        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
+        ; binds' <- zonkMonoBinds env1 binds
+        ; return (env1, binds') })
+
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
+zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
+
+zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
+zonk_lbind env = wrapLocM (zonk_bind env)
+
+zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
+                            , pat_ext = NPatBindTc fvs ty})
+  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
+        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
+        ; new_ty    <- zonkTcTypeToTypeX env ty
+        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
+                       , pat_ext = NPatBindTc fvs new_ty }) }
+
+zonk_bind env (VarBind { var_ext = x
+                       , var_id = var, var_rhs = expr, var_inline = inl })
+  = do { new_var  <- zonkIdBndr env var
+       ; new_expr <- zonkLExpr env expr
+       ; return (VarBind { var_ext = x
+                         , var_id = new_var
+                         , var_rhs = new_expr
+                         , var_inline = inl }) }
+
+zonk_bind env bind@(FunBind { fun_id = (dL->L loc var)
+                            , fun_matches = ms
+                            , fun_co_fn = co_fn })
+  = do { new_var <- zonkIdBndr env var
+       ; (env1, new_co_fn) <- zonkCoFn env co_fn
+       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
+       ; return (bind { fun_id = cL loc new_var
+                      , fun_matches = new_ms
+                      , fun_co_fn = new_co_fn }) }
+
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+                        , abs_ev_binds = ev_binds
+                        , abs_exports = exports
+                        , abs_binds = val_binds
+                        , abs_sig = has_sig })
+  = ASSERT( all isImmutableTyVar tyvars )
+    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
+       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
+         do { let env3 = extendIdZonkEnvRec env2 $
+                         collectHsBindsBinders new_val_binds
+            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
+            ; new_exports   <- mapM (zonk_export env3) exports
+            ; return (new_val_binds, new_exports) }
+       ; return (AbsBinds { abs_ext = noExt
+                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
+                          , abs_ev_binds = new_ev_binds
+                          , abs_exports = new_exports, abs_binds = new_val_bind
+                          , abs_sig = has_sig }) }
+  where
+    zonk_val_bind env lbind
+      | has_sig
+      , (dL->L loc bind@(FunBind { fun_id      = (dL->L mloc mono_id)
+                                 , fun_matches = ms
+                                 , fun_co_fn   = co_fn })) <- lbind
+      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
+                            -- Specifically /not/ zonkIdBndr; we do not
+                            -- want to complain about a levity-polymorphic binder
+           ; (env', new_co_fn) <- zonkCoFn env co_fn
+           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
+           ; return $ cL loc $
+             bind { fun_id      = cL mloc new_mono_id
+                  , fun_matches = new_ms
+                  , fun_co_fn   = new_co_fn } }
+      | otherwise
+      = zonk_lbind env lbind   -- The normal case
+
+    zonk_export env (ABE{ abe_ext = x
+                        , abe_wrap = wrap
+                        , abe_poly = poly_id
+                        , abe_mono = mono_id
+                        , abe_prags = prags })
+        = do new_poly_id <- zonkIdBndr env poly_id
+             (_, new_wrap) <- zonkCoFn env wrap
+             new_prags <- zonkSpecPrags env prags
+             return (ABE{ abe_ext = x
+                        , abe_wrap = new_wrap
+                        , abe_poly = new_poly_id
+                        , abe_mono = zonkIdOcc env mono_id
+                        , abe_prags = new_prags })
+    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
+
+zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)
+                                      , psb_args = details
+                                      , psb_def = lpat
+                                      , psb_dir = dir }))
+  = do { id' <- zonkIdBndr env id
+       ; (env1, lpat') <- zonkPat env lpat
+       ; let details' = zonkPatSynDetails env1 details
+       ; (_env2, dir') <- zonkPatSynDir env1 dir
+       ; return $ PatSynBind x $
+                  bind { psb_id = cL loc id'
+                       , psb_args = details'
+                       , psb_def = lpat'
+                       , psb_dir = dir' } }
+
+zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
+zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"
+
+zonkPatSynDetails :: ZonkEnv
+                  -> HsPatSynDetails (Located TcId)
+                  -> HsPatSynDetails (Located Id)
+zonkPatSynDetails env (PrefixCon as)
+  = PrefixCon (map (zonkLIdOcc env) as)
+zonkPatSynDetails env (InfixCon a1 a2)
+  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
+zonkPatSynDetails env (RecCon flds)
+  = RecCon (map (fmap (zonkLIdOcc env)) flds)
+
+zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
+              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
+zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
+zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
+zonkPatSynDir env (ExplicitBidirectional mg) = do
+    mg' <- zonkMatchGroup env zonkLExpr mg
+    return (env, ExplicitBidirectional mg')
+
+zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
+zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
+                                       ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+  = mapM zonk_prag ps
+  where
+    zonk_prag (dL->L loc (SpecPrag id co_fn inl))
+        = do { (_, co_fn') <- zonkCoFn env co_fn
+             ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
+*                                                                      *
+************************************************************************
+-}
+
+zonkMatchGroup :: ZonkEnv
+            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+            -> MatchGroup GhcTcId (Located (body GhcTcId))
+            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
+zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms)
+                             , mg_ext = MatchGroupTc arg_tys res_ty
+                             , mg_origin = origin })
+  = do  { ms' <- mapM (zonkMatch env zBody) ms
+        ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
+        ; res_ty'  <- zonkTcTypeToTypeX env res_ty
+        ; return (MG { mg_alts = cL l ms'
+                     , mg_ext = MatchGroupTc arg_tys' res_ty'
+                     , mg_origin = origin }) }
+zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
+
+zonkMatch :: ZonkEnv
+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+          -> LMatch GhcTcId (Located (body GhcTcId))
+          -> TcM (LMatch GhcTc (Located (body GhcTc)))
+zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats
+                                            , m_grhss = grhss }))
+  = do  { (env1, new_pats) <- zonkPats env pats
+        ; new_grhss <- zonkGRHSs env1 zBody grhss
+        ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
+zonkMatch _ _ (dL->L  _ (XMatch _)) = panic "zonkMatch"
+zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"
+                             -- due to #15884
+
+-------------------------------------------------------------------------
+zonkGRHSs :: ZonkEnv
+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+          -> GRHSs GhcTcId (Located (body GhcTcId))
+          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
+
+zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do
+    (new_env, new_binds) <- zonkLocalBinds env binds
+    let
+        zonk_grhs (GRHS xx guarded rhs)
+          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
+               new_rhs <- zBody env2 rhs
+               return (GRHS xx new_guarded new_rhs)
+        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
+    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
+    return (GRHSs x new_grhss (cL l new_binds))
+zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
+*                                                                      *
+************************************************************************
+-}
+
+zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
+zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
+zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
+
+zonkLExprs env exprs = mapM (zonkLExpr env) exprs
+zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
+
+zonkExpr env (HsVar x (dL->L l id))
+  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
+    return (HsVar x (cL l (zonkIdOcc env id)))
+
+zonkExpr _ e@(HsConLikeOut {}) = return e
+
+zonkExpr _ (HsIPVar x id)
+  = return (HsIPVar x id)
+
+zonkExpr _ e@HsOverLabel{} = return e
+
+zonkExpr env (HsLit x (HsRat e f ty))
+  = do new_ty <- zonkTcTypeToTypeX env ty
+       return (HsLit x (HsRat e f new_ty))
+
+zonkExpr _ (HsLit x lit)
+  = return (HsLit x lit)
+
+zonkExpr env (HsOverLit x lit)
+  = do  { lit' <- zonkOverLit env lit
+        ; return (HsOverLit x lit') }
+
+zonkExpr env (HsLam x matches)
+  = do new_matches <- zonkMatchGroup env zonkLExpr matches
+       return (HsLam x new_matches)
+
+zonkExpr env (HsLamCase x matches)
+  = do new_matches <- zonkMatchGroup env zonkLExpr matches
+       return (HsLamCase x new_matches)
+
+zonkExpr env (HsApp x e1 e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       return (HsApp x new_e1 new_e2)
+
+zonkExpr env (HsAppType x e t)
+  = do new_e <- zonkLExpr env e
+       return (HsAppType x new_e t)
+       -- NB: the type is an HsType; can't zonk that!
+
+zonkExpr _ e@(HsRnBracketOut _ _ _)
+  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
+
+zonkExpr env (HsTcBracketOut x body bs)
+  = do bs' <- mapM zonk_b bs
+       return (HsTcBracketOut x body bs')
+  where
+    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
+                                      return (PendingTcSplice n e')
+
+zonkExpr env (HsSpliceE _ (HsSplicedT s)) =
+  runTopSplice s >>= zonkExpr env
+
+zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
+                           return (HsSpliceE x s)
+
+zonkExpr env (OpApp fixity e1 op e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_op <- zonkLExpr env op
+       new_e2 <- zonkLExpr env e2
+       return (OpApp fixity new_e1 new_op new_e2)
+
+zonkExpr env (NegApp x expr op)
+  = do (env', new_op) <- zonkSyntaxExpr env op
+       new_expr <- zonkLExpr env' expr
+       return (NegApp x new_expr new_op)
+
+zonkExpr env (HsPar x e)
+  = do new_e <- zonkLExpr env e
+       return (HsPar x new_e)
+
+zonkExpr env (SectionL x expr op)
+  = do new_expr <- zonkLExpr env expr
+       new_op   <- zonkLExpr env op
+       return (SectionL x new_expr new_op)
+
+zonkExpr env (SectionR x op expr)
+  = do new_op   <- zonkLExpr env op
+       new_expr <- zonkLExpr env expr
+       return (SectionR x new_op new_expr)
+
+zonkExpr env (ExplicitTuple x tup_args boxed)
+  = do { new_tup_args <- mapM zonk_tup_arg tup_args
+       ; return (ExplicitTuple x new_tup_args boxed) }
+  where
+    zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e
+                                              ; return (cL l (Present x e')) }
+    zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
+                                            ; return (cL l (Missing t')) }
+    zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
+    zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"
+                             -- due to #15884
+
+
+zonkExpr env (ExplicitSum args alt arity expr)
+  = do new_args <- mapM (zonkTcTypeToTypeX env) args
+       new_expr <- zonkLExpr env expr
+       return (ExplicitSum new_args alt arity new_expr)
+
+zonkExpr env (HsCase x expr ms)
+  = do new_expr <- zonkLExpr env expr
+       new_ms <- zonkMatchGroup env zonkLExpr ms
+       return (HsCase x new_expr new_ms)
+
+zonkExpr env (HsIf x Nothing e1 e2 e3)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_e3 <- zonkLExpr env e3
+       return (HsIf x Nothing new_e1 new_e2 new_e3)
+
+zonkExpr env (HsIf x (Just fun) e1 e2 e3)
+  = do (env1, new_fun) <- zonkSyntaxExpr env fun
+       new_e1 <- zonkLExpr env1 e1
+       new_e2 <- zonkLExpr env1 e2
+       new_e3 <- zonkLExpr env1 e3
+       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
+
+zonkExpr env (HsMultiIf ty alts)
+  = do { alts' <- mapM (wrapLocM zonk_alt) alts
+       ; ty'   <- zonkTcTypeToTypeX env ty
+       ; return $ HsMultiIf ty' alts' }
+  where zonk_alt (GRHS x guard expr)
+          = do { (env', guard') <- zonkStmts env zonkLExpr guard
+               ; expr'          <- zonkLExpr env' expr
+               ; return $ GRHS x guard' expr' }
+        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
+
+zonkExpr env (HsLet x (dL->L l binds) expr)
+  = do (new_env, new_binds) <- zonkLocalBinds env binds
+       new_expr <- zonkLExpr new_env expr
+       return (HsLet x (cL l new_binds) new_expr)
+
+zonkExpr env (HsDo ty do_or_lc (dL->L l stmts))
+  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsDo new_ty do_or_lc (cL l new_stmts))
+
+zonkExpr env (ExplicitList ty wit exprs)
+  = do (env1, new_wit) <- zonkWit env wit
+       new_ty <- zonkTcTypeToTypeX env1 ty
+       new_exprs <- zonkLExprs env1 exprs
+       return (ExplicitList new_ty new_wit new_exprs)
+   where zonkWit env Nothing    = return (env, Nothing)
+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+
+zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
+  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
+        ; new_rbinds   <- zonkRecFields env rbinds
+        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
+                       , rcon_flds = new_rbinds }) }
+
+zonkExpr env (RecordUpd { rupd_flds = rbinds
+                        , rupd_expr = expr
+                        , rupd_ext = RecordUpdTc
+                            { rupd_cons = cons, rupd_in_tys = in_tys
+                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
+  = do  { new_expr    <- zonkLExpr env expr
+        ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys
+        ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
+        ; new_rbinds  <- zonkRecUpdFields env rbinds
+        ; (_, new_recwrap) <- zonkCoFn env req_wrap
+        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
+                            , rupd_ext = RecordUpdTc
+                                { rupd_cons = cons, rupd_in_tys = new_in_tys
+                                , rupd_out_tys = new_out_tys
+                                , rupd_wrap = new_recwrap }}) }
+
+zonkExpr env (ExprWithTySig _ e ty)
+  = do { e' <- zonkLExpr env e
+       ; return (ExprWithTySig noExt e' ty) }
+
+zonkExpr env (ArithSeq expr wit info)
+  = do (env1, new_wit) <- zonkWit env wit
+       new_expr <- zonkExpr env expr
+       new_info <- zonkArithSeq env1 info
+       return (ArithSeq new_expr new_wit new_info)
+   where zonkWit env Nothing    = return (env, Nothing)
+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+
+zonkExpr env (HsSCC x src lbl expr)
+  = do new_expr <- zonkLExpr env expr
+       return (HsSCC x src lbl new_expr)
+
+zonkExpr env (HsTickPragma x src info srcInfo expr)
+  = do new_expr <- zonkLExpr env expr
+       return (HsTickPragma x src info srcInfo new_expr)
+
+-- hdaume: core annotations
+zonkExpr env (HsCoreAnn x src lbl expr)
+  = do new_expr <- zonkLExpr env expr
+       return (HsCoreAnn x src lbl new_expr)
+
+-- arrow notation extensions
+zonkExpr env (HsProc x pat body)
+  = do  { (env1, new_pat) <- zonkPat env pat
+        ; new_body <- zonkCmdTop env1 body
+        ; return (HsProc x new_pat new_body) }
+
+-- StaticPointers extension
+zonkExpr env (HsStatic fvs expr)
+  = HsStatic fvs <$> zonkLExpr env expr
+
+zonkExpr env (HsWrap x co_fn expr)
+  = do (env1, new_co_fn) <- zonkCoFn env co_fn
+       new_expr <- zonkExpr env1 expr
+       return (HsWrap x new_co_fn new_expr)
+
+zonkExpr _ e@(HsUnboundVar {}) = return e
+
+zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
+
+-------------------------------------------------------------------------
+{-
+Note [Skolems in zonkSyntaxExpr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider rebindable syntax with something like
+
+  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
+
+The x and y become skolems that are in scope when type-checking the
+arguments to the bind. This means that we must extend the ZonkEnv with
+these skolems when zonking the arguments to the bind. But the skolems
+are different between the two arguments, and so we should theoretically
+carry around different environments to use for the different arguments.
+
+However, this becomes a logistical nightmare, especially in dealing with
+the more exotic Stmt forms. So, we simplify by making the critical
+assumption that the uniques of the skolems are different. (This assumption
+is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
+Now, we can safely just extend one environment.
+-}
+
+-- See Note [Skolems in zonkSyntaxExpr]
+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
+               -> TcM (ZonkEnv, SyntaxExpr GhcTc)
+zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr
+                               , syn_arg_wraps = arg_wraps
+                               , syn_res_wrap  = res_wrap })
+  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
+       ; expr'              <- zonkExpr env0 expr
+       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
+       ; return (env1, SyntaxExpr { syn_expr      = expr'
+                                  , syn_arg_wraps = arg_wraps'
+                                  , syn_res_wrap  = res_wrap' }) }
+
+-------------------------------------------------------------------------
+
+zonkLCmd  :: ZonkEnv -> LHsCmd GhcTcId   -> TcM (LHsCmd GhcTc)
+zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)
+
+zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd
+
+zonkCmd env (HsCmdWrap x w cmd)
+  = do { (env1, w') <- zonkCoFn env w
+       ; cmd' <- zonkCmd env1 cmd
+       ; return (HsCmdWrap x w' cmd') }
+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
+
+zonkCmd env (HsCmdArrForm x op f fixity args)
+  = do new_op <- zonkLExpr env op
+       new_args <- mapM (zonkCmdTop env) args
+       return (HsCmdArrForm x new_op f fixity new_args)
+
+zonkCmd env (HsCmdApp x c e)
+  = do new_c <- zonkLCmd env c
+       new_e <- zonkLExpr env e
+       return (HsCmdApp x new_c new_e)
+
+zonkCmd env (HsCmdLam x matches)
+  = do new_matches <- zonkMatchGroup env zonkLCmd matches
+       return (HsCmdLam x new_matches)
+
+zonkCmd env (HsCmdPar x c)
+  = do new_c <- zonkLCmd env c
+       return (HsCmdPar x new_c)
+
+zonkCmd env (HsCmdCase x expr ms)
+  = do new_expr <- zonkLExpr env expr
+       new_ms <- zonkMatchGroup env zonkLCmd ms
+       return (HsCmdCase x new_expr new_ms)
+
+zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
+  = do { (env1, new_eCond) <- zonkWit env eCond
+       ; new_ePred <- zonkLExpr env1 ePred
+       ; new_cThen <- zonkLCmd env1 cThen
+       ; new_cElse <- zonkLCmd env1 cElse
+       ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
+  where
+    zonkWit env Nothing  = return (env, Nothing)
+    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
+
+zonkCmd env (HsCmdLet x (dL->L l binds) cmd)
+  = do (new_env, new_binds) <- zonkLocalBinds env binds
+       new_cmd <- zonkLCmd new_env cmd
+       return (HsCmdLet x (cL l new_binds) new_cmd)
+
+zonkCmd env (HsCmdDo ty (dL->L l stmts))
+  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsCmdDo new_ty (cL l new_stmts))
+
+zonkCmd _ (XCmd{}) = panic "zonkCmd"
+
+
+
+zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
+zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
+
+zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
+  = do new_cmd <- zonkLCmd env cmd
+       new_stack_tys <- zonkTcTypeToTypeX env stack_tys
+       new_ty <- zonkTcTypeToTypeX env ty
+       new_ids <- mapSndM (zonkExpr env) ids
+
+       MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )
+         -- desugarer assumes that this is not levity polymorphic...
+         -- but indeed it should always be lifted due to the typing
+         -- rules for arrows
+
+       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"
+
+-------------------------------------------------------------------------
+zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
+zonkCoFn env WpHole   = return (env, WpHole)
+zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
+                                    ; (env2, c2') <- zonkCoFn env1 c2
+                                    ; return (env2, WpCompose c1' c2') }
+zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1
+                                     ; (env2, c2') <- zonkCoFn env1 c2
+                                     ; t1'         <- zonkTcTypeToTypeX env2 t1
+                                     ; return (env2, WpFun c1' c2' t1' d) }
+zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
+                              ; return (env, WpCast co') }
+zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
+                                 ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
+                                 ; return (env, WpEvApp arg') }
+zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
+                              do { (env', tv') <- zonkTyBndrX env tv
+                                 ; return (env', WpTyLam tv') }
+zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty
+                                 ; return (env, WpTyApp ty') }
+zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
+                                 ; return (env1, WpLet bs') }
+
+-------------------------------------------------------------------------
+zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
+zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; e' <- zonkExpr env e
+        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+
+zonkOverLit _ XOverLit{} = panic "zonkOverLit"
+
+-------------------------------------------------------------------------
+zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
+
+zonkArithSeq env (From e)
+  = do new_e <- zonkLExpr env e
+       return (From new_e)
+
+zonkArithSeq env (FromThen e1 e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       return (FromThen new_e1 new_e2)
+
+zonkArithSeq env (FromTo e1 e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       return (FromTo new_e1 new_e2)
+
+zonkArithSeq env (FromThenTo e1 e2 e3)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_e3 <- zonkLExpr env e3
+       return (FromThenTo new_e1 new_e2 new_e3)
+
+
+-------------------------------------------------------------------------
+zonkStmts :: ZonkEnv
+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+          -> [LStmt GhcTcId (Located (body GhcTcId))]
+          -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])
+zonkStmts env _ []     = return (env, [])
+zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody) s
+                                ; (env2, ss') <- zonkStmts env1 zBody ss
+                                ; return (env2, s' : ss') }
+
+zonkStmt :: ZonkEnv
+         -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+         -> Stmt GhcTcId (Located (body GhcTcId))
+         -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))
+zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
+  = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
+       ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+       ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
+       ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+                              , b <- bs]
+             env2 = extendIdZonkEnvRec env1 new_binders
+       ; new_mzip <- zonkExpr env2 mzip_op
+       ; return (env2
+                , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
+  where
+    zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
+       = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts
+            ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
+            ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
+                                                                   new_return) }
+    zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"
+
+zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
+                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
+                            , recS_bind_fn = bind_id
+                            , recS_ext =
+                                       RecStmtTc { recS_bind_ty = bind_ty
+                                                 , recS_later_rets = later_rets
+                                                 , recS_rec_rets = rec_rets
+                                                 , recS_ret_ty = ret_ty} })
+  = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
+       ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
+       ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id
+       ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty
+       ; new_rvs <- zonkIdBndrs env3 rvs
+       ; new_lvs <- zonkIdBndrs env3 lvs
+       ; new_ret_ty  <- zonkTcTypeToTypeX env3 ret_ty
+       ; let env4 = extendIdZonkEnvRec env3 new_rvs
+       ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
+        -- Zonk the ret-expressions in an envt that
+        -- has the polymorphic bindings in the envt
+       ; new_later_rets <- mapM (zonkExpr env5) later_rets
+       ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
+       ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed
+                 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
+                         , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
+                         , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
+                         , recS_ext = RecStmtTc
+                             { recS_bind_ty = new_bind_ty
+                             , recS_later_rets = new_later_rets
+                             , recS_rec_rets = new_rec_rets
+                             , recS_ret_ty = new_ret_ty } }) }
+
+zonkStmt env zBody (BodyStmt ty body then_op guard_op)
+  = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op
+       (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
+       new_body <- zBody env2 body
+       new_ty   <- zonkTcTypeToTypeX env2 ty
+       return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
+
+zonkStmt env zBody (LastStmt x body noret ret_op)
+  = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
+       new_body <- zBody env1 body
+       return (env, LastStmt x new_body noret new_ret)
+
+zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+                          , trS_by = by, trS_form = form, trS_using = using
+                          , trS_ret = return_op, trS_bind = bind_op
+                          , trS_ext = bind_arg_ty
+                          , trS_fmap = liftM_op })
+  = do {
+    ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
+    ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty
+    ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
+    ; by'        <- fmapMaybeM (zonkLExpr env2) by
+    ; using'     <- zonkLExpr env2 using
+
+    ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
+    ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
+    ; liftM_op'  <- zonkExpr env3 liftM_op
+    ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
+    ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+                               , trS_by = by', trS_form = form, trS_using = using'
+                               , trS_ret = return_op', trS_bind = bind_op'
+                               , trS_ext = bind_arg_ty'
+                               , trS_fmap = liftM_op' }) }
+  where
+    zonkBinderMapEntry env  (oldBinder, newBinder) = do
+        let oldBinder' = zonkIdOcc env oldBinder
+        newBinder' <- zonkIdBndr env newBinder
+        return (oldBinder', newBinder')
+
+zonkStmt env _ (LetStmt x (dL->L l binds))
+  = do (env1, new_binds) <- zonkLocalBinds env binds
+       return (env1, LetStmt x (cL l new_binds))
+
+zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
+  = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
+        ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+        ; new_body <- zBody env1 body
+        ; (env2, new_pat) <- zonkPat env1 pat
+        ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+        ; return ( env2
+                 , BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
+
+-- Scopes: join > ops (in reverse order) > pats (in forward order)
+--              > rest of stmts
+zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
+  = do  { (env1, new_mb_join)   <- zonk_join env mb_join
+        ; (env2, new_args)      <- zonk_args env1 args
+        ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty
+        ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }
+  where
+    zonk_join env Nothing  = return (env, Nothing)
+    zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
+
+    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
+    get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
+    get_pat (_, XApplicativeArg _) = panic "zonkStmt"
+
+    replace_pat pat (op, ApplicativeArgOne x _ a isBody)
+      = (op, ApplicativeArgOne x pat a isBody)
+    replace_pat pat (op, ApplicativeArgMany x a b _)
+      = (op, ApplicativeArgMany x a b pat)
+    replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"
+
+    zonk_args env args
+      = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
+           ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)
+           ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
+
+     -- these need to go backward, because if any operators are higher-rank,
+     -- later operators may introduce skolems that are in scope for earlier
+     -- arguments
+    zonk_args_rev env ((op, arg) : args)
+      = do { (env1, new_op)         <- zonkSyntaxExpr env op
+           ; new_arg                <- zonk_arg env1 arg
+           ; (env2, new_args)       <- zonk_args_rev env1 args
+           ; return (env2, (new_op, new_arg) : new_args) }
+    zonk_args_rev env [] = return (env, [])
+
+    zonk_arg env (ApplicativeArgOne x pat expr isBody)
+      = do { new_expr <- zonkLExpr env expr
+           ; return (ApplicativeArgOne x pat new_expr isBody) }
+    zonk_arg env (ApplicativeArgMany x stmts ret pat)
+      = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
+           ; new_ret           <- zonkExpr env1 ret
+           ; return (ApplicativeArgMany x new_stmts new_ret pat) }
+    zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"
+
+zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"
+
+-------------------------------------------------------------------------
+zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
+zonkRecFields env (HsRecFields flds dd)
+  = do  { flds' <- mapM zonk_rbind flds
+        ; return (HsRecFields flds' dd) }
+  where
+    zonk_rbind (dL->L l fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+           ; return (cL l (fld { hsRecFieldLbl = new_id
+                              , hsRecFieldArg = new_expr })) }
+
+zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]
+                 -> TcM [LHsRecUpdField GhcTcId]
+zonkRecUpdFields env = mapM zonk_rbind
+  where
+    zonk_rbind (dL->L l fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+           ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
+                               , hsRecFieldArg = new_expr })) }
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
+            -> TcM (Either (Located HsIPName) b)
+mapIPNameTc _ (Left x)  = return (Left x)
+mapIPNameTc f (Right x) = do r <- f x
+                             return (Right r)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-Pats]{Patterns}
+*                                                                      *
+************************************************************************
+-}
+
+zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
+-- Extend the environment as we go, because it's possible for one
+-- pattern to bind something that is used in another (inside or
+-- to the right)
+zonkPat env pat = wrapLocSndM (zonk_pat env) pat
+
+zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)
+zonk_pat env (ParPat x p)
+  = do  { (env', p') <- zonkPat env p
+        ; return (env', ParPat x p') }
+
+zonk_pat env (WildPat ty)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; ensureNotLevPoly ty'
+            (text "In a wildcard pattern")
+        ; return (env, WildPat ty') }
+
+zonk_pat env (VarPat x (dL->L l v))
+  = do  { v' <- zonkIdBndr env v
+        ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) }
+
+zonk_pat env (LazyPat x pat)
+  = do  { (env', pat') <- zonkPat env pat
+        ; return (env',  LazyPat x pat') }
+
+zonk_pat env (BangPat x pat)
+  = do  { (env', pat') <- zonkPat env pat
+        ; return (env',  BangPat x pat') }
+
+zonk_pat env (AsPat x (dL->L loc v) pat)
+  = do  { v' <- zonkIdBndr env v
+        ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
+        ; return (env', AsPat x (cL loc v') pat') }
+
+zonk_pat env (ViewPat ty expr pat)
+  = do  { expr' <- zonkLExpr env expr
+        ; (env', pat') <- zonkPat env pat
+        ; ty' <- zonkTcTypeToTypeX env ty
+        ; return (env', ViewPat ty' expr' pat') }
+
+zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; (env', pats') <- zonkPats env pats
+        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }
+
+zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
+  = do  { (env', wit') <- zonkSyntaxExpr env wit
+        ; ty2' <- zonkTcTypeToTypeX env' ty2
+        ; ty' <- zonkTcTypeToTypeX env' ty
+        ; (env'', pats') <- zonkPats env' pats
+        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
+
+zonk_pat env (TuplePat tys pats boxed)
+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
+        ; (env', pats') <- zonkPats env pats
+        ; return (env', TuplePat tys' pats' boxed) }
+
+zonk_pat env (SumPat tys pat alt arity )
+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
+        ; (env', pat') <- zonkPat env pat
+        ; return (env', SumPat tys' pat' alt arity) }
+
+zonk_pat env p@(ConPatOut { pat_arg_tys = tys
+                          , pat_tvs = tyvars
+                          , pat_dicts = evs
+                          , pat_binds = binds
+                          , pat_args = args
+                          , pat_wrap = wrapper
+                          , pat_con = (dL->L _ con) })
+  = ASSERT( all isImmutableTyVar tyvars )
+    do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys
+
+          -- an unboxed tuple pattern (but only an unboxed tuple pattern)
+          -- might have levity-polymorphic arguments. Check for this badness.
+        ; case con of
+            RealDataCon dc
+              | isUnboxedTupleTyCon (dataConTyCon dc)
+              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)
+            _ -> return ()
+
+        ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+          -- Must zonk the existential variables, because their
+          -- /kind/ need potential zonking.
+          -- cf typecheck/should_compile/tc221.hs
+        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+        ; (env2, new_binds) <- zonkTcEvBinds env1 binds
+        ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
+        ; (env', new_args) <- zonkConStuff env3 args
+        ; return (env', p { pat_arg_tys = new_tys,
+                            pat_tvs = new_tyvars,
+                            pat_dicts = new_evs,
+                            pat_binds = new_binds,
+                            pat_args = new_args,
+                            pat_wrap = new_wrapper}) }
+  where
+    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
+
+zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
+
+zonk_pat env (SigPat ty pat hs_ty)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; (env', pat') <- zonkPat env pat
+        ; return (env', SigPat ty' pat' hs_ty) }
+
+zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr)
+  = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
+        ; (env2, mb_neg') <- case mb_neg of
+            Nothing -> return (env1, Nothing)
+            Just n  -> second Just <$> zonkSyntaxExpr env1 n
+
+        ; lit' <- zonkOverLit env2 lit
+        ; ty' <- zonkTcTypeToTypeX env2 ty
+        ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') }
+
+zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2)
+  = do  { (env1, e1') <- zonkSyntaxExpr env  e1
+        ; (env2, e2') <- zonkSyntaxExpr env1 e2
+        ; n' <- zonkIdBndr env2 n
+        ; lit1' <- zonkOverLit env2 lit1
+        ; lit2' <- zonkOverLit env2 lit2
+        ; ty' <- zonkTcTypeToTypeX env2 ty
+        ; return (extendIdZonkEnv1 env2 n',
+                  NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') }
+
+zonk_pat env (CoPat x co_fn pat ty)
+  = do { (env', co_fn') <- zonkCoFn env co_fn
+       ; (env'', pat') <- zonkPat env' (noLoc pat)
+       ; ty' <- zonkTcTypeToTypeX env'' ty
+       ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
+
+zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
+
+---------------------------
+zonkConStuff :: ZonkEnv
+             -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
+             -> TcM (ZonkEnv,
+                    HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
+zonkConStuff env (PrefixCon pats)
+  = do  { (env', pats') <- zonkPats env pats
+        ; return (env', PrefixCon pats') }
+
+zonkConStuff env (InfixCon p1 p2)
+  = do  { (env1, p1') <- zonkPat env  p1
+        ; (env', p2') <- zonkPat env1 p2
+        ; return (env', InfixCon p1' p2') }
+
+zonkConStuff env (RecCon (HsRecFields rpats dd))
+  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
+        ; let rpats' = zipWith (\(dL->L l rp) p' ->
+                                  cL l (rp { hsRecFieldArg = p' }))
+                               rpats pats'
+        ; return (env', RecCon (HsRecFields rpats' dd)) }
+        -- Field selectors have declared types; hence no zonking
+
+---------------------------
+zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
+zonkPats env []         = return (env, [])
+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
+                             ; (env', pats') <- zonkPats env1 pats
+                             ; return (env', pat':pats') }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-Foreign]{Foreign exports}
+*                                                                      *
+************************************************************************
+-}
+
+zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]
+                   -> TcM [LForeignDecl GhcTc]
+zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
+
+zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
+zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
+                                     , fd_fe = spec })
+  = return (ForeignExport { fd_name = zonkLIdOcc env i
+                          , fd_sig_ty = undefined, fd_e_ext = co
+                          , fd_fe = spec })
+zonkForeignExport _ for_imp
+  = return for_imp     -- Foreign imports don't need zonking
+
+zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
+zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
+
+zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
+zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+                          , rd_lhs = lhs
+                          , rd_rhs = rhs })
+  = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
+
+       ; let env_lhs = setZonkType env_inside SkolemiseFlexi
+              -- See Note [Zonking the LHS of a RULE]
+
+       ; new_lhs <- zonkLExpr env_lhs    lhs
+       ; new_rhs <- zonkLExpr env_inside rhs
+
+       ; return $ rule { rd_tmvs = new_tm_bndrs
+                       , rd_lhs  = new_lhs
+                       , rd_rhs  = new_rhs } }
+  where
+   zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v)))
+      = do { (env', v') <- zonk_it env v
+           ; return (env', cL l (RuleBndr x (cL loc v'))) }
+   zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
+   zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"
+   zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match"
+                            -- due to #15884
+
+   zonk_it env v
+     | isId v     = do { v' <- zonkIdBndr env v
+                       ; return (extendIdZonkEnvRec env [v'], v') }
+     | otherwise  = ASSERT( isImmutableTyVar v)
+                    zonkTyBndrX env v
+                    -- DV: used to be return (env,v) but that is plain
+                    -- wrong because we may need to go inside the kind
+                    -- of v and zonk there!
+zonkRule _ (XRuleDecl _) = panic "zonkRule"
+
+{-
+************************************************************************
+*                                                                      *
+              Constraints and evidence
+*                                                                      *
+************************************************************************
+-}
+
+zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
+zonkEvTerm env (EvExpr e)
+  = EvExpr <$> zonkCoreExpr env e
+zonkEvTerm env (EvTypeable ty ev)
+  = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev
+zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
+                      , et_binds = ev_binds, et_body = body_id })
+  = do { (env0, new_tvs) <- zonkTyBndrsX env tvs
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+       ; let new_body_id = zonkIdOcc env2 body_id
+       ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
+                       , et_binds = new_ev_binds, et_body = new_body_id }) }
+
+zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
+zonkCoreExpr env (Var v)
+    | isCoVar v
+    = Coercion <$> zonkCoVarOcc env v
+    | otherwise
+    = return (Var $ zonkIdOcc env v)
+zonkCoreExpr _ (Lit l)
+    = return $ Lit l
+zonkCoreExpr env (Coercion co)
+    = Coercion <$> zonkCoToCo env co
+zonkCoreExpr env (Type ty)
+    = Type <$> zonkTcTypeToTypeX env ty
+
+zonkCoreExpr env (Cast e co)
+    = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
+zonkCoreExpr env (Tick t e)
+    = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
+
+zonkCoreExpr env (App e1 e2)
+    = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
+zonkCoreExpr env (Lam v e)
+    = do { (env1, v') <- zonkCoreBndrX env v
+         ; Lam v' <$> zonkCoreExpr env1 e }
+zonkCoreExpr env (Let bind e)
+    = do (env1, bind') <- zonkCoreBind env bind
+         Let bind'<$> zonkCoreExpr env1 e
+zonkCoreExpr env (Case scrut b ty alts)
+    = do scrut' <- zonkCoreExpr env scrut
+         ty' <- zonkTcTypeToTypeX env ty
+         b' <- zonkIdBndr env b
+         let env1 = extendIdZonkEnv1 env b'
+         alts' <- mapM (zonkCoreAlt env1) alts
+         return $ Case scrut' b' ty' alts'
+
+zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
+zonkCoreAlt env (dc, bndrs, rhs)
+    = do (env1, bndrs') <- zonkCoreBndrsX env bndrs
+         rhs' <- zonkCoreExpr env1 rhs
+         return $ (dc, bndrs', rhs')
+
+zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
+zonkCoreBind env (NonRec v e)
+    = do v' <- zonkIdBndr env v
+         e' <- zonkCoreExpr env e
+         let env1 = extendIdZonkEnv1 env v'
+         return (env1, NonRec v' e')
+zonkCoreBind env (Rec pairs)
+    = do (env1, pairs') <- fixM go
+         return (env1, Rec pairs')
+  where
+    go ~(_, new_pairs) = do
+         let env1 = extendIdZonkEnvRec env (map fst new_pairs)
+         pairs' <- mapM (zonkCorePair env1) pairs
+         return (env1, pairs')
+
+zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
+zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
+
+zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
+zonkEvTypeable env (EvTypeableTyCon tycon e)
+  = do { e'  <- mapM (zonkEvTerm env) e
+       ; return $ EvTypeableTyCon tycon e' }
+zonkEvTypeable env (EvTypeableTyApp t1 t2)
+  = do { t1' <- zonkEvTerm env t1
+       ; t2' <- zonkEvTerm env t2
+       ; return (EvTypeableTyApp t1' t2') }
+zonkEvTypeable env (EvTypeableTrFun t1 t2)
+  = do { t1' <- zonkEvTerm env t1
+       ; t2' <- zonkEvTerm env t2
+       ; return (EvTypeableTrFun t1' t2') }
+zonkEvTypeable env (EvTypeableTyLit t1)
+  = do { t1' <- zonkEvTerm env t1
+       ; return (EvTypeableTyLit t1') }
+
+zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
+                            ; return (env, [EvBinds (unionManyBags bs')]) }
+
+zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
+zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
+                          ; return (env', EvBinds bs') }
+
+zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
+zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
+zonk_tc_ev_binds env (EvBinds bs)    = zonkEvBinds env bs
+
+zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
+  = do { bs <- readMutVar ref
+       ; zonkEvBinds env (evBindMapBinds bs) }
+zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)
+
+zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBinds env binds
+  = {-# SCC "zonkEvBinds" #-}
+    fixM (\ ~( _, new_binds) -> do
+         { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
+         ; binds' <- mapBagM (zonkEvBind env1) binds
+         ; return (env1, binds') })
+  where
+    collect_ev_bndrs :: Bag EvBind -> [EvVar]
+    collect_ev_bndrs = foldrBag add []
+    add (EvBind { eb_lhs = var }) vars = var : vars
+
+zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
+zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
+  = do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
+
+         -- Optimise the common case of Refl coercions
+         -- See Note [Optimise coercion zonking]
+         -- This has a very big effect on some programs (eg #5030)
+
+       ; term' <- case getEqPredTys_maybe (idType var') of
+           Just (r, ty1, ty2) | ty1 `eqType` ty2
+                  -> return (evCoercion (mkTcReflCo r ty1))
+           _other -> zonkEvTerm env term
+
+       ; return (bind { eb_lhs = var', eb_rhs = term' }) }
+
+{- Note [Optimise coercion zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When optimising evidence binds we may come across situations where
+a coercion looks like
+      cv = ReflCo ty
+or    cv1 = cv2
+where the type 'ty' is big.  In such cases it is a waste of time to zonk both
+  * The variable on the LHS
+  * The coercion on the RHS
+Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
+use Refl on the right, ignoring the actual coercion on the RHS.
+
+This can have a very big effect, because the constraint solver sometimes does go
+to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf #5030)
+
+
+************************************************************************
+*                                                                      *
+                         Zonking types
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Sharing when zonking to Type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem:
+
+    In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to
+    (Indirect zty), see Note [Sharing in zonking] in TcMType. But we
+    /can't/ do this when zonking a TcType to a Type (#15552, esp
+    comment:3).  Suppose we have
+
+       alpha -> alpha
+         where
+            alpha is already unified:
+             alpha := T{tc-tycon} Int -> Int
+         and T is knot-tied
+
+    By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
+    but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
+    Note [Type checking recursive type and class declarations] in
+    TcTyClsDecls.
+
+    Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
+    the same path as Note [Sharing in zonking] in TcMType, we'll
+    update alpha to
+       alpha := T{knot-tied-tc} Int -> Int
+
+    But alas, if we encounter alpha for a /second/ time, we end up
+    looking at T{knot-tied-tc} and fall into a black hole. The whole
+    point of zonkTcTypeToType is that it produces a type full of
+    knot-tied tycons, and you must not look at the result!!
+
+    To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
+    the same as zonkTcTypeToType. (If we distinguished TcType from
+    Type, this issue would have been a type error!)
+
+Solution: (see #15552 for other variants)
+
+    One possible solution is simply not to do the short-circuiting.
+    That has less sharing, but maybe sharing is rare. And indeed,
+    that turns out to be viable from a perf point of view
+
+    But the code implements something a bit better
+
+    * ZonkEnv contains ze_meta_tv_env, which maps
+          from a MetaTyVar (unificaion variable)
+          to a Type (not a TcType)
+
+    * In zonkTyVarOcc, we check this map to see if we have zonked
+      this variable before. If so, use the previous answer; if not
+      zonk it, and extend the map.
+
+    * The map is of course stateful, held in a TcRef. (That is unlike
+      the treatment of lexically-scoped variables in ze_tv_env and
+      ze_id_env.)
+
+    Is the extra work worth it?  Some non-sytematic perf measurements
+    suggest that compiler allocation is reduced overall (by 0.5% or so)
+    but compile time really doesn't change.
+-}
+
+zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
+zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
+                          , ze_tv_env = tv_env
+                          , ze_meta_tv_env = mtv_env_ref }) tv
+  | isTcTyVar tv
+  = case tcTyVarDetails tv of
+      SkolemTv {}    -> lookup_in_tv_env
+      RuntimeUnk {}  -> lookup_in_tv_env
+      MetaTv { mtv_ref = ref }
+        -> do { mtv_env <- readTcRef mtv_env_ref
+                -- See Note [Sharing when zonking to Type]
+              ; case lookupVarEnv mtv_env tv of
+                  Just ty -> return ty
+                  Nothing -> do { mtv_details <- readTcRef ref
+                                ; zonk_meta mtv_env ref mtv_details } }
+  | otherwise
+  = lookup_in_tv_env
+
+  where
+    lookup_in_tv_env    -- Look up in the env just as we do for Ids
+      = case lookupVarEnv tv_env tv of
+          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv
+          Just tv' -> return (mkTyVarTy tv')
+
+    zonk_meta mtv_env ref Flexi
+      = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
+           ; ty <- commitFlexi flexi tv kind
+           ; writeMetaTyVarRef tv ref ty  -- Belt and braces
+           ; finish_meta mtv_env ty }
+
+    zonk_meta mtv_env _ (Indirect ty)
+      = do { zty <- zonkTcTypeToTypeX env ty
+           ; finish_meta mtv_env zty }
+
+    finish_meta mtv_env ty
+      = do { let mtv_env' = extendVarEnv mtv_env tv ty
+           ; writeTcRef mtv_env_ref mtv_env'
+           ; return ty }
+
+lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
+lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv
+  = lookupVarEnv tv_env tv
+
+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
+-- Only monadic so we can do tc-tracing
+commitFlexi flexi tv zonked_kind
+  = case flexi of
+      SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))
+
+      DefaultFlexi
+        | isRuntimeRepTy zonked_kind
+        -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
+              ; return liftedRepTy }
+        | otherwise
+        -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
+              ; return (anyTypeOfKind zonked_kind) }
+
+      RuntimeUnkFlexi
+        -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
+              ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
+                        -- This is where RuntimeUnks are born:
+                        -- otherwise-unconstrained unification variables are
+                        -- turned into RuntimeUnks as they leave the
+                        -- typechecker's monad
+  where
+     name = tyVarName tv
+
+zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
+zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv
+  | Just cv' <- lookupVarEnv tyco_env cv  -- don't look in the knot-tied env
+  = return $ mkCoVarCo cv'
+  | otherwise
+  = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
+
+zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
+zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+  = do { contents <- readTcRef ref
+       ; case contents of
+           Just co -> do { co' <- zonkCoToCo env co
+                         ; checkCoercionHole cv co' }
+
+              -- This next case should happen only in the presence of
+              -- (undeferred) type errors. Originally, I put in a panic
+              -- here, but that caused too many uses of `failIfErrsM`.
+           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
+                         ; when debugIsOn $
+                           whenNoErrs $
+                           MASSERT2( False
+                                   , text "Type-correct unfilled coercion hole"
+                                     <+> ppr hole )
+                         ; cv' <- zonkCoVar cv
+                         ; return $ mkCoVarCo cv' } }
+                             -- This will be an out-of-scope variable, but keeping
+                             -- this as a coercion hole led to #15787
+
+zonk_tycomapper :: TyCoMapper ZonkEnv TcM
+zonk_tycomapper = TyCoMapper
+  { tcm_tyvar      = zonkTyVarOcc
+  , tcm_covar      = zonkCoVarOcc
+  , tcm_hole       = zonkCoHole
+  , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
+  , tcm_tycon      = zonkTcTyConToTyCon }
+
+-- Zonk a TyCon by changing a TcTyCon to a regular TyCon
+zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
+zonkTcTyConToTyCon tc
+  | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
+                      ; case thing of
+                          ATyCon real_tc -> return real_tc
+                          _              -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
+  | otherwise    = return tc -- it's already zonked
+
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+zonkTcTypeToType :: TcType -> TcM Type
+zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty
+
+zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
+zonkTcTypeToTypeX = mapType zonk_tycomapper
+
+zonkTcTypesToTypes :: [TcType] -> TcM [Type]
+zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys
+
+zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
+zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys
+
+zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+zonkCoToCo = mapCoercion zonk_tycomapper
+
+zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
+zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
+  = do { ty' <- zonkTcTypeToTypeX ze ty
+       ; gdm_spec' <- zonk_gdm gdm_spec
+       ; return (name, ty', gdm_spec') }
+  where
+    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
+             -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
+    zonk_gdm Nothing = return Nothing
+    zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
+    zonk_gdm (Just (GenericDM (loc, ty)))
+      = do { ty' <- zonkTcTypeToTypeX ze ty
+           ; return (Just (GenericDM (loc, ty'))) }
+
+---------------------------------------
+{- Note [Zonking the LHS of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also DsBinds Note [Free tyvars on rule LHS]
+
+We need to gather the type variables mentioned on the LHS so we can
+quantify over them.  Example:
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)) and we do
+not want to zap the unbound meta-tyvar 'alpha' to Any, because that
+limits the applicability of the rule.  Instead, we want to quantify
+over it!
+
+We do this in two stages.
+
+* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'.  We
+  do this by using zonkTvSkolemising as the UnboundTyVarZonker in the
+  ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a
+  UnboundTyVarZonker.)
+
+* In DsBinds, we quantify over it.  See DsBinds
+  Note [Free tyvars on rule LHS]
+
+Quantifying here is awkward because (a) the data type is big and (b)
+finding the free type vars of an expression is necessarily monadic
+operation. (consider /\a -> f @ b, where b is side-effected to a)
+-}
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHsType.hs
@@ -0,0 +1,2939 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcHsType (
+        -- Type signatures
+        kcHsSigType, tcClassSigType,
+        tcHsSigType, tcHsSigWcType,
+        tcHsPartialSigType,
+        funsSigCtxt, addSigCtxt, pprSigCtxt,
+
+        tcHsClsInstType,
+        tcHsDeriv, tcDerivStrategy,
+        tcHsTypeApp,
+        UserTypeCtxt(..),
+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,
+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,
+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
+        ContextKind(..),
+
+                -- Type checking type and class decls
+        kcLookupTcTyCon, bindTyClTyVars,
+        etaExpandAlgTyCon, tcbVisibilities,
+
+          -- tyvars
+        zonkAndScopedSort,
+
+        -- Kind-checking types
+        -- No kind generalisation, no checkValidType
+        kcLHsQTyVars,
+        tcWildCardBinders,
+        tcHsLiftedType,   tcHsOpenType,
+        tcHsLiftedTypeNC, tcHsOpenTypeNC,
+        tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
+        failIfEmitsConstraints,
+        solveEqualities, -- useful re-export
+
+        typeLevelMode, kindLevelMode,
+
+        kindGeneralize, checkExpectedKind_pp,
+
+        -- Sort-checking kinds
+        tcLHsKindSig, badKindSig,
+
+        -- Zonking and promoting
+        zonkPromoteType,
+
+        -- Pattern type signatures
+        tcHsPatSigType, tcPatSig,
+
+        -- Error messages
+        funAppCtxt, addTyConFlavCtxt
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcRnMonad
+import TcEvidence
+import TcEnv
+import TcMType
+import TcValidity
+import TcUnify
+import TcIface
+import TcSimplify
+import TcHsSyn
+import TyCoRep  ( Type(..) )
+import TcErrors ( reportAllUnsolved )
+import TcType
+import Inst   ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )
+import TyCoRep( TyCoBinder(..) )  -- Used in etaExpandAlgTyCon
+import Type
+import TysPrim
+import Coercion
+import RdrName( lookupLocalRdrOcc )
+import Var
+import VarSet
+import TyCon
+import ConLike
+import DataCon
+import Class
+import Name
+-- import NameSet
+import VarEnv
+import TysWiredIn
+import BasicTypes
+import SrcLoc
+import Constants ( mAX_CTUPLE_SIZE )
+import ErrUtils( MsgDoc )
+import Unique
+import UniqSet
+import Util
+import UniqSupply
+import Outputable
+import FastString
+import PrelNames hiding ( wildCardName )
+import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Maybes
+import Data.List ( find )
+import Control.Monad
+
+{-
+        ----------------------------
+                General notes
+        ----------------------------
+
+Unlike with expressions, type-checking types both does some checking and
+desugars at the same time. This is necessary because we often want to perform
+equality checks on the types right away, and it would be incredibly painful
+to do this on un-desugared types. Luckily, desugared types are close enough
+to HsTypes to make the error messages sane.
+
+During type-checking, we perform as little validity checking as possible.
+Generally, after type-checking, you will want to do validity checking, say
+with TcValidity.checkValidType.
+
+Validity checking
+~~~~~~~~~~~~~~~~~
+Some of the validity check could in principle be done by the kind checker,
+but not all:
+
+- During desugaring, we normalise by expanding type synonyms.  Only
+  after this step can we check things like type-synonym saturation
+  e.g.  type T k = k Int
+        type S a = a
+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);
+  and then S is saturated.  This is a GHC extension.
+
+- Similarly, also a GHC extension, we look through synonyms before complaining
+  about the form of a class or instance declaration
+
+- Ambiguity checks involve functional dependencies
+
+Also, in a mutually recursive group of types, we can't look at the TyCon until we've
+finished building the loop.  So to keep things simple, we postpone most validity
+checking until step (3).
+
+%************************************************************************
+%*                                                                      *
+              Check types AND do validity checking
+*                                                                      *
+************************************************************************
+-}
+
+funsSigCtxt :: [Located Name] -> UserTypeCtxt
+-- Returns FunSigCtxt, with no redundant-context-reporting,
+-- form a list of located names
+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False
+funsSigCtxt []              = panic "funSigCtxt"
+
+addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
+addSigCtxt ctxt hs_ty thing_inside
+  = setSrcSpan (getLoc hs_ty) $
+    addErrCtxt (pprSigCtxt ctxt hs_ty) $
+    thing_inside
+
+pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc
+-- (pprSigCtxt ctxt <extra> <type>)
+-- prints    In the type signature for 'f':
+--              f :: <type>
+-- The <extra> is either empty or "the ambiguity check for"
+pprSigCtxt ctxt hs_ty
+  | Just n <- isSigMaybe ctxt
+  = hang (text "In the type signature:")
+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)
+
+  | otherwise
+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)
+       2 (ppr hs_ty)
+
+tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
+-- This one is used when we have a LHsSigWcType, but in
+-- a place where wildcards aren't allowed. The renamer has
+-- already checked this, so we can simply ignore it.
+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
+
+kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
+kcHsSigType names (HsIB { hsib_body = hs_ty
+                                  , hsib_ext = sig_vars })
+  = discardResult                        $
+    addSigCtxt (funsSigCtxt names) hs_ty $
+    bindImplicitTKBndrs_Skol sig_vars    $
+    tc_lhs_type typeLevelMode hs_ty liftedTypeKind
+
+kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType"
+
+tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
+-- Does not do validity checking
+tcClassSigType skol_info names sig_ty
+  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $
+    tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
+       -- Do not zonk-to-Type, nor perform a validity check
+       -- We are in a knot with the class and associated types
+       -- Zonking and validity checking is done by tcClassDecl
+
+tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
+-- Does validity checking
+-- See Note [Recipe for checking a signature]
+tcHsSigType ctxt sig_ty
+  = addSigCtxt ctxt (hsSigType sig_ty) $
+    do { traceTc "tcHsSigType {" (ppr sig_ty)
+
+          -- Generalise here: see Note [Kind generalisation]
+       ; ty <- tc_hs_sig_type skol_info sig_ty
+                                      (expectedKindInCtxt ctxt)
+       ; ty <- zonkTcType ty
+
+       ; checkValidType ctxt ty
+       ; traceTc "end tcHsSigType }" (ppr ty)
+       ; return ty }
+  where
+    skol_info = SigTypeSkol ctxt
+
+tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
+               -> ContextKind -> TcM Type
+-- Kind-checks/desugars an 'LHsSigType',
+--   solve equalities,
+--   and then kind-generalizes.
+-- This will never emit constraints, as it uses solveEqualities interally.
+-- No validity checking or zonking
+tc_hs_sig_type skol_info hs_sig_type ctxt_kind
+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
+  = do { (tc_lvl, (wanted, (spec_tkvs, ty)))
+              <- pushTcLevelM                           $
+                 solveLocalEqualitiesX "tc_hs_sig_type" $
+                 bindImplicitTKBndrs_Skol sig_vars      $
+                 do { kind <- newExpectedKind ctxt_kind
+                    ; tc_lhs_type typeLevelMode hs_ty kind }
+       -- Any remaining variables (unsolved in the solveLocalEqualities)
+       -- should be in the global tyvars, and therefore won't be quantified
+
+       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
+       ; let ty1 = mkSpecForAllTys spec_tkvs ty
+       ; kvs <- kindGeneralizeLocal wanted ty1
+       ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)
+                                  tc_lvl wanted
+
+       -- See Note [Fail fast if there are insoluble kind equalities]
+       --     in TcSimplify
+       ; when (insolubleWC wanted) failM
+
+       ; return (mkInvForAllTys kvs ty1) }
+
+tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type"
+
+tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type
+-- tcTopLHsType is used for kind-checking top-level HsType where
+--   we want to fully solve /all/ equalities, and report errors
+-- Does zonking, but not validity checking because it's used
+--   for things (like deriving and instances) that aren't
+--   ordinary types
+tcTopLHsType hs_sig_type ctxt_kind
+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
+  = do { traceTc "tcTopLHsType {" (ppr hs_ty)
+       ; (spec_tkvs, ty)
+              <- pushTcLevelM_                     $
+                 solveEqualities                   $
+                 bindImplicitTKBndrs_Skol sig_vars $
+                 do { kind <- newExpectedKind ctxt_kind
+                    ; tc_lhs_type typeLevelMode hs_ty kind }
+
+       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
+       ; let ty1 = mkSpecForAllTys spec_tkvs ty
+       ; kvs <- kindGeneralize ty1
+       ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)
+       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])
+       ; return final_ty}
+
+tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType"
+
+-----------------
+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
+-- E.g.    class C (a::*) (b::k->k)
+--         data T a b = ... deriving( C Int )
+--    returns ([k], C, [k, Int], [k->k])
+-- Return values are fully zonked
+tcHsDeriv hs_ty
+  = do { ty <- checkNoErrs $  -- Avoid redundant error report
+                              -- with "illegal deriving", below
+               tcTopLHsType hs_ty AnyKind
+       ; let (tvs, pred)    = splitForAllTys ty
+             (kind_args, _) = splitFunTys (tcTypeKind pred)
+       ; case getClassPredTys_maybe pred of
+           Just (cls, tys) -> return (tvs, (cls, tys, kind_args))
+           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
+
+-- | Typecheck something within the context of a deriving strategy.
+-- This is of particular importance when the deriving strategy is @via@.
+-- For instance:
+--
+-- @
+-- deriving via (S a) instance C (T a)
+-- @
+--
+-- We need to typecheck @S a@, and moreover, we need to extend the tyvar
+-- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified
+-- the type variable @a@.
+tcDerivStrategy
+  :: forall a.
+     Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy
+  -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the
+                      -- deriving strategy, which might quantify some type
+                      -- variables of its own.
+  -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
+     -- ^ The typechecked deriving strategy, all quantified tyvars, and
+     -- the payload of the typechecked thing.
+tcDerivStrategy mds thing_inside
+  = case mds of
+      Nothing -> boring_case Nothing
+      Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds
+                    pure (Just ds', tvs, thing)
+  where
+    tc_deriv_strategy :: DerivStrategy GhcRn
+                      -> TcM (DerivStrategy GhcTc, [TyVar], a)
+    tc_deriv_strategy StockStrategy    = boring_case StockStrategy
+    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
+    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy
+    tc_deriv_strategy (ViaStrategy ty) = do
+      ty' <- checkNoErrs $
+             tcTopLHsType ty AnyKind
+      let (via_tvs, via_pred) = splitForAllTys ty'
+      tcExtendTyVarEnv via_tvs $ do
+        (thing_tvs, thing) <- thing_inside
+        pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)
+
+    boring_case :: mds -> TcM (mds, [TyVar], a)
+    boring_case mds = do
+      (thing_tvs, thing) <- thing_inside
+      pure (mds, thing_tvs, thing)
+
+tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt
+                -> LHsSigType GhcRn
+                -> TcM Type
+-- Like tcHsSigType, but for a class instance declaration
+tcHsClsInstType user_ctxt hs_inst_ty
+  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
+    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so
+         -- these constraints will never be solved later. And failing
+         -- eagerly avoids follow-on errors when checkValidInstance
+         -- sees an unsolved coercion hole
+         inst_ty <- checkNoErrs $
+                    tcTopLHsType hs_inst_ty (TheKind constraintKind)
+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty
+       ; return inst_ty }
+
+----------------------------------------------
+-- | Type-check a visible type application
+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
+-- See Note [Recipe for checking a signature] in TcHsType
+tcHsTypeApp wc_ty kind
+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty
+  = do { ty <- solveLocalEqualities "tcHsTypeApp" $
+               -- We are looking at a user-written type, very like a
+               -- signature so we want to solve its equalities right now
+               unsetWOptM Opt_WarnPartialTypeSignatures $
+               setXOptM LangExt.PartialTypeSignatures $
+               -- See Note [Wildcards in visible type application]
+               tcWildCardBinders sig_wcs $ \ _ ->
+               tcCheckLHsType hs_ty kind
+       -- We must promote here. Ex:
+       --   f :: forall a. a
+       --   g = f @(forall b. Proxy b -> ()) @Int ...
+       -- After when processing the @Int, we'll have to check its kind
+       -- against the as-yet-unknown kind of b. This check causes an assertion
+       -- failure if we don't promote.
+       ; ty <- zonkPromoteType ty
+       ; checkValidType TypeAppCtxt ty
+       ; return ty }
+tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"
+
+{- Note [Wildcards in visible type application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed
+wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType
+will call emitWildCardHoleConstraints on them. However, this would trigger
+error/warning when an unnamed wildcard is passed in as a visible type argument,
+which we do not want because users should be able to write @_ to skip a instantiating
+a type variable variable without fuss. The solution is to switch the
+PartialTypeSignatures flags here to let the typechecker know that it's checking
+a '@_' and do not emit hole constraints on it.
+See related Note [Wildcards in visible kind application]
+and Note [The wildcard story for types] in HsTypes.hs
+
+-}
+
+{-
+************************************************************************
+*                                                                      *
+            The main kind checker: no validity checks here
+*                                                                      *
+************************************************************************
+-}
+
+---------------------------
+tcHsOpenType, tcHsLiftedType,
+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
+-- Used for type signatures
+-- Do not do validity checking
+tcHsOpenType ty   = addTypeCtxt ty $ tcHsOpenTypeNC ty
+tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty
+
+tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind
+                         ; tc_lhs_type typeLevelMode ty ek }
+tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind
+
+-- Like tcHsType, but takes an expected kind
+tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType
+tcCheckLHsType hs_ty exp_kind
+  = addTypeCtxt hs_ty $
+    tc_lhs_type typeLevelMode hs_ty exp_kind
+
+tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)
+-- Called from outside: set the context
+tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)
+
+-- Like tcLHsType, but use it in a context where type synonyms and type families
+-- do not need to be saturated, like in a GHCi :kind call
+tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
+tcLHsTypeUnsaturated hs_ty
+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty)
+  = addTypeCtxt hs_ty $
+    do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty
+       ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args }
+         -- Notice the 'nosat'; do not instantiate trailing
+         -- invisible arguments of a type family.
+         -- See Note [Dealing with :kind]
+
+  | otherwise
+  = addTypeCtxt hs_ty $
+    tc_infer_lhs_type mode hs_ty
+
+  where
+    mode = typeLevelMode
+
+{- Note [Dealing with :kind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this GHCi command
+  ghci> type family F :: Either j k
+  ghci> :kind F
+  F :: forall {j,k}. Either j k
+
+We will only get the 'forall' if we /refrain/ from saturating those
+invisible binders. But generally we /do/ saturate those invisible
+binders (see tcInferApps), and we want to do so for nested application
+even in GHCi.  Consider for example (#16287)
+  ghci> type family F :: k
+  ghci> data T :: (forall k. k) -> Type
+  ghci> :kind T F
+We want to reject this. It's just at the very top level that we want
+to switch off saturation.
+
+So tcLHsTypeUnsaturated does a little special case for top level
+applications.  Actually the common case is a bare variable, as above.
+
+
+************************************************************************
+*                                                                      *
+      Type-checking modes
+*                                                                      *
+************************************************************************
+
+The kind-checker is parameterised by a TcTyMode, which contains some
+information about where we're checking a type.
+
+The renamer issues errors about what it can. All errors issued here must
+concern things that the renamer can't handle.
+
+-}
+
+-- | Info about the context in which we're checking a type. Currently,
+-- differentiates only between types and kinds, but this will likely
+-- grow, at least to include the distinction between patterns and
+-- not-patterns.
+--
+-- To find out where the mode is used, search for 'mode_level'
+data TcTyMode = TcTyMode { mode_level :: TypeOrKind }
+
+typeLevelMode :: TcTyMode
+typeLevelMode = TcTyMode { mode_level = TypeLevel }
+
+kindLevelMode :: TcTyMode
+kindLevelMode = TcTyMode { mode_level = KindLevel }
+
+-- switch to kind level
+kindLevel :: TcTyMode -> TcTyMode
+kindLevel mode = mode { mode_level = KindLevel }
+
+instance Outputable TcTyMode where
+  ppr = ppr . mode_level
+
+{-
+Note [Bidirectional type checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In expressions, whenever we see a polymorphic identifier, say `id`, we are
+free to instantiate it with metavariables, knowing that we can always
+re-generalize with type-lambdas when necessary. For example:
+
+  rank2 :: (forall a. a -> a) -> ()
+  x = rank2 id
+
+When checking the body of `x`, we can instantiate `id` with a metavariable.
+Then, when we're checking the application of `rank2`, we notice that we really
+need a polymorphic `id`, and then re-generalize over the unconstrained
+metavariable.
+
+In types, however, we're not so lucky, because *we cannot re-generalize*!
+There is no lambda. So, we must be careful only to instantiate at the last
+possible moment, when we're sure we're never going to want the lost polymorphism
+again. This is done in calls to tcInstInvisibleTyBinders.
+
+To implement this behavior, we use bidirectional type checking, where we
+explicitly think about whether we know the kind of the type we're checking
+or not. Note that there is a difference between not knowing a kind and
+knowing a metavariable kind: the metavariables are TauTvs, and cannot become
+forall-quantified kinds. Previously (before dependent types), there were
+no higher-rank kinds, and so we could instantiate early and be sure that
+no types would have polymorphic kinds, and so we could always assume that
+the kind of a type was a fresh metavariable. Not so anymore, thus the
+need for two algorithms.
+
+For HsType forms that can never be kind-polymorphic, we implement only the
+"down" direction, where we safely assume a metavariable kind. For HsType forms
+that *can* be kind-polymorphic, we implement just the "up" (functions with
+"infer" in their name) version, as we gain nothing by also implementing the
+"down" version.
+
+Note [Future-proofing the type checker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As discussed in Note [Bidirectional type checking], each HsType form is
+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions
+are mutually recursive, so that either one can work for any type former.
+But, we want to make sure that our pattern-matches are complete. So,
+we have a bunch of repetitive code just so that we get warnings if we're
+missing any patterns.
+
+-}
+
+------------------------------------------
+-- | Check and desugar a type, returning the core type and its
+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression
+-- level.
+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
+tc_infer_lhs_type mode (L span ty)
+  = setSrcSpan span $
+    tc_infer_hs_type mode ty
+
+---------------------------
+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.
+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
+tc_infer_hs_type_ek mode hs_ty ek
+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty
+       ; checkExpectedKind hs_ty ty k ek }
+
+---------------------------
+-- | Infer the kind of a type and desugar. This is the "up" type-checker,
+-- as described in Note [Bidirectional type checking]
+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
+
+tc_infer_hs_type mode (HsParTy _ t)
+  = tc_infer_lhs_type mode t
+
+tc_infer_hs_type mode ty
+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty
+  = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty
+       ; tcInferApps mode hs_fun_ty fun_ty hs_args }
+
+tc_infer_hs_type mode (HsKindSig _ ty sig)
+  = do { sig' <- tcLHsKindSig KindSigCtxt sig
+                 -- We must typecheck the kind signature, and solve all
+                 -- its equalities etc; from this point on we may do
+                 -- things like instantiate its foralls, so it needs
+                 -- to be fully determined (#14904)
+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')
+       ; ty' <- tc_lhs_type mode ty sig'
+       ; return (ty', sig') }
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate
+-- the splice location to the typechecker. Here we skip over it in order to have
+-- the same kind inferred for a given expression whether it was produced from
+-- splices or not.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))
+  = tc_infer_hs_type mode ty
+
+tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
+tc_infer_hs_type _    (XHsType (NHsCoreTy ty))
+  = return (ty, tcTypeKind ty)
+
+tc_infer_hs_type _ (HsExplicitListTy _ _ tys)
+  | null tys  -- this is so that we can use visible kind application with '[]
+              -- e.g ... '[] @Bool
+  = return (mkTyConTy promotedNilDataCon,
+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)
+
+tc_infer_hs_type mode other_ty
+  = do { kv <- newMetaKindVar
+       ; ty' <- tc_hs_type mode other_ty kv
+       ; return (ty', kv) }
+
+------------------------------------------
+tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
+tc_lhs_type mode (L span ty) exp_kind
+  = setSrcSpan span $
+    tc_hs_type mode ty exp_kind
+
+tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
+-- See Note [Bidirectional type checking]
+
+tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type _ ty@(HsBangTy _ bang _) _
+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
+    -- bangs are invalid, so fail. (#7210, #14761)
+    = do { let bangError err = failWith $
+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
+                 text err <+> text "annotation cannot appear nested inside a type"
+         ; case bang of
+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"
+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"
+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"
+             HsSrcBang _ _ _                   -> bangError "strictness" }
+tc_hs_type _ ty@(HsRecTy {})      _
+      -- Record types (which only show up temporarily in constructor
+      -- signatures) should have been removed by now
+    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.
+-- Here we get rid of it and add the finalizers to the global environment
+-- while capturing the local environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))
+           exp_kind
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tc_hs_type mode ty exp_kind
+
+-- This should never happen; type splices are expanded by the renamer
+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
+  = failWithTc (text "Unexpected type splice:" <+> ppr ty)
+
+---------- Functions and applications
+tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind
+  = tc_fun_type mode ty1 ty2 exp_kind
+
+tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
+  | op `hasKey` funTyConKey
+  = tc_fun_type mode ty1 ty2 exp_kind
+
+--------- Foralls
+tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs
+                                   , hst_body = ty }) exp_kind
+  = do { (tclvl, wanted, (tvs', ty'))
+            <- pushLevelAndCaptureConstraints $
+               bindExplicitTKBndrs_Skol hs_tvs $
+               tc_lhs_type mode ty exp_kind
+    -- Do not kind-generalise here!  See Note [Kind generalisation]
+    -- Why exp_kind?  See Note [Body kind of HsForAllTy]
+       ; let argf        = case fvf of
+                             ForallVis   -> Required
+                             ForallInvis -> Specified
+             bndrs       = mkTyVarBinders argf tvs'
+             skol_info   = ForAllSkol (ppr forall)
+             m_telescope = Just (sep (map ppr hs_tvs))
+
+       ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted
+
+       ; return (mkForAllTys bndrs ty') }
+
+tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind
+  | null (unLoc ctxt)
+  = tc_lhs_type mode rn_ty exp_kind
+
+  -- See Note [Body kind of a HsQualTy]
+  | tcIsConstraintKind exp_kind
+  = do { ctxt' <- tc_hs_context mode ctxt
+       ; ty'   <- tc_lhs_type mode rn_ty constraintKind
+       ; return (mkPhiTy ctxt' ty') }
+
+  | otherwise
+  = do { ctxt' <- tc_hs_context mode ctxt
+
+       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can
+                                -- be TYPE r, for any r, hence newOpenTypeKind
+       ; ty' <- tc_lhs_type mode rn_ty ek
+       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')
+                           liftedTypeKind exp_kind }
+
+--------- Lists, arrays, and tuples
+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind
+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
+       ; checkWiredInTyCon listTyCon
+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
+
+-- See Note [Distinguishing tuple kinds] in HsTypes
+-- See Note [Inferring tuple kinds]
+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
+  | Just tup_sort <- tupKindSort_maybe exp_kind
+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind
+  | otherwise
+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys
+       ; kinds <- mapM zonkTcType kinds
+           -- Infer each arg type separately, because errors can be
+           -- confusing if we give them a shared kind.  Eg #7410
+           -- (Either Int, Int), we do not want to get an error saying
+           -- "the second argument of a tuple should have kind *->*"
+
+       ; let (arg_kind, tup_sort)
+               = case [ (k,s) | k <- kinds
+                              , Just s <- [tupKindSort_maybe k] ] of
+                    ((k,s) : _) -> (k,s)
+                    [] -> (liftedTypeKind, BoxedTuple)
+         -- In the [] case, it's not clear what the kind is, so guess *
+
+       ; tys' <- sequence [ setSrcSpan loc $
+                            checkExpectedKind hs_ty ty kind arg_kind
+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
+
+       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
+
+
+tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind
+  = tc_tuple rn_ty mode tup_sort tys exp_kind
+  where
+    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above
+                  HsUnboxedTuple    -> UnboxedTuple
+                  HsBoxedTuple      -> BoxedTuple
+                  HsConstraintTuple -> ConstraintTuple
+                  _                 -> panic "tc_hs_type HsTupleTy"
+
+tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
+  = do { let arity = length hs_tys
+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
+       ; let arg_reps = map kindRep arg_kinds
+             arg_tys  = arg_reps ++ tau_tys
+             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys
+             sum_kind = unboxedSumKind arg_reps
+       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind
+       }
+
+--------- Promoted lists and tuples
+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
+  = do { tks <- mapM (tc_infer_lhs_type mode) tys
+       ; (taus', kind) <- unifyKinds tys tks
+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }
+  where
+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]
+
+tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
+  -- using newMetaKindVar means that we force instantiations of any polykinded
+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.
+  = do { ks   <- replicateM arity newMetaKindVar
+       ; taus <- zipWithM (tc_lhs_type mode) tys ks
+       ; let kind_con   = tupleTyCon           Boxed arity
+             ty_con     = promotedTupleDataCon Boxed arity
+             tup_k      = mkTyConApp kind_con ks
+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
+  where
+    arity = length tys
+
+--------- Constraint types
+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
+  = do { MASSERT( isTypeLevel (mode_level mode) )
+       ; ty' <- tc_lhs_type mode ty liftedTypeKind
+       ; let n' = mkStrLitTy $ hsIPNameFS n
+       ; ipClass <- tcLookupClass ipClassName
+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])
+                           constraintKind exp_kind }
+
+tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind
+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to
+  -- handle it in 'coreView' and 'tcView'.
+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind
+
+--------- Literals
+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
+  = do { checkWiredInTyCon typeNatKindCon
+       ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }
+
+tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
+  = do { checkWiredInTyCon typeSymbolKindCon
+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
+
+--------- Potentially kind-polymorphic types: call the "up" checker
+-- See Note [Future-proofing the type checker]
+tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type _    wc@(HsWildCardTy _)        ek = tcWildCardOcc wc ek
+
+------------------------------------------
+tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind
+            -> TcM TcType
+tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
+  TypeLevel ->
+    do { arg_k <- newOpenTypeKind
+       ; res_k <- newOpenTypeKind
+       ; ty1' <- tc_lhs_type mode ty1 arg_k
+       ; ty2' <- tc_lhs_type mode ty2 res_k
+       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkVisFunTy ty1' ty2')
+                           liftedTypeKind exp_kind }
+  KindLevel ->  -- no representation polymorphism in kinds. yet.
+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
+       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkVisFunTy ty1' ty2')
+                           liftedTypeKind exp_kind }
+
+---------------------------
+tcWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType
+tcWildCardOcc wc exp_kind
+  = do { wc_tv <- newWildTyVar
+          -- The wildcard's kind should be an un-filled-in meta tyvar
+       ; loc <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
+       ; part_tysig <- xoptM LangExt.PartialTypeSignatures
+       ; warning <- woptM Opt_WarnPartialTypeSignatures
+       -- See Note [Wildcards in visible kind application]
+       ; unless (part_tysig && not warning)
+             (emitWildCardHoleConstraints [(name,wc_tv)])
+       ; checkExpectedKind wc (mkTyVarTy wc_tv)
+                           (tyVarKind wc_tv) exp_kind }
+
+{- Note [Wildcards in visible kind application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are cases where users might want to pass in a wildcard as a visible kind
+argument, for instance:
+
+data T :: forall k1 k2. k1 → k2 → Type where
+  MkT :: T a b
+x :: T @_ @Nat False n
+x = MkT
+
+So we should allow '@_' without emitting any hole constraints, and
+regardless of whether PartialTypeSignatures is enabled or not. But how would
+the typechecker know which '_' is being used in VKA and which is not when it
+calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs?
+The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,
+but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc.
+And whenever we see a '@', we automatically turn on PartialTypeSignatures and
+turn off hole constraint warnings, and never call emitWildCardHoleConstraints
+under these conditions.
+See related Note [Wildcards in visible type application] here and
+Note [The wildcard story for types] in HsTypes.hs
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+                Tuples
+*                                                                      *
+********************************************************************* -}
+
+---------------------------
+tupKindSort_maybe :: TcKind -> Maybe TupleSort
+tupKindSort_maybe k
+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
+  | Just k'      <- tcView k            = tupKindSort_maybe k'
+  | tcIsConstraintKind k = Just ConstraintTuple
+  | tcIsLiftedTypeKind k   = Just BoxedTuple
+  | otherwise            = Nothing
+
+tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
+tc_tuple rn_ty mode tup_sort tys exp_kind
+  = do { arg_kinds <- case tup_sort of
+           BoxedTuple      -> return (replicate arity liftedTypeKind)
+           UnboxedTuple    -> replicateM arity newOpenTypeKind
+           ConstraintTuple -> return (replicate arity constraintKind)
+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }
+  where
+    arity   = length tys
+
+finish_tuple :: HsType GhcRn
+             -> TupleSort
+             -> [TcType]    -- ^ argument types
+             -> [TcKind]    -- ^ of these kinds
+             -> TcKind      -- ^ expected kind of the whole tuple
+             -> TcM TcType
+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind
+  = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
+       ; let arg_tys  = case tup_sort of
+                   -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
+                 UnboxedTuple    -> tau_reps ++ tau_tys
+                 BoxedTuple      -> tau_tys
+                 ConstraintTuple -> tau_tys
+       ; tycon <- case tup_sort of
+           ConstraintTuple
+             | arity > mAX_CTUPLE_SIZE
+                         -> failWith (bigConstraintTuple arity)
+             | otherwise -> tcLookupTyCon (cTupleTyConName arity)
+           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity
+                               ; checkWiredInTyCon tc
+                               ; return tc }
+           UnboxedTuple  -> return (tupleTyCon Unboxed arity)
+       ; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }
+  where
+    arity = length tau_tys
+    tau_reps = map kindRep tau_kinds
+    res_kind = case tup_sort of
+                 UnboxedTuple    -> unboxedTupleKind tau_reps
+                 BoxedTuple      -> liftedTypeKind
+                 ConstraintTuple -> constraintKind
+
+bigConstraintTuple :: Arity -> MsgDoc
+bigConstraintTuple arity
+  = hang (text "Constraint tuple arity too large:" <+> int arity
+          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
+       2 (text "Instead, use a nested tuple")
+
+
+{- *********************************************************************
+*                                                                      *
+                Type applications
+*                                                                      *
+********************************************************************* -}
+
+splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
+splitHsAppTys hs_ty
+  | is_app hs_ty = Just (go (noLoc hs_ty) [])
+  | otherwise    = Nothing
+  where
+    is_app :: HsType GhcRn -> Bool
+    is_app (HsAppKindTy {})        = True
+    is_app (HsAppTy {})            = True
+    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)
+      -- I'm not sure why this funTyConKey test is necessary
+      -- Can it even happen?  Perhaps for   t1 `(->)` t2
+      -- but then maybe it's ok to treat that like a normal
+      -- application rather than using the special rule for HsFunTy
+    is_app (HsTyVar {})            = True
+    is_app (HsParTy _ (L _ ty))    = is_app ty
+    is_app _                       = False
+
+    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)
+    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)
+    go (L sp (HsParTy _ f))        as = go f (HsArgPar sp : as)
+    go (L _  (HsOpTy _ l op@(L sp _) r)) as
+      = ( L sp (HsTyVar noExt NotPromoted op)
+        , HsValArg l : HsValArg r : as )
+    go f as = (f, as)
+
+---------------------------
+tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
+-- Version of tc_infer_lhs_type specialised for the head of an
+-- application. In particular, for a HsTyVar (which includes type
+-- constructors, it does not zoom off into tcInferApps and family
+-- saturation
+tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv)))
+  = tcTyVar mode tv
+tcInferAppHead mode ty
+  = tc_infer_lhs_type mode ty
+
+---------------------------
+-- | Apply a type of a given kind to a list of arguments. This instantiates
+-- invisible parameters as necessary. Always consumes all the arguments,
+-- using matchExpectedFunKind as necessary.
+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-
+-- These kinds should be used to instantiate invisible kind variables;
+-- they come from an enclosing class for an associated type/data family.
+--
+-- tcInferApps also arranges to saturate any trailing invisible arguments
+--   of a type-family application, which is usually the right thing to do
+-- tcInferApps_nosat does not do this saturation; it is used only
+--   by ":kind" in GHCi
+tcInferApps, tcInferApps_nosat
+    :: TcTyMode
+    -> LHsType GhcRn        -- ^ Function (for printing only)
+    -> TcType               -- ^ Function
+    -> [LHsTypeArg GhcRn]   -- ^ Args
+    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)
+tcInferApps mode hs_ty fun hs_args
+  = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args
+       ; saturateFamApp f_args res_k }
+
+tcInferApps_nosat mode orig_hs_ty fun orig_hs_args
+  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)
+       ; (f_args, res_k) <- go_init 1 fun orig_hs_args
+       ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k)
+       ; return (f_args, res_k) }
+  where
+
+    -- go_init just initialises the auxiliary
+    -- arguments of the 'go' loop
+    go_init n fun all_args
+      = go n fun empty_subst fun_ki all_args
+      where
+        fun_ki = tcTypeKind fun
+           -- We do (tcTypeKind fun) here, even though the caller
+           -- knows the function kind, to absolutely guarantee
+           -- INVARIANT for 'go'
+           -- Note that in a typical application (F t1 t2 t3),
+           -- the 'fun' is just a TyCon, so tcTypeKind is fast
+
+        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $
+                      tyCoVarsOfType fun_ki
+
+    go :: Int             -- The # of the next argument
+       -> TcType          -- Function applied to some args
+       -> TCvSubst        -- Applies to function kind
+       -> TcKind          -- Function kind
+       -> [LHsTypeArg GhcRn]    -- Un-type-checked args
+       -> TcM (TcType, TcKind)  -- Result type and its kind
+    -- INVARIANT: in any call (go n fun subst fun_ki args)
+    --               tcTypeKind fun  =  subst(fun_ki)
+    -- So the 'subst' and 'fun_ki' arguments are simply
+    -- there to avoid repeatedly calling tcTypeKind.
+    --
+    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant
+    -- it's important that if fun_ki has a forall, then so does
+    -- (tcTypeKind fun), because the next thing we are going to do
+    -- is apply 'fun' to an argument type.
+
+    -- Dispatch on all_args first, for performance reasons
+    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of
+
+      ---------------- No user-written args left. We're done!
+      ([], _) -> return (fun, substTy subst fun_ki)
+
+      ---------------- HsArgPar: We don't care about parens here
+      (HsArgPar _ : args, _) -> go n fun subst fun_ki args
+
+      ---------------- HsTypeArg: a kind application (fun @ki)
+      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->
+        case ki_binder of
+
+        -- FunTy with PredTy on LHS, or ForAllTy with Inferred
+        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki
+        Anon InvisArg _         -> instantiate ki_binder inner_ki
+
+        Named (Bndr _ Specified) ->  -- Visible kind application
+          do { traceTc "tcInferApps (vis kind app)"
+                       (vcat [ ppr ki_binder, ppr hs_ki_arg
+                             , ppr (tyBinderType ki_binder)
+                             , ppr subst ])
+
+             ; let exp_kind = substTy subst $ tyBinderType ki_binder
+
+             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $
+                         unsetWOptM Opt_WarnPartialTypeSignatures $
+                         setXOptM LangExt.PartialTypeSignatures $
+                             -- Urgh!  see Note [Wildcards in visible kind application]
+                             -- ToDo: must kill this ridiculous messing with DynFlags
+                         tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind
+
+             ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind)
+             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg
+             ; go (n+1) fun' subst' inner_ki hs_args }
+
+        -- Attempted visible kind application (fun @ki), but fun_ki is
+        --   forall k -> blah   or   k1 -> k2
+        -- So we need a normal application.  Error.
+        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki
+
+      -- No binder; try applying the substitution, or fail if that's not possible
+      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $
+                                           ty_app_err ki_arg substed_fun_ki
+
+      ---------------- HsValArg: a nomal argument (fun ty)
+      (HsValArg arg : args, Just (ki_binder, inner_ki))
+        -- next binder is invisible; need to instantiate it
+        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;
+                                        -- or ForAllTy with Inferred or Specified
+         -> instantiate ki_binder inner_ki
+
+        -- "normal" case
+        | otherwise
+         -> do { traceTc "tcInferApps (vis normal app)"
+                          (vcat [ ppr ki_binder
+                                , ppr arg
+                                , ppr (tyBinderType ki_binder)
+                                , ppr subst ])
+                ; let exp_kind = substTy subst $ tyBinderType ki_binder
+                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $
+                          tc_lhs_type mode arg exp_kind
+                ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind)
+                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'
+                ; go (n+1) fun' subst' inner_ki args }
+
+          -- no binder; try applying the substitution, or infer another arrow in fun kind
+      (HsValArg _ : _, Nothing)
+        -> try_again_after_substing_or $
+           do { let arrows_needed = n_initial_val_args all_args
+              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki
+
+              ; fun' <- zonkTcType (fun `mkTcCastTy` co)
+                     -- This zonk is essential, to expose the fruits
+                     -- of matchExpectedFunKind to the 'go' loop
+
+              ; traceTc "tcInferApps (no binder)" $
+                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki
+                        , ppr arrows_needed
+                        , ppr co
+                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]
+              ; go_init n fun' all_args }
+                -- Use go_init to establish go's INVARIANT
+      where
+        instantiate ki_binder inner_ki
+          = do { traceTc "tcInferApps (need to instantiate)"
+                         (vcat [ ppr ki_binder, ppr subst])
+               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder
+               ; go n (mkAppTy fun arg') subst' inner_ki all_args }
+                 -- Because tcInvisibleTyBinder instantiate ki_binder,
+                 -- the kind of arg' will have the same shape as the kind
+                 -- of ki_binder.  So we don't need mkAppTyM here.
+
+        try_again_after_substing_or fallthrough
+          | not (isEmptyTCvSubst subst)
+          = go n fun zapped_subst substed_fun_ki all_args
+          | otherwise
+          = fallthrough
+
+        zapped_subst   = zapTCvSubst subst
+        substed_fun_ki = substTy subst fun_ki
+        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)
+
+    n_initial_val_args :: [HsArg tm ty] -> Arity
+    -- Count how many leading HsValArgs we have
+    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args
+    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args
+    n_initial_val_args _                    = 0
+
+    ty_app_err arg ty
+      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)
+                $$ text "to visible kind argument" <+> quotes (ppr arg)
+
+
+mkAppTyM :: TCvSubst
+         -> TcType -> TyCoBinder    -- fun, plus its top-level binder
+         -> TcType                  -- arg
+         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)
+-- Precondition: the application (fun arg) is well-kinded after zonking
+--               That is, the application makes sense
+--
+-- Precondition: for (mkAppTyM subst fun bndr arg)
+--       tcTypeKind fun  =  Pi bndr. body
+--  That is, fun always has a ForAllTy or FunTy at the top
+--           and 'bndr' is fun's pi-binder
+--
+-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type
+--                invariant, then so does the result type (fun arg)
+--
+-- We do not require that
+--    tcTypeKind arg = tyVarKind (binderVar bndr)
+-- This must be true after zonking (precondition 1), but it's not
+-- required for the (PKTI).
+mkAppTyM subst fun ki_binder arg
+  | -- See Note [mkAppTyM]: Nasty case 2
+    TyConApp tc args <- fun
+  , isTypeSynonymTyCon tc
+  , args `lengthIs` (tyConArity tc - 1)
+  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym
+  = do { arg'  <- zonkTcType  arg
+       ; args' <- zonkTcTypes args
+       ; let subst' = case ki_binder of
+                        Anon {}           -> subst
+                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'
+       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }
+
+
+mkAppTyM subst fun (Anon {}) arg
+   = return (subst, mk_app_ty fun arg)
+
+mkAppTyM subst fun (Named (Bndr tv _)) arg
+  = do { arg' <- if isTrickyTvBinder tv
+                 then -- See Note [mkAppTyM]: Nasty case 1
+                      zonkTcType arg
+                 else return     arg
+       ; return ( extendTvSubstAndInScope subst tv arg'
+                , mk_app_ty fun arg' ) }
+
+mk_app_ty :: TcType -> TcType -> TcType
+-- This function just adds an ASSERT for mkAppTyM's precondition
+mk_app_ty fun arg
+  = ASSERT2( isPiTy fun_kind
+           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )
+    mkAppTy fun arg
+  where
+    fun_kind = tcTypeKind fun
+
+isTrickyTvBinder :: TcTyVar -> Bool
+-- NB: isTrickyTvBinder is just an optimisation
+-- It would be absolutely sound to return True always
+isTrickyTvBinder tv = isPiTy (tyVarKind tv)
+
+{- Note [The Purely Kinded Type Invariant (PKTI)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+During type inference, we maintain this invariant
+
+ (PKTI) It is legal to call 'tcTypeKind' on any Type ty,
+        on any sub-term of ty, /without/ zonking ty
+
+        Moreover, any such returned kind
+        will itself satisfy (PKTI)
+
+By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".
+The way in which tcTypeKind can crash is in applications
+    (a t1 t2 .. tn)
+if 'a' is a type variable whose kind doesn't have enough arrows
+or foralls.  (The crash is in piResultTys.)
+
+The loop in tcInferApps has to be very careful to maintain the (PKTI).
+For example, suppose
+    kappa is a unification variable
+    We have already unified kappa := Type
+      yielding    co :: Refl (Type -> Type)
+    a :: kappa
+then consider the type
+    (a Int)
+If we call tcTypeKind on that, we'll crash, because the (un-zonked)
+kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.
+
+So the type inference engine is very careful when building applications.
+This happens in tcInferApps. Suppose we are kind-checking the type (a Int),
+where (a :: kappa).  Then in tcInferApps we'll run out of binders on
+a's kind, so we'll call matchExpectedFunKind, and unify
+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)
+At this point we must zonk the function type to expose the arrrow, so
+that (a Int) will satisfy (PKTI).
+
+The absence of this caused #14174 and #14520.
+
+The calls to mkAppTyM is the other place we are very careful.
+
+Note [mkAppTyM]
+~~~~~~~~~~~~~~~
+mkAppTyM is trying to guaranteed the Purely Kinded Type Invariant
+(PKTI) for its result type (fun arg).  There are two ways it can go wrong:
+
+* Nasty case 1: forall types (polykinds/T14174a)
+    T :: forall (p :: *->*). p Int -> p Bool
+  Now kind-check (T x), where x::kappa.
+  Well, T and x both satisfy the PKTI, but
+     T x :: x Int -> x Bool
+  and (x Int) does /not/ satisfy the PKTI.
+
+* Nasty case 2: type synonyms
+    type S f a = f a
+  Even though (S ff aa) would satisfy the (PKTI) if S was a data type
+  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)
+  if S is a type synonym, because the /expansion/ of (S ff aa) is
+  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps
+  (ff :: kappa), where 'kappa' has already been unified with (*->*).
+
+  We check for nasty case 2 on the final argument of a type synonym.
+
+Notice that in both cases the trickiness only happens if the
+bound variable has a pi-type.  Hence isTrickyTvBinder.
+-}
+
+
+saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)
+-- Precondition for (saturateFamApp ty kind):
+--     tcTypeKind ty = kind
+--
+-- If 'ty' is an unsaturated family application wtih trailing
+-- invisible arguments, instanttiate them.
+-- See Note [saturateFamApp]
+
+saturateFamApp ty kind
+  | Just (tc, args) <- tcSplitTyConApp_maybe ty
+  , mustBeSaturated tc
+  , let n_to_inst = tyConArity tc - length args
+  = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind
+       ; return (ty `mkTcAppTys` extra_args, ki') }
+  | otherwise
+  = return (ty, kind)
+
+{- Note [saturateFamApp]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   type family F :: Either j k
+   type instance F @Type = Right Maybe
+   type instance F @Type = Right Either```
+
+Then F :: forall {j,k}. Either j k
+
+The two type instances do a visible kind application that instantiates
+'j' but not 'k'.  But we want to end up with instances that look like
+  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe
+
+so that F has arity 2.  We must instantiate that trailing invisible
+binder. In general, Invisible binders precede Specified and Required,
+so this is only going to bite for apparently-nullary families.
+
+Note that
+  type family F2 :: forall k. k -> *
+is quite different and really does have arity 0.
+
+It's not just type instances where we need to saturate those
+unsaturated arguments: see #11246.  Hence doing this in tcInferApps.
+-}
+
+appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
+appTypeToArg f []                       = f
+appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args
+appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args
+appTypeToArg f (HsTypeArg l arg : args)
+  = appTypeToArg (mkHsAppKindTy l f arg) args
+
+
+{- *********************************************************************
+*                                                                      *
+                checkExpectedKind
+*                                                                      *
+********************************************************************* -}
+
+-- | This instantiates invisible arguments for the type being checked if it must
+-- be saturated and is not yet saturated. It then calls and uses the result
+-- from checkExpectedKindX to build the final type
+checkExpectedKind :: HasDebugCallStack
+                  => HsType GhcRn       -- ^ type we're checking (for printing)
+                  -> TcType             -- ^ type we're checking
+                  -> TcKind             -- ^ the known kind of that type
+                  -> TcKind             -- ^ the expected kind
+                  -> TcM TcType
+-- Just a convenience wrapper to save calls to 'ppr'
+checkExpectedKind hs_ty ty act exp
+  = checkExpectedKind_pp (ppr hs_ty) ty act exp
+
+checkExpectedKind_pp :: HasDebugCallStack
+                     => SDoc               -- ^ The thing we are checking
+                     -> TcType             -- ^ type we're checking
+                     -> TcKind             -- ^ the known kind of that type
+                     -> TcKind             -- ^ the expected kind
+                     -> TcM TcType
+checkExpectedKind_pp pp_hs_ty ty act_kind exp_kind
+  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)
+
+       ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind
+
+       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
+                                   , uo_expected = exp_kind
+                                   , uo_thing    = Just pp_hs_ty
+                                   , uo_visible  = True } -- the hs_ty is visible
+
+       ; traceTc "checkExpectedKindX" $
+         vcat [ pp_hs_ty
+              , text "act_kind':" <+> ppr act_kind'
+              , text "exp_kind:" <+> ppr exp_kind ]
+
+       ; let res_ty = ty `mkTcAppTys` new_args
+
+       ; if act_kind' `tcEqType` exp_kind
+         then return res_ty  -- This is very common
+         else do { co_k <- uType KindLevel origin act_kind' exp_kind
+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
+                                                     , ppr exp_kind
+                                                     , ppr co_k ])
+                ; return (res_ty `mkTcCastTy` co_k) } }
+    where
+      -- We need to make sure that both kinds have the same number of implicit
+      -- foralls out front. If the actual kind has more, instantiate accordingly.
+      -- Otherwise, just pass the type & kind through: the errors are caught
+      -- in unifyType.
+      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
+      n_act_invis_bndrs = invisibleTyBndrCount act_kind
+      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs
+
+
+---------------------------
+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
+tcHsMbContext Nothing    = return []
+tcHsMbContext (Just cxt) = tcHsContext cxt
+
+tcHsContext :: LHsContext GhcRn -> TcM [PredType]
+tcHsContext = tc_hs_context typeLevelMode
+
+tcLHsPredType :: LHsType GhcRn -> TcM PredType
+tcLHsPredType = tc_lhs_pred typeLevelMode
+
+tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)
+
+tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType
+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind
+
+---------------------------
+tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)
+-- See Note [Type checking recursive type and class declarations]
+-- in TcTyClsDecls
+tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
+  = do { traceTc "lk1" (ppr name)
+       ; thing <- tcLookup name
+       ; case thing of
+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
+
+           ATcTyCon tc_tc
+             -> do { -- See Note [GADT kind self-reference]
+                     unless (isTypeLevel (mode_level mode))
+                            (promotionErr name TyConPE)
+                   ; check_tc tc_tc
+                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }
+
+           AGlobal (ATyCon tc)
+             -> do { check_tc tc
+                   ; return (mkTyConTy tc, tyConKind tc) }
+
+           AGlobal (AConLike (RealDataCon dc))
+             -> do { data_kinds <- xoptM LangExt.DataKinds
+                   ; unless (data_kinds || specialPromotedDc dc) $
+                       promotionErr name NoDataKindsDC
+                   ; when (isFamInstTyCon (dataConTyCon dc)) $
+                       -- see #15245
+                       promotionErr name FamDataConPE
+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc
+                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))
+                   ; case dc_theta_illegal_constraint theta of
+                       Just pred -> promotionErr name $
+                                    ConstrainedDataConPE pred
+                       Nothing   -> pure ()
+                   ; let tc = promoteDataCon dc
+                   ; return (mkTyConApp tc [], tyConKind tc) }
+
+           APromotionErr err -> promotionErr name err
+
+           _  -> wrongThingErr "type" thing name }
+  where
+    check_tc :: TyCon -> TcM ()
+    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds
+                     ; unless (isTypeLevel (mode_level mode) ||
+                               data_kinds ||
+                               isKindTyCon tc) $
+                       promotionErr name NoDataKindsTC }
+
+    -- We cannot promote a data constructor with a context that contains
+    -- constraints other than equalities, so error if we find one.
+    -- See Note [Constraints in kinds] in TyCoRep
+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType
+    dc_theta_illegal_constraint = find (not . isEqPred)
+
+{-
+Note [GADT kind self-reference]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A promoted type cannot be used in the body of that type's declaration.
+#11554 shows this example, which made GHC loop:
+
+  import Data.Kind
+  data P (x :: k) = Q
+  data A :: Type where
+    B :: forall (a :: A). P a -> A
+
+In order to check the constructor B, we need to have the promoted type A, but in
+order to get that promoted type, B must first be checked. To prevent looping, a
+TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.
+Any ATcTyCon is a TyCon being defined in the current recursive group (see data
+type decl for TcTyThing), and all such TyCons are illegal in kinds.
+
+#11962 proposes checking the head of a data declaration separately from
+its constructors. This would allow the example above to pass.
+
+Note [Body kind of a HsForAllTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The body of a forall is usually a type, but in principle
+there's no reason to prohibit *unlifted* types.
+In fact, GHC can itself construct a function with an
+unboxed tuple inside a for-all (via CPR analysis; see
+typecheck/should_compile/tc170).
+
+Moreover in instance heads we get forall-types with
+kind Constraint.
+
+It's tempting to check that the body kind is either * or #. But this is
+wrong. For example:
+
+  class C a b
+  newtype N = Mk Foo deriving (C a)
+
+We're doing newtype-deriving for C. But notice how `a` isn't in scope in
+the predicate `C a`. So we quantify, yielding `forall a. C a` even though
+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but
+convenient. Bottom line: don't check for * or # here.
+
+Note [Body kind of a HsQualTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If ctxt is non-empty, the HsQualTy really is a /function/, so the
+kind of the result really is '*', and in that case the kind of the
+body-type can be lifted or unlifted.
+
+However, consider
+    instance Eq a => Eq [a] where ...
+or
+    f :: (Eq a => Eq [a]) => blah
+Here both body-kind of the HsQualTy is Constraint rather than *.
+Rather crudely we tell the difference by looking at exp_kind. It's
+very convenient to typecheck instance types like any other HsSigType.
+
+Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's
+better to reject in checkValidType.  If we say that the body kind
+should be '*' we risk getting TWO error messages, one saying that Eq
+[a] doens't have kind '*', and one saying that we need a Constraint to
+the left of the outer (=>).
+
+How do we figure out the right body kind?  Well, it's a bit of a
+kludge: I just look at the expected kind.  If it's Constraint, we
+must be in this instance situation context. It's a kludge because it
+wouldn't work if any unification was involved to compute that result
+kind -- but it isn't.  (The true way might be to use the 'mode'
+parameter, but that seemed like a sledgehammer to crack a nut.)
+
+Note [Inferring tuple kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,
+we try to figure out whether it's a tuple of kind * or Constraint.
+  Step 1: look at the expected kind
+  Step 2: infer argument kinds
+
+If after Step 2 it's not clear from the arguments that it's
+Constraint, then it must be *.  Once having decided that we re-check
+the arguments to give good error messages in
+  e.g.  (Maybe, Maybe)
+
+Note that we will still fail to infer the correct kind in this case:
+
+  type T a = ((a,a), D a)
+  type family D :: Constraint -> Constraint
+
+While kind checking T, we do not yet know the kind of D, so we will default the
+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
+
+Note [Desugaring types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:
+
+  * It transforms from HsType to Type
+
+  * It zonks any kinds.  The returned type should have no mutable kind
+    or type variables (hence returning Type not TcType):
+      - any unconstrained kind variables are defaulted to (Any *) just
+        as in TcHsSyn.
+      - there are no mutable type variables because we are
+        kind-checking a type
+    Reason: the returned type may be put in a TyCon or DataCon where
+    it will never subsequently be zonked.
+
+You might worry about nested scopes:
+        ..a:kappa in scope..
+            let f :: forall b. T '[a,b] -> Int
+In this case, f's type could have a mutable kind variable kappa in it;
+and we might then default it to (Any *) when dealing with f's type
+signature.  But we don't expect this to happen because we can't get a
+lexically scoped type variable with a mutable kind variable in it.  A
+delicate point, this.  If it becomes an issue we might need to
+distinguish top-level from nested uses.
+
+Moreover
+  * it cannot fail,
+  * it does no unifications
+  * it does no validity checking, except for structural matters, such as
+        (a) spurious ! annotations.
+        (b) a class used as a type
+
+Note [Kind of a type splice]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these terms, each with TH type splice inside:
+     [| e1 :: Maybe $(..blah..) |]
+     [| e2 :: $(..blah..) |]
+When kind-checking the type signature, we'll kind-check the splice
+$(..blah..); we want to give it a kind that can fit in any context,
+as if $(..blah..) :: forall k. k.
+
+In the e1 example, the context of the splice fixes kappa to *.  But
+in the e2 example, we'll desugar the type, zonking the kind unification
+variables as we go.  When we encounter the unconstrained kappa, we
+want to default it to '*', not to (Any *).
+
+Help functions for type applications
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+
+addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
+        -- Wrap a context around only if we want to show that contexts.
+        -- Omit invisible ones and ones user's won't grok
+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.
+addTypeCtxt (L _ ty) thing
+  = addErrCtxt doc thing
+  where
+    doc = text "In the type" <+> quotes (ppr ty)
+
+{-
+************************************************************************
+*                                                                      *
+                Type-variable binders
+%*                                                                      *
+%************************************************************************
+
+Note [Keeping scoped variables in order: Explicit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user writes `forall a b c. blah`, we bring a, b, and c into
+scope and then check blah. In the process of checking blah, we might
+learn the kinds of a, b, and c, and these kinds might indicate that
+b depends on c, and thus that we should reject the user-written type.
+
+One approach to doing this would be to bring each of a, b, and c into
+scope, one at a time, creating an implication constraint and
+bumping the TcLevel for each one. This would work, because the kind
+of, say, b would be untouchable when c is in scope (and the constraint
+couldn't float out because c blocks it). However, it leads to terrible
+error messages, complaining about skolem escape. While it is indeed
+a problem of skolem escape, we can do better.
+
+Instead, our approach is to bring the block of variables into scope
+all at once, creating one implication constraint for the lot. The
+user-written variables are skolems in the implication constraint. In
+TcSimplify.setImplicationStatus, we check to make sure that the ordering
+is correct, choosing ImplicationStatus IC_BadTelescope if they aren't.
+Then, in TcErrors, we report if there is a bad telescope. This way,
+we can report a suggested ordering to the user if there is a problem.
+
+Note [Keeping scoped variables in order: Implicit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user implicitly quantifies over variables (say, in a type
+signature), we need to come up with some ordering on these variables.
+This is done by bumping the TcLevel, bringing the tyvars into scope,
+and then type-checking the thing_inside. The constraints are all
+wrapped in an implication, which is then solved. Finally, we can
+zonk all the binders and then order them with scopedSort.
+
+It's critical to solve before zonking and ordering in order to uncover
+any unifications. You might worry that this eager solving could cause
+trouble elsewhere. I don't think it will. Because it will solve only
+in an increased TcLevel, it can't unify anything that was mentioned
+elsewhere. Additionally, we require that the order of implicitly
+quantified variables is manifest by the scope of these variables, so
+we're not going to learn more information later that will help order
+these variables.
+
+Note [Recipe for checking a signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Checking a user-written signature requires several steps:
+
+ 1. Generate constraints.
+ 2. Solve constraints.
+ 3. Zonk.
+ 4. Promote tyvars and/or kind-generalize.
+ 5. Zonk.
+ 6. Check validity.
+
+There may be some surprises in here:
+
+Step 2 is necessary for two reasons: most signatures also bring
+implicitly quantified variables into scope, and solving is necessary
+to get these in the right order (see Note [Keeping scoped variables in
+order: Implicit]). Additionally, solving is necessary in order to
+kind-generalize correctly.
+
+In Step 4, we have to deal with the fact that metatyvars generated
+in the type may have a bumped TcLevel, because explicit foralls
+raise the TcLevel. To avoid these variables from ever being visible
+in the surrounding context, we must obey the following dictum:
+
+  Every metavariable in a type must either be
+    (A) promoted
+    (B) generalized, or
+    (C) zapped to Any
+
+If a variable is generalized, then it becomes a skolem and no longer
+has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as
+it's not really in play here.) On the other hand, if it is not
+generalized (because we're not generalizing the construct -- e.g., pattern
+sig -- or because the metavars are constrained -- see kindGeneralizeLocal)
+we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]
+in TcType.
+
+For more about (C), see Note [Naughty quantification candidates] in TcMType.
+
+After promoting/generalizing, we need to zonk *again* because both
+promoting and generalizing fill in metavariables.
+
+To avoid the double-zonk, we do two things:
+ 1. When we're not generalizing:
+    zonkPromoteType and friends zonk and promote at the same time.
+    Accordingly, the function does steps 3-5 all at once, preventing
+    the need for multiple traversals.
+
+ 2. When we are generalizing:
+    kindGeneralize does not require a zonked type -- it zonks as it
+    gathers free variables. So this way effectively sidesteps step 3.
+-}
+
+tcWildCardBinders :: [Name]
+                  -> ([(Name, TcTyVar)] -> TcM a)
+                  -> TcM a
+tcWildCardBinders wc_names thing_inside
+  = do { wcs <- mapM (const newWildTyVar) wc_names
+       ; let wc_prs = wc_names `zip` wcs
+       ; tcExtendNameTyVarEnv wc_prs $
+         thing_inside wc_prs }
+
+newWildTyVar :: TcM TcTyVar
+-- ^ New unification variable for a wildcard
+newWildTyVar
+  = do { kind <- newMetaKindVar
+       ; uniq <- newUnique
+       ; details <- newMetaDetails TauTv
+       ; let name = mkSysTvName uniq (fsLit "_")
+             tyvar = (mkTcTyVar name kind details)
+       ; traceTc "newWildTyVar" (ppr tyvar)
+       ; return tyvar }
+
+{- *********************************************************************
+*                                                                      *
+             Kind inference for type declarations
+*                                                                      *
+********************************************************************* -}
+
+{- Note [The initial kind of a type constructor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+kcLHsQTyVars is responsible for getting the initial kind of
+a type constructor.
+
+It has two cases:
+
+ * The TyCon has a CUSK.  In that case, find the full, final,
+   poly-kinded kind of the TyCon.  It's very like a term-level
+   binding where we have a complete type signature for the
+   function.
+
+ * It does not have a CUSK.  Find a monomorphic kind, with
+   unification variables in it; they will be generalised later.
+   It's very like a term-level binding where we do not have
+   a type signature (or, more accurately, where we have a
+   partial type signature), so we infer the type and generalise.
+-}
+
+
+------------------------------
+-- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,
+-- user-supplied kind signature (CUSK), generalise the result.
+-- Used in 'getInitialKind' (for tycon kinds and other kinds)
+-- and in kind-checking (but not for tycon kinds, which are checked with
+-- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures]
+-- in HsDecls.
+--
+-- This function does not do telescope checking.
+kcLHsQTyVars :: Name              -- ^ of the thing being checked
+             -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+             -> Bool              -- ^ True <=> the decl being checked has a CUSK
+             -> LHsQTyVars GhcRn
+             -> TcM Kind          -- ^ The result kind
+             -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+kcLHsQTyVars name flav cusk tvs thing_inside
+  | cusk      = kcLHsQTyVars_Cusk    name flav tvs thing_inside
+  | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside
+
+
+kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk
+    :: Name              -- ^ of the thing being checked
+    -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+    -> LHsQTyVars GhcRn
+    -> TcM Kind          -- ^ The result kind
+    -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+
+------------------------------
+kcLHsQTyVars_Cusk name flav
+              (HsQTvs { hsq_ext = kv_ns
+                      , hsq_explicit = hs_tvs }) thing_inside
+  -- CUSK case
+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
+  = addTyConFlavCtxt name flav $
+    do { (scoped_kvs, (tc_tvs, res_kind))
+           <- pushTcLevelM_                               $
+              solveEqualities                             $
+              bindImplicitTKBndrs_Q_Skol kv_ns            $
+              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $
+              thing_inside
+
+           -- Now, because we're in a CUSK,
+           -- we quantify over the mentioned kind vars
+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs
+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs
+
+       ; candidates <- candidateQTyVarsOfKinds all_kinds
+             -- 'candidates' are all the variables that we are going to
+             -- skolemise and then quantify over.  We do not include spec_req_tvs
+             -- because they are /already/ skolems
+
+       ; let inf_candidates = candidates `delCandidates` spec_req_tkvs
+
+       ; inferred <- quantifyTyVars emptyVarSet inf_candidates
+                     -- NB: 'inferred' comes back sorted in dependency order
+
+       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs
+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs
+       ; res_kind   <- zonkTcType           res_kind
+
+       ; let mentioned_kv_set = candidateKindVars candidates
+             specified        = scopedSort scoped_kvs
+                                -- NB: maintain the L-R order of scoped_kvs
+
+             final_tc_binders =  mkNamedTyConBinders Inferred  inferred
+                              ++ mkNamedTyConBinders Specified specified
+                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs
+
+             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
+             tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs
+                               True {- it is generalised -} flav
+         -- If the ordering from
+         -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls
+         -- doesn't work, we catch it here, before an error cascade
+       ; checkTyConTelescope tycon
+
+       ; traceTc "kcLHsQTyVars: cusk" $
+         vcat [ text "name" <+> ppr name
+              , text "kv_ns" <+> ppr kv_ns
+              , text "hs_tvs" <+> ppr hs_tvs
+              , text "scoped_kvs" <+> ppr scoped_kvs
+              , text "tc_tvs" <+> ppr tc_tvs
+              , text "res_kind" <+> ppr res_kind
+              , text "candidates" <+> ppr candidates
+              , text "inferred" <+> ppr inferred
+              , text "specified" <+> ppr specified
+              , text "final_tc_binders" <+> ppr final_tc_binders
+              , text "mkTyConKind final_tc_bndrs res_kind"
+                <+> ppr (mkTyConKind final_tc_binders res_kind)
+              , text "all_tv_prs" <+> ppr all_tv_prs ]
+
+       ; return tycon }
+  where
+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
+              | otherwise            = AnyKind
+
+kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
+------------------------------
+kcLHsQTyVars_NonCusk name flav
+              (HsQTvs { hsq_ext = kv_ns
+                      , hsq_explicit = hs_tvs }) thing_inside
+  -- Non_CUSK case
+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
+  = do { (scoped_kvs, (tc_tvs, res_kind))
+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?
+           -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $
+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $
+              thing_inside
+              -- Why "_Tv" not "_Skol"? See third wrinkle in
+              -- Note [Inferring kinds for type declarations] in TcTyClsDecls,
+
+       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they
+               -- might unify with kind vars in other types in a mutually
+               -- recursive group.
+               -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+
+             tc_binders = mkAnonTyConBinders VisArg tc_tvs
+               -- Also, note that tc_binders has the tyvars from only the
+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]
+               -- in TcTyClsDecls
+               --
+               -- mkAnonTyConBinder: see Note [No polymorphic recursion]
+
+             all_tv_prs = (kv_ns                `zip` scoped_kvs) ++
+                          (hsLTyVarNames hs_tvs `zip` tc_tvs)
+               -- NB: bindIplicitTKBndrs_Q_Tv makes /freshly-named/ unification
+               --     variables, hence the need to zip here.  Ditto bindExplicit..
+               -- See TcMType Note [Unification variables need fresh Names]
+
+             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs
+                               False -- not yet generalised
+                               flav
+
+       ; traceTc "kcLHsQTyVars: not-cusk" $
+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs
+              , ppr scoped_kvs
+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]
+       ; return tycon }
+  where
+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
+              | otherwise            = AnyKind
+
+kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
+
+{- Note [No polymorphic recursion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Should this kind-check?
+  data T ka (a::ka) b  = MkT (T Type           Int   Bool)
+                             (T (Type -> Type) Maybe Bool)
+
+Notice that T is used at two different kinds in its RHS.  No!
+This should not kind-check.  Polymorphic recursion is known to
+be a tough nut.
+
+Previously, we laboriously (with help from the renamer)
+tried to give T the polymoprhic kind
+   T :: forall ka -> ka -> kappa -> Type
+where kappa is a unification variable, even in the getInitialKinds
+phase (which is what kcLHsQTyVars_NonCusk is all about).  But
+that is dangerously fragile (see the ticket).
+
+Solution: make kcLHsQTyVars_NonCusk give T a straightforward
+monomorphic kind, with no quantification whatsoever. That's why
+we use mkAnonTyConBinder for all arguments when figuring out
+tc_binders.
+
+But notice that (#16322 comment:3)
+
+* The algorithm successfully kind-checks this declaration:
+    data T2 ka (a::ka) = MkT2 (T2 Type a)
+
+  Starting with (getInitialKinds)
+    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *
+  we get
+    kappa4 := kappa1   -- from the (a:ka) kind signature
+    kappa1 := Type     -- From application T2 Type
+
+  These constraints are soluble so generaliseTcTyCon gives
+    T2 :: forall (k::Type) -> k -> *
+
+  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase
+  fails, because the call (T2 Type a) in the RHS is ill-kinded.
+
+  We'd really prefer all errors to show up in the kind checking
+  phase.
+
+* This algorithm still accepts (in all phases)
+     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)
+  although T3 is really polymorphic-recursive too.
+  Perhaps we should somehow reject that.
+
+Note [Kind-checking tyvar binders for associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When kind-checking the type-variable binders for associated
+   data/newtype decls
+   family decls
+we behave specially for type variables that are already in scope;
+that is, bound by the enclosing class decl.  This is done in
+kcLHsQTyVarBndrs:
+  * The use of tcImplicitQTKBndrs
+  * The tcLookupLocal_maybe code in kc_hs_tv
+
+See Note [Associated type tyvar names] in Class and
+    Note [TyVar binders for associated decls] in HsDecls
+
+We must do the same for family instance decls, where the in-scope
+variables may be bound by the enclosing class instance decl.
+Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.
+
+Note [Kind variable ordering for associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should be the kind of `T` in the following example? (#15591)
+
+  class C (a :: Type) where
+    type T (x :: f a)
+
+As per Note [Ordering of implicit variables] in RnTypes, we want to quantify
+the kind variables in left-to-right order of first occurrence in order to
+support visible kind application. But we cannot perform this analysis on just
+T alone, since its variable `a` actually occurs /before/ `f` if you consider
+the fact that `a` was previously bound by the parent class `C`. That is to say,
+the kind of `T` should end up being:
+
+  T :: forall a f. f a -> Type
+
+(It wouldn't necessarily be /wrong/ if the kind ended up being, say,
+forall f a. f a -> Type, but that would not be as predictable for users of
+visible kind application.)
+
+In contrast, if `T` were redefined to be a top-level type family, like `T2`
+below:
+
+  type family T2 (x :: f (a :: Type))
+
+Then `a` first appears /after/ `f`, so the kind of `T2` should be:
+
+  T2 :: forall f a. f a -> Type
+
+In order to make this distinction, we need to know (in kcLHsQTyVars) which
+type variables have been bound by the parent class (if there is one). With
+the class-bound variables in hand, we can ensure that we always quantify
+these first.
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+             Expected kinds
+*                                                                      *
+********************************************************************* -}
+
+-- | Describes the kind expected in a certain context.
+data ContextKind = TheKind Kind   -- ^ a specific kind
+                 | AnyKind        -- ^ any kind will do
+                 | OpenKind       -- ^ something of the form @TYPE _@
+
+-----------------------
+newExpectedKind :: ContextKind -> TcM Kind
+newExpectedKind (TheKind k) = return k
+newExpectedKind AnyKind     = newMetaKindVar
+newExpectedKind OpenKind    = newOpenTypeKind
+
+-----------------------
+expectedKindInCtxt :: UserTypeCtxt -> ContextKind
+-- Depending on the context, we might accept any kind (for instance, in a TH
+-- splice), or only certain kinds (like in type signatures).
+expectedKindInCtxt (TySynCtxt _)   = AnyKind
+expectedKindInCtxt ThBrackCtxt     = AnyKind
+expectedKindInCtxt (GhciCtxt {})   = AnyKind
+-- The types in a 'default' decl can have varying kinds
+-- See Note [Extended defaults]" in TcEnv
+expectedKindInCtxt DefaultDeclCtxt     = AnyKind
+expectedKindInCtxt TypeAppCtxt         = AnyKind
+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind
+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind
+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind
+expectedKindInCtxt _                   = OpenKind
+
+
+{- *********************************************************************
+*                                                                      *
+             Bringing type variables into scope
+*                                                                      *
+********************************************************************* -}
+
+--------------------------------------
+-- Implicit binders
+--------------------------------------
+
+bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
+  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
+  :: [Name] -> TcM a -> TcM ([TcTyVar], a)
+bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar
+bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar
+bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)
+bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)
+
+bindImplicitTKBndrsX
+   :: (Name -> TcM TcTyVar) -- new_tv function
+   -> [Name]
+   -> TcM a
+   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence
+                           -- with the passed in [Name]
+bindImplicitTKBndrsX new_tv tv_names thing_inside
+  = do { tkvs <- mapM new_tv tv_names
+       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)
+       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)
+                thing_inside
+       ; return (tkvs, res) }
+
+newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar
+-- Behave like new_tv, except that if the tyvar is in scope, use it
+newImplicitTyVarQ new_tv name
+  = do { mb_tv <- tcLookupLcl_maybe name
+       ; case mb_tv of
+           Just (ATyVar _ tv) -> return tv
+           _ -> new_tv name }
+
+newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar
+newFlexiKindedTyVar new_tv name
+  = do { kind <- newMetaKindVar
+       ; new_tv name kind }
+
+newFlexiKindedSkolemTyVar :: Name -> TcM TyVar
+newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar
+
+newFlexiKindedTyVarTyVar :: Name -> TcM TyVar
+newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar
+   -- See Note [Unification variables need fresh Names] in TcMType
+
+--------------------------------------
+-- Explicit binders
+--------------------------------------
+
+bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
+    :: [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
+
+bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)
+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)
+
+bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
+    :: ContextKind
+    -> [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
+
+bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)
+bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)
+
+-- | Used during the "kind-checking" pass in TcTyClsDecls only,
+-- and even then only for data-con declarations.
+bindExplicitTKBndrsX
+    :: (HsTyVarBndr GhcRn -> TcM TcTyVar)
+    -> [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)  -- Returned [TcTyVar] are in 1-1 correspondence
+                           -- with the passed-in [LHsTyVarBndr]
+bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
+  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)
+       ; go hs_tvs }
+  where
+    go [] = do { res <- thing_inside
+               ; return ([], res) }
+    go (L _ hs_tv : hs_tvs)
+       = do { tv <- tc_tv hs_tv
+            -- Extend the environment as we go, in case a binder
+            -- is mentioned in the kind of a later binder
+            --   e.g. forall k (a::k). blah
+            -- NB: tv's Name may differ from hs_tv's
+            -- See TcMType Note [Unification variables need fresh Names]
+            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $
+                           go hs_tvs
+            ; return (tv:tvs, res) }
+
+-----------------
+tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
+              -> HsTyVarBndr GhcRn -> TcM TcTyVar
+-- Returned TcTyVar has the same name; no cloning
+tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))
+  = do { kind <- newMetaKindVar
+       ; new_tv tv_nm kind }
+tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
+       ; new_tv tv_nm kind }
+tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
+
+-----------------
+tcHsQTyVarBndr :: ContextKind
+               -> (Name -> Kind -> TcM TyVar)
+               -> HsTyVarBndr GhcRn -> TcM TcTyVar
+-- Just like tcHsTyVarBndr, but also
+--   - uses the in-scope TyVar from class, if it exists
+--   - takes a ContextKind to use for the no-sig case
+tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm))
+  = do { mb_tv <- tcLookupLcl_maybe tv_nm
+       ; case mb_tv of
+           Just (ATyVar _ tv) -> return tv
+           _ -> do { kind <- newExpectedKind ctxt_kind
+                   ; new_tv tv_nm kind } }
+
+tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
+       ; mb_tv <- tcLookupLcl_maybe tv_nm
+       ; case mb_tv of
+           Just (ATyVar _ tv)
+             -> do { discardResult $ unifyKind (Just hs_tv)
+                                        kind (tyVarKind tv)
+                       -- This unify rejects:
+                       --    class C (m :: * -> *) where
+                       --      type F (m :: *) = ...
+                   ; return tv }
+
+           _ -> new_tv tv_nm kind }
+  where
+    hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm)
+            -- Used for error messages only
+
+tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
+
+
+--------------------------------------
+-- Binding type/class variables in the
+-- kind-checking and typechecking phases
+--------------------------------------
+
+bindTyClTyVars :: Name
+               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
+-- ^ Used for the type variables of a type or class decl
+-- in the "kind checking" and "type checking" pass,
+-- but not in the initial-kind run.
+bindTyClTyVars tycon_name thing_inside
+  = do { tycon <- kcLookupTcTyCon tycon_name
+       ; let scoped_prs = tcTyConScopedTyVars tycon
+             res_kind   = tyConResKind tycon
+             binders    = tyConBinders tycon
+       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)
+       ; tcExtendNameTyVarEnv scoped_prs $
+         thing_inside binders res_kind }
+
+-- getInitialKind has made a suitably-shaped kind for the type or class
+-- Look it up in the local environment. This is used only for tycons
+-- that we're currently type-checking, so we're sure to find a TcTyCon.
+kcLookupTcTyCon :: Name -> TcM TcTyCon
+kcLookupTcTyCon nm
+  = do { tc_ty_thing <- tcLookup nm
+       ; return $ case tc_ty_thing of
+           ATcTyCon tc -> tc
+           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }
+
+
+{- *********************************************************************
+*                                                                      *
+             Kind generalisation
+*                                                                      *
+********************************************************************* -}
+
+zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
+zonkAndScopedSort spec_tkvs
+  = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs
+          -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv
+
+       -- Do a stable topological sort, following
+       -- Note [Ordering of implicit variables] in RnTypes
+       ; return (scopedSort spec_tkvs) }
+
+kindGeneralize :: TcType -> TcM [KindVar]
+-- Quantify the free kind variables of a kind or type
+-- In the latter case the type is closed, so it has no free
+-- type variables.  So in both cases, all the free vars are kind vars
+-- Input needn't be zonked.
+-- NB: You must call solveEqualities or solveLocalEqualities before
+-- kind generalization
+--
+-- NB: this function is just a specialised version of
+--        kindGeneralizeLocal emptyWC kind_or_type
+--
+kindGeneralize kind_or_type
+  = do { kt <- zonkTcType kind_or_type
+       ; traceTc "kindGeneralise1" (ppr kt)
+       ; dvs <- candidateQTyVarsOfKind kind_or_type
+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
+       ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type
+                                        , ppr dvs ])
+       ; quantifyTyVars gbl_tvs dvs }
+
+-- | This variant of 'kindGeneralize' refuses to generalize over any
+-- variables free in the given WantedConstraints. Instead, it promotes
+-- these variables into an outer TcLevel. See also
+-- Note [Promoting unification variables] in TcSimplify
+kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]
+kindGeneralizeLocal wanted kind_or_type
+  = do {
+       -- This bit is very much like decideMonoTyVars in TcSimplify,
+       -- but constraints are so much simpler in kinds, it is much
+       -- easier here. (In particular, we never quantify over a
+       -- constraint in a type.)
+       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)
+       ; (_, constrained) <- promoteTyVarSet constrained
+
+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
+       ; let mono_tvs = gbl_tvs `unionVarSet` constrained
+
+         -- use the "Kind" variant here, as any types we see
+         -- here will already have all type variables quantified;
+         -- thus, every free variable is really a kv, never a tv.
+       ; dvs <- candidateQTyVarsOfKind kind_or_type
+
+       ; traceTc "kindGeneralizeLocal" $
+         vcat [ text "Wanted:" <+> ppr wanted
+              , text "Kind or type:" <+> ppr kind_or_type
+              , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted))
+              , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained)
+              , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs)
+              , text "dvs:" <+> ppr dvs ]
+
+       ; quantifyTyVars mono_tvs dvs }
+
+{- Note [Levels and generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f x = e
+with no type signature. We are currently at level i.
+We must
+  * Push the level to level (i+1)
+  * Allocate a fresh alpha[i+1] for the result type
+  * Check that e :: alpha[i+1], gathering constraint WC
+  * Solve WC as far as possible
+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]
+  * Find the free variables with level > i, in this case gamma[i]
+  * Skolemise those free variables and quantify over them, giving
+       f :: forall g. beta[i-1] -> g
+  * Emit the residiual constraint wrapped in an implication for g,
+    thus   forall g. WC
+
+All of this happens for types too.  Consider
+  f :: Int -> (forall a. Proxy a -> Int)
+
+Note [Kind generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do kind generalisation only at the outer level of a type signature.
+For example, consider
+  T :: forall k. k -> *
+  f :: (forall a. T a -> Int) -> Int
+When kind-checking f's type signature we generalise the kind at
+the outermost level, thus:
+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!
+and *not* at the inner forall:
+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!
+Reason: same as for HM inference on value level declarations,
+we want to infer the most general type.  The f2 type signature
+would be *less applicable* than f1, because it requires a more
+polymorphic argument.
+
+NB: There are no explicit kind variables written in f's signature.
+When there are, the renamer adds these kind variables to the list of
+variables bound by the forall, so you can indeed have a type that's
+higher-rank in its kind. But only by explicit request.
+
+Note [Kinds of quantified type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcTyVarBndrsGen quantifies over a specified list of type variables,
+*and* over the kind variables mentioned in the kinds of those tyvars.
+
+Note that we must zonk those kinds (obviously) but less obviously, we
+must return type variables whose kinds are zonked too. Example
+    (a :: k7)  where  k7 := k9 -> k9
+We must return
+    [k9, a:k9->k9]
+and NOT
+    [k9, a:k7]
+Reason: we're going to turn this into a for-all type,
+   forall k9. forall (a:k7). blah
+which the type checker will then instantiate, and instantiate does not
+look through unification variables!
+
+Hence using zonked_kinds when forming tvs'.
+
+-}
+
+-----------------------------------
+etaExpandAlgTyCon :: [TyConBinder]
+                  -> Kind
+                  -> TcM ([TyConBinder], Kind)
+-- GADT decls can have a (perhaps partial) kind signature
+--      e.g.  data T a :: * -> * -> * where ...
+-- This function makes up suitable (kinded) TyConBinders for the
+-- argument kinds.  E.g. in this case it might return
+--   ([b::*, c::*], *)
+-- Never emits constraints.
+-- It's a little trickier than you might think: see
+-- Note [TyConBinders for the result kind signature of a data type]
+etaExpandAlgTyCon tc_bndrs kind
+  = do  { loc     <- getSrcSpanM
+        ; uniqs   <- newUniqueSupply
+        ; rdr_env <- getLocalRdrEnv
+        ; let new_occs = [ occ
+                         | str <- allNameStrings
+                         , let occ = mkOccName tvName str
+                         , isNothing (lookupLocalRdrOcc rdr_env occ)
+                         -- Note [Avoid name clashes for associated data types]
+                         , not (occ `elem` lhs_occs) ]
+              new_uniqs = uniqsFromSupply uniqs
+              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))
+        ; return (go loc new_occs new_uniqs subst [] kind) }
+  where
+    lhs_tvs  = map binderVar tc_bndrs
+    lhs_occs = map getOccName lhs_tvs
+
+    go loc occs uniqs subst acc kind
+      = case splitPiTy_maybe kind of
+          Nothing -> (reverse acc, substTy subst kind)
+
+          Just (Anon af arg, kind')
+            -> go loc occs' uniqs' subst' (tcb : acc) kind'
+            where
+              arg'   = substTy subst arg
+              tv     = mkTyVar (mkInternalName uniq occ loc) arg'
+              subst' = extendTCvInScope subst tv
+              tcb    = Bndr tv (AnonTCB af)
+              (uniq:uniqs') = uniqs
+              (occ:occs')   = occs
+
+          Just (Named (Bndr tv vis), kind')
+            -> go loc occs uniqs subst' (tcb : acc) kind'
+            where
+              (subst', tv') = substTyVarBndr subst tv
+              tcb = Bndr tv' (NamedTCB vis)
+
+badKindSig :: Bool -> Kind -> SDoc
+badKindSig check_for_type kind
+ = hang (sep [ text "Kind signature on data type declaration has non-*"
+             , (if check_for_type then empty else text "and non-variable") <+>
+               text "return kind" ])
+        2 (ppr kind)
+
+tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
+-- Result is in 1-1 correpondence with orig_args
+tcbVisibilities tc orig_args
+  = go (tyConKind tc) init_subst orig_args
+  where
+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))
+    go _ _ []
+      = []
+
+    go fun_kind subst all_args@(arg : args)
+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind
+      = case tcb of
+          Anon af _           -> AnonTCB af   : go inner_kind subst  args
+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args
+                 where
+                    subst' = extendTCvSubst subst tv arg
+
+      | not (isEmptyTCvSubst subst)
+      = go (substTy subst fun_kind) init_subst all_args
+
+      | otherwise
+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)
+
+
+{- Note [TyConBinders for the result kind signature of a data type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given
+  data T (a::*) :: * -> forall k. k -> *
+we want to generate the extra TyConBinders for T, so we finally get
+  (a::*) (b::*) (k::*) (c::k)
+The function etaExpandAlgTyCon generates these extra TyConBinders from
+the result kind signature.
+
+We need to take care to give the TyConBinders
+  (a) OccNames that are fresh (because the TyConBinders of a TyCon
+      must have distinct OccNames
+
+  (b) Uniques that are fresh (obviously)
+
+For (a) we need to avoid clashes with the tyvars declared by
+the user before the "::"; in the above example that is 'a'.
+And also see Note [Avoid name clashes for associated data types].
+
+For (b) suppose we have
+   data T :: forall k. k -> forall k. k -> *
+where the two k's are identical even up to their uniques.  Surprisingly,
+this can happen: see #14515.
+
+It's reasonably easy to solve all this; just run down the list with a
+substitution; hence the recursive 'go' function.  But it has to be
+done.
+
+Note [Avoid name clashes for associated data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider    class C a b where
+               data D b :: * -> *
+When typechecking the decl for D, we'll invent an extra type variable
+for D, to fill out its kind.  Ideally we don't want this type variable
+to be 'a', because when pretty printing we'll get
+            class C a b where
+               data D b a0
+(NB: the tidying happens in the conversion to IfaceSyn, which happens
+as part of pretty-printing a TyThing.)
+
+That's why we look in the LocalRdrEnv to see what's in scope. This is
+important only to get nice-looking output when doing ":info C" in GHCi.
+It isn't essential for correctness.
+
+
+************************************************************************
+*                                                                      *
+             Partial signatures
+*                                                                      *
+************************************************************************
+
+-}
+
+tcHsPartialSigType
+  :: UserTypeCtxt
+  -> LHsSigWcType GhcRn       -- The type signature
+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards
+         , Maybe TcType       -- Extra-constraints wildcard
+         , [Name]             -- Original tyvar names, in correspondence with ...
+         , [TcTyVar]          -- ... Implicitly and explicitly bound type variables
+         , TcThetaType        -- Theta part
+         , TcType )           -- Tau part
+-- See Note [Recipe for checking a signature]
+tcHsPartialSigType ctxt sig_ty
+  | HsWC { hswc_ext  = sig_wcs, hswc_body = ib_ty } <- sig_ty
+  , HsIB { hsib_ext = implicit_hs_tvs
+         , hsib_body = hs_ty } <- ib_ty
+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
+  = addSigCtxt ctxt hs_ty $
+    do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
+            <- solveLocalEqualities "tcHsPatSigTypes"      $
+               tcWildCardBinders sig_wcs $ \ wcs ->
+               bindImplicitTKBndrs_Tv implicit_hs_tvs       $
+               bindExplicitTKBndrs_Tv explicit_hs_tvs       $
+               do {   -- Instantiate the type-class context; but if there
+                      -- is an extra-constraints wildcard, just discard it here
+                    (theta, wcx) <- tcPartialContext hs_ctxt
+
+                  ; tau <- tcHsOpenType hs_tau
+
+                  ; return (wcs, wcx, theta, tau) }
+
+         -- We must return these separately, because all the zonking below
+         -- might change the name of a TyVarTv. This, in turn, causes trouble
+         -- in partial type signatures that bind scoped type variables, as
+         -- we bring the wrong name into scope in the function body.
+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug
+       ; let tv_names = implicit_hs_tvs ++ hsLTyVarNames explicit_hs_tvs
+
+       -- Spit out the wildcards (including the extra-constraints one)
+       -- as "hole" constraints, so that they'll be reported if necessary
+       -- See Note [Extra-constraint holes in partial type signatures]
+       ; emitWildCardHoleConstraints wcs
+
+         -- The TyVarTvs created above will sometimes have too high a TcLevel
+         -- (note that they are generated *after* bumping the level in
+         -- the tc{Im,Ex}plicitTKBndrsSig functions. Bumping the level
+         -- is still important here, because the kinds of these variables
+         -- do indeed need to have the higher level, so they can unify
+         -- with other local type variables. But, now that we've type-checked
+         -- everything (and solved equalities in the tcImplicit call)
+         -- we need to promote the TyVarTvs so we don't violate the TcLevel
+         -- invariant
+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
+       ; explicit_tvs <- mapM zonkAndSkolemise explicit_tvs
+       ; theta        <- mapM zonkTcType theta
+       ; tau          <- zonkTcType tau
+
+       ; let all_tvs = implicit_tvs ++ explicit_tvs
+
+       ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)
+
+       ; traceTc "tcHsPartialSigType" (ppr all_tvs)
+       ; return (wcs, wcx, tv_names, all_tvs, theta, tau) }
+
+tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"
+tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"
+
+tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)
+tcPartialContext hs_theta
+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
+  , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last
+  = do { wc_tv_ty <- setSrcSpan wc_loc $
+                     tcWildCardOcc wc constraintKind
+       ; theta <- mapM tcLHsPredType hs_theta1
+       ; return (theta, Just wc_tv_ty) }
+  | otherwise
+  = do { theta <- mapM tcLHsPredType hs_theta
+       ; return (theta, Nothing) }
+
+{- Note [Extra-constraint holes in partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: (_) => a -> a
+  f x = ...
+
+* The renamer leaves '_' untouched.
+
+* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
+  tcWildCardBinders.
+
+* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar
+  with the inferred constraints, e.g. (Eq a, Show a)
+
+* TcErrors.mkHoleError finally reports the error.
+
+An annoying difficulty happens if there are more than 62 inferred
+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.
+Where do we find the TyCon?  For good reasons we only have constraint
+tuples up to 62 (see Note [How tuples work] in TysWiredIn).  So how
+can we make a 70-tuple?  This was the root cause of #14217.
+
+It's incredibly tiresome, because we only need this type to fill
+in the hole, to communicate to the error reporting machinery.  Nothing
+more.  So I use a HACK:
+
+* I make an /ordinary/ tuple of the constraints, in
+  TcBinds.chooseInferredQuantifiers. This is ill-kinded because
+  ordinary tuples can't contain constraints, but it works fine. And for
+  ordinary tuples we don't have the same limit as for constraint
+  tuples (which need selectors and an assocated class).
+
+* Because it is ill-kinded, it trips an assert in writeMetaTyVar,
+  so now I disable the assertion if we are writing a type of
+  kind Constraint.  (That seldom/never normally happens so we aren't
+  losing much.)
+
+Result works fine, but it may eventually bite us.
+
+
+************************************************************************
+*                                                                      *
+      Pattern signatures (i.e signatures that occur in patterns)
+*                                                                      *
+********************************************************************* -}
+
+tcHsPatSigType :: UserTypeCtxt
+               -> LHsSigWcType GhcRn          -- The type signature
+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards
+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding
+                                              -- the scoped type variables
+                      , TcType)       -- The type
+-- Used for type-checking type signatures in
+-- (a) patterns           e.g  f (x::Int) = e
+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x
+--
+-- This may emit constraints
+-- See Note [Recipe for checking a signature]
+tcHsPatSigType ctxt sig_ty
+  | HsWC { hswc_ext = sig_wcs,   hswc_body = ib_ty } <- sig_ty
+  , HsIB { hsib_ext = sig_ns
+         , hsib_body = hs_ty } <- ib_ty
+  = addSigCtxt ctxt hs_ty $
+    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns
+       ; (wcs, sig_ty)
+            <- solveLocalEqualities "tcHsPatSigType" $
+                 -- Always solve local equalities if possible,
+                 -- else casts get in the way of deep skolemisation
+                 -- (#16033)
+               tcWildCardBinders sig_wcs        $ \ wcs ->
+               tcExtendNameTyVarEnv sig_tkv_prs $
+               do { sig_ty <- tcHsOpenType hs_ty
+                  ; return (wcs, sig_ty) }
+
+        ; emitWildCardHoleConstraints wcs
+
+          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty
+          -- contains a forall). Promote these.
+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...
+          -- When we instantiate x, we have to compare the kind of the argument
+          -- to a's kind, which will be a metavariable.
+        ; sig_ty <- zonkPromoteType sig_ty
+        ; checkValidType ctxt sig_ty
+
+        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)
+        ; return (wcs, sig_tkv_prs, sig_ty) }
+  where
+    new_implicit_tv name
+      = do { kind <- newMetaKindVar
+           ; tv   <- case ctxt of
+                       RuleSigCtxt {} -> newSkolemTyVar name kind
+                       _              -> newPatSigTyVar name kind
+                       -- See Note [Pattern signature binders]
+             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)
+           ; return (name, tv) }
+
+tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"
+tcHsPatSigType _ (XHsWildCardBndrs _)          = panic "tcHsPatSigType"
+
+tcPatSig :: Bool                    -- True <=> pattern binding
+         -> LHsSigWcType GhcRn
+         -> ExpSigmaType
+         -> TcM (TcType,            -- The type to use for "inside" the signature
+                 [(Name,TcTyVar)],  -- The new bit of type environment, binding
+                                    -- the scoped type variables
+                 [(Name,TcTyVar)],  -- The wildcards
+                 HsWrapper)         -- Coercion due to unification with actual ty
+                                    -- Of shape:  res_ty ~ sig_ty
+tcPatSig in_pat_bind sig res_ty
+ = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
+        -- sig_tvs are the type variables free in 'sig',
+        -- and not already in scope. These are the ones
+        -- that should be brought into scope
+
+        ; if null sig_tvs then do {
+                -- Just do the subsumption check and return
+                  wrap <- addErrCtxtM (mk_msg sig_ty) $
+                          tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
+                ; return (sig_ty, [], sig_wcs, wrap)
+        } else do
+                -- Type signature binds at least one scoped type variable
+
+                -- A pattern binding cannot bind scoped type variables
+                -- It is more convenient to make the test here
+                -- than in the renamer
+        { when in_pat_bind (addErr (patBindSigErr sig_tvs))
+
+                -- Check that all newly-in-scope tyvars are in fact
+                -- constrained by the pattern.  This catches tiresome
+                -- cases like
+                --      type T a = Int
+                --      f :: Int -> Int
+                --      f (x :: T a) = ...
+                -- Here 'a' doesn't get a binding.  Sigh
+        ; let bad_tvs = filterOut (`elemVarSet` exactTyCoVarsOfType sig_ty)
+                                  (tyCoVarsOfTypeList sig_ty)
+        ; checkTc (null bad_tvs) (badPatTyVarTvs sig_ty bad_tvs)
+
+        -- Now do a subsumption check of the pattern signature against res_ty
+        ; wrap <- addErrCtxtM (mk_msg sig_ty) $
+                  tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
+
+        -- Phew!
+        ; return (sig_ty, sig_tvs, sig_wcs, wrap)
+        } }
+  where
+    mk_msg sig_ty tidy_env
+       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty
+            ; res_ty <- readExpType res_ty   -- should be filled in by now
+            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty
+            ; let msg = vcat [ hang (text "When checking that the pattern signature:")
+                                  4 (ppr sig_ty)
+                             , nest 2 (hang (text "fits the type of its context:")
+                                          2 (ppr res_ty)) ]
+            ; return (tidy_env, msg) }
+
+patBindSigErr :: [(Name,TcTyVar)] -> SDoc
+patBindSigErr sig_tvs
+  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs
+          <+> pprQuotedList (map fst sig_tvs))
+       2 (text "in a pattern binding signature")
+
+{- Note [Pattern signature binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Type variables in the type environment] in TcRnTypes.
+Consider
+
+  data T where
+    MkT :: forall a. a -> (a -> Int) -> T
+
+  f :: T -> ...
+  f (MkT x (f :: b -> c)) = <blah>
+
+Here
+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',
+   It must be a skolem so that that it retains its identity, and
+   TcErrors.getSkolemInfo can thereby find the binding site for the skolem.
+
+ * The type signature pattern (f :: b -> c) makes freshs meta-tyvars
+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the
+   environment
+
+ * Then unification makes beta := a_sk, gamma := Int
+   That's why we must make beta and gamma a MetaTv,
+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).
+
+ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,
+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,
+
+Another example (#13881):
+   fl :: forall (l :: [a]). Sing l -> Sing l
+   fl (SNil :: Sing (l :: [y])) = SNil
+When we reach the pattern signature, 'l' is in scope from the
+outer 'forall':
+   "a" :-> a_sk :: *
+   "l" :-> l_sk :: [a_sk]
+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check
+the pattern signature
+   Sing (l :: [y])
+That unifies y_sig := a_sk.  We return from tcHsPatSigType with
+the pair ("y" :-> y_sig).
+
+For RULE binders, though, things are a bit different (yuk).
+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...
+Here this really is the binding site of the type variable so we'd like
+to use a skolem, so that we get a complaint if we unify two of them
+together.  Hence the new_tv function in tcHsPatSigType.
+
+
+************************************************************************
+*                                                                      *
+        Checking kinds
+*                                                                      *
+************************************************************************
+
+-}
+
+unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
+unifyKinds rn_tys act_kinds
+  = do { kind <- newMetaKindVar
+       ; let check rn_ty (ty, act_kind)
+               = checkExpectedKind (unLoc rn_ty) ty act_kind kind
+       ; tys' <- zipWithM check rn_tys act_kinds
+       ; return (tys', kind) }
+
+{-
+************************************************************************
+*                                                                      *
+    Promotion
+*                                                                      *
+************************************************************************
+-}
+
+-- | Whenever a type is about to be added to the environment, it's necessary
+-- to make sure that any free meta-tyvars in the type are promoted to the
+-- current TcLevel. (They might be at a higher level due to the level-bumping
+-- in tcExplicitTKBndrs, for example.) This function both zonks *and*
+-- promotes. Why at the same time? See Note [Recipe for checking a signature]
+zonkPromoteType :: TcType -> TcM TcType
+zonkPromoteType = mapType zonkPromoteMapper ()
+
+-- cf. TcMType.zonkTcTypeMapper
+zonkPromoteMapper :: TyCoMapper () TcM
+zonkPromoteMapper = TyCoMapper { tcm_tyvar    = const zonkPromoteTcTyVar
+                               , tcm_covar    = const covar
+                               , tcm_hole     = const hole
+                               , tcm_tycobinder = const tybinder
+                               , tcm_tycon    = return }
+  where
+    covar cv
+      = mkCoVarCo <$> zonkPromoteTyCoVarKind cv
+
+    hole :: CoercionHole -> TcM Coercion
+    hole h
+      = do { contents <- unpackCoercionHole_maybe h
+           ; case contents of
+               Just co -> do { co <- zonkPromoteCoercion co
+                             ; checkCoercionHole cv co }
+               Nothing -> do { cv' <- zonkPromoteTyCoVarKind cv
+                             ; return $ mkHoleCo (setCoHoleCoVar h cv') } }
+      where
+        cv = coHoleCoVar h
+
+    tybinder :: TyVar -> ArgFlag -> TcM ((), TyVar)
+    tybinder tv _flag = ((), ) <$> zonkPromoteTyCoVarKind tv
+
+zonkPromoteTcTyVar :: TyCoVar -> TcM TcType
+zonkPromoteTcTyVar tv
+  | isMetaTyVar tv
+  = do { let ref = metaTyVarRef tv
+       ; contents <- readTcRef ref
+       ; case contents of
+           Flexi -> do { (_, promoted_tv) <- promoteTyVar tv
+                       ; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }
+           Indirect ty -> zonkPromoteType ty }
+
+  | isTcTyVar tv && isSkolemTyVar tv  -- NB: isSkolemTyVar says "True" to pure TyVars
+  = do { tc_lvl <- getTcLevel
+       ; mkTyVarTy <$> zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }
+
+  | otherwise
+  = mkTyVarTy <$> zonkPromoteTyCoVarKind tv
+
+zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar
+zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType
+
+zonkPromoteCoercion :: Coercion -> TcM Coercion
+zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()
+
+{-
+************************************************************************
+*                                                                      *
+        Sort checking kinds
+*                                                                      *
+************************************************************************
+
+tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
+It does sort checking and desugaring at the same time, in one single pass.
+-}
+
+tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
+tcLHsKindSig ctxt hs_kind
+-- See  Note [Recipe for checking a signature] in TcHsType
+-- Result is zonked
+  = do { kind <- solveLocalEqualities "tcLHsKindSig" $
+                 tc_lhs_kind kindLevelMode hs_kind
+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)
+       -- No generalization, so we must promote
+       ; kind <- zonkPromoteType kind
+         -- This zonk is very important in the case of higher rank kinds
+         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).
+         --                          <more blah>
+         --      When instantiating p's kind at occurrences of p in <more blah>
+         --      it's crucial that the kind we instantiate is fully zonked,
+         --      else we may fail to substitute properly
+
+       ; checkValidType ctxt kind
+       ; traceTc "tcLHsKindSig2" (ppr kind)
+       ; return kind }
+
+tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind
+tc_lhs_kind mode k
+  = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $
+    tc_lhs_type (kindLevel mode) k liftedTypeKind
+
+promotionErr :: Name -> PromotionErr -> TcM a
+promotionErr name err
+  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")
+                   2 (parens reason))
+  where
+    reason = case err of
+               ConstrainedDataConPE pred
+                              -> text "it has an unpromotable context"
+                                 <+> quotes (ppr pred)
+               FamDataConPE   -> text "it comes from a data family instance"
+               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"
+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"
+               PatSynPE       -> text "pattern synonyms cannot be promoted"
+               _ -> text "it is defined and used in the same recursive group"
+
+{-
+************************************************************************
+*                                                                      *
+                Scoped type variables
+*                                                                      *
+************************************************************************
+-}
+
+badPatTyVarTvs :: TcType -> [TyVar] -> SDoc
+badPatTyVarTvs sig_ty bad_tvs
+  = vcat [ fsep [text "The type variable" <> plural bad_tvs,
+                 quotes (pprWithCommas ppr bad_tvs),
+                 text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),
+                 text "but are actually discarded by a type synonym" ]
+         , text "To fix this, expand the type synonym"
+         , text "[Note: I hope to lift this restriction in due course]" ]
+
+{-
+************************************************************************
+*                                                                      *
+          Error messages and such
+*                                                                      *
+************************************************************************
+-}
+
+
+-- | If the inner action emits constraints, report them as errors and fail;
+-- otherwise, propagates the return value. Useful as a wrapper around
+-- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be
+-- another chance to solve constraints
+failIfEmitsConstraints :: TcM a -> TcM a
+failIfEmitsConstraints thing_inside
+  = checkNoErrs $  -- We say that we fail if there are constraints!
+                   -- c.f same checkNoErrs in solveEqualities
+    do { (res, lie) <- captureConstraints thing_inside
+       ; reportAllUnsolved lie
+       ; return res
+       }
+
+-- | Make an appropriate message for an error in a function argument.
+-- Used for both expressions and types.
+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
+funAppCtxt fun arg arg_no
+  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),
+                    quotes (ppr fun) <> text ", namely"])
+       2 (quotes (ppr arg))
+
+-- | Add a "In the data declaration for T" or some such.
+addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a
+addTyConFlavCtxt name flav
+  = addErrCtxt $ hsep [ text "In the", ppr flav
+                      , text "declaration for", quotes (ppr name) ]
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -0,0 +1,2137 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcInstDecls: Typechecking instance declarations
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcBinds
+import TcTyClsDecls
+import TcTyDecls ( addTyConsToGblEnv )
+import TcClassDcl( tcClassDecl2, tcATDefault,
+                   HsSigFun, mkHsSigFun, badMethodErr,
+                   findMethodBind, instantiateMethod )
+import TcSigs
+import TcRnMonad
+import TcValidity
+import TcHsSyn
+import TcMType
+import TcType
+import BuildTyCl
+import Inst
+import ClsInst( AssocInstInfo(..), isNotAssociated )
+import InstEnv
+import FamInst
+import FamInstEnv
+import TcDeriv
+import TcEnv
+import TcHsType
+import TcUnify
+import CoreSyn    ( Expr(..), mkApps, mkVarApps, mkLams )
+import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
+import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
+import Type
+import TcEvidence
+import TyCon
+import CoAxiom
+import DataCon
+import ConLike
+import Class
+import Var
+import VarEnv
+import VarSet
+import Bag
+import BasicTypes
+import DynFlags
+import ErrUtils
+import FastString
+import Id
+import ListSetOps
+import Name
+import NameSet
+import Outputable
+import SrcLoc
+import Util
+import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Maybes
+import Data.List( mapAccumL )
+
+
+{-
+Typechecking instance declarations is done in two passes. The first
+pass, made by @tcInstDecls1@, collects information to be used in the
+second pass.
+
+This pre-processed info includes the as-yet-unprocessed bindings
+inside the instance declaration.  These are type-checked in the second
+pass, when the class-instance envs and GVE contain all the info from
+all the instance and value decls.  Indeed that's the reason we need
+two passes over the instance decls.
+
+
+Note [How instance declarations are translated]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is how we translate instance declarations into Core
+
+Running example:
+        class C a where
+           op1, op2 :: Ix b => a -> b -> b
+           op2 = <dm-rhs>
+
+        instance C a => C [a]
+           {-# INLINE [2] op1 #-}
+           op1 = <rhs>
+===>
+        -- Method selectors
+        op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
+        op1 = ...
+        op2 = ...
+
+        -- Default methods get the 'self' dictionary as argument
+        -- so they can call other methods at the same type
+        -- Default methods get the same type as their method selector
+        $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
+        $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
+               -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
+               -- Note [Tricky type variable scoping]
+
+        -- A top-level definition for each instance method
+        -- Here op1_i, op2_i are the "instance method Ids"
+        -- The INLINE pragma comes from the user pragma
+        {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
+        op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
+        op1_i = /\a. \(d:C a).
+               let this :: C [a]
+                   this = df_i a d
+                     -- Note [Subtle interaction of recursion and overlap]
+
+                   local_op1 :: forall b. Ix b => [a] -> b -> b
+                   local_op1 = <rhs>
+                     -- Source code; run the type checker on this
+                     -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
+                     -- Note [Tricky type variable scoping]
+
+               in local_op1 a d
+
+        op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
+
+        -- The dictionary function itself
+        {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
+        df_i :: forall a. C a -> C [a]
+        df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
+                -- But see Note [Default methods in instances]
+                -- We can't apply the type checker to the default-method call
+
+        -- Use a RULE to short-circuit applications of the class ops
+        {-# RULE "op1@C[a]" forall a, d:C a.
+                            op1 [a] (df_i d) = op1_i a d #-}
+
+Note [Instances and loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Note that df_i may be mutually recursive with both op1_i and op2_i.
+  It's crucial that df_i is not chosen as the loop breaker, even
+  though op1_i has a (user-specified) INLINE pragma.
+
+* Instead the idea is to inline df_i into op1_i, which may then select
+  methods from the MkC record, and thereby break the recursion with
+  df_i, leaving a *self*-recursive op1_i.  (If op1_i doesn't call op at
+  the same type, it won't mention df_i, so there won't be recursion in
+  the first place.)
+
+* If op1_i is marked INLINE by the user there's a danger that we won't
+  inline df_i in it, and that in turn means that (since it'll be a
+  loop-breaker because df_i isn't), op1_i will ironically never be
+  inlined.  But this is OK: the recursion breaking happens by way of
+  a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
+  unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
+
+Note [ClassOp/DFun selection]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One thing we see a lot is stuff like
+    op2 (df d1 d2)
+where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
+'op2' and 'df' to get
+     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
+       MkD _ op2 _ _ _ -> op2
+And that will reduce to ($cop2 d1 d2) which is what we wanted.
+
+But it's tricky to make this work in practice, because it requires us to
+inline both 'op2' and 'df'.  But neither is keen to inline without having
+seen the other's result; and it's very easy to get code bloat (from the
+big intermediate) if you inline a bit too much.
+
+Instead we use a cunning trick.
+ * We arrange that 'df' and 'op2' NEVER inline.
+
+ * We arrange that 'df' is ALWAYS defined in the sylised form
+      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
+
+ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
+   that lists its methods.
+
+ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
+   a suitable constructor application -- inlining df "on the fly" as it
+   were.
+
+ * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
+   extracts the right piece iff its argument satisfies
+   exprIsConApp_maybe.  This is done in MkId mkDictSelId
+
+ * We make 'df' CONLIKE, so that shared uses still match; eg
+      let d = df d1 d2
+      in ...(op2 d)...(op1 d)...
+
+Note [Single-method classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the class has just one method (or, more accurately, just one element
+of {superclasses + methods}), then we use a different strategy.
+
+   class C a where op :: a -> a
+   instance C a => C [a] where op = <blah>
+
+We translate the class decl into a newtype, which just gives a
+top-level axiom. The "constructor" MkC expands to a cast, as does the
+class-op selector.
+
+   axiom Co:C a :: C a ~ (a->a)
+
+   op :: forall a. C a -> (a -> a)
+   op a d = d |> (Co:C a)
+
+   MkC :: forall a. (a->a) -> C a
+   MkC = /\a.\op. op |> (sym Co:C a)
+
+The clever RULE stuff doesn't work now, because ($df a d) isn't
+a constructor application, so exprIsConApp_maybe won't return
+Just <blah>.
+
+Instead, we simply rely on the fact that casts are cheap:
+
+   $df :: forall a. C a => C [a]
+   {-# INLINE df #-}  -- NB: INLINE this
+   $df = /\a. \d. MkC [a] ($cop_list a d)
+       = $cop_list |> forall a. C a -> (sym (Co:C [a]))
+
+   $cop_list :: forall a. C a => [a] -> [a]
+   $cop_list = <blah>
+
+So if we see
+   (op ($df a d))
+we'll inline 'op' and '$df', since both are simply casts, and
+good things happen.
+
+Why do we use this different strategy?  Because otherwise we
+end up with non-inlined dictionaries that look like
+    $df = $cop |> blah
+which adds an extra indirection to every use, which seems stupid.  See
+#4138 for an example (although the regression reported there
+wasn't due to the indirection).
+
+There is an awkward wrinkle though: we want to be very
+careful when we have
+    instance C a => C [a] where
+      {-# INLINE op #-}
+      op = ...
+then we'll get an INLINE pragma on $cop_list but it's important that
+$cop_list only inlines when it's applied to *two* arguments (the
+dictionary and the list argument).  So we must not eta-expand $df
+above.  We ensure that this doesn't happen by putting an INLINE
+pragma on the dfun itself; after all, it ends up being just a cast.
+
+There is one more dark corner to the INLINE story, even more deeply
+buried.  Consider this (#3772):
+
+    class DeepSeq a => C a where
+      gen :: Int -> a
+
+    instance C a => C [a] where
+      gen n = ...
+
+    class DeepSeq a where
+      deepSeq :: a -> b -> b
+
+    instance DeepSeq a => DeepSeq [a] where
+      {-# INLINE deepSeq #-}
+      deepSeq xs b = foldr deepSeq b xs
+
+That gives rise to these defns:
+
+    $cdeepSeq :: DeepSeq a -> [a] -> b -> b
+    -- User INLINE( 3 args )!
+    $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
+
+    $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
+    -- DFun (with auto INLINE pragma)
+    $fDeepSeq[] a d = $cdeepSeq a d |> blah
+
+    $cp1 a d :: C a => DeepSep [a]
+    -- We don't want to eta-expand this, lest
+    -- $cdeepSeq gets inlined in it!
+    $cp1 a d = $fDeepSep[] a (scsel a d)
+
+    $fC[] :: C a => C [a]
+    -- Ordinary DFun
+    $fC[] a d = MkC ($cp1 a d) ($cgen a d)
+
+Here $cp1 is the code that generates the superclass for C [a].  The
+issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
+and then $cdeepSeq will inline there, which is definitely wrong.  Like
+on the dfun, we solve this by adding an INLINE pragma to $cp1.
+
+Note [Subtle interaction of recursion and overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+  class C a where { op1,op2 :: a -> a }
+  instance C a => C [a] where
+    op1 x = op2 x ++ op2 x
+    op2 x = ...
+  instance C [Int] where
+    ...
+
+When type-checking the C [a] instance, we need a C [a] dictionary (for
+the call of op2).  If we look up in the instance environment, we find
+an overlap.  And in *general* the right thing is to complain (see Note
+[Overlapping instances] in InstEnv).  But in *this* case it's wrong to
+complain, because we just want to delegate to the op2 of this same
+instance.
+
+Why is this justified?  Because we generate a (C [a]) constraint in
+a context in which 'a' cannot be instantiated to anything that matches
+other overlapping instances, or else we would not be executing this
+version of op1 in the first place.
+
+It might even be a bit disguised:
+
+  nullFail :: C [a] => [a] -> [a]
+  nullFail x = op2 x ++ op2 x
+
+  instance C a => C [a] where
+    op1 x = nullFail x
+
+Precisely this is used in package 'regex-base', module Context.hs.
+See the overlapping instances for RegexContext, and the fact that they
+call 'nullFail' just like the example above.  The DoCon package also
+does the same thing; it shows up in module Fraction.hs.
+
+Conclusion: when typechecking the methods in a C [a] instance, we want to
+treat the 'a' as an *existential* type variable, in the sense described
+by Note [Binding when looking up instances].  That is why isOverlappableTyVar
+responds True to an InstSkol, which is the kind of skolem we use in
+tcInstDecl2.
+
+
+Note [Tricky type variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In our example
+        class C a where
+           op1, op2 :: Ix b => a -> b -> b
+           op2 = <dm-rhs>
+
+        instance C a => C [a]
+           {-# INLINE [2] op1 #-}
+           op1 = <rhs>
+
+note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
+in scope in <rhs>.  In particular, we must make sure that 'b' is in
+scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
+which brings appropriate tyvars into scope. This happens for both
+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
+complained if 'b' is mentioned in <rhs>.
+
+
+
+************************************************************************
+*                                                                      *
+\subsection{Extracting instance decls}
+*                                                                      *
+************************************************************************
+
+Gather up the instance declarations from their various sources
+-}
+
+tcInstDecls1    -- Deal with both source-code and imported instance decls
+   :: [LInstDecl GhcRn]         -- Source code instance decls
+   -> TcM (TcGblEnv,            -- The full inst env
+           [InstInfo GhcRn],    -- Source-code instance decls to process;
+                                -- contains all dfuns for this module
+           [DerivInfo])         -- From data family instances
+
+tcInstDecls1 inst_decls
+  = do {    -- Do class and family instance declarations
+       ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
+
+       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
+             fam_insts   = concat fam_insts_s
+             local_infos = concat local_infos_s
+
+       ; gbl_env <- addClsInsts local_infos $
+                    addFamInsts fam_insts   $
+                    getGblEnv
+
+       ; return ( gbl_env
+                , local_infos
+                , concat datafam_deriv_infos ) }
+
+-- | Use DerivInfo for data family instances (produced by tcInstDecls1),
+--   datatype declarations (TyClDecl), and standalone deriving declarations
+--   (DerivDecl) to check and process all derived class instances.
+tcInstDeclsDeriv
+  :: [DerivInfo]
+  -> [LTyClDecl GhcRn]
+  -> [LDerivDecl GhcRn]
+  -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
+tcInstDeclsDeriv datafam_deriv_infos tyclds derivds
+  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
+       if isBrackStage th_stage
+       then do { gbl_env <- getGblEnv
+               ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
+       else do { data_deriv_infos <- mkDerivInfos tyclds
+               ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos
+               ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
+               ; return (tcg_env, bagToList info_bag, valbinds) }
+
+addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
+addClsInsts infos thing_inside
+  = tcExtendLocalInstEnv (map iSpec infos) thing_inside
+
+addFamInsts :: [FamInst] -> TcM a -> TcM a
+-- Extend (a) the family instance envt
+--        (b) the type envt with stuff from data type decls
+addFamInsts fam_insts thing_inside
+  = tcExtendLocalFamInstEnv fam_insts $
+    tcExtendGlobalEnv axioms          $
+    do { traceTc "addFamInsts" (pprFamInsts fam_insts)
+       ; gbl_env <- addTyConsToGblEnv data_rep_tycons
+                    -- Does not add its axiom; that comes
+                    -- from adding the 'axioms' above
+       ; setGblEnv gbl_env thing_inside }
+  where
+    axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
+    data_rep_tycons = famInstsRepTyCons fam_insts
+      -- The representation tycons for 'data instances' declarations
+
+{-
+Note [Deriving inside TH brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a declaration bracket
+  [d| data T = A | B deriving( Show ) |]
+
+there is really no point in generating the derived code for deriving(
+Show) and then type-checking it. This will happen at the call site
+anyway, and the type check should never fail!  Moreover (#6005)
+the scoping of the generated code inside the bracket does not seem to
+work out.
+
+The easy solution is simply not to generate the derived instances at
+all.  (A less brutal solution would be to generate them with no
+bindings.)  This will become moot when we shift to the new TH plan, so
+the brutal solution will do.
+-}
+
+tcLocalInstDecl :: LInstDecl GhcRn
+                -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
+        -- A source-file instance declaration
+        -- Type-check all the stuff before the "where"
+        --
+        -- We check for respectable instance type, and context
+tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
+  = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)
+       ; return ([], [fam_inst], []) }
+
+tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
+  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl)
+       ; return ([], [fam_inst], maybeToList m_deriv_info) }
+
+tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
+  = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
+       ; return (insts, fam_insts, deriv_infos) }
+
+tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"
+
+tcClsInstDecl :: LClsInstDecl GhcRn
+              -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
+-- The returned DerivInfos are for any associated data families
+tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
+                                  , cid_sigs = uprags, cid_tyfam_insts = ats
+                                  , cid_overlap_mode = overlap_mode
+                                  , cid_datafam_insts = adts }))
+  = setSrcSpan loc                      $
+    addErrCtxt (instDeclCtxt1 hs_ty)  $
+    do  { traceTc "tcLocalInstDecl" (ppr hs_ty)
+        ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty
+        ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
+             -- NB: tcHsClsInstType does checkValidInstance
+
+        ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars
+        ; let tv_skol_prs = [ (tyVarName tv, skol_tv)
+                            | (tv, skol_tv) <- tyvars `zip` skol_tvs ]
+              n_inferred = countWhile ((== Inferred) . binderArgFlag) $
+                           fst $ splitForAllVarBndrs dfun_ty
+              visible_skol_tvs = drop n_inferred skol_tvs
+
+        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)
+
+        -- Next, process any associated types.
+        ; (datafam_stuff, tyfam_insts)
+             <- tcExtendNameTyVarEnv tv_skol_prs $
+                do  { let mini_env   = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys)
+                          mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env
+                          mb_info    = InClsInst { ai_class = clas
+                                                 , ai_tyvars = visible_skol_tvs
+                                                 , ai_inst_env = mini_env }
+                    ; df_stuff  <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts
+                    ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info)   ats
+
+                      -- Check for missing associated types and build them
+                      -- from their defaults (if available)
+                    ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
+                                        (classATItems clas)
+
+                    ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
+
+
+        -- Finally, construct the Core representation of the instance.
+        -- (This no longer includes the associated types.)
+        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty))
+                -- Dfun location is that of instance *header*
+
+        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
+                              tyvars theta clas inst_tys
+
+        ; let inst_binds = InstBindings
+                             { ib_binds = binds
+                             , ib_tyvars = map Var.varName tyvars -- Scope over bindings
+                             , ib_pragmas = uprags
+                             , ib_extensions = []
+                             , ib_derived = False }
+              inst_info = InstInfo { iSpec  = ispec, iBinds = inst_binds }
+
+              (datafam_insts, m_deriv_infos) = unzip datafam_stuff
+              deriv_infos                    = catMaybes m_deriv_infos
+              all_insts                      = tyfam_insts ++ datafam_insts
+
+         -- In hs-boot files there should be no bindings
+        ; is_boot <- tcIsHsBootOrSig
+        ; let no_binds = isEmptyLHsBinds binds && null uprags
+        ; failIfTc (is_boot && not no_binds) badBootDeclErr
+
+        ; return ( [inst_info], all_insts, deriv_infos ) }
+  where
+    defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
+                  `unionNameSet`
+                  mkNameSet (map (unLoc . feqn_tycon
+                                        . hsib_body
+                                        . dfid_eqn
+                                        . unLoc) adts)
+
+tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"
+
+{-
+************************************************************************
+*                                                                      *
+               Type family instances
+*                                                                      *
+************************************************************************
+
+Family instances are somewhat of a hybrid.  They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+-}
+
+tcTyFamInstDecl :: AssocInstInfo
+                -> LTyFamInstDecl GhcRn -> TcM FamInst
+  -- "type instance"
+  -- See Note [Associated type instances]
+tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
+  = setSrcSpan loc           $
+    tcAddTyFamInstCtxt decl  $
+    do { let fam_lname = feqn_tycon (hsib_body eqn)
+       ; fam_tc <- tcLookupLocatedTyCon fam_lname
+       ; tcFamInstDeclChecks mb_clsinfo fam_tc
+
+         -- (0) Check it's an open type family
+       ; checkTc (isTypeFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)
+       ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
+
+         -- (1) do the work of verifying the synonym group
+       ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
+                                        (L (getLoc fam_lname) eqn)
+
+
+         -- (2) check for validity
+       ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
+       ; checkValidCoAxBranch fam_tc co_ax_branch
+
+         -- (3) construct coercion axiom
+       ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
+       ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
+       ; newFamInst SynFamilyInst axiom }
+
+
+---------------------
+tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()
+-- Used for both type and data families
+tcFamInstDeclChecks mb_clsinfo fam_tc
+  = do { -- Type family instances require -XTypeFamilies
+         -- and can't (currently) be in an hs-boot file
+       ; traceTc "tcFamInstDecl" (ppr fam_tc)
+       ; type_families <- xoptM LangExt.TypeFamilies
+       ; is_boot       <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?
+       ; checkTc type_families $ badFamInstDecl fam_tc
+       ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+       -- Check that it is a family TyCon, and that
+       -- oplevel type instances are not for associated types.
+       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
+
+       ; when (isNotAssociated mb_clsinfo &&   -- Not in a class decl
+               isTyConAssoc fam_tc)            -- but an associated type
+              (addErr $ assocInClassErr fam_tc)
+       }
+
+{- Note [Associated type instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We allow this:
+  class C a where
+    type T x a
+  instance C Int where
+    type T (S y) Int = y
+    type T Z     Int = Char
+
+Note that
+  a) The variable 'x' is not bound by the class decl
+  b) 'x' is instantiated to a non-type-variable in the instance
+  c) There are several type instance decls for T in the instance
+
+All this is fine.  Of course, you can't give any *more* instances
+for (T ty Int) elsewhere, because it's an *associated* type.
+
+
+************************************************************************
+*                                                                      *
+               Data family instances
+*                                                                      *
+************************************************************************
+
+For some reason data family instances are a lot more complicated
+than type family instances
+-}
+
+tcDataFamInstDecl :: AssocInstInfo
+                  -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
+  -- "newtype instance" and "data instance"
+tcDataFamInstDecl mb_clsinfo
+    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars
+                                                   , hsib_body =
+      FamEqn { feqn_bndrs  = mb_bndrs
+             , feqn_pats   = hs_pats
+             , feqn_tycon  = lfam_name@(L _ fam_name)
+             , feqn_fixity = fixity
+             , feqn_rhs    = HsDataDefn { dd_ND      = new_or_data
+                                        , dd_cType   = cType
+                                        , dd_ctxt    = hs_ctxt
+                                        , dd_cons    = hs_cons
+                                        , dd_kindSig = m_ksig
+                                        , dd_derivs  = derivs } }}}))
+  = setSrcSpan loc             $
+    tcAddDataFamInstCtxt decl  $
+    do { fam_tc <- tcLookupLocatedTyCon lfam_name
+
+       ; tcFamInstDeclChecks mb_clsinfo fam_tc
+
+       -- Check that the family declaration is for the right kind
+       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+       ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons
+          -- Do /not/ check that the number of patterns = tyConArity fam_tc
+          -- See [Arity of data families] in FamInstEnv
+
+       ; (qtvs, pats, res_kind, stupid_theta)
+             <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs
+                                fixity hs_ctxt hs_pats m_ksig hs_cons
+
+       -- Eta-reduce the axiom if possible
+       -- Quite tricky: see Note [Eta-reduction for data families]
+       ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats
+             eta_tvs       = map binderVar eta_tcbs
+             post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs
+
+             full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs
+                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind))
+                         ++ eta_tcbs
+                 -- Put the eta-removed tyvars at the end
+                 -- Remember, qtvs is in arbitrary order, except kind vars are
+                 -- first, so there is no reason to suppose that the eta_tvs
+                 -- (obtained from the pats) are at the end (#11148)
+
+       -- Eta-expand the representation tycon until it has reult kind *
+       -- See also Note [Arity of data families] in FamInstEnv
+       -- NB: we can do this after eta-reducing the axiom, because if
+       --     we did it before the "extra" tvs from etaExpandAlgTyCon
+       --     would always be eta-reduced
+       ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind
+       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)
+       ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs
+             all_pats    = pats `chkAppend` extra_pats
+             orig_res_ty = mkTyConApp fam_tc all_pats
+             ty_binders  = full_tcbs `chkAppend` extra_tcbs
+
+       ; traceTc "tcDataFamInstDecl" $
+         vcat [ text "Fam tycon:" <+> ppr fam_tc
+              , text "Pats:" <+> ppr pats
+              , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats)
+              , text "all_pats:" <+> ppr all_pats
+              , text "ty_binders" <+> ppr ty_binders
+              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
+              , text "eta_pats" <+> ppr eta_pats
+              , text "eta_tcbs" <+> ppr eta_tcbs ]
+
+       ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
+           do { data_cons <- tcExtendTyVarEnv qtvs $
+                             -- For H98 decls, the tyvars scope
+                             -- over the data constructors
+                             tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons
+
+              ; rep_tc_name <- newFamInstTyConName lfam_name pats
+              ; axiom_name  <- newFamInstAxiomName lfam_name [pats]
+              ; tc_rhs <- case new_or_data of
+                     DataType -> return (mkDataTyConRhs data_cons)
+                     NewType  -> ASSERT( not (null data_cons) )
+                                 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
+
+              ; let axiom  = mkSingleCoAxiom Representational axiom_name
+                                 post_eta_qtvs eta_tvs [] fam_tc eta_pats
+                                 (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs))
+                    parent = DataFamInstTyCon axiom fam_tc all_pats
+
+                      -- NB: Use the full ty_binders from the pats. See bullet toward
+                      -- the end of Note [Data type families] in TyCon
+                    rep_tc   = mkAlgTyCon rep_tc_name
+                                          ty_binders liftedTypeKind
+                                          (map (const Nominal) ty_binders)
+                                          (fmap unLoc cType) stupid_theta
+                                          tc_rhs parent
+                                          gadt_syntax
+                 -- We always assume that indexed types are recursive.  Why?
+                 -- (1) Due to their open nature, we can never be sure that a
+                 -- further instance might not introduce a new recursive
+                 -- dependency.  (2) They are always valid loop breakers as
+                 -- they involve a coercion.
+              ; return (rep_tc, axiom) }
+
+       -- Remember to check validity; no recursion to worry about here
+       -- Check that left-hand sides are ok (mono-types, no type families,
+       -- consistent instantiations, etc)
+       ; let ax_branch = coAxiomSingleBranch axiom
+       ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch
+       ; checkValidCoAxBranch fam_tc ax_branch
+       ; checkValidTyCon rep_tc
+
+       ; let m_deriv_info = case derivs of
+               L _ []    -> Nothing
+               L _ preds ->
+                 Just $ DerivInfo { di_rep_tc  = rep_tc
+                                  , di_clauses = preds
+                                  , di_ctxt    = tcMkDataFamInstCtxt decl }
+
+       ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
+       ; return (fam_inst, m_deriv_info) }
+  where
+    eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
+    -- See Note [Eta reduction for data families] in FamInstEnv
+    -- Splits the incoming patterns into two: the [TyVar]
+    -- are the patterns that can be eta-reduced away.
+    -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])
+    --
+    -- NB: quadratic algorithm, but types are small here
+    eta_reduce fam_tc pats
+        = go (reverse (zip3 pats fvs_s vis_s)) []
+        where
+          vis_s :: [TyConBndrVis]
+          vis_s = tcbVisibilities fam_tc pats
+
+          fvs_s :: [TyCoVarSet]  -- 1-1 correspondence with pats
+                                 -- Each elt is the free vars of all /earlier/ pats
+          (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats
+          add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs)
+
+    go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs
+      | Just tv <- getTyVar_maybe pat
+      , not (tv `elemVarSet` fvs_to_the_left)
+      = go pats (Bndr tv tcb_vis : etad_tvs)
+    go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)
+
+tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"
+
+-----------------------
+tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]
+                -> LexicalFixity -> LHsContext GhcRn
+                -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]
+                -> TcM ([TyVar], [Type], Kind, ThetaType)
+-- The "header" is the part other than the data constructors themselves
+-- e.g.  data instance D [a] :: * -> * where ...
+-- Here the "header" is the bit before the "where"
+tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons
+  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind)))
+            <- pushTcLevelM_                                $
+               solveEqualities                              $
+               bindImplicitTKBndrs_Q_Skol imp_vars          $
+               bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+               do { stupid_theta <- tcHsContext hs_ctxt
+                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
+
+                  -- Ensure that the instance is consistent
+                  -- with its parent class
+                  ; addConsistencyConstraints mb_clsinfo lhs_ty
+
+                  -- Add constraints from the data constructors
+                  ; mapM_ (wrapLocM_ kcConDecl) hs_cons
+
+                  -- Add constraints from the result signature
+                  ; res_kind <- tc_kind_sig m_ksig
+                  ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind
+                  ; return (stupid_theta, lhs_ty, res_kind) }
+
+       -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]
+       -- This code (and the stuff immediately above) is very similar
+       -- to that in tcFamTyInstEqnGuts.  Maybe we should abstract the
+       -- common code; but for the moment I concluded that it's
+       -- clearer to duplicate it.  Still, if you fix a bug here,
+       -- check there too!
+       ; let scoped_tvs = imp_tvs ++ exp_tvs
+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
+       ; qtvs <- quantifyTyVars emptyVarSet dvs
+
+       -- Zonk the patterns etc into the Type world
+       ; (ze, qtvs)   <- zonkTyBndrs qtvs
+       ; lhs_ty       <- zonkTcTypeToTypeX ze lhs_ty
+       ; res_kind     <- zonkTcTypeToTypeX ze res_kind
+       ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta
+
+       -- Check that type patterns match the class instance head
+       ; let pats = unravelFamInstPats lhs_ty
+       ; return (qtvs, pats, res_kind, stupid_theta) }
+  where
+    fam_name  = tyConName fam_tc
+    data_ctxt = DataKindCtxt fam_name
+    pp_lhs    = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt
+    exp_bndrs = mb_bndrs `orElse` []
+
+    -- See Note [Result kind signature for a data family instance]
+    tc_kind_sig Nothing
+      = return liftedTypeKind
+    tc_kind_sig (Just hs_kind)
+      = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind
+           ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind
+           ; lvl <- getTcLevel
+           ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs
+             -- Perhaps surprisingly, we don't need the skolemised tvs themselves
+           ; return (substTy subst inner_kind) }
+
+{- Note [Result kind signature for a data family instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The expected type might have a forall at the type. Normally, we
+can't skolemise in kinds because we don't have type-level lambda.
+But here, we're at the top-level of an instance declaration, so
+we actually have a place to put the regeneralised variables.
+Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise
+Examples in indexed-types/should_compile/T12369
+
+Note [Eta-reduction for data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data D :: * -> * -> * -> * -> *
+
+   data instance D [(a,b)] p q :: * -> * where
+      D1 :: blah1
+      D2 :: blah2
+
+Then we'll generate a representation data type
+  data Drep a b p q z where
+      D1 :: blah1
+      D2 :: blah2
+
+and an axiom to connect them
+  axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z
+
+except that we'll eta-reduce the axiom to
+  axiom AxDrep forall a b. D [(a,b]] = Drep a b
+There are several fiddly subtleties lurking here
+
+* The representation tycon Drep is parameerised over the free
+  variables of the pattern, in no particular order. So there is no
+  guarantee that 'p' and 'q' will come last in Drep's parameters, and
+  in the right order.  So, if the /patterns/ of the family insatance
+  are eta-redcible, we re-order Drep's parameters to put the
+  eta-reduced type variables last.
+
+* Although we eta-reduce the axiom, we eta-/expand/ the representation
+  tycon Drep.  The kind of D says it takses four arguments, but the
+  data instance header only supplies three.  But the AlgTyCOn for Drep
+  itself must have enough TyConBinders so that its result kind is Type.
+  So, with etaExpandAlgTyCon we make up some extra TyConBinders
+
+* The result kind in the instance might be a polykind, like this:
+     data family DP a :: forall k. k -> *
+     data instance DP [b] :: forall k1 k2. (k1,k2) -> *
+
+  So in type-checking the LHS (DP Int) we need to check that it is
+  more polymorphic than the signature.  To do that we must skolemise
+  the siganture and istantiate the call of DP.  So we end up with
+     data instance DP [b] @(k1,k2) (z :: (k1,k2)) where
+
+  Note that we must parameterise the representation tycon DPrep over
+  'k1' and 'k2', as well as 'b'.
+
+  The skolemise bit is done in tc_kind_sig, while the instantiate bit
+  is done by tcFamTyPats.
+
+* Very fiddly point.  When we eta-reduce to
+     axiom AxDrep forall a b. D [(a,b]] = Drep a b
+
+  we want the kind of (D [(a,b)]) to be the same as the kind of
+  (Drep a b).  This ensures that applying the axiom doesn't change the
+  kind.  Why is that hard?  Because the kind of (Drep a b) depends on
+  the TyConBndrVis on Drep's arguments. In particular do we have
+    (forall (k::*). blah) or (* -> blah)?
+
+  We must match whatever D does!  In #15817 we had
+      data family X a :: forall k. * -> *   -- Note: a forall that is not used
+      data instance X Int b = MkX
+
+  So the data instance is really
+      data istance X Int @k b = MkX
+
+  The axiom will look like
+      axiom    X Int = Xrep
+
+  and it's important that XRep :: forall k * -> *, following X.
+
+  To achieve this we get the TyConBndrVis flags from tcbVisibilities,
+  and use those flags for any eta-reduced arguments.  Sigh.
+
+* The final turn of the knife is that tcbVisibilities is itself
+  tricky to sort out.  Consider
+      data family D k :: k
+  Then consider D (forall k2. k2 -> k2) Type Type
+  The visibilty flags on an application of D may affected by the arguments
+  themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities
+  does.
+
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+      Class instance declarations, pass 2
+*                                                                      *
+********************************************************************* -}
+
+tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
+             -> TcM (LHsBinds GhcTc)
+-- (a) From each class declaration,
+--      generate any default-method bindings
+-- (b) From each instance decl
+--      generate the dfun binding
+
+tcInstDecls2 tycl_decls inst_decls
+  = do  { -- (a) Default methods from class decls
+          let class_decls = filter (isClassDecl . unLoc) tycl_decls
+        ; dm_binds_s <- mapM tcClassDecl2 class_decls
+        ; let dm_binds = unionManyBags dm_binds_s
+
+          -- (b) instance declarations
+        ; let dm_ids = collectHsBindsBinders dm_binds
+              -- Add the default method Ids (again)
+              -- (they were arready added in TcTyDecls.tcAddImplicits)
+              -- See Note [Default methods in the type environment]
+        ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
+                          mapM tcInstDecl2 inst_decls
+
+          -- Done
+        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
+
+{- Note [Default methods in the type environment]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The default method Ids are already in the type environment (see Note
+[Default method Ids and Template Haskell] in TcTyDcls), BUT they
+don't have their InlinePragmas yet.  Usually that would not matter,
+because the simplifier propagates information from binding site to
+use.  But, unusually, when compiling instance decls we *copy* the
+INLINE pragma from the default method to the method for that
+particular operation (see Note [INLINE and default methods] below).
+
+So right here in tcInstDecls2 we must re-extend the type envt with
+the default method Ids replete with their INLINE pragmas.  Urk.
+-}
+
+tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
+            -- Returns a binding for the dfun
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
+  = recoverM (return emptyLHsBinds)             $
+    setSrcSpan loc                              $
+    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
+    do {  -- Instantiate the instance decl with skolem constants
+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id
+       ; dfun_ev_vars <- newEvVars dfun_theta
+                     -- We instantiate the dfun_id with superSkolems.
+                     -- See Note [Subtle interaction of recursion and overlap]
+                     -- and Note [Binding when looking up instances]
+
+       ; let (clas, inst_tys) = tcSplitDFunHead inst_head
+             (class_tyvars, sc_theta, _, op_items) = classBigSig clas
+             sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
+
+       ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
+
+                      -- Deal with 'SPECIALISE instance' pragmas
+                      -- See Note [SPECIALISE instance pragmas]
+       ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
+
+         -- Typecheck superclasses and methods
+         -- See Note [Typechecking plan for instance declarations]
+       ; dfun_ev_binds_var <- newTcEvBinds
+       ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
+       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
+             <- pushTcLevelM $
+                do { (sc_ids, sc_binds, sc_implics)
+                        <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
+                                          inst_tys dfun_ev_binds
+                                          sc_theta'
+
+                      -- Typecheck the methods
+                   ; (meth_ids, meth_binds, meth_implics)
+                        <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
+                                     inst_tys dfun_ev_binds spec_inst_info
+                                     op_items ibinds
+
+                   ; return ( sc_ids     ++          meth_ids
+                            , sc_binds   `unionBags` meth_binds
+                            , sc_implics `unionBags` meth_implics ) }
+
+       ; imp <- newImplication
+       ; emitImplication $
+         imp { ic_tclvl  = tclvl
+             , ic_skols  = inst_tyvars
+             , ic_given  = dfun_ev_vars
+             , ic_wanted = mkImplicWC sc_meth_implics
+             , ic_binds  = dfun_ev_binds_var
+             , ic_info   = InstSkol }
+
+       -- Create the result bindings
+       ; self_dict <- newDict clas inst_tys
+       ; let class_tc      = classTyCon clas
+             [dict_constr] = tyConDataCons class_tc
+             dict_bind     = mkVarBind self_dict (L loc con_app_args)
+
+                     -- We don't produce a binding for the dict_constr; instead we
+                     -- rely on the simplifier to unfold this saturated application
+                     -- We do this rather than generate an HsCon directly, because
+                     -- it means that the special cases (e.g. dictionary with only one
+                     -- member) are dealt with by the common MkId.mkDataConWrapId
+                     -- code rather than needing to be repeated here.
+                     --    con_app_tys  = MkD ty1 ty2
+                     --    con_app_scs  = MkD ty1 ty2 sc1 sc2
+                     --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)
+                                  (HsConLikeOut noExt (RealDataCon dict_constr))
+                       -- NB: We *can* have covars in inst_tys, in the case of
+                       -- promoted GADT constructors.
+
+             con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids
+
+             app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
+             app_to_meth fun meth_id = HsApp noExt (L loc fun)
+                                            (L loc (wrapId arg_wrapper meth_id))
+
+             inst_tv_tys = mkTyVarTys inst_tyvars
+             arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
+
+             is_newtype = isNewTyCon class_tc
+             dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
+             dfun_spec_prags
+                | is_newtype = SpecPrags []
+                | otherwise  = SpecPrags spec_inst_prags
+                    -- Newtype dfuns just inline unconditionally,
+                    -- so don't attempt to specialise them
+
+             export = ABE { abe_ext  = noExt
+                          , abe_wrap = idHsWrapper
+                          , abe_poly = dfun_id_w_prags
+                          , abe_mono = self_dict
+                          , abe_prags = dfun_spec_prags }
+                          -- NB: see Note [SPECIALISE instance pragmas]
+             main_bind = AbsBinds { abs_ext = noExt
+                                  , abs_tvs = inst_tyvars
+                                  , abs_ev_vars = dfun_ev_vars
+                                  , abs_exports = [export]
+                                  , abs_ev_binds = []
+                                  , abs_binds = unitBag dict_bind
+                                  , abs_sig = True }
+
+       ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
+       }
+ where
+   dfun_id = instanceDFunId ispec
+   loc     = getSrcSpan dfun_id
+
+addDFunPrags :: DFunId -> [Id] -> DFunId
+-- DFuns need a special Unfolding and InlinePrag
+--    See Note [ClassOp/DFun selection]
+--    and Note [Single-method classes]
+-- It's easiest to create those unfoldings right here, where
+-- have all the pieces in hand, even though we are messing with
+-- Core at this point, which the typechecker doesn't usually do
+-- However we take care to build the unfolding using the TyVars from
+-- the DFunId rather than from the skolem pieces that the typechecker
+-- is messing with.
+addDFunPrags dfun_id sc_meth_ids
+ | is_newtype
+  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity 0 con_app
+            `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+ | otherwise
+ = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args
+           `setInlinePragma` dfunInlinePragma
+ where
+   con_app    = mkLams dfun_bndrs $
+                mkApps (Var (dataConWrapId dict_con)) dict_args
+                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
+                 -- See Note [Levity polymorphism checking] in DsMonad
+   dict_args  = map Type inst_tys ++
+                [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
+
+   (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
+   ev_ids      = mkTemplateLocalsNum 1                    dfun_theta
+   dfun_bndrs  = dfun_tvs ++ ev_ids
+   clas_tc     = classTyCon clas
+   [dict_con]  = tyConDataCons clas_tc
+   is_newtype  = isNewTyCon clas_tc
+
+wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
+wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))
+
+{- Note [Typechecking plan for instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For instance declarations we generate the following bindings and implication
+constraints.  Example:
+
+   instance Ord a => Ord [a] where compare = <compare-rhs>
+
+generates this:
+
+   Bindings:
+      -- Method bindings
+      $ccompare :: forall a. Ord a => a -> a -> Ordering
+      $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
+
+      -- Superclass bindings
+      $cp1Ord :: forall a. Ord a => Eq [a]
+      $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
+               in dfEqList (dw :: Eq a)
+
+   Constraints:
+      forall a. Ord a =>
+                -- Method constraint
+             (forall. (empty) => <constraints from compare-rhs>)
+                -- Superclass constraint
+          /\ (forall. (empty) => dw :: Eq a)
+
+Notice that
+
+ * Per-meth/sc implication.  There is one inner implication per
+   superclass or method, with no skolem variables or givens.  The only
+   reason for this one is to gather the evidence bindings privately
+   for this superclass or method.  This implication is generated
+   by checkInstConstraints.
+
+ * Overall instance implication. There is an overall enclosing
+   implication for the whole instance declaration, with the expected
+   skolems and givens.  We need this to get the correct "redundant
+   constraint" warnings, gathering all the uses from all the methods
+   and superclasses.  See TcSimplify Note [Tracking redundant
+   constraints]
+
+ * The given constraints in the outer implication may generate
+   evidence, notably by superclass selection.  Since the method and
+   superclass bindings are top-level, we want that evidence copied
+   into *every* method or superclass definition.  (Some of it will
+   be usused in some, but dead-code elimination will drop it.)
+
+   We achieve this by putting the evidence variable for the overall
+   instance implication into the AbsBinds for each method/superclass.
+   Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
+   (And that in turn is why the abs_ev_binds field of AbBinds is a
+   [TcEvBinds] rather than simply TcEvBinds.
+
+   This is a bit of a hack, but works very nicely in practice.
+
+ * Note that if a method has a locally-polymorphic binding, there will
+   be yet another implication for that, generated by tcPolyCheck
+   in tcMethodBody. E.g.
+          class C a where
+            foo :: forall b. Ord b => blah
+
+
+************************************************************************
+*                                                                      *
+      Type-checking superclasses
+*                                                                      *
+************************************************************************
+-}
+
+tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
+               -> TcEvBinds
+               -> TcThetaType
+               -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
+-- Make a new top-level function binding for each superclass,
+-- something like
+--    $Ordp1 :: forall a. Ord a => Eq [a]
+--    $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
+--
+-- See Note [Recursive superclasses] for why this is so hard!
+-- In effect, we build a special-purpose solver for the first step
+-- of solving each superclass constraint
+tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
+  = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
+       ; return (ids, listToBag binds, listToBag implics) }
+  where
+    loc = getSrcSpan dfun_id
+    size = sizeTypes inst_tys
+    tc_super (sc_pred, n)
+      = do { (sc_implic, ev_binds_var, sc_ev_tm)
+                <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
+
+           ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))
+           ; sc_ev_id     <- newEvVar sc_pred
+           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
+           ; let sc_top_ty = mkInvForAllTys tyvars $
+                             mkPhiTy (map idType dfun_evs) sc_pred
+                 sc_top_id = mkLocalId sc_top_name sc_top_ty
+                 export = ABE { abe_ext  = noExt
+                              , abe_wrap = idHsWrapper
+                              , abe_poly = sc_top_id
+                              , abe_mono = sc_ev_id
+                              , abe_prags = noSpecPrags }
+                 local_ev_binds = TcEvBinds ev_binds_var
+                 bind = AbsBinds { abs_ext      = noExt
+                                 , abs_tvs      = tyvars
+                                 , abs_ev_vars  = dfun_evs
+                                 , abs_exports  = [export]
+                                 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
+                                 , abs_binds    = emptyBag
+                                 , abs_sig      = False }
+           ; return (sc_top_id, L loc bind, sc_implic) }
+
+-------------------
+checkInstConstraints :: TcM result
+                     -> TcM (Implication, EvBindsVar, result)
+-- See Note [Typechecking plan for instance declarations]
+checkInstConstraints thing_inside
+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints  $
+                                    thing_inside
+
+       ; ev_binds_var <- newTcEvBinds
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = InstSkol }
+
+       ; return (implic', ev_binds_var, result) }
+
+{-
+Note [Recursive superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #3731, #4809, #5751, #5913, #6117, #6161, which all
+describe somewhat more complicated situations, but ones
+encountered in practice.
+
+See also tests tcrun020, tcrun021, tcrun033, and #11427.
+
+----- THE PROBLEM --------
+The problem is that it is all too easy to create a class whose
+superclass is bottom when it should not be.
+
+Consider the following (extreme) situation:
+        class C a => D a where ...
+        instance D [a] => D [a] where ...   (dfunD)
+        instance C [a] => C [a] where ...   (dfunC)
+Although this looks wrong (assume D [a] to prove D [a]), it is only a
+more extreme case of what happens with recursive dictionaries, and it
+can, just about, make sense because the methods do some work before
+recursing.
+
+To implement the dfunD we must generate code for the superclass C [a],
+which we had better not get by superclass selection from the supplied
+argument:
+       dfunD :: forall a. D [a] -> D [a]
+       dfunD = \d::D [a] -> MkD (scsel d) ..
+
+Otherwise if we later encounter a situation where
+we have a [Wanted] dw::D [a] we might solve it thus:
+     dw := dfunD dw
+Which is all fine except that now ** the superclass C is bottom **!
+
+The instance we want is:
+       dfunD :: forall a. D [a] -> D [a]
+       dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
+
+----- THE SOLUTION --------
+The basic solution is simple: be very careful about using superclass
+selection to generate a superclass witness in a dictionary function
+definition.  More precisely:
+
+  Superclass Invariant: in every class dictionary,
+                        every superclass dictionary field
+                        is non-bottom
+
+To achieve the Superclass Invariant, in a dfun definition we can
+generate a guaranteed-non-bottom superclass witness from:
+  (sc1) one of the dictionary arguments itself (all non-bottom)
+  (sc2) an immediate superclass of a smaller dictionary
+  (sc3) a call of a dfun (always returns a dictionary constructor)
+
+The tricky case is (sc2).  We proceed by induction on the size of
+the (type of) the dictionary, defined by TcValidity.sizeTypes.
+Let's suppose we are building a dictionary of size 3, and
+suppose the Superclass Invariant holds of smaller dictionaries.
+Then if we have a smaller dictionary, its immediate superclasses
+will be non-bottom by induction.
+
+What does "we have a smaller dictionary" mean?  It might be
+one of the arguments of the instance, or one of its superclasses.
+Here is an example, taken from CmmExpr:
+       class Ord r => UserOfRegs r a where ...
+(i1)   instance UserOfRegs r a => UserOfRegs r (Maybe a) where
+(i2)   instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+
+For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
+since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
+
+But for (i2) that isn't the case, so we must add an explicit, and
+perhaps surprising, (Ord r) argument to the instance declaration.
+
+Here's another example from #6161:
+
+       class       Super a => Duper a  where ...
+       class Duper (Fam a) => Foo a    where ...
+(i3)   instance Foo a => Duper (Fam a) where ...
+(i4)   instance              Foo Float where ...
+
+It would be horribly wrong to define
+   dfDuperFam :: Foo a -> Duper (Fam a)  -- from (i3)
+   dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
+
+   dfFooFloat :: Foo Float               -- from (i4)
+   dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
+
+Now the Super superclass of Duper is definitely bottom!
+
+This won't happen because when processing (i3) we can use the
+superclasses of (Foo a), which is smaller, namely Duper (Fam a).  But
+that is *not* smaller than the target so we can't take *its*
+superclasses.  As a result the program is rightly rejected, unless you
+add (Super (Fam a)) to the context of (i3).
+
+Note [Solving superclass constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+How do we ensure that every superclass witness is generated by
+one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
+Answer:
+
+  * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
+    where 'size' is the size of the instance declaration. e.g.
+          class C a => D a where...
+          instance blah => D [a] where ...
+    The wanted superclass constraint for C [a] has origin
+    ScOrigin size, where size = size( D [a] ).
+
+  * (sc1) When we rewrite such a wanted constraint, it retains its
+    origin.  But if we apply an instance declaration, we can set the
+    origin to (ScOrigin infinity), thus lifting any restrictions by
+    making prohibitedSuperClassSolve return False.
+
+  * (sc2) ScOrigin wanted constraints can't be solved from a
+    superclass selection, except at a smaller type.  This test is
+    implemented by TcInteract.prohibitedSuperClassSolve
+
+  * The "given" constraints of an instance decl have CtOrigin
+    GivenOrigin InstSkol.
+
+  * When we make a superclass selection from InstSkol we use
+    a SkolemInfo of (InstSC size), where 'size' is the size of
+    the constraint whose superclass we are taking.  A similarly
+    when taking the superclass of an InstSC.  This is implemented
+    in TcCanonical.newSCWorkFromFlavored
+
+Note [Silent superclass arguments] (historical interest only)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB1: this note describes our *old* solution to the
+     recursive-superclass problem. I'm keeping the Note
+     for now, just as institutional memory.
+     However, the code for silent superclass arguments
+     was removed in late Dec 2014
+
+NB2: the silent-superclass solution introduced new problems
+     of its own, in the form of instance overlap.  Tests
+     SilentParametersOverlapping, T5051, and T7862 are examples
+
+NB3: the silent-superclass solution also generated tons of
+     extra dictionaries.  For example, in monad-transformer
+     code, when constructing a Monad dictionary you had to pass
+     an Applicative dictionary; and to construct that you neede
+     a Functor dictionary. Yet these extra dictionaries were
+     often never used.  Test T3064 compiled *far* faster after
+     silent superclasses were eliminated.
+
+Our solution to this problem "silent superclass arguments".  We pass
+to each dfun some ``silent superclass arguments’’, which are the
+immediate superclasses of the dictionary we are trying to
+construct. In our example:
+       dfun :: forall a. C [a] -> D [a] -> D [a]
+       dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
+Notice the extra (dc :: C [a]) argument compared to the previous version.
+
+This gives us:
+
+     -----------------------------------------------------------
+     DFun Superclass Invariant
+     ~~~~~~~~~~~~~~~~~~~~~~~~
+     In the body of a DFun, every superclass argument to the
+     returned dictionary is
+       either   * one of the arguments of the DFun,
+       or       * constant, bound at top level
+     -----------------------------------------------------------
+
+This net effect is that it is safe to treat a dfun application as
+wrapping a dictionary constructor around its arguments (in particular,
+a dfun never picks superclasses from the arguments under the
+dictionary constructor). No superclass is hidden inside a dfun
+application.
+
+The extra arguments required to satisfy the DFun Superclass Invariant
+always come first, and are called the "silent" arguments.  You can
+find out how many silent arguments there are using Id.dfunNSilent;
+and then you can just drop that number of arguments to see the ones
+that were in the original instance declaration.
+
+DFun types are built (only) by MkId.mkDictFunId, so that is where we
+decide what silent arguments are to be added.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+      Type-checking an instance method
+*                                                                      *
+************************************************************************
+
+tcMethod
+- Make the method bindings, as a [(NonRec, HsBinds)], one per method
+- Remembering to use fresh Name (the instance method Name) as the binder
+- Bring the instance method Ids into scope, for the benefit of tcInstSig
+- Use sig_fn mapping instance method Name -> instance tyvars
+- Ditto prag_fn
+- Use tcValBinds to do the checking
+-}
+
+tcMethods :: DFunId -> Class
+          -> [TcTyVar] -> [EvVar]
+          -> [TcType]
+          -> TcEvBinds
+          -> ([Located TcSpecPrag], TcPragEnv)
+          -> [ClassOpItem]
+          -> InstBindings GhcRn
+          -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
+        -- The returned inst_meth_ids all have types starting
+        --      forall tvs. theta => ...
+tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+                  dfun_ev_binds (spec_inst_prags, prag_fn) op_items
+                  (InstBindings { ib_binds      = binds
+                                , ib_tyvars     = lexical_tvs
+                                , ib_pragmas    = sigs
+                                , ib_extensions = exts
+                                , ib_derived    = is_derived })
+  = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
+       -- The lexical_tvs scope over the 'where' part
+    do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
+       ; checkMinimalDefinition
+       ; checkMethBindMembership
+       ; (ids, binds, mb_implics) <- set_exts exts $
+                                     unset_warnings_deriving $
+                                     mapAndUnzip3M tc_item op_items
+       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
+  where
+    set_exts :: [LangExt.Extension] -> TcM a -> TcM a
+    set_exts es thing = foldr setXOptM thing es
+
+    -- See Note [Avoid -Winaccessible-code when deriving]
+    unset_warnings_deriving :: TcM a -> TcM a
+    unset_warnings_deriving
+      | is_derived = unsetWOptM Opt_WarnInaccessibleCode
+      | otherwise  = id
+
+    hs_sig_fn = mkHsSigFun sigs
+    inst_loc  = getSrcSpan dfun_id
+
+    ----------------------
+    tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
+    tc_item (sel_id, dm_info)
+      | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
+      = tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                              dfun_ev_binds is_derived hs_sig_fn
+                              spec_inst_prags prags
+                              sel_id user_bind bndr_loc
+      | otherwise
+      = do { traceTc "tc_def" (ppr sel_id)
+           ; tc_default sel_id dm_info }
+
+    ----------------------
+    tc_default :: Id -> DefMethInfo
+               -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
+
+    tc_default sel_id (Just (dm_name, _))
+      = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
+           ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                          dfun_ev_binds is_derived hs_sig_fn
+                          spec_inst_prags inline_prags
+                          sel_id meth_bind inst_loc }
+
+    tc_default sel_id Nothing     -- No default method at all
+      = do { traceTc "tc_def: warn" (ppr sel_id)
+           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
+                                       inst_tys sel_id
+           ; dflags <- getDynFlags
+           ; let meth_bind = mkVarBind meth_id $
+                             mkLHsWrap lam_wrapper (error_rhs dflags)
+           ; return (meth_id, meth_bind, Nothing) }
+      where
+        error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
+        error_fun    = L inst_loc $
+                       wrapId (mkWpTyApps
+                                [ getRuntimeRep meth_tau, meth_tau])
+                              nO_METHOD_BINDING_ERROR_ID
+        error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText
+                                              (unsafeMkByteString (error_string dflags))))
+        meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)
+        error_string dflags = showSDoc dflags
+                              (hcat [ppr inst_loc, vbar, ppr sel_id ])
+        lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+
+    ----------------------
+    -- Check if one of the minimal complete definitions is satisfied
+    checkMinimalDefinition
+      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
+        warnUnsatisfiedMinimalDefinition
+
+    methodExists meth = isJust (findMethodBind meth binds prag_fn)
+
+    ----------------------
+    -- Check if any method bindings do not correspond to the class.
+    -- See Note [Mismatched class methods and associated type families].
+    checkMethBindMembership
+      = mapM_ (addErrTc . badMethodErr clas) mismatched_meths
+      where
+        bind_nms         = map unLoc $ collectMethodBinders binds
+        cls_meth_nms     = map (idName . fst) op_items
+        mismatched_meths = bind_nms `minusList` cls_meth_nms
+
+{-
+Note [Mismatched class methods and associated type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's entirely possible for someone to put methods or associated type family
+instances inside of a class in which it doesn't belong. For instance, we'd
+want to fail if someone wrote this:
+
+  instance Eq () where
+    type Rep () = Maybe
+    compare = undefined
+
+Since neither the type family `Rep` nor the method `compare` belong to the
+class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
+since that would discover that the parent class `Eq` is incorrect.
+
+However, there is a scenario in which the renamer could fail to catch this:
+if the instance was generated through Template Haskell, as in #12387. In that
+case, Template Haskell will provide fully resolved names (e.g.,
+`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
+on. For this reason, we also put an extra validity check for this in the
+typechecker as a last resort.
+
+Note [Avoid -Winaccessible-code when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Winaccessible-code can be particularly noisy when deriving instances for
+GADTs. Consider the following example (adapted from #8128):
+
+  data T a where
+    MkT1 :: Int -> T Int
+    MkT2 :: T Bool
+    MkT3 :: T Bool
+  deriving instance Eq (T a)
+  deriving instance Ord (T a)
+
+In the derived Ord instance, GHC will generate the following code:
+
+  instance Ord (T a) where
+    compare x y
+      = case x of
+          MkT2
+            -> case y of
+                 MkT1 {} -> GT
+                 MkT2    -> EQ
+                 _       -> LT
+          ...
+
+However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
+differ, so if -Winaccessible-code is enabled, then deriving this instance will
+result in unwelcome warnings.
+
+One conceivable approach to fixing this issue would be to change `deriving Ord`
+such that it becomes smarter about not generating unreachable cases. This,
+however, would be a highly nontrivial refactor, as we'd have to propagate
+through typing information everywhere in the algorithm that generates Ord
+instances in order to determine which cases were unreachable. This seems like
+a lot of work for minimal gain, so we have opted not to go for this approach.
+
+Instead, we take the much simpler approach of always disabling
+-Winaccessible-code for derived code. To accomplish this, we do the following:
+
+1. In tcMethods (which typechecks method bindings), disable
+   -Winaccessible-code.
+2. When creating Implications during typechecking, record the Env
+   (through ic_env) at the time of creation. Since the Env also stores
+   DynFlags, this will remember that -Winaccessible-code was disabled over
+   the scope of that implication.
+3. After typechecking comes error reporting, where GHC must decide how to
+   report inaccessible code to the user, on an Implication-by-Implication
+   basis. If an Implication's DynFlags indicate that -Winaccessible-code was
+   disabled, then don't bother reporting it. That's it!
+-}
+
+------------------------
+tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
+             -> TcEvBinds -> Bool
+             -> HsSigFun
+             -> [LTcSpecPrag] -> [LSig GhcRn]
+             -> Id -> LHsBind GhcRn -> SrcSpan
+             -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
+tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                     dfun_ev_binds is_derived
+                     sig_fn spec_inst_prags prags
+                     sel_id (L bind_loc meth_bind) bndr_loc
+  = add_meth_ctxt $
+    do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
+       ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
+                                            mkMethIds clas tyvars dfun_ev_vars
+                                                      inst_tys sel_id
+
+       ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
+                       -- Substitute the local_meth_name for the binder
+                       -- NB: the binding is always a FunBind
+
+            -- taking instance signature into account might change the type of
+            -- the local_meth_id
+       ; (meth_implic, ev_binds_var, tc_bind)
+             <- checkInstConstraints $
+                tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
+
+       ; global_meth_id <- addInlinePrags global_meth_id prags
+       ; spec_prags     <- tcSpecPrags global_meth_id prags
+
+        ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
+              export = ABE { abe_ext   = noExt
+                           , abe_poly  = global_meth_id
+                           , abe_mono  = local_meth_id
+                           , abe_wrap  = idHsWrapper
+                           , abe_prags = specs }
+
+              local_ev_binds = TcEvBinds ev_binds_var
+              full_bind = AbsBinds { abs_ext      = noExt
+                                   , abs_tvs      = tyvars
+                                   , abs_ev_vars  = dfun_ev_vars
+                                   , abs_exports  = [export]
+                                   , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
+                                   , abs_binds    = tc_bind
+                                   , abs_sig      = True }
+
+        ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
+  where
+        -- For instance decls that come from deriving clauses
+        -- we want to print out the full source code if there's an error
+        -- because otherwise the user won't see the code at all
+    add_meth_ctxt thing
+      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
+      | otherwise  = thing
+
+tcMethodBodyHelp :: HsSigFun -> Id -> TcId
+                 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
+tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
+  | Just hs_sig_ty <- hs_sig_fn sel_name
+              -- There is a signature in the instance
+              -- See Note [Instance method signatures]
+  = do { let ctxt = FunSigCtxt sel_name True
+       ; (sig_ty, hs_wrap)
+             <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
+                do { inst_sigs <- xoptM LangExt.InstanceSigs
+                   ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
+                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
+                   ; let local_meth_ty = idType local_meth_id
+                   ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
+                                tcSubType_NC ctxt sig_ty local_meth_ty
+                   ; return (sig_ty, hs_wrap) }
+
+       ; inner_meth_name <- newName (nameOccName sel_name)
+       ; let inner_meth_id  = mkLocalId inner_meth_name sig_ty
+             inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
+                                          , sig_ctxt = ctxt
+                                          , sig_loc  = getLoc (hsSigType hs_sig_ty) }
+
+
+       ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
+
+       ; let export = ABE { abe_ext   = noExt
+                          , abe_poly  = local_meth_id
+                          , abe_mono  = inner_id
+                          , abe_wrap  = hs_wrap
+                          , abe_prags = noSpecPrags }
+
+       ; return (unitBag $ L (getLoc meth_bind) $
+                 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
+                          , abs_exports = [export]
+                          , abs_binds = tc_bind, abs_ev_binds = []
+                          , abs_sig = True }) }
+
+  | otherwise  -- No instance signature
+  = do { let ctxt = FunSigCtxt sel_name False
+                    -- False <=> don't report redundant constraints
+                    -- The signature is not under the users control!
+             tc_sig = completeSigFromId ctxt local_meth_id
+              -- Absent a type sig, there are no new scoped type variables here
+              -- Only the ones from the instance decl itself, which are already
+              -- in scope.  Example:
+              --      class C a where { op :: forall b. Eq b => ... }
+              --      instance C [c] where { op = <rhs> }
+              -- In <rhs>, 'c' is scope but 'b' is not!
+
+       ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
+       ; return tc_bind }
+
+  where
+    sel_name   = idName sel_id
+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
+                                -- they are all for meth_id
+
+
+------------------------
+mkMethIds :: Class -> [TcTyVar] -> [EvVar]
+          -> [TcType] -> Id -> TcM (TcId, TcId)
+             -- returns (poly_id, local_id), but ignoring any instance signature
+             -- See Note [Instance method signatures]
+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
+  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)
+        ; local_meth_name <- newName sel_occ
+                  -- Base the local_meth_name on the selector name, because
+                  -- type errors from tcMethodBody come from here
+        ; let poly_meth_id  = mkLocalId poly_meth_name  poly_meth_ty
+              local_meth_id = mkLocalId local_meth_name local_meth_ty
+
+        ; return (poly_meth_id, local_meth_id) }
+  where
+    sel_name      = idName sel_id
+    sel_occ       = nameOccName sel_name
+    local_meth_ty = instantiateMethod clas sel_id inst_tys
+    poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty
+    theta         = map idType dfun_ev_vars
+
+methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
+methSigCtxt sel_name sig_ty meth_ty env0
+  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty
+       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
+       ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
+                      2 (vcat [ text "is more general than its signature in the class"
+                              , text "Instance sig:" <+> ppr sig_ty
+                              , text "   Class sig:" <+> ppr meth_ty ])
+       ; return (env2, msg) }
+
+misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
+misplacedInstSig name hs_ty
+  = vcat [ hang (text "Illegal type signature in instance declaration:")
+              2 (hang (pprPrefixName name)
+                    2 (dcolon <+> ppr hs_ty))
+         , text "(Use InstanceSigs to allow this)" ]
+
+{- Note [Instance method signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XInstanceSigs we allow the user to supply a signature for the
+method in an instance declaration.  Here is an artificial example:
+
+       data T a = MkT a
+       instance Ord a => Ord (T a) where
+         (>) :: forall b. b -> b -> Bool
+         (>) = error "You can't compare Ts"
+
+The instance signature can be *more* polymorphic than the instantiated
+class method (in this case: Age -> Age -> Bool), but it cannot be less
+polymorphic.  Moreover, if a signature is given, the implementation
+code should match the signature, and type variables bound in the
+singature should scope over the method body.
+
+We achieve this by building a TcSigInfo for the method, whether or not
+there is an instance method signature, and using that to typecheck
+the declaration (in tcMethodBody).  That means, conveniently,
+that the type variables bound in the signature will scope over the body.
+
+What about the check that the instance method signature is more
+polymorphic than the instantiated class method type?  We just do a
+tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
+this (for the example above
+
+ AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
+         , abs_exports
+             = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
+                        , gr_lcl :: T a -> T a -> Bool }
+         , abs_binds
+             = AbsBind { abs_tvs = [], abs_ev_vars = []
+                       , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
+                                                , gr_inner :: forall b. b -> b -> Bool }
+                       , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
+                                             , ..etc.. }
+               } }
+
+Wow!  Three nested AbsBinds!
+ * The outer one abstracts over the tyvars and dicts for the instance
+ * The middle one is only present if there is an instance signature,
+   and does the impedance matching for that signature
+ * The inner one is for the method binding itself against either the
+   signature from the class, or the instance signature.
+-}
+
+----------------------
+mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
+        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
+        -- There are two sources:
+        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
+        --     These ones have the dfun inside, but [perhaps surprisingly]
+        --     the correct wrapper.
+        -- See Note [Handling SPECIALISE pragmas] in TcBinds
+mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
+  = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
+  where
+    spec_prags_from_inst
+       | isInlinePragma (idInlinePragma meth_id)
+       = []  -- Do not inherit SPECIALISE from the instance if the
+             -- method is marked INLINE, because then it'll be inlined
+             -- and the specialisation would do nothing. (Indeed it'll provoke
+             -- a warning from the desugarer
+       | otherwise
+       = [ L inst_loc (SpecPrag meth_id wrap inl)
+         | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]
+
+
+mkDefMethBind :: Class -> [Type] -> Id -> Name
+              -> TcM (LHsBind GhcRn, [LSig GhcRn])
+-- The is a default method (vanailla or generic) defined in the class
+-- So make a binding   op = $dmop @t1 @t2
+-- where $dmop is the name of the default method in the class,
+-- and t1,t2 are the instance types.
+-- See Note [Default methods in instances] for why we use
+-- visible type application here
+mkDefMethBind clas inst_tys sel_id dm_name
+  = do  { dflags <- getDynFlags
+        ; dm_id <- tcLookupId dm_name
+        ; let inline_prag = idInlinePragma dm_id
+              inline_prags | isAnyInlinePragma inline_prag
+                           = [noLoc (InlineSig noExt fn inline_prag)]
+                           | otherwise
+                           = []
+                 -- Copy the inline pragma (if any) from the default method
+                 -- to this version. Note [INLINE and default methods]
+
+              fn   = noLoc (idName sel_id)
+              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
+                                      , tyConBinderArgFlag tcb /= Inferred ]
+              rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
+              bind = noLoc $ mkTopFunBind Generated fn $
+                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
+
+        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+                   (vcat [ppr clas <+> ppr inst_tys,
+                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+       ; return (bind, inline_prags) }
+  where
+    mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
+    mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy
+                                                $ noLoc $ XHsType $ NHsCoreTy ty))
+       -- NB: use visible type application
+       -- See Note [Default methods in instances]
+
+----------------------
+derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
+derivBindCtxt sel_id clas tys
+   = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
+          , nest 2 (text "in a derived instance for"
+                    <+> quotes (pprClassPred clas tys) <> colon)
+          , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
+
+warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
+warnUnsatisfiedMinimalDefinition mindef
+  = do { warn <- woptM Opt_WarnMissingMethods
+       ; warnTc (Reason Opt_WarnMissingMethods) warn message
+       }
+  where
+    message = vcat [text "No explicit implementation for"
+                   ,nest 2 $ pprBooleanFormulaNice mindef
+                   ]
+
+{-
+Note [Export helper functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange to export the "helper functions" of an instance declaration,
+so that they are not subject to preInlineUnconditionally, even if their
+RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
+the dict fun as Ids, not as CoreExprs, so we can't substitute a
+non-variable for them.
+
+We could change this by making DFunUnfoldings have CoreExprs, but it
+seems a bit simpler this way.
+
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+
+   class Baz v x where
+      foo :: x -> x
+      foo y = <blah>
+
+   instance Baz Int Int
+
+From the class decl we get
+
+   $dmfoo :: forall v x. Baz v x => x -> x
+   $dmfoo y = <blah>
+
+Notice that the type is ambiguous.  So we use Visible Type Application
+to disambiguate:
+
+   $dBazIntInt = MkBaz fooIntInt
+   fooIntInt = $dmfoo @Int @Int
+
+Lacking VTA we'd get ambiguity errors involving the default method.  This applies
+equally to vanilla default methods (#1061) and generic default methods
+(#12220).
+
+Historical note: before we had VTA we had to generate
+post-type-checked code, which took a lot more code, and didn't work for
+generic default methods.
+
+Note [INLINE and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Default methods need special case.  They are supposed to behave rather like
+macros.  For example
+
+  class Foo a where
+    op1, op2 :: Bool -> a -> a
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+  instance Foo Int where
+    -- op1 via default method
+    op2 b x = <blah>
+
+The instance declaration should behave
+
+   just as if 'op1' had been defined with the
+   code, and INLINE pragma, from its original
+   definition.
+
+That is, just as if you'd written
+
+  instance Foo Int where
+    op2 b x = <blah>
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+So for the above example we generate:
+
+  {-# INLINE $dmop1 #-}
+  -- $dmop1 has an InlineCompulsory unfolding
+  $dmop1 d b x = op2 d (not b) x
+
+  $fFooInt = MkD $cop1 $cop2
+
+  {-# INLINE $cop1 #-}
+  $cop1 = $dmop1 $fFooInt
+
+  $cop2 = <blah>
+
+Note carefully:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+  instance $cop1.  Otherwise we'll just inline the former in the
+  latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an
+  unfolding with an InlineCompulsory source. That means
+  that it'll be inlined at every use site, notably in
+  each instance declaration, such as $cop1.  This inlining
+  must happen even though
+    a) $dmop1 is not saturated in $cop1
+    b) $cop1 itself has an INLINE pragma
+
+  It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+  recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+  (which makes the Unfoldings), we use the IsDefaultMethod constructor
+  in TcSpecPrags.
+
+
+************************************************************************
+*                                                                      *
+        Specialise instance pragmas
+*                                                                      *
+************************************************************************
+
+Note [SPECIALISE instance pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   instance (Ix a, Ix b) => Ix (a,b) where
+     {-# SPECIALISE instance Ix (Int,Int) #-}
+     range (x,y) = ...
+
+We make a specialised version of the dictionary function, AND
+specialised versions of each *method*.  Thus we should generate
+something like this:
+
+  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
+  {-# DFUN [$crangePair, ...] #-}
+  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
+  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
+
+  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
+  $crange da db = <blah>
+
+The SPECIALISE pragmas are acted upon by the desugarer, which generate
+
+  dii :: Ix Int
+  dii = ...
+
+  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
+  {-# DFUN [$crangePair di di, ...] #-}
+  $s$dfIxPair = Ix ($crangePair di di) (...)
+
+  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
+
+  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
+  $c$crangePair = ...specialised RHS of $crangePair...
+
+  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
+
+Note that
+
+  * The specialised dictionary $s$dfIxPair is very much needed, in case we
+    call a function that takes a dictionary, but in a context where the
+    specialised dictionary can be used.  See #7797.
+
+  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
+    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
+
+  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
+       --> {ClassOp rule for range}     $crangePair Int Int d1 d2
+       --> {SPEC rule for $crangePair}  $s$crangePair
+    or thus:
+       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
+       --> {ClassOpRule for range}      $s$crangePair
+    It doesn't matter which way.
+
+  * We want to specialise the RHS of both $dfIxPair and $crangePair,
+    but the SAME HsWrapper will do for both!  We can call tcSpecPrag
+    just once, and pass the result (in spec_inst_info) to tcMethods.
+-}
+
+tcSpecInstPrags :: DFunId -> InstBindings GhcRn
+                -> TcM ([Located TcSpecPrag], TcPragEnv)
+tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+                            filter isSpecInstLSig uprags
+             -- The filter removes the pragmas for methods
+       ; return (spec_inst_prags, mkPragEnv uprags binds) }
+
+------------------------------
+tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
+tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
+  = addErrCtxt (spec_ctxt prag) $
+    do  { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
+        ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
+        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
+  where
+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
+
+tcSpecInst _  _ = panic "tcSpecInst"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 hs_inst_ty
+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+instDeclCtxt2 :: Type -> SDoc
+instDeclCtxt2 dfun_ty
+  = inst_decl_ctxt (ppr (mkClassPred cls tys))
+  where
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = hang (text "In the instance declaration for")
+                        2 (quotes doc)
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+  = text "Illegal family instance in hs-boot file"
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
+         , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
+
+assocInClassErr :: TyCon -> SDoc
+assocInClassErr name
+ = text "Associated type" <+> quotes (ppr name) <+>
+   text "must be inside a class instance"
+
+badFamInstDecl :: TyCon -> SDoc
+badFamInstDecl tc_name
+  = vcat [ text "Illegal family instance for" <+>
+           quotes (ppr tc_name)
+         , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
+
+notOpenFamily :: TyCon -> SDoc
+notOpenFamily tc
+  = text "Illegal instance for closed family" <+> quotes (ppr tc)
diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcInstDcls.hs-boot
@@ -0,0 +1,16 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+module TcInstDcls ( tcInstDecls1 ) where
+
+import HsSyn
+import TcRnTypes
+import TcEnv( InstInfo )
+import TcDeriv
+
+-- We need this because of the mutual recursion
+-- between TcTyClsDecls and TcInstDcls
+tcInstDecls1 :: [LInstDecl GhcRn]
+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcInteract.hs
@@ -0,0 +1,2609 @@
+{-# LANGUAGE CPP #-}
+
+module TcInteract (
+     solveSimpleGivens,   -- Solves [Ct]
+     solveSimpleWanteds,  -- Solves Cts
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+import BasicTypes ( SwapFlag(..), isSwapped,
+                    infinity, IntWithInf, intGtLimit )
+import TcCanonical
+import TcFlatten
+import TcUnify( canSolveByUnification )
+import VarSet
+import Type
+import InstEnv( DFunInstType )
+import CoAxiom( sfInteractTop, sfInteractInert )
+
+import Var
+import TcType
+import PrelNames ( coercibleTyConKey,
+                   heqTyConKey, eqTyConKey, ipClassKey )
+import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
+import Class
+import TyCon
+import FunDeps
+import FamInst
+import ClsInst( InstanceWhat(..), safeOverlap )
+import FamInstEnv
+import Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )
+
+import TcEvidence
+import Outputable
+
+import TcRnTypes
+import TcSMonad
+import Bag
+import MonadUtils ( concatMapM, foldlM )
+
+import CoreSyn
+import Data.List( partition, deleteFirstsBy )
+import SrcLoc
+import VarEnv
+
+import Control.Monad
+import Maybes( isJust )
+import Pair (Pair(..))
+import Unique( hasKey )
+import DynFlags
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
+
+{-
+**********************************************************************
+*                                                                    *
+*                      Main Interaction Solver                       *
+*                                                                    *
+**********************************************************************
+
+Note [Basic Simplifier Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1. Pick an element from the WorkList if there exists one with depth
+   less than our context-stack depth.
+
+2. Run it down the 'stage' pipeline. Stages are:
+      - canonicalization
+      - inert reactions
+      - spontaneous reactions
+      - top-level intreactions
+   Each stage returns a StopOrContinue and may have sideffected
+   the inerts or worklist.
+
+   The threading of the stages is as follows:
+      - If (Stop) is returned by a stage then we start again from Step 1.
+      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to
+        the next stage in the pipeline.
+4. If the element has survived (i.e. ContinueWith x) the last stage
+   then we add him in the inerts and jump back to Step 1.
+
+If in Step 1 no such element exists, we have exceeded our context-stack
+depth and will simply fail.
+
+Note [Unflatten after solving the simple wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We unflatten after solving the wc_simples of an implication, and before attempting
+to float. This means that
+
+ * The fsk/fmv flatten-skolems only survive during solveSimples.  We don't
+   need to worry about them across successive passes over the constraint tree.
+   (E.g. we don't need the old ic_fsk field of an implication.
+
+ * When floating an equality outwards, we don't need to worry about floating its
+   associated flattening constraints.
+
+ * Another tricky case becomes easy: #4935
+       type instance F True a b = a
+       type instance F False a b = b
+
+       [w] F c a b ~ gamma
+       (c ~ True) => a ~ gamma
+       (c ~ False) => b ~ gamma
+
+   Obviously this is soluble with gamma := F c a b, and unflattening
+   will do exactly that after solving the simple constraints and before
+   attempting the implications.  Before, when we were not unflattening,
+   we had to push Wanted funeqs in as new givens.  Yuk!
+
+   Another example that becomes easy: indexed_types/should_fail/T7786
+      [W] BuriedUnder sub k Empty ~ fsk
+      [W] Intersect fsk inv ~ s
+      [w] xxx[1] ~ s
+      [W] forall[2] . (xxx[1] ~ Empty)
+                   => Intersect (BuriedUnder sub k Empty) inv ~ Empty
+
+Note [Running plugins on unflattened wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is an annoying mismatch between solveSimpleGivens and
+solveSimpleWanteds, because the latter needs to fiddle with the inert
+set, unflatten and zonk the wanteds.  It passes the zonked wanteds
+to runTcPluginsWanteds, which produces a replacement set of wanteds,
+some additional insolubles and a flag indicating whether to go round
+the loop again.  If so, prepareInertsForImplications is used to remove
+the previous wanteds (which will still be in the inert set).  Note
+that prepareInertsForImplications will discard the insolubles, so we
+must keep track of them separately.
+-}
+
+solveSimpleGivens :: [Ct] -> TcS ()
+solveSimpleGivens givens
+  | null givens  -- Shortcut for common case
+  = return ()
+  | otherwise
+  = do { traceTcS "solveSimpleGivens {" (ppr givens)
+       ; go givens
+       ; traceTcS "End solveSimpleGivens }" empty }
+  where
+    go givens = do { solveSimples (listToBag givens)
+                   ; new_givens <- runTcPluginsGiven
+                   ; when (notNull new_givens) $
+                     go new_givens }
+
+solveSimpleWanteds :: Cts -> TcS WantedConstraints
+-- NB: 'simples' may contain /derived/ equalities, floated
+--     out from a nested implication. So don't discard deriveds!
+-- The result is not necessarily zonked
+solveSimpleWanteds simples
+  = do { traceTcS "solveSimpleWanteds {" (ppr simples)
+       ; dflags <- getDynFlags
+       ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })
+       ; traceTcS "solveSimpleWanteds end }" $
+             vcat [ text "iterations =" <+> ppr n
+                  , text "residual =" <+> ppr wc ]
+       ; return wc }
+  where
+    go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)
+    go n limit wc
+      | n `intGtLimit` limit
+      = failTcS (hang (text "solveSimpleWanteds: too many iterations"
+                       <+> parens (text "limit =" <+> ppr limit))
+                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
+                            , text "Simples =" <+> ppr simples
+                            , text "WC ="      <+> ppr wc ]))
+
+     | isEmptyBag (wc_simple wc)
+     = return (n,wc)
+
+     | otherwise
+     = do { -- Solve
+            (unif_count, wc1) <- solve_simple_wanteds wc
+
+            -- Run plugins
+          ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
+             -- See Note [Running plugins on unflattened wanteds]
+
+          ; if unif_count == 0 && not rerun_plugin
+            then return (n, wc2)             -- Done
+            else do { traceTcS "solveSimple going round again:" $
+                      ppr unif_count $$ ppr rerun_plugin
+                    ; go (n+1) limit wc2 } }      -- Loop
+
+
+solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)
+-- Try solving these constraints
+-- Affects the unification state (of course) but not the inert set
+-- The result is not necessarily zonked
+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 })
+  = nestTcS $
+    do { solveSimples simples1
+       ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts
+       ; (unif_count, unflattened_eqs) <- reportUnifications $
+                                          unflattenWanteds tv_eqs fun_eqs
+            -- See Note [Unflatten after solving the simple wanteds]
+       ; return ( unif_count
+                , WC { wc_simple = others `andCts` unflattened_eqs
+                     , wc_impl   = implics1 `unionBags` implics2 }) }
+
+{- Note [The solveSimpleWanteds loop]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving a bunch of simple constraints is done in a loop,
+(the 'go' loop of 'solveSimpleWanteds'):
+  1. Try to solve them; unflattening may lead to improvement that
+     was not exploitable during solving
+  2. Try the plugin
+  3. If step 1 did improvement during unflattening; or if the plugin
+     wants to run again, go back to step 1
+
+Non-obviously, improvement can also take place during
+the unflattening that takes place in step (1). See TcFlatten,
+See Note [Unflattening can force the solver to iterate]
+-}
+
+-- The main solver loop implements Note [Basic Simplifier Plan]
+---------------------------------------------------------------
+solveSimples :: Cts -> TcS ()
+-- Returns the final InertSet in TcS
+-- Has no effect on work-list or residual-implications
+-- The constraints are initially examined in left-to-right order
+
+solveSimples cts
+  = {-# SCC "solveSimples" #-}
+    do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)
+       ; solve_loop }
+  where
+    solve_loop
+      = {-# SCC "solve_loop" #-}
+        do { sel <- selectNextWorkItem
+           ; case sel of
+              Nothing -> return ()
+              Just ct -> do { runSolverPipeline thePipeline ct
+                            ; solve_loop } }
+
+-- | Extract the (inert) givens and invoke the plugins on them.
+-- Remove solved givens from the inert set and emit insolubles, but
+-- return new work produced so that 'solveSimpleGivens' can feed it back
+-- into the main solver.
+runTcPluginsGiven :: TcS [Ct]
+runTcPluginsGiven
+  = do { plugins <- getTcPlugins
+       ; if null plugins then return [] else
+    do { givens <- getInertGivens
+       ; if null givens then return [] else
+    do { p <- runTcPlugins plugins (givens,[],[])
+       ; let (solved_givens, _, _) = pluginSolvedCts p
+             insols                = pluginBadCts p
+       ; updInertCans (removeInertCts solved_givens)
+       ; updInertIrreds (\irreds -> extendCtsList irreds insols)
+       ; return (pluginNewCts p) } } }
+
+-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on
+-- them and produce an updated bag of wanteds (possibly with some new
+-- work) and a bag of insolubles.  The boolean indicates whether
+-- 'solveSimpleWanteds' should feed the updated wanteds back into the
+-- main solver.
+runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)
+runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 })
+  | isEmptyBag simples1
+  = return (False, wc)
+  | otherwise
+  = do { plugins <- getTcPlugins
+       ; if null plugins then return (False, wc) else
+
+    do { given <- getInertGivens
+       ; simples1 <- zonkSimples simples1    -- Plugin requires zonked inputs
+       ; let (wanted, derived) = partition isWantedCt (bagToList simples1)
+       ; p <- runTcPlugins plugins (given, derived, wanted)
+       ; let (_, _,                solved_wanted)   = pluginSolvedCts p
+             (_, unsolved_derived, unsolved_wanted) = pluginInputCts p
+             new_wanted                             = pluginNewCts p
+             insols                                 = pluginBadCts p
+
+-- SLPJ: I'm deeply suspicious of this
+--       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)
+
+       ; mapM_ setEv solved_wanted
+       ; return ( notNull (pluginNewCts p)
+                , WC { wc_simple = listToBag new_wanted       `andCts`
+                                   listToBag unsolved_wanted  `andCts`
+                                   listToBag unsolved_derived `andCts`
+                                   listToBag insols
+                     , wc_impl   = implics1 } ) } }
+  where
+    setEv :: (EvTerm,Ct) -> TcS ()
+    setEv (ev,ct) = case ctEvidence ct of
+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev
+      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
+
+-- | A triple of (given, derived, wanted) constraints to pass to plugins
+type SplitCts  = ([Ct], [Ct], [Ct])
+
+-- | A solved triple of constraints, with evidence for wanteds
+type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])
+
+-- | Represents collections of constraints generated by typechecker
+-- plugins
+data TcPluginProgress = TcPluginProgress
+    { pluginInputCts  :: SplitCts
+      -- ^ Original inputs to the plugins with solved/bad constraints
+      -- removed, but otherwise unmodified
+    , pluginSolvedCts :: SolvedCts
+      -- ^ Constraints solved by plugins
+    , pluginBadCts    :: [Ct]
+      -- ^ Constraints reported as insoluble by plugins
+    , pluginNewCts    :: [Ct]
+      -- ^ New constraints emitted by plugins
+    }
+
+getTcPlugins :: TcS [TcPluginSolver]
+getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) }
+
+-- | Starting from a triple of (given, derived, wanted) constraints,
+-- invoke each of the typechecker plugins in turn and return
+--
+--  * the remaining unmodified constraints,
+--  * constraints that have been solved,
+--  * constraints that are insoluble, and
+--  * new work.
+--
+-- Note that new work generated by one plugin will not be seen by
+-- other plugins on this pass (but the main constraint solver will be
+-- re-invoked and they will see it later).  There is no check that new
+-- work differs from the original constraints supplied to the plugin:
+-- the plugin itself should perform this check if necessary.
+runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
+runTcPlugins plugins all_cts
+  = foldM do_plugin initialProgress plugins
+  where
+    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
+    do_plugin p solver = do
+        result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))
+        return $ progress p result
+
+    progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress
+    progress p (TcPluginContradiction bad_cts) =
+       p { pluginInputCts = discard bad_cts (pluginInputCts p)
+         , pluginBadCts   = bad_cts ++ pluginBadCts p
+         }
+    progress p (TcPluginOk solved_cts new_cts) =
+      p { pluginInputCts  = discard (map snd solved_cts) (pluginInputCts p)
+        , pluginSolvedCts = add solved_cts (pluginSolvedCts p)
+        , pluginNewCts    = new_cts ++ pluginNewCts p
+        }
+
+    initialProgress = TcPluginProgress all_cts ([], [], []) [] []
+
+    discard :: [Ct] -> SplitCts -> SplitCts
+    discard cts (xs, ys, zs) =
+        (xs `without` cts, ys `without` cts, zs `without` cts)
+
+    without :: [Ct] -> [Ct] -> [Ct]
+    without = deleteFirstsBy eqCt
+
+    eqCt :: Ct -> Ct -> Bool
+    eqCt c c' = ctFlavour c == ctFlavour c'
+             && ctPred c `tcEqType` ctPred c'
+
+    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts
+    add xs scs = foldl' addOne scs xs
+
+    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts
+    addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of
+      CtGiven  {} -> (ct:givens, deriveds, wanteds)
+      CtDerived{} -> (givens, ct:deriveds, wanteds)
+      CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)
+
+
+type WorkItem = Ct
+type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)
+
+runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
+                  -> WorkItem                   -- The work item
+                  -> TcS ()
+-- Run this item down the pipeline, leaving behind new work and inerts
+runSolverPipeline pipeline workItem
+  = do { wl <- getWorkList
+       ; inerts <- getTcSInerts
+       ; tclevel <- getTcLevel
+       ; traceTcS "----------------------------- " empty
+       ; traceTcS "Start solver pipeline {" $
+                  vcat [ text "tclevel =" <+> ppr tclevel
+                       , text "work item =" <+> ppr workItem
+                       , text "inerts =" <+> ppr inerts
+                       , text "rest of worklist =" <+> ppr wl ]
+
+       ; bumpStepCountTcS    -- One step for each constraint processed
+       ; final_res  <- run_pipeline pipeline (ContinueWith workItem)
+
+       ; case final_res of
+           Stop ev s       -> do { traceFireTcS ev s
+                                 ; traceTcS "End solver pipeline (discharged) }" empty
+                                 ; return () }
+           ContinueWith ct -> do { addInertCan ct
+                                 ; traceFireTcS (ctEvidence ct) (text "Kept as inert")
+                                 ; traceTcS "End solver pipeline (kept as inert) }" $
+                                            (text "final_item =" <+> ppr ct) }
+       }
+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct
+                     -> TcS (StopOrContinue Ct)
+        run_pipeline [] res        = return res
+        run_pipeline _ (Stop ev s) = return (Stop ev s)
+        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
+          = do { traceTcS ("runStage " ++ stg_name ++ " {")
+                          (text "workitem   = " <+> ppr ct)
+               ; res <- stg ct
+               ; traceTcS ("end stage " ++ stg_name ++ " }") empty
+               ; run_pipeline stgs res }
+
+{-
+Example 1:
+  Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
+  Reagent: a ~ [b] (given)
+
+React with (c~d)     ==> IR (ContinueWith (a~[b]))  True    []
+React with (F a ~ t) ==> IR (ContinueWith (a~[b]))  False   [F [b] ~ t]
+React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True    []
+
+Example 2:
+  Inert:  {c ~w d, F a ~g t, b ~w Int, a ~w ty}
+  Reagent: a ~w [b]
+
+React with (c ~w d)   ==> IR (ContinueWith (a~[b]))  True    []
+React with (F a ~g t) ==> IR (ContinueWith (a~[b]))  True    []    (can't rewrite given with wanted!)
+etc.
+
+Example 3:
+  Inert:  {a ~ Int, F Int ~ b} (given)
+  Reagent: F a ~ b (wanted)
+
+React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []
+React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing
+-}
+
+thePipeline :: [(String,SimplifierStage)]
+thePipeline = [ ("canonicalization",        TcCanonical.canonicalize)
+              , ("interact with inerts",    interactWithInertsStage)
+              , ("top-level reactions",     topReactionsStage) ]
+
+{-
+*********************************************************************************
+*                                                                               *
+                       The interact-with-inert Stage
+*                                                                               *
+*********************************************************************************
+
+Note [The Solver Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We always add Givens first.  So you might think that the solver has
+the invariant
+
+   If the work-item is Given,
+   then the inert item must Given
+
+But this isn't quite true.  Suppose we have,
+    c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int
+After processing the first two, we get
+     c1: [G] beta ~ [alpha], c2 : [W] blah
+Now, c3 does not interact with the given c1, so when we spontaneously
+solve c3, we must re-react it with the inert set.  So we can attempt a
+reaction between inert c2 [W] and work-item c3 [G].
+
+It *is* true that [Solver Invariant]
+   If the work-item is Given,
+   AND there is a reaction
+   then the inert item must Given
+or, equivalently,
+   If the work-item is Given,
+   and the inert item is Wanted/Derived
+   then there is no reaction
+-}
+
+-- Interaction result of  WorkItem <~> Ct
+
+interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
+-- Precondition: if the workitem is a CTyEqCan then it will not be able to
+-- react with anything at this stage.
+
+interactWithInertsStage wi
+  = do { inerts <- getTcSInerts
+       ; let ics = inert_cans inerts
+       ; case wi of
+             CTyEqCan  {} -> interactTyVarEq ics wi
+             CFunEqCan {} -> interactFunEq   ics wi
+             CIrredCan {} -> interactIrred   ics wi
+             CDictCan  {} -> interactDict    ics wi
+             _ -> pprPanic "interactWithInerts" (ppr wi) }
+                -- CHoleCan are put straight into inert_frozen, so never get here
+                -- CNonCanonical have been canonicalised
+
+data InteractResult
+   = KeepInert   -- Keep the inert item, and solve the work item from it
+                 -- (if the latter is Wanted; just discard it if not)
+   | KeepWork    -- Keep the work item, and solve the intert item from it
+
+instance Outputable InteractResult where
+  ppr KeepInert = text "keep inert"
+  ppr KeepWork  = text "keep work-item"
+
+solveOneFromTheOther :: CtEvidence  -- Inert
+                     -> CtEvidence  -- WorkItem
+                     -> TcS InteractResult
+-- Precondition:
+-- * inert and work item represent evidence for the /same/ predicate
+--
+-- We can always solve one from the other: even if both are wanted,
+-- although we don't rewrite wanteds with wanteds, we can combine
+-- two wanteds into one by solving one from the other
+
+solveOneFromTheOther ev_i ev_w
+  | isDerived ev_w         -- Work item is Derived; just discard it
+  = return KeepInert
+
+  | isDerived ev_i     -- The inert item is Derived, we can just throw it away,
+  = return KeepWork    -- The ev_w is inert wrt earlier inert-set items,
+                       -- so it's safe to continue on from this point
+
+  | CtWanted { ctev_loc = loc_w } <- ev_w
+  , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w
+  = -- inert must be Given
+    do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)
+       ; return KeepWork }
+
+  | CtWanted {} <- ev_w
+       -- Inert is Given or Wanted
+  = return KeepInert
+
+  -- From here on the work-item is Given
+
+  | CtWanted { ctev_loc = loc_i } <- ev_i
+  , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i
+  = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)
+       ; return KeepInert }      -- Just discard the un-usable Given
+                                 -- This never actually happens because
+                                 -- Givens get processed first
+
+  | CtWanted {} <- ev_i
+  = return KeepWork
+
+  -- From here on both are Given
+  -- See Note [Replacement vs keeping]
+
+  | lvl_i == lvl_w
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; binds <- getTcEvBindsMap ev_binds_var
+       ; return (same_level_strategy binds) }
+
+  | otherwise   -- Both are Given, levels differ
+  = return different_level_strategy
+  where
+     pred  = ctEvPred ev_i
+     loc_i = ctEvLoc ev_i
+     loc_w = ctEvLoc ev_w
+     lvl_i = ctLocLevel loc_i
+     lvl_w = ctLocLevel loc_w
+     ev_id_i = ctEvEvId ev_i
+     ev_id_w = ctEvEvId ev_w
+
+     different_level_strategy  -- Both Given
+       | isIPPred pred, lvl_w > lvl_i = KeepWork
+       | lvl_w < lvl_i                = KeepWork
+       | otherwise                    = KeepInert
+
+     same_level_strategy binds -- Both Given
+       | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i
+       = case ctLocOrigin loc_w of
+            GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork
+                                     | otherwise -> KeepInert
+            _                                    -> KeepWork
+
+       | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w
+       = KeepInert
+
+       | has_binding binds ev_id_w
+       , not (has_binding binds ev_id_i)
+       , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))
+       = KeepWork
+
+       | otherwise
+       = KeepInert
+
+     has_binding binds ev_id = isJust (lookupEvBind binds ev_id)
+
+{-
+Note [Replacement vs keeping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have two Given constraints both of type (C tys), say, which should
+we keep?  More subtle than you might think!
+
+  * Constraints come from different levels (different_level_strategy)
+
+      - For implicit parameters we want to keep the innermost (deepest)
+        one, so that it overrides the outer one.
+        See Note [Shadowing of Implicit Parameters]
+
+      - For everything else, we want to keep the outermost one.  Reason: that
+        makes it more likely that the inner one will turn out to be unused,
+        and can be reported as redundant.  See Note [Tracking redundant constraints]
+        in TcSimplify.
+
+        It transpires that using the outermost one is reponsible for an
+        8% performance improvement in nofib cryptarithm2, compared to
+        just rolling the dice.  I didn't investigate why.
+
+  * Constraints coming from the same level (i.e. same implication)
+
+       (a) Always get rid of InstSC ones if possible, since they are less
+           useful for solving.  If both are InstSC, choose the one with
+           the smallest TypeSize
+           See Note [Solving superclass constraints] in TcInstDcls
+
+       (b) Keep the one that has a non-trivial evidence binding.
+              Example:  f :: (Eq a, Ord a) => blah
+              then we may find [G] d3 :: Eq a
+                               [G] d2 :: Eq a
+                with bindings  d3 = sc_sel (d1::Ord a)
+            We want to discard d2 in favour of the superclass selection from
+            the Ord dictionary.
+            Why? See Note [Tracking redundant constraints] in TcSimplify again.
+
+       (c) But don't do (b) if the evidence binding depends transitively on the
+           one without a binding.  Example (with RecursiveSuperClasses)
+              class C a => D a
+              class D a => C a
+           Inert:     d1 :: C a, d2 :: D a
+           Binds:     d3 = sc_sel d2, d2 = sc_sel d1
+           Work item: d3 :: C a
+           Then it'd be ridiculous to replace d1 with d3 in the inert set!
+           Hence the findNeedEvVars test.  See #14774.
+
+  * Finally, when there is still a choice, use KeepInert rather than
+    KeepWork, for two reasons:
+      - to avoid unnecessary munging of the inert set.
+      - to cut off superclass loops; see Note [Superclass loops] in TcCanonical
+
+Doing the depth-check for implicit parameters, rather than making the work item
+always override, is important.  Consider
+
+    data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }
+
+    f :: (?x::a) => T a -> Int
+    f T1 = ?x
+    f T2 = 3
+
+We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add
+two new givens in the work-list:  [G] (?x::Int)
+                                  [G] (a ~ Int)
+Now consider these steps
+  - process a~Int, kicking out (?x::a)
+  - process (?x::Int), the inner given, adding to inert set
+  - process (?x::a), the outer given, overriding the inner given
+Wrong!  The depth-check ensures that the inner implicit parameter wins.
+(Actually I think that the order in which the work-list is processed means
+that this chain of events won't happen, but that's very fragile.)
+
+*********************************************************************************
+*                                                                               *
+                   interactIrred
+*                                                                               *
+*********************************************************************************
+
+Note [Multiple matching irreds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that it's impossible to have multiple irreds all match the
+work item; after all, interactIrred looks for matches and solves one from the
+other. However, note that interacting insoluble, non-droppable irreds does not
+do this matching. We thus might end up with several insoluble, non-droppable,
+matching irreds in the inert set. When another irred comes along that we have
+not yet labeled insoluble, we can find multiple matches. These multiple matches
+cause no harm, but it would be wrong to ASSERT that they aren't there (as we
+once had done). This problem can be tickled by typecheck/should_compile/holes.
+
+-}
+
+-- Two pieces of irreducible evidence: if their types are *exactly identical*
+-- we can rewrite them. We can never improve using this:
+-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
+-- mean that (ty1 ~ ty2)
+interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+
+interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })
+  | insoluble  -- For insolubles, don't allow the constaint to be dropped
+               -- which can happen with solveOneFromTheOther, so that
+               -- we get distinct error messages with -fdefer-type-errors
+               -- See Note [Do not add duplicate derived insolubles]
+  , not (isDroppableCt workItem)
+  = continueWith workItem
+
+  | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
+  , ((ct_i, swap) : _rest) <- bagToList matching_irreds
+        -- See Note [Multiple matching irreds]
+  , let ev_i = ctEvidence ct_i
+  = do { what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)
+       ; case what_next of
+            KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)
+                            ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }
+            KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)
+                            ; updInertIrreds (\_ -> others)
+                            ; continueWith workItem } }
+
+  | otherwise
+  = continueWith workItem
+
+  where
+    swap_me :: SwapFlag -> CtEvidence -> EvTerm
+    swap_me swap ev
+      = case swap of
+           NotSwapped -> ctEvTerm ev
+           IsSwapped  -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev)))
+
+interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
+
+findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct)
+findMatchingIrreds irreds ev
+  | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred
+    -- See Note [Solving irreducible equalities]
+  = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds
+  | otherwise
+  = partitionBagWith match_non_eq irreds
+  where
+    pred = ctEvPred ev
+    match_non_eq ct
+      | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped)
+      | otherwise                            = Right ct
+
+    match_eq eq_rel1 lty1 rty1 ct
+      | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct)
+      , eq_rel1 == eq_rel2
+      , Just swap <- match_eq_help lty1 rty1 lty2 rty2
+      = Left (ct, swap)
+      | otherwise
+      = Right ct
+
+    match_eq_help lty1 rty1 lty2 rty2
+      | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2
+      = Just NotSwapped
+      | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2
+      = Just IsSwapped
+      | otherwise
+      = Nothing
+
+{- Note [Solving irreducible equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#14333)
+  [G] a b ~R# c d
+  [W] c d ~R# a b
+Clearly we should be able to solve this! Even though the constraints are
+not decomposable. We solve this when looking up the work-item in the
+irreducible constraints to look for an identical one.  When doing this
+lookup, findMatchingIrreds spots the equality case, and matches either
+way around. It has to return a swap-flag so we can generate evidence
+that is the right way round too.
+
+Note [Do not add duplicate derived insolubles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we *must* add an insoluble (Int ~ Bool) even if there is
+one such there already, because they may come from distinct call
+sites.  Not only do we want an error message for each, but with
+-fdefer-type-errors we must generate evidence for each.  But for
+*derived* insolubles, we only want to report each one once.  Why?
+
+(a) A constraint (C r s t) where r -> s, say, may generate the same fundep
+    equality many times, as the original constraint is successively rewritten.
+
+(b) Ditto the successive iterations of the main solver itself, as it traverses
+    the constraint tree. See example below.
+
+Also for *given* insolubles we may get repeated errors, as we
+repeatedly traverse the constraint tree.  These are relatively rare
+anyway, so removing duplicates seems ok.  (Alternatively we could take
+the SrcLoc into account.)
+
+Note that the test does not need to be particularly efficient because
+it is only used if the program has a type error anyway.
+
+Example of (b): assume a top-level class and instance declaration:
+
+  class D a b | a -> b
+  instance D [a] [a]
+
+Assume we have started with an implication:
+
+  forall c. Eq c => { wc_simple = D [c] c [W] }
+
+which we have simplified to:
+
+  forall c. Eq c => { wc_simple = D [c] c [W]
+                                  (c ~ [c]) [D] }
+
+For some reason, e.g. because we floated an equality somewhere else,
+we might try to re-solve this implication. If we do not do a
+dropDerivedWC, then we will end up trying to solve the following
+constraints the second time:
+
+  (D [c] c) [W]
+  (c ~ [c]) [D]
+
+which will result in two Deriveds to end up in the insoluble set:
+
+  wc_simple   = D [c] c [W]
+               (c ~ [c]) [D], (c ~ [c]) [D]
+-}
+
+{-
+*********************************************************************************
+*                                                                               *
+                   interactDict
+*                                                                               *
+*********************************************************************************
+
+Note [Shortcut solving]
+~~~~~~~~~~~~~~~~~~~~~~~
+When we interact a [W] constraint with a [G] constraint that solves it, there is
+a possibility that we could produce better code if instead we solved from a
+top-level instance declaration (See #12791, #5835). For example:
+
+    class M a b where m :: a -> b
+
+    type C a b = (Num a, M a b)
+
+    f :: C Int b => b -> Int -> Int
+    f _ x = x + 1
+
+The body of `f` requires a [W] `Num Int` instance. We could solve this
+constraint from the givens because we have `C Int b` and that provides us a
+solution for `Num Int`. This would let us produce core like the following
+(with -O2):
+
+    f :: forall b. C Int b => b -> Int -> Int
+    f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) ->
+        + @ Int
+          (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))
+          eta1
+          A.f1
+
+This is bad! We could do /much/ better if we solved [W] `Num Int` directly
+from the instance that we have in scope:
+
+    f :: forall b. C Int b => b -> Int -> Int
+    f = \ (@ b) _ _ (x :: Int) ->
+        case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }
+
+** NB: It is important to emphasize that all this is purely an optimization:
+** exactly the same programs should typecheck with or without this
+** procedure.
+
+Solving fully
+~~~~~~~~~~~~~
+There is a reason why the solver does not simply try to solve such
+constraints with top-level instances. If the solver finds a relevant
+instance declaration in scope, that instance may require a context
+that can't be solved for. A good example of this is:
+
+    f :: Ord [a] => ...
+    f x = ..Need Eq [a]...
+
+If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would
+be left with the obligation to solve the constraint Eq a, which we cannot. So we
+must be conservative in our attempt to use an instance declaration to solve the
+[W] constraint we're interested in.
+
+Our rule is that we try to solve all of the instance's subgoals
+recursively all at once. Precisely: We only attempt to solve
+constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci
+are themselves class constraints of the form `C1', ... Cm' => C' t1'
+... tn'` and we only succeed if the entire tree of constraints is
+solvable from instances.
+
+An example that succeeds:
+
+    class Eq a => C a b | b -> a where
+      m :: b -> a
+
+    f :: C [Int] b => b -> Bool
+    f x = m x == []
+
+We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This
+produces the following core:
+
+    f :: forall b. C [Int] b => b -> Bool
+    f = \ (@ b) ($dC :: C [Int] b) (x :: b) ->
+        GHC.Classes.$fEq[]_$s$c==
+          (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)
+
+An example that fails:
+
+    class Eq a => C a b | b -> a where
+      m :: b -> a
+
+    f :: C [a] b => b -> Bool
+    f x = m x == []
+
+Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:
+
+    f :: forall a b. C [a] b => b -> Bool
+    f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->
+        ==
+          @ [a]
+          (A.$p1C @ [a] @ b $dC)
+          (m @ [a] @ b $dC eta)
+          (GHC.Types.[] @ a)
+
+Note [Shortcut solving: type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have (#13943)
+  class Take (n :: Nat) where ...
+  instance {-# OVERLAPPING #-}                    Take 0 where ..
+  instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..
+
+And we have [W] Take 3.  That only matches one instance so we get
+[W] Take (3-1).  Really we should now flatten to reduce the (3-1) to 2, and
+so on -- but that is reproducing yet more of the solver.  Sigh.  For now,
+we just give up (remember all this is just an optimisation).
+
+But we must not just naively try to lookup (Take (3-1)) in the
+InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a
+unique match on the (Take n) instance.  That leads immediately to an
+infinite loop.  Hence the check that 'preds' have no type families
+(isTyFamFree).
+
+Note [Shortcut solving: incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This optimization relies on coherence of dictionaries to be correct. When we
+cannot assume coherence because of IncoherentInstances then this optimization
+can change the behavior of the user's code.
+
+The following four modules produce a program whose output would change depending
+on whether we apply this optimization when IncoherentInstances is in effect:
+
+#########
+    {-# LANGUAGE MultiParamTypeClasses #-}
+    module A where
+
+    class A a where
+      int :: a -> Int
+
+    class A a => C a b where
+      m :: b -> a -> a
+
+#########
+    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+    module B where
+
+    import A
+
+    instance A a where
+      int _ = 1
+
+    instance C a [b] where
+      m _ = id
+
+#########
+    {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
+    {-# LANGUAGE IncoherentInstances #-}
+    module C where
+
+    import A
+
+    instance A Int where
+      int _ = 2
+
+    instance C Int [Int] where
+      m _ = id
+
+    intC :: C Int a => a -> Int -> Int
+    intC _ x = int x
+
+#########
+    module Main where
+
+    import A
+    import B
+    import C
+
+    main :: IO ()
+    main = print (intC [] (0::Int))
+
+The output of `main` if we avoid the optimization under the effect of
+IncoherentInstances is `1`. If we were to do the optimization, the output of
+`main` would be `2`.
+
+Note [Shortcut try_solve_from_instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The workhorse of the short-cut solver is
+    try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
+                            -> CtEvidence       -- Solve this
+                            -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+Note that:
+
+* The CtEvidence is the goal to be solved
+
+* The MaybeT anages early failure if we find a subgoal that
+  cannot be solved from instances.
+
+* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
+  state that allows try_solve_from_instance to augmennt the evidence
+  bindings and inert_solved_dicts as it goes.
+
+  If it succeeds, we commit all these bindings and solved dicts to the
+  main TcS InertSet.  If not, we abandon it all entirely.
+
+Passing along the solved_dicts important for two reasons:
+
+* We need to be able to handle recursive super classes. The
+  solved_dicts state  ensures that we remember what we have already
+  tried to solve to avoid looping.
+
+* As #15164 showed, it can be important to exploit sharing between
+  goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;
+  and to solve G2 we may need H. If we don't spot this sharing we may
+  solve H twice; and if this pattern repeats we may get exponentially bad
+  behaviour.
+-}
+
+interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
+  | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
+  = -- There is a matching dictionary in the inert set
+    do { -- First to try to solve it /completely/ from top level instances
+         -- See Note [Shortcut solving]
+         dflags <- getDynFlags
+       ; short_cut_worked <- shortCutSolver dflags ev_w ev_i
+       ; if short_cut_worked
+         then stopWith ev_w "interactDict/solved from instance"
+         else
+
+    do { -- Ths short-cut solver didn't fire, so we
+         -- solve ev_w from the matching inert ev_i we found
+         what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "lookupInertDict" (ppr what_next)
+       ; case what_next of
+           KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
+                           ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
+           KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)
+                           ; updInertDicts $ \ ds -> delDict ds cls tys
+                           ; continueWith workItem } } }
+
+  | cls `hasKey` ipClassKey
+  , isGiven ev_w
+  = interactGivenIP inerts workItem
+
+  | otherwise
+  = do { addFunDepWork inerts ev_w cls
+       ; continueWith workItem  }
+
+interactDict _ wi = pprPanic "interactDict" (ppr wi)
+
+-- See Note [Shortcut solving]
+shortCutSolver :: DynFlags
+               -> CtEvidence -- Work item
+               -> CtEvidence -- Inert we want to try to replace
+               -> TcS Bool   -- True <=> success
+shortCutSolver dflags ev_w ev_i
+  | isWanted ev_w
+ && isGiven ev_i
+ -- We are about to solve a [W] constraint from a [G] constraint. We take
+ -- a moment to see if we can get a better solution using an instance.
+ -- Note that we only do this for the sake of performance. Exactly the same
+ -- programs should typecheck regardless of whether we take this step or
+ -- not. See Note [Shortcut solving]
+
+ && not (xopt LangExt.IncoherentInstances dflags)
+ -- If IncoherentInstances is on then we cannot rely on coherence of proofs
+ -- in order to justify this optimization: The proof provided by the
+ -- [G] constraint's superclass may be different from the top-level proof.
+ -- See Note [Shortcut solving: incoherence]
+
+ && gopt Opt_SolveConstantDicts dflags
+ -- Enabled by the -fsolve-constant-dicts flag
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
+                     getTcEvBindsMap ev_binds_var
+       ; solved_dicts <- getSolvedDicts
+
+       ; mb_stuff <- runMaybeT $ try_solve_from_instance
+                                   (ev_binds, solved_dicts) ev_w
+
+       ; case mb_stuff of
+           Nothing -> return False
+           Just (ev_binds', solved_dicts')
+              -> do { setTcEvBindsMap ev_binds_var ev_binds'
+                    ; setSolvedDicts solved_dicts'
+                    ; return True } }
+
+  | otherwise
+  = return False
+  where
+    -- This `CtLoc` is used only to check the well-staged condition of any
+    -- candidate DFun. Our subgoals all have the same stage as our root
+    -- [W] constraint so it is safe to use this while solving them.
+    loc_w = ctEvLoc ev_w
+
+    try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]
+      :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
+      -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+    try_solve_from_instance (ev_binds, solved_dicts) ev
+      | let pred = ctEvPred ev
+            loc  = ctEvLoc  ev
+      , ClassPred cls tys <- classifyPredType pred
+      = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
+           ; case inst_res of
+               OneInst { cir_new_theta = preds
+                       , cir_mk_ev     = mk_ev
+                       , cir_what      = what }
+                 | safeOverlap what
+                 , all isTyFamFree preds  -- Note [Shortcut solving: type families]
+                 -> do { let solved_dicts' = addDict solved_dicts cls tys ev
+                             -- solved_dicts': it is important that we add our goal
+                             -- to the cache before we solve! Otherwise we may end
+                             -- up in a loop while solving recursive dictionaries.
+
+                       ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
+                       ; loc' <- lift $ checkInstanceOK loc what pred
+
+                       ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds
+                                  -- Emit work for subgoals but use our local cache
+                                  -- so we can solve recursive dictionaries.
+
+                       ; let ev_tm     = mk_ev (map getEvExpr evc_vs)
+                             ev_binds' = extendEvBinds ev_binds $
+                                         mkWantedEvBind (ctEvEvId ev) ev_tm
+
+                       ; foldlM try_solve_from_instance
+                                (ev_binds', solved_dicts')
+                                (freshGoals evc_vs) }
+
+               _ -> mzero }
+      | otherwise = mzero
+
+
+    -- Use a local cache of solved dicts while emitting EvVars for new work
+    -- We bail out of the entire computation if we need to emit an EvVar for
+    -- a subgoal that isn't a ClassPred.
+    new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
+    new_wanted_cached loc cache pty
+      | ClassPred cls tys <- classifyPredType pty
+      = lift $ case findDict cache loc_w cls tys of
+          Just ctev -> return $ Cached (ctEvExpr ctev)
+          Nothing   -> Fresh <$> newWantedNC loc pty
+      | otherwise = mzero
+
+addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
+-- Add derived constraints from type-class functional dependencies.
+addFunDepWork inerts work_ev cls
+  | isImprovable work_ev
+  = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)
+               -- No need to check flavour; fundeps work between
+               -- any pair of constraints, regardless of flavour
+               -- Importantly we don't throw workitem back in the
+               -- worklist because this can cause loops (see #5236)
+  | otherwise
+  = return ()
+  where
+    work_pred = ctEvPred work_ev
+    work_loc  = ctEvLoc work_ev
+
+    add_fds inert_ct
+      | isImprovable inert_ev
+      = do { traceTcS "addFunDepWork" (vcat
+                [ ppr work_ev
+                , pprCtLoc work_loc, ppr (isGivenLoc work_loc)
+                , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
+                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;
+
+        emitFunDepDeriveds $
+        improveFromAnother derived_loc inert_pred work_pred
+               -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
+               -- NB: We do create FDs for given to report insoluble equations that arise
+               -- from pairs of Givens, and also because of floating when we approximate
+               -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
+        }
+      | otherwise
+      = return ()
+      where
+        inert_ev   = ctEvidence inert_ct
+        inert_pred = ctEvPred inert_ev
+        inert_loc  = ctEvLoc inert_ev
+        derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`
+                                              ctl_depth inert_loc
+                               , ctl_origin = FunDepOrigin1 work_pred  work_loc
+                                                            inert_pred inert_loc }
+
+{-
+**********************************************************************
+*                                                                    *
+                   Implicit parameters
+*                                                                    *
+**********************************************************************
+-}
+
+interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- Work item is Given (?x:ty)
+-- See Note [Shadowing of Implicit Parameters]
+interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
+                                          , cc_tyargs = tys@(ip_str:_) })
+  = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }
+       ; stopWith ev "Given IP" }
+  where
+    dicts           = inert_dicts inerts
+    ip_dicts        = findDictsByClass dicts cls
+    other_ip_dicts  = filterBag (not . is_this_ip) ip_dicts
+    filtered_dicts  = addDictsByClass dicts cls other_ip_dicts
+
+    -- Pick out any Given constraints for the same implicit parameter
+    is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ })
+       = isGiven ev && ip_str `tcEqType` ip_str'
+    is_this_ip _ = False
+
+interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
+
+{- Note [Shadowing of Implicit Parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example:
+
+f :: (?x :: Char) => Char
+f = let ?x = 'a' in ?x
+
+The "let ?x = ..." generates an implication constraint of the form:
+
+?x :: Char => ?x :: Char
+
+Furthermore, the signature for `f` also generates an implication
+constraint, so we end up with the following nested implication:
+
+?x :: Char => (?x :: Char => ?x :: Char)
+
+Note that the wanted (?x :: Char) constraint may be solved in
+two incompatible ways:  either by using the parameter from the
+signature, or by using the local definition.  Our intention is
+that the local definition should "shadow" the parameter of the
+signature, and we implement this as follows: when we add a new
+*given* implicit parameter to the inert set, it replaces any existing
+givens for the same implicit parameter.
+
+Similarly, consider
+   f :: (?x::a) => Bool -> a
+
+   g v = let ?x::Int = 3
+         in (f v, let ?x::Bool = True in f v)
+
+This should probably be well typed, with
+   g :: Bool -> (Int, Bool)
+
+So the inner binding for ?x::Bool *overrides* the outer one.
+
+All this works for the normal cases but it has an odd side effect in
+some pathological programs like this:
+-- This is accepted, the second parameter shadows
+f1 :: (?x :: Int, ?x :: Char) => Char
+f1 = ?x
+
+-- This is rejected, the second parameter shadows
+f2 :: (?x :: Int, ?x :: Char) => Int
+f2 = ?x
+
+Both of these are actually wrong:  when we try to use either one,
+we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char),
+which would lead to an error.
+
+I can think of two ways to fix this:
+
+  1. Simply disallow multiple constraints for the same implicit
+    parameter---this is never useful, and it can be detected completely
+    syntactically.
+
+  2. Move the shadowing machinery to the location where we nest
+     implications, and add some code here that will produce an
+     error if we get multiple givens for the same implicit parameter.
+
+
+**********************************************************************
+*                                                                    *
+                   interactFunEq
+*                                                                    *
+**********************************************************************
+-}
+
+interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- Try interacting the work item with the inert set
+interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc
+                                          , cc_tyargs = args, cc_fsk = fsk })
+  | Just inert_ct@(CFunEqCan { cc_ev = ev_i
+                             , cc_fsk = fsk_i })
+         <- findFunEq (inert_funeqs inerts) tc args
+  , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev
+  = do { traceTcS "reactFunEq (rewrite inert item):" $
+         vcat [ text "work_item =" <+> ppr work_item
+              , text "inertItem=" <+> ppr ev_i
+              , text "(swap_flag, upgrade)" <+> ppr pr ]
+       ; if isSwapped swap_flag
+         then do {   -- Rewrite inert using work-item
+                   let work_item' | upgrade_flag = upgradeWanted work_item
+                                  | otherwise    = work_item
+                 ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'
+                      -- Do the updInertFunEqs before the reactFunEq, so that
+                      -- we don't kick out the inertItem as well as consuming it!
+                 ; reactFunEq ev fsk ev_i fsk_i
+                 ; stopWith ev "Work item rewrites inert" }
+         else do {   -- Rewrite work-item using inert
+                 ; when upgrade_flag $
+                   updInertFunEqs $ \ feqs -> insertFunEq feqs tc args
+                                                 (upgradeWanted inert_ct)
+                 ; reactFunEq ev_i fsk_i ev fsk
+                 ; stopWith ev "Inert rewrites work item" } }
+
+  | otherwise   -- Try improvement
+  = do { improveLocalFunEqs ev inerts tc args fsk
+       ; continueWith work_item }
+
+interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)
+
+upgradeWanted :: Ct -> Ct
+-- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2
+-- so upgrade the [W] to [WD] before putting it in the inert set
+upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }
+  where
+    upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )
+                    ev { ctev_nosh = WDeriv }
+
+improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar
+                   -> TcS ()
+-- Generate derived improvement equalities, by comparing
+-- the current work item with inert CFunEqs
+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'
+--
+-- See Note [FunDep and implicit parameter reactions]
+improveLocalFunEqs work_ev inerts fam_tc args fsk
+  | isGiven work_ev -- See Note [No FunEq improvement for Givens]
+    || not (isImprovable work_ev)
+  = return ()
+
+  | not (null improvement_eqns)
+  = do { traceTcS "interactFunEq improvements: " $
+         vcat [ text "Eqns:" <+> ppr improvement_eqns
+              , text "Candidates:" <+> ppr funeqs_for_tc
+              , text "Inert eqs:" <+> ppr ieqs ]
+       ; emitFunDepDeriveds improvement_eqns }
+
+  | otherwise
+  = return ()
+
+  where
+    ieqs          = inert_eqs inerts
+    funeqs        = inert_funeqs inerts
+    funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc
+    rhs           = lookupFlattenTyVar ieqs fsk
+    work_loc      = ctEvLoc work_ev
+    work_pred     = ctEvPred work_ev
+    fam_inj_info  = tyConInjectivityInfo fam_tc
+
+    --------------------
+    improvement_eqns :: [FunDepEqn CtLoc]
+    improvement_eqns
+      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+      =    -- Try built-in families, notably for arithmethic
+         concatMap (do_one_built_in ops) funeqs_for_tc
+
+      | Injective injective_args <- fam_inj_info
+      =    -- Try improvement from type families with injectivity annotations
+        concatMap (do_one_injective injective_args) funeqs_for_tc
+
+      | otherwise
+      = []
+
+    --------------------
+    do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })
+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs
+                                             (lookupFlattenTyVar ieqs ifsk))
+
+    do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)
+
+    --------------------
+    -- See Note [Type inference for type families with injectivity]
+    do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args
+                                         , cc_fsk = ifsk, cc_ev = inert_ev })
+      | isImprovable inert_ev
+      , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk
+      = mk_fd_eqns inert_ev $
+            [ Pair arg iarg
+            | (arg, iarg, True) <- zip3 args inert_args inj_args ]
+      | otherwise
+      = []
+
+    do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)
+
+    --------------------
+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]
+    mk_fd_eqns inert_ev eqns
+      | null eqns  = []
+      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
+                             , fd_pred1 = work_pred
+                             , fd_pred2 = ctEvPred inert_ev
+                             , fd_loc   = loc } ]
+      where
+        inert_loc = ctEvLoc inert_ev
+        loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
+                                      ctl_depth work_loc }
+
+-------------
+reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1
+           -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2
+           -> TcS ()
+reactFunEq from_this fsk1 solve_this fsk2
+  = do { traceTcS "reactFunEq"
+            (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])
+       ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
+       ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$
+                                     ppr solve_this $$ ppr fsk2) }
+
+{- Note [Type inference for type families with injectivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a type family with an injectivity annotation:
+    type family F a b = r | r -> b
+
+Then if we have two CFunEqCan constraints for F with the same RHS
+   F s1 t1 ~ rhs
+   F s2 t2 ~ rhs
+then we can use the injectivity to get a new Derived constraint on
+the injective argument
+  [D] t1 ~ t2
+
+That in turn can help GHC solve constraints that would otherwise require
+guessing.  For example, consider the ambiguity check for
+   f :: F Int b -> Int
+We get the constraint
+   [W] F Int b ~ F Int beta
+where beta is a unification variable.  Injectivity lets us pick beta ~ b.
+
+Injectivity information is also used at the call sites. For example:
+   g = f True
+gives rise to
+   [W] F Int b ~ Bool
+from which we can derive b.  This requires looking at the defining equations of
+a type family, ie. finding equation with a matching RHS (Bool in this example)
+and infering values of type variables (b in this example) from the LHS patterns
+of the matching equation.  For closed type families we have to perform
+additional apartness check for the selected equation to check that the selected
+is guaranteed to fire for given LHS arguments.
+
+These new constraints are simply *Derived* constraints; they have no evidence.
+We could go further and offer evidence from decomposing injective type-function
+applications, but that would require new evidence forms, and an extension to
+FC, so we don't do that right now (Dec 14).
+
+See also Note [Injective type families] in TyCon
+
+
+Note [Cache-caused loops]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
+solved cache (which is the default behaviour or xCtEvidence), because the interaction
+may not be contributing towards a solution. Here is an example:
+
+Initial inert set:
+  [W] g1 : F a ~ beta1
+Work item:
+  [W] g2 : F a ~ beta2
+The work item will react with the inert yielding the _same_ inert set plus:
+    (i)   Will set g2 := g1 `cast` g3
+    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
+    (iii) Will emit [W] g3 : beta1 ~ beta2
+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
+will set
+      g1 := g ; sym g3
+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
+remember that we have this in our solved cache, and it is ... g2! In short we
+created the evidence loop:
+
+        g2 := g1 ; g3
+        g3 := refl
+        g1 := g2 ; sym g3
+
+To avoid this situation we do not cache as solved any workitems (or inert)
+which did not really made a 'step' towards proving some goal. Solved's are
+just an optimization so we don't lose anything in terms of completeness of
+solving.
+
+
+Note [Efficient Orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are interacting two FunEqCans with the same LHS:
+          (inert)  ci :: (F ty ~ xi_i)
+          (work)   cw :: (F ty ~ xi_w)
+We prefer to keep the inert (else we pass the work item on down
+the pipeline, which is a bit silly).  If we keep the inert, we
+will (a) discharge 'cw'
+     (b) produce a new equality work-item (xi_w ~ xi_i)
+Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):
+    new_work :: xi_w ~ xi_i
+    cw := ci ; sym new_work
+Why?  Consider the simplest case when xi1 is a type variable.  If
+we generate xi1~xi2, porcessing that constraint will kick out 'ci'.
+If we generate xi2~xi1, there is less chance of that happening.
+Of course it can and should still happen if xi1=a, xi1=Int, say.
+But we want to avoid it happening needlessly.
+
+Similarly, if we *can't* keep the inert item (because inert is Wanted,
+and work is Given, say), we prefer to orient the new equality (xi_i ~
+xi_w).
+
+Note [Carefully solve the right CFunEqCan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   ---- OLD COMMENT, NOW NOT NEEDED
+   ---- because we now allow multiple
+   ---- wanted FunEqs with the same head
+Consider the constraints
+  c1 :: F Int ~ a      -- Arising from an application line 5
+  c2 :: F Int ~ Bool   -- Arising from an application line 10
+Suppose that 'a' is a unification variable, arising only from
+flattening.  So there is no error on line 5; it's just a flattening
+variable.  But there is (or might be) an error on line 10.
+
+Two ways to combine them, leaving either (Plan A)
+  c1 :: F Int ~ a      -- Arising from an application line 5
+  c3 :: a ~ Bool       -- Arising from an application line 10
+or (Plan B)
+  c2 :: F Int ~ Bool   -- Arising from an application line 10
+  c4 :: a ~ Bool       -- Arising from an application line 5
+
+Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error
+on the *totally innocent* line 5.  An example is test SimpleFail16
+where the expected/actual message comes out backwards if we use
+the wrong plan.
+
+The second is the right thing to do.  Hence the isMetaTyVarTy
+test when solving pairwise CFunEqCan.
+
+
+**********************************************************************
+*                                                                    *
+                   interactTyVarEq
+*                                                                    *
+**********************************************************************
+-}
+
+inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole
+                   -> Maybe ( CtEvidence  -- The evidence for the inert
+                            , SwapFlag    -- Whether we need mkSymCo
+                            , Bool)       -- True <=> keep a [D] version
+                                          --          of the [WD] constraint
+inertsCanDischarge inerts tv rhs fr
+  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                    , cc_eq_rel = eq_rel }
+                             <- findTyEqs inerts tv
+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
+                         , rhs_i `tcEqType` rhs ]
+  =  -- Inert:     a ~ ty
+     -- Work item: a ~ ty
+    Just (ev_i, NotSwapped, keep_deriv ev_i)
+
+  | Just tv_rhs <- getTyVar_maybe rhs
+  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                    , cc_eq_rel = eq_rel }
+                             <- findTyEqs inerts tv_rhs
+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
+                         , rhs_i `tcEqType` mkTyVarTy tv ]
+  =  -- Inert:     a ~ b
+     -- Work item: b ~ a
+     Just (ev_i, IsSwapped, keep_deriv ev_i)
+
+  | otherwise
+  = Nothing
+
+  where
+    keep_deriv ev_i
+      | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]
+      , (Wanted WDeriv, _) <- fr           -- work item is [WD]
+      = True   -- Keep a derived verison of the work item
+      | otherwise
+      = False  -- Work item is fully discharged
+
+interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- CTyEqCans are always consumed, so always returns Stop
+interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
+                                          , cc_rhs = rhs
+                                          , cc_ev = ev
+                                          , cc_eq_rel = eq_rel })
+  | Just (ev_i, swapped, keep_deriv)
+       <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)
+  = do { setEvBindIfWanted ev $
+         evCoercion (maybeSym swapped $
+                     tcDowngradeRole (eqRelRole eq_rel)
+                                     (ctEvRole ev_i)
+                                     (ctEvCoercion ev_i))
+
+       ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev
+                                  , ctev_loc  = ctEvLoc  ev }
+       ; when keep_deriv $
+         emitWork [workItem { cc_ev = deriv_ev }]
+         -- As a Derived it might not be fully rewritten,
+         -- so we emit it as new work
+
+       ; stopWith ev "Solved from inert" }
+
+  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]
+  = do { traceTcS "Not unifying representational equality" (ppr workItem)
+       ; continueWith workItem }
+
+  | isGiven ev         -- See Note [Touchables and givens]
+  = continueWith workItem
+
+  | otherwise
+  = do { tclvl <- getTcLevel
+       ; if canSolveByUnification tclvl tv rhs
+         then do { solveByUnification ev tv rhs
+                 ; n_kicked <- kickOutAfterUnification tv
+                 ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
+
+         else continueWith workItem }
+
+interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
+
+solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
+-- Solve with the identity coercion
+-- Precondition: kind(xi) equals kind(tv)
+-- Precondition: CtEvidence is Wanted or Derived
+-- Precondition: CtEvidence is nominal
+-- Returns: workItem where
+--        workItem = the new Given constraint
+--
+-- NB: No need for an occurs check here, because solveByUnification always
+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariants
+--     say that in (a ~ xi), the type variable a does not appear in xi.
+--     See TcRnTypes.Ct invariants.
+--
+-- Post: tv is unified (by side effect) with xi;
+--       we often write tv := xi
+solveByUnification wd tv xi
+  = do { let tv_ty = mkTyVarTy tv
+       ; traceTcS "Sneaky unification:" $
+                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,
+                             text "Coercion:" <+> pprEq tv_ty xi,
+                             text "Left Kind is:" <+> ppr (tcTypeKind tv_ty),
+                             text "Right Kind is:" <+> ppr (tcTypeKind xi) ]
+
+       ; unifyTyVar tv xi
+       ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }
+
+{- Note [Avoid double unifications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The spontaneous solver has to return a given which mentions the unified unification
+variable *on the left* of the equality. Here is what happens if not:
+  Original wanted:  (a ~ alpha),  (alpha ~ Int)
+We spontaneously solve the first wanted, without changing the order!
+      given : a ~ alpha      [having unified alpha := a]
+Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.
+At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]
+
+We avoid this problem by orienting the resulting given so that the unification
+variable is on the left.  [Note that alternatively we could attempt to
+enforce this at canonicalization]
+
+See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding
+double unifications is the main reason we disallow touchable
+unification variables as RHS of type family equations: F xis ~ alpha.
+
+Note [Do not unify representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   [W] alpha ~R# b
+where alpha is touchable. Should we unify alpha := b?
+
+Certainly not!  Unifying forces alpha and be to be the same; but they
+only need to be representationally equal types.
+
+For example, we might have another constraint [W] alpha ~# N b
+where
+  newtype N b = MkN b
+and we want to get alpha := N b.
+
+See also #15144, which was caused by unifying a representational
+equality (in the unflattener).
+
+
+************************************************************************
+*                                                                      *
+*          Functional dependencies, instantiation of equations
+*                                                                      *
+************************************************************************
+
+When we spot an equality arising from a functional dependency,
+we now use that equality (a "wanted") to rewrite the work-item
+constraint right away.  This avoids two dangers
+
+ Danger 1: If we send the original constraint on down the pipeline
+           it may react with an instance declaration, and in delicate
+           situations (when a Given overlaps with an instance) that
+           may produce new insoluble goals: see #4952
+
+ Danger 2: If we don't rewrite the constraint, it may re-react
+           with the same thing later, and produce the same equality
+           again --> termination worries.
+
+To achieve this required some refactoring of FunDeps.hs (nicer
+now!).
+
+Note [FunDep and implicit parameter reactions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, our story of interacting two dictionaries (or a dictionary
+and top-level instances) for functional dependencies, and implicit
+parameters, is that we simply produce new Derived equalities.  So for example
+
+        class D a b | a -> b where ...
+    Inert:
+        d1 :g D Int Bool
+    WorkItem:
+        d2 :w D Int alpha
+
+    We generate the extra work item
+        cv :d alpha ~ Bool
+    where 'cv' is currently unused.  However, this new item can perhaps be
+    spontaneously solved to become given and react with d2,
+    discharging it in favour of a new constraint d2' thus:
+        d2' :w D Int Bool
+        d2 := d2' |> D Int cv
+    Now d2' can be discharged from d1
+
+We could be more aggressive and try to *immediately* solve the dictionary
+using those extra equalities, but that requires those equalities to carry
+evidence and derived do not carry evidence.
+
+If that were the case with the same inert set and work item we might dischard
+d2 directly:
+
+        cv :w alpha ~ Bool
+        d2 := d1 |> D Int cv
+
+But in general it's a bit painful to figure out the necessary coercion,
+so we just take the first approach. Here is a better example. Consider:
+    class C a b c | a -> b
+And:
+     [Given]  d1 : C T Int Char
+     [Wanted] d2 : C T beta Int
+In this case, it's *not even possible* to solve the wanted immediately.
+So we should simply output the functional dependency and add this guy
+[but NOT its superclasses] back in the worklist. Even worse:
+     [Given] d1 : C T Int beta
+     [Wanted] d2: C T beta Int
+Then it is solvable, but its very hard to detect this on the spot.
+
+It's exactly the same with implicit parameters, except that the
+"aggressive" approach would be much easier to implement.
+
+Note [Weird fundeps]
+~~~~~~~~~~~~~~~~~~~~
+Consider   class Het a b | a -> b where
+              het :: m (f c) -> a -> m b
+
+           class GHet (a :: * -> *) (b :: * -> *) | a -> b
+           instance            GHet (K a) (K [a])
+           instance Het a b => GHet (K a) (K b)
+
+The two instances don't actually conflict on their fundeps,
+although it's pretty strange.  So they are both accepted. Now
+try   [W] GHet (K Int) (K Bool)
+This triggers fundeps from both instance decls;
+      [D] K Bool ~ K [a]
+      [D] K Bool ~ K beta
+And there's a risk of complaining about Bool ~ [a].  But in fact
+the Wanted matches the second instance, so we never get as far
+as the fundeps.
+
+#7875 is a case in point.
+-}
+
+emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()
+-- See Note [FunDep and implicit parameter reactions]
+emitFunDepDeriveds fd_eqns
+  = mapM_ do_one_FDEqn fd_eqns
+  where
+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
+     | null tvs  -- Common shortcut
+     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
+          ; mapM_ (unifyDerived loc Nominal) eqs }
+     | otherwise
+     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)
+          ; subst <- instFlexi tvs  -- Takes account of kind substitution
+          ; mapM_ (do_one_eq loc subst) eqs }
+
+    do_one_eq loc subst (Pair ty1 ty2)
+       = unifyDerived loc Nominal $
+         Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)
+
+{-
+**********************************************************************
+*                                                                    *
+                       The top-reaction Stage
+*                                                                    *
+**********************************************************************
+-}
+
+topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
+-- The work item does not react with the inert set,
+-- so try interaction with top-level instances. Note:
+topReactionsStage work_item
+  = do { traceTcS "doTopReact" (ppr work_item)
+       ; case work_item of
+           CDictCan {}  -> do { inerts <- getTcSInerts
+                              ; doTopReactDict inerts work_item }
+           CFunEqCan {} -> doTopReactFunEq work_item
+           CIrredCan {} -> doTopReactOther work_item
+           CTyEqCan {}  -> doTopReactOther work_item
+           _  -> -- Any other work item does not react with any top-level equations
+                 continueWith work_item  }
+
+
+--------------------
+doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
+-- Try local quantified constraints for
+--     CTyEqCan  e.g.  (a ~# ty)
+-- and CIrredCan e.g.  (c a)
+--
+-- Why equalities? See TcCanonical
+-- Note [Equality superclasses in quantified constraints]
+doTopReactOther work_item
+  | isGiven ev
+  = continueWith work_item
+
+  | EqPred eq_rel t1 t2 <- classifyPredType pred
+  = -- See Note [Looking up primitive equalities in quantified constraints]
+    case boxEqPred eq_rel t1 t2 of
+      Nothing -> continueWith work_item
+      Just (cls, tys)
+        -> do { res <- matchLocalInst (mkClassPred cls tys) loc
+              ; case res of
+                  OneInst { cir_mk_ev = mk_ev }
+                    -> chooseInstance work_item
+                           (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })
+                    where
+                  _ -> continueWith work_item }
+
+  | otherwise
+  = do { res <- matchLocalInst pred loc
+       ; case res of
+           OneInst {} -> chooseInstance work_item res
+           _          -> continueWith work_item }
+  where
+    ev = ctEvidence work_item
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+    mk_eq_ev cls tys mk_ev evs
+      = case (mk_ev evs) of
+          EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)
+          ev       -> pprPanic "mk_eq_ev" (ppr ev)
+      where
+        [sc_id] = classSCSelIds cls
+
+{- Note [Looking up primitive equalities in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For equalities (a ~# b) look up (a ~ b), and then do a superclass
+selection. This avoids having to support quantified constraints whose
+kind is not Constraint, such as (forall a. F a ~# b)
+
+See
+ * Note [Evidence for quantified constraints] in Type
+ * Note [Equality superclasses in quantified constraints]
+   in TcCanonical
+-}
+
+--------------------
+doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
+doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
+                                     , cc_tyargs = args, cc_fsk = fsk })
+
+  | fsk `elemVarSet` tyCoVarsOfTypes args
+  = no_reduction    -- See Note [FunEq occurs-check principle]
+
+  | otherwise  -- Note [Reduction for Derived CFunEqCans]
+  = do { match_res <- matchFam fam_tc args
+                           -- Look up in top-level instances, or built-in axiom
+                           -- See Note [MATCHING-SYNONYMS]
+       ; case match_res of
+           Nothing         -> no_reduction
+           Just match_info -> reduce_top_fun_eq old_ev fsk match_info }
+  where
+    no_reduction
+      = do { improveTopFunEqs old_ev fam_tc args fsk
+           ; continueWith work_item }
+
+doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)
+
+reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)
+                  -> TcS (StopOrContinue Ct)
+-- We have found an applicable top-level axiom: use it to reduce
+-- Precondition: fsk is not free in rhs_ty
+reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
+  | not (isDerived old_ev)  -- Precondition of shortCutReduction
+  , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
+  , isTypeFamilyTyCon tc
+  , tc_args `lengthIs` tyConArity tc    -- Short-cut
+  = -- RHS is another type-family application
+    -- Try shortcut; see Note [Top-level reductions for type functions]
+    do { shortCutReduction old_ev fsk ax_co tc tc_args
+       ; stopWith old_ev "Fun/Top (shortcut)" }
+
+  | otherwise
+  = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
+           , ppr old_ev $$ ppr rhs_ty )
+           -- Guaranteed by Note [FunEq occurs-check principle]
+    do { dischargeFunEq old_ev fsk ax_co rhs_ty
+       ; traceTcS "doTopReactFunEq" $
+         vcat [ text "old_ev:" <+> ppr old_ev
+              , nest 2 (text ":=") <+> ppr ax_co ]
+       ; stopWith old_ev "Fun/Top" }
+
+improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()
+-- See Note [FunDep and implicit parameter reactions]
+improveTopFunEqs ev fam_tc args fsk
+  | isGiven ev            -- See Note [No FunEq improvement for Givens]
+    || not (isImprovable ev)
+  = return ()
+
+  | otherwise
+  = do { ieqs <- getInertEqs
+       ; fam_envs <- getFamInstEnvs
+       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args
+                                    (lookupFlattenTyVar ieqs fsk)
+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk
+                                          , ppr eqns ])
+       ; mapM_ (unifyDerived loc Nominal) eqns }
+  where
+    loc = ctEvLoc ev  -- ToDo: this location is wrong; it should be FunDepOrigin2
+                      -- See #14778
+
+improve_top_fun_eqs :: FamInstEnvs
+                    -> TyCon -> [TcType] -> TcType
+                    -> TcS [TypeEqn]
+improve_top_fun_eqs fam_envs fam_tc args rhs_ty
+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+  = return (sfInteractTop ops args rhs_ty)
+
+  -- see Note [Type inference for type families with injectivity]
+  | isOpenTypeFamilyTyCon fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
+  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
+  = -- it is possible to have several compatible equations in an open type
+    -- family but we only want to derive equalities from one such equation.
+    do { let improvs = buildImprovementData fam_insts
+                           fi_tvs fi_tys fi_rhs (const Nothing)
+
+       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)
+       ; concatMapM (injImproveEqns injective_args) $
+         take 1 improvs }
+
+  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
+  = concatMapM (injImproveEqns injective_args) $
+    buildImprovementData (fromBranches (co_ax_branches ax))
+                         cab_tvs cab_lhs cab_rhs Just
+
+  | otherwise
+  = return []
+
+  where
+      buildImprovementData
+          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)
+          -> (a -> [TyVar])          -- get bound tyvars of an axiom
+          -> (a -> [Type])           -- get LHS of an axiom
+          -> (a -> Type)             -- get RHS of an axiom
+          -> (a -> Maybe CoAxBranch) -- Just => apartness check required
+          -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )]
+             -- Result:
+             -- ( [arguments of a matching axiom]
+             -- , RHS-unifying substitution
+             -- , axiom variables without substitution
+             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )
+      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =
+          [ (ax_args, subst, unsubstTvs, wrap axiom)
+          | axiom <- axioms
+          , let ax_args = axiomLHS axiom
+                ax_rhs  = axiomRHS axiom
+                ax_tvs  = axiomTVs axiom
+          , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty]
+          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)
+                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]
+                   -- The order of unsubstTvs is important; it must be
+                   -- in telescope order e.g. (k:*) (a:k)
+
+      injImproveEqns :: [Bool]
+                     -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch)
+                     -> TcS [TypeEqn]
+      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)
+        = do { subst <- instFlexiX subst unsubstTvs
+                  -- If the current substitution bind [k -> *], and
+                  -- one of the un-substituted tyvars is (a::k), we'd better
+                  -- be sure to apply the current substitution to a's kind.
+                  -- Hence instFlexiX.   #13135 was an example.
+
+             ; return [ Pair (substTyUnchecked subst ax_arg) arg
+                        -- NB: the ax_arg part is on the left
+                        -- see Note [Improvement orientation]
+                      | case cabr of
+                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'
+                          _          -> True
+                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
+
+
+shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
+                  -> TyCon -> [TcType] -> TcS ()
+-- See Note [Top-level reductions for type functions]
+-- Previously, we flattened the tc_args here, but there's no need to do so.
+-- And, if we did, this function would have all the complication of
+-- TcCanonical.canCFunEqCan. See Note [canCFunEqCan]
+shortCutReduction old_ev fsk ax_co fam_tc tc_args
+  = ASSERT( ctEvEqRel old_ev == NomEq)
+               -- ax_co :: F args ~ G tc_args
+               -- old_ev :: F args ~ fsk
+    do { new_ev <- case ctEvFlavour old_ev of
+           Given -> newGivenEvVar deeper_loc
+                         ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
+                         , evCoercion (mkTcSymCo ax_co
+                                       `mkTcTransCo` ctEvCoercion old_ev) )
+
+           Wanted {} ->
+             do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal
+                                        (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
+                ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co
+                ; return new_ev }
+
+           Derived -> pprPanic "shortCutReduction" (ppr old_ev)
+
+       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
+                                , cc_tyargs = tc_args, cc_fsk = fsk }
+       ; updWorkListTcS (extendWorkListFunEq new_ct) }
+  where
+    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
+
+{- Note [Top-level reductions for type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c.f. Note [The flattening story] in TcFlatten
+
+Suppose we have a CFunEqCan  F tys ~ fmv/fsk, and a matching axiom.
+Here is what we do, in four cases:
+
+* Wanteds: general firing rule
+    (work item) [W]        x : F tys ~ fmv
+    instantiate axiom: ax_co : F tys ~ rhs
+
+   Then:
+      Discharge   fmv := rhs
+      Discharge   x := ax_co ; sym x2
+   This is *the* way that fmv's get unified; even though they are
+   "untouchable".
+
+   NB: Given Note [FunEq occurs-check principle], fmv does not appear
+   in tys, and hence does not appear in the instantiated RHS.  So
+   the unification can't make an infinite type.
+
+* Wanteds: short cut firing rule
+  Applies when the RHS of the axiom is another type-function application
+      (work item)        [W] x : F tys ~ fmv
+      instantiate axiom: ax_co : F tys ~ G rhs_tys
+
+  It would be a waste to create yet another fmv for (G rhs_tys).
+  Instead (shortCutReduction):
+      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)
+      - Add G rhs_xis ~ fmv to flat cache  (note: the same old fmv)
+      - New canonical wanted   [W] x2 : G rhs_xis ~ fmv  (CFunEqCan)
+      - Discharge x := ax_co ; G cos ; x2
+
+* Givens: general firing rule
+      (work item)        [G] g : F tys ~ fsk
+      instantiate axiom: ax_co : F tys ~ rhs
+
+   Now add non-canonical given (since rhs is not flat)
+      [G] (sym g ; ax_co) : fsk ~ rhs  (Non-canonical)
+
+* Givens: short cut firing rule
+  Applies when the RHS of the axiom is another type-function application
+      (work item)        [G] g : F tys ~ fsk
+      instantiate axiom: ax_co : F tys ~ G rhs_tys
+
+  It would be a waste to create yet another fsk for (G rhs_tys).
+  Instead (shortCutReduction):
+     - Flatten rhs_tys: flat_cos : tys ~ flat_tys
+     - Add new Canonical given
+          [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk   (CFunEqCan)
+
+Note [FunEq occurs-check principle]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I have spent a lot of time finding a good way to deal with
+CFunEqCan constraints like
+    F (fuv, a) ~ fuv
+where flatten-skolem occurs on the LHS.  Now in principle we
+might may progress by doing a reduction, but in practice its
+hard to find examples where it is useful, and easy to find examples
+where we fall into an infinite reduction loop.  A rule that works
+very well is this:
+
+  *** FunEq occurs-check principle ***
+
+      Do not reduce a CFunEqCan
+          F tys ~ fsk
+      if fsk appears free in tys
+      Instead we treat it as stuck.
+
+Examples:
+
+* #5837 has [G] a ~ TF (a,Int), with an instance
+    type instance TF (a,b) = (TF a, TF b)
+  This readily loops when solving givens.  But with the FunEq occurs
+  check principle, it rapidly gets stuck which is fine.
+
+* #12444 is a good example, explained in comment:2.  We have
+    type instance F (Succ x) = Succ (F x)
+    [W] alpha ~ Succ (F alpha)
+  If we allow the reduction to happen, we get an infinite loop
+
+Note [Cached solved FunEqs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When trying to solve, say (FunExpensive big-type ~ ty), it's important
+to see if we have reduced (FunExpensive big-type) before, lest we
+simply repeat it.  Hence the lookup in inert_solved_funeqs.  Moreover
+we must use `funEqCanDischarge` because both uses might (say) be Wanteds,
+and we *still* want to save the re-computation.
+
+Note [MATCHING-SYNONYMS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+When trying to match a dictionary (D tau) to a top-level instance, or a
+type family equation (F taus_1 ~ tau_2) to a top-level family instance,
+we do *not* need to expand type synonyms because the matcher will do that for us.
+
+Note [Improvement orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A very delicate point is the orientation of derived equalities
+arising from injectivity improvement (#12522).  Suppse we have
+  type family F x = t | t -> x
+  type instance F (a, Int) = (Int, G a)
+where G is injective; and wanted constraints
+
+  [W] TF (alpha, beta) ~ fuv
+  [W] fuv ~ (Int, <some type>)
+
+The injectivity will give rise to derived constraints
+
+  [D] gamma1 ~ alpha
+  [D] Int ~ beta
+
+The fresh unification variable gamma1 comes from the fact that we
+can only do "partial improvement" here; see Section 5.2 of
+"Injective type families for Haskell" (HS'15).
+
+Now, it's very important to orient the equations this way round,
+so that the fresh unification variable will be eliminated in
+favour of alpha.  If we instead had
+   [D] alpha ~ gamma1
+then we would unify alpha := gamma1; and kick out the wanted
+constraint.  But when we grough it back in, it'd look like
+   [W] TF (gamma1, beta) ~ fuv
+and exactly the same thing would happen again!  Infinite loop.
+
+This all seems fragile, and it might seem more robust to avoid
+introducing gamma1 in the first place, in the case where the
+actual argument (alpha, beta) partly matches the improvement
+template.  But that's a bit tricky, esp when we remember that the
+kinds much match too; so it's easier to let the normal machinery
+handle it.  Instead we are careful to orient the new derived
+equality with the template on the left.  Delicate, but it works.
+
+Note [No FunEq improvement for Givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't do improvements (injectivity etc) for Givens. Why?
+
+* It generates Derived constraints on skolems, which don't do us
+  much good, except perhaps identify inaccessible branches.
+  (They'd be perfectly valid though.)
+
+* For type-nat stuff the derived constraints include type families;
+  e.g.  (a < b), (b < c) ==> a < c If we generate a Derived for this,
+  we'll generate a Derived/Wanted CFunEqCan; and, since the same
+  InertCans (after solving Givens) are used for each iteration, that
+  massively confused the unflattening step (TcFlatten.unflatten).
+
+  In fact it led to some infinite loops:
+     indexed-types/should_compile/T10806
+     indexed-types/should_compile/T10507
+     polykinds/T10742
+
+Note [Reduction for Derived CFunEqCans]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You may wonder if it's important to use top-level instances to
+simplify [D] CFunEqCan's.  But it is.  Here's an example (T10226).
+
+   type instance F    Int = Int
+   type instance FInv Int = Int
+
+Suppose we have to solve
+    [WD] FInv (F alpha) ~ alpha
+    [WD] F alpha ~ Int
+
+  --> flatten
+    [WD] F alpha ~ fuv0
+    [WD] FInv fuv0 ~ fuv1  -- (A)
+    [WD] fuv1 ~ alpha
+    [WD] fuv0 ~ Int        -- (B)
+
+  --> Rewwrite (A) with (B), splitting it
+    [WD] F alpha ~ fuv0
+    [W] FInv fuv0 ~ fuv1
+    [D] FInv Int ~ fuv1    -- (C)
+    [WD] fuv1 ~ alpha
+    [WD] fuv0 ~ Int
+
+  --> Reduce (C) with top-level instance
+      **** This is the key step ***
+    [WD] F alpha ~ fuv0
+    [W] FInv fuv0 ~ fuv1
+    [D] fuv1 ~ Int        -- (D)
+    [WD] fuv1 ~ alpha     -- (E)
+    [WD] fuv0 ~ Int
+
+  --> Rewrite (D) with (E)
+    [WD] F alpha ~ fuv0
+    [W] FInv fuv0 ~ fuv1
+    [D] alpha ~ Int       -- (F)
+    [WD] fuv1 ~ alpha
+    [WD] fuv0 ~ Int
+
+  --> unify (F)  alpha := Int, and that solves it
+
+Another example is indexed-types/should_compile/T10634
+-}
+
+{- *******************************************************************
+*                                                                    *
+         Top-level reaction for class constraints (CDictCan)
+*                                                                    *
+**********************************************************************-}
+
+doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
+-- Try to use type-class instance declarations to simplify the constraint
+doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
+                                          , cc_tyargs = xis })
+  | isGiven ev   -- Never use instances for Given constraints
+  = do { try_fundep_improvement
+       ; continueWith work_item }
+
+  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached
+  = do { setEvBindIfWanted ev (ctEvTerm solved_ev)
+       ; stopWith ev "Dict/Top (cached)" }
+
+  | otherwise  -- Wanted or Derived, but not cached
+   = do { dflags <- getDynFlags
+        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
+        ; case lkup_res of
+               OneInst { cir_what = what }
+                  -> do { unless (safeOverlap what) $
+                          insertSafeOverlapFailureTcS work_item
+                        ; when (isWanted ev) $ addSolvedDict ev cls xis
+                        ; chooseInstance work_item lkup_res }
+               _  ->  -- NoInstance or NotSure
+                     do { when (isImprovable ev) $
+                          try_fundep_improvement
+                        ; continueWith work_item } }
+   where
+     dict_pred   = mkClassPred cls xis
+     dict_loc    = ctEvLoc ev
+     dict_origin = ctLocOrigin dict_loc
+
+     -- We didn't solve it; so try functional dependencies with
+     -- the instance environment, and return
+     -- See also Note [Weird fundeps]
+     try_fundep_improvement
+        = do { traceTcS "try_fundeps" (ppr work_item)
+             ; instEnvs <- getInstEnvs
+             ; emitFunDepDeriveds $
+               improveFromInstEnv instEnvs mk_ct_loc dict_pred }
+
+     mk_ct_loc :: PredType   -- From instance decl
+               -> SrcSpan    -- also from instance deol
+               -> CtLoc
+     mk_ct_loc inst_pred inst_loc
+       = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
+                                               inst_pred inst_loc }
+
+doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
+
+
+chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
+chooseInstance work_item
+               (OneInst { cir_new_theta = theta
+                        , cir_what      = what
+                        , cir_mk_ev     = mk_ev })
+  = do { traceTcS "doTopReact/found instance for" $ ppr ev
+       ; deeper_loc <- checkInstanceOK loc what pred
+       ; if isDerived ev then finish_derived deeper_loc theta
+                         else finish_wanted  deeper_loc theta mk_ev }
+  where
+     ev         = ctEvidence work_item
+     pred       = ctEvPred ev
+     loc        = ctEvLoc ev
+
+     finish_wanted :: CtLoc -> [TcPredType]
+                   -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)
+      -- Precondition: evidence term matches the predicate workItem
+     finish_wanted loc theta mk_ev
+        = do { evb <- getTcEvBindsVar
+             ; if isCoEvBindsVar evb
+               then -- See Note [Instances in no-evidence implications]
+                    continueWith work_item
+               else
+          do { evc_vars <- mapM (newWanted loc) theta
+             ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
+             ; emitWorkNC (freshGoals evc_vars)
+             ; stopWith ev "Dict/Top (solved wanted)" } }
+
+     finish_derived loc theta
+       = -- Use type-class instances for Deriveds, in the hope
+         -- of generating some improvements
+         -- C.f. Example 3 of Note [The improvement story]
+         -- It's easy because no evidence is involved
+         do { emitNewDeriveds loc theta
+            ; traceTcS "finish_derived" (ppr (ctl_depth loc))
+            ; stopWith ev "Dict/Top (solved derived)" }
+
+chooseInstance work_item lookup_res
+  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
+
+checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
+-- Check that it's OK to use this insstance:
+--    (a) the use is well staged in the Template Haskell sense
+--    (b) we have not recursed too deep
+-- Returns the CtLoc to used for sub-goals
+checkInstanceOK loc what pred
+  = do { checkWellStagedDFun loc what pred
+       ; checkReductionDepth deeper_loc pred
+       ; return deeper_loc }
+  where
+     deeper_loc = zap_origin (bumpCtLocDepth loc)
+     origin     = ctLocOrigin loc
+
+     zap_origin loc  -- After applying an instance we can set ScOrigin to
+                     -- infinity, so that prohibitedSuperClassSolve never fires
+       | ScOrigin {} <- origin
+       = setCtLocOrigin loc (ScOrigin infinity)
+       | otherwise
+       = loc
+
+{- Note [Instances in no-evidence implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #15290 we had
+  [G] forall p q. Coercible p q => Coercible (m p) (m q))
+  [W] forall <no-ev> a. m (Int, IntStateT m a)
+                          ~R#
+                        m (Int, StateT Int m a)
+
+The Given is an ordinary quantified constraint; the Wanted is an implication
+equality that arises from
+  [W] (forall a. t1) ~R# (forall a. t2)
+
+But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
+we can't generate any term evidence.  So we can't actually use that
+lovely quantified constraint.  Alas!
+
+This test arranges to ignore the instance-based solution under these
+(rare) circumstances.   It's sad, but I  really don't see what else we can do.
+-}
+
+
+matchClassInst :: DynFlags -> InertSet
+               -> Class -> [Type]
+               -> CtLoc -> TcS ClsInstResult
+matchClassInst dflags inerts clas tys loc
+-- First check whether there is an in-scope Given that could
+-- match this constraint.  In that case, do not use any instance
+-- whether top level, or local quantified constraints.
+-- ee Note [Instance and Given overlap]
+  | not (xopt LangExt.IncoherentInstances dflags)
+  , not (naturallyCoherentClass clas)
+  , let matchable_givens = matchableGivens loc pred inerts
+  , not (isEmptyBag matchable_givens)
+  = do { traceTcS "Delaying instance application" $
+           vcat [ text "Work item=" <+> pprClassPred clas tys
+                , text "Potential matching givens:" <+> ppr matchable_givens ]
+       ; return NotSure }
+
+  | otherwise
+  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'
+       ; local_res <- matchLocalInst pred loc
+       ; case local_res of
+           OneInst {} ->  -- See Note [Local instances and incoherence]
+                do { traceTcS "} matchClassInst local match" $ ppr local_res
+                   ; return local_res }
+
+           NotSure -> -- In the NotSure case for local instances
+                      -- we don't want to try global instances
+                do { traceTcS "} matchClassInst local not sure" empty
+                   ; return local_res }
+
+           NoInstance  -- No local instances, so try global ones
+              -> do { global_res <- matchGlobalInst dflags False clas tys
+                    ; traceTcS "} matchClassInst global result" $ ppr global_res
+                    ; return global_res } }
+  where
+    pred = mkClassPred clas tys
+
+-- | If a class is "naturally coherent", then we needn't worry at all, in any
+-- way, about overlapping/incoherent instances. Just solve the thing!
+-- See Note [Naturally coherent classes]
+-- See also Note [The equality class story] in TysPrim.
+naturallyCoherentClass :: Class -> Bool
+naturallyCoherentClass cls
+  = isCTupleClass cls
+    || cls `hasKey` heqTyConKey
+    || cls `hasKey` eqTyConKey
+    || cls `hasKey` coercibleTyConKey
+
+
+{- Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example, from the OutsideIn(X) paper:
+       instance P x => Q [x]
+       instance (x ~ y) => R y [x]
+
+       wob :: forall a b. (Q [b], R b a) => a -> Int
+
+       g :: forall a. Q [a] => [a] -> Int
+       g x = wob x
+
+From 'g' we get the impliation constraint:
+            forall a. Q [a] => (Q [beta], R beta [a])
+If we react (Q [beta]) with its top-level axiom, we end up with a
+(P beta), which we have no way of discharging. On the other hand,
+if we react R beta [a] with the top-level we get  (beta ~ a), which
+is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
+now solvable by the given Q [a].
+
+The partial solution is that:
+  In matchClassInst (and thus in topReact), we return a matching
+  instance only when there is no Given in the inerts which is
+  unifiable to this particular dictionary.
+
+  We treat any meta-tyvar as "unifiable" for this purpose,
+  *including* untouchable ones.  But not skolems like 'a' in
+  the implication constraint above.
+
+The end effect is that, much as we do for overlapping instances, we
+delay choosing a class instance if there is a possibility of another
+instance OR a given to match our constraint later on. This fixes
+#4981 and #5002.
+
+Other notes:
+
+* The check is done *first*, so that it also covers classes
+  with built-in instance solving, such as
+     - constraint tuples
+     - natural numbers
+     - Typeable
+
+* Flatten-skolems: we do not treat a flatten-skolem as unifiable
+  for this purpose.
+  E.g.   f :: Eq (F a) => [a] -> [a]
+         f xs = ....(xs==xs).....
+  Here we get [W] Eq [a], and we don't want to refrain from solving
+  it because of the given (Eq (F a)) constraint!
+
+* The given-overlap problem is arguably not easy to appear in practice
+  due to our aggressive prioritization of equality solving over other
+  constraints, but it is possible. I've added a test case in
+  typecheck/should-compile/GivenOverlapping.hs
+
+* Another "live" example is #10195; another is #10177.
+
+* We ignore the overlap problem if -XIncoherentInstances is in force:
+  see #6002 for a worked-out example where this makes a
+  difference.
+
+* Moreover notice that our goals here are different than the goals of
+  the top-level overlapping checks. There we are interested in
+  validating the following principle:
+
+      If we inline a function f at a site where the same global
+      instance environment is available as the instance environment at
+      the definition site of f then we should get the same behaviour.
+
+  But for the Given Overlap check our goal is just related to completeness of
+  constraint solving.
+
+* The solution is only a partial one.  Consider the above example with
+       g :: forall a. Q [a] => [a] -> Int
+       g x = let v = wob x
+             in v
+  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
+  general type for 'v'.  When generalising v's type we'll simplify its
+  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
+  will use the instance declaration after all. #11948 was a case
+  in point.
+
+All of this is disgustingly delicate, so to discourage people from writing
+simplifiable class givens, we warn about signatures that contain them;
+see TcValidity Note [Simplifiable given constraints].
+
+Note [Naturally coherent classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A few built-in classes are "naturally coherent".  This term means that
+the "instance" for the class is bidirectional with its superclass(es).
+For example, consider (~~), which behaves as if it was defined like
+this:
+  class a ~# b => a ~~ b
+  instance a ~# b => a ~~ b
+(See Note [The equality types story] in TysPrim.)
+
+Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
+without worrying about Note [Instance and Given overlap].  Why?  Because
+if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
+so the reduction of the [W] constraint does not risk losing any solutions.
+
+On the other hand, it can be fatal to /fail/ to reduce such
+equalities, on the grounds of Note [Instance and Given overlap],
+because many good things flow from [W] t1 ~# t2.
+
+The same reasoning applies to
+
+* (~~)        heqTyCOn
+* (~)         eqTyCon
+* Coercible   coercibleTyCon
+
+And less obviously to:
+
+* Tuple classes.  For reasons described in TcSMonad
+  Note [Tuples hiding implicit parameters], we may have a constraint
+     [W] (?x::Int, C a)
+  with an exactly-matching Given constraint.  We must decompose this
+  tuple and solve the components separately, otherwise we won't solve
+  it at all!  It is perfectly safe to decompose it, because again the
+  superclasses invert the instance;  e.g.
+      class (c1, c2) => (% c1, c2 %)
+      instance (c1, c2) => (% c1, c2 %)
+  Example in #14218
+
+Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b
+
+PS: the term "naturally coherent" doesn't really seem helpful.
+Perhaps "invertible" or something?  I left it for now though.
+
+Note [Local instances and incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
+                 => c b -> Bool
+   f x = x==x
+
+We get [W] Eq (c b), and we must use the local instance to solve it.
+
+BUT that wanted also unifies with the top-level Eq [a] instance,
+and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
+we can't solve the wanted at all.  So we mark it as Incohherent.
+According to Note [Rules for instance lookup] in InstEnv, that'll
+make it win even if there are other instances that unify.
+
+Moreover this is not a hack!  The evidence for this local instance
+will be constructed by GHC at a call site... from the very instances
+that unify with it here.  It is not like an incoherent user-written
+instance which might have utterly different behaviour.
+
+Consdider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
+get it from the Eq a context, without worrying that there are
+lots of top-level instances that unify with [W] Eq a!  We'll use
+those instances to build evidence to pass to f. That's just the
+nullary case of what's happening here.
+-}
+
+matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
+-- Look up the predicate in Given quantified constraints,
+-- which are effectively just local instance declarations.
+matchLocalInst pred loc
+  = do { ics <- getInertCans
+       ; case match_local_inst (inert_insts ics) of
+           ([], False) -> return NoInstance
+           ([(dfun_ev, inst_tys)], unifs)
+             | not unifs
+             -> do { let dfun_id = ctEvEvId dfun_ev
+                   ; (tys, theta) <- instDFunType dfun_id inst_tys
+                   ; return $ OneInst { cir_new_theta = theta
+                                      , cir_mk_ev     = evDFunApp dfun_id tys
+                                      , cir_what      = LocalInstance } }
+           _ -> return NotSure }
+  where
+    pred_tv_set = tyCoVarsOfType pred
+
+    match_local_inst :: [QCInst]
+                     -> ( [(CtEvidence, [DFunInstType])]
+                        , Bool )      -- True <=> Some unify but do not match
+    match_local_inst []
+      = ([], False)
+    match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred
+                               , qci_ev = ev })
+                     : qcis)
+      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
+      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
+                                        emptyTvSubstEnv qpred pred
+      , let match = (ev, map (lookupVarEnv tv_subst) qtvs)
+      = (match:matches, unif)
+
+      | otherwise
+      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)
+               , ppr qci $$ ppr pred )
+            -- ASSERT: unification relies on the
+            -- quantified variables being fresh
+        (matches, unif || this_unif)
+      where
+        qtv_set = mkVarSet qtvs
+        this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc
+        (matches, unif) = match_local_inst qcis
+
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcMType.hs
@@ -0,0 +1,2240 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Monadic type operations
+
+This module contains monadic operations over types that contain
+mutable type variables.
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
+
+module TcMType (
+  TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
+
+  --------------------------------
+  -- Creating new mutable type variables
+  newFlexiTyVar,
+  newFlexiTyVarTy,              -- Kind -> TcM TcType
+  newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]
+  newOpenFlexiTyVarTy, newOpenTypeKind,
+  newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,
+  cloneMetaTyVar,
+  newFmvTyVar, newFskTyVar,
+
+  readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
+  newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
+
+  --------------------------------
+  -- Expected types
+  ExpType(..), ExpSigmaType, ExpRhoType,
+  mkCheckExpType,
+  newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst,
+  readExpType, readExpType_maybe,
+  expTypeToType, checkingExpType_maybe, checkingExpType,
+  tauifyExpType, inferResultToType,
+
+  --------------------------------
+  -- Creating new evidence variables
+  newEvVar, newEvVars, newDict,
+  newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,
+  emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
+  emitDerivedEqs,
+  newTcEvBinds, newNoTcEvBinds, addTcEvBind,
+
+  newCoercionHole, fillCoercionHole, isFilledCoercionHole,
+  unpackCoercionHole, unpackCoercionHole_maybe,
+  checkCoercionHole,
+
+  --------------------------------
+  -- Instantiation
+  newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
+  newMetaTyVarTyVars, newMetaTyVarTyVarX,
+  newTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX,
+  tcInstType,
+  tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,
+  tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
+
+  freshenTyVarBndrs, freshenCoVarBndrsX,
+
+  --------------------------------
+  -- Zonking and tidying
+  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,
+  tidyEvVar, tidyCt, tidySkolemInfo,
+    zonkTcTyVar, zonkTcTyVars,
+  zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,
+  zonkTyCoVarsAndFV, zonkTcTypeAndFV,
+  zonkTyCoVarsAndFVList,
+  candidateQTyVarsOfType,  candidateQTyVarsOfKind,
+  candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
+  CandidatesQTvs(..), delCandidates, candidateKindVars,
+  zonkAndSkolemise, skolemiseQuantifiedTyVar,
+  defaultTyVar, quantifyTyVars,
+  zonkTcType, zonkTcTypes, zonkCo,
+  zonkTyCoVarKind,
+
+  zonkEvVar, zonkWC, zonkSimples,
+  zonkId, zonkCoVar,
+  zonkCt, zonkSkolemInfo,
+
+  tcGetGlobalTyCoVars,
+
+  ------------------------------
+  -- Levity polymorphism
+  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr
+  ) where
+
+#include "HsVersions.h"
+
+-- friends:
+import GhcPrelude
+
+import TyCoRep
+import TcType
+import Type
+import TyCon
+import Coercion
+import Class
+import Var
+
+-- others:
+import TcRnMonad        -- TcType, amongst others
+import TcEvidence
+import Id
+import Name
+import VarSet
+import TysWiredIn
+import TysPrim
+import VarEnv
+import NameEnv
+import PrelNames
+import Util
+import Outputable
+import FastString
+import Bag
+import Pair
+import UniqSet
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Maybes
+import Data.List        ( mapAccumL )
+import Control.Arrow    ( second )
+import qualified Data.Semigroup as Semi
+
+{-
+************************************************************************
+*                                                                      *
+        Kind variables
+*                                                                      *
+************************************************************************
+-}
+
+mkKindName :: Unique -> Name
+mkKindName unique = mkSystemName unique kind_var_occ
+
+kind_var_occ :: OccName -- Just one for all MetaKindVars
+                        -- They may be jiggled by tidying
+kind_var_occ = mkOccName tvName "k"
+
+newMetaKindVar :: TcM TcKind
+newMetaKindVar
+  = do { details <- newMetaDetails TauTv
+       ; uniq <- newUnique
+       ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details
+       ; traceTc "newMetaKindVar" (ppr kv)
+       ; return (mkTyVarTy kv) }
+
+newMetaKindVars :: Int -> TcM [TcKind]
+newMetaKindVars n = replicateM n newMetaKindVar
+
+{-
+************************************************************************
+*                                                                      *
+     Evidence variables; range over constraints we can abstract over
+*                                                                      *
+************************************************************************
+-}
+
+newEvVars :: TcThetaType -> TcM [EvVar]
+newEvVars theta = mapM newEvVar theta
+
+--------------
+
+newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar
+-- Creates new *rigid* variables for predicates
+newEvVar ty = do { name <- newSysName (predTypeOccName ty)
+                 ; return (mkLocalIdOrCoVar name ty) }
+
+newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
+-- Deals with both equality and non-equality predicates
+newWanted orig t_or_k pty
+  = do loc <- getCtLocM orig t_or_k
+       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty
+                                else EvVarDest <$> newEvVar pty
+       return $ CtWanted { ctev_dest = d
+                         , ctev_pred = pty
+                         , ctev_nosh = WDeriv
+                         , ctev_loc = loc }
+
+newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
+newWanteds orig = mapM (newWanted orig Nothing)
+
+-- | Create a new 'CHoleCan' 'Ct'.
+newHoleCt :: Hole -> Id -> Type -> TcM Ct
+newHoleCt hole ev ty = do
+  loc <- getCtLocM HoleOrigin Nothing
+  pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty
+                                     , ctev_dest = EvVarDest ev
+                                     , ctev_nosh = WDeriv
+                                     , ctev_loc  = loc }
+                  , cc_hole = hole }
+
+----------------------------------------------
+-- Cloning constraints
+----------------------------------------------
+
+cloneWanted :: Ct -> TcM Ct
+cloneWanted ct
+  | ev@(CtWanted { ctev_dest = HoleDest {}, ctev_pred = pty }) <- ctEvidence ct
+  = do { co_hole <- newCoercionHole pty
+       ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }
+  | otherwise
+  = return ct
+
+cloneWC :: WantedConstraints -> TcM WantedConstraints
+-- Clone all the evidence bindings in
+--   a) the ic_bind field of any implications
+--   b) the CoercionHoles of any wanted constraints
+-- so that solving the WantedConstraints will not have any visible side
+-- effect, /except/ from causing unifications
+cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { simples' <- mapBagM cloneWanted simples
+       ; implics' <- mapBagM cloneImplication implics
+       ; return (wc { wc_simple = simples', wc_impl = implics' }) }
+
+cloneImplication :: Implication -> TcM Implication
+cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted })
+  = do { binds'        <- cloneEvBindsVar binds
+       ; inner_wanted' <- cloneWC inner_wanted
+       ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) }
+
+----------------------------------------------
+-- Emitting constraints
+----------------------------------------------
+
+-- | Emits a new Wanted. Deals with both equalities and non-equalities.
+emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
+emitWanted origin pty
+  = do { ev <- newWanted origin Nothing pty
+       ; emitSimple $ mkNonCanonical ev
+       ; return $ ctEvTerm ev }
+
+emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
+-- Emit some new derived nominal equalities
+emitDerivedEqs origin pairs
+  | null pairs
+  = return ()
+  | otherwise
+  = do { loc <- getCtLocM origin Nothing
+       ; emitSimples (listToBag (map (mk_one loc) pairs)) }
+  where
+    mk_one loc (ty1, ty2)
+       = mkNonCanonical $
+         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2
+                   , ctev_loc = loc }
+
+-- | Emits a new equality constraint
+emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
+emitWantedEq origin t_or_k role ty1 ty2
+  = do { hole <- newCoercionHole pty
+       ; loc <- getCtLocM origin (Just t_or_k)
+       ; emitSimple $ mkNonCanonical $
+         CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
+                  , ctev_nosh = WDeriv, ctev_loc = loc }
+       ; return (HoleCo hole) }
+  where
+    pty = mkPrimEqPredRole role ty1 ty2
+
+-- | Creates a new EvVar and immediately emits it as a Wanted.
+-- No equality predicates here.
+emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar
+emitWantedEvVar origin ty
+  = do { new_cv <- newEvVar ty
+       ; loc <- getCtLocM origin Nothing
+       ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv
+                             , ctev_pred = ty
+                             , ctev_nosh = WDeriv
+                             , ctev_loc  = loc }
+       ; emitSimple $ mkNonCanonical ctev
+       ; return new_cv }
+
+emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
+emitWantedEvVars orig = mapM (emitWantedEvVar orig)
+
+newDict :: Class -> [TcType] -> TcM DictId
+newDict cls tys
+  = do { name <- newSysName (mkDictOcc (getOccName cls))
+       ; return (mkLocalId name (mkClassPred cls tys)) }
+
+predTypeOccName :: PredType -> OccName
+predTypeOccName ty = case classifyPredType ty of
+    ClassPred cls _ -> mkDictOcc (getOccName cls)
+    EqPred {}       -> mkVarOccFS (fsLit "co")
+    IrredPred {}    -> mkVarOccFS (fsLit "irred")
+    ForAllPred {}   -> mkVarOccFS (fsLit "df")
+
+{-
+************************************************************************
+*                                                                      *
+        Coercion holes
+*                                                                      *
+************************************************************************
+-}
+
+newCoercionHole :: TcPredType -> TcM CoercionHole
+newCoercionHole pred_ty
+  = do { co_var <- newEvVar pred_ty
+       ; traceTc "New coercion hole:" (ppr co_var)
+       ; ref <- newMutVar Nothing
+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }
+
+-- | Put a value in a coercion hole
+fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co
+  = do {
+#if defined(DEBUG)
+       ; cts <- readTcRef ref
+       ; whenIsJust cts $ \old_co ->
+         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)
+#endif
+       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)
+       ; writeTcRef ref (Just co) }
+
+-- | Is a coercion hole filled in?
+isFilledCoercionHole :: CoercionHole -> TcM Bool
+isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref
+
+-- | Retrieve the contents of a coercion hole. Panics if the hole
+-- is unfilled
+unpackCoercionHole :: CoercionHole -> TcM Coercion
+unpackCoercionHole hole
+  = do { contents <- unpackCoercionHole_maybe hole
+       ; case contents of
+           Just co -> return co
+           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }
+
+-- | Retrieve the contents of a coercion hole, if it is filled
+unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
+unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref
+
+-- | Check that a coercion is appropriate for filling a hole. (The hole
+-- itself is needed only for printing.
+-- Always returns the checked coercion, but this return value is necessary
+-- so that the input coercion is forced only when the output is forced.
+checkCoercionHole :: CoVar -> Coercion -> TcM Coercion
+checkCoercionHole cv co
+  | debugIsOn
+  = do { cv_ty <- zonkTcType (varType cv)
+                  -- co is already zonked, but cv might not be
+       ; return $
+         ASSERT2( ok cv_ty
+                , (text "Bad coercion hole" <+>
+                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
+                                            , ppr cv_ty ]) )
+         co }
+  | otherwise
+  = return co
+
+  where
+    (Pair t1 t2, role) = coercionKindRole co
+    ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty
+             =  t1 `eqType` cv_t1
+             && t2 `eqType` cv_t2
+             && role == eqRelRole cv_rel
+             | otherwise
+             = False
+
+{-
+************************************************************************
+*
+    Expected types
+*
+************************************************************************
+
+Note [ExpType]
+~~~~~~~~~~~~~~
+
+An ExpType is used as the "expected type" when type-checking an expression.
+An ExpType can hold a "hole" that can be filled in by the type-checker.
+This allows us to have one tcExpr that works in both checking mode and
+synthesis mode (that is, bidirectional type-checking). Previously, this
+was achieved by using ordinary unification variables, but we don't need
+or want that generality. (For example, #11397 was caused by doing the
+wrong thing with unification variables.) Instead, we observe that these
+holes should
+
+1. never be nested
+2. never appear as the type of a variable
+3. be used linearly (never be duplicated)
+
+By defining ExpType, separately from Type, we can achieve goals 1 and 2
+statically.
+
+See also [wiki:typechecking]
+
+Note [TcLevel of ExpType]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data G a where
+    MkG :: G Bool
+
+  foo MkG = True
+
+This is a classic untouchable-variable / ambiguous GADT return type
+scenario. But, with ExpTypes, we'll be inferring the type of the RHS.
+And, because there is only one branch of the case, we won't trigger
+Note [Case branches must never infer a non-tau type] of TcMatches.
+We thus must track a TcLevel in an Inferring ExpType. If we try to
+fill the ExpType and find that the TcLevels don't work out, we
+fill the ExpType with a tau-tv at the low TcLevel, hopefully to
+be worked out later by some means. This is triggered in
+test gadt/gadt-escape1.
+
+-}
+
+-- actual data definition is in TcType
+
+-- | Make an 'ExpType' suitable for inferring a type of kind * or #.
+newInferExpTypeNoInst :: TcM ExpSigmaType
+newInferExpTypeNoInst = newInferExpType False
+
+newInferExpTypeInst :: TcM ExpRhoType
+newInferExpTypeInst = newInferExpType True
+
+newInferExpType :: Bool -> TcM ExpType
+newInferExpType inst
+  = do { u <- newUnique
+       ; tclvl <- getTcLevel
+       ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl)
+       ; ref <- newMutVar Nothing
+       ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl
+                           , ir_ref = ref, ir_inst = inst })) }
+
+-- | Extract a type out of an ExpType, if one exists. But one should always
+-- exist. Unless you're quite sure you know what you're doing.
+readExpType_maybe :: ExpType -> TcM (Maybe TcType)
+readExpType_maybe (Check ty)                   = return (Just ty)
+readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref
+
+-- | Extract a type out of an ExpType. Otherwise, panics.
+readExpType :: ExpType -> TcM TcType
+readExpType exp_ty
+  = do { mb_ty <- readExpType_maybe exp_ty
+       ; case mb_ty of
+           Just ty -> return ty
+           Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }
+
+-- | Returns the expected type when in checking mode.
+checkingExpType_maybe :: ExpType -> Maybe TcType
+checkingExpType_maybe (Check ty) = Just ty
+checkingExpType_maybe _          = Nothing
+
+-- | Returns the expected type when in checking mode. Panics if in inference
+-- mode.
+checkingExpType :: String -> ExpType -> TcType
+checkingExpType _   (Check ty) = ty
+checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)
+
+tauifyExpType :: ExpType -> TcM ExpType
+-- ^ Turn a (Infer hole) type into a (Check alpha),
+-- where alpha is a fresh unification variable
+tauifyExpType (Check ty)      = return (Check ty)  -- No-op for (Check ty)
+tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res
+                                   ; return (Check ty) }
+
+-- | Extracts the expected type if there is one, or generates a new
+-- TauTv if there isn't.
+expTypeToType :: ExpType -> TcM TcType
+expTypeToType (Check ty)      = return ty
+expTypeToType (Infer inf_res) = inferResultToType inf_res
+
+inferResultToType :: InferResult -> TcM Type
+inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
+                      , ir_ref = ref })
+  = do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+       ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)
+             -- See Note [TcLevel of ExpType]
+       ; writeMutVar ref (Just tau)
+       ; traceTc "Forcing ExpType to be monomorphic:"
+                 (ppr u <+> text ":=" <+> ppr tau)
+       ; return tau }
+
+
+{- *********************************************************************
+*                                                                      *
+        SkolemTvs (immutable)
+*                                                                      *
+********************************************************************* -}
+
+tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
+                   -- ^ How to instantiate the type variables
+           -> Id                                            -- ^ Type to instantiate
+           -> TcM ([(Name, TcTyVar)], TcThetaType, TcType)  -- ^ Result
+                -- (type vars, preds (incl equalities), rho)
+tcInstType inst_tyvars id
+  = case tcSplitForAllTys (idType id) of
+        ([],    rho) -> let     -- There may be overloading despite no type variables;
+                                --      (?x :: Int) => Int -> Int
+                                (theta, tau) = tcSplitPhiTy rho
+                            in
+                            return ([], theta, tau)
+
+        (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars
+                            ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)
+                                  tv_prs       = map tyVarName tyvars `zip` tyvars'
+                            ; return (tv_prs, theta, tau) }
+
+tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
+-- Instantiate a type signature with skolem constants.
+-- We could give them fresh names, but no need to do so
+tcSkolDFunType dfun
+  = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun
+       ; return (map snd tv_prs, theta, tau) }
+
+tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
+-- Make skolem constants, but do *not* give them new names, as above
+-- Moreover, make them "super skolems"; see comments with superSkolemTv
+-- see Note [Kind substitution when instantiating]
+-- Precondition: tyvars should be ordered by scoping
+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst
+
+tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
+tcSuperSkolTyVar subst tv
+  = (extendTvSubstWithClone subst tv new_tv, new_tv)
+  where
+    kind   = substTyUnchecked subst (tyVarKind tv)
+    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
+
+-- | Given a list of @['TyVar']@, skolemize the type variables,
+-- returning a substitution mapping the original tyvars to the
+-- skolems, and the list of newly bound skolems.
+tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst
+
+tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False
+
+tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst
+
+tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst
+
+tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
+                          -> TcM (TCvSubst, [TcTyVar])
+-- Skolemise one level deeper, hence pushTcLevel
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsPushLevel overlappable subst tvs
+  = do { tc_lvl <- getTcLevel
+       ; let pushed_lvl = pushTcLevel tc_lvl
+       ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }
+
+tcInstSkolTyVarsAt :: TcLevel -> Bool
+                   -> TCvSubst -> [TyVar]
+                   -> TcM (TCvSubst, [TcTyVar])
+tcInstSkolTyVarsAt lvl overlappable subst tvs
+  = freshenTyCoVarsX new_skol_tv subst tvs
+  where
+    details = SkolemTv lvl overlappable
+    new_skol_tv name kind = mkTcTyVar name kind details
+
+------------------
+freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
+-- ^ Give fresh uniques to a bunch of TyVars, but they stay
+--   as TyVars, rather than becoming TcTyVars
+-- Used in FamInst.newFamInst, and Inst.newClsInst
+freshenTyVarBndrs = freshenTyCoVars mkTyVar
+
+freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
+-- ^ Give fresh uniques to a bunch of CoVars
+-- Used in FamInst.newFamInst
+freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst
+
+------------------
+freshenTyCoVars :: (Name -> Kind -> TyCoVar)
+                -> [TyVar] -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst
+
+freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
+                 -> TCvSubst -> [TyCoVar]
+                 -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)
+
+freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
+                -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
+-- This a complete freshening operation:
+-- the skolems have a fresh unique, and a location from the monad
+-- See Note [Skolemising type variables]
+freshenTyCoVarX mk_tcv subst tycovar
+  = do { loc  <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let old_name = tyVarName tycovar
+             new_name = mkInternalName uniq (getOccName old_name) loc
+             new_kind = substTyUnchecked subst (tyVarKind tycovar)
+             new_tcv  = mk_tcv new_name new_kind
+             subst1   = extendTCvSubstWithClone subst tycovar new_tcv
+       ; return (subst1, new_tcv) }
+
+{- Note [Skolemising type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The tcInstSkolTyVars family of functions instantiate a list of TyVars
+to fresh skolem TcTyVars. Important notes:
+
+a) Level allocation. We generally skolemise /before/ calling
+   pushLevelAndCaptureConstraints.  So we want their level to the level
+   of the soon-to-be-created implication, which has a level ONE HIGHER
+   than the current level.  Hence the pushTcLevel.  It feels like a
+   slight hack.
+
+b) The [TyVar] should be ordered (kind vars first)
+   See Note [Kind substitution when instantiating]
+
+c) It's a complete freshening operation: the skolems have a fresh
+   unique, and a location from the monad
+
+d) The resulting skolems are
+        non-overlappable for tcInstSkolTyVars,
+   but overlappable for tcInstSuperSkolTyVars
+   See TcDerivInfer Note [Overlap and deriving] for an example
+   of where this matters.
+
+Note [Kind substitution when instantiating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we instantiate a bunch of kind and type variables, first we
+expect them to be topologically sorted.
+Then we have to instantiate the kind variables, build a substitution
+from old variables to the new variables, then instantiate the type
+variables substituting the original kind.
+
+Exemple: If we want to instantiate
+  [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]
+we want
+  [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]
+instead of the buggous
+  [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]
+
+
+************************************************************************
+*                                                                      *
+        MetaTvs (meta type variables; mutable)
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [TyVarTv]
+~~~~~~~~~~~~
+
+A TyVarTv can unify with type *variables* only, including other TyVarTvs and
+skolems. Sometimes, they can unify with type variables that the user would
+rather keep distinct; see #11203 for an example.  So, any client of this
+function needs to either allow the TyVarTvs to unify with each other or check
+that they don't (say, with a call to findDubTyVarTvs).
+
+Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in
+patterns, to make sure these type variables only refer to other type variables,
+but this restriction was dropped, and ScopedTypeVariables can now refer to full
+types (GHC Proposal 29).
+
+The remaining uses of newTyVarTyVars are
+* In kind signatures, see
+  TcTyClsDecls Note [Inferring kinds for type declarations]
+           and Note [Kind checking for GADTs]
+* In partial type signatures, see Note [Quantified variables in partial type signatures]
+-}
+
+newMetaTyVarName :: FastString -> TcM Name
+-- Makes a /System/ Name, which is eagerly eliminated by
+-- the unifier; see TcUnify.nicer_to_update_tv1, and
+-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)
+newMetaTyVarName str
+  = do { uniq <- newUnique
+       ; return (mkSystemName uniq (mkTyVarOccFS str)) }
+
+cloneMetaTyVarName :: Name -> TcM Name
+cloneMetaTyVarName name
+  = do { uniq <- newUnique
+       ; return (mkSystemName uniq (nameOccName name)) }
+         -- See Note [Name of an instantiated type variable]
+
+{- Note [Name of an instantiated type variable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we give a unification variable a System Name, which
+influences the way it is tidied; see TypeRep.tidyTyVarBndr.
+
+Note [Unification variables need fresh Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whenever we allocate a unification variable (MetaTyVar) we give
+it a fresh name.   #16221 is a very tricky case that illustrates
+why this is important:
+
+   data SameKind :: k -> k -> *
+   data T0 a = forall k2 (b :: k2). MkT0 (SameKind a b) !Int
+
+When kind-checking T0, we give (a :: kappa1). Then, in kcConDecl
+we allocate a unification variable kappa2 for k2, and then we
+end up unifying kappa1 := kappa2 (because of the (SameKind a b).
+
+Now we generalise over kappa2; but if kappa2's Name is k2,
+we'll end up giving T0 the kind forall k2. k2 -> *.  Nothing
+directly wrong with that but when we typecheck the data constrautor
+we end up giving it the type
+  MkT0 :: forall k1 (a :: k1) k2 (b :: k2).
+          SameKind @k2 a b -> Int -> T0 @{k2} a
+which is bogus.  The result type should be T0 @{k1} a.
+
+And there no reason /not/ to clone the Name when making a
+unification variable.  So that's what we do.
+-}
+
+newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
+-- Make a new meta tyvar out of thin air
+newAnonMetaTyVar meta_info kind
+  = do  { let s = case meta_info of
+                        TauTv       -> fsLit "t"
+                        FlatMetaTv  -> fsLit "fmv"
+                        FlatSkolTv  -> fsLit "fsk"
+                        TyVarTv      -> fsLit "a"
+        ; name    <- newMetaTyVarName s
+        ; details <- newMetaDetails meta_info
+        ; let tyvar = mkTcTyVar name kind details
+        ; traceTc "newAnonMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+-- makes a new skolem tv
+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
+newSkolemTyVar name kind
+  = do { lvl <- getTcLevel
+       ; return (mkTcTyVar name kind (SkolemTv lvl False)) }
+
+newTyVarTyVar :: Name -> Kind -> TcM TcTyVar
+-- See Note [TyVarTv]
+-- See Note [Unification variables need fresh Names]
+newTyVarTyVar name kind
+  = do { details <- newMetaDetails TyVarTv
+       ; uniq <- newUnique
+       ; let name' = name `setNameUnique` uniq
+             tyvar = mkTcTyVar name' kind details
+         -- Don't use cloneMetaTyVar, which makes a SystemName
+         -- We want to keep the original more user-friendly Name
+         -- In practical terms that means that in error messages,
+         -- when the Name is tidied we get 'a' rather than 'a0'
+       ; traceTc "newTyVarTyVar" (ppr tyvar)
+       ; return tyvar }
+
+newPatSigTyVar :: Name -> Kind -> TcM TcTyVar
+newPatSigTyVar name kind
+  = do { details <- newMetaDetails TauTv
+       ; uniq <- newUnique
+       ; let name' = name `setNameUnique` uniq
+             tyvar = mkTcTyVar name' kind details
+         -- Don't use cloneMetaTyVar;
+         -- same reasoning as in newTyVarTyVar
+       ; traceTc "newPatSigTyVar" (ppr tyvar)
+       ; return tyvar }
+
+cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
+-- Make a fresh MetaTyVar, basing the name
+-- on that of the supplied TyVar
+cloneAnonMetaTyVar info tv kind
+  = do  { details <- newMetaDetails info
+        ; name    <- cloneMetaTyVarName (tyVarName tv)
+        ; let tyvar = mkTcTyVar name kind details
+        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+newFskTyVar :: TcType -> TcM TcTyVar
+newFskTyVar fam_ty
+  = do { details <- newMetaDetails FlatSkolTv
+       ; name <- newMetaTyVarName (fsLit "fsk")
+       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+
+newFmvTyVar :: TcType -> TcM TcTyVar
+-- Very like newMetaTyVar, except sets mtv_tclvl to one less
+-- so that the fmv is untouchable.
+newFmvTyVar fam_ty
+  = do { details <- newMetaDetails FlatMetaTv
+       ; name <- newMetaTyVarName (fsLit "s")
+       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+
+newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
+newMetaDetails info
+  = do { ref <- newMutVar Flexi
+       ; tclvl <- getTcLevel
+       ; return (MetaTv { mtv_info = info
+                        , mtv_ref = ref
+                        , mtv_tclvl = tclvl }) }
+
+cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
+cloneMetaTyVar tv
+  = ASSERT( isTcTyVar tv )
+    do  { ref  <- newMutVar Flexi
+        ; name' <- cloneMetaTyVarName (tyVarName tv)
+        ; let details' = case tcTyVarDetails tv of
+                           details@(MetaTv {}) -> details { mtv_ref = ref }
+                           _ -> pprPanic "cloneMetaTyVar" (ppr tv)
+              tyvar = mkTcTyVar name' (tyVarKind tv) details'
+        ; traceTc "cloneMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+-- Works for both type and kind variables
+readMetaTyVar :: TyVar -> TcM MetaDetails
+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+                      readMutVar (metaTyVarRef tyvar)
+
+isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)
+isFilledMetaTyVar_maybe tv
+ | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
+ = do { cts <- readTcRef ref
+      ; case cts of
+          Indirect ty -> return (Just ty)
+          Flexi       -> return Nothing }
+ | otherwise
+ = return Nothing
+
+isFilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a filled-in (Indirect) meta type variable
+isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv
+
+isUnfilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a un-filled-in (Flexi) meta type variable
+-- NB: Not the opposite of isFilledMetaTyVar
+isUnfilledMetaTyVar tv
+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
+  = do  { details <- readMutVar ref
+        ; return (isFlexi details) }
+  | otherwise = return False
+
+--------------------
+-- Works with both type and kind variables
+writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
+-- Write into a currently-empty MetaTyVar
+
+writeMetaTyVar tyvar ty
+  | not debugIsOn
+  = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty
+
+-- Everything from here on only happens if DEBUG is on
+  | not (isTcTyVar tyvar)
+  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )
+    return ()
+
+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar
+  = writeMetaTyVarRef tyvar ref ty
+
+  | otherwise
+  = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
+    return ()
+
+--------------------
+writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
+-- Here the tyvar is for error checking only;
+-- the ref cell must be for the same tyvar
+writeMetaTyVarRef tyvar ref ty
+  | not debugIsOn
+  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)
+                                   <+> text ":=" <+> ppr ty)
+       ; writeTcRef ref (Indirect ty) }
+
+  -- Everything from here on only happens if DEBUG is on
+  | otherwise
+  = do { meta_details <- readMutVar ref;
+       -- Zonk kinds to allow the error check to work
+       ; zonked_tv_kind <- zonkTcType tv_kind
+       ; zonked_ty_kind <- zonkTcType ty_kind
+       ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind
+                          || tcEqKind zonked_ty_kind zonked_tv_kind
+             -- Hack alert! tcIsConstraintKind: see TcHsType
+             -- Note [Extra-constraint holes in partial type signatures]
+
+             kind_msg = hang (text "Ill-kinded update to meta tyvar")
+                           2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)
+                              <+> text ":="
+                              <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )
+
+       ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
+
+       -- Check for double updates
+       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )
+
+       -- Check for level OK
+       -- See Note [Level check when unifying]
+       ; MASSERT2( level_check_ok, level_check_msg )
+
+       -- Check Kinds ok
+       ; MASSERT2( kind_check_ok, kind_msg )
+
+       -- Do the write
+       ; writeMutVar ref (Indirect ty) }
+  where
+    tv_kind = tyVarKind tyvar
+    ty_kind = tcTypeKind ty
+
+    tv_lvl = tcTyVarLevel tyvar
+    ty_lvl = tcTypeLevel ty
+
+    level_check_ok  = not (ty_lvl `strictlyDeeperThan` tv_lvl)
+    level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty
+
+    double_upd_msg details = hang (text "Double update of meta tyvar")
+                                2 (ppr tyvar $$ ppr details)
+
+{- Note [Level check when unifying]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When unifying
+     alpha:lvl := ty
+we expect that the TcLevel of 'ty' will be <= lvl.
+However, during unflatting we do
+     fuv:l := ty:(l+1)
+which is usually wrong; hence the check isFmmvTyVar in level_check_ok.
+See Note [TcLevel assignment] in TcType.
+-}
+
+{-
+% Generating fresh variables for pattern match check
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+        MetaTvs: TauTvs
+*                                                                      *
+************************************************************************
+
+Note [Never need to instantiate coercion variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With coercion variables sloshing around in types, it might seem that we
+sometimes need to instantiate coercion variables. This would be problematic,
+because coercion variables inhabit unboxed equality (~#), and the constraint
+solver thinks in terms only of boxed equality (~). The solution is that
+we never need to instantiate coercion variables in the first place.
+
+The tyvars that we need to instantiate come from the types of functions,
+data constructors, and patterns. These will never be quantified over
+coercion variables, except for the special case of the promoted Eq#. But,
+that can't ever appear in user code, so we're safe!
+-}
+
+
+newFlexiTyVar :: Kind -> TcM TcTyVar
+newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
+
+newFlexiTyVarTy :: Kind -> TcM TcType
+newFlexiTyVarTy kind = do
+    tc_tyvar <- newFlexiTyVar kind
+    return (mkTyVarTy tc_tyvar)
+
+newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
+newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind)
+
+newOpenTypeKind :: TcM TcKind
+newOpenTypeKind
+  = do { rr <- newFlexiTyVarTy runtimeRepTy
+       ; return (tYPE rr) }
+
+-- | Create a tyvar that can be a lifted or unlifted type.
+-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh
+newOpenFlexiTyVarTy :: TcM TcType
+newOpenFlexiTyVarTy
+  = do { kind <- newOpenTypeKind
+       ; newFlexiTyVarTy kind }
+
+newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Instantiate with META type variables
+-- Note that this works for a sequence of kind, type, and coercion variables
+-- variables.  Eg    [ (k:*), (a:k->k) ]
+--             Gives [ (k7:*), (a8:k7->k7) ]
+newMetaTyVars = newMetaTyVarsX emptyTCvSubst
+    -- emptyTCvSubst has an empty in-scope set, but that's fine here
+    -- Since the tyvars are freshly made, they cannot possibly be
+    -- captured by any existing for-alls.
+
+newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Just like newMetaTyVars, but start with an existing substitution.
+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+
+newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Make a new unification variable tyvar whose Name and Kind come from
+-- an existing TyVar. We substitute kind variables in the kind.
+newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar
+
+newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst
+
+newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Just like newMetaTyVarX, but make a TyVarTv
+newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar
+
+newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+newWildCardX subst tv
+  = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))
+       ; return (extendTvSubstWithClone subst tv new_tv, new_tv) }
+
+new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+new_meta_tv_x info subst tv
+  = do  { new_tv <- cloneAnonMetaTyVar info tv substd_kind
+        ; let subst1 = extendTvSubstWithClone subst tv new_tv
+        ; return (subst1, new_tv) }
+  where
+    substd_kind = substTyUnchecked subst (tyVarKind tv)
+      -- NOTE: #12549 is fixed so we could use
+      -- substTy here, but the tc_infer_args problem
+      -- is not yet fixed so leaving as unchecked for now.
+      -- OLD NOTE:
+      -- Unchecked because we call newMetaTyVarX from
+      -- tcInstTyBinder, which is called from tcInferApps
+      -- which does not yet take enough trouble to ensure
+      -- the in-scope set is right; e.g. #12785 trips
+      -- if we use substTy here
+
+newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
+newMetaTyVarTyAtLevel tc_lvl kind
+  = do  { ref  <- newMutVar Flexi
+        ; name <- newMetaTyVarName (fsLit "p")
+        ; let details = MetaTv { mtv_info  = TauTv
+                               , mtv_ref   = ref
+                               , mtv_tclvl = tc_lvl }
+        ; return (mkTyVarTy (mkTcTyVar name kind details)) }
+
+{- *********************************************************************
+*                                                                      *
+          Finding variables to quantify over
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Dependent type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Haskell type inference we quantify over type variables; but we only
+quantify over /kind/ variables when -XPolyKinds is on.  Without -XPolyKinds
+we default the kind variables to *.
+
+So, to support this defaulting, and only for that reason, when
+collecting the free vars of a type, prior to quantifying, we must keep
+the type and kind variables separate.
+
+But what does that mean in a system where kind variables /are/ type
+variables? It's a fairly arbitrary distinction based on how the
+variables appear:
+
+  - "Kind variables" appear in the kind of some other free variable
+
+     These are the ones we default to * if -XPolyKinds is off
+
+  - "Type variables" are all free vars that are not kind variables
+
+E.g.  In the type    T k (a::k)
+      'k' is a kind variable, because it occurs in the kind of 'a',
+          even though it also appears at "top level" of the type
+      'a' is a type variable, because it doesn't
+
+We gather these variables using a CandidatesQTvs record:
+  DV { dv_kvs: Variables free in the kind of a free type variable
+               or of a forall-bound type variable
+     , dv_tvs: Variables sytactically free in the type }
+
+So:  dv_kvs            are the kind variables of the type
+     (dv_tvs - dv_kvs) are the type variable of the type
+
+Note that
+
+* A variable can occur in both.
+      T k (x::k)    The first occurrence of k makes it
+                    show up in dv_tvs, the second in dv_kvs
+
+* We include any coercion variables in the "dependent",
+  "kind-variable" set because we never quantify over them.
+
+* The "kind variables" might depend on each other; e.g
+     (k1 :: k2), (k2 :: *)
+  The "type variables" do not depend on each other; if
+  one did, it'd be classified as a kind variable!
+
+Note [CandidatesQTvs determinism and order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Determinism: when we quantify over type variables we decide the
+  order in which they appear in the final type. Because the order of
+  type variables in the type can end up in the interface file and
+  affects some optimizations like worker-wrapper, we want this order to
+  be deterministic.
+
+  To achieve that we use deterministic sets of variables that can be
+  converted to lists in a deterministic order. For more information
+  about deterministic sets see Note [Deterministic UniqFM] in UniqDFM.
+
+* Order: as well as being deterministic, we use an
+  accumulating-parameter style for candidateQTyVarsOfType so that we
+  add variables one at a time, left to right.  That means we tend to
+  produce the variables in left-to-right order.  This is just to make
+  it bit more predictable for the programmer.
+
+Note [Naughty quantification candidates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#14880, dependent/should_compile/T14880-2), suppose
+we are trying to generalise this type:
+
+  forall arg. ... (alpha[tau]:arg) ...
+
+We have a metavariable alpha whose kind mentions a skolem variable
+boudn inside the very type we are generalising.
+This can arise while type-checking a user-written type signature
+(see the test case for the full code).
+
+We cannot generalise over alpha!  That would produce a type like
+  forall {a :: arg}. forall arg. ...blah...
+The fact that alpha's kind mentions arg renders it completely
+ineligible for generaliation.
+
+However, we are not going to learn any new constraints on alpha,
+because its kind isn't even in scope in the outer context.  So alpha
+is entirely unconstrained.
+
+What then should we do with alpha?  During generalization, every
+metavariable is either (A) promoted, (B) generalized, or (C) zapped
+(according again to Note [Recipe for checking a signature] in
+TcHsType).
+
+ * We can't generalise it.
+ * We can't promote it, because its kind prevents that
+ * We can't simply leave it be, because this type is about to
+   go into the typing environment (as the type of some let-bound
+   variable, say), and then chaos erupts when we try to instantiate.
+
+So, we zap it, eagerly, to Any. We don't have to do this eager zapping
+in terms (say, in `length []`) because terms are never re-examined before
+the final zonk (which zaps any lingering metavariables to Any).
+
+We do this eager zapping in candidateQTyVars, which always precedes
+generalisation, because at that moment we have a clear picture of
+what skolems are in scope.
+
+-}
+
+data CandidatesQTvs
+  -- See Note [Dependent type variables]
+  -- See Note [CandidatesQTvs determinism and order]
+  --
+  -- Invariants:
+  --   * All variables stored here are MetaTvs. No exceptions.
+  --   * All variables are fully zonked, including their kinds
+  --
+  = DV { dv_kvs :: DTyVarSet    -- "kind" metavariables (dependent)
+       , dv_tvs :: DTyVarSet    -- "type" metavariables (non-dependent)
+         -- A variable may appear in both sets
+         -- E.g.   T k (x::k)    The first occurrence of k makes it
+         --                      show up in dv_tvs, the second in dv_kvs
+         -- See Note [Dependent type variables]
+
+       , dv_cvs :: CoVarSet
+         -- These are covars. We will *not* quantify over these, but
+         -- we must make sure also not to quantify over any cv's kinds,
+         -- so we include them here as further direction for quantifyTyVars
+    }
+
+instance Semi.Semigroup CandidatesQTvs where
+   (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 })
+     <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 })
+          = DV { dv_kvs = kv1 `unionDVarSet` kv2
+               , dv_tvs = tv1 `unionDVarSet` tv2
+               , dv_cvs = cv1 `unionVarSet` cv2 }
+
+instance Monoid CandidatesQTvs where
+   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet }
+   mappend = (Semi.<>)
+
+instance Outputable CandidatesQTvs where
+  ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs })
+    = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs
+                                             , text "dv_tvs =" <+> ppr tvs
+                                             , text "dv_cvs =" <+> ppr cvs ])
+
+
+candidateKindVars :: CandidatesQTvs -> TyVarSet
+candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)
+
+-- | Gathers free variables to use as quantification candidates (in
+-- 'quantifyTyVars'). This might output the same var
+-- in both sets, if it's used in both a type and a kind.
+-- See Note [CandidatesQTvs determinism and order]
+-- See Note [Dependent type variables]
+candidateQTyVarsOfType :: TcType       -- not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty
+
+-- | Like 'splitDepVarsOfType', but over a list of types
+candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs
+candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys
+
+-- | Like 'candidateQTyVarsOfType', but consider every free variable
+-- to be dependent. This is appropriate when generalizing a *kind*,
+-- instead of a type. (That way, -XNoPolyKinds will default the variables
+-- to Type.)
+candidateQTyVarsOfKind :: TcKind       -- Not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty
+
+candidateQTyVarsOfKinds :: [TcKind]    -- Not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys
+
+delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars
+  = DV { dv_kvs = kvs `delDVarSetList` vars
+       , dv_tvs = tvs `delDVarSetList` vars
+       , dv_cvs = cvs `delVarSetList`  vars }
+
+collect_cand_qtvs
+  :: Bool            -- True <=> consider every fv in Type to be dependent
+  -> VarSet          -- Bound variables (both locally bound and globally bound)
+  -> CandidatesQTvs  -- Accumulating parameter
+  -> Type            -- Not necessarily zonked
+  -> TcM CandidatesQTvs
+
+-- Key points:
+--   * Looks through meta-tyvars as it goes;
+--     no need to zonk in advance
+--
+--   * Needs to be monadic anyway, because it does the zap-naughty
+--     stuff; see Note [Naughty quantification candidates]
+--
+--   * Returns fully-zonked CandidateQTvs, including their kinds
+--     so that subsequent dependency analysis (to build a well
+--     scoped telescope) works correctly
+
+collect_cand_qtvs is_dep bound dvs ty
+  = go dvs ty
+  where
+    is_bound tv = tv `elemVarSet` bound
+
+    -----------------
+    go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs
+    -- Uses accumulating-parameter style
+    go dv (AppTy t1 t2)     = foldlM go dv [t1, t2]
+    go dv (TyConApp _ tys)  = foldlM go dv tys
+    go dv (FunTy _ arg res) = foldlM go dv [arg, res]
+    go dv (LitTy {})        = return dv
+    go dv (CastTy ty co)    = do dv1 <- go dv ty
+                                 collect_cand_qtvs_co bound dv1 co
+    go dv (CoercionTy co)   = collect_cand_qtvs_co bound dv co
+
+    go dv (TyVarTy tv)
+      | is_bound tv = return dv
+      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv
+                         ; case m_contents of
+                             Just ind_ty -> go dv ind_ty
+                             Nothing     -> go_tv dv tv }
+
+    go dv (ForAllTy (Bndr tv _) ty)
+      = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)
+           ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty }
+
+    -----------------
+    go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
+      | tv `elemDVarSet` kvs = return dv  -- We have met this tyvar aleady
+      | not is_dep
+      , tv `elemDVarSet` tvs = return dv  -- We have met this tyvar aleady
+      | otherwise
+      = do { tv_kind <- zonkTcType (tyVarKind tv)
+                 -- This zonk is annoying, but it is necessary, both to
+                 -- ensure that the collected candidates have zonked kinds
+                 -- (#15795) and to make the naughty check
+                 -- (which comes next) works correctly
+           ; if intersectsVarSet bound (tyCoVarsOfType tv_kind)
+
+             then -- See Note [Naughty quantification candidates]
+                  do { traceTc "Zapping naughty quantifier" (pprTyVar tv)
+                     ; writeMetaTyVar tv (anyTypeOfKind tv_kind)
+                     ; collect_cand_qtvs True bound dv tv_kind }
+
+             else do { let tv' = tv `setTyVarKind` tv_kind
+                           dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }
+                               | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }
+                               -- See Note [Order of accumulation]
+                     ; collect_cand_qtvs True emptyVarSet dv' tv_kind } }
+
+collect_cand_qtvs_co :: VarSet -- bound variables
+                     -> CandidatesQTvs -> Coercion
+                     -> TcM CandidatesQTvs
+collect_cand_qtvs_co bound = go_co
+  where
+    go_co dv (Refl ty)             = collect_cand_qtvs True bound dv ty
+    go_co dv (GRefl _ ty mco)      = do dv1 <- collect_cand_qtvs True bound dv ty
+                                        go_mco dv1 mco
+    go_co dv (TyConAppCo _ _ cos)  = foldlM go_co dv cos
+    go_co dv (AppCo co1 co2)       = foldlM go_co dv [co1, co2]
+    go_co dv (FunCo _ co1 co2)     = foldlM go_co dv [co1, co2]
+    go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos
+    go_co dv (AxiomRuleCo _ cos)   = foldlM go_co dv cos
+    go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov
+                                        dv2 <- collect_cand_qtvs True bound dv1 t1
+                                        collect_cand_qtvs True bound dv2 t2
+    go_co dv (SymCo co)            = go_co dv co
+    go_co dv (TransCo co1 co2)     = foldlM go_co dv [co1, co2]
+    go_co dv (NthCo _ _ co)        = go_co dv co
+    go_co dv (LRCo _ co)           = go_co dv co
+    go_co dv (InstCo co1 co2)      = foldlM go_co dv [co1, co2]
+    go_co dv (KindCo co)           = go_co dv co
+    go_co dv (SubCo co)            = go_co dv co
+
+    go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole
+                                case m_co of
+                                  Just co -> go_co dv co
+                                  Nothing -> go_cv dv (coHoleCoVar hole)
+
+    go_co dv (CoVarCo cv) = go_cv dv cv
+
+    go_co dv (ForAllCo tcv kind_co co)
+      = do { dv1 <- go_co dv kind_co
+           ; collect_cand_qtvs_co (bound `extendVarSet` tcv) dv1 co }
+
+    go_mco dv MRefl    = return dv
+    go_mco dv (MCo co) = go_co dv co
+
+    go_prov dv UnsafeCoerceProv    = return dv
+    go_prov dv (PhantomProv co)    = go_co dv co
+    go_prov dv (ProofIrrelProv co) = go_co dv co
+    go_prov dv (PluginProv _)      = return dv
+
+    go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
+    go_cv dv@(DV { dv_cvs = cvs }) cv
+      | is_bound cv         = return dv
+      | cv `elemVarSet` cvs = return dv
+      | otherwise           = collect_cand_qtvs True emptyVarSet
+                                    (dv { dv_cvs = cvs `extendVarSet` cv })
+                                    (idType cv)
+
+    is_bound tv = tv `elemVarSet` bound
+
+{- Note [Order of accumulation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might be tempted (like I was) to use unitDVarSet and mappend
+rather than extendDVarSet.  However, the union algorithm for
+deterministic sets depends on (roughly) the size of the sets. The
+elements from the smaller set end up to the right of the elements from
+the larger one. When sets are equal, the left-hand argument to
+`mappend` goes to the right of the right-hand argument.
+
+In our case, if we use unitDVarSet and mappend, we learn that the free
+variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify
+over them in that order. (The a comes after the b because we union the
+singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,
+the size criterion works to our advantage.) This is just annoying to
+users, so I use `extendDVarSet`, which unambiguously puts the new
+element to the right.
+
+Note that the unitDVarSet/mappend implementation would not be wrong
+against any specification -- just suboptimal and confounding to users.
+-}
+
+{- *********************************************************************
+*                                                                      *
+             Quantification
+*                                                                      *
+************************************************************************
+
+Note [quantifyTyVars]
+~~~~~~~~~~~~~~~~~~~~~
+quantifyTyVars is given the free vars of a type that we
+are about to wrap in a forall.
+
+It takes these free type/kind variables (partitioned into dependent and
+non-dependent variables) and
+  1. Zonks them and remove globals and covars
+  2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)
+  3. Calls skolemiseQuantifiedTyVar on each
+
+Step (2) is often unimportant, because the kind variable is often
+also free in the type.  Eg
+     Typeable k (a::k)
+has free vars {k,a}.  But the type (see #7916)
+    (f::k->*) (a::k)
+has free vars {f,a}, but we must add 'k' as well! Hence step (2).
+
+* This function distinguishes between dependent and non-dependent
+  variables only to keep correct defaulting behavior with -XNoPolyKinds.
+  With -XPolyKinds, it treats both classes of variables identically.
+
+* quantifyTyVars never quantifies over
+    - a coercion variable (or any tv mentioned in the kind of a covar)
+    - a runtime-rep variable
+
+Note [quantifyTyVars determinism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The results of quantifyTyVars are wrapped in a forall and can end up in the
+interface file. One such example is inferred type signatures. They also affect
+the results of optimizations, for example worker-wrapper. This means that to
+get deterministic builds quantifyTyVars needs to be deterministic.
+
+To achieve this CandidatesQTvs is backed by deterministic sets which allows them
+to be later converted to a list in a deterministic order.
+
+For more information about deterministic sets see
+Note [Deterministic UniqFM] in UniqDFM.
+-}
+
+quantifyTyVars
+  :: TcTyCoVarSet     -- Global tvs; already zonked
+  -> CandidatesQTvs   -- See Note [Dependent type variables]
+                      -- Already zonked
+  -> TcM [TcTyVar]
+-- See Note [quantifyTyVars]
+-- Can be given a mixture of TcTyVars and TyVars, in the case of
+--   associated type declarations. Also accepts covars, but *never* returns any.
+quantifyTyVars gbl_tvs
+               dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars })
+  = do { outer_tclvl <- getTcLevel
+       ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs])
+       ; let co_tvs = closeOverKinds covars
+             mono_tvs = gbl_tvs `unionVarSet` co_tvs
+              -- NB: All variables in the kind of a covar must not be
+              -- quantified over, as we don't quantify over the covar.
+
+             dep_kvs = dVarSetElemsWellScoped $
+                       dep_tkvs `dVarSetMinusVarSet` mono_tvs
+                       -- dVarSetElemsWellScoped: put the kind variables into
+                       --    well-scoped order.
+                       --    E.g.  [k, (a::k)] not the other way roud
+
+             nondep_tvs = dVarSetElems $
+                          (nondep_tkvs `minusDVarSet` dep_tkvs)
+                           `dVarSetMinusVarSet` mono_tvs
+                 -- See Note [Dependent type variables]
+                 -- The `minus` dep_tkvs removes any kind-level vars
+                 --    e.g. T k (a::k)   Since k appear in a kind it'll
+                 --    be in dv_kvs, and is dependent. So remove it from
+                 --    dv_tvs which will also contain k
+                 -- No worry about dependent covars here;
+                 --    they are all in dep_tkvs
+                 -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV
+
+       -- This block uses level numbers to decide what to quantify
+       -- and emits a warning if the two methods do not give the same answer
+       ; let dep_kvs2    = dVarSetElemsWellScoped $
+                           filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs
+             nondep_tvs2 = filter (quantifiableTv outer_tclvl) $
+                           dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)
+
+             all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2
+             bad_msg = hang (text "Quantification by level numbers would fail")
+                          2 (vcat [ text "Outer level =" <+> ppr outer_tclvl
+                                  , text "dep_tkvs ="    <+> ppr dep_tkvs
+                                  , text "co_vars ="     <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv)
+                                                                  | cv <- nonDetEltsUniqSet covars ]
+                                  , text "co_tvs ="      <+> ppr co_tvs
+                                  , text "dep_kvs ="     <+> ppr dep_kvs
+                                  , text "dep_kvs2 ="    <+> ppr dep_kvs2
+                                  , text "nondep_tvs ="  <+> ppr nondep_tvs
+                                  , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ])
+       ; WARN( not all_ok, bad_msg ) return ()
+
+             -- In the non-PolyKinds case, default the kind variables
+             -- to *, and zonk the tyvars as usual.  Notice that this
+             -- may make quantifyTyVars return a shorter list
+             -- than it was passed, but that's ok
+       ; poly_kinds  <- xoptM LangExt.PolyKinds
+       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs
+       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs
+       ; let final_qtvs = dep_kvs' ++ nondep_tvs'
+           -- Because of the order, any kind variables
+           -- mentioned in the kinds of the nondep_tvs'
+           -- now refer to the dep_kvs'
+
+       ; traceTc "quantifyTyVars 2"
+           (vcat [ text "globals:"    <+> ppr gbl_tvs
+                 , text "mono_tvs:"   <+> ppr mono_tvs
+                 , text "nondep:"     <+> pprTyVars nondep_tvs
+                 , text "dep:"        <+> pprTyVars dep_kvs
+                 , text "dep_kvs'"    <+> pprTyVars dep_kvs'
+                 , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])
+
+       -- We should never quantify over coercion variables; check this
+       ; let co_vars = filter isCoVar final_qtvs
+       ; MASSERT2( null co_vars, ppr co_vars )
+
+       ; return final_qtvs }
+  where
+    -- zonk_quant returns a tyvar if it should be quantified over;
+    -- otherwise, it returns Nothing. The latter case happens for
+    --    * Kind variables, with -XNoPolyKinds: don't quantify over these
+    --    * RuntimeRep variables: we never quantify over these
+    zonk_quant default_kind tkv
+      | not (isTyVar tkv)
+      = return Nothing   -- this can happen for a covar that's associated with
+                         -- a coercion hole. Test case: typecheck/should_compile/T2494
+
+      | not (isTcTyVar tkv)  -- I don't think this can ever happen.
+                             -- Hence the assert
+      = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv)
+        return (Just tkv)
+
+      | otherwise
+      = do { deflt_done <- defaultTyVar default_kind tkv
+           ; case deflt_done of
+               True  -> return Nothing
+               False -> do { tv <- skolemiseQuantifiedTyVar tkv
+                           ; return (Just tv) } }
+
+quantifiableTv :: TcLevel   -- Level of the context, outside the quantification
+               -> TcTyVar
+               -> Bool
+quantifiableTv outer_tclvl tcv
+  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately
+  = tcTyVarLevel tcv > outer_tclvl
+  | otherwise
+  = False
+
+zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar
+-- A tyvar binder is never a unification variable (TauTv),
+-- rather it is always a skolem. It *might* be a TyVarTv.
+-- (Because non-CUSK type declarations use TyVarTvs.)
+-- Regardless, it may have a kind that has not yet been zonked,
+-- and may include kind unification variables.
+zonkAndSkolemise tyvar
+  | isTyVarTyVar tyvar
+     -- We want to preserve the binding location of the original TyVarTv.
+     -- This is important for error messages. If we don't do this, then
+     -- we get bad locations in, e.g., typecheck/should_fail/T2688
+  = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar
+       ; skolemiseQuantifiedTyVar zonked_tyvar }
+
+  | otherwise
+  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )
+    zonkTyCoVarKind tyvar
+
+skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
+-- The quantified type variables often include meta type variables
+-- we want to freeze them into ordinary type variables
+-- The meta tyvar is updated to point to the new skolem TyVar.  Now any
+-- bound occurrences of the original type variable will get zonked to
+-- the immutable version.
+--
+-- We leave skolem TyVars alone; they are immutable.
+--
+-- This function is called on both kind and type variables,
+-- but kind variables *only* if PolyKinds is on.
+
+skolemiseQuantifiedTyVar tv
+  = case tcTyVarDetails tv of
+      SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)
+                        ; return (setTyVarKind tv kind) }
+        -- It might be a skolem type variable,
+        -- for example from a user type signature
+
+      MetaTv {} -> skolemiseUnboundMetaTyVar tv
+
+      _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk
+
+defaultTyVar :: Bool      -- True <=> please default this kind variable to *
+             -> TcTyVar   -- If it's a MetaTyVar then it is unbound
+             -> TcM Bool  -- True <=> defaulted away altogether
+
+defaultTyVar default_kind tv
+  | not (isMetaTyVar tv)
+  = return False
+
+  | isTyVarTyVar tv
+    -- Do not default TyVarTvs. Doing so would violate the invariants
+    -- on TyVarTvs; see Note [Signature skolems] in TcType.
+    -- #13343 is an example; #14555 is another
+    -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+  = return False
+
+
+  | isRuntimeRepVar tv  -- Do not quantify over a RuntimeRep var
+                        -- unless it is a TyVarTv, handled earlier
+  = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)
+       ; writeMetaTyVar tv liftedRepTy
+       ; return True }
+
+  | default_kind            -- -XNoPolyKinds and this is a kind var
+  = default_kind_var tv     -- so default it to * if possible
+
+  | otherwise
+  = return False
+
+  where
+    default_kind_var :: TyVar -> TcM Bool
+       -- defaultKindVar is used exclusively with -XNoPolyKinds
+       -- See Note [Defaulting with -XNoPolyKinds]
+       -- It takes an (unconstrained) meta tyvar and defaults it.
+       -- Works only on vars of type *; for other kinds, it issues an error.
+    default_kind_var kv
+      | isLiftedTypeKind (tyVarKind kv)
+      = do { traceTc "Defaulting a kind var to *" (ppr kv)
+           ; writeMetaTyVar kv liftedTypeKind
+           ; return True }
+      | otherwise
+      = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
+                          , text "of kind:" <+> ppr (tyVarKind kv')
+                          , text "Perhaps enable PolyKinds or add a kind signature" ])
+           -- We failed to default it, so return False to say so.
+           -- Hence, it'll get skolemised.  That might seem odd, but we must either
+           -- promote, skolemise, or zap-to-Any, to satisfy TcHsType
+           --    Note [Recipe for checking a signature]
+           -- Otherwise we get level-number assertion failures. It doesn't matter much
+           -- because we are in an error siutation anyway.
+           ; return False
+        }
+      where
+        (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
+
+skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar
+-- We have a Meta tyvar with a ref-cell inside it
+-- Skolemise it, so that we are totally out of Meta-tyvar-land
+-- We create a skolem TcTyVar, not a regular TyVar
+--   See Note [Zonking to Skolem]
+skolemiseUnboundMetaTyVar tv
+  = ASSERT2( isMetaTyVar tv, ppr tv )
+    do  { when debugIsOn (check_empty tv)
+        ; span <- getSrcSpanM    -- Get the location from "here"
+                                 -- ie where we are generalising
+        ; kind <- zonkTcType (tyVarKind tv)
+        ; let uniq        = getUnique tv
+                -- NB: Use same Unique as original tyvar. This is
+                -- convenient in reading dumps, but is otherwise inessential.
+
+              tv_name     = getOccName tv
+              final_name  = mkInternalName uniq tv_name span
+              final_tv    = mkTcTyVar final_name kind details
+
+        ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)
+        ; writeMetaTyVar tv (mkTyVarTy final_tv)
+        ; return final_tv }
+
+  where
+    details = SkolemTv (metaTyVarTcLevel tv) False
+    check_empty tv       -- [Sept 04] Check for non-empty.
+      = when debugIsOn $  -- See note [Silly Type Synonym]
+        do { cts <- readMetaTyVar tv
+           ; case cts of
+               Flexi       -> return ()
+               Indirect ty -> WARN( True, ppr tv $$ ppr ty )
+                              return () }
+
+{- Note [Defaulting with -XNoPolyKinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data Compose f g a = Mk (f (g a))
+
+We infer
+
+  Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> *
+  Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1).
+        f (g a) -> Compose k1 k2 f g a
+
+Now, in another module, we have -XNoPolyKinds -XDataKinds in effect.
+What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds,
+we just defaulted all kind variables to *. But that's no good here,
+because the kind variables in 'Mk aren't of kind *, so defaulting to *
+is ill-kinded.
+
+After some debate on #11334, we decided to issue an error in this case.
+The code is in defaultKindVar.
+
+Note [What is a meta variable?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "meta type-variable", also know as a "unification variable" is a placeholder
+introduced by the typechecker for an as-yet-unknown monotype.
+
+For example, when we see a call `reverse (f xs)`, we know that we calling
+    reverse :: forall a. [a] -> [a]
+So we know that the argument `f xs` must be a "list of something". But what is
+the "something"? We don't know until we explore the `f xs` a bit more. So we set
+out what we do know at the call of `reverse` by instantiate its type with a fresh
+meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the
+result, is `[alpha]`. The unification variable `alpha` stands for the
+as-yet-unknown type of the elements of the list.
+
+As type inference progresses we may learn more about `alpha`. For example, suppose
+`f` has the type
+    f :: forall b. b -> [Maybe b]
+Then we instantiate `f`'s type with another fresh unification variable, say
+`beta`; and equate `f`'s result type with reverse's argument type, thus
+`[alpha] ~ [Maybe beta]`.
+
+Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've
+refined our knowledge about `alpha`. And so on.
+
+If you found this Note useful, you may also want to have a look at
+Section 5 of "Practical type inference for higher rank types" (Peyton Jones,
+Vytiniotis, Weirich and Shields. J. Functional Programming. 2011).
+
+Note [What is zonking?]
+~~~~~~~~~~~~~~~~~~~~~~~
+GHC relies heavily on mutability in the typechecker for efficient operation.
+For this reason, throughout much of the type checking process meta type
+variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable
+variables (known as TcRefs).
+
+Zonking is the process of ripping out these mutable variables and replacing them
+with a real Type. This involves traversing the entire type expression, but the
+interesting part of replacing the mutable variables occurs in zonkTyVarOcc.
+
+There are two ways to zonk a Type:
+
+ * zonkTcTypeToType, which is intended to be used at the end of type-checking
+   for the final zonk. It has to deal with unfilled metavars, either by filling
+   it with a value like Any or failing (determined by the UnboundTyVarZonker
+   used).
+
+ * zonkTcType, which will happily ignore unfilled metavars. This is the
+   appropriate function to use while in the middle of type-checking.
+
+Note [Zonking to Skolem]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We used to zonk quantified type variables to regular TyVars.  However, this
+leads to problems.  Consider this program from the regression test suite:
+
+  eval :: Int -> String -> String -> String
+  eval 0 root actual = evalRHS 0 root actual
+
+  evalRHS :: Int -> a
+  evalRHS 0 root actual = eval 0 root actual
+
+It leads to the deferral of an equality (wrapped in an implication constraint)
+
+  forall a. () => ((String -> String -> String) ~ a)
+
+which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).
+In the meantime `a' is zonked and quantified to form `evalRHS's signature.
+This has the *side effect* of also zonking the `a' in the deferred equality
+(which at this point is being handed around wrapped in an implication
+constraint).
+
+Finally, the equality (with the zonked `a') will be handed back to the
+simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop.
+If we zonk `a' with a regular type variable, we will have this regular type
+variable now floating around in the simplifier, which in many places assumes to
+only see proper TcTyVars.
+
+We can avoid this problem by zonking with a skolem.  The skolem is rigid
+(which we require for a quantified variable), but is still a TcTyVar that the
+simplifier knows how to deal with.
+
+Note [Silly Type Synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+        type C u a = u  -- Note 'a' unused
+
+        foo :: (forall a. C u a -> C u a) -> u
+        foo x = ...
+
+        bar :: Num u => u
+        bar = foo (\t -> t + t)
+
+* From the (\t -> t+t) we get type  {Num d} =>  d -> d
+  where d is fresh.
+
+* Now unify with type of foo's arg, and we get:
+        {Num (C d a)} =>  C d a -> C d a
+  where a is fresh.
+
+* Now abstract over the 'a', but float out the Num (C d a) constraint
+  because it does not 'really' mention a.  (see exactTyVarsOfType)
+  The arg to foo becomes
+        \/\a -> \t -> t+t
+
+* So we get a dict binding for Num (C d a), which is zonked to give
+        a = ()
+  [Note Sept 04: now that we are zonking quantified type variables
+  on construction, the 'a' will be frozen as a regular tyvar on
+  quantification, so the floated dict will still have type (C d a).
+  Which renders this whole note moot; happily!]
+
+* Then the \/\a abstraction has a zonked 'a' in it.
+
+All very silly.   I think its harmless to ignore the problem.  We'll end up with
+a \/\a in the final result but all the occurrences of a will be zonked to ()
+
+************************************************************************
+*                                                                      *
+              Zonking types
+*                                                                      *
+************************************************************************
+
+-}
+
+-- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in
+-- the environment. To improve subsequent calls to the same function it writes
+-- the zonked set back into the environment. Note that this returns all
+-- variables free in anything (term-level or type-level) in scope. We thus
+-- don't have to worry about clashes with things that are not in scope, because
+-- if they are reachable, then they'll be returned here.
+-- NB: This is closed over kinds, so it can return unification variables mentioned
+-- in the kinds of in-scope tyvars.
+tcGetGlobalTyCoVars :: TcM TcTyVarSet
+tcGetGlobalTyCoVars
+  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
+       ; gbl_tvs  <- readMutVar gtv_var
+       ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs
+       ; writeMutVar gtv_var gbl_tvs'
+       ; return gbl_tvs' }
+
+zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
+-- Zonk a type and take its free variables
+-- With kind polymorphism it can be essential to zonk *first*
+-- so that we find the right set of free variables.  Eg
+--    forall k1. forall (a:k2). a
+-- where k2:=k1 is in the substitution.  We don't want
+-- k2 to look free in this type!
+zonkTcTypeAndFV ty
+  = tyCoVarsOfTypeDSet <$> zonkTcType ty
+
+zonkTyCoVar :: TyCoVar -> TcM TcType
+-- Works on TyVars and TcTyVars
+zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
+               | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv
+               | otherwise    = ASSERT2( isCoVar tv, ppr tv )
+                                mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv
+   -- Hackily, when typechecking type and class decls
+   -- we have TyVars in scope added (only) in
+   -- TcHsType.bindTyClTyVars, but it seems
+   -- painful to make them into TcTyVars there
+
+zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
+zonkTyCoVarsAndFV tycovars
+  = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
+  -- It's OK to use nonDetEltsUniqSet here because we immediately forget about
+  -- the ordering by turning it into a nondeterministic set and the order
+  -- of zonking doesn't matter for determinism.
+
+-- Takes a list of TyCoVars, zonks them and returns a
+-- deterministically ordered list of their free variables.
+zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]
+zonkTyCoVarsAndFVList tycovars
+  = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars
+
+zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
+zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
+
+-----------------  Types
+zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar
+zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)
+                        ; return (setTyVarKind tv kind') }
+
+zonkTcTypes :: [TcType] -> TcM [TcType]
+zonkTcTypes tys = mapM zonkTcType tys
+
+{-
+************************************************************************
+*                                                                      *
+              Zonking constraints
+*                                                                      *
+************************************************************************
+-}
+
+zonkImplication :: Implication -> TcM Implication
+zonkImplication implic@(Implic { ic_skols  = skols
+                               , ic_given  = given
+                               , ic_wanted = wanted
+                               , ic_info   = info })
+  = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!
+                                                -- as #7230 showed
+       ; given'  <- mapM zonkEvVar given
+       ; info'   <- zonkSkolemInfo info
+       ; wanted' <- zonkWCRec wanted
+       ; return (implic { ic_skols  = skols'
+                        , ic_given  = given'
+                        , ic_wanted = wanted'
+                        , ic_info   = info' }) }
+
+zonkEvVar :: EvVar -> TcM EvVar
+zonkEvVar var = do { ty' <- zonkTcType (varType var)
+                   ; return (setVarType var ty') }
+
+
+zonkWC :: WantedConstraints -> TcM WantedConstraints
+zonkWC wc = zonkWCRec wc
+
+zonkWCRec :: WantedConstraints -> TcM WantedConstraints
+zonkWCRec (WC { wc_simple = simple, wc_impl = implic })
+  = do { simple' <- zonkSimples simple
+       ; implic' <- mapBagM zonkImplication implic
+       ; return (WC { wc_simple = simple', wc_impl = implic' }) }
+
+zonkSimples :: Cts -> TcM Cts
+zonkSimples cts = do { cts' <- mapBagM zonkCt' cts
+                     ; traceTc "zonkSimples done:" (ppr cts')
+                     ; return cts' }
+
+zonkCt' :: Ct -> TcM Ct
+zonkCt' ct = zonkCt ct
+
+{- Note [zonkCt behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+zonkCt tries to maintain the canonical form of a Ct.  For example,
+  - a CDictCan should stay a CDictCan;
+  - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).
+  - a CHoleCan should stay a CHoleCan
+  - a CIrredCan should stay a CIrredCan with its cc_insol flag intact
+
+Why?, for example:
+- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the
+  simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,
+  constraints are zonked before being passed to the plugin. This means if we
+  don't preserve a canonical form, @expandSuperClasses@ fails to expand
+  superclasses. This is what happened in #11525.
+
+- For CHoleCan, once we forget that it's a hole, we can never recover that info.
+
+- For CIrredCan we want to see if a constraint is insoluble with insolubleWC
+
+NB: we do not expect to see any CFunEqCans, because zonkCt is only
+called on unflattened constraints.
+
+NB: Constraints are always re-flattened etc by the canonicaliser in
+@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that
+are actually in the inert set carry all the guarantees. So it is okay if zonkCt
+creates e.g. a CDictCan where the cc_tyars are /not/ function free.
+-}
+
+zonkCt :: Ct -> TcM Ct
+zonkCt ct@(CHoleCan { cc_ev = ev })
+  = do { ev' <- zonkCtEvidence ev
+       ; return $ ct { cc_ev = ev' } }
+
+zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
+  = do { ev'   <- zonkCtEvidence ev
+       ; args' <- mapM zonkTcType args
+       ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
+
+zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })
+  = do { ev'    <- zonkCtEvidence ev
+       ; tv_ty' <- zonkTcTyVar tv
+       ; case getTyVar_maybe tv_ty' of
+           Just tv' -> do { rhs' <- zonkTcType rhs
+                          ; return ct { cc_ev    = ev'
+                                      , cc_tyvar = tv'
+                                      , cc_rhs   = rhs' } }
+           Nothing  -> return (mkNonCanonical ev') }
+
+zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag
+  = do { ev' <- zonkCtEvidence ev
+       ; return (ct { cc_ev = ev' }) }
+
+zonkCt ct
+  = ASSERT( not (isCFunEqCan ct) )
+  -- We do not expect to see any CFunEqCans, because zonkCt is only called on
+  -- unflattened constraints.
+    do { fl' <- zonkCtEvidence (ctEvidence ct)
+       ; return (mkNonCanonical fl') }
+
+zonkCtEvidence :: CtEvidence -> TcM CtEvidence
+zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
+  = do { pred' <- zonkTcType pred
+       ; return (ctev { ctev_pred = pred'}) }
+zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })
+  = do { pred' <- zonkTcType pred
+       ; let dest' = case dest of
+                       EvVarDest ev -> EvVarDest $ setVarType ev pred'
+                         -- necessary in simplifyInfer
+                       HoleDest h   -> HoleDest h
+       ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }
+zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
+  = do { pred' <- zonkTcType pred
+       ; return (ctev { ctev_pred = pred' }) }
+
+zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
+zonkSkolemInfo (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty
+                                            ; return (SigSkol cx ty' tv_prs) }
+zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
+                                     ; return (InferSkol ntys') }
+  where
+    do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
+zonkSkolemInfo skol_info = return skol_info
+
+{-
+%************************************************************************
+%*                                                                      *
+\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}
+*                                                                      *
+*              For internal use only!                                  *
+*                                                                      *
+************************************************************************
+
+-}
+
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+  = do { ty' <- zonkTcType (idType id)
+       ; return (Id.setIdType id ty') }
+
+zonkCoVar :: CoVar -> TcM CoVar
+zonkCoVar = zonkId
+
+-- | A suitable TyCoMapper for zonking a type during type-checking,
+-- before all metavars are filled in.
+zonkTcTypeMapper :: TyCoMapper () TcM
+zonkTcTypeMapper = TyCoMapper
+  { tcm_tyvar = const zonkTcTyVar
+  , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
+  , tcm_hole  = hole
+  , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
+  , tcm_tycon      = zonkTcTyCon }
+  where
+    hole :: () -> CoercionHole -> TcM Coercion
+    hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+      = do { contents <- readTcRef ref
+           ; case contents of
+               Just co -> do { co' <- zonkCo co
+                             ; checkCoercionHole cv co' }
+               Nothing -> do { cv' <- zonkCoVar cv
+                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }
+
+zonkTcTyCon :: TcTyCon -> TcM TcTyCon
+-- Only called on TcTyCons
+-- A non-poly TcTyCon may have unification
+-- variables that need zonking, but poly ones cannot
+zonkTcTyCon tc
+ | tcTyConIsPoly tc = return tc
+ | otherwise        = do { tck' <- zonkTcType (tyConKind tc)
+                         ; return (setTcTyConKind tc tck') }
+
+-- For unbound, mutable tyvars, zonkType uses the function given to it
+-- For tyvars bound at a for-all, zonkType zonks them to an immutable
+--      type variable and zonks the kind too
+zonkTcType :: TcType -> TcM TcType
+zonkTcType = mapType zonkTcTypeMapper ()
+
+-- | "Zonk" a coercion -- really, just zonk any types in the coercion
+zonkCo :: Coercion -> TcM Coercion
+zonkCo = mapCoercion zonkTcTypeMapper ()
+
+zonkTcTyVar :: TcTyVar -> TcM TcType
+-- Simply look through all Flexis
+zonkTcTyVar tv
+  | isTcTyVar tv
+  = case tcTyVarDetails tv of
+      SkolemTv {}   -> zonk_kind_and_return
+      RuntimeUnk {} -> zonk_kind_and_return
+      MetaTv { mtv_ref = ref }
+         -> do { cts <- readMutVar ref
+               ; case cts of
+                    Flexi       -> zonk_kind_and_return
+                    Indirect ty -> do { zty <- zonkTcType ty
+                                      ; writeTcRef ref (Indirect zty)
+                                        -- See Note [Sharing in zonking]
+                                      ; return zty } }
+
+  | otherwise -- coercion variable
+  = zonk_kind_and_return
+  where
+    zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv
+                              ; return (mkTyVarTy z_tv) }
+
+-- Variant that assumes that any result of zonking is still a TyVar.
+-- Should be used only on skolems and TyVarTvs
+zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar
+zonkTcTyVarToTyVar tv
+  = do { ty <- zonkTcTyVar tv
+       ; let tv' = case tcGetTyVar_maybe ty of
+                     Just tv' -> tv'
+                     Nothing  -> pprPanic "zonkTcTyVarToTyVar"
+                                          (ppr tv $$ ppr ty)
+       ; return tv' }
+
+zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)]
+zonkTyVarTyVarPairs prs
+  = mapM do_one prs
+  where
+    do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv
+                         ; return (nm, tv') }
+
+{- Note [Sharing in zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   alpha :-> beta :-> gamma :-> ty
+where the ":->" means that the unification variable has been
+filled in with Indirect. Then when zonking alpha, it'd be nice
+to short-circuit beta too, so we end up with
+   alpha :-> zty
+   beta  :-> zty
+   gamma :-> zty
+where zty is the zonked version of ty.  That way, if we come across
+beta later, we'll have less work to do.  (And indeed the same for
+alpha.)
+
+This is easily achieved: just overwrite (Indirect ty) with (Indirect
+zty).  Non-systematic perf comparisons suggest that this is a modest
+win.
+
+But c.f Note [Sharing when zonking to Type] in TcHsSyn.
+
+%************************************************************************
+%*                                                                      *
+                 Tidying
+*                                                                      *
+************************************************************************
+-}
+
+zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
+zonkTidyTcType env ty = do { ty' <- zonkTcType ty
+                           ; return (tidyOpenType env ty') }
+
+zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
+zonkTidyTcTypes = zonkTidyTcTypes' []
+  where zonkTidyTcTypes' zs env [] = return (env, reverse zs)
+        zonkTidyTcTypes' zs env (ty:tys)
+          = do { (env', ty') <- zonkTidyTcType env ty
+               ; zonkTidyTcTypes' (ty':zs) env' tys }
+
+zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
+zonkTidyOrigin env (GivenOrigin skol_info)
+  = do { skol_info1 <- zonkSkolemInfo skol_info
+       ; let skol_info2 = tidySkolemInfo env skol_info1
+       ; return (env, GivenOrigin skol_info2) }
+zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act
+                                      , uo_expected = exp })
+  = do { (env1, act') <- zonkTidyTcType env  act
+       ; (env2, exp') <- zonkTidyTcType env1 exp
+       ; return ( env2, orig { uo_actual   = act'
+                             , uo_expected = exp' }) }
+zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)
+  = do { (env1, ty1')   <- zonkTidyTcType env  ty1
+       ; (env2, m_ty2') <- case m_ty2 of
+                             Just ty2 -> second Just <$> zonkTidyTcType env1 ty2
+                             Nothing  -> return (env1, Nothing)
+       ; (env3, orig')  <- zonkTidyOrigin env2 orig
+       ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }
+zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)
+  = do { (env1, p1') <- zonkTidyTcType env  p1
+       ; (env2, p2') <- zonkTidyTcType env1 p2
+       ; return (env2, FunDepOrigin1 p1' l1 p2' l2) }
+zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)
+  = do { (env1, p1') <- zonkTidyTcType env  p1
+       ; (env2, p2') <- zonkTidyTcType env1 p2
+       ; (env3, o1') <- zonkTidyOrigin env2 o1
+       ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }
+zonkTidyOrigin env orig = return (env, orig)
+
+----------------
+tidyCt :: TidyEnv -> Ct -> Ct
+-- Used only in error reporting
+-- Also converts it to non-canonical
+tidyCt env ct
+  = case ct of
+     CHoleCan { cc_ev = ev }
+       -> ct { cc_ev = tidy_ev env ev }
+     _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))
+  where
+    tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
+     -- NB: we do not tidy the ctev_evar field because we don't
+     --     show it in error messages
+    tidy_ev env ctev@(CtGiven { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+    tidy_ev env ctev@(CtWanted { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+    tidy_ev env ctev@(CtDerived { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+
+----------------
+tidyEvVar :: TidyEnv -> EvVar -> EvVar
+tidyEvVar env var = setVarType var (tidyType env (varType var))
+
+----------------
+tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
+tidySkolemInfo env (DerivSkol ty)         = DerivSkol (tidyType env ty)
+tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs
+tidySkolemInfo env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)
+tidySkolemInfo env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)
+tidySkolemInfo _   info                   = info
+
+tidySigSkol :: TidyEnv -> UserTypeCtxt
+            -> TcType -> [(Name,TcTyVar)] -> SkolemInfo
+-- We need to take special care when tidying SigSkol
+-- See Note [SigSkol SkolemInfo] in TcRnTypes
+tidySigSkol env cx ty tv_prs
+  = SigSkol cx (tidy_ty env ty) tv_prs'
+  where
+    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs
+    inst_env = mkNameEnv tv_prs'
+
+    tidy_ty env (ForAllTy (Bndr tv vis) ty)
+      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)
+      where
+        (env', tv') = tidy_tv_bndr env tv
+
+    tidy_ty env ty@(FunTy _ arg res)
+      = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res }
+
+    tidy_ty env ty = tidyType env ty
+
+    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
+    tidy_tv_bndr env@(occ_env, subst) tv
+      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)
+      = ((occ_env, extendVarEnv subst tv tv'), tv')
+
+      | otherwise
+      = tidyVarBndr env tv
+
+-------------------------------------------------------------------------
+{-
+%************************************************************************
+%*                                                                      *
+             Levity polymorphism checks
+*                                                                      *
+************************************************************************
+
+See Note [Levity polymorphism checking] in DsMonad
+
+-}
+
+-- | According to the rules around representation polymorphism
+-- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder
+-- can have a representation-polymorphic type. This check ensures
+-- that we respect this rule. It is a bit regrettable that this error
+-- occurs in zonking, after which we should have reported all errors.
+-- But it's hard to see where else to do it, because this can be discovered
+-- only after all solving is done. And, perhaps most importantly, this
+-- isn't really a compositional property of a type system, so it's
+-- not a terrible surprise that the check has to go in an awkward spot.
+ensureNotLevPoly :: Type  -- its zonked type
+                 -> SDoc  -- where this happened
+                 -> TcM ()
+ensureNotLevPoly ty doc
+  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type
+                   -- forall a. a. See, for example, test ghci/scripts/T9140
+    checkForLevPoly doc ty
+
+  -- See Note [Levity polymorphism checking] in DsMonad
+checkForLevPoly :: SDoc -> Type -> TcM ()
+checkForLevPoly = checkForLevPolyX addErr
+
+checkForLevPolyX :: Monad m
+                 => (SDoc -> m ())  -- how to report an error
+                 -> SDoc -> Type -> m ()
+checkForLevPolyX add_err extra ty
+  | isTypeLevPoly ty
+  = add_err (formatLevPolyErr ty $$ extra)
+  | otherwise
+  = return ()
+
+formatLevPolyErr :: Type  -- levity-polymorphic type
+                 -> SDoc
+formatLevPolyErr ty
+  = hang (text "A levity-polymorphic type is not allowed here:")
+       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty
+               , text "Kind:" <+> pprWithTYPE tidy_ki ])
+  where
+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
+    tidy_ki             = tidyType tidy_env (tcTypeKind ty)
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcMatches.hs
@@ -0,0 +1,1100 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcMatches: Typecheck some @Matches@
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
+                   TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
+                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+                   tcDoStmt, tcGuardStmt
+       ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
+                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
+
+import BasicTypes (LexicalFixity(..))
+import HsSyn
+import TcRnMonad
+import TcEnv
+import TcPat
+import TcMType
+import TcType
+import TcBinds
+import TcUnify
+import Name
+import TysWiredIn
+import Id
+import TyCon
+import TysPrim
+import TcEvidence
+import Outputable
+import Util
+import SrcLoc
+
+-- Create chunkified tuple tybes for monad comprehensions
+import MkCore
+
+import Control.Monad
+import Control.Arrow ( second )
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{tcMatchesFun, tcMatchesCase}
+*                                                                      *
+************************************************************************
+
+@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
+@FunMonoBind@.  The second argument is the name of the function, which
+is used in error messages.  It checks that all the equations have the
+same number of arguments before using @tcMatches@ to do the work.
+
+Note [Polymorphic expected type for tcMatchesFun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcMatchesFun may be given a *sigma* (polymorphic) type
+so it must be prepared to use tcSkolemise to skolemise it.
+See Note [sig_tau may be polymorphic] in TcPat.
+-}
+
+tcMatchesFun :: Located Name
+             -> MatchGroup GhcRn (LHsExpr GhcRn)
+             -> ExpRhoType     -- Expected type of function
+             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
+                                -- Returns type of body
+tcMatchesFun fn@(L _ fun_name) matches exp_ty
+  = do  {  -- Check that they all have the same no of arguments
+           -- Location is in the monad, set the caller so that
+           -- any inter-equation error messages get some vaguely
+           -- sensible location.        Note: we have to do this odd
+           -- ann-grabbing, because we don't always have annotations in
+           -- hand when we call tcMatchesFun...
+          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
+        ; checkArgs fun_name matches
+
+        ; (wrap_gen, (wrap_fun, group))
+            <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->
+                  -- Note [Polymorphic expected type for tcMatchesFun]
+               do { (matches', wrap_fun)
+                       <- matchExpectedFunTys herald arity exp_rho $
+                          \ pat_tys rhs_ty ->
+                          tcMatches match_ctxt pat_tys rhs_ty matches
+                  ; return (wrap_fun, matches') }
+        ; return (wrap_gen <.> wrap_fun, group) }
+  where
+    arity = matchGroupArity matches
+    herald = text "The equation(s) for"
+             <+> quotes (ppr fun_name) <+> text "have"
+    what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+    match_ctxt = MC { mc_what = what, mc_body = tcBody }
+    strictness
+      | [L _ match] <- unLoc $ mg_alts matches
+      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
+      = SrcStrict
+      | otherwise
+      = NoSrcStrict
+
+{-
+@tcMatchesCase@ doesn't do the argument-count check because the
+parser guarantees that each equation has exactly one argument.
+-}
+
+tcMatchesCase :: (Outputable (body GhcRn)) =>
+                TcMatchCtxt body                        -- Case context
+             -> TcSigmaType                             -- Type of scrutinee
+             -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives
+             -> ExpRhoType                    -- Type of whole case expressions
+             -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
+                -- Translated alternatives
+                -- wrapper goes from MatchGroup's ty to expected ty
+
+tcMatchesCase ctxt scrut_ty matches res_ty
+  = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
+
+tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
+              -> TcMatchCtxt HsExpr
+              -> MatchGroup GhcRn (LHsExpr GhcRn)
+              -> ExpRhoType   -- deeply skolemised
+              -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
+tcMatchLambda herald match_ctxt match res_ty
+  = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
+    tcMatches match_ctxt pat_tys rhs_ty match
+  where
+    n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
+           | otherwise               = matchGroupArity match
+
+-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
+
+tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
+           -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
+-- Used for pattern bindings
+tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
+  where
+    match_ctxt = MC { mc_what = PatBindRhs,
+                      mc_body = tcBody }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{tcMatch}
+*                                                                      *
+************************************************************************
+
+Note [Case branches must never infer a non-tau type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  case ... of
+    ... -> \(x :: forall a. a -> a) -> x
+    ... -> \y -> y
+
+Should that type-check? The problem is that, if we check the second branch
+first, then we'll get a type (b -> b) for the branches, which won't unify
+with the polytype in the first branch. If we check the first branch first,
+then everything is OK. This order-dependency is terrible. So we want only
+proper tau-types in branches (unless a sigma-type is pushed down).
+This is what expTypeToType ensures: it replaces an Infer with a fresh
+tau-type.
+
+An even trickier case looks like
+
+  f x True  = x undefined
+  f x False = x ()
+
+Here, we see that the arguments must also be non-Infer. Thus, we must
+use expTypeToType on the output of matchExpectedFunTys, not the input.
+
+But we make a special case for a one-branch case. This is so that
+
+  f = \(x :: forall a. a -> a) -> x
+
+still gets assigned a polytype.
+-}
+
+-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
+-- expected type into TauTvs.
+-- See Note [Case branches must never infer a non-tau type]
+tauifyMultipleMatches :: [LMatch id body]
+                      -> [ExpType] -> TcM [ExpType]
+tauifyMultipleMatches group exp_tys
+  | isSingletonMatchGroup group = return exp_tys
+  | otherwise                   = mapM tauifyExpType exp_tys
+  -- NB: In the empty-match case, this ensures we fill in the ExpType
+
+-- | Type-check a MatchGroup.
+tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
+          -> [ExpSigmaType]      -- Expected pattern types
+          -> ExpRhoType          -- Expected result-type of the Match.
+          -> MatchGroup GhcRn (Located (body GhcRn))
+          -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
+
+data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
+  = MC { mc_what :: HsMatchContext Name,  -- What kind of thing this is
+         mc_body :: Located (body GhcRn)         -- Type checker for a body of
+                                                -- an alternative
+                 -> ExpRhoType
+                 -> TcM (Located (body GhcTcId)) }
+
+tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
+                                  , mg_origin = origin })
+  = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
+            -- See Note [Case branches must never infer a non-tau type]
+
+       ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
+       ; pat_tys  <- mapM readExpType pat_tys
+       ; rhs_ty   <- readExpType rhs_ty
+       ; return (MG { mg_alts = L l matches'
+                    , mg_ext = MatchGroupTc pat_tys rhs_ty
+                    , mg_origin = origin }) }
+tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"
+
+-------------
+tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
+        -> [ExpSigmaType]        -- Expected pattern types
+        -> ExpRhoType            -- Expected result-type of the Match.
+        -> LMatch GhcRn (Located (body GhcRn))
+        -> TcM (LMatch GhcTcId (Located (body GhcTcId)))
+
+tcMatch ctxt pat_tys rhs_ty match
+  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
+  where
+    tc_match ctxt pat_tys rhs_ty
+             match@(Match { m_pats = pats, m_grhss = grhss })
+      = add_match_ctxt match $
+        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
+                                tcGRHSs ctxt grhss rhs_ty
+           ; return (Match { m_ext = noExt
+                           , m_ctxt = mc_what ctxt, m_pats = pats'
+                           , m_grhss = grhss' }) }
+    tc_match  _ _ _ (XMatch _) = panic "tcMatch"
+
+        -- For (\x -> e), tcExpr has already said "In the expression \x->e"
+        -- so we don't want to add "In the lambda abstraction \x->e"
+    add_match_ctxt match thing_inside
+        = case mc_what ctxt of
+            LambdaExpr -> thing_inside
+            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
+
+-------------
+tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
+        -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
+
+-- Notice that we pass in the full res_ty, so that we get
+-- good inference from simple things like
+--      f = \(x::forall a.a->a) -> <stuff>
+-- We used to force it to be a monotype when there was more than one guard
+-- but we don't need to do that any more
+
+tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
+  = do  { (binds', grhss')
+            <- tcLocalBinds binds $
+               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
+
+        ; return (GRHSs noExt grhss' (L l binds')) }
+tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"
+
+-------------
+tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
+       -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
+
+tcGRHS ctxt res_ty (GRHS _ guards rhs)
+  = do  { (guards', rhs')
+            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
+               mc_body ctxt rhs
+        ; return (GRHS noExt guards' rhs') }
+  where
+    stmt_ctxt  = PatGuard (mc_what ctxt)
+tcGRHS _ _ (XGRHS _) = panic "tcGRHS"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
+*                                                                      *
+************************************************************************
+-}
+
+tcDoStmts :: HsStmtContext Name
+          -> Located [LStmt GhcRn (LHsExpr GhcRn)]
+          -> ExpRhoType
+          -> TcM (HsExpr GhcTcId)          -- Returns a HsDo
+tcDoStmts ListComp (L l stmts) res_ty
+  = do  { res_ty <- expTypeToType res_ty
+        ; (co, elt_ty) <- matchExpectedListTy res_ty
+        ; let list_ty = mkListTy elt_ty
+        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
+                            (mkCheckExpType elt_ty)
+        ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
+
+tcDoStmts DoExpr (L l stmts) res_ty
+  = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty DoExpr (L l stmts')) }
+
+tcDoStmts MDoExpr (L l stmts) res_ty
+  = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty MDoExpr (L l stmts')) }
+
+tcDoStmts MonadComp (L l stmts) res_ty
+  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty MonadComp (L l stmts')) }
+
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+
+tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
+tcBody body res_ty
+  = do  { traceTc "tcBody" (ppr res_ty)
+        ; tcMonoExpr body res_ty
+        }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{tcStmts}
+*                                                                      *
+************************************************************************
+-}
+
+type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
+type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
+
+type TcStmtChecker body rho_type
+  =  forall thing. HsStmtContext Name
+                -> Stmt GhcRn (Located (body GhcRn))
+                -> rho_type                 -- Result type for comprehension
+                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
+                -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
+
+tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
+        -> TcStmtChecker body rho_type   -- NB: higher-rank type
+        -> [LStmt GhcRn (Located (body GhcRn))]
+        -> rho_type
+        -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
+tcStmts ctxt stmt_chk stmts res_ty
+  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
+                        const (return ())
+       ; return stmts' }
+
+tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
+               -> TcStmtChecker body rho_type    -- NB: higher-rank type
+               -> [LStmt GhcRn (Located (body GhcRn))]
+               -> rho_type
+               -> (rho_type -> TcM thing)
+               -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
+
+-- Note the higher-rank type.  stmt_chk is applied at different
+-- types in the equations for tcStmts
+
+tcStmtsAndThen _ _ [] res_ty thing_inside
+  = do  { thing <- thing_inside res_ty
+        ; return ([], thing) }
+
+-- LetStmts are handled uniformly, regardless of context
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)
+                                                             res_ty thing_inside
+  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
+              tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
+        ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }
+
+-- Don't set the error context for an ApplicativeStmt.  It ought to be
+-- possible to do this with a popErrCtxt in the tcStmt case for
+-- ApplicativeStmt, but it did someting strange and broke a test (ado002).
+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
+  | ApplicativeStmt{} <- stmt
+  = do  { (stmt', (stmts', thing)) <-
+             stmt_chk ctxt stmt res_ty $ \ res_ty' ->
+               tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
+                 thing_inside
+        ; return (L loc stmt' : stmts', thing) }
+
+  -- For the vanilla case, handle the location-setting part
+  | otherwise
+  = do  { (stmt', (stmts', thing)) <-
+                setSrcSpan loc                              $
+                addErrCtxt (pprStmtInCtxt ctxt stmt)        $
+                stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->
+                popErrCtxt                                  $
+                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
+                thing_inside
+        ; return (L loc stmt' : stmts', thing) }
+
+---------------------------------------------------
+--              Pattern guards
+---------------------------------------------------
+
+tcGuardStmt :: TcExprStmtChecker
+tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
+  = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
+        ; thing  <- thing_inside res_ty
+        ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
+  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs
+                                   -- Stmt has a context already
+        ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
+                                    pat (mkCheckExpType rhs_ty) $
+                            thing_inside res_ty
+        ; return (mkTcBindStmt pat' rhs', thing) }
+
+tcGuardStmt _ stmt _ _
+  = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--           List comprehensions
+--               (no rebindable syntax)
+---------------------------------------------------
+
+-- Dealt with separately, rather than by tcMcStmt, because
+--   a) We have special desugaring rules for list comprehensions,
+--      which avoid creating intermediate lists.  They in turn
+--      assume that the bind/return operations are the regular
+--      polymorphic ones, and in particular don't have any
+--      coercion matching stuff in them.  It's hard to avoid the
+--      potential for non-trivial coercions in tcMcStmt
+
+tcLcStmt :: TyCon       -- The list type constructor ([])
+         -> TcExprStmtChecker
+
+tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
+  = do { body' <- tcMonoExprNC body elt_ty
+       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
+
+-- A generator, pat <- rhs
+tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
+ = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
+        ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                            thing_inside elt_ty
+        ; return (mkTcBindStmt pat' rhs', thing) }
+
+-- A boolean guard
+tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
+  = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)
+        ; thing <- thing_inside elt_ty
+        ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+-- ParStmt: See notes with tcMcStmt
+tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
+  = do  { (pairs', thing) <- loop bndr_stmts_s
+        ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
+  where
+    -- loop :: [([LStmt GhcRn], [GhcRn])]
+    --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
+    loop [] = do { thing <- thing_inside elt_ty
+                 ; return ([], thing) }         -- matching in the branches
+
+    loop (ParStmtBlock x stmts names _ : pairs)
+      = do { (stmts', (ids, pairs', thing))
+                <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
+                   do { ids <- tcLookupLocalIds names
+                      ; (pairs', thing) <- loop pairs
+                      ; return (ids, pairs', thing) }
+           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
+    loop (XParStmtBlock{}:_) = panic "tcLcStmt"
+
+tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
+                              , trS_bndrs =  bindersMap
+                              , trS_by = by, trS_using = using }) elt_ty thing_inside
+  = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
+             -- The inner 'stmts' lack a LastStmt, so the element type
+             --  passed in to tcStmtsAndThen is never looked at
+       ; (stmts', (bndr_ids, by'))
+            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
+               { by' <- traverse tcInferSigma by
+               ; bndr_ids <- tcLookupLocalIds bndr_names
+               ; return (bndr_ids, by') }
+
+       ; let m_app ty = mkTyConApp m_tc [ty]
+
+       --------------- Typecheck the 'using' function -------------
+       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
+       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)
+
+         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
+       ; let n_app = case form of
+                       ThenForm -> (\ty -> ty)
+                       _        -> m_app
+
+             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
+             by_arrow = case by' of
+                          Nothing       -> \ty -> ty
+                          Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty
+
+             tup_ty        = mkBigCoreVarTupTy bndr_ids
+             poly_arg_ty   = m_app alphaTy
+             poly_res_ty   = m_app (n_app alphaTy)
+             using_poly_ty = mkInvForAllTy alphaTyVar $
+                             by_arrow $
+                             poly_arg_ty `mkVisFunTy` poly_res_ty
+
+       ; using' <- tcPolyExpr using using_poly_ty
+       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
+
+             -- 'stmts' returns a result of type (m1_ty tuple_ty),
+             -- typically something like [(Int,Bool,Int)]
+             -- We don't know what tuple_ty is yet, so we use a variable
+       ; let mk_n_bndr :: Name -> TcId -> TcId
+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
+
+             -- Ensure that every old binder of type `b` is linked up with its
+             -- new binder which should have type `n b`
+             -- See Note [GroupStmt binder map] in HsExpr
+             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
+             bindersMap' = bndr_ids `zip` n_bndr_ids
+
+       -- Type check the thing in the environment with
+       -- these new binders and return the result
+       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
+
+       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+                           , trS_by = fmap fst by', trS_using = final_using
+                           , trS_ret = noSyntaxExpr
+                           , trS_bind = noSyntaxExpr
+                           , trS_fmap = noExpr
+                           , trS_ext = unitTy
+                           , trS_form = form }, thing) }
+
+tcLcStmt _ _ stmt _ _
+  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--           Monad comprehensions
+--        (supports rebindable syntax)
+---------------------------------------------------
+
+tcMcStmt :: TcExprStmtChecker
+
+tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
+  = do  { (body', return_op')
+            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
+               \ [a_ty] ->
+               tcMonoExprNC body (mkCheckExpType a_ty)
+        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
+        ; return (LastStmt x body' noret return_op', thing) }
+
+-- Generators for monad comprehensions ( pat <- rhs )
+--
+--   [ body | q <- gen ]  ->  gen :: m a
+--                            q   ::   a
+--
+
+tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
+           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+  = do  { ((rhs', pat', thing, new_res_ty), bind_op')
+            <- tcSyntaxOp MCompOrigin bind_op
+                          [SynRho, SynFun SynAny SynRho] res_ty $
+               \ [rhs_ty, pat_ty, new_res_ty] ->
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                  ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
+                                           (mkCheckExpType pat_ty) $
+                                     thing_inside (mkCheckExpType new_res_ty)
+                  ; return (rhs', pat', thing, new_res_ty) }
+
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
+
+        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+
+-- Boolean expressions.
+--
+--   [ body | stmts, expr ]  ->  expr :: m Bool
+--
+tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
+  = do  { -- Deal with rebindable syntax:
+          --    guard_op :: test_ty -> rhs_ty
+          --    then_op  :: rhs_ty -> new_res_ty -> res_ty
+          -- Where test_ty is, for example, Bool
+        ; ((thing, rhs', rhs_ty, guard_op'), then_op')
+            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
+               \ [rhs_ty, new_res_ty] ->
+               do { (rhs', guard_op')
+                      <- tcSyntaxOp MCompOrigin guard_op [SynAny]
+                                    (mkCheckExpType rhs_ty) $
+                         \ [test_ty] ->
+                         tcMonoExpr rhs (mkCheckExpType test_ty)
+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (thing, rhs', rhs_ty, guard_op') }
+        ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
+
+-- Grouping statements
+--
+--   [ body | stmts, then group by e using f ]
+--     ->  e :: t
+--         f :: forall a. (a -> t) -> m a -> m (m a)
+--   [ body | stmts, then group using f ]
+--     ->  f :: forall a. m a -> m (m a)
+
+-- We type [ body | (stmts, group by e using f), ... ]
+--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
+--
+-- We type the functions as follows:
+--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
+--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
+--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
+--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
+--
+tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
+                         , trS_by = by, trS_using = using, trS_form = form
+                         , trS_ret = return_op, trS_bind = bind_op
+                         , trS_fmap = fmap_op }) res_ty thing_inside
+  = do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind
+       ; m1_ty   <- newFlexiTyVarTy star_star_kind
+       ; m2_ty   <- newFlexiTyVarTy star_star_kind
+       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind
+       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)
+
+         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
+       ; n_app <- case form of
+                    ThenForm -> return (\ty -> ty)
+                    _        -> do { n_ty <- newFlexiTyVarTy star_star_kind
+                                   ; return (n_ty `mkAppTy`) }
+       ; let by_arrow :: Type -> Type
+             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
+             --                          or res                    ('by' absent)
+             by_arrow = case by of
+                          Nothing -> \res -> res
+                          Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res
+
+             poly_arg_ty  = m1_ty `mkAppTy` alphaTy
+             using_arg_ty = m1_ty `mkAppTy` tup_ty
+             poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy
+             using_res_ty = m2_ty `mkAppTy` n_app tup_ty
+             using_poly_ty = mkInvForAllTy alphaTyVar $
+                             by_arrow $
+                             poly_arg_ty `mkVisFunTy` poly_res_ty
+
+             -- 'stmts' returns a result of type (m1_ty tuple_ty),
+             -- typically something like [(Int,Bool,Int)]
+             -- We don't know what tuple_ty is yet, so we use a variable
+       ; let (bndr_names, n_bndr_names) = unzip bindersMap
+       ; (stmts', (bndr_ids, by', return_op')) <-
+            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
+                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do
+                { by' <- case by of
+                           Nothing -> return Nothing
+                           Just e  -> do { e' <- tcMonoExpr e
+                                                   (mkCheckExpType by_e_ty)
+                                         ; return (Just e') }
+
+                -- Find the Ids (and hence types) of all old binders
+                ; bndr_ids <- tcLookupLocalIds bndr_names
+
+                -- 'return' is only used for the binders, so we know its type.
+                --   return :: (a,b,c,..) -> m (a,b,c,..)
+                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
+                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]
+                                       res_ty' $ \ _ -> return ()
+
+                ; return (bndr_ids, by', return_op') }
+
+       --------------- Typecheck the 'bind' function -------------
+       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
+       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op
+                             [ synKnownType using_res_ty
+                             , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ]
+                             res_ty $ \ _ -> return ()
+
+       --------------- Typecheck the 'fmap' function -------------
+       ; fmap_op' <- case form of
+                       ThenForm -> return noExpr
+                       _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
+                            mkInvForAllTy alphaTyVar $
+                            mkInvForAllTy betaTyVar  $
+                            (alphaTy `mkVisFunTy` betaTy)
+                            `mkVisFunTy` (n_app alphaTy)
+                            `mkVisFunTy` (n_app betaTy)
+
+       --------------- Typecheck the 'using' function -------------
+       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
+
+       ; using' <- tcPolyExpr using using_poly_ty
+       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
+
+       --------------- Bulding the bindersMap ----------------
+       ; let mk_n_bndr :: Name -> TcId -> TcId
+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
+
+             -- Ensure that every old binder of type `b` is linked up with its
+             -- new binder which should have type `n b`
+             -- See Note [GroupStmt binder map] in HsExpr
+             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+             bindersMap' = bndr_ids `zip` n_bndr_ids
+
+       -- Type check the thing in the environment with
+       -- these new binders and return the result
+       ; thing <- tcExtendIdEnv n_bndr_ids $
+                  thing_inside (mkCheckExpType new_res_ty)
+
+       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+                           , trS_by = by', trS_using = final_using
+                           , trS_ret = return_op', trS_bind = bind_op'
+                           , trS_ext = n_app tup_ty
+                           , trS_fmap = fmap_op', trS_form = form }, thing) }
+
+-- A parallel set of comprehensions
+--      [ (g x, h x) | ... ; let g v = ...
+--                   | ... ; let h v = ... ]
+--
+-- It's possible that g,h are overloaded, so we need to feed the LIE from the
+-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
+-- Similarly if we had an existential pattern match:
+--
+--      data T = forall a. Show a => C a
+--
+--      [ (show x, show y) | ... ; C x <- ...
+--                         | ... ; C y <- ... ]
+--
+-- Then we need the LIE from (show x, show y) to be simplified against
+-- the bindings for x and y.
+--
+-- It's difficult to do this in parallel, so we rely on the renamer to
+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
+-- So the binders of the first parallel group will be in scope in the second
+-- group.  But that's fine; there's no shadowing to worry about.
+--
+-- Note: The `mzip` function will get typechecked via:
+--
+--   ParStmt [st1::t1, st2::t2, st3::t3]
+--
+--   mzip :: m st1
+--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
+--        -> m (st1, (st2, st3))
+--
+tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
+  = do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind
+       ; m_ty   <- newFlexiTyVarTy star_star_kind
+
+       ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $
+                        (m_ty `mkAppTy` alphaTy)
+                        `mkVisFunTy`
+                        (m_ty `mkAppTy` betaTy)
+                        `mkVisFunTy`
+                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
+       ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
+
+        -- type dummies since we don't know all binder types yet
+       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
+                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
+
+       -- Typecheck bind:
+       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
+             tuple_ty = mk_tuple_ty tup_tys
+
+       ; (((blocks', thing), inner_res_ty), bind_op')
+           <- tcSyntaxOp MCompOrigin bind_op
+                         [ synKnownType (m_ty `mkAppTy` tuple_ty)
+                         , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
+              \ [inner_res_ty] ->
+              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
+                                 tup_tys bndr_stmts_s
+                 ; return (stuff, inner_res_ty) }
+
+       ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
+
+  where
+    mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
+
+       -- loop :: Type                                  -- m_ty
+       --      -> ExpRhoType                            -- inner_res_ty
+       --      -> [TcType]                              -- tup_tys
+       --      -> [ParStmtBlock Name]
+       --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
+    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
+                                   ; return ([], thing) }
+                                   -- matching in the branches
+
+    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
+                           (ParStmtBlock x stmts names return_op : pairs)
+      = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
+           ; (stmts', (ids, return_op', pairs', thing))
+                <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
+                   \m_tup_ty' ->
+                   do { ids <- tcLookupLocalIds names
+                      ; let tup_ty = mkBigCoreVarTupTy ids
+                      ; (_, return_op') <-
+                          tcSyntaxOp MCompOrigin return_op
+                                     [synKnownType tup_ty] m_tup_ty' $
+                                     \ _ -> return ()
+                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
+                      ; return (ids, return_op', pairs', thing) }
+           ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
+    loop _ _ _ _ = panic "tcMcStmt.loop"
+
+tcMcStmt _ stmt _ _
+  = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--           Do-notation
+--        (supports rebindable syntax)
+---------------------------------------------------
+
+tcDoStmt :: TcExprStmtChecker
+
+tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
+  = do { body' <- tcMonoExprNC body res_ty
+       ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
+
+tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
+  = do  {       -- Deal with rebindable syntax:
+                --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+                -- This level of generality is needed for using do-notation
+                -- in full generality; see #1537
+
+          ((rhs', pat', new_res_ty, thing), bind_op')
+            <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
+                \ [rhs_ty, pat_ty, new_res_ty] ->
+                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                   ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
+                                            (mkCheckExpType pat_ty) $
+                                      thing_inside (mkCheckExpType new_res_ty)
+                   ; return (rhs', pat', new_res_ty, thing) }
+
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
+
+        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+
+tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
+  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
+                                thing_inside . mkCheckExpType
+        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
+            Nothing -> (, Nothing) <$> tc_app_stmts res_ty
+            Just join_op ->
+              second Just <$>
+              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
+               \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
+
+        ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
+
+tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
+  = do  {       -- Deal with rebindable syntax;
+                --   (>>) :: rhs_ty -> new_res_ty -> res_ty
+        ; ((rhs', rhs_ty, thing), then_op')
+            <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
+               \ [rhs_ty, new_res_ty] ->
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (rhs', rhs_ty, thing) }
+        ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
+
+tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
+                       , recS_rec_ids = rec_names, recS_ret_fn = ret_op
+                       , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
+         res_ty thing_inside
+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
+              tup_ty  = mkBigCoreTupTy tup_elt_tys
+
+        ; tcExtendIdEnv tup_ids $ do
+        { ((stmts', (ret_op', tup_rets)), stmts_ty)
+                <- tcInferInst $ \ exp_ty ->
+                   tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
+                   do { tup_rets <- zipWithM tcCheckId tup_names
+                                      (map mkCheckExpType tup_elt_tys)
+                             -- Unify the types of the "final" Ids (which may
+                             -- be polymorphic) with those of "knot-tied" Ids
+                      ; (_, ret_op')
+                          <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
+                                        inner_res_ty $ \_ -> return ()
+                      ; return (ret_op', tup_rets) }
+
+        ; ((_, mfix_op'), mfix_res_ty)
+            <- tcInferInst $ \ exp_ty ->
+               tcSyntaxOp DoOrigin mfix_op
+                          [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $
+               \ _ -> return ()
+
+        ; ((thing, new_res_ty), bind_op')
+            <- tcSyntaxOp DoOrigin bind_op
+                          [ synKnownType mfix_res_ty
+                          , synKnownType tup_ty `SynFun` SynRho ]
+                          res_ty $
+               \ [new_res_ty] ->
+               do { thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (thing, new_res_ty) }
+
+        ; let rec_ids = takeList rec_names tup_ids
+        ; later_ids <- tcLookupLocalIds later_names
+        ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
+                                 ppr later_ids <+> ppr (map idType later_ids)]
+        ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
+                          , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
+                          , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
+                          , recS_ext = RecStmtTc
+                            { recS_bind_ty = new_res_ty
+                            , recS_later_rets = []
+                            , recS_rec_rets = tup_rets
+                            , recS_ret_ty = stmts_ty} }, thing)
+        }}
+
+tcDoStmt _ stmt _ _
+  = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
+
+
+
+---------------------------------------------------
+-- MonadFail Proposal warnings
+---------------------------------------------------
+
+-- The idea behind issuing MonadFail warnings is that we add them whenever a
+-- failable pattern is encountered. However, instead of throwing a type error
+-- when the constraint cannot be satisfied, we only issue a warning in
+-- TcErrors.hs.
+
+tcMonadFailOp :: CtOrigin
+              -> LPat GhcTcId
+              -> SyntaxExpr GhcRn    -- The fail op
+              -> TcType              -- Type of the whole do-expression
+              -> TcRn (SyntaxExpr GhcTcId)  -- Typechecked fail op
+-- Get a 'fail' operator expression, to use if the pattern
+-- match fails. If the pattern is irrefutatable, just return
+-- noSyntaxExpr; it won't be used
+tcMonadFailOp orig pat fail_op res_ty
+  | isIrrefutableHsPat pat
+  = return noSyntaxExpr
+
+  | otherwise
+  = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
+                             (mkCheckExpType res_ty) $ \_ -> return ())
+
+{-
+Note [Treat rebindable syntax first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking
+        do { bar; ... } :: IO ()
+we want to typecheck 'bar' in the knowledge that it should be an IO thing,
+pushing info from the context into the RHS.  To do this, we check the
+rebindable syntax first, and push that information into (tcMonoExprNC rhs).
+Otherwise the error shows up when checking the rebindable syntax, and
+the expected/inferred stuff is back to front (see #3613).
+
+Note [typechecking ApplicativeStmt]
+
+join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
+
+fresh type variables:
+   pat_ty_1..pat_ty_n
+   exp_ty_1..exp_ty_n
+   t_1..t_(n-1)
+
+body  :: body_ty
+(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
+pat_i :: pat_ty_i
+e_i   :: exp_ty_i
+<$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
+<*>_i :: t_(i-1) -> exp_ty_i -> t_i
+join :: tn -> res_ty
+-}
+
+tcApplicativeStmts
+  :: HsStmtContext Name
+  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
+  -> ExpRhoType                         -- rhs_ty
+  -> (TcRhoType -> TcM t)               -- thing_inside
+  -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
+
+tcApplicativeStmts ctxt pairs rhs_ty thing_inside
+ = do { body_ty <- newFlexiTyVarTy liftedTypeKind
+      ; let arity = length pairs
+      ; ts <- replicateM (arity-1) $ newInferExpTypeInst
+      ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
+      ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
+      ; let fun_ty = mkVisFunTys pat_tys body_ty
+
+       -- NB. do the <$>,<*> operators first, we don't want type errors here
+       --     i.e. goOps before goArgs
+       -- See Note [Treat rebindable syntax first]
+      ; let (ops, args) = unzip pairs
+      ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
+
+      -- Typecheck each ApplicativeArg separately
+      -- See Note [ApplicativeDo and constraints]
+      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
+
+      -- Bring into scope all the things bound by the args,
+      -- and typecheck the thing_inside
+      -- See Note [ApplicativeDo and constraints]
+      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
+               thing_inside body_ty
+
+      ; return (zip ops' args', body_ty, res) }
+  where
+    goOps _ [] = return []
+    goOps t_left ((op,t_i,exp_ty) : ops)
+      = do { (_, op')
+               <- tcSyntaxOp DoOrigin op
+                             [synKnownType t_left, synKnownType exp_ty] t_i $
+                   \ _ -> return ()
+           ; t_i <- readExpType t_i
+           ; ops' <- goOps t_i ops
+           ; return (op' : ops') }
+
+    goArg :: (ApplicativeArg GhcRn, Type, Type)
+          -> TcM (ApplicativeArg GhcTcId)
+
+    goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)
+      = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
+        addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $
+        do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
+           ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                          return ()
+           ; return (ApplicativeArgOne x pat' rhs' isBody) }
+
+    goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
+      = do { (stmts', (ret',pat')) <-
+                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
+                \res_ty  -> do
+                  { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
+                  ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                                 return ()
+                  ; return (ret', pat')
+                  }
+           ; return (ApplicativeArgMany x stmts' ret' pat') }
+
+    goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"
+
+    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
+    get_arg_bndrs (ApplicativeArgOne _ pat _ _)  = collectPatBinders pat
+    get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+    get_arg_bndrs (XApplicativeArg _)            = panic "tcApplicativeStmts"
+
+
+{- Note [ApplicativeDo and constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An applicative-do is supposed to take place in parallel, so
+constraints bound in one arm can't possibly be available in another
+(#13242).  Our current rule is this (more details and discussion
+on the ticket). Consider
+
+   ...stmts...
+   ApplicativeStmts [arg1, arg2, ... argN]
+   ...more stmts...
+
+where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
+Now, we say that:
+
+* Constraints required by the argi can be solved from
+  constraint bound by ...stmts...
+
+* Constraints and existentials bound by the argi are not available
+  to solve constraints required either by argj (where i /= j),
+  or by ...more stmts....
+
+* Within the stmts of each 'argi' individually, however, constraints bound
+  by earlier stmts can be used to solve later ones.
+
+To achieve this, we just typecheck each 'argi' separately, bring all
+the variables they bind into scope, and typecheck the thing_inside.
+
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
+number of args are used in each equation.
+-}
+
+checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
+checkArgs _ (MG { mg_alts = L _ [] })
+    = return ()
+checkArgs fun (MG { mg_alts = L _ (match1:matches) })
+    | null bad_matches
+    = return ()
+    | otherwise
+    = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
+                         text "have different numbers of arguments"
+                       , nest 2 (ppr (getLoc match1))
+                       , nest 2 (ppr (getLoc (head bad_matches)))])
+  where
+    n_args1 = args_in_match match1
+    bad_matches = [m | m <- matches, args_in_match m /= n_args1]
+
+    args_in_match :: LMatch GhcRn body -> Int
+    args_in_match (L _ (Match { m_pats = pats })) = length pats
+    args_in_match (L _ (XMatch _)) = panic "checkArgs"
+checkArgs _ (XMatchGroup{}) = panic "checkArgs"
diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcMatches.hs-boot
@@ -0,0 +1,17 @@
+module TcMatches where
+import HsSyn    ( GRHSs, MatchGroup, LHsExpr )
+import TcEvidence( HsWrapper )
+import Name     ( Name )
+import TcType   ( ExpRhoType, TcRhoType )
+import TcRnTypes( TcM )
+import SrcLoc   ( Located )
+import HsExtension ( GhcRn, GhcTcId )
+
+tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
+              -> TcRhoType
+              -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
+
+tcMatchesFun :: Located Name
+             -> MatchGroup GhcRn (LHsExpr GhcRn)
+             -> ExpRhoType
+             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPat.hs
@@ -0,0 +1,1193 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcPat: Typechecking patterns
+-}
+
+{-# LANGUAGE CPP, RankNTypes, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)
+             , tcPat, tcPat_O, tcPats
+             , addDataConStupidTheta, badFieldCon, polyPatSig ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )
+
+import HsSyn
+import TcHsSyn
+import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags )
+import TcRnMonad
+import Inst
+import Id
+import Var
+import Name
+import RdrName
+import TcEnv
+import TcMType
+import TcValidity( arityErr )
+import Type ( pprTyVars )
+import TcType
+import TcUnify
+import TcHsType
+import TysWiredIn
+import TcEvidence
+import TyCon
+import DataCon
+import PatSyn
+import ConLike
+import PrelNames
+import BasicTypes hiding (SuccessFlag(..))
+import DynFlags
+import SrcLoc
+import VarSet
+import Util
+import Outputable
+import qualified GHC.LanguageExtensions as LangExt
+import Control.Arrow  ( second )
+import ListSetOps ( getNth )
+
+{-
+************************************************************************
+*                                                                      *
+                External interface
+*                                                                      *
+************************************************************************
+-}
+
+tcLetPat :: (Name -> Maybe TcId)
+         -> LetBndrSpec
+         -> LPat GhcRn -> ExpSigmaType
+         -> TcM a
+         -> TcM (LPat GhcTcId, a)
+tcLetPat sig_fn no_gen pat pat_ty thing_inside
+  = do { bind_lvl <- getTcLevel
+       ; let ctxt = LetPat { pc_lvl    = bind_lvl
+                           , pc_sig_fn = sig_fn
+                           , pc_new    = no_gen }
+             penv = PE { pe_lazy = True
+                       , pe_ctxt = ctxt
+                       , pe_orig = PatOrigin }
+
+       ; tc_lpat pat pat_ty penv thing_inside }
+
+-----------------
+tcPats :: HsMatchContext Name
+       -> [LPat GhcRn]            -- Patterns,
+       -> [ExpSigmaType]         --   and their types
+       -> TcM a                  --   and the checker for the body
+       -> TcM ([LPat GhcTcId], a)
+
+-- This is the externally-callable wrapper function
+-- Typecheck the patterns, extend the environment to bind the variables,
+-- do the thing inside, use any existentially-bound dictionaries to
+-- discharge parts of the returning LIE, and deal with pattern type
+-- signatures
+
+--   1. Initialise the PatState
+--   2. Check the patterns
+--   3. Check the body
+--   4. Check that no existentials escape
+
+tcPats ctxt pats pat_tys thing_inside
+  = tc_lpats penv pats pat_tys thing_inside
+  where
+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
+
+tcPat :: HsMatchContext Name
+      -> LPat GhcRn -> ExpSigmaType
+      -> TcM a                     -- Checker for body
+      -> TcM (LPat GhcTcId, a)
+tcPat ctxt = tcPat_O ctxt PatOrigin
+
+-- | A variant of 'tcPat' that takes a custom origin
+tcPat_O :: HsMatchContext Name
+        -> CtOrigin              -- ^ origin to use if the type needs inst'ing
+        -> LPat GhcRn -> ExpSigmaType
+        -> TcM a                 -- Checker for body
+        -> TcM (LPat GhcTcId, a)
+tcPat_O ctxt orig pat pat_ty thing_inside
+  = tc_lpat pat pat_ty penv thing_inside
+  where
+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }
+
+
+{-
+************************************************************************
+*                                                                      *
+                PatEnv, PatCtxt, LetBndrSpec
+*                                                                      *
+************************************************************************
+-}
+
+data PatEnv
+  = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed
+       , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears
+       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing
+       }
+
+data PatCtxt
+  = LamPat   -- Used for lambdas, case etc
+       (HsMatchContext Name)
+
+  | LetPat   -- Used only for let(rec) pattern bindings
+             -- See Note [Typing patterns in pattern bindings]
+       { pc_lvl    :: TcLevel
+                   -- Level of the binding group
+
+       , pc_sig_fn :: Name -> Maybe TcId
+                   -- Tells the expected type
+                   -- for binders with a signature
+
+       , pc_new :: LetBndrSpec
+                -- How to make a new binder
+       }        -- for binders without signatures
+
+data LetBndrSpec
+  = LetLclBndr            -- We are going to generalise, and wrap in an AbsBinds
+                          -- so clone a fresh binder for the local monomorphic Id
+
+  | LetGblBndr TcPragEnv  -- Generalisation plan is NoGen, so there isn't going
+                          -- to be an AbsBinds; So we must bind the global version
+                          -- of the binder right away.
+                          -- And here is the inline-pragma information
+
+instance Outputable LetBndrSpec where
+  ppr LetLclBndr      = text "LetLclBndr"
+  ppr (LetGblBndr {}) = text "LetGblBndr"
+
+makeLazy :: PatEnv -> PatEnv
+makeLazy penv = penv { pe_lazy = True }
+
+inPatBind :: PatEnv -> Bool
+inPatBind (PE { pe_ctxt = LetPat {} }) = True
+inPatBind (PE { pe_ctxt = LamPat {} }) = False
+
+{- *********************************************************************
+*                                                                      *
+                Binders
+*                                                                      *
+********************************************************************* -}
+
+tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId)
+-- (coi, xp) = tcPatBndr penv x pat_ty
+-- Then coi : pat_ty ~ typeof(xp)
+--
+tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
+                                      , pc_sig_fn = sig_fn
+                                      , pc_new    = no_gen } })
+          bndr_name exp_pat_ty
+  -- For the LetPat cases, see
+  -- Note [Typechecking pattern bindings] in TcBinds
+
+  | Just bndr_id <- sig_fn bndr_name   -- There is a signature
+  = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id)
+           -- See Note [Subsumption check at pattern variables]
+       ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
+       ; return (wrap, bndr_id) }
+
+  | otherwise                          -- No signature
+  = do { (co, bndr_ty) <- case exp_pat_ty of
+             Check pat_ty    -> promoteTcType bind_lvl pat_ty
+             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )
+                                -- If we were under a constructor that bumped
+                                -- the level, we'd be in checking mode
+                                do { bndr_ty <- inferResultToType infer_res
+                                   ; return (mkTcNomReflCo bndr_ty, bndr_ty) }
+       ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty
+       ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl
+                                          , ppr exp_pat_ty, ppr bndr_ty, ppr co
+                                          , ppr bndr_id ])
+       ; return (mkWpCastN co, bndr_id) }
+
+tcPatBndr _ bndr_name pat_ty
+  = do { pat_ty <- expTypeToType pat_ty
+       ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)
+       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }
+               -- Whether or not there is a sig is irrelevant,
+               -- as this is local
+
+newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
+-- Make up a suitable Id for the pattern-binder.
+-- See Note [Typechecking pattern bindings], item (4) in TcBinds
+--
+-- In the polymorphic case when we are going to generalise
+--    (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"
+--    of the Id; the original name will be bound to the polymorphic version
+--    by the AbsBinds
+-- In the monomorphic case when we are not going to generalise
+--    (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,
+--    and we use the original name directly
+newLetBndr LetLclBndr name ty
+  = do { mono_name <- cloneLocalName name
+       ; return (mkLocalId mono_name ty) }
+newLetBndr (LetGblBndr prags) name ty
+  = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)
+
+tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
+-- Used when typechecking patterns
+tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2
+
+{- Note [Subsumption check at pattern variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we come across a variable with a type signature, we need to do a
+subsumption, not equality, check against the context type.  e.g.
+
+    data T = MkT (forall a. a->a)
+      f :: forall b. [b]->[b]
+      MkT f = blah
+
+Since 'blah' returns a value of type T, its payload is a polymorphic
+function of type (forall a. a->a).  And that's enough to bind the
+less-polymorphic function 'f', but we need some impedance matching
+to witness the instantiation.
+
+
+************************************************************************
+*                                                                      *
+                The main worker functions
+*                                                                      *
+************************************************************************
+
+Note [Nesting]
+~~~~~~~~~~~~~~
+tcPat takes a "thing inside" over which the pattern scopes.  This is partly
+so that tcPat can extend the environment for the thing_inside, but also
+so that constraints arising in the thing_inside can be discharged by the
+pattern.
+
+This does not work so well for the ErrCtxt carried by the monad: we don't
+want the error-context for the pattern to scope over the RHS.
+Hence the getErrCtxt/setErrCtxt stuff in tcMultiple
+-}
+
+--------------------
+type Checker inp out =  forall r.
+                          inp
+                       -> PatEnv
+                       -> TcM r
+                       -> TcM (out, r)
+
+tcMultiple :: Checker inp out -> Checker [inp] [out]
+tcMultiple tc_pat args penv thing_inside
+  = do  { err_ctxt <- getErrCtxt
+        ; let loop _ []
+                = do { res <- thing_inside
+                     ; return ([], res) }
+
+              loop penv (arg:args)
+                = do { (p', (ps', res))
+                                <- tc_pat arg penv $
+                                   setErrCtxt err_ctxt $
+                                   loop penv args
+                -- setErrCtxt: restore context before doing the next pattern
+                -- See note [Nesting] above
+
+                     ; return (p':ps', res) }
+
+        ; loop penv args }
+
+--------------------
+tc_lpat :: LPat GhcRn
+        -> ExpSigmaType
+        -> PatEnv
+        -> TcM a
+        -> TcM (LPat GhcTcId, a)
+tc_lpat (dL->L span pat) pat_ty penv thing_inside
+  = setSrcSpan span $
+    do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+                                          thing_inside
+        ; return (cL span pat', res) }
+
+tc_lpats :: PatEnv
+         -> [LPat GhcRn] -> [ExpSigmaType]
+         -> TcM a
+         -> TcM ([LPat GhcTcId], a)
+tc_lpats penv pats tys thing_inside
+  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )
+    tcMultiple (\(p,t) -> tc_lpat p t)
+                (zipEqual "tc_lpats" pats tys)
+                penv thing_inside
+
+--------------------
+tc_pat  :: PatEnv
+        -> Pat GhcRn
+        -> ExpSigmaType  -- Fully refined result type
+        -> TcM a                -- Thing inside
+        -> TcM (Pat GhcTcId,    -- Translated pattern
+                a)              -- Result of thing inside
+
+tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside
+  = do  { (wrap, id) <- tcPatBndr penv name pat_ty
+        ; res <- tcExtendIdEnv1 name id thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) }
+
+tc_pat penv (ParPat x pat) pat_ty thing_inside
+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+        ; return (ParPat x pat', res) }
+
+tc_pat penv (BangPat x pat) pat_ty thing_inside
+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+        ; return (BangPat x pat', res) }
+
+tc_pat penv (LazyPat x pat) pat_ty thing_inside
+  = do  { (pat', (res, pat_ct))
+                <- tc_lpat pat pat_ty (makeLazy penv) $
+                   captureConstraints thing_inside
+                -- Ignore refined penv', revert to penv
+
+        ; emitConstraints pat_ct
+        -- captureConstraints/extendConstraints:
+        --   see Note [Hopping the LIE in lazy patterns]
+
+        -- Check that the expected pattern type is itself lifted
+        ; pat_ty <- readExpType pat_ty
+        ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind
+
+        ; return (LazyPat x pat', res) }
+
+tc_pat _ (WildPat _) pat_ty thing_inside
+  = do  { res <- thing_inside
+        ; pat_ty <- expTypeToType pat_ty
+        ; return (WildPat pat_ty, res) }
+
+tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside
+  = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
+        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+                         tc_lpat pat (mkCheckExpType $ idType bndr_id)
+                                 penv thing_inside
+            -- NB: if we do inference on:
+            --          \ (y@(x::forall a. a->a)) = e
+            -- we'll fail.  The as-pattern infers a monotype for 'y', which then
+            -- fails to unify with the polymorphic type for 'x'.  This could
+            -- perhaps be fixed, but only with a bit more work.
+            --
+            -- If you fix it, don't forget the bindInstsOfPatIds!
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty,
+                  res) }
+
+tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
+  = do  {
+         -- Expr must have type `forall a1...aN. OPT' -> B`
+         -- where overall_pat_ty is an instance of OPT'.
+        ; (expr',expr'_inferred) <- tcInferSigma expr
+
+         -- expression must be a function
+        ; let expr_orig = lexprCtOrigin expr
+              herald    = text "A view pattern expression expects"
+        ; (expr_wrap1, [inf_arg_ty], inf_res_ty)
+            <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred
+            -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)
+
+         -- check that overall pattern is more polymorphic than arg type
+        ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty
+            -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty
+
+         -- pattern must have inf_res_ty
+        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside
+
+        ; overall_pat_ty <- readExpType overall_pat_ty
+        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
+                                    overall_pat_ty inf_res_ty doc
+               -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"
+               --                (overall_pat_ty -> inf_res_ty)
+              expr_wrap = expr_wrap2' <.> expr_wrap1
+              doc = text "When checking the view pattern function:" <+> (ppr expr)
+        ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
+
+-- Type signatures in patterns
+-- See Note [Pattern coercions] below
+tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
+  = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
+                                                            sig_ty pat_ty
+                -- Using tcExtendNameTyVarEnv is appropriate here
+                -- because we're not really bringing fresh tyvars into scope.
+                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
+                -- from an outer scope to mention one of these tyvars in its kind.
+        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
+                         tcExtendNameTyVarEnv tv_binds $
+                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
+
+------------------------
+-- Lists, tuples, arrays
+tc_pat penv (ListPat Nothing pats) pat_ty thing_inside
+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+                                     pats penv thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat coi
+                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
+}
+
+tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside
+  = do  { tau_pat_ty <- expTypeToType pat_ty
+        ; ((pats', res, elt_ty), e')
+            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
+                                          SynList $
+                 \ [elt_ty] ->
+                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+                                                 pats penv thing_inside
+                    ; return (pats', res, elt_ty) }
+        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
+}
+
+tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
+  = do  { let arity = length pats
+              tc = tupleTyCon boxity arity
+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
+                                               penv pat_ty
+                     -- Unboxed tuples have RuntimeRep vars, which we discard:
+                     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
+                                           Boxed   -> arg_tys
+        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
+                                   thing_inside
+
+        ; dflags <- getDynFlags
+
+        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
+        -- so that we can experiment with lazy tuple-matching.
+        -- This is a pretty odd place to make the switch, but
+        -- it was easy to do.
+        ; let
+              unmangled_result = TuplePat con_arg_tys pats' boxity
+                                 -- pat_ty /= pat_ty iff coi /= IdCo
+              possibly_mangled_result
+                | gopt Opt_IrrefutableTuples dflags &&
+                  isBoxed boxity      = LazyPat noExt (noLoc unmangled_result)
+                | otherwise           = unmangled_result
+
+        ; pat_ty <- readExpType pat_ty
+        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
+          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
+        }
+
+tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
+  = do  { let tc = sumTyCon arity
+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
+                                               penv pat_ty
+        ; -- Drop levity vars, we don't care about them here
+          let con_arg_tys = drop arity arg_tys
+        ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+                                 penv thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+                 , res)
+        }
+
+------------------------
+-- Data constructors
+tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
+  = tcConPat penv con pat_ty arg_pats thing_inside
+
+------------------------
+-- Literal patterns
+tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
+  = do  { let lit_ty = hsLitType simple_lit
+        ; wrap   <- tcSubTypePat penv pat_ty lit_ty
+        ; res    <- thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
+                 , res) }
+
+------------------------
+-- Overloaded patterns: n, and n+k
+
+-- In the case of a negative literal (the more complicated case),
+-- we get
+--
+--   case v of (-5) -> blah
+--
+-- becoming
+--
+--   if v == (negate (fromInteger 5)) then blah else ...
+--
+-- There are two bits of rebindable syntax:
+--   (==)   :: pat_ty -> neg_lit_ty -> Bool
+--   negate :: lit_ty -> neg_lit_ty
+-- where lit_ty is the type of the overloaded literal 5.
+--
+-- When there is no negation, neg_lit_ty and lit_ty are the same
+tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside
+  = do  { let orig = LiteralOrigin over_lit
+        ; ((lit', mb_neg'), eq')
+            <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
+                          (mkCheckExpType boolTy) $
+               \ [neg_lit_ty] ->
+               let new_over_lit lit_ty = newOverloadedLit over_lit
+                                           (mkCheckExpType lit_ty)
+               in case mb_neg of
+                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
+                 Just neg -> -- Negative literal
+                             -- The 'negate' is re-mappable syntax
+                   second Just <$>
+                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
+                    \ [lit_ty] -> new_over_lit lit_ty)
+
+        ; res <- thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) }
+
+{-
+Note [NPlusK patterns]
+~~~~~~~~~~~~~~~~~~~~~~
+From
+
+  case v of x + 5 -> blah
+
+we get
+
+  if v >= 5 then (\x -> blah) (v - 5) else ...
+
+There are two bits of rebindable syntax:
+  (>=) :: pat_ty -> lit1_ty -> Bool
+  (-)  :: pat_ty -> lit2_ty -> var_ty
+
+lit1_ty and lit2_ty could conceivably be different.
+var_ty is the type inferred for x, the variable in the pattern.
+
+If the pushed-down pattern type isn't a tau-type, the two pat_ty's above
+could conceivably be different specializations. But this is very much
+like the situation in Note [Case branches must be taus] in TcMatches.
+So we tauify the pat_ty before proceeding.
+
+Note that we need to type-check the literal twice, because it is used
+twice, and may be used at different types. The second HsOverLit stored in the
+AST is used for the subtraction operation.
+-}
+
+-- See Note [NPlusK patterns]
+tc_pat penv (NPlusKPat _ (dL->L nm_loc name)
+               (dL->L loc lit) _ ge minus) pat_ty
+              thing_inside
+  = do  { pat_ty <- expTypeToType pat_ty
+        ; let orig = LiteralOrigin lit
+        ; (lit1', ge')
+            <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]
+                                  (mkCheckExpType boolTy) $
+               \ [lit1_ty] ->
+               newOverloadedLit lit (mkCheckExpType lit1_ty)
+        ; ((lit2', minus_wrap, bndr_id), minus')
+            <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $
+               \ [lit2_ty, var_ty] ->
+               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
+                  ; (wrap, bndr_id) <- setSrcSpan nm_loc $
+                                     tcPatBndr penv name (mkCheckExpType var_ty)
+                           -- co :: var_ty ~ idType bndr_id
+
+                           -- minus_wrap is applicable to minus'
+                  ; return (lit2', wrap, bndr_id) }
+
+        -- The Report says that n+k patterns must be in Integral
+        -- but it's silly to insist on this in the RebindableSyntax case
+        ; unlessM (xoptM LangExt.RebindableSyntax) $
+          do { icls <- tcLookupClass integralClassName
+             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
+
+        ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+
+        ; let minus'' = minus' { syn_res_wrap =
+                                    minus_wrap <.> syn_res_wrap minus' }
+              pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2'
+                               ge' minus''
+        ; return (pat', res) }
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
+-- Here we get rid of it and add the finalizers to the global environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))
+            pat_ty thing_inside
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tc_pat penv pat pat_ty thing_inside
+
+tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut
+
+
+{-
+Note [Hopping the LIE in lazy patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a lazy pattern, we must *not* discharge constraints from the RHS
+from dictionaries bound in the pattern.  E.g.
+        f ~(C x) = 3
+We can't discharge the Num constraint from dictionaries bound by
+the pattern C!
+
+So we have to make the constraints from thing_inside "hop around"
+the pattern.  Hence the captureConstraints and emitConstraints.
+
+The same thing ensures that equality constraints in a lazy match
+are not made available in the RHS of the match. For example
+        data T a where { T1 :: Int -> T Int; ... }
+        f :: T a -> Int -> a
+        f ~(T1 i) y = y
+It's obviously not sound to refine a to Int in the right
+hand side, because the argument might not match T1 at all!
+
+Finally, a lazy pattern should not bind any existential type variables
+because they won't be in scope when we do the desugaring
+
+
+************************************************************************
+*                                                                      *
+        Most of the work for constructors is here
+        (the rest is in the ConPatIn case of tc_pat)
+*                                                                      *
+************************************************************************
+
+[Pattern matching indexed data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following declarations:
+
+  data family Map k :: * -> *
+  data instance Map (a, b) v = MapPair (Map a (Pair b v))
+
+and a case expression
+
+  case x :: Map (Int, c) w of MapPair m -> ...
+
+As explained by [Wrappers for data instance tycons] in MkIds.hs, the
+worker/wrapper types for MapPair are
+
+  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
+  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+
+So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is
+:R123Map, which means the straight use of boxySplitTyConApp would give a type
+error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls
+boxySplitTyConApp with the family tycon Map instead, which gives us the family
+type list {(Int, c), w}.  To get the correct split for :R123Map, we need to
+unify the family type list {(Int, c), w} with the instance types {(a, b), v}
+(provided by tyConFamInst_maybe together with the family tycon).  This
+unification yields the substitution [a -> Int, b -> c, v -> w], which gives us
+the split arguments for the representation tycon :R123Map as {Int, c, w}
+
+In other words, boxySplitTyConAppWithFamily implicitly takes the coercion
+
+  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
+
+moving between representation and family type into account.  To produce type
+correct Core, this coercion needs to be used to case the type of the scrutinee
+from the family to the representation type.  This is achieved by
+unwrapFamInstScrutinee using a CoPat around the result pattern.
+
+Now it might appear seem as if we could have used the previous GADT type
+refinement infrastructure of refineAlt and friends instead of the explicit
+unification and CoPat generation.  However, that would be wrong.  Why?  The
+whole point of GADT refinement is that the refinement is local to the case
+alternative.  In contrast, the substitution generated by the unification of
+the family type list and instance types needs to be propagated to the outside.
+Imagine that in the above example, the type of the scrutinee would have been
+(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the
+substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the
+instantiation of x with (a, b) must be global; ie, it must be valid in *all*
+alternatives of the case expression, whereas in the GADT case it might vary
+between alternatives.
+
+RIP GADT refinement: refinements have been replaced by the use of explicit
+equality constraints that are used in conjunction with implication constraints
+to express the local scope of GADT refinements.
+-}
+
+--      Running example:
+-- MkT :: forall a b c. (a~[b]) => b -> c -> T a
+--       with scrutinee of type (T ty)
+
+tcConPat :: PatEnv -> Located Name
+         -> ExpSigmaType           -- Type of the pattern
+         -> HsConPatDetails GhcRn -> TcM a
+         -> TcM (Pat GhcTcId, a)
+tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside
+  = do  { con_like <- tcLookupConLike con_name
+        ; case con_like of
+            RealDataCon data_con -> tcDataConPat penv con_lname data_con
+                                                 pat_ty arg_pats thing_inside
+            PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn
+                                             pat_ty arg_pats thing_inside
+        }
+
+tcDataConPat :: PatEnv -> Located Name -> DataCon
+             -> ExpSigmaType               -- Type of the pattern
+             -> HsConPatDetails GhcRn -> TcM a
+             -> TcM (Pat GhcTcId, a)
+tcDataConPat penv (dL->L con_span con_name) data_con pat_ty
+             arg_pats thing_inside
+  = do  { let tycon = dataConTyCon data_con
+                  -- For data families this is the representation tycon
+              (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+                = dataConFullSig data_con
+              header = cL con_span (RealDataCon data_con)
+
+          -- Instantiate the constructor type variables [a->ty]
+          -- This may involve doing a family-instance coercion,
+          -- and building a wrapper
+        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty
+        ; pat_ty <- readExpType pat_ty
+
+          -- Add the stupid theta
+        ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
+
+        ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys
+        ; checkExistentials ex_tvs all_arg_tys penv
+
+        ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys
+                  -- NB: Do not use zipTvSubst!  See #14154
+                  -- We want to create a well-kinded substitution, so
+                  -- that the instantiated type is well-kinded
+
+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs
+                     -- Get location from monad, not from ex_tvs
+
+        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
+              -- pat_ty' is type of the actual constructor application
+              -- pat_ty' /= pat_ty iff coi /= IdCo
+
+              arg_tys' = substTys tenv arg_tys
+
+        ; traceTc "tcConPat" (vcat [ ppr con_name
+                                   , pprTyVars univ_tvs
+                                   , pprTyVars ex_tvs
+                                   , ppr eq_spec
+                                   , ppr theta
+                                   , pprTyVars ex_tvs'
+                                   , ppr ctxt_res_tys
+                                   , ppr arg_tys'
+                                   , ppr arg_pats ])
+        ; if null ex_tvs && null eq_spec && null theta
+          then do { -- The common case; no class bindings etc
+                    -- (see Note [Arrows and patterns])
+                    (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
+                                                  arg_pats penv thing_inside
+                  ; let res_pat = ConPatOut { pat_con = header,
+                                              pat_tvs = [], pat_dicts = [],
+                                              pat_binds = emptyTcEvBinds,
+                                              pat_args = arg_pats',
+                                              pat_arg_tys = ctxt_res_tys,
+                                              pat_wrap = idHsWrapper }
+
+                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
+
+          else do   -- The general case, with existential,
+                    -- and local equality constraints
+        { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)
+                           -- order is *important* as we generate the list of
+                           -- dictionary binders from theta'
+              no_equalities = null eq_spec && not (any isEqPred theta)
+              skol_info = PatSkol (RealDataCon data_con) mc
+              mc = case pe_ctxt penv of
+                     LamPat mc -> mc
+                     LetPat {} -> PatBindRhs
+
+        ; gadts_on    <- xoptM LangExt.GADTs
+        ; families_on <- xoptM LangExt.TypeFamilies
+        ; checkTc (no_equalities || gadts_on || families_on)
+                  (text "A pattern match on a GADT requires the" <+>
+                   text "GADTs or TypeFamilies language extension")
+                  -- #2905 decided that a *pattern-match* of a GADT
+                  -- should require the GADT language flag.
+                  -- Re TypeFamilies see also #7156
+
+        ; given <- newEvVars theta'
+        ; (ev_binds, (arg_pats', res))
+             <- checkConstraints skol_info ex_tvs' given $
+                tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside
+
+        ; let res_pat = ConPatOut { pat_con   = header,
+                                    pat_tvs   = ex_tvs',
+                                    pat_dicts = given,
+                                    pat_binds = ev_binds,
+                                    pat_args  = arg_pats',
+                                    pat_arg_tys = ctxt_res_tys,
+                                    pat_wrap  = idHsWrapper }
+        ; return (mkHsWrapPat wrap res_pat pat_ty, res)
+        } }
+
+tcPatSynPat :: PatEnv -> Located Name -> PatSyn
+            -> ExpSigmaType                -- Type of the pattern
+            -> HsConPatDetails GhcRn -> TcM a
+            -> TcM (Pat GhcTcId, a)
+tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside
+  = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn
+
+        ; (subst, univ_tvs') <- newMetaTyVars univ_tvs
+
+        ; let all_arg_tys = ty : prov_theta ++ arg_tys
+        ; checkExistentials ex_tvs all_arg_tys penv
+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
+        ; let ty'         = substTy tenv ty
+              arg_tys'    = substTys tenv arg_tys
+              prov_theta' = substTheta tenv prov_theta
+              req_theta'  = substTheta tenv req_theta
+
+        ; wrap <- tcSubTypePat penv pat_ty ty'
+        ; traceTc "tcPatSynPat" (ppr pat_syn $$
+                                 ppr pat_ty $$
+                                 ppr ty' $$
+                                 ppr ex_tvs' $$
+                                 ppr prov_theta' $$
+                                 ppr req_theta' $$
+                                 ppr arg_tys')
+
+        ; prov_dicts' <- newEvVars prov_theta'
+
+        ; let skol_info = case pe_ctxt penv of
+                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc
+                            LetPat {} -> UnkSkol -- Doesn't matter
+
+        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'
+        ; traceTc "instCall" (ppr req_wrap)
+
+        ; traceTc "checkConstraints {" Outputable.empty
+        ; (ev_binds, (arg_pats', res))
+             <- checkConstraints skol_info ex_tvs' prov_dicts' $
+                tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
+
+        ; traceTc "checkConstraints }" (ppr ev_binds)
+        ; let res_pat = ConPatOut { pat_con   = cL con_span $ PatSynCon pat_syn,
+                                    pat_tvs   = ex_tvs',
+                                    pat_dicts = prov_dicts',
+                                    pat_binds = ev_binds,
+                                    pat_args  = arg_pats',
+                                    pat_arg_tys = mkTyVarTys univ_tvs',
+                                    pat_wrap  = req_wrap }
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
+
+----------------------------
+-- | Convenient wrapper for calling a matchExpectedXXX function
+matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))
+                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)
+-- See Note [Matching polytyped patterns]
+-- Returns a wrapper : pat_ty ~R inner_ty
+matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty
+  = do { pat_ty <- expTypeToType pat_ty
+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
+       ; (co, res) <- inner_match pat_rho
+       ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)
+       ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) }
+
+----------------------------
+matchExpectedConTy :: PatEnv
+                   -> TyCon      -- The TyCon that this data
+                                 -- constructor actually returns
+                                 -- In the case of a data family this is
+                                 -- the /representation/ TyCon
+                   -> ExpSigmaType  -- The type of the pattern; in the case
+                                    -- of a data family this would mention
+                                    -- the /family/ TyCon
+                   -> TcM (HsWrapper, [TcSigmaType])
+-- See Note [Matching constructor patterns]
+-- Returns a wrapper : pat_ty "->" T ty1 ... tyn
+matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
+  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
+         -- Comments refer to Note [Matching constructor patterns]
+         -- co_tc :: forall a. T [a] ~ T7 a
+  = do { pat_ty <- expTypeToType exp_pat_ty
+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
+
+       ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
+             -- tys = [ty1,ty2]
+
+       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
+                                             ppr (tyConTyVars data_tc),
+                                             ppr fam_tc, ppr fam_args,
+                                             ppr exp_pat_ty,
+                                             ppr pat_ty,
+                                             ppr pat_rho, ppr wrap])
+       ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
+             -- co1 : T (ty1,ty2) ~N pat_rho
+             -- could use tcSubType here... but it's the wrong way round
+             -- for actual vs. expected in error messages.
+
+       ; let tys' = mkTyVarTys tvs'
+             co2 = mkTcUnbranchedAxInstCo co_tc tys' []
+             -- co2 : T (ty1,ty2) ~R T7 ty1 ty2
+
+             full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2
+             -- full_co :: pat_rho ~R T7 ty1 ty2
+
+       ; return ( mkWpCastR full_co <.> wrap, tys') }
+
+  | otherwise
+  = do { pat_ty <- expTypeToType exp_pat_ty
+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
+       ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
+       ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }
+
+{-
+Note [Matching constructor patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
+
+ * In the simple case, pat_ty = tc tys
+
+ * If pat_ty is a polytype, we want to instantiate it
+   This is like part of a subsumption check.  Eg
+      f :: (forall a. [a]) -> blah
+      f [] = blah
+
+ * In a type family case, suppose we have
+          data family T a
+          data instance T (p,q) = A p | B q
+       Then we'll have internally generated
+              data T7 p q = A p | B q
+              axiom coT7 p q :: T (p,q) ~ T7 p q
+
+       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that
+           coi = coi2 . coi1 : T7 t ~ pat_ty
+           coi1 : T (ty1,ty2) ~ pat_ty
+           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)
+
+   For families we do all this matching here, not in the unifier,
+   because we never want a whisper of the data_tycon to appear in
+   error messages; it's a purely internal thing
+-}
+
+tcConArgs :: ConLike -> [TcSigmaType]
+          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)
+
+tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside
+  = do  { checkTc (con_arity == no_of_args)     -- Check correct arity
+                  (arityErr (text "constructor") con_like con_arity no_of_args)
+        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
+        ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys
+                                              penv thing_inside
+        ; return (PrefixCon arg_pats', res) }
+  where
+    con_arity  = conLikeArity con_like
+    no_of_args = length arg_pats
+
+tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside
+  = do  { checkTc (con_arity == 2)      -- Check correct arity
+                  (arityErr (text "constructor") con_like con_arity 2)
+        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check
+        ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
+                                              penv thing_inside
+        ; return (InfixCon p1' p2', res) }
+  where
+    con_arity  = conLikeArity con_like
+
+tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
+  = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
+        ; return (RecCon (HsRecFields rpats' dd), res) }
+  where
+    tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
+                        (LHsRecField GhcTcId (LPat GhcTcId))
+    tc_field (dL->L l (HsRecField (dL->L loc
+                                    (FieldOcc sel (dL->L lr rdr))) pat pun))
+             penv thing_inside
+      = do { sel'   <- tcLookupId sel
+           ; pat_ty <- setSrcSpan loc $ find_field_ty sel
+                                          (occNameFS $ rdrNameOcc rdr)
+           ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
+           ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat'
+                                                                    pun), res) }
+    tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _
+           = panic "tcConArgs"
+    tc_field _ _ _ = panic "tc_field: Impossible Match"
+                             -- due to #15884
+
+
+    find_field_ty :: Name -> FieldLabelString -> TcM TcType
+    find_field_ty sel lbl
+        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of
+
+                -- No matching field; chances are this field label comes from some
+                -- other record type (or maybe none).  If this happens, just fail,
+                -- otherwise we get crashes later (#8570), and similar:
+                --      f (R { foo = (a,b) }) = a+b
+                -- If foo isn't one of R's fields, we don't want to crash when
+                -- typechecking the "a+b".
+           [] -> failWith (badFieldCon con_like lbl)
+
+                -- The normal case, when the field comes from the right constructor
+           (pat_ty : extras) -> do
+                traceTc "find_field" (ppr pat_ty <+> ppr extras)
+                ASSERT( null extras ) (return pat_ty)
+
+    field_tys :: [(FieldLabel, TcType)]
+    field_tys = zip (conLikeFieldLabels con_like) arg_tys
+          -- Don't use zipEqual! If the constructor isn't really a record, then
+          -- dataConFieldLabels will be empty (and each field in the pattern
+          -- will generate an error below).
+
+tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc)
+tcConArg (arg_pat, arg_ty) penv thing_inside
+  = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside
+
+addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
+-- Instantiate the "stupid theta" of the data con, and throw
+-- the constraints into the constraint set
+addDataConStupidTheta data_con inst_tys
+  | null stupid_theta = return ()
+  | otherwise         = instStupidTheta origin inst_theta
+  where
+    origin = OccurrenceOf (dataConName data_con)
+        -- The origin should always report "occurrence of C"
+        -- even when C occurs in a pattern
+    stupid_theta = dataConStupidTheta data_con
+    univ_tvs     = dataConUnivTyVars data_con
+    tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys)
+         -- NB: inst_tys can be longer than the univ tyvars
+         --     because the constructor might have existentials
+    inst_theta = substTheta tenv stupid_theta
+
+{-
+Note [Arrows and patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+(Oct 07) Arrow notation has the odd property that it involves
+"holes in the scope". For example:
+  expr :: Arrow a => a () Int
+  expr = proc (y,z) -> do
+          x <- term -< y
+          expr' -< x
+
+Here the 'proc (y,z)' binding scopes over the arrow tails but not the
+arrow body (e.g 'term').  As things stand (bogusly) all the
+constraints from the proc body are gathered together, so constraints
+from 'term' will be seen by the tcPat for (y,z).  But we must *not*
+bind constraints from 'term' here, because the desugarer will not make
+these bindings scope over 'term'.
+
+The Right Thing is not to confuse these constraints together. But for
+now the Easy Thing is to ensure that we do not have existential or
+GADT constraints in a 'proc', and to short-cut the constraint
+simplification for such vanilla patterns so that it binds no
+constraints. Hence the 'fast path' in tcConPat; but it's also a good
+plan for ordinary vanilla patterns to bypass the constraint
+simplification step.
+
+************************************************************************
+*                                                                      *
+                Note [Pattern coercions]
+*                                                                      *
+************************************************************************
+
+In principle, these program would be reasonable:
+
+        f :: (forall a. a->a) -> Int
+        f (x :: Int->Int) = x 3
+
+        g :: (forall a. [a]) -> Bool
+        g [] = True
+
+In both cases, the function type signature restricts what arguments can be passed
+in a call (to polymorphic ones).  The pattern type signature then instantiates this
+type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we
+generate the translated term
+        f = \x' :: (forall a. a->a).  let x = x' Int in x 3
+
+From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
+And it requires a significant amount of code to implement, because we need to decorate
+the translated pattern with coercion functions (generated from the subsumption check
+by tcSub).
+
+So for now I'm just insisting on type *equality* in patterns.  No subsumption.
+
+Old notes about desugaring, at a time when pattern coercions were handled:
+
+A SigPat is a type coercion and must be handled one at at time.  We can't
+combine them unless the type of the pattern inside is identical, and we don't
+bother to check for that.  For example:
+
+        data T = T1 Int | T2 Bool
+        f :: (forall a. a -> a) -> T -> t
+        f (g::Int->Int)   (T1 i) = T1 (g i)
+        f (g::Bool->Bool) (T2 b) = T2 (g b)
+
+We desugar this as follows:
+
+        f = \ g::(forall a. a->a) t::T ->
+            let gi = g Int
+            in case t of { T1 i -> T1 (gi i)
+                           other ->
+            let gb = g Bool
+            in case t of { T2 b -> T2 (gb b)
+                           other -> fail }}
+
+Note that we do not treat the first column of patterns as a
+column of variables, because the coerced variables (gi, gb)
+would be of different types.  So we get rather grotty code.
+But I don't think this is a common case, and if it was we could
+doubtless improve it.
+
+Meanwhile, the strategy is:
+        * treat each SigPat coercion (always non-identity coercions)
+                as a separate block
+        * deal with the stuff inside, and then wrap a binding round
+                the result to bind the new variable (gi, gb, etc)
+
+
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+Note [Existential check]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Lazy patterns can't bind existentials.  They arise in two ways:
+  * Let bindings      let { C a b = e } in b
+  * Twiddle patterns  f ~(C a b) = e
+The pe_lazy field of PatEnv says whether we are inside a lazy
+pattern (perhaps deeply)
+
+See also Note [Typechecking pattern bindings] in TcBinds
+-}
+
+maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside
+  | not (worth_wrapping pat) = tcm thing_inside
+  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+                               -- Remember to pop before doing thing_inside
+  where
+   worth_wrapping (VarPat {}) = False
+   worth_wrapping (ParPat {}) = False
+   worth_wrapping (AsPat {})  = False
+   worth_wrapping _           = True
+   msg = hang (text "In the pattern:") 2 (ppr pat)
+
+-----------------------------------------------
+checkExistentials :: [TyVar]   -- existentials
+                  -> [Type]    -- argument types
+                  -> PatEnv -> TcM ()
+    -- See Note [Existential check]]
+    -- See Note [Arrows and patterns]
+checkExistentials ex_tvs tys _
+  | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return ()
+checkExistentials _ _ (PE { pe_ctxt = LetPat {}})         = return ()
+checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr })  = failWithTc existentialProcPat
+checkExistentials _ _ (PE { pe_lazy = True })             = failWithTc existentialLazyPat
+checkExistentials _ _ _                                   = return ()
+
+existentialLazyPat :: SDoc
+existentialLazyPat
+  = hang (text "An existential or GADT data constructor cannot be used")
+       2 (text "inside a lazy (~) pattern")
+
+existentialProcPat :: SDoc
+existentialProcPat
+  = text "Proc patterns cannot use existential or GADT data constructors"
+
+badFieldCon :: ConLike -> FieldLabelString -> SDoc
+badFieldCon con field
+  = hsep [text "Constructor" <+> quotes (ppr con),
+          text "does not have field", quotes (ppr field)]
+
+polyPatSig :: TcType -> SDoc
+polyPatSig sig_ty
+  = hang (text "Illegal polymorphic type signature in pattern:")
+       2 (ppr sig_ty)
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -0,0 +1,1148 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcPatSyn]{Typechecking pattern synonym declarations}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
+                , tcPatSynBuilderOcc, nonBidirectionalErr
+  ) where
+
+import GhcPrelude
+
+import HsSyn
+import TcPat
+import Type( tidyTyCoVarBinders, tidyTypes, tidyType )
+import TcRnMonad
+import TcSigs( emptyPragEnv, completeSigFromId )
+import TcEnv
+import TcMType
+import TcHsSyn
+import TysPrim
+import Name
+import SrcLoc
+import PatSyn
+import NameSet
+import Panic
+import Outputable
+import FastString
+import Var
+import VarEnv( emptyTidyEnv, mkInScopeSet )
+import Id
+import IdInfo( RecSelParent(..), setLevityInfoWithType )
+import TcBinds
+import BasicTypes
+import TcSimplify
+import TcUnify
+import Type( PredTree(..), EqRel(..), classifyPredType )
+import TysWiredIn
+import TcType
+import TcEvidence
+import BuildTyCl
+import VarSet
+import MkId
+import TcTyDecls
+import ConLike
+import FieldLabel
+import Bag
+import Util
+import ErrUtils
+import Data.Maybe( mapMaybe )
+import Control.Monad ( zipWithM )
+import Data.List( partition )
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+                    Type checking a pattern synonym
+*                                                                      *
+************************************************************************
+-}
+
+tcPatSynDecl :: PatSynBind GhcRn GhcRn
+             -> Maybe TcSigInfo
+             -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcPatSynDecl psb mb_sig
+  = recoverM (recoverPSB psb) $
+    case mb_sig of
+      Nothing                 -> tcInferPatSynDecl psb
+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
+      _                       -> panic "tcPatSynDecl"
+
+recoverPSB :: PatSynBind GhcRn GhcRn
+           -> TcM (LHsBinds GhcTc, TcGblEnv)
+-- See Note [Pattern synonym error recovery]
+recoverPSB (PSB { psb_id = (dL->L _ name)
+                , psb_args = details })
+ = do { matcher_name <- newImplicitBinder name mkMatcherOcc
+      ; let placeholder = AConLike $ PatSynCon $
+                          mk_placeholder matcher_name
+      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
+      ; return (emptyBag, gbl_env) }
+  where
+    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
+    mk_placeholder matcher_name
+      = mkPatSyn name is_infix
+                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])
+                        [] -- Arg tys
+                        alphaTy
+                        (matcher_id, True) Nothing
+                        []  -- Field labels
+       where
+         -- The matcher_id is used only by the desugarer, so actually
+         -- and error-thunk would probably do just as well here.
+         matcher_id = mkLocalId matcher_name $
+                      mkSpecForAllTys [alphaTyVar] alphaTy
+
+recoverPSB (XPatSynBind {}) = panic "recoverPSB"
+
+{- Note [Pattern synonym error recovery]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If type inference for a pattern synonym fails, we can't continue with
+the rest of tc_patsyn_finish, because we may get knock-on errors, or
+even a crash.  E.g. from
+   pattern What = True :: Maybe
+we get a kind error; and we must stop right away (#15289).
+
+We stop if there are /any/ unsolved constraints, not just insoluble
+ones; because pattern synonyms are top-level things, we will never
+solve them later if we can't solve them now.  And if we were to carry
+on, tc_patsyn_finish does zonkTcTypeToType, which defaults any
+unsolved unificatdion variables to Any, which confuses the error
+reporting no end (#15685).
+
+So we use simplifyTop to completely solve the constraint, report
+any errors, throw an exception.
+
+Even in the event of such an error we can recover and carry on, just
+as we do for value bindings, provided we plug in placeholder for the
+pattern synonym: see recoverPSB.  The goal of the placeholder is not
+to cause a raft of follow-on errors.  I've used the simplest thing for
+now, but we might need to elaborate it a bit later.  (e.g.  I've given
+it zero args, which may cause knock-on errors if it is used in a
+pattern.) But it'll do for now.
+
+-}
+
+tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
+                  -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details
+                       , psb_def = lpat, psb_dir = dir })
+  = addPatSynCtxt lname $
+    do { traceTc "tcInferPatSynDecl {" $ ppr name
+
+       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+       ; (tclvl, wanted, ((lpat', args), pat_ty))
+            <- pushLevelAndCaptureConstraints  $
+               tcInferNoInst                   $ \ exp_ty ->
+               tcPat PatSyn lpat exp_ty        $
+               mapM tcLookupId arg_names
+
+       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
+
+             named_taus = (name, pat_ty) : map mk_named_tau args
+             mk_named_tau arg
+               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))
+               -- The mkSpecForAllTys is important (#14552), albeit
+               -- slightly artifical (there is no variable with this funny type).
+               -- We do not want to quantify over variable (alpha::k)
+               -- that mention the existentially-bound type variables
+               -- ex_tvs in its kind k.
+               -- See Note [Type variables whose kind is captured]
+
+       ; (univ_tvs, req_dicts, ev_binds, residual, _)
+               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
+       ; top_ev_binds <- checkNoErrs (simplifyTop residual)
+       ; addTopEvBinds top_ev_binds $
+
+    do { prov_dicts <- mapM zonkId prov_dicts
+       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
+             -- Filtering: see Note [Remove redundant provided dicts]
+             (prov_theta, prov_evs)
+                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
+             req_theta = map evVarPred req_dicts
+
+       -- Report coercions that esacpe
+       -- See Note [Coercions that escape]
+       ; args <- mapM zonkId args
+       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
+                              , let bad_cos = filterDVarSet isId $
+                                              (tyCoVarsOfTypeDSet (idType arg))
+                              , not (isEmptyDVarSet bad_cos) ]
+       ; mapM_ dependentArgErr bad_args
+
+       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
+       ; tc_patsyn_finish lname dir is_infix lpat'
+                          (mkTyVarBinders Inferred univ_tvs
+                            , req_theta,  ev_binds, req_dicts)
+                          (mkTyVarBinders Inferred ex_tvs
+                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)
+                          (map nlHsVar args, map idType args)
+                          pat_ty rec_fields } }
+tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
+
+mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
+-- See Note [Equality evidence in pattern synonyms]
+mkProvEvidence ev_id
+  | EqPred r ty1 ty2 <- classifyPredType pred
+  , let k1 = tcTypeKind ty1
+        k2 = tcTypeKind ty2
+        is_homo = k1 `tcEqType` k2
+        homo_tys   = [k1, ty1, ty2]
+        hetero_tys = [k1, k2, ty1, ty2]
+  = case r of
+      ReprEq | is_homo
+             -> Just ( mkClassPred coercibleClass    homo_tys
+                     , evDataConApp coercibleDataCon homo_tys eq_con_args )
+             | otherwise -> Nothing
+      NomEq  | is_homo
+             -> Just ( mkClassPred eqClass    homo_tys
+                     , evDataConApp eqDataCon homo_tys eq_con_args )
+             | otherwise
+             -> Just ( mkClassPred heqClass    hetero_tys
+                     , evDataConApp heqDataCon hetero_tys eq_con_args )
+
+  | otherwise
+  = Just (pred, EvExpr (evId ev_id))
+  where
+    pred = evVarPred ev_id
+    eq_con_args = [evId ev_id]
+
+dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
+-- See Note [Coercions that escape]
+dependentArgErr (arg, bad_cos)
+  = addErrTc $
+    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
+         , hang (text "Pattern-bound variable")
+              2 (ppr arg <+> dcolon <+> ppr (idType arg))
+         , nest 2 $
+           hang (text "has a type that mentions pattern-bound coercion"
+                 <> plural bad_co_list <> colon)
+              2 (pprWithCommas ppr bad_co_list)
+         , text "Hint: use -fprint-explicit-coercions to see the coercions"
+         , text "Probable fix: add a pattern signature" ]
+  where
+    bad_co_list = dVarSetElems bad_cos
+
+{- Note [Type variables whose kind is captured]
+~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data AST a = Sym [a]
+  class Prj s where { prj :: [a] -> Maybe (s a)
+  pattern P x <= Sym (prj -> Just x)
+
+Here we get a matcher with this type
+  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r
+
+No problem.  But note that 's' is not fixed by the type of the
+pattern (AST a), nor is it existentially bound.  It's really only
+fixed by the type of the continuation.
+
+#14552 showed that this can go wrong if the kind of 's' mentions
+existentially bound variables.  We obviously can't make a type like
+  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
+                                   -> r -> r
+But neither is 's' itself existentially bound, so the forall (s::k->*)
+can't go in the inner forall either.  (What would the matcher apply
+the continuation to?)
+
+Solution: do not quantiify over any unification variable whose kind
+mentions the existentials.  We can conveniently do that by making the
+"taus" passed to simplifyInfer look like
+   forall ex_tvs. arg_ty
+
+After that, Note [Naughty quantification candidates] in TcMType takes
+over, and zonks any such naughty variables to Any.
+
+Note [Remove redundant provided dicts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Recall that
+   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
+                                       => a1 :~~: a2
+(NB: technically the (k1~k2) existential dictionary is not necessary,
+but it's there at the moment.)
+
+Now consider (#14394):
+   pattern Foo = HRefl
+in a non-poly-kinded module.  We don't want to get
+    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
+with that redundant (* ~ *).  We'd like to remove it; hence the call to
+mkMinimalWithSCs.
+
+Similarly consider
+  data S a where { MkS :: Ord a => a -> S a }
+  pattern Bam x y <- (MkS (x::a), MkS (y::a)))
+
+The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
+need one.  Agian mkMimimalWithSCs removes the redundant one.
+
+Note [Equality evidence in pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data X a where
+     MkX :: Eq a => [a] -> X (Maybe a)
+  pattern P x = MkG x
+
+Then there is a danger that GHC will infer
+  P :: forall a.  () =>
+       forall b. (a ~# Maybe b, Eq b) => [b] -> X a
+
+The 'builder' for P, which is called in user-code, will then
+have type
+  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a
+
+and that is bad because (a ~# Maybe b) is not a predicate type
+(see Note [Types for coercions, predicates, and evidence] in Type)
+and is not implicitly instantiated.
+
+So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and
+marginally less efficient, if the builder/martcher are not inlined.
+
+See also Note [Lift equality constaints when quantifying] in TcType
+
+Note [Coercions that escape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#14507 showed an example where the inferred type of the matcher
+for the pattern synonym was somethign like
+   $mSO :: forall (r :: TYPE rep) kk (a :: k).
+           TypeRep k a
+           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
+           -> (Void# -> r)
+           -> r
+
+What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
+selection) by the pattern being matched; and indeed it is implicit in
+the context (Bool ~ k).  You could imagine trying to extract it like
+this:
+   $mSO :: forall (r :: TYPE rep) kk (a :: k).
+           TypeRep k a
+           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
+                  let co_a2sv = sc_sel co
+                  in TypeRep Bool (a |> co_a2sv) -> r)
+           -> (Void# -> r)
+           -> r
+
+But we simply don't allow that in types.  Maybe one day but not now.
+
+How to detect this situation?  We just look for free coercion variables
+in the types of any of the arguments to the matcher.  The error message
+is not very helpful, but at least we don't get a Lint error.
+-}
+
+tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
+                  -> TcPatSynInfo
+                  -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details
+                         , psb_def = lpat, psb_dir = dir }
+                  TPSI{ patsig_implicit_bndrs = implicit_tvs
+                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
+                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta
+                      , patsig_body_ty    = sig_body_ty }
+  = addPatSynCtxt lname $
+    do { let decl_arity = length arg_names
+             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+
+       ; traceTc "tcCheckPatSynDecl" $
+         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
+              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
+
+       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
+                                 Right stuff  -> return stuff
+                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing
+
+       -- Complain about:  pattern P :: () => forall x. x -> P x
+       -- The existential 'x' should not appear in the result type
+       -- Can't check this until we know P's arity
+       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
+       ; checkTc (null bad_tvs) $
+         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
+                   , text "namely" <+> quotes (ppr pat_ty) ])
+            2 (text "mentions existential type variable" <> plural bad_tvs
+               <+> pprQuotedList bad_tvs)
+
+         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
+       ; let univ_fvs = closeOverKinds $
+                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
+             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
+             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
+             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs
+             univ_tvs   = binderVars univ_bndrs
+             ex_tvs     = binderVars ex_bndrs
+
+       -- Right!  Let's check the pattern against the signature
+       -- See Note [Checking against a pattern signature]
+       ; req_dicts <- newEvVars req_theta
+       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
+           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
+           pushLevelAndCaptureConstraints            $
+           tcExtendTyVarEnv univ_tvs                 $
+           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
+           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
+                    empty_subst = mkEmptyTCvSubst in_scope
+              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
+                    -- newMetaTyVarX: see the "Existential type variables"
+                    -- part of Note [Checking against a pattern signature]
+              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
+              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
+              ; let prov_theta' = substTheta subst prov_theta
+                  -- Add univ_tvs to the in_scope set to
+                  -- satisfy the substitution invariant. There's no need to
+                  -- add 'ex_tvs' as they are already in the domain of the
+                  -- substitution.
+                  -- See also Note [The substitution invariant] in TyCoRep.
+              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
+              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
+              ; return (ex_tvs', prov_dicts, args') }
+
+       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
+                         -- The type here is a bit bogus, but we do not print
+                         -- the type for PatSynCtxt, so it doesn't matter
+                         -- See TcRnTypes Note [Skolem info for pattern synonyms]
+       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
+
+       -- Solve the constraints now, because we are about to make a PatSyn,
+       -- which should not contain unification variables and the like (#10997)
+       ; simplifyTopImplic implics
+
+       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
+       -- Otherwise we may get a type error when typechecking the builder,
+       -- when that should be impossible
+
+       ; traceTc "tcCheckPatSynDecl }" $ ppr name
+       ; tc_patsyn_finish lname dir is_infix lpat'
+                          (univ_bndrs, req_theta, ev_binds, req_dicts)
+                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
+                          (args', arg_tys)
+                          pat_ty rec_fields }
+  where
+    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
+    tc_arg subst arg_name arg_ty
+      = do {   -- Look up the variable actually bound by lpat
+               -- and check that it has the expected type
+             arg_id <- tcLookupId arg_name
+           ; wrap <- tcSubType_NC GenSigCtxt
+                                 (idType arg_id)
+                                 (substTyUnchecked subst arg_ty)
+                -- Why do we need tcSubType here?
+                -- See Note [Pattern synonyms and higher rank types]
+           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
+tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"
+
+{- [Pattern synonyms and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T = MkT (forall a. a->a)
+
+  pattern P :: (Int -> Int) -> T
+  pattern P x <- MkT x
+
+This should work.  But in the matcher we must match against MkT, and then
+instantiate its argument 'x', to get a function of type (Int -> Int).
+Equality is not enough!  #13752 was an example.
+
+
+Note [The pattern-synonym signature splitting rule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a pattern signature, we must split
+     the kind-generalised variables, and
+     the implicitly-bound variables
+into universal and existential.  The rule is this
+(see discussion on #11224):
+
+     The universal tyvars are the ones mentioned in
+          - univ_tvs: the user-specified (forall'd) universals
+          - req_theta
+          - res_ty
+     The existential tyvars are all the rest
+
+For example
+
+   pattern P :: () => b -> T a
+   pattern P x = ...
+
+Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
+how do we split the arg_tys from req_ty?  Consider
+
+   pattern Q :: () => b -> S c -> T a
+   pattern Q x = ...
+
+This is an odd example because Q has only one syntactic argument, and
+so presumably is defined by a view pattern matching a function.  But
+it can happen (#11977, #12108).
+
+We don't know Q's arity from the pattern signature, so we have to wait
+until we see the pattern declaration itself before deciding res_ty is,
+and hence which variables are existential and which are universal.
+
+And that in turn is why TcPatSynInfo has a separate field,
+patsig_implicit_bndrs, to capture the implicitly bound type variables,
+because we don't yet know how to split them up.
+
+It's a slight compromise, because it means we don't really know the
+pattern synonym's real signature until we see its declaration.  So,
+for example, in hs-boot file, we may need to think what to do...
+(eg don't have any implicitly-bound variables).
+
+
+Note [Checking against a pattern signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking the actual supplied pattern against the pattern synonym
+signature, we need to be quite careful.
+
+----- Provided constraints
+Example
+
+    data T a where
+      MkT :: Ord a => a -> T a
+
+    pattern P :: () => Eq a => a -> [T a]
+    pattern P x = [MkT x]
+
+We must check that the (Eq a) that P claims to bind (and to
+make available to matches against P), is derivable from the
+actual pattern.  For example:
+    f (P (x::a)) = ...here (Eq a) should be available...
+And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.
+
+----- Existential type variables
+Unusually, we instantiate the existential tyvars of the pattern with
+*meta* type variables.  For example
+
+    data S where
+      MkS :: Eq a => [a] -> S
+
+    pattern P :: () => Eq x => x -> S
+    pattern P x <- MkS x
+
+The pattern synonym conceals from its client the fact that MkS has a
+list inside it.  The client just thinks it's a type 'x'.  So we must
+unify x := [a] during type checking, and then use the instantiating type
+[a] (called ex_tys) when building the matcher.  In this case we'll get
+
+   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
+   $mP x k = case x of
+               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
+                                              dl = $dfunEqList d
+                                          in k [a] dl ys
+
+All this applies when type-checking the /matching/ side of
+a pattern synonym.  What about the /building/ side?
+
+* For Unidirectional, there is no builder
+
+* For ExplicitBidirectional, the builder is completely separate
+  code, typechecked in tcPatSynBuilderBind
+
+* For ImplicitBidirectional, the builder is still typechecked in
+  tcPatSynBuilderBind, by converting the pattern to an expression and
+  typechecking it.
+
+  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
+  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
+  is redundant since tcPatSynBuilderBind does the job, (b) it was
+  still incomplete (TyVarTvs can unify with each other), and (c) it
+  didn't even work (#13441 was accepted with
+  ExplicitBidirectional, but rejected if expressed in
+  ImplicitBidirectional form.  Conclusion: trying to be too clever is
+  a bad idea.
+-}
+
+collectPatSynArgInfo :: HsPatSynDetails (Located Name)
+                     -> ([Name], [Name], Bool)
+collectPatSynArgInfo details =
+  case details of
+    PrefixCon names      -> (map unLoc names, [], False)
+    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
+    RecCon names         -> (vars, sels, False)
+                         where
+                            (vars, sels) = unzip (map splitRecordPatSyn names)
+  where
+    splitRecordPatSyn :: RecordPatSynField (Located Name)
+                      -> (Name, Name)
+    splitRecordPatSyn (RecordPatSynField
+                       { recordPatSynPatVar     = (dL->L _ patVar)
+                       , recordPatSynSelectorId = (dL->L _ selId) })
+      = (patVar, selId)
+
+addPatSynCtxt :: Located Name -> TcM a -> TcM a
+addPatSynCtxt (dL->L loc name) thing_inside
+  = setSrcSpan loc $
+    addErrCtxt (text "In the declaration for pattern synonym"
+                <+> quotes (ppr name)) $
+    thing_inside
+
+wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
+wrongNumberOfParmsErr name decl_arity missing
+  = failWithTc $
+    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
+          <+> speakNOf decl_arity (text "argument"))
+       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+
+-------------------------
+-- Shared by both tcInferPatSyn and tcCheckPatSyn
+tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
+                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
+                 -> Bool              -- ^ Whether infix
+                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
+                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
+                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
+                 -> ([LHsExpr GhcTcId], [TcType])   -- ^ Pattern arguments and
+                                                    -- types
+                 -> TcType            -- ^ Pattern type
+                 -> [Name]            -- ^ Selector names
+                 -- ^ Whether fields, empty if not record PatSyn
+                 -> TcM (LHsBinds GhcTc, TcGblEnv)
+tc_patsyn_finish lname dir is_infix lpat'
+                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
+                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
+                 (args, arg_tys)
+                 pat_ty field_labels
+  = do { -- Zonk everything.  We are about to build a final PatSyn
+         -- so there had better be no unification variables in there
+
+         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs
+       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
+       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
+       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
+       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty
+       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys
+
+       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
+             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'
+             req_theta  = tidyTypes env2 req_theta'
+             prov_theta = tidyTypes env2 prov_theta'
+             arg_tys    = tidyTypes env2 arg_tys'
+             pat_ty     = tidyType  env2 pat_ty'
+
+       ; traceTc "tc_patsyn_finish {" $
+           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
+           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
+           ppr (ex_tvs, prov_theta, prov_dicts) $$
+           ppr args $$
+           ppr arg_tys $$
+           ppr pat_ty
+
+       -- Make the 'matcher'
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
+                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
+                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
+                                         (args, arg_tys)
+                                         pat_ty
+
+       -- Make the 'builder'
+       ; builder_id <- mkPatSynBuilderId dir lname
+                                         univ_tvs req_theta
+                                         ex_tvs   prov_theta
+                                         arg_tys pat_ty
+
+         -- TODO: Make this have the proper information
+       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
+                                            , flIsOverloaded = False
+                                            , flSelector = name }
+             field_labels' = map mkFieldLabel field_labels
+
+
+       -- Make the PatSyn itself
+       ; let patSyn = mkPatSyn (unLoc lname) is_infix
+                        (univ_tvs, req_theta)
+                        (ex_tvs, prov_theta)
+                        arg_tys
+                        pat_ty
+                        matcher_id builder_id
+                        field_labels'
+
+       -- Selectors
+       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
+             tything = AConLike (PatSynCon patSyn)
+       ; tcg_env <- tcExtendGlobalEnv [tything] $
+                    tcRecSelBinds rn_rec_sel_binds
+
+       ; traceTc "tc_patsyn_finish }" empty
+       ; return (matcher_bind, tcg_env) }
+
+{-
+************************************************************************
+*                                                                      *
+         Constructing the "matcher" Id and its binding
+*                                                                      *
+************************************************************************
+-}
+
+tcPatSynMatcher :: Located Name
+                -> LPat GhcTc
+                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
+                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
+                -> ([LHsExpr GhcTcId], [TcType])
+                -> TcType
+                -> TcM ((Id, Bool), LHsBinds GhcTc)
+-- See Note [Matchers and builders for pattern synonyms] in PatSyn
+tcPatSynMatcher (dL->L loc name) lpat
+                (univ_tvs, req_theta, req_ev_binds, req_dicts)
+                (ex_tvs, ex_tys, prov_theta, prov_dicts)
+                (args, arg_tys) pat_ty
+  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
+       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
+       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
+             rr     = mkTyVarTy rr_tv
+             res_tv = mkTyVar tv_name (tYPE rr)
+             res_ty = mkTyVarTy res_tv
+             is_unlifted = null args && null prov_dicts
+             (cont_args, cont_arg_tys)
+               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
+               | otherwise   = (args,                 arg_tys)
+             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
+                       mkVisFunTys cont_arg_tys res_ty
+
+             fail_ty  = mkVisFunTy voidPrimTy res_ty
+
+       ; matcher_name <- newImplicitBinder name mkMatcherOcc
+       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
+       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
+       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty
+
+       ; let matcher_tau   = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty
+             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
+             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
+                             -- See Note [Exported LocalIds] in Id
+
+             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
+             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
+
+             fail' = nlHsApps fail [nlHsVar voidPrimId]
+
+             args = map nlVarPat [scrutinee, cont, fail]
+             lwpat = noLoc $ WildPat pat_ty
+             cases = if isIrrefutableHsPat lpat
+                     then [mkHsCaseAlt lpat  cont']
+                     else [mkHsCaseAlt lpat  cont',
+                           mkHsCaseAlt lwpat fail']
+             body = mkLHsWrap (mkWpLet req_ev_binds) $
+                    cL (getLoc lpat) $
+                    HsCase noExt (nlHsVar scrutinee) $
+                    MG{ mg_alts = cL (getLoc lpat) cases
+                      , mg_ext = MatchGroupTc [pat_ty] res_ty
+                      , mg_origin = Generated
+                      }
+             body' = noLoc $
+                     HsLam noExt $
+                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
+                                                        args body]
+                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
+                       , mg_origin = Generated
+                       }
+             match = mkMatch (mkPrefixFunRhs (cL loc name)) []
+                             (mkHsLams (rr_tv:res_tv:univ_tvs)
+                                       req_dicts body')
+                             (noLoc (EmptyLocalBinds noExt))
+             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
+             mg = MG{ mg_alts = cL (getLoc match) [match]
+                    , mg_ext = MatchGroupTc [] res_ty
+                    , mg_origin = Generated
+                    }
+
+       ; let bind = FunBind{ fun_ext = emptyNameSet
+                           , fun_id = cL loc matcher_id
+                           , fun_matches = mg
+                           , fun_co_fn = idHsWrapper
+                           , fun_tick = [] }
+             matcher_bind = unitBag (noLoc bind)
+
+       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
+       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
+
+       ; return ((matcher_id, is_unlifted), matcher_bind) }
+
+mkPatSynRecSelBinds :: PatSyn
+                    -> [FieldLabel]  -- ^ Visible field labels
+                    -> [(Id, LHsBind GhcRn)]
+mkPatSynRecSelBinds ps fields
+  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
+    | fld_lbl <- fields ]
+
+isUnidirectional :: HsPatSynDir a -> Bool
+isUnidirectional Unidirectional          = True
+isUnidirectional ImplicitBidirectional   = False
+isUnidirectional ExplicitBidirectional{} = False
+
+{-
+************************************************************************
+*                                                                      *
+         Constructing the "builder" Id
+*                                                                      *
+************************************************************************
+-}
+
+mkPatSynBuilderId :: HsPatSynDir a -> Located Name
+                  -> [TyVarBinder] -> ThetaType
+                  -> [TyVarBinder] -> ThetaType
+                  -> [Type] -> Type
+                  -> TcM (Maybe (Id, Bool))
+mkPatSynBuilderId dir (dL->L _ name)
+                  univ_bndrs req_theta ex_bndrs prov_theta
+                  arg_tys pat_ty
+  | isUnidirectional dir
+  = return Nothing
+  | otherwise
+  = do { builder_name <- newImplicitBinder name mkBuilderOcc
+       ; let theta          = req_theta ++ prov_theta
+             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
+             builder_sigma  = add_void need_dummy_arg $
+                              mkForAllTys univ_bndrs $
+                              mkForAllTys ex_bndrs $
+                              mkPhiTy theta $
+                              mkVisFunTys arg_tys $
+                              pat_ty
+             builder_id     = mkExportedVanillaId builder_name builder_sigma
+              -- See Note [Exported LocalIds] in Id
+
+             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
+
+       ; return (Just (builder_id', need_dummy_arg)) }
+  where
+
+tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
+                    -> TcM (LHsBinds GhcTc)
+-- See Note [Matchers and builders for pattern synonyms] in PatSyn
+tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name)
+                         , psb_def = lpat
+                         , psb_dir = dir
+                         , psb_args = details })
+  | isUnidirectional dir
+  = return emptyBag
+
+  | Left why <- mb_match_group       -- Can't invert the pattern
+  = setSrcSpan (getLoc lpat) $ failWithTc $
+    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
+                 <+> quotes (ppr name) <> colon)
+              2 why
+         , text "RHS pattern:" <+> ppr lpat ]
+
+  | Right match_group <- mb_match_group  -- Bidirectional
+  = do { patsyn <- tcLookupPatSyn name
+       ; case patSynBuilder patsyn of {
+           Nothing -> return emptyBag ;
+             -- This case happens if we found a type error in the
+             -- pattern synonym, recovered, and put a placeholder
+             -- with patSynBuilder=Nothing in the environment
+
+           Just (builder_id, need_dummy_arg) ->  -- Normal case
+    do { -- Bidirectional, so patSynBuilder returns Just
+         let match_group' | need_dummy_arg = add_dummy_arg match_group
+                          | otherwise      = match_group
+
+             bind = FunBind { fun_ext = placeHolderNamesTc
+                            , fun_id      = cL loc (idName builder_id)
+                            , fun_matches = match_group'
+                            , fun_co_fn   = idHsWrapper
+                            , fun_tick    = [] }
+
+             sig = completeSigFromId (PatSynCtxt name) builder_id
+
+       ; traceTc "tcPatSynBuilderBind {" $
+         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
+       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
+       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
+       ; return builder_binds } } }
+
+  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
+  where
+    mb_match_group
+       = case dir of
+           ExplicitBidirectional explicit_mg -> Right explicit_mg
+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
+           Unidirectional -> panic "tcPatSynBuilderBind"
+
+    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
+    mk_mg body = mkMatchGroup Generated [builder_match]
+          where
+            builder_args  = [cL loc (VarPat noExt (cL loc n))
+                            | (dL->L loc n) <- args]
+            builder_match = mkMatch (mkPrefixFunRhs (cL loc name))
+                                    builder_args body
+                                    (noLoc (EmptyLocalBinds noExt))
+
+    args = case details of
+              PrefixCon args     -> args
+              InfixCon arg1 arg2 -> [arg1, arg2]
+              RecCon args        -> map recordPatSynPatVar args
+
+    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
+                  -> MatchGroup GhcRn (LHsExpr GhcRn)
+    add_dummy_arg mg@(MG { mg_alts =
+                           (dL->L l [dL->L loc
+                                           match@(Match { m_pats = pats })]) })
+      = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }
+    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
+                             pprMatches other_mg
+tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"
+
+tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
+-- monadic only for failure
+tcPatSynBuilderOcc ps
+  | Just (builder_id, add_void_arg) <- builder
+  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
+        builder_ty   = idType builder_id
+  = return $
+    if add_void_arg
+    then ( builder_expr   -- still just return builder_expr; the void# arg is added
+                          -- by dsConLike in the desugarer
+         , tcFunResultTy builder_ty )
+    else (builder_expr, builder_ty)
+
+  | otherwise  -- Unidirectional
+  = nonBidirectionalErr name
+  where
+    name    = patSynName ps
+    builder = patSynBuilder ps
+
+add_void :: Bool -> Type -> Type
+add_void need_dummy_arg ty
+  | need_dummy_arg = mkVisFunTy voidPrimTy ty
+  | otherwise      = ty
+
+tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
+            -> Either MsgDoc (LHsExpr GhcRn)
+-- Given a /pattern/, return an /expression/ that builds a value
+-- that matches the pattern.  E.g. if the pattern is (Just [x]),
+-- the expression is (Just [x]).  They look the same, but the
+-- input uses constructors from HsPat and the output uses constructors
+-- from HsExpr.
+--
+-- Returns (Left r) if the pattern is not invertible, for reason r.
+-- See Note [Builder for a bidirectional pattern synonym]
+tcPatToExpr name args pat = go pat
+  where
+    lhsVars = mkNameSet (map unLoc args)
+
+    -- Make a prefix con for prefix and infix patterns for simplicity
+    mkPrefixConExpr :: Located Name -> [LPat GhcRn]
+                    -> Either MsgDoc (HsExpr GhcRn)
+    mkPrefixConExpr lcon@(dL->L loc _) pats
+      = do { exprs <- mapM go pats
+           ; return (foldl' (\x y -> HsApp noExt (cL loc x) y)
+                            (HsVar noExt lcon) exprs) }
+
+    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
+                    -> Either MsgDoc (HsExpr GhcRn)
+    mkRecordConExpr con fields
+      = do { exprFields <- mapM go fields
+           ; return (RecordCon noExt con exprFields) }
+
+    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
+    go (dL->L loc p) = cL loc <$> go1 p
+
+    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
+    go1 (ConPatIn con info)
+      = case info of
+          PrefixCon ps  -> mkPrefixConExpr con ps
+          InfixCon l r  -> mkPrefixConExpr con [l,r]
+          RecCon fields -> mkRecordConExpr con fields
+
+    go1 (SigPat _ pat _) = go1 (unLoc pat)
+        -- See Note [Type signatures and the builder expression]
+
+    go1 (VarPat _ (dL->L l var))
+        | var `elemNameSet` lhsVars
+        = return $ HsVar noExt (cL l var)
+        | otherwise
+        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
+    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat
+    go1 p@(ListPat reb pats)
+      | Nothing <- reb = do { exprs <- mapM go pats
+                            ; return $ ExplicitList noExt Nothing exprs }
+      | otherwise                   = notInvertibleListPat p
+    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
+                                         ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) exprs)
+                                                                           box }
+    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
+                                         ; return $ ExplicitSum noExt alt arity
+                                                                   (noLoc expr)
+                                         }
+    go1 (LitPat _ lit)              = return $ HsLit noExt lit
+    go1 (NPat _ (dL->L _ n) mb_neg _)
+        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg
+                                                     [noLoc (HsOverLit noExt n)]
+        | otherwise                 = return $ HsOverLit noExt n
+    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
+    go1 (CoPat{})                   = panic "CoPat in output of renamer"
+    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
+                                    = go1 pat
+    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
+    go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"
+
+    -- The following patterns are not invertible.
+    go1 p@(BangPat {})                       = notInvertible p -- #14112
+    go1 p@(LazyPat {})                       = notInvertible p
+    go1 p@(WildPat {})                       = notInvertible p
+    go1 p@(AsPat {})                         = notInvertible p
+    go1 p@(ViewPat {})                       = notInvertible p
+    go1 p@(NPlusKPat {})                     = notInvertible p
+    go1 p@(XPat {})                          = notInvertible p
+    go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
+    go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
+    go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
+    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p
+
+    notInvertible p = Left (not_invertible_msg p)
+
+    not_invertible_msg p
+      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
+                <+> text "pattern synonym, e.g.")
+             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
+                      <+> ppr pat <+> text "where")
+                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
+      where
+        pp_name = ppr name
+        pp_args = hsep (map ppr args)
+
+    -- We should really be able to invert list patterns, even when
+    -- rebindable syntax is on, but doing so involves a bit of
+    -- refactoring; see #14380.  Until then we reject with a
+    -- helpful error message.
+    notInvertibleListPat p
+      = Left (vcat [ not_invertible_msg p
+                   , text "Reason: rebindable syntax is on."
+                   , text "This is fixable: add use-case to #14380" ])
+
+{- Note [Builder for a bidirectional pattern synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a bidirectional pattern synonym we need to produce an /expression/
+that matches the supplied /pattern/, given values for the arguments
+of the pattern synonym.  For example
+  pattern F x y = (Just x, [y])
+The 'builder' for F looks like
+  $builderF x y = (Just x, [y])
+
+We can't always do this:
+ * Some patterns aren't invertible; e.g. view patterns
+      pattern F x = (reverse -> x:_)
+
+ * The RHS pattern might bind more variables than the pattern
+   synonym, so again we can't invert it
+      pattern F x = (x,y)
+
+ * Ditto wildcards
+      pattern F x = (x,_)
+
+
+Note [Redundant constraints for builder]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The builder can have redundant constraints, which are awkard to eliminate.
+Consider
+   pattern P = Just 34
+To match against this pattern we need (Eq a, Num a).  But to build
+(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
+sig_warn_redundant to False.
+
+************************************************************************
+*                                                                      *
+         Helper functions
+*                                                                      *
+************************************************************************
+
+Note [As-patterns in pattern synonym definitions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rationale for rejecting as-patterns in pattern synonym definitions
+is that an as-pattern would introduce nonindependent pattern synonym
+arguments, e.g. given a pattern synonym like:
+
+        pattern K x y = x@(Just y)
+
+one could write a nonsensical function like
+
+        f (K Nothing x) = ...
+
+or
+        g (K (Just True) False) = ...
+
+Note [Type signatures and the builder expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   pattern L x = Left x :: Either [a] [b]
+
+In tc{Infer/Check}PatSynDecl we will check that the pattern has the
+specified type.  We check the pattern *as a pattern*, so the type
+signature is a pattern signature, and so brings 'a' and 'b' into
+scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
+'x', say.  Nevertheless, the sigature may be useful to constrain
+the type.
+
+When making the binding for the *builder*, though, we don't want
+  $buildL x = Left x :: Either [a] [b]
+because that wil either mean (forall a b. Either [a] [b]), or we'll
+get a complaint that 'a' and 'b' are out of scope. (Actually the
+latter; #9867.)  No, the job of the signature is done, so when
+converting the pattern to an expression (for the builder RHS) we
+simply discard the signature.
+
+Note [Record PatSyn Desugaring]
+-------------------------------
+It is important that prov_theta comes before req_theta as this ordering is used
+when desugaring record pattern synonym updates.
+
+Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
+want to avoid difficult to decipher core lint errors!
+ -}
+
+
+nonBidirectionalErr :: Outputable name => name -> TcM a
+nonBidirectionalErr name = failWithTc $
+    text "non-bidirectional pattern synonym"
+    <+> quotes (ppr name) <+> text "used in an expression"
+
+-- Walk the whole pattern and for all ConPatOuts, collect the
+-- existentially-bound type variables and evidence binding variables.
+--
+-- These are used in computing the type of a pattern synonym and also
+-- in generating matcher functions, since success continuations need
+-- to be passed these pattern-bound evidences.
+tcCollectEx
+  :: LPat GhcTc
+  -> ( [TyVar]        -- Existentially-bound type variables
+                      -- in correctly-scoped order; e.g. [ k:*, x:k ]
+     , [EvVar] )      -- and evidence variables
+
+tcCollectEx pat = go pat
+  where
+    go :: LPat GhcTc -> ([TyVar], [EvVar])
+    go = go1 . unLoc
+
+    go1 :: Pat GhcTc -> ([TyVar], [EvVar])
+    go1 (LazyPat _ p)      = go p
+    go1 (AsPat _ _ p)      = go p
+    go1 (ParPat _ p)       = go p
+    go1 (BangPat _ p)      = go p
+    go1 (ListPat _ ps)     = mergeMany . map go $ ps
+    go1 (TuplePat _ ps _)  = mergeMany . map go $ ps
+    go1 (SumPat _ p _ _)   = go p
+    go1 (ViewPat _ _ p)    = go p
+    go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $
+                              goConDetails $ pat_args con
+    go1 (SigPat _ p _)     = go p
+    go1 (CoPat _ _ p _)    = go1 p
+    go1 (NPlusKPat _ n k _ geq subtract)
+      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
+    go1 _                   = empty
+
+    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
+    goConDetails (PrefixCon ps) = mergeMany . map go $ ps
+    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
+    goConDetails (RecCon HsRecFields{ rec_flds = flds })
+      = mergeMany . map goRecFd $ flds
+
+    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
+    goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p
+
+    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
+    mergeMany = foldr merge empty
+    empty     = ([], [])
diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPatSyn.hs-boot
@@ -0,0 +1,16 @@
+module TcPatSyn where
+
+import HsSyn     ( PatSynBind, LHsBinds )
+import TcRnTypes ( TcM, TcSigInfo )
+import TcRnMonad ( TcGblEnv)
+import Outputable ( Outputable )
+import HsExtension ( GhcRn, GhcTc )
+import Data.Maybe  ( Maybe )
+
+tcPatSynDecl :: PatSynBind GhcRn GhcRn
+             -> Maybe TcSigInfo
+             -> TcM (LHsBinds GhcTc, TcGblEnv)
+
+tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
+
+nonBidirectionalErr :: Outputable name => name -> TcM a
diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPluginM.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE CPP #-}
+-- | This module provides an interface for typechecker plugins to
+-- access select functions of the 'TcM', principally those to do with
+-- reading parts of the state.
+module TcPluginM (
+#if defined(GHCI)
+        -- * Basic TcPluginM functionality
+        TcPluginM,
+        tcPluginIO,
+        tcPluginTrace,
+        unsafeTcPluginTcM,
+
+        -- * Finding Modules and Names
+        FindResult(..),
+        findImportedModule,
+        lookupOrig,
+
+        -- * Looking up Names in the typechecking environment
+        tcLookupGlobal,
+        tcLookupTyCon,
+        tcLookupDataCon,
+        tcLookupClass,
+        tcLookup,
+        tcLookupId,
+
+        -- * Getting the TcM state
+        getTopEnv,
+        getEnvs,
+        getInstEnvs,
+        getFamInstEnvs,
+        matchFam,
+
+        -- * Type variables
+        newUnique,
+        newFlexiTyVar,
+        isTouchableTcPluginM,
+
+        -- * Zonking
+        zonkTcType,
+        zonkCt,
+
+        -- * Creating constraints
+        newWanted,
+        newDerived,
+        newGiven,
+        newCoercionHole,
+
+        -- * Manipulating evidence bindings
+        newEvVar,
+        setEvBind,
+        getEvBindsTcPluginM
+#endif
+    ) where
+
+#if defined(GHCI)
+import GhcPrelude
+
+import qualified TcRnMonad as TcM
+import qualified TcSMonad  as TcS
+import qualified TcEnv     as TcM
+import qualified TcMType   as TcM
+import qualified FamInst   as TcM
+import qualified IfaceEnv
+import qualified Finder
+
+import FamInstEnv ( FamInstEnv )
+import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
+                  , unsafeTcPluginTcM, getEvBindsTcPluginM
+                  , liftIO, traceTc )
+import TcMType    ( TcTyVar, TcType )
+import TcEnv      ( TcTyThing )
+import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
+                  , EvExpr, EvBind, mkGivenEvBind )
+import TcRnTypes  ( CtEvidence(..) )
+import Var        ( EvVar )
+
+import Module
+import Name
+import TyCon
+import DataCon
+import Class
+import HscTypes
+import Outputable
+import Type
+import Id
+import InstEnv
+import FastString
+import Unique
+
+
+-- | Perform some IO, typically to interact with an external tool.
+tcPluginIO :: IO a -> TcPluginM a
+tcPluginIO a = unsafeTcPluginTcM (liftIO a)
+
+-- | Output useful for debugging the compiler.
+tcPluginTrace :: String -> SDoc -> TcPluginM ()
+tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
+
+
+findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
+findImportedModule mod_name mb_pkg = do
+    hsc_env <- getTopEnv
+    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
+
+lookupOrig :: Module -> OccName -> TcPluginM Name
+lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
+
+
+tcLookupGlobal :: Name -> TcPluginM TyThing
+tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
+
+tcLookupTyCon :: Name -> TcPluginM TyCon
+tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
+
+tcLookupDataCon :: Name -> TcPluginM DataCon
+tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
+
+tcLookupClass :: Name -> TcPluginM Class
+tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
+
+tcLookup :: Name -> TcPluginM TcTyThing
+tcLookup = unsafeTcPluginTcM . TcM.tcLookup
+
+tcLookupId :: Name -> TcPluginM Id
+tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
+
+
+getTopEnv :: TcPluginM HscEnv
+getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
+
+getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
+getEnvs = unsafeTcPluginTcM TcM.getEnvs
+
+getInstEnvs :: TcPluginM InstEnvs
+getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
+
+getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
+
+matchFam :: TyCon -> [Type]
+         -> TcPluginM (Maybe (TcCoercion, TcType))
+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
+
+newUnique :: TcPluginM Unique
+newUnique = unsafeTcPluginTcM TcM.newUnique
+
+newFlexiTyVar :: Kind -> TcPluginM TcTyVar
+newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
+
+isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
+isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
+
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+zonkTcType :: TcType -> TcPluginM TcType
+zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
+
+zonkCt :: Ct -> TcPluginM Ct
+zonkCt = unsafeTcPluginTcM . TcM.zonkCt
+
+
+-- | Create a new wanted constraint.
+newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence
+newWanted loc pty
+  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)
+
+-- | Create a new derived constraint.
+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
+newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
+
+-- | Create a new given constraint, with the supplied evidence.  This
+-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
+-- will panic.
+newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
+newGiven loc pty evtm = do
+   new_ev <- newEvVar pty
+   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
+   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
+
+-- | Create a fresh evidence variable.
+newEvVar :: PredType -> TcPluginM EvVar
+newEvVar = unsafeTcPluginTcM . TcM.newEvVar
+
+-- | Create a fresh coercion hole.
+newCoercionHole :: PredType -> TcPluginM CoercionHole
+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
+
+-- | Bind an evidence variable.  This must not be invoked from
+-- 'tcPluginInit' or 'tcPluginStop', or it will panic.
+setEvBind :: EvBind -> TcPluginM ()
+setEvBind ev_bind = do
+    tc_evbinds <- getEvBindsTcPluginM
+    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
+#else
+-- this dummy import is needed as a consequence of NoImplicitPrelude
+import GhcPrelude ()
+#endif
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -0,0 +1,2916 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcRnDriver]{Typechecking a whole module}
+
+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcRnDriver (
+        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
+        tcRnImportDecls,
+        tcRnLookupRdrName,
+        getModuleInterface,
+        tcRnDeclsi,
+        isGHCiMonad,
+        runTcInteractive,    -- Used by GHC API clients (#8878)
+        tcRnLookupName,
+        tcRnGetInfo,
+        tcRnModule, tcRnModuleTcRnM,
+        tcTopSrcDecls,
+        rnTopSrcDecls,
+        checkBootDecl, checkHiBootIface',
+        findExtraSigImports,
+        implicitRequirements,
+        checkUnitId,
+        mergeSignatures,
+        tcRnMergeSignatures,
+        instantiateSignature,
+        tcRnInstantiateSignature,
+        loadUnqualIfaces,
+        -- More private...
+        badReexportedBootThing,
+        checkBootDeclM,
+        missingBootThing,
+        getRenamedStuff, RenamedStuff
+    ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )
+import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
+import IfaceEnv( externaliseName )
+import TcHsType
+import TcValidity( checkValidType )
+import TcMatches
+import Inst( deeplyInstantiate )
+import TcUnify( checkConstraints )
+import RnTypes
+import RnExpr
+import RnUtils ( HsDocContext(..) )
+import RnFixity ( lookupFixityRn )
+import MkId
+import TidyPgm    ( globaliseAndTidyId )
+import TysWiredIn ( unitTy, mkListTy )
+import Plugins
+import DynFlags
+import HsSyn
+import IfaceSyn ( ShowSub(..), showToHeader )
+import IfaceType( ShowForAllFlag(..) )
+import PatSyn( pprPatSynType )
+import PrelNames
+import PrelInfo
+import RdrName
+import TcHsSyn
+import TcExpr
+import TcRnMonad
+import TcRnExports
+import TcEvidence
+import qualified BooleanFormula as BF
+import PprTyThing( pprTyThingInContext )
+import CoreFVs( orphNamesOfFamInst )
+import FamInst
+import InstEnv
+import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
+                 , famInstEnvElts, extendFamInstEnvList, normaliseType )
+import TcAnnotations
+import TcBinds
+import MkIface          ( coAxiomToIfaceDecl )
+import HeaderInfo       ( mkPrelImports )
+import TcDefaults
+import TcEnv
+import TcRules
+import TcForeign
+import TcInstDcls
+import TcIface
+import TcMType
+import TcType
+import TcSimplify
+import TcTyClsDecls
+import TcTypeable ( mkTypeableBinds )
+import TcBackpack
+import LoadIface
+import RnNames
+import RnEnv
+import RnSource
+import ErrUtils
+import Id
+import IdInfo( IdDetails(..) )
+import VarEnv
+import Module
+import UniqFM
+import Name
+import NameEnv
+import NameSet
+import Avail
+import TyCon
+import SrcLoc
+import HscTypes
+import ListSetOps
+import Outputable
+import ConLike
+import DataCon
+import Type
+import Class
+import BasicTypes hiding( SuccessFlag(..) )
+import CoAxiom
+import Annotations
+import Data.List ( sortBy, sort )
+import Data.Ord
+import FastString
+import Maybes
+import Util
+import Bag
+import Inst (tcGetInsts)
+import qualified GHC.LanguageExtensions as LangExt
+import Data.Data ( Data )
+import HsDumpAst
+import qualified Data.Set as S
+
+import Control.DeepSeq
+import Control.Monad
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+        Typecheck and rename a module
+*                                                                      *
+************************************************************************
+-}
+
+-- | Top level entry point for typechecker and renamer
+tcRnModule :: HscEnv
+           -> ModSummary
+           -> Bool              -- True <=> save renamed syntax
+           -> HsParsedModule
+           -> IO (Messages, Maybe TcGblEnv)
+
+tcRnModule hsc_env mod_sum save_rn_syntax
+   parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}
+ | RealSrcSpan real_loc <- loc
+ = withTiming (pure dflags)
+              (text "Renamer/typechecker"<+>brackets (ppr this_mod))
+              (const ()) $
+   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
+          withTcPlugins hsc_env $
+
+          tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
+
+  | otherwise
+  = return ((emptyBag, unitBag err_msg), Nothing)
+
+  where
+    hsc_src = ms_hsc_src mod_sum
+    dflags = hsc_dflags hsc_env
+    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
+              text "Module does not have a RealSrcSpan:" <+> ppr this_mod
+
+    this_pkg = thisPackage (hsc_dflags hsc_env)
+
+    pair :: (Module, SrcSpan)
+    pair@(this_mod,_)
+      | Just (dL->L mod_loc mod) <- hsmodName this_module
+      = (mkModule this_pkg mod, mod_loc)
+
+      | otherwise   -- 'module M where' is omitted
+      = (mAIN, srcLocSpan (srcSpanStart loc))
+
+
+
+
+tcRnModuleTcRnM :: HscEnv
+                -> ModSummary
+                -> HsParsedModule
+                -> (Module, SrcSpan)
+                -> TcRn TcGblEnv
+-- Factored out separately from tcRnModule so that a Core plugin can
+-- call the type checker directly
+tcRnModuleTcRnM hsc_env mod_sum
+                (HsParsedModule {
+                   hpm_module =
+                      (dL->L loc (HsModule maybe_mod export_ies
+                                       import_decls local_decls mod_deprec
+                                       maybe_doc_hdr)),
+                   hpm_src_files = src_files
+                })
+                (this_mod, prel_imp_loc)
+ = setSrcSpan loc $
+   do { let { explicit_mod_hdr = isJust maybe_mod
+            ; hsc_src          = ms_hsc_src mod_sum }
+      ; -- Load the hi-boot interface for this module, if any
+        -- We do this now so that the boot_names can be passed
+        -- to tcTyAndClassDecls, because the boot_names are
+        -- automatically considered to be loop breakers
+        tcg_env <- getGblEnv
+      ; boot_info <- tcHiBootIface hsc_src this_mod
+      ; setGblEnv (tcg_env { tcg_self_boot = boot_info })
+        $ do
+        { -- Deal with imports; first add implicit prelude
+          implicit_prelude <- xoptM LangExt.ImplicitPrelude
+        ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
+                               implicit_prelude import_decls }
+
+        ; whenWOptM Opt_WarnImplicitPrelude $
+             when (notNull prel_imports) $
+                addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)
+
+        ; -- TODO This is a little skeevy; maybe handle a bit more directly
+          let { simplifyImport (dL->L _ idecl) =
+                  ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl)
+              }
+        ; raw_sig_imports <- liftIO
+                             $ findExtraSigImports hsc_env hsc_src
+                                 (moduleName this_mod)
+        ; raw_req_imports <- liftIO
+                             $ implicitRequirements hsc_env
+                                (map simplifyImport (prel_imports
+                                                     ++ import_decls))
+        ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc
+                $ (simpleImportDecl mod_name)
+                  { ideclHiding = Just (False, noLoc [])}
+              ; mkImport _ = panic "mkImport" }
+        ; let { all_imports = prel_imports ++ import_decls
+                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) }
+        ; -- OK now finally rename the imports
+          tcg_env <- {-# SCC "tcRnImports" #-}
+                     tcRnImports hsc_env all_imports
+
+        ; -- If the whole module is warned about or deprecated
+          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
+          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
+          let { tcg_env1 = case mod_deprec of
+                             Just (dL->L _ txt) ->
+                               tcg_env {tcg_warns = WarnAll txt}
+                             Nothing            -> tcg_env
+              }
+        ; setGblEnv tcg_env1
+          $ do { -- Rename and type check the declarations
+                 traceRn "rn1a" empty
+               ; tcg_env <- if isHsBootOrSig hsc_src
+                            then tcRnHsBootDecls hsc_src local_decls
+                            else {-# SCC "tcRnSrcDecls" #-}
+                                 tcRnSrcDecls explicit_mod_hdr local_decls
+               ; setGblEnv tcg_env
+                 $ do { -- Process the export list
+                        traceRn "rn4a: before exports" empty
+                      ; tcg_env <- tcRnExports explicit_mod_hdr export_ies
+                                     tcg_env
+                      ; traceRn "rn4b: after exports" empty
+                      ; -- Check main is exported(must be after tcRnExports)
+                        checkMainExported tcg_env
+                      ; -- Compare hi-boot iface (if any) with the real thing
+                        -- Must be done after processing the exports
+                        tcg_env <- checkHiBootIface tcg_env boot_info
+                      ; -- The new type env is already available to stuff
+                        -- slurped from interface files, via
+                        -- TcEnv.setGlobalTypeEnv. It's important that this
+                        -- includes the stuff in checkHiBootIface,
+                        -- because the latter might add new bindings for
+                        -- boot_dfuns, which may be mentioned in imported
+                        -- unfoldings.
+
+                        -- Don't need to rename the Haddock documentation,
+                        -- it's not parsed by GHC anymore.
+                        tcg_env <- return (tcg_env
+                                           { tcg_doc_hdr = maybe_doc_hdr })
+                      ; -- Report unused names
+                        -- Do this /after/ typeinference, so that when reporting
+                        -- a function with no type signature we can give the
+                        -- inferred type
+                        reportUnusedNames export_ies tcg_env
+                      ; -- add extra source files to tcg_dependent_files
+                        addDependentFiles src_files
+                      ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env
+                      ; -- Dump output and return
+                        tcDump tcg_env
+                      ; return tcg_env }
+               }
+        }
+      }
+
+implicitPreludeWarn :: SDoc
+implicitPreludeWarn
+  = text "Module `Prelude' implicitly imported"
+
+{-
+************************************************************************
+*                                                                      *
+                Import declarations
+*                                                                      *
+************************************************************************
+-}
+
+tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
+tcRnImports hsc_env import_decls
+  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
+
+        ; this_mod <- getModule
+        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
+              ; dep_mods = imp_dep_mods imports
+
+                -- We want instance declarations from all home-package
+                -- modules below this one, including boot modules, except
+                -- ourselves.  The 'except ourselves' is so that we don't
+                -- get the instances from this module's hs-boot file.  This
+                -- filtering also ensures that we don't see instances from
+                -- modules batch (@--make@) compiled before this one, but
+                -- which are not below this one.
+              ; want_instances :: ModuleName -> Bool
+              ; want_instances mod = mod `elemUFM` dep_mods
+                                   && mod /= moduleName this_mod
+              ; (home_insts, home_fam_insts) = hptInstances hsc_env
+                                                            want_instances
+              } ;
+
+                -- Record boot-file info in the EPS, so that it's
+                -- visible to loadHiBootInterface in tcRnSrcDecls,
+                -- and any other incrementally-performed imports
+        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
+
+                -- Update the gbl env
+        ; updGblEnv ( \ gbl ->
+            gbl {
+              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
+              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
+              tcg_rn_imports   = rn_imports,
+              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
+              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
+                                                      home_fam_insts,
+              tcg_hpc          = hpc_info
+            }) $ do {
+
+        ; traceRn "rn1" (ppr (imp_dep_mods imports))
+                -- Fail if there are any errors so far
+                -- The error printing (if needed) takes advantage
+                -- of the tcg_env we have now set
+--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
+        ; failIfErrsM
+
+                -- Load any orphan-module (including orphan family
+                -- instance-module) interfaces, so that their rules and
+                -- instance decls will be found.  But filter out a
+                -- self hs-boot: these instances will be checked when
+                -- we define them locally.
+                -- (We don't need to load non-orphan family instance
+                -- modules until we either try to use the instances they
+                -- define, or define our own family instances, at which
+                -- point we need to check them for consistency.)
+        ; loadModuleInterfaces (text "Loading orphan modules")
+                               (filter (/= this_mod) (imp_orphs imports))
+
+                -- Check type-family consistency between imports.
+                -- See Note [The type family instance consistency story]
+        ; traceRn "rn1: checking family instance consistency {" empty
+        ; let { dir_imp_mods = moduleEnvKeys
+                             . imp_mods
+                             $ imports }
+        ; checkFamInstConsistency dir_imp_mods
+        ; traceRn "rn1: } checking family instance consistency" empty
+
+        ; getGblEnv } }
+
+{-
+************************************************************************
+*                                                                      *
+        Type-checking the top level of a module
+*                                                                      *
+************************************************************************
+-}
+
+tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
+             -> [LHsDecl GhcPs]               -- Declarations
+             -> TcM TcGblEnv
+tcRnSrcDecls explicit_mod_hdr decls
+ = do { -- Do all the declarations
+      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
+
+        -- Check for the 'main' declaration
+        -- Must do this inside the captureTopConstraints
+        -- NB: always set envs *before* captureTopConstraints
+      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
+                               captureTopConstraints $
+                               checkMain explicit_mod_hdr
+
+      ; setEnvs (tcg_env, tcl_env) $ do {
+
+             --         Simplify constraints
+             --
+             -- We do this after checkMain, so that we use the type info
+             -- that checkMain adds
+             --
+             -- We do it with both global and local env in scope:
+             --  * the global env exposes the instances to simplifyTop
+             --  * the local env exposes the local Ids to simplifyTop,
+             --    so that we get better error messages (monomorphism restriction)
+      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
+                        simplifyTop (lie `andWC` lie_main)
+
+        -- Emit Typeable bindings
+      ; tcg_env <- mkTypeableBinds
+
+
+      ; traceTc "Tc9" empty
+
+      ; failIfErrsM     -- Don't zonk if there have been errors
+                        -- It's a waste of time; and we may get debug warnings
+                        -- about strangely-typed TyCons!
+      ; traceTc "Tc10" empty
+
+        -- Zonk the final code.  This must be done last.
+        -- Even simplifyTop may do some unification.
+        -- This pass also warns about missing type signatures
+      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')
+            <- zonkTcGblEnv new_ev_binds tcg_env
+
+        -- Finalizers must run after constraints are simplified, or some types
+        -- might not be complete when using reify (see #12777).
+        -- and also after we zonk the first time because we run typed splices
+        -- in the zonker which gives rise to the finalisers.
+      ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)
+                                     run_th_modfinalizers
+      ; finishTH
+      ; traceTc "Tc11" empty
+
+      ; -- zonk the new bindings arising from running the finalisers.
+        -- This won't give rise to any more finalisers as you can't nest
+        -- finalisers inside finalisers.
+      ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
+            <- zonkTcGblEnv emptyBag tcg_env_mf
+
+
+      ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)
+                                (plusTypeEnv bind_env_mf bind_env)
+            ; tcg_env' = tcg_env_mf
+                          { tcg_binds    = binds' `unionBags` binds_mf,
+                            tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,
+                            tcg_imp_specs = imp_specs' ++ imp_specs_mf ,
+                            tcg_rules    = rules' ++ rules_mf ,
+                            tcg_fords    = fords' ++ fords_mf } } ;
+
+      ; setGlobalTypeEnv tcg_env' final_type_env
+
+   } }
+
+zonkTcGblEnv :: Bag EvBind -> TcGblEnv
+             -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
+                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
+zonkTcGblEnv new_ev_binds tcg_env =
+  let TcGblEnv {   tcg_binds     = binds,
+                   tcg_ev_binds  = cur_ev_binds,
+                   tcg_imp_specs = imp_specs,
+                   tcg_rules     = rules,
+                   tcg_fords     = fords } = tcg_env
+
+      all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
+
+  in {-# SCC "zonkTopDecls" #-}
+      zonkTopDecls all_ev_binds binds rules imp_specs fords
+
+
+-- | Remove accumulated bindings, rules and so on from TcGblEnv
+clearTcGblEnv :: TcGblEnv -> TcGblEnv
+clearTcGblEnv tcg_env
+  = tcg_env { tcg_binds    = emptyBag,
+              tcg_ev_binds = emptyBag ,
+              tcg_imp_specs = [],
+              tcg_rules    = [],
+              tcg_fords    = [] }
+
+-- | Runs TH finalizers and renames and typechecks the top-level declarations
+-- that they could introduce.
+run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
+run_th_modfinalizers = do
+  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+  th_modfinalizers <- readTcRef th_modfinalizers_var
+  if null th_modfinalizers
+  then getEnvs
+  else do
+    writeTcRef th_modfinalizers_var []
+    let run_finalizer (lcl_env, f) =
+            setLclEnv lcl_env (runRemoteModFinalizers f)
+
+    (_, lie_th) <- captureTopConstraints $
+                   mapM_ run_finalizer th_modfinalizers
+
+      -- Finalizers can add top-level declarations with addTopDecls, so
+      -- we have to run tc_rn_src_decls to get them
+    (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
+
+    setEnvs (tcg_env, tcl_env) $ do
+      -- Subsequent rounds of finalizers run after any new constraints are
+      -- simplified, or some types might not be complete when using reify
+      -- (see #12777).
+      new_ev_binds <- {-# SCC "simplifyTop2" #-}
+                      simplifyTop (lie_th `andWC` lie_top_decls)
+      addTopEvBinds new_ev_binds run_th_modfinalizers
+        -- addTopDecls can add declarations which add new finalizers.
+
+tc_rn_src_decls :: [LHsDecl GhcPs]
+                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
+-- Loops around dealing with each top level inter-splice group
+-- in turn, until it's dealt with the entire module
+-- Never emits constraints; calls captureTopConstraints internally
+tc_rn_src_decls ds
+ = {-# SCC "tc_rn_src_decls" #-}
+   do { (first_group, group_tail) <- findSplice ds
+                -- If ds is [] we get ([], Nothing)
+
+        -- Deal with decls up to, but not including, the first splice
+      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
+                -- rnTopSrcDecls fails if there are any errors
+
+        -- Get TH-generated top-level declarations and make sure they don't
+        -- contain any splices since we don't handle that at the moment
+        --
+        -- The plumbing here is a bit odd: see #10853
+      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
+      ; th_ds <- readTcRef th_topdecls_var
+      ; writeTcRef th_topdecls_var []
+
+      ; (tcg_env, rn_decls) <-
+            if null th_ds
+            then return (tcg_env, rn_decls)
+            else do { (th_group, th_group_tail) <- findSplice th_ds
+                    ; case th_group_tail of
+                        { Nothing -> return ()
+                        ; Just (SpliceDecl _ (dL->L loc _) _, _) ->
+                            setSrcSpan loc
+                            $ addErr (text
+                                ("Declaration splices are not "
+                                  ++ "permitted inside top-level "
+                                  ++ "declarations added with addTopDecls"))
+                        ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"
+                        }
+                      -- Rename TH-generated top-level declarations
+                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
+                        $ rnTopSrcDecls th_group
+
+                      -- Dump generated top-level declarations
+                    ; let msg = "top-level declarations added with addTopDecls"
+                    ; traceSplice
+                        $ SpliceInfo { spliceDescription = msg
+                                     , spliceIsDecl    = True
+                                     , spliceSource    = Nothing
+                                     , spliceGenerated = ppr th_rn_decls }
+                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
+                    }
+
+      -- Type check all declarations
+      -- NB: set the env **before** captureTopConstraints so that error messages
+      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
+      -- the captureTopConstraints must go here, not in tcRnSrcDecls.
+      ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
+                                      captureTopConstraints $
+                                      tcTopSrcDecls rn_decls
+
+        -- If there is no splice, we're nearly done
+      ; setEnvs (tcg_env, tcl_env) $
+        case group_tail of
+          { Nothing -> return (tcg_env, tcl_env, lie1)
+
+            -- If there's a splice, we must carry on
+          ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) ->
+            do { recordTopLevelSpliceLoc loc
+
+                 -- Rename the splice expression, and get its supporting decls
+               ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
+
+                 -- Glue them on the front of the remaining decls and loop
+               ; (tcg_env, tcl_env, lie2) <-
+                   setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+                   tc_rn_src_decls (spliced_decls ++ rest_ds)
+
+               ; return (tcg_env, tcl_env, lie1 `andWC` lie2)
+               }
+          ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"
+          }
+      }
+
+{-
+************************************************************************
+*                                                                      *
+        Compiling hs-boot source files, and
+        comparing the hi-boot interface with the real thing
+*                                                                      *
+************************************************************************
+-}
+
+tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
+tcRnHsBootDecls hsc_src decls
+   = do { (first_group, group_tail) <- findSplice decls
+
+                -- Rename the declarations
+        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
+                            , hs_derivds = deriv_decls
+                            , hs_fords  = for_decls
+                            , hs_defds  = def_decls
+                            , hs_ruleds = rule_decls
+                            , hs_annds  = _
+                            , hs_valds  = XValBindsLR (NValBinds val_binds val_sigs) })
+              <- rnTopSrcDecls first_group
+
+        -- The empty list is for extra dependencies coming from .hs-boot files
+        -- See Note [Extra dependencies from .hs-boot files] in RnSource
+
+        ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
+              -- NB: setGblEnv **before** captureTopConstraints so that
+              -- if the latter reports errors, it knows what's in scope
+
+                -- Check for illegal declarations
+        ; case group_tail of
+             Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
+             Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls"
+             Nothing                  -> return ()
+        ; mapM_ (badBootDecl hsc_src "foreign") for_decls
+        ; mapM_ (badBootDecl hsc_src "default") def_decls
+        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
+
+                -- Typecheck type/class/instance decls
+        ; traceTc "Tc2 (boot)" empty
+        ; (tcg_env, inst_infos, _deriv_binds)
+             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
+        ; setGblEnv tcg_env     $ do {
+
+        -- Emit Typeable bindings
+        ; tcg_env <- mkTypeableBinds
+        ; setGblEnv tcg_env $ do {
+
+                -- Typecheck value declarations
+        ; traceTc "Tc5" empty
+        ; val_ids <- tcHsBootSigs val_binds val_sigs
+
+                -- Wrap up
+                -- No simplification or zonking to do
+        ; traceTc "Tc7a" empty
+        ; gbl_env <- getGblEnv
+
+                -- Make the final type-env
+                -- Include the dfun_ids so that their type sigs
+                -- are written into the interface file.
+        ; let { type_env0 = tcg_type_env gbl_env
+              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
+              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
+              ; dfun_ids = map iDFunId inst_infos
+              }
+
+        ; setGlobalTypeEnv gbl_env type_env2
+   }}}
+   ; traceTc "boot" (ppr lie); return gbl_env }
+
+badBootDecl :: HscSource -> String -> Located decl -> TcM ()
+badBootDecl hsc_src what (dL->L loc _)
+  = addErrAt loc (char 'A' <+> text what
+      <+> text "declaration is not (currently) allowed in a"
+      <+> (case hsc_src of
+            HsBootFile -> text "hs-boot"
+            HsigFile -> text "hsig"
+            _ -> panic "badBootDecl: should be an hsig or hs-boot file")
+      <+> text "file")
+
+{-
+Once we've typechecked the body of the module, we want to compare what
+we've found (gathered in a TypeEnv) with the hi-boot details (if any).
+-}
+
+checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
+-- Compare the hi-boot file for this module (if there is one)
+-- with the type environment we've just come up with
+-- In the common case where there is no hi-boot file, the list
+-- of boot_names is empty.
+
+checkHiBootIface tcg_env boot_info
+  | NoSelfBoot <- boot_info  -- Common case
+  = return tcg_env
+
+  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!
+  = return tcg_env
+
+  | SelfBoot { sb_mds = boot_details } <- boot_info
+  , TcGblEnv { tcg_binds    = binds
+             , tcg_insts    = local_insts
+             , tcg_type_env = local_type_env
+             , tcg_exports  = local_exports } <- tcg_env
+  = do  { -- This code is tricky, see Note [DFun knot-tying]
+        ; dfun_prs <- checkHiBootIface' local_insts local_type_env
+                                        local_exports boot_details
+
+        -- Now add the boot-dfun bindings  $fxblah = $fblah
+        -- to (a) the type envt, and (b) the top-level bindings
+        ; let boot_dfuns = map fst dfun_prs
+              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
+              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+                                     | (boot_dfun, dfun) <- dfun_prs ]
+              tcg_env_w_binds
+                = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
+
+        ; type_env' `seq`
+             -- Why the seq?  Without, we will put a TypeEnv thunk in
+             -- tcg_type_env_var.  That thunk will eventually get
+             -- forced if we are typechecking interfaces, but that
+             -- is no good if we are trying to typecheck the very
+             -- DFun we were going to put in.
+             -- TODO: Maybe setGlobalTypeEnv should be strict.
+          setGlobalTypeEnv tcg_env_w_binds type_env' }
+
+  | otherwise = panic "checkHiBootIface: unreachable code"
+
+{- Note [DFun impedance matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We return a list of "impedance-matching" bindings for the dfuns
+defined in the hs-boot file, such as
+          $fxEqT = $fEqT
+We need these because the module and hi-boot file might differ in
+the name it chose for the dfun: the name of a dfun is not
+uniquely determined by its type; there might be multiple dfuns
+which, individually, would map to the same name (in which case
+we have to disambiguate them.)  There's no way for the hi file
+to know exactly what disambiguation to use... without looking
+at the hi-boot file itself.
+
+In fact, the names will always differ because we always pick names
+prefixed with "$fx" for boot dfuns, and "$f" for real dfuns
+(so that this impedance matching is always possible).
+
+Note [DFun knot-tying]
+~~~~~~~~~~~~~~~~~~~~~~
+The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from
+typechecking the hi-boot file that we are presently implementing.
+Suppose we are typechecking the module A: when we typecheck the
+hi-boot file, whenever we see an identifier A.T, we knot-tie this
+identifier to the *local* type environment (via if_rec_types.)  The
+contract then is that we don't *look* at 'SelfBootInfo' until we've
+finished typechecking the module and updated the type environment with
+the new tycons and ids.
+
+This most works well, but there is one problem: DFuns!  We do not want
+to look at the mb_insts of the ModDetails in SelfBootInfo, because a
+dfun in one of those ClsInsts is gotten (in TcIface.tcIfaceInst) by a
+(lazily evaluated) lookup in the if_rec_types.  We could extend the
+type env, do a setGloblaTypeEnv etc; but that all seems very indirect.
+It is much more directly simply to extract the DFunIds from the
+md_types of the SelfBootInfo.
+
+See #4003, #16038 for why we need to take care here.
+-}
+
+checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
+                  -> ModDetails -> TcM [(Id, Id)]
+-- Variant which doesn't require a full TcGblEnv; you could get the
+-- local components from another ModDetails.
+checkHiBootIface'
+        local_insts local_type_env local_exports
+        (ModDetails { md_types = boot_type_env
+                    , md_fam_insts = boot_fam_insts
+                    , md_exports = boot_exports })
+  = do  { traceTc "checkHiBootIface" $ vcat
+             [ ppr boot_type_env, ppr boot_exports]
+
+                -- Check the exports of the boot module, one by one
+        ; mapM_ check_export boot_exports
+
+                -- Check for no family instances
+        ; unless (null boot_fam_insts) $
+            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
+                   "instances in boot files yet...")
+            -- FIXME: Why?  The actual comparison is not hard, but what would
+            --        be the equivalent to the dfun bindings returned for class
+            --        instances?  We can't easily equate tycons...
+
+                -- Check instance declarations
+                -- and generate an impedance-matching binding
+        ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns
+
+        ; failIfErrsM
+
+        ; return (catMaybes mb_dfun_prs) }
+
+  where
+    boot_dfun_names = map idName boot_dfuns
+    boot_dfuns      = filter isDFunId $ typeEnvIds boot_type_env
+       -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts
+       --     We don't want to look at md_insts!
+       --     Why not?  See Note [DFun knot-tying]
+
+    check_export boot_avail     -- boot_avail is exported by the boot iface
+      | name `elem` boot_dfun_names = return ()
+      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,
+                                                -- 'error' is handled by a rather gross hack
+                                                -- (see comments in GHC.Err.hs-boot)
+
+        -- Check that the actual module exports the same thing
+      | not (null missing_names)
+      = addErrAt (nameSrcSpan (head missing_names))
+                 (missingBootThing True (head missing_names) "exported by")
+
+        -- If the boot module does not *define* the thing, we are done
+        -- (it simply re-exports it, and names match, so nothing further to do)
+      | isNothing mb_boot_thing = return ()
+
+        -- Check that the actual module also defines the thing, and
+        -- then compare the definitions
+      | Just real_thing <- lookupTypeEnv local_type_env name,
+        Just boot_thing <- mb_boot_thing
+      = checkBootDeclM True boot_thing real_thing
+
+      | otherwise
+      = addErrTc (missingBootThing True name "defined in")
+      where
+        name          = availName boot_avail
+        mb_boot_thing = lookupTypeEnv boot_type_env name
+        missing_names = case lookupNameEnv local_export_env name of
+                          Nothing    -> [name]
+                          Just avail -> availNames boot_avail `minusList` availNames avail
+
+    local_export_env :: NameEnv AvailInfo
+    local_export_env = availsToNameEnv local_exports
+
+    check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
+        -- Returns a pair of the boot dfun in terms of the equivalent
+        -- real dfun. Delicate (like checkBootDecl) because it depends
+        -- on the types lining up precisely even to the ordering of
+        -- the type variables in the foralls.
+    check_cls_inst boot_dfun
+      | (real_dfun : _) <- find_real_dfun boot_dfun
+      , let local_boot_dfun = Id.mkExportedVanillaId
+                                  (idName boot_dfun) (idType real_dfun)
+      = return (Just (local_boot_dfun, real_dfun))
+          -- Two tricky points here:
+          --
+          --  * The local_boot_fun should have a Name from the /boot-file/,
+          --    but type from the dfun defined in /this module/.
+          --    That ensures that the TyCon etc inside the type are
+          --    the ones defined in this module, not the ones gotten
+          --    from the hi-boot file, which may have a lot less info
+          --    (#8743, comment:10).
+          --
+          --  * The DFunIds from boot_details are /GlobalIds/, because
+          --    they come from typechecking M.hi-boot.
+          --    But all bindings in this module should be for /LocalIds/,
+          --    otherwise dependency analysis fails (#16038). This
+          --    is another reason for using mkExportedVanillaId, rather
+          --    that modifying boot_dfun, to make local_boot_fun.
+
+      | otherwise
+      = setSrcSpan (getLoc (getName boot_dfun)) $
+        do { traceTc "check_cls_inst" $ vcat
+                [ text "local_insts"  <+>
+                     vcat (map (ppr . idType . instanceDFunId) local_insts)
+                , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ]
+
+           ; addErrTc (instMisMatch boot_dfun)
+           ; return Nothing }
+
+    find_real_dfun :: DFunId -> [DFunId]
+    find_real_dfun boot_dfun
+       = [dfun | inst <- local_insts
+               , let dfun = instanceDFunId inst
+               , idType dfun `eqType` boot_dfun_ty ]
+       where
+          boot_dfun_ty   = idType boot_dfun
+
+
+-- In general, to perform these checks we have to
+-- compare the TyThing from the .hi-boot file to the TyThing
+-- in the current source file.  We must be careful to allow alpha-renaming
+-- where appropriate, and also the boot declaration is allowed to omit
+-- constructors and class methods.
+--
+-- See rnfail055 for a good test of this stuff.
+
+-- | Compares two things for equivalence between boot-file and normal code,
+-- reporting an error if they don't match up.
+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
+               -> TyThing -> TyThing -> TcM ()
+checkBootDeclM is_boot boot_thing real_thing
+  = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->
+       addErrAt span
+                (bootMisMatch is_boot err real_thing boot_thing)
+  where
+    -- Here we use the span of the boot thing or, if it doesn't have a sensible
+    -- span, that of the real thing,
+    span
+      | let span = nameSrcSpan (getName boot_thing)
+      , isGoodSrcSpan span
+      = span
+      | otherwise
+      = nameSrcSpan (getName real_thing)
+
+-- | Compares the two things for equivalence between boot-file and normal
+-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
+-- failure. If the difference will be apparent to the user, @Just empty@ is
+-- perfectly suitable.
+checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
+
+checkBootDecl _ (AnId id1) (AnId id2)
+  = ASSERT(id1 == id2)
+    check (idType id1 `eqType` idType id2)
+          (text "The two types are different")
+
+checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)
+  = checkBootTyCon is_boot tc1 tc2
+
+checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
+  = pprPanic "checkBootDecl" (ppr dc1)
+
+checkBootDecl _ _ _ = Just empty -- probably shouldn't happen
+
+-- | Combines two potential error messages
+andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
+Nothing `andThenCheck` msg     = msg
+msg     `andThenCheck` Nothing = msg
+Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
+infixr 0 `andThenCheck`
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, return the provided check
+checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
+checkUnless True  _ = Nothing
+checkUnless False k = k
+
+-- | Run the check provided for every pair of elements in the lists.
+-- The provided SDoc should name the element type, in the plural.
+checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
+            -> Maybe SDoc
+checkListBy check_fun as bs whats = go [] as bs
+  where
+    herald = text "The" <+> whats <+> text "do not match"
+
+    go []   [] [] = Nothing
+    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
+    go docs (x:xs) (y:ys) = case check_fun x y of
+      Just doc -> go (doc:docs) xs ys
+      Nothing  -> go docs       xs ys
+    go _    _  _ = Just (hang (herald <> colon)
+                            2 (text "There are different numbers of" <+> whats))
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, fail with the given SDoc.
+check :: Bool -> SDoc -> Maybe SDoc
+check True  _   = Nothing
+check False doc = Just doc
+
+-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
+checkSuccess :: Maybe SDoc
+checkSuccess = Nothing
+
+----------------
+checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc
+checkBootTyCon is_boot tc1 tc2
+  | not (eqType (tyConKind tc1) (tyConKind tc2))
+  = Just $ text "The types have different kinds"    -- First off, check the kind
+
+  | Just c1 <- tyConClass_maybe tc1
+  , Just c2 <- tyConClass_maybe tc2
+  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
+          = classExtraBigSig c1
+        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
+          = classExtraBigSig c2
+  , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
+  = let
+       eqSig (id1, def_meth1) (id2, def_meth2)
+         = check (name1 == name2)
+                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                  text "are different") `andThenCheck`
+           check (eqTypeX env op_ty1 op_ty2)
+                 (text "The types of" <+> pname1 <+>
+                  text "are different") `andThenCheck`
+           if is_boot
+               then check (eqMaybeBy eqDM def_meth1 def_meth2)
+                          (text "The default methods associated with" <+> pname1 <+>
+                           text "are different")
+               else check (subDM op_ty1 def_meth1 def_meth2)
+                          (text "The default methods associated with" <+> pname1 <+>
+                           text "are not compatible")
+         where
+          name1 = idName id1
+          name2 = idName id2
+          pname1 = quotes (ppr name1)
+          pname2 = quotes (ppr name2)
+          (_, rho_ty1) = splitForAllTys (idType id1)
+          op_ty1 = funResultTy rho_ty1
+          (_, rho_ty2) = splitForAllTys (idType id2)
+          op_ty2 = funResultTy rho_ty2
+
+       eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
+         = checkBootTyCon is_boot tc1 tc2 `andThenCheck`
+           check (eqATDef def_ats1 def_ats2)
+                 (text "The associated type defaults differ")
+
+       eqDM (_, VanillaDM)    (_, VanillaDM)    = True
+       eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
+       eqDM _ _ = False
+
+       -- NB: first argument is from hsig, second is from real impl.
+       -- Order of pattern matching matters.
+       subDM _ Nothing _ = True
+       subDM _ _ Nothing = False
+       -- If the hsig wrote:
+       --
+       --   f :: a -> a
+       --   default f :: a -> a
+       --
+       -- this should be validly implementable using an old-fashioned
+       -- vanilla default method.
+       subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))
+        = eqTypeX env t1 t2
+       -- This case can occur when merging signatures
+       subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))
+        = eqTypeX env t1 t2
+       subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True
+       subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))
+        = eqTypeX env t1 t2
+
+       -- Ignore the location of the defaults
+       eqATDef Nothing             Nothing             = True
+       eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
+       eqATDef _ _ = False
+
+       eqFD (as1,bs1) (as2,bs2) =
+         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+    in
+    checkRoles roles1 roles2 `andThenCheck`
+          -- Checks kind of class
+    check (eqListBy eqFD clas_fds1 clas_fds2)
+          (text "The functional dependencies do not match") `andThenCheck`
+    checkUnless (isAbstractTyCon tc1) $
+    check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
+          (text "The class constraints do not match") `andThenCheck`
+    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
+    checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`
+    check (classMinimalDef c1 `BF.implies` classMinimalDef c2)
+        (text "The MINIMAL pragmas are not compatible")
+
+  | Just syn_rhs1 <- synTyConRhs_maybe tc1
+  , Just syn_rhs2 <- synTyConRhs_maybe tc2
+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
+  = ASSERT(tc1 == tc2)
+    checkRoles roles1 roles2 `andThenCheck`
+    check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say
+  -- This allows abstract 'data T a' to be implemented using 'type T = ...'
+  -- and abstract 'class K a' to be implement using 'type K = ...'
+  -- See Note [Synonyms implement abstract data]
+  | not is_boot -- don't support for hs-boot yet
+  , isAbstractTyCon tc1
+  , Just (tvs, ty) <- synTyConDefn_maybe tc2
+  , Just (tc2', args) <- tcSplitTyConApp_maybe ty
+  = checkSynAbsData tvs ty tc2' args
+    -- TODO: When it's a synonym implementing a class, we really
+    -- should check if the fundeps are satisfied, but
+    -- there is not an obvious way to do this for a constraint synonym.
+    -- So for now, let it all through (it won't cause segfaults, anyway).
+    -- Tracked at #12704.
+
+  -- This allows abstract 'data T :: Nat' to be implemented using
+  -- 'type T = 42' Since the kinds already match (we have checked this
+  -- upfront) all we need to check is that the implementation 'type T
+  -- = ...' defined an actual literal.  See #15138 for the case this
+  -- handles.
+  | not is_boot
+  , isAbstractTyCon tc1
+  , Just (_,ty2) <- synTyConDefn_maybe tc2
+  , isJust (isLitTy ty2)
+  = Nothing
+
+  | Just fam_flav1 <- famTyConFlav_maybe tc1
+  , Just fam_flav2 <- famTyConFlav_maybe tc2
+  = ASSERT(tc1 == tc2)
+    let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True
+        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
+        -- This case only happens for hsig merging:
+        eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True
+        eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
+        eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
+        eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
+            = eqClosedFamilyAx ax1 ax2
+        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
+        eqFamFlav _ _ = False
+        injInfo1 = tyConInjectivityInfo tc1
+        injInfo2 = tyConInjectivityInfo tc2
+    in
+    -- check equality of roles, family flavours and injectivity annotations
+    -- (NB: Type family roles are always nominal. But the check is
+    -- harmless enough.)
+    checkRoles roles1 roles2 `andThenCheck`
+    check (eqFamFlav fam_flav1 fam_flav2)
+        (whenPprDebug $
+            text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>
+            text "do not match") `andThenCheck`
+    check (injInfo1 == injInfo2) (text "Injectivities do not match")
+
+  | isAlgTyCon tc1 && isAlgTyCon tc2
+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
+  = ASSERT(tc1 == tc2)
+    checkRoles roles1 roles2 `andThenCheck`
+    check (eqListBy (eqTypeX env)
+                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))
+          (text "The datatype contexts do not match") `andThenCheck`
+    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
+
+  | otherwise = Just empty   -- two very different types -- should be obvious
+  where
+    roles1 = tyConRoles tc1 -- the abstract one
+    roles2 = tyConRoles tc2
+    roles_msg = text "The roles do not match." $$
+                (text "Roles on abstract types default to" <+>
+                 quotes (text "representational") <+> text "in boot files.")
+
+    roles_subtype_msg = text "The roles are not compatible:" $$
+                        text "Main module:" <+> ppr roles2 $$
+                        text "Hsig file:" <+> ppr roles1
+
+    checkRoles r1 r2
+      | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping]
+      = check (r1 == r2) roles_msg
+      | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg
+
+    -- Note [Role subtyping]
+    -- ~~~~~~~~~~~~~~~~~~~~~
+    -- In the current formulation of roles, role subtyping is only OK if the
+    -- "abstract" TyCon was not representationally injective.  Among the most
+    -- notable examples of non representationally injective TyCons are abstract
+    -- data, which can be implemented via newtypes (which are not
+    -- representationally injective).  The key example is
+    -- in this example from #13140:
+    --
+    --      -- In an hsig file
+    --      data T a -- abstract!
+    --      type role T nominal
+    --
+    --      -- Elsewhere
+    --      foo :: Coercible (T a) (T b) => a -> b
+    --      foo x = x
+    --
+    -- We must NOT allow foo to typecheck, because if we instantiate
+    -- T with a concrete data type with a phantom role would cause
+    -- Coercible (T a) (T b) to be provable.  Fortunately, if T is not
+    -- representationally injective, we cannot make the inference that a ~N b if
+    -- T a ~R T b.
+    --
+    -- Unconditional role subtyping would be possible if we setup
+    -- an extra set of roles saying when we can project out coercions
+    -- (we call these proj-roles); then it would NOT be valid to instantiate T
+    -- with a data type at phantom since the proj-role subtyping check
+    -- would fail.  See #13140 for more details.
+    --
+    -- One consequence of this is we get no role subtyping for non-abstract
+    -- data types in signatures. Suppose you have:
+    --
+    --      signature A where
+    --          type role T nominal
+    --          data T a = MkT
+    --
+    -- If you write this, we'll treat T as injective, and make inferences
+    -- like T a ~R T b ==> a ~N b (mkNthCo).  But if we can
+    -- subsequently replace T with one at phantom role, we would then be able to
+    -- infer things like T Int ~R T Bool which is bad news.
+    --
+    -- We could allow role subtyping here if we didn't treat *any* data types
+    -- defined in signatures as injective.  But this would be a bit surprising,
+    -- replacing a data type in a module with one in a signature could cause
+    -- your code to stop typechecking (whereas if you made the type abstract,
+    -- it is more understandable that the type checker knows less).
+    --
+    -- It would have been best if this was purely a question of defaults
+    -- (i.e., a user could explicitly ask for one behavior or another) but
+    -- the current role system isn't expressive enough to do this.
+    -- Having explict proj-roles would solve this problem.
+
+    rolesSubtypeOf [] [] = True
+    -- NB: this relation is the OPPOSITE of the subroling relation
+    rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys
+    rolesSubtypeOf _ _ = False
+
+    -- Note [Synonyms implement abstract data]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- An abstract data type or class can be implemented using a type synonym,
+    -- but ONLY if the type synonym is nullary and has no type family
+    -- applications.  This arises from two properties of skolem abstract data:
+    --
+    --    For any T (with some number of paramaters),
+    --
+    --    1. T is a valid type (it is "curryable"), and
+    --
+    --    2. T is valid in an instance head (no type families).
+    --
+    -- See also 'HowAbstract' and Note [Skolem abstract data].
+
+    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,
+    -- check that this synonym is an acceptable implementation of @tc1@.
+    -- See Note [Synonyms implement abstract data]
+    checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
+    checkSynAbsData tvs ty tc2' args =
+        check (null (tcTyFamInsts ty))
+              (text "Illegal type family application in implementation of abstract data.")
+                `andThenCheck`
+        check (null tvs)
+              (text "Illegal parameterized type synonym in implementation of abstract data." $$
+               text "(Try eta reducing your type synonym so that it is nullary.)")
+                `andThenCheck`
+        -- Don't report roles errors unless the type synonym is nullary
+        checkUnless (not (null tvs)) $
+            ASSERT( null roles2 )
+            -- If we have something like:
+            --
+            --  signature H where
+            --      data T a
+            --  module H where
+            --      data K a b = ...
+            --      type T = K Int
+            --
+            -- we need to drop the first role of K when comparing!
+            checkRoles roles1 (drop (length args) (tyConRoles tc2'))
+{-
+        -- Hypothetically, if we were allow to non-nullary type synonyms, here
+        -- is how you would check the roles
+        if length tvs == length roles1
+            then checkRoles roles1 roles2
+            else case tcSplitTyConApp_maybe ty of
+                    Just (tc2', args) ->
+                        checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)
+                    Nothing -> Just roles_msg
+-}
+
+    eqAlgRhs _ AbstractTyCon _rhs2
+      = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon
+    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
+        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
+    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
+        eqCon (data_con tc1) (data_con tc2)
+    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
+                           text "definition with a" <+> quotes (text "newtype") <+>
+                           text "definition")
+
+    eqCon c1 c2
+      =  check (name1 == name2)
+               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                text "differ") `andThenCheck`
+         check (dataConIsInfix c1 == dataConIsInfix c2)
+               (text "The fixities of" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
+               (text "The strictness annotations for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))
+               (text "The record label lists for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqType (dataConUserType c1) (dataConUserType c2))
+               (text "The types for" <+> pname1 <+> text "differ")
+      where
+        name1 = dataConName c1
+        name2 = dataConName c2
+        pname1 = quotes (ppr name1)
+        pname2 = quotes (ppr name2)
+
+    eqClosedFamilyAx Nothing Nothing  = True
+    eqClosedFamilyAx Nothing (Just _) = False
+    eqClosedFamilyAx (Just _) Nothing = False
+    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
+                     (Just (CoAxiom { co_ax_branches = branches2 }))
+      =  numBranches branches1 == numBranches branches2
+      && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
+      where
+        branch_list1 = fromBranches branches1
+        branch_list2 = fromBranches branches2
+
+    eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1
+                                     , cab_lhs = lhs1, cab_rhs = rhs1 })
+                         (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2
+                                     , cab_lhs = lhs2, cab_rhs = rhs2 })
+      | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2
+      , Just env  <- eqVarBndrs env1        cvs1 cvs2
+      = eqListBy (eqTypeX env) lhs1 lhs2 &&
+        eqTypeX env rhs1 rhs2
+
+      | otherwise = False
+
+emptyRnEnv2 :: RnEnv2
+emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
+
+----------------
+missingBootThing :: Bool -> Name -> String -> SDoc
+missingBootThing is_boot name what
+  = quotes (ppr name) <+> text "is exported by the"
+    <+> (if is_boot then text "hs-boot" else text "hsig")
+    <+> text "file, but not"
+    <+> text what <+> text "the module"
+
+badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
+badReexportedBootThing dflags is_boot name name'
+  = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat
+        [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")
+           <+> text "file (re)exports" <+> quotes (ppr name)
+        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')
+        ]
+
+bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
+bootMisMatch is_boot extra_info real_thing boot_thing
+  = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
+  where
+    to_doc
+      = pprTyThingInContext $ showToHeader { ss_forall =
+                                              if is_boot
+                                                then ShowForAllMust
+                                                else ShowForAllWhen }
+
+    real_doc = to_doc real_thing
+    boot_doc = to_doc boot_thing
+
+    pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
+    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
+      = vcat
+          [ ppr real_thing <+>
+            text "has conflicting definitions in the module",
+            text "and its" <+>
+              (if is_boot
+                then text "hs-boot file"
+                else text "hsig file"),
+            text "Main module:" <+> real_doc,
+              (if is_boot
+                then text "Boot file:  "
+                else text "Hsig file: ")
+                <+> boot_doc,
+            extra_info
+          ]
+
+instMisMatch :: DFunId -> SDoc
+instMisMatch dfun
+  = hang (text "instance" <+> ppr (idType dfun))
+       2 (text "is defined in the hs-boot file, but not in the module itself")
+
+{-
+************************************************************************
+*                                                                      *
+        Type-checking the top level of a module (continued)
+*                                                                      *
+************************************************************************
+-}
+
+rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
+-- Fails if there are any errors
+rnTopSrcDecls group
+ = do { -- Rename the source decls
+        traceRn "rn12" empty ;
+        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
+        traceRn "rn13" empty ;
+        (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
+        traceRn "rn13-plugin" empty ;
+
+        -- save the renamed syntax, if we want it
+        let { tcg_env'
+                | Just grp <- tcg_rn_decls tcg_env
+                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
+                | otherwise
+                   = tcg_env };
+
+                -- Dump trace of renaming part
+        rnDump rn_decls ;
+        return (tcg_env', rn_decls)
+   }
+
+tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
+                         hs_derivds = deriv_decls,
+                         hs_fords  = foreign_decls,
+                         hs_defds  = default_decls,
+                         hs_annds  = annotation_decls,
+                         hs_ruleds = rule_decls,
+                         hs_valds  = hs_val_binds@(XValBindsLR
+                                              (NValBinds val_binds val_sigs)) })
+ = do {         -- Type-check the type and class decls, and all imported decls
+                -- The latter come in via tycl_decls
+        traceTc "Tc2 (src)" empty ;
+
+                -- Source-language instances, including derivings,
+                -- and import the supporting declarations
+        traceTc "Tc3" empty ;
+        (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
+            <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+
+        setGblEnv tcg_env       $ do {
+
+                -- Generate Applicative/Monad proposal (AMP) warnings
+        traceTc "Tc3b" empty ;
+
+                -- Generate Semigroup/Monoid warnings
+        traceTc "Tc3c" empty ;
+        tcSemigroupWarnings ;
+
+                -- Foreign import declarations next.
+        traceTc "Tc4" empty ;
+        (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
+        tcExtendGlobalValEnv fi_ids     $ do {
+
+                -- Default declarations
+        traceTc "Tc4a" empty ;
+        default_tys <- tcDefaults default_decls ;
+        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+
+                -- Value declarations next.
+                -- It is important that we check the top-level value bindings
+                -- before the GHC-generated derived bindings, since the latter
+                -- may be defined in terms of the former. (For instance,
+                -- the bindings produced in a Data instance.)
+        traceTc "Tc5" empty ;
+        tc_envs <- tcTopBinds val_binds val_sigs;
+        setEnvs tc_envs $ do {
+
+                -- Now GHC-generated derived bindings, generics, and selectors
+                -- Do not generate warnings from compiler-generated code;
+                -- hence the use of discardWarnings
+        tc_envs@(tcg_env, tcl_env)
+            <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
+        setEnvs tc_envs $ do {  -- Environment doesn't change now
+
+                -- Second pass over class and instance declarations,
+                -- now using the kind-checked decls
+        traceTc "Tc6" empty ;
+        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
+
+                -- Foreign exports
+        traceTc "Tc7" empty ;
+        (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
+
+                -- Annotations
+        annotations <- tcAnnotations annotation_decls ;
+
+                -- Rules
+        rules <- tcRules rule_decls ;
+
+                -- Wrap up
+        traceTc "Tc7a" empty ;
+        let { all_binds = inst_binds     `unionBags`
+                          foe_binds
+
+            ; fo_gres = fi_gres `unionBags` foe_gres
+            ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
+                                emptyFVs fo_gres
+
+            ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
+                          `minusNameSet` getTypeSigNames val_sigs
+
+                -- Extend the GblEnv with the (as yet un-zonked)
+                -- bindings, rules, foreign decls
+            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds
+                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names
+                                 , tcg_rules   = tcg_rules tcg_env
+                                                      ++ flattenRuleDecls rules
+                                 , tcg_anns    = tcg_anns tcg_env ++ annotations
+                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
+                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
+                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
+                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
+
+        -- See Note [Newtype constructor usage in foreign declarations]
+        addUsedGREs (bagToList fo_gres) ;
+
+        return (tcg_env', tcl_env)
+    }}}}}}
+
+tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
+
+
+tcSemigroupWarnings :: TcM ()
+tcSemigroupWarnings = do
+    traceTc "tcSemigroupWarnings" empty
+    let warnFlag = Opt_WarnSemigroup
+    tcPreludeClashWarn warnFlag sappendName
+    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName
+
+
+-- | Warn on local definitions of names that would clash with future Prelude
+-- elements.
+--
+--   A name clashes if the following criteria are met:
+--       1. It would is imported (unqualified) from Prelude
+--       2. It is locally defined in the current module
+--       3. It has the same literal name as the reference function
+--       4. It is not identical to the reference function
+tcPreludeClashWarn :: WarningFlag
+                   -> Name
+                   -> TcM ()
+tcPreludeClashWarn warnFlag name = do
+    { warn <- woptM warnFlag
+    ; when warn $ do
+    { traceTc "tcPreludeClashWarn/wouldBeImported" empty
+    -- Is the name imported (unqualified) from Prelude? (Point 4 above)
+    ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
+    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
+    -- will not appear in rnImports automatically if it is set.)
+
+    -- Continue only the name is imported from Prelude
+    ; when (importedViaPrelude name rnImports) $ do
+      -- Handle 2.-4.
+    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv
+
+    ; let clashes :: GlobalRdrElt -> Bool
+          clashes x = isLocalDef && nameClashes && isNotInProperModule
+            where
+              isLocalDef = gre_lcl x == True
+              -- Names are identical ...
+              nameClashes = nameOccName (gre_name x) == nameOccName name
+              -- ... but not the actual definitions, because we don't want to
+              -- warn about a bad definition of e.g. <> in Data.Semigroup, which
+              -- is the (only) proper place where this should be defined
+              isNotInProperModule = gre_name x /= name
+
+          -- List of all offending definitions
+          clashingElts :: [GlobalRdrElt]
+          clashingElts = filter clashes rdrElts
+
+    ; traceTc "tcPreludeClashWarn/prelude_functions"
+                (hang (ppr name) 4 (sep [ppr clashingElts]))
+
+    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep
+              [ text "Local definition of"
+              , (quotes . ppr . nameOccName . gre_name) x
+              , text "clashes with a future Prelude name." ]
+              $$
+              text "This will become an error in a future release." )
+    ; mapM_ warn_msg clashingElts
+    }}}
+
+  where
+
+    -- Is the given name imported via Prelude?
+    --
+    -- Possible scenarios:
+    --   a) Prelude is imported implicitly, issue warnings.
+    --   b) Prelude is imported explicitly, but without mentioning the name in
+    --      question. Issue no warnings.
+    --   c) Prelude is imported hiding the name in question. Issue no warnings.
+    --   d) Qualified import of Prelude, no warnings.
+    importedViaPrelude :: Name
+                       -> [ImportDecl GhcRn]
+                       -> Bool
+    importedViaPrelude name = any importViaPrelude
+      where
+        isPrelude :: ImportDecl GhcRn -> Bool
+        isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
+
+        -- Implicit (Prelude) import?
+        isImplicit :: ImportDecl GhcRn -> Bool
+        isImplicit = ideclImplicit
+
+        -- Unqualified import?
+        isUnqualified :: ImportDecl GhcRn -> Bool
+        isUnqualified = not . isImportDeclQualified . ideclQualified
+
+        -- List of explicitly imported (or hidden) Names from a single import.
+        --   Nothing -> No explicit imports
+        --   Just (False, <names>) -> Explicit import list of <names>
+        --   Just (True , <names>) -> Explicit hiding of <names>
+        importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
+        importListOf = fmap toImportList . ideclHiding
+          where
+            toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))
+
+        isExplicit :: ImportDecl GhcRn -> Bool
+        isExplicit x = case importListOf x of
+            Nothing -> False
+            Just (False, explicit)
+                -> nameOccName name `elem`    map nameOccName explicit
+            Just (True, hidden)
+                -> nameOccName name `notElem` map nameOccName hidden
+
+        -- Check whether the given name would be imported (unqualified) from
+        -- an import declaration.
+        importViaPrelude :: ImportDecl GhcRn -> Bool
+        importViaPrelude x = isPrelude x
+                          && isUnqualified x
+                          && (isImplicit x || isExplicit x)
+
+
+-- Notation: is* is for classes the type is an instance of, should* for those
+--           that it should also be an instance of based on the corresponding
+--           is*.
+tcMissingParentClassWarn :: WarningFlag
+                         -> Name -- ^ Instances of this ...
+                         -> Name -- ^ should also be instances of this
+                         -> TcM ()
+tcMissingParentClassWarn warnFlag isName shouldName
+  = do { warn <- woptM warnFlag
+       ; when warn $ do
+       { traceTc "tcMissingParentClassWarn" empty
+       ; isClass'     <- tcLookupClass_maybe isName
+       ; shouldClass' <- tcLookupClass_maybe shouldName
+       ; case (isClass', shouldClass') of
+              (Just isClass, Just shouldClass) -> do
+                  { localInstances <- tcGetInsts
+                  ; let isInstance m = is_cls m == isClass
+                        isInsts = filter isInstance localInstances
+                  ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)
+                  ; forM_ isInsts (checkShouldInst isClass shouldClass)
+                  }
+              (is',should') ->
+                  traceTc "tcMissingParentClassWarn/notIsShould"
+                          (hang (ppr isName <> text "/" <> ppr shouldName) 2 (
+                            (hsep [ quotes (text "Is"), text "lookup for"
+                                  , ppr isName
+                                  , text "resulted in", ppr is' ])
+                            $$
+                            (hsep [ quotes (text "Should"), text "lookup for"
+                                  , ppr shouldName
+                                  , text "resulted in", ppr should' ])))
+       }}
+  where
+    -- Check whether the desired superclass exists in a given environment.
+    checkShouldInst :: Class   -- ^ Class of existing instance
+                    -> Class   -- ^ Class there should be an instance of
+                    -> ClsInst -- ^ Existing instance
+                    -> TcM ()
+    checkShouldInst isClass shouldClass isInst
+      = do { instEnv <- tcGetInstEnvs
+           ; let (instanceMatches, shouldInsts, _)
+                    = lookupInstEnv False instEnv shouldClass (is_tys isInst)
+
+           ; traceTc "tcMissingParentClassWarn/checkShouldInst"
+                     (hang (ppr isInst) 4
+                         (sep [ppr instanceMatches, ppr shouldInsts]))
+
+           -- "<location>: Warning: <type> is an instance of <is> but not
+           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
+           ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
+                 warnMsg (Just name:_) =
+                      addWarnAt (Reason warnFlag) instLoc $
+                           hsep [ (quotes . ppr . nameOccName) name
+                                , text "is an instance of"
+                                , (ppr . nameOccName . className) isClass
+                                , text "but not"
+                                , (ppr . nameOccName . className) shouldClass ]
+                                <> text "."
+                           $$
+                           hsep [ text "This will become an error in"
+                                , text "a future release." ]
+                 warnMsg _ = pure ()
+           ; when (null shouldInsts && null instanceMatches) $
+                  warnMsg (is_tcs isInst)
+           }
+
+    tcLookupClass_maybe :: Name -> TcM (Maybe Class)
+    tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case
+        Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls
+        _else -> pure Nothing
+
+
+---------------------------
+tcTyClsInstDecls :: [TyClGroup GhcRn]
+                 -> [LDerivDecl GhcRn]
+                 -> [(RecFlag, LHsBinds GhcRn)]
+                 -> TcM (TcGblEnv,            -- The full inst env
+                         [InstInfo GhcRn],    -- Source-code instance decls to
+                                              -- process; contains all dfuns for
+                                              -- this module
+                          HsValBinds GhcRn)   -- Supporting bindings for derived
+                                              -- instances
+
+tcTyClsInstDecls tycl_decls deriv_decls binds
+ = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
+   tcAddPatSynPlaceholders (getPatSynBinds binds) $
+   do { (tcg_env, inst_info, datafam_deriv_info)
+          <- tcTyAndClassDecls tycl_decls ;
+      ; setGblEnv tcg_env $ do {
+          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to
+          -- process the deriving clauses, including data family deriving
+          -- clauses discovered in @tcTyAndClassDecls@.
+          --
+          -- Careful to quit now in case there were instance errors, so that
+          -- the deriving errors don't pile up as well.
+          ; failIfErrsM
+          ; let tyclds = tycl_decls >>= group_tyclds
+          ; (tcg_env', inst_info', val_binds)
+              <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls
+          ; setGblEnv tcg_env' $ do {
+                failIfErrsM
+              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)
+      }}}
+
+{- *********************************************************************
+*                                                                      *
+        Checking for 'main'
+*                                                                      *
+************************************************************************
+-}
+
+checkMain :: Bool  -- False => no 'module M(..) where' header at all
+          -> TcM TcGblEnv
+-- If we are in module Main, check that 'main' is defined.
+checkMain explicit_mod_hdr
+ = do   { dflags  <- getDynFlags
+        ; tcg_env <- getGblEnv
+        ; check_main dflags tcg_env explicit_mod_hdr }
+
+check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
+check_main dflags tcg_env explicit_mod_hdr
+ | mod /= main_mod
+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
+   return tcg_env
+
+ | otherwise
+ = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
+                -- Check that 'main' is in scope
+                -- It might be imported from another module!
+        ; case mb_main of {
+             Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
+                           ; complain_no_main
+                           ; return tcg_env } ;
+             Just main_name -> do
+
+        { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
+        ; let loc       = srcLocSpan (getSrcLoc main_name)
+        ; ioTyCon <- tcLookupTyCon ioTyConName
+        ; res_ty <- newFlexiTyVarTy liftedTypeKind
+        ; let io_ty = mkTyConApp ioTyCon [res_ty]
+              skol_info = SigSkol (FunSigCtxt main_name False) io_ty []
+        ; (ev_binds, main_expr)
+               <- checkConstraints skol_info [] [] $
+                  addErrCtxt mainCtxt    $
+                  tcMonoExpr (cL loc (HsVar noExt (cL loc main_name)))
+                             (mkCheckExpType io_ty)
+
+                -- See Note [Root-main Id]
+                -- Construct the binding
+                --      :Main.main :: IO res_ty = runMainIO res_ty main
+        ; run_main_id <- tcLookupId runMainIOName
+        ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
+                                   (mkVarOccFS (fsLit "main"))
+                                   (getSrcSpan main_name)
+              ; root_main_id = Id.mkExportedVanillaId root_main_name
+                                                      (mkTyConApp ioTyCon [res_ty])
+              ; co  = mkWpTyApps [res_ty]
+              -- The ev_binds of the `main` function may contain deferred
+              -- type error when type of `main` is not `IO a`. The `ev_binds`
+              -- must be put inside `runMainIO` to ensure the deferred type
+              -- error can be emitted correctly. See #13838.
+              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
+                        mkHsDictLet ev_binds main_expr
+              ; main_bind = mkVarBind root_main_id rhs }
+
+        ; return (tcg_env { tcg_main  = Just main_name,
+                            tcg_binds = tcg_binds tcg_env
+                                        `snocBag` main_bind,
+                            tcg_dus   = tcg_dus tcg_env
+                                        `plusDU` usesOnly (unitFV main_name)
+                        -- Record the use of 'main', so that we don't
+                        -- complain about it being defined but not used
+                 })
+    }}}
+  where
+    mod         = tcg_mod tcg_env
+    main_mod    = mainModIs dflags
+    main_fn     = getMainFun dflags
+    interactive = ghcLink dflags == LinkInMemory
+
+    complain_no_main = unless (interactive && not explicit_mod_hdr)
+                              (addErrTc noMainMsg)                  -- #12906
+        -- Without an explicit module header...
+          -- in interactive mode, don't worry about the absence of 'main'.
+          -- in other modes, add error message and go on with typechecking.
+
+    mainCtxt  = text "When checking the type of the" <+> pp_main_fn
+    noMainMsg = text "The" <+> pp_main_fn
+                <+> text "is not defined in module" <+> quotes (ppr main_mod)
+    pp_main_fn = ppMainFn main_fn
+
+-- | Get the unqualified name of the function to use as the \"main\" for the main module.
+-- Either returns the default name or the one configured on the command line with -main-is
+getMainFun :: DynFlags -> RdrName
+getMainFun dflags = case mainFunIs dflags of
+                      Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
+                      Nothing -> main_RDR_Unqual
+
+-- If we are in module Main, check that 'main' is exported.
+checkMainExported :: TcGblEnv -> TcM ()
+checkMainExported tcg_env
+  = case tcg_main tcg_env of
+      Nothing -> return () -- not the main module
+      Just main_name ->
+         do { dflags <- getDynFlags
+            ; let main_mod = mainModIs dflags
+            ; when (ghcLink dflags /= LinkInMemory) $      -- #11647
+                checkTc (main_name `elem`
+                           concatMap availNames (tcg_exports tcg_env)) $
+                   text "The" <+> ppMainFn (nameRdrName main_name) <+>
+                   text "is not exported by module" <+> quotes (ppr main_mod) }
+
+ppMainFn :: RdrName -> SDoc
+ppMainFn main_fn
+  | rdrNameOcc main_fn == mainOcc
+  = text "IO action" <+> quotes (ppr main_fn)
+  | otherwise
+  = text "main IO action" <+> quotes (ppr main_fn)
+
+mainOcc :: OccName
+mainOcc = mkVarOccFS (fsLit "main")
+
+{-
+Note [Root-main Id]
+~~~~~~~~~~~~~~~~~~~
+The function that the RTS invokes is always :Main.main, which we call
+root_main_id.  (Because GHC allows the user to have a module not
+called Main as the main module, we can't rely on the main function
+being called "Main.main".  That's why root_main_id has a fixed module
+":Main".)
+
+This is unusual: it's a LocalId whose Name has a Module from another
+module.  Tiresomely, we must filter it out again in MkIface, les we
+get two defns for 'main' in the interface file!
+
+
+*********************************************************
+*                                                       *
+                GHCi stuff
+*                                                       *
+*********************************************************
+-}
+
+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
+-- Initialise the tcg_inst_env with instances from all home modules.
+-- This mimics the more selective call to hptInstances in tcRnImports
+runTcInteractive hsc_env thing_inside
+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $
+    do { traceTc "setInteractiveContext" $
+            vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
+                 , text "ic_rn_gbl_env (LocalDef)" <+>
+                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
+                                                 , let local_gres = filter isLocalGRE gres
+                                                 , not (null local_gres) ]) ]
+
+       ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
+                                          : dep_orphs (mi_deps iface))
+                                 (loadSrcInterface (text "runTcInteractive") m
+                                                   False mb_pkg)
+
+       ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
+            case i of                   -- force above: see #15111
+                IIModule n -> getOrphans n Nothing
+                IIDecl i ->
+                  let mb_pkg = sl_fs <$> ideclPkgQual i in
+                  getOrphans (unLoc (ideclName i)) mb_pkg
+
+       ; let imports = emptyImportAvails {
+                            imp_orphs = orphs
+                        }
+
+       ; (gbl_env, lcl_env) <- getEnvs
+       ; let gbl_env' = gbl_env {
+                           tcg_rdr_env      = ic_rn_gbl_env icxt
+                         , tcg_type_env     = type_env
+                         , tcg_inst_env     = extendInstEnvList
+                                               (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
+                                               home_insts
+                         , tcg_fam_inst_env = extendFamInstEnvList
+                                               (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
+                                                                     ic_finsts)
+                                               home_fam_insts
+                         , tcg_field_env    = mkNameEnv con_fields
+                              -- setting tcg_field_env is necessary
+                              -- to make RecordWildCards work (test: ghci049)
+                         , tcg_fix_env      = ic_fix_env icxt
+                         , tcg_default      = ic_default icxt
+                              -- must calculate imp_orphs of the ImportAvails
+                              -- so that instance visibility is done correctly
+                         , tcg_imports      = imports
+                         }
+
+       ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids
+       ; setEnvs (gbl_env', lcl_env') thing_inside }
+  where
+    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
+
+    icxt                     = hsc_IC hsc_env
+    (ic_insts, ic_finsts)    = ic_instances icxt
+    (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
+
+    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
+    -- Put Ids with free type variables (always RuntimeUnks)
+    -- in the *local* type environment
+    -- See Note [Initialising the type environment for GHCi]
+    is_closed thing
+      | AnId id <- thing
+      , not (isTypeClosedLetBndr id)
+      = Left (idName id, ATcId { tct_id = id
+                               , tct_info = NotLetBound })
+      | otherwise
+      = Right thing
+
+    type_env1 = mkTypeEnvWithImplicits top_ty_things
+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
+                -- Putting the dfuns in the type_env
+                -- is just to keep Core Lint happy
+
+    con_fields = [ (dataConName c, dataConFieldLabels c)
+                 | ATyCon t <- top_ty_things
+                 , c <- tyConDataCons t ]
+
+
+{- Note [Initialising the type environment for GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the Ids in ic_things, defined by the user in 'let' stmts,
+have closed types. E.g.
+   ghci> let foo x y = x && not y
+
+However the GHCi debugger creates top-level bindings for Ids whose
+types have free RuntimeUnk skolem variables, standing for unknown
+types.  If we don't register these free TyVars as global TyVars then
+the typechecker will try to quantify over them and fall over in
+skolemiseQuantifiedTyVar. so we must add any free TyVars to the
+typechecker's global TyVar set.  That is most conveniently by using
+tcExtendLocalTypeEnv, which automatically extends the global TyVar
+set.
+
+We do this by splitting out the Ids with open types, using 'is_closed'
+to do the partition.  The top-level things go in the global TypeEnv;
+the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the
+local TypeEnv.
+
+Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope
+things are already in the interactive context's GlobalRdrEnv.
+Extending the local RdrEnv isn't terrible, but it means there is an
+entry for the same Name in both global and local RdrEnvs, and that
+lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).
+
+We don't bother with the tcl_th_bndrs environment either.
+-}
+
+-- | The returned [Id] is the list of new Ids bound by this statement. It can
+-- be used to extend the InteractiveContext via extendInteractiveContext.
+--
+-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
+-- values, coerced to ().
+tcRnStmt :: HscEnv -> GhciLStmt GhcPs
+         -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
+tcRnStmt hsc_env rdr_stmt
+  = runTcInteractive hsc_env $ do {
+
+    -- The real work is done here
+    ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
+    zonked_expr <- zonkTopLExpr tc_expr ;
+    zonked_ids  <- zonkTopBndrs bound_ids ;
+
+    failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors
+                   -- test case: ghci/scripts/T13202{,a}
+
+        -- None of the Ids should be of unboxed type, because we
+        -- cast them all to HValues in the end!
+    mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;
+
+    traceTc "tcs 1" empty ;
+    this_mod <- getModule ;
+    global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;
+        -- Note [Interactively-bound Ids in GHCi] in HscTypes
+
+{- ---------------------------------------------
+   At one stage I removed any shadowed bindings from the type_env;
+   they are inaccessible but might, I suppose, cause a space leak if we leave them there.
+   However, with Template Haskell they aren't necessarily inaccessible.  Consider this
+   GHCi session
+         Prelude> let f n = n * 2 :: Int
+         Prelude> fName <- runQ [| f |]
+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
+         14
+         Prelude> let f n = n * 3 :: Int
+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
+   In the last line we use 'fName', which resolves to the *first* 'f'
+   in scope. If we delete it from the type env, GHCi crashes because
+   it doesn't expect that.
+
+   Hence this code is commented out
+
+-------------------------------------------------- -}
+
+    traceOptTcRn Opt_D_dump_tc
+        (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+               text "Typechecked expr" <+> ppr zonked_expr]) ;
+
+    return (global_ids, zonked_expr, fix_env)
+    }
+  where
+    bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",
+                                  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+
+{-
+--------------------------------------------------------------------------
+                Typechecking Stmts in GHCi
+
+Here is the grand plan, implemented in tcUserStmt
+
+        What you type                   The IO [HValue] that hscStmt returns
+        -------------                   ------------------------------------
+        let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+                                        bindings: [x,y,...]
+
+        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+                                        bindings: [x,y,...]
+
+        expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
+          [NB: result not printed]      bindings: [it]
+
+        expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
+          result showable)              bindings: [it]
+
+        expr (of non-IO type,
+          result not showable)  ==>     error
+-}
+
+-- | A plan is an attempt to lift some code into the IO monad.
+type PlanResult = ([Id], LHsExpr GhcTc)
+type Plan = TcM PlanResult
+
+-- | Try the plans in order. If one fails (by raising an exn), try the next.
+-- If one succeeds, take it.
+runPlans :: [Plan] -> TcM PlanResult
+runPlans []     = panic "runPlans"
+runPlans [p]    = p
+runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
+
+-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
+-- GHCi 'environment'.
+--
+-- By 'lift' and 'environment we mean that the code is changed to
+-- execute properly in an IO monad. See Note [Interactively-bound Ids
+-- in GHCi] in HscTypes for more details. We do this lifting by trying
+-- different ways ('plans') of lifting the code into the IO monad and
+-- type checking each plan until one succeeds.
+tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
+
+-- An expression typed at the prompt is treated very specially
+tcUserStmt (dL->L loc (BodyStmt _ expr _ _))
+  = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
+               -- Don't try to typecheck if the renamer fails!
+        ; ghciStep <- getGhciStepIO
+        ; uniq <- newUnique
+        ; interPrintName <- getInteractivePrintName
+        ; let fresh_it  = itName uniq loc
+              matches   = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr
+                                   (noLoc emptyLocalBinds)]
+              -- [it = expr]
+              the_bind  = cL loc $ (mkTopFunBind FromSource
+                                     (cL loc fresh_it) matches)
+                                         { fun_ext = fvs }
+              -- Care here!  In GHCi the expression might have
+              -- free variables, and they in turn may have free type variables
+              -- (if we are at a breakpoint, say).  We must put those free vars
+
+              -- [let it = expr]
+              let_stmt  = cL loc $ LetStmt noExt $ noLoc $ HsValBinds noExt
+                           $ XValBindsLR
+                               (NValBinds [(NonRecursive,unitBag the_bind)] [])
+
+              -- [it <- e]
+              bind_stmt = cL loc $ BindStmt noExt
+                                       (cL loc (VarPat noExt (cL loc fresh_it)))
+                                       (nlHsApp ghciStep rn_expr)
+                                       (mkRnSyntaxExpr bindIOName)
+                                       noSyntaxExpr
+
+              -- [; print it]
+              print_it  = cL loc $ BodyStmt noExt
+                                           (nlHsApp (nlHsVar interPrintName)
+                                           (nlHsVar fresh_it))
+                                           (mkRnSyntaxExpr thenIOName)
+                                                  noSyntaxExpr
+
+              -- NewA
+              no_it_a = cL loc $ BodyStmt noExt (nlHsApps bindIOName
+                                       [rn_expr , nlHsVar interPrintName])
+                                       (mkRnSyntaxExpr thenIOName)
+                                       noSyntaxExpr
+
+              no_it_b = cL loc $ BodyStmt noExt (rn_expr)
+                                       (mkRnSyntaxExpr thenIOName)
+                                       noSyntaxExpr
+
+              no_it_c = cL loc $ BodyStmt noExt
+                                      (nlHsApp (nlHsVar interPrintName) rn_expr)
+                                      (mkRnSyntaxExpr thenIOName)
+                                      noSyntaxExpr
+
+              -- See Note [GHCi Plans]
+
+              it_plans = [
+                    -- Plan A
+                    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+                       ; it_ty <- zonkTcType (idType it_id)
+                       ; when (isUnitTy $ it_ty) failM
+                       ; return stuff },
+
+                        -- Plan B; a naked bind statement
+                    tcGhciStmts [bind_stmt],
+
+                        -- Plan C; check that the let-binding is typeable all by itself.
+                        -- If not, fail; if so, try to print it.
+                        -- The two-step process avoids getting two errors: one from
+                        -- the expression itself, and one from the 'print it' part
+                        -- This two-step story is very clunky, alas
+                    do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
+                                --- checkNoErrs defeats the error recovery of let-bindings
+                       ; tcGhciStmts [let_stmt, print_it] } ]
+
+              -- Plans where we don't bind "it"
+              no_it_plans = [
+                    tcGhciStmts [no_it_a] ,
+                    tcGhciStmts [no_it_b] ,
+                    tcGhciStmts [no_it_c] ]
+
+        ; generate_it <- goptM Opt_NoIt
+
+        -- We disable `-fdefer-type-errors` in GHCi for naked expressions.
+        -- See Note [Deferred type errors in GHCi]
+
+        -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`
+        -- and `-fdefer-out-of-scope-variables`. However the flag
+        -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and
+        -- `-fno-defer-out-of-scope-variables`. Thus the later two flags
+        -- also need to be unset here.
+        ; plan <- unsetGOptM Opt_DeferTypeErrors $
+                  unsetGOptM Opt_DeferTypedHoles $
+                  unsetGOptM Opt_DeferOutOfScopeVariables $
+                    runPlans $ if generate_it
+                                 then no_it_plans
+                                 else it_plans
+
+        ; fix_env <- getFixityEnv
+        ; return (plan, fix_env) }
+
+{- Note [Deferred type errors in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHCi, we ensure that type errors don't get deferred when type checking the
+naked expressions. Deferring type errors here is unhelpful because the
+expression gets evaluated right away anyway. It also would potentially emit
+two redundant type-error warnings, one from each plan.
+
+#14963 reveals another bug that when deferred type errors is enabled
+in GHCi, any reference of imported/loaded variables (directly or indirectly)
+in interactively issued naked expressions will cause ghc panic. See more
+detailed dicussion in #14963.
+
+The interactively issued declarations, statements, as well as the modules
+loaded into GHCi, are not affected. That means, for declaration, you could
+have
+
+    Prelude> :set -fdefer-type-errors
+    Prelude> x :: IO (); x = putStrLn True
+    <interactive>:14:26: warning: [-Wdeferred-type-errors]
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘x’: x = putStrLn True
+
+But for naked expressions, you will have
+
+    Prelude> :set -fdefer-type-errors
+    Prelude> putStrLn True
+    <interactive>:2:10: error:
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘it’: it = putStrLn True
+
+    Prelude> let x = putStrLn True
+    <interactive>:2:18: warning: [-Wdeferred-type-errors]
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘x’: x = putStrLn True
+-}
+
+tcUserStmt rdr_stmt@(dL->L loc _)
+  = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
+           rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
+             fix_env <- getFixityEnv
+             return (fix_env, emptyFVs)
+            -- Don't try to typecheck if the renamer fails!
+       ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
+       ; rnDump rn_stmt ;
+
+       ; ghciStep <- getGhciStepIO
+       ; let gi_stmt
+               | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt
+                     = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2
+               | otherwise = rn_stmt
+
+       ; opt_pr_flag <- goptM Opt_PrintBindResult
+       ; let print_result_plan
+               | opt_pr_flag                         -- The flag says "print result"
+               , [v] <- collectLStmtBinders gi_stmt  -- One binder
+                           =  [mk_print_result_plan gi_stmt v]
+               | otherwise = []
+
+        -- The plans are:
+        --      [stmt; print v]         if one binder and not v::()
+        --      [stmt]                  otherwise
+       ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
+       ; return (plan, fix_env) }
+  where
+    mk_print_result_plan stmt v
+      = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+           ; v_ty <- zonkTcType (idType v_id)
+           ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
+           ; return stuff }
+      where
+        print_v  = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar printName)
+                                    (nlHsVar v))
+                                    (mkRnSyntaxExpr thenIOName) noSyntaxExpr
+
+{-
+Note [GHCi Plans]
+~~~~~~~~~~~~~~~~~
+When a user types an expression in the repl we try to print it in three different
+ways. Also, depending on whether -fno-it is set, we bind a variable called `it`
+which can be used to refer to the result of the expression subsequently in the repl.
+
+The normal plans are :
+  A. [it <- e; print e]     but not if it::()
+  B. [it <- e]
+  C. [let it = e; print it]
+
+When -fno-it is set, the plans are:
+  A. [e >>= print]
+  B. [e]
+  C. [let it = e in print it]
+
+The reason for -fno-it is explained in #14336. `it` can lead to the repl
+leaking memory as it is repeatedly queried.
+-}
+
+-- | Typecheck the statements given and then return the results of the
+-- statement in the form 'IO [()]'.
+tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
+tcGhciStmts stmts
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
+        ret_id  <- tcLookupId returnIOName ;            -- return @ IO
+        let {
+            ret_ty      = mkListTy unitTy ;
+            io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;
+            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts
+                                         (mkCheckExpType io_ret_ty) ;
+            names = collectLStmtsBinders stmts ;
+         } ;
+
+        -- OK, we're ready to typecheck the stmts
+        traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+        ((tc_stmts, ids), lie) <- captureTopConstraints $
+                                  tc_io_stmts $ \ _ ->
+                                  mapM tcLookupId names  ;
+                        -- Look up the names right in the middle,
+                        -- where they will all be in scope
+
+        -- Simplify the context
+        traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+        const_binds <- checkNoErrs (simplifyInteractive lie) ;
+                -- checkNoErrs ensures that the plan fails if context redn fails
+
+        traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+        let {   -- mk_return builds the expression
+                --      returnIO @ [()] [coerce () x, ..,  coerce () z]
+                --
+                -- Despite the inconvenience of building the type applications etc,
+                -- this *has* to be done in type-annotated post-typecheck form
+                -- because we are going to return a list of *polymorphic* values
+                -- coerced to type (). If we built a *source* stmt
+                --      return [coerce x, ..., coerce z]
+                -- then the type checker would instantiate x..z, and we wouldn't
+                -- get their *polymorphic* values.  (And we'd get ambiguity errs
+                -- if they were overloaded, since they aren't applied to anything.)
+            ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
+                       (noLoc $ ExplicitList unitTy Nothing
+                                                            (map mk_item ids)) ;
+            mk_item id = let ty_args = [idType id, unitTy] in
+                         nlHsApp (nlHsTyApp unsafeCoerceId
+                                   (map getRuntimeRep ty_args ++ ty_args))
+                                 (nlHsVar id) ;
+            stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+        } ;
+        return (ids, mkHsDictLet (EvBinds const_binds) $
+                     noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))
+    }
+
+-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
+getGhciStepIO :: TcM (LHsExpr GhcRn)
+getGhciStepIO = do
+    ghciTy <- getGHCiMonad
+    a_tv <- newName (mkTyVarOccFS (fsLit "a"))
+    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
+        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+
+        step_ty = noLoc $ HsForAllTy
+                     { hst_fvf = ForallInvis
+                     , hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]
+                     , hst_xforall = noExt
+                     , hst_body  = nlHsFunTy ghciM ioM }
+
+        stepTy :: LHsSigWcType GhcRn
+        stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
+
+    return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)
+
+isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
+isGHCiMonad hsc_env ty
+  = runTcInteractive hsc_env $ do
+        rdrEnv <- getGlobalRdrEnv
+        let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
+        case occIO of
+            Just [n] -> do
+                let name = gre_name n
+                ghciClass <- tcLookupClass ghciIoClassName
+                userTyCon <- tcLookupTyCon name
+                let userTy = mkTyConApp userTyCon []
+                _ <- tcLookupInstance ghciClass [userTy]
+                return name
+
+            Just _  -> failWithTc $ text "Ambiguous type!"
+            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
+
+-- | How should we infer a type? See Note [TcRnExprMode]
+data TcRnExprMode = TM_Inst    -- ^ Instantiate the type fully (:type)
+                  | TM_NoInst  -- ^ Do not instantiate the type (:type +v)
+                  | TM_Default -- ^ Default the type eagerly (:type +d)
+
+-- | tcRnExpr just finds the type of an expression
+tcRnExpr :: HscEnv
+         -> TcRnExprMode
+         -> LHsExpr GhcPs
+         -> IO (Messages, Maybe Type)
+tcRnExpr hsc_env mode rdr_expr
+  = runTcInteractive hsc_env $
+    do {
+
+    (rn_expr, _fvs) <- rnLExpr rdr_expr ;
+    failIfErrsM ;
+
+        -- Now typecheck the expression, and generalise its type
+        -- it might have a rank-2 type (e.g. :t runST)
+    uniq <- newUnique ;
+    let { fresh_it  = itName uniq (getLoc rdr_expr)
+        ; orig = lexprCtOrigin rn_expr } ;
+    ((tclvl, res_ty), lie)
+          <- captureTopConstraints $
+             pushTcLevelM          $
+             do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr
+                ; if inst
+                  then snd <$> deeplyInstantiate orig expr_ty
+                  else return expr_ty } ;
+
+    -- Generalise
+    (qtvs, dicts, _, residual, _)
+         <- simplifyInfer tclvl infer_mode
+                          []    {- No sig vars -}
+                          [(fresh_it, res_ty)]
+                          lie ;
+
+    -- Ignore the dictionary bindings
+    _ <- perhaps_disable_default_warnings $
+         simplifyInteractive residual ;
+
+    let { all_expr_ty = mkInvForAllTys qtvs $
+                        mkPhiTy (map idType dicts) res_ty } ;
+    ty <- zonkTcType all_expr_ty ;
+
+    -- We normalise type families, so that the type of an expression is the
+    -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac
+    -- #10321 for further discussion.
+    fam_envs <- tcGetFamInstEnvs ;
+    -- normaliseType returns a coercion which we discard, so the Role is
+    -- irrelevant
+    return (snd (normaliseType fam_envs Nominal ty))
+    }
+  where
+    -- See Note [TcRnExprMode]
+    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of
+      TM_Inst    -> (True,  NoRestrictions, id)
+      TM_NoInst  -> (False, NoRestrictions, id)
+      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)
+
+--------------------------
+tcRnImportDecls :: HscEnv
+                -> [LImportDecl GhcPs]
+                -> IO (Messages, Maybe GlobalRdrEnv)
+-- Find the new chunk of GlobalRdrEnv created by this list of import
+-- decls.  In contract tcRnImports *extends* the TcGblEnv.
+tcRnImportDecls hsc_env import_decls
+ =  runTcInteractive hsc_env $
+    do { gbl_env <- updGblEnv zap_rdr_env $
+                    tcRnImports hsc_env import_decls
+       ; return (tcg_rdr_env gbl_env) }
+  where
+    zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
+
+-- tcRnType just finds the kind of a type
+tcRnType :: HscEnv
+         -> Bool        -- Normalise the returned type
+         -> LHsType GhcPs
+         -> IO (Messages, Maybe (Type, Kind))
+tcRnType hsc_env normalise rdr_type
+  = runTcInteractive hsc_env $
+    setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
+    do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
+               <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)
+                  -- The type can have wild cards, but no implicit
+                  -- generalisation; e.g.   :kind (T _)
+       ; failIfErrsM
+
+        -- Now kind-check the type
+        -- It can have any rank or kind
+        -- First bring into scope any wildcards
+       ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
+       ; ((ty, kind), lie)  <-
+                       captureTopConstraints $
+                       tcWildCardBinders wcs $ \ wcs' ->
+                       do { emitWildCardHoleConstraints wcs'
+                          ; tcLHsTypeUnsaturated rn_type }
+       ; _ <- checkNoErrs (simplifyInteractive lie)
+
+       -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
+       ; kind <- zonkTcType kind
+       ; kvs <- kindGeneralize kind
+       ; ty  <- zonkTcTypeToType ty
+
+       -- Do validity checking on type
+       ; checkValidType (GhciCtxt True) ty
+
+       ; ty' <- if normalise
+                then do { fam_envs <- tcGetFamInstEnvs
+                        ; let (_, ty')
+                                = normaliseType fam_envs Nominal ty
+                        ; return ty' }
+                else return ty ;
+
+       ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) }
+
+{- Note [TcRnExprMode]
+~~~~~~~~~~~~~~~~~~~~~~
+How should we infer a type when a user asks for the type of an expression e
+at the GHCi prompt? We offer 3 different possibilities, described below. Each
+considers this example, with -fprint-explicit-foralls enabled:
+
+  foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
+  :type{,-spec,-def} foo @Int
+
+:type / TM_Inst
+
+  In this mode, we report the type that would be inferred if a variable
+  were assigned to expression e, without applying the monomorphism restriction.
+  This means we deeply instantiate the type and then regeneralize, as discussed
+  in #11376.
+
+  > :type foo @Int
+  forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String
+
+  Note that the variables and constraints are reordered here, because this
+  is possible during regeneralization. Also note that the variables are
+  reported as Inferred instead of Specified.
+
+:type +v / TM_NoInst
+
+  This mode is for the benefit of users using TypeApplications. It does no
+  instantiation whatsoever, sometimes meaning that class constraints are not
+  solved.
+
+  > :type +v foo @Int
+  forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String
+
+  Note that Show Int is still reported, because the solver never got a chance
+  to see it.
+
+:type +d / TM_Default
+
+  This mode is for the benefit of users who wish to see instantiations of
+  generalized types, and in particular to instantiate Foldable and Traversable.
+  In this mode, any type variable that can be defaulted is defaulted. Because
+  GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are
+  defaulted.
+
+  > :type +d foo @Int
+  Int -> [Integer] -> String
+
+  Note that this mode can sometimes lead to a type error, if a type variable is
+  used with a defaultable class but cannot actually be defaulted:
+
+  bar :: (Num a, Monoid a) => a -> a
+  > :type +d bar
+  ** error **
+
+  The error arises because GHC tries to default a but cannot find a concrete
+  type in the defaulting list that is both Num and Monoid. (If this list is
+  modified to include an element that is both Num and Monoid, the defaulting
+  would succeed, of course.)
+
+Note [Kind-generalise in tcRnType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We switch on PolyKinds when kind-checking a user type, so that we will
+kind-generalise the type, even when PolyKinds is not otherwise on.
+This gives the right default behaviour at the GHCi prompt, where if
+you say ":k T", and T has a polymorphic kind, you'd like to see that
+polymorphism. Of course.  If T isn't kind-polymorphic you won't get
+anything unexpected, but the apparent *loss* of polymorphism, for
+types that you know are polymorphic, is quite surprising.  See Trac
+#7688 for a discussion.
+
+Note that the goal is to generalise the *kind of the type*, not
+the type itself! Example:
+  ghci> data SameKind :: k -> k -> Type
+  ghci> :k SameKind _
+
+We want to get `k -> Type`, not `Any -> Type`, which is what we would
+get without kind-generalisation. Note that `:k SameKind` is OK, as
+GHC will not instantiate SameKind here, and so we see its full kind
+of `forall k. k -> k -> Type`.
+
+************************************************************************
+*                                                                      *
+                 tcRnDeclsi
+*                                                                      *
+************************************************************************
+
+tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
+-}
+
+tcRnDeclsi :: HscEnv
+           -> [LHsDecl GhcPs]
+           -> IO (Messages, Maybe TcGblEnv)
+tcRnDeclsi hsc_env local_decls
+  = runTcInteractive hsc_env $
+    tcRnSrcDecls False local_decls
+
+externaliseAndTidyId :: Module -> Id -> TcM Id
+externaliseAndTidyId this_mod id
+  = do { name' <- externaliseName this_mod (idName id)
+       ; return (globaliseAndTidyId (setIdName id name')) }
+
+
+{-
+************************************************************************
+*                                                                      *
+        More GHCi stuff, to do with browsing and getting info
+*                                                                      *
+************************************************************************
+-}
+
+-- | ASSUMES that the module is either in the 'HomePackageTable' or is
+-- a package module with an interface on disk.  If neither of these is
+-- true, then the result will be an error indicating the interface
+-- could not be found.
+getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
+getModuleInterface hsc_env mod
+  = runTcInteractive hsc_env $
+    loadModuleInterface (text "getModuleInterface") mod
+
+tcRnLookupRdrName :: HscEnv -> Located RdrName
+                  -> IO (Messages, Maybe [Name])
+-- ^ Find all the Names that this RdrName could mean, in GHCi
+tcRnLookupRdrName hsc_env (dL->L loc rdr_name)
+  = runTcInteractive hsc_env $
+    setSrcSpan loc           $
+    do {   -- If the identifier is a constructor (begins with an
+           -- upper-case letter), then we need to consider both
+           -- constructor and type class identifiers.
+         let rdr_names = dataTcOccs rdr_name
+       ; names_s <- mapM lookupInfoOccRn rdr_names
+       ; let names = concat names_s
+       ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))
+       ; return names }
+
+tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
+tcRnLookupName hsc_env name
+  = runTcInteractive hsc_env $
+    tcRnLookupName' name
+
+-- To look up a name we have to look in the local environment (tcl_lcl)
+-- as well as the global environment, which is what tcLookup does.
+-- But we also want a TyThing, so we have to convert:
+
+tcRnLookupName' :: Name -> TcRn TyThing
+tcRnLookupName' name = do
+   tcthing <- tcLookup name
+   case tcthing of
+     AGlobal thing    -> return thing
+     ATcId{tct_id=id} -> return (AnId id)
+     _ -> panic "tcRnLookupName'"
+
+tcRnGetInfo :: HscEnv
+            -> Name
+            -> IO ( Messages
+                  , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
+
+-- Used to implement :info in GHCi
+--
+-- Look up a RdrName and return all the TyThings it might be
+-- A capitalised RdrName is given to us in the DataName namespace,
+-- but we want to treat it as *both* a data constructor
+--  *and* as a type or class constructor;
+-- hence the call to dataTcOccs, and we return up to two results
+tcRnGetInfo hsc_env name
+  = runTcInteractive hsc_env $
+    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+           -- Load the interface for all unqualified types and classes
+           -- That way we will find all the instance declarations
+           -- (Packages have not orphan modules, and we assume that
+           --  in the home package all relevant modules are loaded.)
+
+       ; thing  <- tcRnLookupName' name
+       ; fixity <- lookupFixityRn name
+       ; (cls_insts, fam_insts) <- lookupInsts thing
+       ; let info = lookupKnownNameInfo name
+       ; return (thing, fixity, cls_insts, fam_insts, info) }
+
+
+-- Lookup all class and family instances for a type constructor.
+--
+-- This function filters all instances in the type environment, so there
+-- is a lot of duplicated work if it is called many times in the same
+-- type environment. If this becomes a problem, the NameEnv computed
+-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions
+-- could be changed to consult that index.
+lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
+lookupInsts (ATyCon tc)
+  = do  { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
+        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
+                -- Load all instances for all classes that are
+                -- in the type environment (which are all the ones
+                -- we've seen in any interface file so far)
+
+          -- Return only the instances relevant to the given thing, i.e.
+          -- the instances whose head contains the thing's name.
+        ; let cls_insts =
+                 [ ispec        -- Search all
+                 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
+                 , instIsVisible vis_mods ispec
+                 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
+        ; let fam_insts =
+                 [ fispec
+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
+                 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
+        ; return (cls_insts, fam_insts) }
+  where
+    tc_name     = tyConName tc
+
+lookupInsts _ = return ([],[])
+
+loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
+-- Load the interface for everything that is in scope unqualified
+-- This is so that we can accurately report the instances for
+-- something
+loadUnqualIfaces hsc_env ictxt
+  = initIfaceTcRn $ do
+    mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
+  where
+    this_pkg = thisPackage (hsc_dflags hsc_env)
+
+    unqual_mods = [ nameModule name
+                  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
+                  , let name = gre_name gre
+                  , nameIsFromExternalPackage this_pkg name
+                  , isTcOcc (nameOccName name)   -- Types and classes only
+                  , unQualOK gre ]               -- In scope unqualified
+    doc = text "Need interface for module whose export(s) are in scope unqualified"
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                Debugging output
+      This is what happens when you do -ddump-types
+*                                                                      *
+************************************************************************
+-}
+
+rnDump :: (Outputable a, Data a) => a -> TcRn ()
+-- Dump, with a banner, if -ddump-rn
+rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }
+
+tcDump :: TcGblEnv -> TcRn ()
+tcDump env
+ = do { dflags <- getDynFlags ;
+
+        -- Dump short output if -ddump-types or -ddump-tc
+        when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+          (traceTcRnForUser Opt_D_dump_types short_dump) ;
+
+        -- Dump bindings if -ddump-tc
+        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);
+
+        -- Dump bindings as an hsSyn AST if -ddump-tc-ast
+        traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)
+   }
+  where
+    short_dump = pprTcGblEnv env
+    full_dump  = pprLHsBinds (tcg_binds env)
+        -- NB: foreign x-d's have undefined's in their types;
+        --     hence can't show the tc_fords
+    ast_dump = showAstData NoBlankSrcSpan (tcg_binds env)
+
+-- It's unpleasant having both pprModGuts and pprModDetails here
+pprTcGblEnv :: TcGblEnv -> SDoc
+pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
+                        tcg_insts     = insts,
+                        tcg_fam_insts = fam_insts,
+                        tcg_rules     = rules,
+                        tcg_imports   = imports })
+  = getPprDebug $ \debug ->
+    vcat [ ppr_types debug type_env
+         , ppr_tycons debug fam_insts type_env
+         , ppr_datacons debug type_env
+         , ppr_patsyns type_env
+         , ppr_insts insts
+         , ppr_fam_insts fam_insts
+         , ppr_rules rules
+         , text "Dependent modules:" <+>
+                pprUFM (imp_dep_mods imports) (ppr . sort)
+         , text "Dependent packages:" <+>
+                ppr (S.toList $ imp_dep_pkgs imports)]
+  where         -- The use of sort is just to reduce unnecessary
+                -- wobbling in testsuite output
+
+ppr_rules :: [LRuleDecl GhcTc] -> SDoc
+ppr_rules rules
+  = ppUnless (null rules) $
+    hang (text "RULES")
+       2 (vcat (map ppr rules))
+
+ppr_types :: Bool -> TypeEnv -> SDoc
+ppr_types debug type_env
+  = ppr_things "TYPE SIGNATURES" ppr_sig
+             (sortBy (comparing getOccName) ids)
+  where
+    ids = [id | id <- typeEnvIds type_env, want_sig id]
+    want_sig id
+      | debug     = True
+      | otherwise = hasTopUserName id
+                    && case idDetails id of
+                         VanillaId    -> True
+                         RecSelId {}  -> True
+                         ClassOpId {} -> True
+                         FCallId {}   -> True
+                         _            -> False
+             -- Data cons (workers and wrappers), pattern synonyms,
+             -- etc are suppressed (unless -dppr-debug),
+             -- because they appear elsehwere
+
+    ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
+
+ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
+ppr_tycons debug fam_insts type_env
+  = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons
+         , ppr_things "COERCION AXIOMS" ppr_ax
+                      (typeEnvCoAxioms type_env) ]
+  where
+    fi_tycons = famInstsRepTyCons fam_insts
+
+    tycons = sortBy (comparing getOccName) $
+             [tycon | tycon <- typeEnvTyCons type_env
+                    , want_tycon tycon]
+             -- Sort by OccName to reduce unnecessary changes
+    want_tycon tycon | debug      = True
+                     | otherwise  = isExternalName (tyConName tycon) &&
+                                    not (tycon `elem` fi_tycons)
+    ppr_tc tc
+       = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc
+                      <> braces (ppr (tyConArity tc)) <+> dcolon)
+                   2 (ppr (tidyTopType (tyConKind tc)))
+              , nest 2 $
+                ppWhen show_roles $
+                text "roles" <+> (sep (map ppr roles)) ]
+       where
+         show_roles = debug || not (all (== boring_role) roles)
+         roles = tyConRoles tc
+         boring_role | isClassTyCon tc = Nominal
+                     | otherwise       = Representational
+            -- Matches the choice in IfaceSyn, calls to pprRoles
+
+    ppr_ax ax = ppr (coAxiomToIfaceDecl ax)
+      -- We go via IfaceDecl rather than using pprCoAxiom
+      -- This way we get the full axiom (both LHS and RHS) with
+      -- wildcard binders tidied to _1, _2, etc.
+
+ppr_datacons :: Bool -> TypeEnv -> SDoc
+ppr_datacons debug type_env
+  = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
+      -- The filter gets rid of class data constructors
+  where
+    ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc)
+    all_dcs    = typeEnvDataCons type_env
+    wanted_dcs | debug     = all_dcs
+               | otherwise = filterOut is_cls_dc all_dcs
+    is_cls_dc dc = isClassTyCon (dataConTyCon dc)
+
+ppr_patsyns :: TypeEnv -> SDoc
+ppr_patsyns type_env
+  = ppr_things "PATTERN SYNONYMS" ppr_ps
+               (typeEnvPatSyns type_env)
+  where
+    ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps
+
+ppr_insts :: [ClsInst] -> SDoc
+ppr_insts ispecs
+  = ppr_things "CLASS INSTANCES" pprInstance ispecs
+
+ppr_fam_insts :: [FamInst] -> SDoc
+ppr_fam_insts fam_insts
+  = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts
+
+ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
+ppr_things herald ppr_one things
+  | null things = empty
+  | otherwise   = text herald $$ nest 2 (vcat (map ppr_one things))
+
+hasTopUserName :: NamedThing x => x -> Bool
+-- A top-level thing whose name is not "derived"
+-- Thus excluding things like $tcX, from Typeable boilerplate
+-- and C:Coll from class-dictionary data constructors
+hasTopUserName x
+  = isExternalName name && not (isDerivedOccName (nameOccName name))
+  where
+    name = getName x
+
+{-
+********************************************************************************
+
+Type Checker Plugins
+
+********************************************************************************
+-}
+
+withTcPlugins :: HscEnv -> TcM a -> TcM a
+withTcPlugins hsc_env m =
+  do let plugins = getTcPlugins (hsc_dflags hsc_env)
+     case plugins of
+       [] -> m  -- Common fast case
+       _  -> do ev_binds_var <- newTcEvBinds
+                (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins
+                -- This ensures that tcPluginStop is called even if a type
+                -- error occurs during compilation (Fix of #10078)
+                eitherRes <- tryM $ do
+                  updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
+                mapM_ (flip runTcPluginM ev_binds_var) stops
+                case eitherRes of
+                  Left _ -> failM
+                  Right res -> return res
+  where
+  startPlugin ev_binds_var (TcPlugin start solve stop) =
+    do s <- runTcPluginM start ev_binds_var
+       return (solve s, stop s)
+
+getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
+getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
+
+runRenamerPlugin :: TcGblEnv
+                 -> HsGroup GhcRn
+                 -> TcM (TcGblEnv, HsGroup GhcRn)
+runRenamerPlugin gbl_env hs_group = do
+    dflags <- getDynFlags
+    withPlugins dflags
+      (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))
+      (gbl_env, hs_group)
+
+
+-- XXX: should this really be a Maybe X?  Check under which circumstances this
+-- can become a Nothing and decide whether this should instead throw an
+-- exception/signal an error.
+type RenamedStuff =
+        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
+                Maybe LHsDocString))
+
+-- | Extract the renamed information from TcGblEnv.
+getRenamedStuff :: TcGblEnv -> RenamedStuff
+getRenamedStuff tc_result
+  = fmap (\decls -> ( decls, tcg_rn_imports tc_result
+                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
+         (tcg_rn_decls tc_result)
+
+runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
+runTypecheckerPlugin sum hsc_env gbl_env = do
+    let dflags = hsc_dflags hsc_env
+    withPlugins dflags
+      (\p opts env -> mark_plugin_unsafe dflags
+                        >> typeCheckResultAction p opts sum env)
+      gbl_env
+
+mark_plugin_unsafe :: DynFlags -> TcM ()
+mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
+  recordUnsafeInfer pluginUnsafe
+  where
+    unsafeText = "Use of plugins makes the module unsafe"
+    pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
+                                   (Outputable.text unsafeText) )
diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnDriver.hs-boot
@@ -0,0 +1,13 @@
+module TcRnDriver where
+
+import GhcPrelude
+import DynFlags (DynFlags)
+import Type (TyThing)
+import TcRnTypes (TcM)
+import Outputable (SDoc)
+import Name (Name)
+
+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
+               -> TyThing -> TyThing -> TcM ()
+missingBootThing :: Bool -> Name -> String -> SDoc
+badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnExports.hs
@@ -0,0 +1,849 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcRnExports (tcRnExports, exports_from_avail) where
+
+import GhcPrelude
+
+import HsSyn
+import PrelNames
+import RdrName
+import TcRnMonad
+import TcEnv
+import TcType
+import RnNames
+import RnEnv
+import RnUnbound ( reportUnboundName )
+import ErrUtils
+import Id
+import IdInfo
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import TyCon
+import SrcLoc
+import HscTypes
+import Outputable
+import ConLike
+import DataCon
+import PatSyn
+import Maybes
+import UniqSet
+import Util (capitalise)
+import FastString (fsLit)
+
+import Control.Monad
+import DynFlags
+import RnHsDoc          ( rnHsDoc )
+import RdrHsSyn        ( setRdrNameSpace )
+import Data.Either      ( partitionEithers )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Export list processing}
+*                                                                      *
+************************************************************************
+
+Processing the export list.
+
+You might think that we should record things that appear in the export
+list as ``occurrences'' (using @addOccurrenceName@), but you'd be
+wrong.  We do check (here) that they are in scope, but there is no
+need to slurp in their actual declaration (which is what
+@addOccurrenceName@ forces).
+
+Indeed, doing so would big trouble when compiling @PrelBase@, because
+it re-exports @GHC@, which includes @takeMVar#@, whose type includes
+@ConcBase.StateAndSynchVar#@, and so on...
+
+Note [Exports of data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose you see (#5306)
+        module M where
+          import X( F )
+          data instance F Int = FInt
+What does M export?  AvailTC F [FInt]
+                  or AvailTC F [F,FInt]?
+The former is strictly right because F isn't defined in this module.
+But then you can never do an explicit import of M, thus
+    import M( F( FInt ) )
+because F isn't exported by M.  Nor can you import FInt alone from here
+    import M( FInt )
+because we don't have syntax to support that.  (It looks like an import of
+the type FInt.)
+
+At one point I implemented a compromise:
+  * When constructing exports with no export list, or with module M(
+    module M ), we add the parent to the exports as well.
+  * But not when you see module M( f ), even if f is a
+    class method with a parent.
+  * Nor when you see module M( module N ), with N /= M.
+
+But the compromise seemed too much of a hack, so we backed it out.
+You just have to use an explicit export list:
+    module M( F(..) ) where ...
+
+Note [Avails of associated data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose you have (#16077)
+
+    {-# LANGUAGE TypeFamilies #-}
+    module A (module A) where
+
+    class    C a  where { data T a }
+    instance C () where { data T () = D }
+
+Because @A@ is exported explicitly, GHC tries to produce an export list
+from the @GlobalRdrEnv@. In this case, it pulls out the following:
+
+    [ C defined at A.hs:4:1
+    , T parent:C defined at A.hs:4:23
+    , D parent:T defined at A.hs:5:35 ]
+
+If map these directly into avails, (via 'availFromGRE'), we get
+@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@.
+That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is
+exported, but it isn't the first entry in the avail!
+
+We work around this issue by expanding GREs where the parent and child
+are both type constructors into two GRES.
+
+    T parent:C defined at A.hs:4:23
+
+      =>
+
+    [ T parent:C defined at A.hs:4:23
+    , T defined at A.hs:4:23 ]
+
+Then, we get  @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged
+into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant).
+-}
+
+data ExportAccum        -- The type of the accumulating parameter of
+                        -- the main worker function in rnExports
+     = ExportAccum
+        ExportOccMap           --  Tracks exported occurrence names
+        (UniqSet ModuleName)   --  Tracks (re-)exported module names
+
+emptyExportAccum :: ExportAccum
+emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
+
+accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
+             -> [x]
+             -> TcRn [y]
+accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
+  where f' acc x = do
+          m <- attemptM (f acc x)
+          pure $ case m of
+            Just (Just (acc', y)) -> (acc', Just y)
+            _                     -> (acc, Nothing)
+
+type ExportOccMap = OccEnv (Name, IE GhcPs)
+        -- Tracks what a particular exported OccName
+        --   in an export list refers to, and which item
+        --   it came from.  It's illegal to export two distinct things
+        --   that have the same occurrence name
+
+tcRnExports :: Bool       -- False => no 'module M(..) where' header at all
+          -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list
+          -> TcGblEnv
+          -> RnM TcGblEnv
+
+        -- Complains if two distinct exports have same OccName
+        -- Warns about identical exports.
+        -- Complains about exports items not in scope
+
+tcRnExports explicit_mod exports
+          tcg_env@TcGblEnv { tcg_mod     = this_mod,
+                              tcg_rdr_env = rdr_env,
+                              tcg_imports = imports,
+                              tcg_src     = hsc_src }
+ = unsetWOptM Opt_WarnWarningsDeprecations $
+       -- Do not report deprecations arising from the export
+       -- list, to avoid bleating about re-exporting a deprecated
+       -- thing (especially via 'module Foo' export item)
+   do   {
+        ; dflags <- getDynFlags
+        ; let is_main_mod = mainModIs dflags == this_mod
+        ; let default_main = case mainFunIs dflags of
+                 Just main_fun
+                     | is_main_mod -> mkUnqual varName (fsLit main_fun)
+                 _                 -> main_RDR_Unqual
+        ; has_main <- lookupGlobalOccRn_maybe default_main >>= return . isJust
+        -- If the module has no explicit header, and it has a main function,
+        -- then we add a header like "module Main(main) where ..." (#13839)
+        -- See Note [Modules without a module header]
+        ; let real_exports
+                 | explicit_mod = exports
+                 | has_main
+                          = Just (noLoc [noLoc (IEVar noExt
+                                     (noLoc (IEName $ noLoc default_main)))])
+                        -- ToDo: the 'noLoc' here is unhelpful if 'main'
+                        --       turns out to be out of scope
+                 | otherwise = Nothing
+
+        ; let do_it = exports_from_avail real_exports rdr_env imports this_mod
+        ; (rn_exports, final_avails)
+            <- if hsc_src == HsigFile
+                then do (mb_r, msgs) <- tryTc do_it
+                        case mb_r of
+                            Just r  -> return r
+                            Nothing -> addMessages msgs >> failM
+                else checkNoErrs do_it
+        ; let final_ns     = availsToNameSetWithSelectors final_avails
+
+        ; traceRn "rnExports: Exports:" (ppr final_avails)
+
+        ; let new_tcg_env =
+                  tcg_env { tcg_exports    = final_avails,
+                             tcg_rn_exports = case tcg_rn_exports tcg_env of
+                                                Nothing -> Nothing
+                                                Just _  -> rn_exports,
+                            tcg_dus = tcg_dus tcg_env `plusDU`
+                                      usesOnly final_ns }
+        ; failIfErrsM
+        ; return new_tcg_env }
+
+exports_from_avail :: Maybe (Located [LIE GhcPs])
+                         -- ^ 'Nothing' means no explicit export list
+                   -> GlobalRdrEnv
+                   -> ImportAvails
+                         -- ^ Imported modules; this is used to test if a
+                         -- @module Foo@ export is valid (it's not valid
+                         -- if we didn't import @Foo@!)
+                   -> Module
+                   -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
+                         -- (Nothing, _) <=> no explicit export list
+                         -- if explicit export list is present it contains
+                         -- each renamed export item together with its exported
+                         -- names.
+
+exports_from_avail Nothing rdr_env _imports _this_mod
+   -- The same as (module M) where M is the current module name,
+   -- so that's how we handle it, except we also export the data family
+   -- when a data instance is exported.
+  = do {
+    ; warnMissingExportList <- woptM Opt_WarnMissingExportList
+    ; warnIfFlag Opt_WarnMissingExportList
+        warnMissingExportList
+        (missingModuleExportWarn $ moduleName _this_mod)
+    ; let avails =
+            map fix_faminst . gresToAvailInfo
+              . filter isLocalGRE . globalRdrEnvElts $ rdr_env
+    ; return (Nothing, avails) }
+  where
+    -- #11164: when we define a data instance
+    -- but not data family, re-export the family
+    -- Even though we don't check whether this is actually a data family
+    -- only data families can locally define subordinate things (`ns` here)
+    -- without locally defining (and instead importing) the parent (`n`)
+    fix_faminst (AvailTC n ns flds) =
+      let new_ns =
+            case ns of
+              [] -> [n]
+              (p:_) -> if p == n then ns else n:ns
+      in AvailTC n new_ns flds
+
+    fix_faminst avail = avail
+
+
+exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod
+  = do ie_avails <- accumExports do_litem rdr_items
+       let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families
+       return (Just ie_avails, final_exports)
+  where
+    do_litem :: ExportAccum -> LIE GhcPs
+             -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
+    do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
+
+    -- Maps a parent to its in-scope children
+    kids_env :: NameEnv [GlobalRdrElt]
+    kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
+
+    -- See Note [Avails of associated data families]
+    expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]
+    expand_tyty_gre (gre @ GRE { gre_name = me, gre_par = ParentIs p })
+      | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]
+    expand_tyty_gre gre = [gre]
+
+    imported_modules = [ imv_name imv
+                       | xs <- moduleEnvElts $ imp_mods imports
+                       , imv <- importedByUser xs ]
+
+    exports_from_item :: ExportAccum -> LIE GhcPs
+                      -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
+    exports_from_item (ExportAccum occs earlier_mods)
+                      (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod)))
+        | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M
+        = do { warnIfFlag Opt_WarnDuplicateExports True
+                          (dupModuleExport mod) ;
+               return Nothing }
+
+        | otherwise
+        = do { let { exportValid = (mod `elem` imported_modules)
+                                || (moduleName this_mod == mod)
+                   ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)
+                   ; new_exports = [ availFromGRE gre'
+                                   | (gre, _) <- gre_prs
+                                   , gre' <- expand_tyty_gre gre ]
+                   ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
+                   ; mods        = addOneToUniqSet earlier_mods mod
+                   }
+
+             ; checkErr exportValid (moduleNotImported mod)
+             ; warnIfFlag Opt_WarnDodgyExports
+                          (exportValid && null gre_prs)
+                          (nullModuleExport mod)
+
+             ; traceRn "efa" (ppr mod $$ ppr all_gres)
+             ; addUsedGREs all_gres
+
+             ; occs' <- check_occs ie occs new_exports
+                      -- This check_occs not only finds conflicts
+                      -- between this item and others, but also
+                      -- internally within this item.  That is, if
+                      -- 'M.x' is in scope in several ways, we'll have
+                      -- several members of mod_avails with the same
+                      -- OccName.
+             ; traceRn "export_mod"
+                       (vcat [ ppr mod
+                             , ppr new_exports ])
+
+             ; return (Just ( ExportAccum occs' mods
+                            , ( cL loc (IEModuleContents noExt lmod)
+                              , new_exports))) }
+
+    exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie)
+        | isDoc ie
+        = do new_ie <- lookup_doc_ie ie
+             return (Just (acc, (cL loc new_ie, [])))
+
+        | otherwise
+        = do (new_ie, avail) <- lookup_ie ie
+             if isUnboundName (ieName new_ie)
+                  then return Nothing    -- Avoid error cascade
+                  else do
+
+                    occs' <- check_occs ie occs [avail]
+
+                    return (Just ( ExportAccum occs' mods
+                                 , (cL loc new_ie, [avail])))
+
+    -------------
+    lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
+    lookup_ie (IEVar _ (dL->L l rdr))
+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
+             return (IEVar noExt (cL l (replaceWrappedName rdr name)), avail)
+
+    lookup_ie (IEThingAbs _ (dL->L l rdr))
+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
+             return (IEThingAbs noExt (cL l (replaceWrappedName rdr name))
+                    , avail)
+
+    lookup_ie ie@(IEThingAll _ n')
+        = do
+            (n, avail, flds) <- lookup_ie_all ie n'
+            let name = unLoc n
+            return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))
+                   , AvailTC name (name:avail) flds)
+
+
+    lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
+        = do
+            (lname, subs, avails, flds)
+              <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
+            (_, all_avail, all_flds) <-
+              case wc of
+                NoIEWildcard -> return (lname, [], [])
+                IEWildcard _ -> lookup_ie_all ie l
+            let name = unLoc lname
+            return (IEThingWith noExt (replaceLWrappedName l name) wc subs
+                                (flds ++ (map noLoc all_flds)),
+                    AvailTC name (name : avails ++ all_avail)
+                                 (map unLoc flds ++ all_flds))
+
+
+    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
+
+
+    lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
+                   -> RnM (Located Name, [LIEWrappedName Name], [Name],
+                           [Located FieldLabel])
+    lookup_ie_with (dL->L l rdr) sub_rdrs
+        = do name <- lookupGlobalOccRn $ ieWrappedName rdr
+             (non_flds, flds) <- lookupChildrenExport name sub_rdrs
+             if isUnboundName name
+                then return (cL l name, [], [name], [])
+                else return (cL l name, non_flds
+                            , map (ieWrappedName . unLoc) non_flds
+                            , flds)
+
+    lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
+                  -> RnM (Located Name, [Name], [FieldLabel])
+    lookup_ie_all ie (dL->L l rdr) =
+          do name <- lookupGlobalOccRn $ ieWrappedName rdr
+             let gres = findChildren kids_env name
+                 (non_flds, flds) = classifyGREs gres
+             addUsedKids (ieWrappedName rdr) gres
+             warnDodgyExports <- woptM Opt_WarnDodgyExports
+             when (null gres) $
+                  if isTyConName name
+                  then when warnDodgyExports $
+                           addWarn (Reason Opt_WarnDodgyExports)
+                                   (dodgyExportWarn name)
+                  else -- This occurs when you export T(..), but
+                       -- only import T abstractly, or T is a synonym.
+                       addErr (exportItemErr ie)
+             return (cL l name, non_flds, flds)
+
+    -------------
+    lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
+    lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc
+                                           return (IEGroup noExt lev rn_doc)
+    lookup_doc_ie (IEDoc _ doc)       = do rn_doc <- rnHsDoc doc
+                                           return (IEDoc noExt rn_doc)
+    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExt str)
+    lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier
+
+    -- In an export item M.T(A,B,C), we want to treat the uses of
+    -- A,B,C as if they were M.A, M.B, M.C
+    -- Happily pickGREs does just the right thing
+    addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
+    addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
+
+classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
+classifyGREs = partitionEithers . map classifyGRE
+
+classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
+classifyGRE gre = case gre_par gre of
+  FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
+  FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
+  _                      -> Left  n
+  where
+    n = gre_name gre
+
+isDoc :: IE GhcPs -> Bool
+isDoc (IEDoc {})      = True
+isDoc (IEDocNamed {}) = True
+isDoc (IEGroup {})    = True
+isDoc _ = False
+
+-- Renaming and typechecking of exports happens after everything else has
+-- been typechecked.
+
+{-
+Note [Modules without a module header]
+--------------------------------------------------
+
+The Haskell 2010 report says in section 5.1:
+
+>> An abbreviated form of module, consisting only of the module body, is
+>> permitted. If this is used, the header is assumed to be
+>> ‘module Main(main) where’.
+
+For modules without a module header, this is implemented the
+following way:
+
+If the module has a main function:
+   Then create a module header and export the main function.
+   This has the effect to mark the main function and all top level
+   functions called directly or indirectly via main as 'used',
+   and later on, unused top-level functions can be reported correctly.
+   There is no distinction between GHC and GHCi.
+If the module has NO main function:
+   Then export all top-level functions. This marks all top level
+   functions as 'used'.
+   In GHCi this has the effect, that we don't get any 'non-used' warnings.
+   In GHC, however, the 'has-main-module' check in the module
+   compiler/typecheck/TcRnDriver (functions checkMain / check-main) fires,
+   and we get the error:
+      The IO action ‘main’ is not defined in module ‘Main’
+-}
+
+
+-- Renaming exports lists is a minefield. Five different things can appear in
+-- children export lists ( T(A, B, C) ).
+-- 1. Record selectors
+-- 2. Type constructors
+-- 3. Data constructors
+-- 4. Pattern Synonyms
+-- 5. Pattern Synonym Selectors
+--
+-- However, things get put into weird name spaces.
+-- 1. Some type constructors are parsed as variables (-.->) for example.
+-- 2. All data constructors are parsed as type constructors
+-- 3. When there is ambiguity, we default type constructors to data
+-- constructors and require the explicit `type` keyword for type
+-- constructors.
+--
+-- This function first establishes the possible namespaces that an
+-- identifier might be in (`choosePossibleNameSpaces`).
+--
+-- Then for each namespace in turn, tries to find the correct identifier
+-- there returning the first positive result or the first terminating
+-- error.
+--
+
+
+
+lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
+                     -> RnM ([LIEWrappedName Name], [Located FieldLabel])
+lookupChildrenExport spec_parent rdr_items =
+  do
+    xs <- mapAndReportM doOne rdr_items
+    return $ partitionEithers xs
+    where
+        -- Pick out the possible namespaces in order of priority
+        -- This is a consequence of how the parser parses all
+        -- data constructors as type constructors.
+        choosePossibleNamespaces :: NameSpace -> [NameSpace]
+        choosePossibleNamespaces ns
+          | ns == varName = [varName, tcName]
+          | ns == tcName  = [dataName, tcName]
+          | otherwise = [ns]
+        -- Process an individual child
+        doOne :: LIEWrappedName RdrName
+              -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
+        doOne n = do
+
+          let bareName = (ieWrappedName . unLoc) n
+              lkup v = lookupSubBndrOcc_helper False True
+                        spec_parent (setRdrNameSpace bareName v)
+
+          name <-  combineChildLookupResult $ map lkup $
+                   choosePossibleNamespaces (rdrNameSpace bareName)
+          traceRn "lookupChildrenExport" (ppr name)
+          -- Default to data constructors for slightly better error
+          -- messages
+          let unboundName :: RdrName
+              unboundName = if rdrNameSpace bareName == varName
+                                then bareName
+                                else setRdrNameSpace bareName dataName
+
+          case name of
+            NameNotFound -> do { ub <- reportUnboundName unboundName
+                               ; let l = getLoc n
+                               ; return (Left (cL l (IEName (cL l ub))))}
+            FoundFL fls -> return $ Right (cL (getLoc n) fls)
+            FoundName par name -> do { checkPatSynParent spec_parent par name
+                                     ; return
+                                       $ Left (replaceLWrappedName n name) }
+            IncorrectParent p g td gs -> failWithDcErr p g td gs
+
+
+-- Note: [Typing Pattern Synonym Exports]
+-- It proved quite a challenge to precisely specify which pattern synonyms
+-- should be allowed to be bundled with which type constructors.
+-- In the end it was decided to be quite liberal in what we allow. Below is
+-- how Simon described the implementation.
+--
+-- "Personally I think we should Keep It Simple.  All this talk of
+--  satisfiability makes me shiver.  I suggest this: allow T( P ) in all
+--   situations except where `P`'s type is ''visibly incompatible'' with
+--   `T`.
+--
+--    What does "visibly incompatible" mean?  `P` is visibly incompatible
+--    with
+--     `T` if
+--       * `P`'s type is of form `... -> S t1 t2`
+--       * `S` is a data/newtype constructor distinct from `T`
+--
+--  Nothing harmful happens if we allow `P` to be exported with
+--  a type it can't possibly be useful for, but specifying a tighter
+--  relationship is very awkward as you have discovered."
+--
+-- Note that this allows *any* pattern synonym to be bundled with any
+-- datatype type constructor. For example, the following pattern `P` can be
+-- bundled with any type.
+--
+-- ```
+-- pattern P :: (A ~ f) => f
+-- ```
+--
+-- So we provide basic type checking in order to help the user out, most
+-- pattern synonyms are defined with definite type constructors, but don't
+-- actually prevent a library author completely confusing their users if
+-- they want to.
+--
+-- So, we check for exactly four things
+-- 1. The name arises from a pattern synonym definition. (Either a pattern
+--    synonym constructor or a pattern synonym selector)
+-- 2. The pattern synonym is only bundled with a datatype or newtype.
+-- 3. Check that the head of the result type constructor is an actual type
+--    constructor and not a type variable. (See above example)
+-- 4. Is so, check that this type constructor is the same as the parent
+--    type constructor.
+--
+--
+-- Note: [Types of TyCon]
+--
+-- This check appears to be overlly complicated, Richard asked why it
+-- is not simply just `isAlgTyCon`. The answer for this is that
+-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
+-- (It is either a newtype or data depending on the number of methods)
+--
+
+-- | Given a resolved name in the children export list and a parent. Decide
+-- whether we are allowed to export the child with the parent.
+-- Invariant: gre_par == NoParent
+-- See note [Typing Pattern Synonym Exports]
+checkPatSynParent :: Name    -- ^ Alleged parent type constructor
+                             -- User wrote T( P, Q )
+                  -> Parent  -- The parent of P we discovered
+                  -> Name    -- ^ Either a
+                             --   a) Pattern Synonym Constructor
+                             --   b) A pattern synonym selector
+                  -> TcM ()  -- Fails if wrong parent
+checkPatSynParent _ (ParentIs {}) _
+  = return ()
+
+checkPatSynParent _ (FldParent {}) _
+  = return ()
+
+checkPatSynParent parent NoParent mpat_syn
+  | isUnboundName parent -- Avoid an error cascade
+  = return ()
+
+  | otherwise
+  = do { parent_ty_con <- tcLookupTyCon parent
+       ; mpat_syn_thing <- tcLookupGlobal mpat_syn
+
+        -- 1. Check that the Id was actually from a thing associated with patsyns
+       ; case mpat_syn_thing of
+            AnId i | isId i
+                   , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
+                   -> handle_pat_syn (selErr i) parent_ty_con p
+
+            AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
+
+            _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
+  where
+    psErr  = exportErrCtxt "pattern synonym"
+    selErr = exportErrCtxt "pattern synonym record selector"
+
+    assocClassErr :: SDoc
+    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."
+
+    handle_pat_syn :: SDoc
+                   -> TyCon      -- ^ Parent TyCon
+                   -> PatSyn     -- ^ Corresponding bundled PatSyn
+                                 --   and pretty printed origin
+                   -> TcM ()
+    handle_pat_syn doc ty_con pat_syn
+
+      -- 2. See note [Types of TyCon]
+      | not $ isTyConWithSrcDataCons ty_con
+      = addErrCtxt doc $ failWithTc assocClassErr
+
+      -- 3. Is the head a type variable?
+      | Nothing <- mtycon
+      = return ()
+      -- 4. Ok. Check they are actually the same type constructor.
+
+      | Just p_ty_con <- mtycon, p_ty_con /= ty_con
+      = addErrCtxt doc $ failWithTc typeMismatchError
+
+      -- 5. We passed!
+      | otherwise
+      = return ()
+
+      where
+        expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
+        (_, _, _, _, _, res_ty) = patSynSig pat_syn
+        mtycon = fst <$> tcSplitTyConApp_maybe res_ty
+        typeMismatchError :: SDoc
+        typeMismatchError =
+          text "Pattern synonyms can only be bundled with matching type constructors"
+              $$ text "Couldn't match expected type of"
+              <+> quotes (ppr expected_res_ty)
+              <+> text "with actual type of"
+              <+> quotes (ppr res_ty)
+
+
+{-===========================================================================-}
+check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
+           -> RnM ExportOccMap
+check_occs ie occs avails
+  -- 'names' and 'fls' are the entities specified by 'ie'
+  = foldlM check occs names_with_occs
+  where
+    -- Each Name specified by 'ie', paired with the OccName used to
+    -- refer to it in the GlobalRdrEnv
+    -- (see Note [Representing fields in AvailInfo] in Avail).
+    --
+    -- We check for export clashes using the selector Name, but need
+    -- the field label OccName for presenting error messages.
+    names_with_occs = availsNamesWithOccs avails
+
+    check occs (name, occ)
+      = case lookupOccEnv occs name_occ of
+          Nothing -> return (extendOccEnv occs name_occ (name, ie))
+
+          Just (name', ie')
+            | name == name'   -- Duplicate export
+            -- But we don't want to warn if the same thing is exported
+            -- by two different module exports. See ticket #4478.
+            -> do { warnIfFlag Opt_WarnDuplicateExports
+                               (not (dupExport_ok name ie ie'))
+                               (dupExportWarn occ ie ie')
+                  ; return occs }
+
+            | otherwise    -- Same occ name but different names: an error
+            ->  do { global_env <- getGlobalRdrEnv ;
+                     addErr (exportClashErr global_env occ name' name ie' ie) ;
+                     return occs }
+      where
+        name_occ = nameOccName name
+
+
+dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
+-- The Name is exported by both IEs. Is that ok?
+-- "No"  iff the name is mentioned explicitly in both IEs
+--        or one of the IEs mentions the name *alone*
+-- "Yes" otherwise
+--
+-- Examples of "no":  module M( f, f )
+--                    module M( fmap, Functor(..) )
+--                    module M( module Data.List, head )
+--
+-- Example of "yes"
+--    module M( module A, module B ) where
+--        import A( f )
+--        import B( f )
+--
+-- Example of "yes" (#2436)
+--    module M( C(..), T(..) ) where
+--         class C a where { data T a }
+--         instance C Int where { data T Int = TInt }
+--
+-- Example of "yes" (#2436)
+--    module Foo ( T ) where
+--      data family T a
+--    module Bar ( T(..), module Foo ) where
+--        import Foo
+--        data instance T Int = TInt
+
+dupExport_ok n ie1 ie2
+  = not (  single ie1 || single ie2
+        || (explicit_in ie1 && explicit_in ie2) )
+  where
+    explicit_in (IEModuleContents {}) = False                   -- module M
+    explicit_in (IEThingAll _ r)
+      = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)
+    explicit_in _              = True
+
+    single IEVar {}      = True
+    single IEThingAbs {} = True
+    single _               = False
+
+
+dupModuleExport :: ModuleName -> SDoc
+dupModuleExport mod
+  = hsep [text "Duplicate",
+          quotes (text "Module" <+> ppr mod),
+          text "in export list"]
+
+moduleNotImported :: ModuleName -> SDoc
+moduleNotImported mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "is not imported"]
+
+nullModuleExport :: ModuleName -> SDoc
+nullModuleExport mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "exports nothing"]
+
+missingModuleExportWarn :: ModuleName -> SDoc
+missingModuleExportWarn mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "is missing an export list"]
+
+
+dodgyExportWarn :: Name -> SDoc
+dodgyExportWarn item
+  = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)
+
+exportErrCtxt :: Outputable o => String -> o -> SDoc
+exportErrCtxt herald exp =
+  text "In the" <+> text (herald ++ ":") <+> ppr exp
+
+
+addExportErrCtxt :: (OutputableBndrId (GhcPass p))
+                 => IE (GhcPass p) -> TcM a -> TcM a
+addExportErrCtxt ie = addErrCtxt exportCtxt
+  where
+    exportCtxt = text "In the export:" <+> ppr ie
+
+exportItemErr :: IE GhcPs -> SDoc
+exportItemErr export_item
+  = sep [ text "The export item" <+> quotes (ppr export_item),
+          text "attempts to export constructors or class methods that are not visible here" ]
+
+
+dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc
+dupExportWarn occ_name ie1 ie2
+  = hsep [quotes (ppr occ_name),
+          text "is exported by", quotes (ppr ie1),
+          text "and",            quotes (ppr ie2)]
+
+dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc
+dcErrMsg ty_con what_is thing parents =
+          text "The type constructor" <+> quotes (ppr ty_con)
+                <+> text "is not the parent of the" <+> text what_is
+                <+> quotes thing <> char '.'
+                $$ text (capitalise what_is)
+                <> text "s can only be exported with their parent type constructor."
+                $$ (case parents of
+                      [] -> empty
+                      [_] -> text "Parent:"
+                      _  -> text "Parents:") <+> fsep (punctuate comma parents)
+
+failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
+failWithDcErr parent thing thing_doc parents = do
+  ty_thing <- tcLookupGlobal thing
+  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
+                        thing_doc (map ppr parents)
+  where
+    tyThingCategory' :: TyThing -> String
+    tyThingCategory' (AnId i)
+      | isRecordSelector i = "record selector"
+    tyThingCategory' i = tyThingCategory i
+
+
+exportClashErr :: GlobalRdrEnv -> OccName
+               -> Name -> Name
+               -> IE GhcPs -> IE GhcPs
+               -> MsgDoc
+exportClashErr global_env occ name1 name2 ie1 ie2
+  = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
+         , ppr_export ie1' name1'
+         , ppr_export ie2' name2' ]
+  where
+    ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
+                                       quotes (ppr_name name))
+                                    2 (pprNameProvenance (get_gre name)))
+
+    -- DuplicateRecordFields means that nameOccName might be a mangled
+    -- $sel-prefixed thing, in which case show the correct OccName alone
+    ppr_name name
+      | nameOccName name == occ = ppr name
+      | otherwise               = ppr occ
+
+    -- get_gre finds a GRE for the Name, so that we can show its provenance
+    get_gre name
+        = fromMaybe (pprPanic "exportClashErr" (ppr name))
+                    (lookupGRE_Name_OccName global_env name occ)
+    get_loc name = greSrcSpan (get_gre name)
+    (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
+                                   then (name1, ie1, name2, ie2)
+                                   else (name2, ie2, name1, ie1)
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -0,0 +1,2051 @@
+{-
+(c) The University of Glasgow 2006
+
+
+Functions for working with the typechecker environment (setters, getters...).
+-}
+
+{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ViewPatterns #-}
+
+
+module TcRnMonad(
+  -- * Initalisation
+  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
+
+  -- * Simple accessors
+  discardResult,
+  getTopEnv, updTopEnv, getGblEnv, updGblEnv,
+  setGblEnv, getLclEnv, updLclEnv, setLclEnv,
+  getEnvs, setEnvs,
+  xoptM, doptM, goptM, woptM,
+  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
+  whenDOptM, whenGOptM, whenWOptM,
+  whenXOptM, unlessXOptM,
+  getGhcMode,
+  withDoDynamicToo,
+  getEpsVar,
+  getEps,
+  updateEps, updateEps_,
+  getHpt, getEpsAndHpt,
+
+  -- * Arrow scopes
+  newArrowScope, escapeArrowScope,
+
+  -- * Unique supply
+  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
+  newSysName, newSysLocalId, newSysLocalIds,
+
+  -- * Accessing input/output
+  newTcRef, readTcRef, writeTcRef, updTcRef,
+
+  -- * Debugging
+  traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser,
+  traceTcRnWithStyle,
+  getPrintUnqualified,
+  printForUserTcRn,
+  traceIf, traceHiDiffs, traceOptIf,
+  debugTc,
+
+  -- * Typechecker global environment
+  getIsGHCi, getGHCiMonad, getInteractivePrintName,
+  tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
+  getRdrEnvs, getImports,
+  getFixityEnv, extendFixityEnv, getRecFieldEnv,
+  getDeclaredDefaultTys,
+  addDependentFiles,
+
+  -- * Error management
+  getSrcSpanM, setSrcSpan, addLocM,
+  wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,
+  getErrsVar, setErrsVar,
+  addErr,
+  failWith, failAt,
+  addErrAt, addErrs,
+  checkErr,
+  addMessages,
+  discardWarnings,
+
+  -- * Shared error message stuff: renamer and typechecker
+  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
+  attemptM, tryTc,
+  askNoErrs, discardErrs, tryTcDiscardingErrs,
+  checkNoErrs, whenNoErrs,
+  ifErrsM, failIfErrsM,
+  checkTH, failTH,
+
+  -- * Context management for the type checker
+  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
+  addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
+
+  -- * Error message generation (type checker)
+  addErrTc, addErrsTc,
+  addErrTcM, mkErrTcM, mkErrTc,
+  failWithTc, failWithTcM,
+  checkTc, checkTcM,
+  failIfTc, failIfTcM,
+  warnIfFlag, warnIf, warnTc, warnTcM,
+  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
+  mkErrInfo,
+
+  -- * Type constraints
+  newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
+  addTcEvBind, addTopEvBinds,
+  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+  chooseUniqueOccTc,
+  getConstraintVar, setConstraintVar,
+  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
+  emitImplication, emitImplications, emitInsoluble,
+  discardConstraints, captureConstraints, tryCaptureConstraints,
+  pushLevelAndCaptureConstraints,
+  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
+  getTcLevel, setTcLevel, isTouchableTcM,
+  getLclTypeEnv, setLclTypeEnv,
+  traceTcConstraints, emitWildCardHoleConstraints,
+
+  -- * Template Haskell context
+  recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
+  getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
+  addModFinalizersWithLclEnv,
+
+  -- * Safe Haskell context
+  recordUnsafeInfer, finalSafeMode, fixSafeInstances,
+
+  -- * Stuff for the renamer's local env
+  getLocalRdrEnv, setLocalRdrEnv,
+
+  -- * Stuff for interface decls
+  mkIfLclEnv,
+  initIfaceTcRn,
+  initIfaceCheck,
+  initIfaceLcl,
+  initIfaceLclWithSubst,
+  initIfaceLoad,
+  getIfModule,
+  failIfM,
+  forkM_maybe,
+  forkM,
+  setImplicitEnvM,
+
+  withException,
+
+  -- * Stuff for cost centres.
+  ContainsCostCentreState(..), getCCIndexM,
+
+  -- * Types etc.
+  module TcRnTypes,
+  module IOEnv
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes        -- Re-export all
+import IOEnv            -- Re-export all
+import TcEvidence
+
+import HsSyn hiding (LIE)
+import HscTypes
+import Module
+import RdrName
+import Name
+import Type
+
+import TcType
+import InstEnv
+import FamInstEnv
+import PrelNames
+
+import Id
+import VarSet
+import VarEnv
+import ErrUtils
+import SrcLoc
+import NameEnv
+import NameSet
+import Bag
+import Outputable
+import UniqSupply
+import DynFlags
+import FastString
+import Panic
+import Util
+import Annotations
+import BasicTypes( TopLevelFlag )
+import Maybes
+import CostCentreState
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.IORef
+import Control.Monad
+import Data.Set ( Set )
+import qualified Data.Set as Set
+
+import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )
+
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+                        initTc
+*                                                                      *
+************************************************************************
+-}
+
+-- | Setup the initial typechecking environment
+initTc :: HscEnv
+       -> HscSource
+       -> Bool          -- True <=> retain renamed syntax trees
+       -> Module
+       -> RealSrcSpan
+       -> TcM r
+       -> IO (Messages, Maybe r)
+                -- Nothing => error thrown by the thing inside
+                -- (error messages should have been printed already)
+
+initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
+ = do { keep_var     <- newIORef emptyNameSet ;
+        used_gre_var <- newIORef [] ;
+        th_var       <- newIORef False ;
+        th_splice_var<- newIORef False ;
+        th_locs_var  <- newIORef Set.empty ;
+        infer_var    <- newIORef (True, emptyBag) ;
+        dfun_n_var   <- newIORef emptyOccSet ;
+        type_env_var <- case hsc_type_env_var hsc_env of {
+                           Just (_mod, te_var) -> return te_var ;
+                           Nothing             -> newIORef emptyNameEnv } ;
+
+        dependent_files_var <- newIORef [] ;
+        static_wc_var       <- newIORef emptyWC ;
+        cc_st_var           <- newIORef newCostCentreState ;
+        th_topdecls_var      <- newIORef [] ;
+        th_foreign_files_var <- newIORef [] ;
+        th_topnames_var      <- newIORef emptyNameSet ;
+        th_modfinalizers_var <- newIORef [] ;
+        th_coreplugins_var <- newIORef [] ;
+        th_state_var         <- newIORef Map.empty ;
+        th_remote_state_var  <- newIORef Nothing ;
+        let {
+             dflags = hsc_dflags hsc_env ;
+
+             maybe_rn_syntax :: forall a. a -> Maybe a ;
+             maybe_rn_syntax empty_val
+                | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+                | gopt Opt_WriteHie dflags       = Just empty_val
+
+                  -- We want to serialize the documentation in the .hi-files,
+                  -- and need to extract it from the renamed syntax first.
+                  -- See 'ExtractDocs.extractDocs'.
+                | gopt Opt_Haddock dflags       = Just empty_val
+
+                | keep_rn_syntax                = Just empty_val
+                | otherwise                     = Nothing ;
+
+             gbl_env = TcGblEnv {
+                tcg_th_topdecls      = th_topdecls_var,
+                tcg_th_foreign_files = th_foreign_files_var,
+                tcg_th_topnames      = th_topnames_var,
+                tcg_th_modfinalizers = th_modfinalizers_var,
+                tcg_th_coreplugins = th_coreplugins_var,
+                tcg_th_state         = th_state_var,
+                tcg_th_remote_state  = th_remote_state_var,
+
+                tcg_mod            = mod,
+                tcg_semantic_mod   =
+                    canonicalizeModuleIfHome dflags mod,
+                tcg_src            = hsc_src,
+                tcg_rdr_env        = emptyGlobalRdrEnv,
+                tcg_fix_env        = emptyNameEnv,
+                tcg_field_env      = emptyNameEnv,
+                tcg_default        = if moduleUnitId mod == primUnitId
+                                     then Just []  -- See Note [Default types]
+                                     else Nothing,
+                tcg_type_env       = emptyNameEnv,
+                tcg_type_env_var   = type_env_var,
+                tcg_inst_env       = emptyInstEnv,
+                tcg_fam_inst_env   = emptyFamInstEnv,
+                tcg_ann_env        = emptyAnnEnv,
+                tcg_th_used        = th_var,
+                tcg_th_splice_used = th_splice_var,
+                tcg_th_top_level_locs
+                                   = th_locs_var,
+                tcg_exports        = [],
+                tcg_imports        = emptyImportAvails,
+                tcg_used_gres     = used_gre_var,
+                tcg_dus            = emptyDUs,
+
+                tcg_rn_imports     = [],
+                tcg_rn_exports     =
+                    if hsc_src == HsigFile
+                        -- Always retain renamed syntax, so that we can give
+                        -- better errors.  (TODO: how?)
+                        then Just []
+                        else maybe_rn_syntax [],
+                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
+                tcg_tr_module      = Nothing,
+                tcg_binds          = emptyLHsBinds,
+                tcg_imp_specs      = [],
+                tcg_sigs           = emptyNameSet,
+                tcg_ev_binds       = emptyBag,
+                tcg_warns          = NoWarnings,
+                tcg_anns           = [],
+                tcg_tcs            = [],
+                tcg_insts          = [],
+                tcg_fam_insts      = [],
+                tcg_rules          = [],
+                tcg_fords          = [],
+                tcg_patsyns        = [],
+                tcg_merged         = [],
+                tcg_dfun_n         = dfun_n_var,
+                tcg_keep           = keep_var,
+                tcg_doc_hdr        = Nothing,
+                tcg_hpc            = False,
+                tcg_main           = Nothing,
+                tcg_self_boot      = NoSelfBoot,
+                tcg_safeInfer      = infer_var,
+                tcg_dependent_files = dependent_files_var,
+                tcg_tc_plugins     = [],
+                tcg_top_loc        = loc,
+                tcg_static_wc      = static_wc_var,
+                tcg_complete_matches = [],
+                tcg_cc_st          = cc_st_var
+             } ;
+        } ;
+
+        -- OK, here's the business end!
+        initTcWithGbl hsc_env gbl_env loc do_this
+    }
+
+-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
+initTcWithGbl :: HscEnv
+              -> TcGblEnv
+              -> RealSrcSpan
+              -> TcM r
+              -> IO (Messages, Maybe r)
+initTcWithGbl hsc_env gbl_env loc do_this
+ = do { tvs_var      <- newIORef emptyVarSet
+      ; lie_var      <- newIORef emptyWC
+      ; errs_var     <- newIORef (emptyBag, emptyBag)
+      ; let lcl_env = TcLclEnv {
+                tcl_errs       = errs_var,
+                tcl_loc        = loc,     -- Should be over-ridden very soon!
+                tcl_ctxt       = [],
+                tcl_rdr        = emptyLocalRdrEnv,
+                tcl_th_ctxt    = topStage,
+                tcl_th_bndrs   = emptyNameEnv,
+                tcl_arrow_ctxt = NoArrowCtxt,
+                tcl_env        = emptyNameEnv,
+                tcl_bndrs      = [],
+                tcl_tyvars     = tvs_var,
+                tcl_lie        = lie_var,
+                tcl_tclvl      = topTcLevel
+                }
+
+      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+                     do { r <- tryM do_this
+                        ; case r of
+                          Right res -> return (Just res)
+                          Left _    -> return Nothing }
+
+      -- Check for unsolved constraints
+      -- If we succeed (maybe_res = Just r), there should be
+      -- no unsolved constraints.  But if we exit via an
+      -- exception (maybe_res = Nothing), we may have skipped
+      -- solving, so don't panic then (#13466)
+      ; lie <- readIORef (tcl_lie lcl_env)
+      ; when (isJust maybe_res && not (isEmptyWC lie)) $
+        pprPanic "initTc: unsolved constraints" (ppr lie)
+
+        -- Collect any error messages
+      ; msgs <- readIORef (tcl_errs lcl_env)
+
+      ; let { final_res | errorsFound dflags msgs = Nothing
+                        | otherwise               = maybe_res }
+
+      ; return (msgs, final_res)
+      }
+  where dflags = hsc_dflags hsc_env
+
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
+-- Initialise the type checker monad for use in GHCi
+initTcInteractive hsc_env thing_inside
+  = initTc hsc_env HsSrcFile False
+           (icInteractiveModule (hsc_IC hsc_env))
+           (realSrcLocSpan interactive_src_loc)
+           thing_inside
+  where
+    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+
+{- Note [Default types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The Integer type is simply not available in package ghc-prim (it is
+declared in integer-gmp).  So we set the defaulting types to (Just
+[]), meaning there are no default types, rather then Nothing, which
+means "use the default default types of Integer, Double".
+
+If you don't do this, attempted defaulting in package ghc-prim causes
+an actual crash (attempting to look up the Integer type).
+
+
+************************************************************************
+*                                                                      *
+                Initialisation
+*                                                                      *
+************************************************************************
+-}
+
+initTcRnIf :: Char              -- Tag for unique supply
+           -> HscEnv
+           -> gbl -> lcl
+           -> TcRnIf gbl lcl a
+           -> IO a
+initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
+   = do { us     <- mkSplitUniqSupply uniq_tag ;
+        ; us_var <- newIORef us ;
+
+        ; let { env = Env { env_top = hsc_env,
+                            env_us  = us_var,
+                            env_gbl = gbl_env,
+                            env_lcl = lcl_env} }
+
+        ; runIOEnv env thing_inside
+        }
+
+{-
+************************************************************************
+*                                                                      *
+                Simple accessors
+*                                                                      *
+************************************************************************
+-}
+
+discardResult :: TcM a -> TcM ()
+discardResult a = a >> return ()
+
+getTopEnv :: TcRnIf gbl lcl HscEnv
+getTopEnv = do { env <- getEnv; return (env_top env) }
+
+updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
+                          env { env_top = upd top })
+
+getGblEnv :: TcRnIf gbl lcl gbl
+getGblEnv = do { Env{..} <- getEnv; return env_gbl }
+
+updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
+                          env { env_gbl = upd gbl })
+
+setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
+
+getLclEnv :: TcRnIf gbl lcl lcl
+getLclEnv = do { Env{..} <- getEnv; return env_lcl }
+
+updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
+                          env { env_lcl = upd lcl })
+
+setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
+setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRnIf gbl lcl (gbl, lcl)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
+
+-- Command-line flags
+
+xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
+xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
+
+doptM :: DumpFlag -> TcRnIf gbl lcl Bool
+doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
+
+goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
+goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
+
+woptM :: WarningFlag -> TcRnIf gbl lcl Bool
+woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
+
+setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
+
+unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
+
+unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetGOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
+
+unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetWOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
+
+-- | Do it flag is true
+whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenDOptM flag thing_inside = do b <- doptM flag
+                                 when b thing_inside
+
+whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenGOptM flag thing_inside = do b <- goptM flag
+                                 when b thing_inside
+
+whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenWOptM flag thing_inside = do b <- woptM flag
+                                 when b thing_inside
+
+whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenXOptM flag thing_inside = do b <- xoptM flag
+                                 when b thing_inside
+
+unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+unlessXOptM flag thing_inside = do b <- xoptM flag
+                                   unless b thing_inside
+
+getGhcMode :: TcRnIf gbl lcl GhcMode
+getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
+
+withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+withDoDynamicToo =
+  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
+              top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
+
+getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
+getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
+
+getEps :: TcRnIf gbl lcl ExternalPackageState
+getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
+
+-- | Update the external package state.  Returns the second result of the
+-- modifier function.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
+updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
+          -> TcRnIf gbl lcl a
+updateEps upd_fn = do
+  traceIf (text "updating EPS")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var upd_fn
+
+-- | Update the external package state.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
+updateEps_ :: (ExternalPackageState -> ExternalPackageState)
+           -> TcRnIf gbl lcl ()
+updateEps_ upd_fn = do
+  traceIf (text "updating EPS_")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
+
+getHpt :: TcRnIf gbl lcl HomePackageTable
+getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
+
+getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
+getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
+                  ; return (eps, hsc_HPT env) }
+
+-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
+-- an exception if it is an error.
+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
+withException do_this = do
+    r <- do_this
+    dflags <- getDynFlags
+    case r of
+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+        Succeeded result -> return result
+
+{-
+************************************************************************
+*                                                                      *
+                Arrow scopes
+*                                                                      *
+************************************************************************
+-}
+
+newArrowScope :: TcM a -> TcM a
+newArrowScope
+  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
+
+-- Return to the stored environment (from the enclosing proc)
+escapeArrowScope :: TcM a -> TcM a
+escapeArrowScope
+  = updLclEnv $ \ env ->
+    case tcl_arrow_ctxt env of
+      NoArrowCtxt       -> env
+      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
+                                   , tcl_lie = lie
+                                   , tcl_rdr = rdr_env }
+
+{-
+************************************************************************
+*                                                                      *
+                Unique supply
+*                                                                      *
+************************************************************************
+-}
+
+newUnique :: TcRnIf gbl lcl Unique
+newUnique
+ = do { env <- getEnv ;
+        let { u_var = env_us env } ;
+        us <- readMutVar u_var ;
+        case takeUniqFromSupply us of { (uniq, us') -> do {
+        writeMutVar u_var us' ;
+        return $! uniq }}}
+   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
+   -- a chain of unevaluated supplies behind.
+   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
+   -- throw away one half of the new split supply.  This is safe because this
+   -- is the only place we use that unique.  Using the other half of the split
+   -- supply is safer, but slower.
+
+newUniqueSupply :: TcRnIf gbl lcl UniqSupply
+newUniqueSupply
+ = do { env <- getEnv ;
+        let { u_var = env_us env } ;
+        us <- readMutVar u_var ;
+        case splitUniqSupply us of { (us1,us2) -> do {
+        writeMutVar u_var us1 ;
+        return us2 }}}
+
+cloneLocalName :: Name -> TcM Name
+-- Make a fresh Internal name with the same OccName and SrcSpan
+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
+
+newName :: OccName -> TcM Name
+newName occ = do { loc  <- getSrcSpanM
+                 ; newNameAt occ loc }
+
+newNameAt :: OccName -> SrcSpan -> TcM Name
+newNameAt occ span
+  = do { uniq <- newUnique
+       ; return (mkInternalName uniq occ span) }
+
+newSysName :: OccName -> TcRnIf gbl lcl Name
+newSysName occ
+  = do { uniq <- newUnique
+       ; return (mkSystemName uniq occ) }
+
+newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
+newSysLocalId fs ty
+  = do  { u <- newUnique
+        ; return (mkSysLocalOrCoVar fs u ty) }
+
+newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
+newSysLocalIds fs tys
+  = do  { us <- newUniqueSupply
+        ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
+
+instance MonadUnique (IOEnv (Env gbl lcl)) where
+        getUniqueM = newUnique
+        getUniqueSupplyM = newUniqueSupply
+
+{-
+************************************************************************
+*                                                                      *
+                Accessing input/output
+*                                                                      *
+************************************************************************
+-}
+
+newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
+newTcRef = newMutVar
+
+readTcRef :: TcRef a -> TcRnIf gbl lcl a
+readTcRef = readMutVar
+
+writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
+writeTcRef = writeMutVar
+
+updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
+-- Returns ()
+updTcRef ref fn = liftIO $ do { old <- readIORef ref
+                              ; writeIORef ref (fn old) }
+
+{-
+************************************************************************
+*                                                                      *
+                Debugging
+*                                                                      *
+************************************************************************
+-}
+
+
+-- Typechecker trace
+traceTc :: String -> SDoc -> TcRn ()
+traceTc =
+  labelledTraceOptTcRn Opt_D_dump_tc_trace
+
+-- Renamer Trace
+traceRn :: String -> SDoc -> TcRn ()
+traceRn =
+  labelledTraceOptTcRn Opt_D_dump_rn_trace
+
+-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
+-- but accepts a string as a label and formats the trace message uniformly.
+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
+labelledTraceOptTcRn flag herald doc = do
+   traceOptTcRn flag (formatTraceMsg herald doc)
+
+formatTraceMsg :: String -> SDoc -> SDoc
+formatTraceMsg herald doc = hang (text herald) 2 doc
+
+-- | Output a doc if the given 'DumpFlag' is set.
+--
+-- By default this logs to stdout
+-- However, if the `-ddump-to-file` flag is set,
+-- then this will dump output to a file
+--
+-- Just a wrapper for 'dumpSDoc'
+traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
+traceOptTcRn flag doc
+  = do { dflags <- getDynFlags
+       ; when (dopt flag dflags)
+              (traceTcRn flag doc)
+       }
+
+-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
+-- output generated by `-ddump-types` to be in 'PprUser' style. However,
+-- generally we want all other debugging output to use 'PprDump'
+-- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.
+
+-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.
+traceTcRn :: DumpFlag -> SDoc -> TcRn ()
+traceTcRn flag doc
+  = do { dflags  <- getDynFlags
+       ; printer <- getPrintUnqualified dflags
+       ; let dump_style = mkDumpStyle dflags printer
+       ; traceTcRnWithStyle dump_style dflags flag doc }
+
+-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.
+traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()
+-- Used by 'TcRnDriver.tcDump'.
+traceTcRnForUser flag doc
+  = do { dflags  <- getDynFlags
+       ; printer <- getPrintUnqualified dflags
+       ; let user_style = mkUserStyle dflags printer AllTheWay
+       ; traceTcRnWithStyle user_style dflags flag doc }
+
+traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()
+-- ^ Unconditionally dump some trace output
+--
+-- The DumpFlag is used only to set the output filename
+-- for --dump-to-file, not to decide whether or not to output
+-- That part is done by the caller
+traceTcRnWithStyle sty dflags flag doc
+  = do { real_doc <- prettyDoc dflags doc
+       ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc }
+  where
+    -- Add current location if -dppr-debug
+    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
+    prettyDoc dflags doc = if hasPprDebug dflags
+       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
+       else return doc -- The full location is usually way too much
+
+
+getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
+getPrintUnqualified dflags
+  = do { rdr_env <- getGlobalRdrEnv
+       ; return $ mkPrintUnqualified dflags rdr_env }
+
+-- | Like logInfoTcRn, but for user consumption
+printForUserTcRn :: SDoc -> TcRn ()
+printForUserTcRn doc
+  = do { dflags <- getDynFlags
+       ; printer <- getPrintUnqualified dflags
+       ; liftIO (printOutputForUser dflags printer doc) }
+
+{-
+traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
+available.  Alas, they behave inconsistently with the other stuff;
+e.g. are unaffected by -dump-to-file.
+-}
+
+traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
+traceIf      = traceOptIf Opt_D_dump_if_trace
+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
+
+
+traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
+traceOptIf flag doc
+  = whenDOptM flag $    -- No RdrEnv available, so qualify everything
+    do { dflags <- getDynFlags
+       ; liftIO (putMsg dflags doc) }
+
+{-
+************************************************************************
+*                                                                      *
+                Typechecker global environment
+*                                                                      *
+************************************************************************
+-}
+
+getIsGHCi :: TcRn Bool
+getIsGHCi = do { mod <- getModule
+               ; return (isInteractiveModule mod) }
+
+getGHCiMonad :: TcRn Name
+getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
+
+getInteractivePrintName :: TcRn Name
+getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
+
+tcIsHsBootOrSig :: TcRn Bool
+tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
+
+tcIsHsig :: TcRn Bool
+tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }
+
+tcSelfBootInfo :: TcRn SelfBootInfo
+tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
+
+getGlobalRdrEnv :: TcRn GlobalRdrEnv
+getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
+
+getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
+getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
+
+getImports :: TcRn ImportAvails
+getImports = do { env <- getGblEnv; return (tcg_imports env) }
+
+getFixityEnv :: TcRn FixityEnv
+getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
+
+extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
+extendFixityEnv new_bit
+  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
+                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
+
+getRecFieldEnv :: TcRn RecFieldEnv
+getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
+
+getDeclaredDefaultTys :: TcRn (Maybe [Type])
+getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
+
+addDependentFiles :: [FilePath] -> TcRn ()
+addDependentFiles fs = do
+  ref <- fmap tcg_dependent_files getGblEnv
+  dep_files <- readTcRef ref
+  writeTcRef ref (fs ++ dep_files)
+
+{-
+************************************************************************
+*                                                                      *
+                Error management
+*                                                                      *
+************************************************************************
+-}
+
+getSrcSpanM :: TcRn SrcSpan
+        -- Avoid clash with Name.getSrcLoc
+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
+
+setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
+setSrcSpan (RealSrcSpan real_loc) thing_inside
+    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
+-- Don't overwrite useful info with useless:
+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
+
+addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
+addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a
+
+wrapLocM :: (HasSrcSpan a, HasSrcSpan b) =>
+            (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
+-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
+wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a
+                                                ; return (cL loc b) }
+wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) =>
+               (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c)
+wrapLocFstM fn (dL->L loc a) =
+  setSrcSpan loc $ do
+    (b,c) <- fn a
+    return (cL loc b, c)
+
+wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) =>
+               (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)
+wrapLocSndM fn (dL->L loc a) =
+  setSrcSpan loc $ do
+    (b,c) <- fn a
+    return (b, cL loc c)
+
+wrapLocM_ :: HasSrcSpan a =>
+             (SrcSpanLess a -> TcM ()) -> a -> TcM ()
+wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a)
+
+-- Reporting errors
+
+getErrsVar :: TcRn (TcRef Messages)
+getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
+
+setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
+setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
+
+addErr :: MsgDoc -> TcRn ()
+addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
+
+failWith :: MsgDoc -> TcRn a
+failWith msg = addErr msg >> failM
+
+failAt :: SrcSpan -> MsgDoc -> TcRn a
+failAt loc msg = addErrAt loc msg >> failM
+
+addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
+-- addErrAt is mainly (exclusively?) used by the renamer, where
+-- tidying is not an issue, but it's all lazy so the extra
+-- work doesn't matter
+addErrAt loc msg = do { ctxt <- getErrCtxt
+                      ; tidy_env <- tcInitTidyEnv
+                      ; err_info <- mkErrInfo tidy_env ctxt
+                      ; addLongErrAt loc msg err_info }
+
+addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
+addErrs msgs = mapM_ add msgs
+             where
+               add (loc,msg) = addErrAt loc msg
+
+checkErr :: Bool -> MsgDoc -> TcRn ()
+-- Add the error if the bool is False
+checkErr ok msg = unless ok (addErr msg)
+
+addMessages :: Messages -> TcRn ()
+addMessages msgs1
+  = do { errs_var <- getErrsVar ;
+         msgs0 <- readTcRef errs_var ;
+         writeTcRef errs_var (unionMessages msgs0 msgs1) }
+
+discardWarnings :: TcRn a -> TcRn a
+-- Ignore warnings inside the thing inside;
+-- used to ignore-unused-variable warnings inside derived code
+discardWarnings thing_inside
+  = do  { errs_var <- getErrsVar
+        ; (old_warns, _) <- readTcRef errs_var
+
+        ; result <- thing_inside
+
+        -- Revert warnings to old_warns
+        ; (_new_warns, new_errs) <- readTcRef errs_var
+        ; writeTcRef errs_var (old_warns, new_errs)
+
+        ; return result }
+
+{-
+************************************************************************
+*                                                                      *
+        Shared error message stuff: renamer and typechecker
+*                                                                      *
+************************************************************************
+-}
+
+mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
+mkLongErrAt loc msg extra
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         return $ mkLongErrMsg dflags loc printer msg extra }
+
+mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
+mkErrDocAt loc errDoc
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         return $ mkErrDoc dflags loc printer errDoc }
+
+addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
+
+reportErrors :: [ErrMsg] -> TcM ()
+reportErrors = mapM_ reportError
+
+reportError :: ErrMsg -> TcRn ()
+reportError err
+  = do { traceTc "Adding error:" (pprLocErrMsg err) ;
+         errs_var <- getErrsVar ;
+         (warns, errs) <- readTcRef errs_var ;
+         writeTcRef errs_var (warns, errs `snocBag` err) }
+
+reportWarning :: WarnReason -> ErrMsg -> TcRn ()
+reportWarning reason err
+  = do { let warn = makeIntoWarning reason err
+                    -- 'err' was built by mkLongErrMsg or something like that,
+                    -- so it's of error severity.  For a warning we downgrade
+                    -- its severity to SevWarning
+
+       ; traceTc "Adding warning:" (pprLocErrMsg warn)
+       ; errs_var <- getErrsVar
+       ; (warns, errs) <- readTcRef errs_var
+       ; writeTcRef errs_var (warns `snocBag` warn, errs) }
+
+
+-----------------------
+checkNoErrs :: TcM r -> TcM r
+-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
+-- If m fails then (checkNoErrsTc m) fails.
+-- If m succeeds, it checks whether m generated any errors messages
+--      (it might have recovered internally)
+--      If so, it fails too.
+-- Regardless, any errors generated by m are propagated to the enclosing context.
+checkNoErrs main
+  = do  { (res, no_errs) <- askNoErrs main
+        ; unless no_errs failM
+        ; return res }
+
+-----------------------
+whenNoErrs :: TcM () -> TcM ()
+whenNoErrs thing = ifErrsM (return ()) thing
+
+ifErrsM :: TcRn r -> TcRn r -> TcRn r
+--      ifErrsM bale_out normal
+-- does 'bale_out' if there are errors in errors collection
+-- otherwise does 'normal'
+ifErrsM bale_out normal
+ = do { errs_var <- getErrsVar ;
+        msgs <- readTcRef errs_var ;
+        dflags <- getDynFlags ;
+        if errorsFound dflags msgs then
+           bale_out
+        else
+           normal }
+
+failIfErrsM :: TcRn ()
+-- Useful to avoid error cascades
+failIfErrsM = ifErrsM failM (return ())
+
+checkTH :: a -> String -> TcRn ()
+checkTH _ _ = return () -- OK
+
+failTH :: Outputable a => a -> String -> TcRn x
+failTH e what  -- Raise an error in a stage-1 compiler
+  = failWithTc (vcat [ hang (char 'A' <+> text what
+                             <+> text "requires GHC with interpreter support:")
+                          2 (ppr e)
+                     , text "Perhaps you are using a stage-1 compiler?" ])
+
+
+{- *********************************************************************
+*                                                                      *
+        Context management for the type checker
+*                                                                      *
+************************************************************************
+-}
+
+getErrCtxt :: TcM [ErrCtxt]
+getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
+
+setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
+setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
+
+-- | Add a fixed message to the error context. This message should not
+-- do any tidying.
+addErrCtxt :: MsgDoc -> TcM a -> TcM a
+addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+
+-- | Add a message to the error context. This message may do tidying.
+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+
+-- | Add a fixed landmark message to the error context. A landmark
+-- message is always sure to be reported, even if there is a lot of
+-- context. It also doesn't count toward the maximum number of contexts
+-- reported.
+addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
+
+-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
+-- and tidying.
+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
+
+-- Helper function for the above
+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
+                           env { tcl_ctxt = upd ctxt })
+
+popErrCtxt :: TcM a -> TcM a
+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
+
+getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
+getCtLocM origin t_or_k
+  = do { env <- getLclEnv
+       ; return (CtLoc { ctl_origin = origin
+                       , ctl_env    = env
+                       , ctl_t_or_k = t_or_k
+                       , ctl_depth  = initialSubGoalDepth }) }
+
+setCtLocM :: CtLoc -> TcM a -> TcM a
+-- Set the SrcSpan and error context from the CtLoc
+setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
+  = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl
+                           , tcl_bndrs = tcl_bndrs lcl
+                           , tcl_ctxt  = tcl_ctxt lcl })
+              thing_inside
+
+
+{- *********************************************************************
+*                                                                      *
+             Error recovery and exceptions
+*                                                                      *
+********************************************************************* -}
+
+tcTryM :: TcRn r -> TcRn (Maybe r)
+-- The most basic function: catch the exception
+--   Nothing => an exception happened
+--   Just r  => no exception, result R
+-- Errors and constraints are propagated in both cases
+-- Never throws an exception
+tcTryM thing_inside
+  = do { either_res <- tryM thing_inside
+       ; return (case either_res of
+                    Left _  -> Nothing
+                    Right r -> Just r) }
+         -- In the Left case the exception is always the IOEnv
+         -- built-in in exception; see IOEnv.failM
+
+-----------------------
+capture_constraints :: TcM r -> TcM (r, WantedConstraints)
+-- capture_constraints simply captures and returns the
+--                     constraints generated by thing_inside
+-- Precondition: thing_inside must not throw an exception!
+-- Reason for precondition: an exception would blow past the place
+-- where we read the lie_var, and we'd lose the constraints altogether
+capture_constraints thing_inside
+  = do { lie_var <- newTcRef emptyWC
+       ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
+                thing_inside
+       ; lie <- readTcRef lie_var
+       ; return (res, lie) }
+
+capture_messages :: TcM r -> TcM (r, Messages)
+-- capture_messages simply captures and returns the
+--                  errors arnd warnings generated by thing_inside
+-- Precondition: thing_inside must not throw an exception!
+-- Reason for precondition: an exception would blow past the place
+-- where we read the msg_var, and we'd lose the constraints altogether
+capture_messages thing_inside
+  = do { msg_var <- newTcRef emptyMessages
+       ; res     <- setErrsVar msg_var thing_inside
+       ; msgs    <- readTcRef msg_var
+       ; return (res, msgs) }
+
+-----------------------
+-- (askNoErrs m) runs m
+-- If m fails,
+--    then (askNoErrs m) fails, propagating only
+--         insoluble constraints
+--
+-- If m succeeds with result r,
+--    then (askNoErrs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+--
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+askNoErrs :: TcRn a -> TcRn (a, Bool)
+askNoErrs thing_inside
+  = do { ((mb_res, lie), msgs) <- capture_messages    $
+                                  capture_constraints $
+                                  tcTryM thing_inside
+       ; addMessages msgs
+
+       ; case mb_res of
+           Nothing  -> do { emitConstraints (insolublesOnly lie)
+                          ; failM }
+
+           Just res -> do { emitConstraints lie
+                          ; dflags <- getDynFlags
+                          ; let errs_found = errorsFound dflags msgs
+                                          || insolubleWC lie
+                          ; return (res, not errs_found) } }
+
+-----------------------
+tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
+-- (tryCaptureConstraints_maybe m) runs m,
+--   and returns the type constraints it generates
+-- It never throws an exception; instead if thing_inside fails,
+--   it returns Nothing and the /insoluble/ constraints
+-- Error messages are propagated
+tryCaptureConstraints thing_inside
+  = do { (mb_res, lie) <- capture_constraints $
+                          tcTryM thing_inside
+
+       -- See Note [Constraints and errors]
+       ; let lie_to_keep = case mb_res of
+                             Nothing -> insolublesOnly lie
+                             Just {} -> lie
+
+       ; return (mb_res, lie_to_keep) }
+
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+-- If thing_inside fails (throwing an exception),
+--   then (captureConstraints thing_inside) fails too
+--   propagating the insoluble constraints only
+-- Error messages are propagated in either case
+captureConstraints thing_inside
+  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
+
+            -- See Note [Constraints and errors]
+            -- If the thing_inside threw an exception, emit the insoluble
+            -- constraints only (returned by tryCaptureConstraints)
+            -- so that they are not lost
+       ; case mb_res of
+           Nothing  -> do { emitConstraints lie; failM }
+           Just res -> return (res, lie) }
+
+-----------------------
+attemptM :: TcRn r -> TcRn (Maybe r)
+-- (attemptM thing_inside) runs thing_inside
+-- If thing_inside succeeds, returning r,
+--   we return (Just r), and propagate all constraints and errors
+-- If thing_inside fail, throwing an exception,
+--   we return Nothing, propagating insoluble constraints,
+--                      and all errors
+-- attemptM never throws an exception
+attemptM thing_inside
+  = do { (mb_r, lie) <- tryCaptureConstraints thing_inside
+       ; emitConstraints lie
+
+       -- Debug trace
+       ; when (isNothing mb_r) $
+         traceTc "attemptM recovering with insoluble constraints" $
+                 (ppr lie)
+
+       ; return mb_r }
+
+-----------------------
+recoverM :: TcRn r      -- Recovery action; do this if the main one fails
+         -> TcRn r      -- Main action: do this first;
+                        --  if it generates errors, propagate them all
+         -> TcRn r
+-- (recoverM recover thing_inside) runs thing_inside
+-- If thing_inside fails, propagate its errors and insoluble constraints
+--                        and run 'recover'
+-- If thing_inside succeeds, propagate all its errors and constraints
+--
+-- Can fail, if 'recover' fails
+recoverM recover thing
+  = do { mb_res <- attemptM thing ;
+         case mb_res of
+           Nothing  -> recover
+           Just res -> return res }
+
+-----------------------
+
+-- | Drop elements of the input that fail, so the result
+-- list can be shorter than the argument list
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndRecoverM f xs
+  = do { mb_rs <- mapM (attemptM . f) xs
+       ; return [r | Just r <- mb_rs] }
+
+-- | Apply the function to all elements on the input list
+-- If all succeed, return the list of results
+-- Othewise fail, propagating all errors
+mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndReportM f xs
+  = do { mb_rs <- mapM (attemptM . f) xs
+       ; when (any isNothing mb_rs) failM
+       ; return [r | Just r <- mb_rs] }
+
+-- | The accumulator is not updated if the action fails
+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
+foldAndRecoverM _ acc []     = return acc
+foldAndRecoverM f acc (x:xs) =
+                          do { mb_r <- attemptM (f acc x)
+                             ; case mb_r of
+                                Nothing   -> foldAndRecoverM f acc xs
+                                Just acc' -> foldAndRecoverM f acc' xs  }
+
+-----------------------
+tryTc :: TcRn a -> TcRn (Maybe a, Messages)
+-- (tryTc m) executes m, and returns
+--      Just r,  if m succeeds (returning r)
+--      Nothing, if m fails
+-- It also returns all the errors and warnings accumulated by m
+-- It always succeeds (never raises an exception)
+tryTc thing_inside
+ = capture_messages (attemptM thing_inside)
+
+-----------------------
+discardErrs :: TcRn a -> TcRn a
+-- (discardErrs m) runs m,
+--   discarding all error messages and warnings generated by m
+-- If m fails, discardErrs fails, and vice versa
+discardErrs m
+ = do { errs_var <- newTcRef emptyMessages
+      ; setErrsVar errs_var m }
+
+-----------------------
+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
+-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
+--      if 'main' succeeds with no error messages, it's the answer
+--      otherwise discard everything from 'main', including errors,
+--          and try 'recover' instead.
+tryTcDiscardingErrs recover thing_inside
+  = do { ((mb_res, lie), msgs) <- capture_messages    $
+                                  capture_constraints $
+                                  tcTryM thing_inside
+        ; dflags <- getDynFlags
+        ; case mb_res of
+            Just res | not (errorsFound dflags msgs)
+                     , not (insolubleWC lie)
+              -> -- 'main' succeeed with no errors
+                 do { addMessages msgs  -- msgs might still have warnings
+                    ; emitConstraints lie
+                    ; return res }
+
+            _ -> -- 'main' failed, or produced an error message
+                 recover     -- Discard all errors and warnings
+                             -- and unsolved constraints entirely
+        }
+
+{-
+************************************************************************
+*                                                                      *
+             Error message generation (type checker)
+*                                                                      *
+************************************************************************
+
+    The addErrTc functions add an error message, but do not cause failure.
+    The 'M' variants pass a TidyEnv that has already been used to
+    tidy up the message; we then use it to tidy the context messages
+-}
+
+addErrTc :: MsgDoc -> TcM ()
+addErrTc err_msg = do { env0 <- tcInitTidyEnv
+                      ; addErrTcM (env0, err_msg) }
+
+addErrsTc :: [MsgDoc] -> TcM ()
+addErrsTc err_msgs = mapM_ addErrTc err_msgs
+
+addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
+addErrTcM (tidy_env, err_msg)
+  = do { ctxt <- getErrCtxt ;
+         loc  <- getSrcSpanM ;
+         add_err_tcm tidy_env err_msg loc ctxt }
+
+-- Return the error message, instead of reporting it straight away
+mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
+mkErrTcM (tidy_env, err_msg)
+  = do { ctxt <- getErrCtxt ;
+         loc  <- getSrcSpanM ;
+         err_info <- mkErrInfo tidy_env ctxt ;
+         mkLongErrAt loc err_msg err_info }
+
+mkErrTc :: MsgDoc -> TcM ErrMsg
+mkErrTc msg = do { env0 <- tcInitTidyEnv
+                 ; mkErrTcM (env0, msg) }
+
+-- The failWith functions add an error message and cause failure
+
+failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
+failWithTc err_msg
+  = addErrTc err_msg >> failM
+
+failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail
+failWithTcM local_and_msg
+  = addErrTcM local_and_msg >> failM
+
+checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
+checkTc True  _   = return ()
+checkTc False err = failWithTc err
+
+checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+checkTcM True  _   = return ()
+checkTcM False err = failWithTcM err
+
+failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false
+failIfTc False _   = return ()
+failIfTc True  err = failWithTc err
+
+failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+   -- Check that the boolean is false
+failIfTcM False _   = return ()
+failIfTcM True  err = failWithTcM err
+
+
+--         Warnings have no 'M' variant, nor failure
+
+-- | Display a warning if a condition is met,
+--   and the warning is enabled
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+  = do { warn_on <- woptM warn_flag
+       ; when (warn_on && is_bad) $
+         addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+  = when is_bad (addWarn NoReason msg)
+
+-- | Display a warning if a condition is met.
+warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
+warnTc reason warn_if_true warn_msg
+  | warn_if_true = addWarnTc reason warn_msg
+  | otherwise    = return ()
+
+-- | Display a warning if a condition is met.
+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM reason warn_if_true warn_msg
+  | warn_if_true = addWarnTcM reason warn_msg
+  | otherwise    = return ()
+
+-- | Display a warning in the current context.
+addWarnTc :: WarnReason -> MsgDoc -> TcM ()
+addWarnTc reason msg
+ = do { env0 <- tcInitTidyEnv ;
+      addWarnTcM reason (env0, msg) }
+
+-- | Display a warning in a given context.
+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM reason (env0, msg)
+ = do { ctxt <- getErrCtxt ;
+        err_info <- mkErrInfo env0 ctxt ;
+        add_warn reason msg err_info }
+
+-- | Display a warning for the current source location.
+addWarn :: WarnReason -> MsgDoc -> TcRn ()
+addWarn reason msg = add_warn reason msg Outputable.empty
+
+-- | Display a warning for a given source location.
+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
+
+-- | Display a warning, with an optional flag, for the current source
+-- location.
+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn reason msg extra_info
+  = do { loc <- getSrcSpanM
+       ; add_warn_at reason loc msg extra_info }
+
+-- | Display a warning, with an optional flag, for a given location.
+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn_at reason loc msg extra_info
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         let { warn = mkLongWarnMsg dflags loc printer
+                                    msg extra_info } ;
+         reportWarning reason warn }
+
+
+{-
+-----------------------------------
+        Other helper functions
+-}
+
+add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
+            -> [ErrCtxt]
+            -> TcM ()
+add_err_tcm tidy_env err_msg loc ctxt
+ = do { err_info <- mkErrInfo tidy_env ctxt ;
+        addLongErrAt loc err_msg err_info }
+
+mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
+-- Tidy the error info, trimming excessive contexts
+mkErrInfo env ctxts
+--  = do
+--       dbg <- hasPprDebug <$> getDynFlags
+--       if dbg                -- In -dppr-debug style the output
+--          then return empty  -- just becomes too voluminous
+--          else go dbg 0 env ctxts
+ = go False 0 env ctxts
+ where
+   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+   go _ _ _   [] = return empty
+   go dbg n env ((is_landmark, ctxt) : ctxts)
+     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
+     = do { (env', msg) <- ctxt env
+          ; let n' = if is_landmark then n else n+1
+          ; rest <- go dbg n' env' ctxts
+          ; return (msg $$ rest) }
+     | otherwise
+     = go dbg n env ctxts
+
+mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
+mAX_CONTEXTS = 3
+
+-- debugTc is useful for monadic debugging code
+
+debugTc :: TcM () -> TcM ()
+debugTc thing
+ | debugIsOn = thing
+ | otherwise = return ()
+
+{-
+************************************************************************
+*                                                                      *
+             Type constraints
+*                                                                      *
+************************************************************************
+-}
+
+addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
+addTopEvBinds new_ev_binds thing_inside
+  =updGblEnv upd_env thing_inside
+  where
+    upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
+                                               `unionBags` new_ev_binds }
+
+newTcEvBinds :: TcM EvBindsVar
+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
+                  ; tcvs_ref  <- newTcRef emptyVarSet
+                  ; uniq <- newUnique
+                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
+                  ; return (EvBindsVar { ebv_binds = binds_ref
+                                       , ebv_tcvs = tcvs_ref
+                                       , ebv_uniq = uniq }) }
+
+-- | Creates an EvBindsVar incapable of holding any bindings. It still
+-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus
+-- must be made monadically
+newNoTcEvBinds :: TcM EvBindsVar
+newNoTcEvBinds
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; uniq <- newUnique
+       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
+       ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
+                              , ebv_uniq = uniq }) }
+
+cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
+-- Clone the refs, so that any binding created when
+-- solving don't pollute the original
+cloneEvBindsVar ebv@(EvBindsVar {})
+  = do { binds_ref <- newTcRef emptyEvBindMap
+       ; tcvs_ref  <- newTcRef emptyVarSet
+       ; return (ebv { ebv_binds = binds_ref
+                     , ebv_tcvs = tcvs_ref }) }
+cloneEvBindsVar ebv@(CoEvBindsVar {})
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; return (ebv { ebv_tcvs = tcvs_ref }) }
+
+getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+  = readTcRef (ebv_tcvs ev_binds_var)
+
+getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
+getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
+  = readTcRef ev_ref
+getTcEvBindsMap (CoEvBindsVar {})
+  = return emptyEvBindMap
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
+  = writeTcRef ev_ref binds
+setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
+  | isEmptyEvBindMap ev_binds
+  = return ()
+  | otherwise
+  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
+
+addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
+-- Add a binding to the TcEvBinds by side effect
+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
+  = do { traceTc "addTcEvBind" $ ppr u $$
+                                 ppr ev_bind
+       ; bnds <- readTcRef ev_ref
+       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
+addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
+  = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
+
+chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
+chooseUniqueOccTc fn =
+  do { env <- getGblEnv
+     ; let dfun_n_var = tcg_dfun_n env
+     ; set <- readTcRef dfun_n_var
+     ; let occ = fn set
+     ; writeTcRef dfun_n_var (extendOccSet set occ)
+     ; return occ }
+
+getConstraintVar :: TcM (TcRef WantedConstraints)
+getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
+
+setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
+setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
+
+emitStaticConstraints :: WantedConstraints -> TcM ()
+emitStaticConstraints static_lie
+  = do { gbl_env <- getGblEnv
+       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
+
+emitConstraints :: WantedConstraints -> TcM ()
+emitConstraints ct
+  | isEmptyWC ct
+  = return ()
+  | otherwise
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`andWC` ct) }
+
+emitSimple :: Ct -> TcM ()
+emitSimple ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addSimples` unitBag ct) }
+
+emitSimples :: Cts -> TcM ()
+emitSimples cts
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addSimples` cts) }
+
+emitImplication :: Implication -> TcM ()
+emitImplication ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addImplics` unitBag ct) }
+
+emitImplications :: Bag Implication -> TcM ()
+emitImplications ct
+  = unless (isEmptyBag ct) $
+    do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addImplics` ct) }
+
+emitInsoluble :: Ct -> TcM ()
+emitInsoluble ct
+  = do { traceTc "emitInsoluble" (ppr ct)
+       ; lie_var <- getConstraintVar
+       ; updTcRef lie_var (`addInsols` unitBag ct) }
+
+emitInsolubles :: Cts -> TcM ()
+emitInsolubles cts
+  | isEmptyBag cts = return ()
+  | otherwise      = do { traceTc "emitInsolubles" (ppr cts)
+                        ; lie_var <- getConstraintVar
+                        ; updTcRef lie_var (`addInsols` cts) }
+
+-- | Throw out any constraints emitted by the thing_inside
+discardConstraints :: TcM a -> TcM a
+discardConstraints thing_inside = fst <$> captureConstraints thing_inside
+
+-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
+pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
+pushLevelAndCaptureConstraints thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = pushTcLevel (tcl_tclvl env)
+       ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
+       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                       captureConstraints thing_inside
+       ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
+       ; return (tclvl', lie, res) }
+
+pushTcLevelM_ :: TcM a -> TcM a
+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
+
+pushTcLevelM :: TcM a -> TcM (TcLevel, a)
+-- See Note [TcLevel assignment] in TcType
+pushTcLevelM thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = pushTcLevel (tcl_tclvl env)
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
+                          thing_inside
+       ; return (tclvl', res) }
+
+-- Returns pushed TcLevel
+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
+pushTcLevelsM num_levels thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                thing_inside
+       ; return (res, tclvl') }
+
+getTcLevel :: TcM TcLevel
+getTcLevel = do { env <- getLclEnv
+                ; return (tcl_tclvl env) }
+
+setTcLevel :: TcLevel -> TcM a -> TcM a
+setTcLevel tclvl thing_inside
+  = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
+
+isTouchableTcM :: TcTyVar -> TcM Bool
+isTouchableTcM tv
+  = do { lvl <- getTcLevel
+       ; return (isTouchableMetaTyVar lvl tv) }
+
+getLclTypeEnv :: TcM TcTypeEnv
+getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
+
+setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
+-- Set the local type envt, but do *not* disturb other fields,
+-- notably the lie_var
+setLclTypeEnv lcl_env thing_inside
+  = updLclEnv upd thing_inside
+  where
+    upd env = env { tcl_env = tcl_env lcl_env,
+                    tcl_tyvars = tcl_tyvars lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+  = do { lie_var <- getConstraintVar
+       ; lie     <- readTcRef lie_var
+       ; traceOptTcRn Opt_D_dump_tc_trace $
+         hang (text (msg ++ ": LIE:")) 2 (ppr lie)
+       }
+
+emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
+emitWildCardHoleConstraints wcs
+  = do { ct_loc <- getCtLocM HoleOrigin Nothing
+       ; emitInsolubles $ listToBag $
+         map (do_one ct_loc) wcs }
+  where
+    do_one :: CtLoc -> (Name, TcTyVar) -> Ct
+    do_one ct_loc (name, tv)
+       = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+                                      , ctev_loc  = ct_loc' }
+                  , cc_hole = TypeHole (occName name) }
+       where
+         real_span = case nameSrcSpan name of
+                           RealSrcSpan span  -> span
+                           UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
+                                                      (ppr name <+> quotes (ftext str))
+               -- Wildcards are defined locally, and so have RealSrcSpans
+         ct_loc' = setCtLocSpan ct_loc real_span
+
+{- Note [Constraints and errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#12124):
+
+  foo :: Maybe Int
+  foo = return (case Left 3 of
+                  Left -> 1  -- Hard error here!
+                  _    -> 0)
+
+The call to 'return' will generate a (Monad m) wanted constraint; but
+then there'll be "hard error" (i.e. an exception in the TcM monad), from
+the unsaturated Left constructor pattern.
+
+We'll recover in tcPolyBinds, using recoverM.  But then the final
+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
+un-filled-in, and will emit a misleading error message.
+
+The underlying problem is that an exception interrupts the constraint
+gathering process. Bottom line: if we have an exception, it's best
+simply to discard any gathered constraints.  Hence in 'attemptM' we
+capture the constraints in a fresh variable, and only emit them into
+the surrounding context if we exit normally.  If an exception is
+raised, simply discard the collected constraints... we have a hard
+error to report.  So this capture-the-emit dance isn't as stupid as it
+looks :-).
+
+However suppose we throw an exception inside an invocation of
+captureConstraints, and discard all the constraints. Some of those
+constraints might be "variable out of scope" Hole constraints, and that
+might have been the actual original cause of the exception!  For
+example (#12529):
+   f = p @ Int
+Here 'p' is out of scope, so we get an insolube Hole constraint. But
+the visible type application fails in the monad (thows an exception).
+We must not discard the out-of-scope error.
+
+So we /retain the insoluble constraints/ if there is an exception.
+Hence:
+  - insolublesOnly in tryCaptureConstraints
+  - emitConstraints in the Left case of captureConstraints
+
+However note that freshly-generated constraints like (Int ~ Bool), or
+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+insoluble.  The constraint solver does that.  So they'll be discarded.
+That's probably ok; but see th/5358 as a not-so-good example:
+   t1 :: Int
+   t1 x = x   -- Manifestly wrong
+
+   foo = $(...raises exception...)
+We report the exception, but not the bug in t1.  Oh well.  Possible
+solution: make TcUnify.uType spot manifestly-insoluble constraints.
+
+
+************************************************************************
+*                                                                      *
+             Template Haskell context
+*                                                                      *
+************************************************************************
+-}
+
+recordThUse :: TcM ()
+recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
+
+recordThSpliceUse :: TcM ()
+recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
+
+-- | When generating an out-of-scope error message for a variable matching a
+-- binding in a later inter-splice group, the typechecker uses the splice
+-- locations to provide details in the message about the scope of that binding.
+recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
+recordTopLevelSpliceLoc (RealSrcSpan real_loc)
+  = do { env <- getGblEnv
+       ; let locs_var = tcg_th_top_level_locs env
+       ; locs0 <- readTcRef locs_var
+       ; writeTcRef locs_var (Set.insert real_loc locs0) }
+recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
+
+getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
+getTopLevelSpliceLocs
+  = do { env <- getGblEnv
+       ; readTcRef (tcg_th_top_level_locs env) }
+
+keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
+keepAlive name
+  = do { env <- getGblEnv
+       ; traceRn "keep alive" (ppr name)
+       ; updTcRef (tcg_keep env) (`extendNameSet` name) }
+
+getStage :: TcM ThStage
+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
+
+getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
+getStageAndBindLevel name
+  = do { env <- getLclEnv;
+       ; case lookupNameEnv (tcl_th_bndrs env) name of
+           Nothing                  -> return Nothing
+           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
+
+setStage :: ThStage -> TcM a -> TcRn a
+setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
+
+-- | Adds the given modFinalizers to the global environment and set them to use
+-- the current local environment.
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv mod_finalizers
+  = do lcl_env <- getLclEnv
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         (lcl_env, mod_finalizers) : fins
+
+{-
+************************************************************************
+*                                                                      *
+             Safe Haskell context
+*                                                                      *
+************************************************************************
+-}
+
+-- | Mark that safe inference has failed
+-- See Note [Safe Haskell Overlapping Instances Implementation]
+-- although this is used for more than just that failure case.
+recordUnsafeInfer :: WarningMessages -> TcM ()
+recordUnsafeInfer warns =
+    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
+
+-- | Figure out the final correct safe haskell mode
+finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
+finalSafeMode dflags tcg_env = do
+    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
+    return $ case safeHaskell dflags of
+        Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
+                | otherwise                     -> Sf_None
+        s -> s
+
+-- | Switch instances to safe instances if we're in Safe mode.
+fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
+fixSafeInstances sfMode | sfMode /= Sf_Safe = id
+fixSafeInstances _ = map fixSafe
+  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
+                       in inst { is_flag = new_flag }
+
+{-
+************************************************************************
+*                                                                      *
+             Stuff for the renamer's local env
+*                                                                      *
+************************************************************************
+-}
+
+getLocalRdrEnv :: RnM LocalRdrEnv
+getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
+
+setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
+setLocalRdrEnv rdr_env thing_inside
+  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
+
+{-
+************************************************************************
+*                                                                      *
+             Stuff for interface decls
+*                                                                      *
+************************************************************************
+-}
+
+mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
+mkIfLclEnv mod loc boot
+                   = IfLclEnv { if_mod     = mod,
+                                if_loc     = loc,
+                                if_boot    = boot,
+                                if_nsubst  = Nothing,
+                                if_implicits_env = Nothing,
+                                if_tv_env  = emptyFsEnv,
+                                if_id_env  = emptyFsEnv }
+
+-- | Run an 'IfG' (top-level interface monad) computation inside an existing
+-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
+-- based on 'TcGblEnv'.
+initIfaceTcRn :: IfG a -> TcRn a
+initIfaceTcRn thing_inside
+  = do  { tcg_env <- getGblEnv
+        ; dflags <- getDynFlags
+        ; let !mod = tcg_semantic_mod tcg_env
+              -- When we are instantiating a signature, we DEFINITELY
+              -- do not want to knot tie.
+              is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
+                               not (null (thisUnitIdInsts dflags))
+        ; let { if_env = IfGblEnv {
+                            if_doc = text "initIfaceTcRn",
+                            if_rec_types =
+                                if is_instantiate
+                                    then Nothing
+                                    else Just (mod, get_type_env)
+                         }
+              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
+        ; setEnvs (if_env, ()) thing_inside }
+
+-- Used when sucking in a ModIface into a ModDetails to put in
+-- the HPT.  Notably, unlike initIfaceCheck, this does NOT use
+-- hsc_type_env_var (since we're not actually going to typecheck,
+-- so this variable will never get updated!)
+initIfaceLoad :: HscEnv -> IfG a -> IO a
+initIfaceLoad hsc_env do_this
+ = do let gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceLoad",
+                        if_rec_types = Nothing
+                    }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
+-- Used when checking the up-to-date-ness of the old Iface
+-- Initialise the environment with no useful info at all
+initIfaceCheck doc hsc_env do_this
+ = do let rec_types = case hsc_type_env_var hsc_env of
+                         Just (mod,var) -> Just (mod, readTcRef var)
+                         Nothing        -> Nothing
+          gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceCheck" <+> doc,
+                        if_rec_types = rec_types
+                    }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
+initIfaceLcl mod loc_doc hi_boot_file thing_inside
+  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
+
+-- | Initialize interface typechecking, but with a 'NameShape'
+-- to apply when typechecking top-level 'OccName's (see
+-- 'lookupIfaceTop')
+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
+  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
+
+getIfModule :: IfL Module
+getIfModule = do { env <- getLclEnv; return (if_mod env) }
+
+--------------------
+failIfM :: MsgDoc -> IfL a
+-- The Iface monad doesn't have a place to accumulate errors, so we
+-- just fall over fast if one happens; it "shouldn't happen".
+-- We use IfL here so that we can get context info out of the local env
+failIfM msg
+  = do  { env <- getLclEnv
+        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
+        ; dflags <- getDynFlags
+        ; liftIO (putLogMsg dflags NoReason SevFatal
+                   noSrcSpan (defaultErrStyle dflags) full_msg)
+        ; failM }
+
+--------------------
+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
+-- Run thing_inside in an interleaved thread.
+-- It shares everything with the parent thread, so this is DANGEROUS.
+--
+-- It returns Nothing if the computation fails
+--
+-- It's used for lazily type-checking interface
+-- signatures, which is pretty benign
+
+forkM_maybe doc thing_inside
+ -- NB: Don't share the mutable env_us with the interleaved thread since env_us
+ --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).
+ = do { child_us <- newUniqueSupply
+      ; child_env_us <- newMutVar child_us
+        -- see Note [Masking exceptions in forkM_maybe]
+      ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
+        do { traceIf (text "Starting fork {" <+> doc)
+           ; mb_res <- tryM $
+                       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
+                       thing_inside
+           ; case mb_res of
+                Right r  -> do  { traceIf (text "} ending fork" <+> doc)
+                                ; return (Just r) }
+                Left exn -> do {
+
+                    -- Bleat about errors in the forked thread, if -ddump-if-trace is on
+                    -- Otherwise we silently discard errors. Errors can legitimately
+                    -- happen when compiling interface signatures (see tcInterfaceSigs)
+                      whenDOptM Opt_D_dump_if_trace $ do
+                          dflags <- getDynFlags
+                          let msg = hang (text "forkM failed:" <+> doc)
+                                       2 (text (show exn))
+                          liftIO $ putLogMsg dflags
+                                             NoReason
+                                             SevFatal
+                                             noSrcSpan
+                                             (defaultErrStyle dflags)
+                                             msg
+
+                    ; traceIf (text "} ending fork (badly)" <+> doc)
+                    ; return Nothing }
+        }}
+
+forkM :: SDoc -> IfL a -> IfL a
+forkM doc thing_inside
+ = do   { mb_res <- forkM_maybe doc thing_inside
+        ; return (case mb_res of
+                        Nothing -> pgmError "Cannot continue after interface file error"
+                                   -- pprPanic "forkM" doc
+                        Just r  -> r) }
+
+setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
+                                     { if_implicits_env = Just tenv }) m
+
+{-
+Note [Masking exceptions in forkM_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When using GHC-as-API it must be possible to interrupt snippets of code
+executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
+by throwing an asynchronous interrupt to the GHC thread. However, there is a
+subtle problem: runStmt first typechecks the code before running it, and the
+exception might interrupt the type checker rather than the code. Moreover, the
+typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
+more importantly might be inside an exception handler inside that
+unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
+asynchronous exception as a synchronous exception, and the exception will end
+up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
+discussion).  We don't currently know a general solution to this problem, but
+we can use uninterruptibleMask_ to avoid the situation.
+-}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+  extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+  extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+  extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+            => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+  env <- getGblEnv
+  let cc_st_ref = extractCostCentreState env
+  cc_st <- readTcRef cc_st_ref
+  let (idx, cc_st') = getCCIndex nm cc_st
+  writeTcRef cc_st_ref cc_st'
+  return idx
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRules.hs
@@ -0,0 +1,463 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+
+TcRules: Typechecking transformation rules
+-}
+
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcRules ( tcRules ) where
+
+import GhcPrelude
+
+import HsSyn
+import TcRnTypes
+import TcRnMonad
+import TcSimplify
+import TcMType
+import TcType
+import TcHsType
+import TcExpr
+import TcEnv
+import TcUnify( buildImplicationFor )
+import TcEvidence( mkTcCoVarCo )
+import Type
+import TyCon( isTypeFamilyTyCon )
+import Id
+import Var( EvVar )
+import VarSet
+import BasicTypes       ( RuleName )
+import SrcLoc
+import Outputable
+import FastString
+import Bag
+
+{-
+Note [Typechecking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We *infer* the typ of the LHS, and use that type to *check* the type of
+the RHS.  That means that higher-rank rules work reasonably well. Here's
+an example (test simplCore/should_compile/rule2.hs) produced by Roman:
+
+   foo :: (forall m. m a -> m b) -> m a -> m b
+   foo f = ...
+
+   bar :: (forall m. m a -> m a) -> m a -> m a
+   bar f = ...
+
+   {-# RULES "foo/bar" foo = bar #-}
+
+He wanted the rule to typecheck.
+
+Note [TcLevel in type checking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
+check the term-level binders in a bumped level, and we must accordingly bump
+the level whenever these binders are in scope.
+-}
+
+tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]
+tcRules decls = mapM (wrapLocM tcRuleDecls) decls
+
+tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)
+tcRuleDecls (HsRules { rds_src = src
+                     , rds_rules = decls })
+   = do { tc_decls <- mapM (wrapLocM tcRule) decls
+        ; return $ HsRules { rds_ext   = noExt
+                           , rds_src   = src
+                           , rds_rules = tc_decls } }
+tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"
+
+tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)
+tcRule (HsRule { rd_ext  = ext
+               , rd_name = rname@(L _ (_,name))
+               , rd_act  = act
+               , rd_tyvs = ty_bndrs
+               , rd_tmvs = tm_bndrs
+               , rd_lhs  = lhs
+               , rd_rhs  = rhs })
+  = addErrCtxt (ruleCtxt name)  $
+    do { traceTc "---- Rule ------" (pprFullRuleName rname)
+
+        -- Note [Typechecking rules]
+       ; (tc_lvl, stuff) <- pushTcLevelM $
+                            generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+
+       ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted
+                                , rhs', rhs_wanted, rule_ty) = stuff
+
+       ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
+                                  , ppr lhs_wanted
+                                  , ppr rhs_wanted ])
+
+       ; (lhs_evs, residual_lhs_wanted)
+            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted
+
+       -- SimplfyRule Plan, step 4
+       -- Now figure out what to quantify over
+       -- c.f. TcSimplify.simplifyInfer
+       -- We quantify over any tyvars free in *either* the rule
+       --  *or* the bound variables.  The latter is important.  Consider
+       --      ss (x,(y,z)) = (x,z)
+       --      RULE:  forall v. fst (ss v) = fst v
+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))
+       --
+       -- We also need to get the completely-uconstrained tyvars of
+       -- the LHS, lest they otherwise get defaulted to Any; but we do that
+       -- during zonking (see TcHsSyn.zonkRule)
+
+       ; let tpl_ids = lhs_evs ++ id_bndrs
+       ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level
+                                      -- monomorphic bindings from the MR; test tc111
+       ; forall_tkvs <- candidateQTyVarsOfTypes $
+                        map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars
+                        rule_ty : map idType tpl_ids
+       ; qtkvs <- quantifyTyVars gbls forall_tkvs
+       ; traceTc "tcRule" (vcat [ pprFullRuleName rname
+                                , ppr forall_tkvs
+                                , ppr qtkvs
+                                , ppr tv_bndrs
+                                , ppr rule_ty
+                                , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
+                  ])
+
+       -- SimplfyRule Plan, step 5
+       -- Simplify the LHS and RHS constraints:
+       -- For the LHS constraints we must solve the remaining constraints
+       -- (a) so that we report insoluble ones
+       -- (b) so that we bind any soluble ones
+       ; let all_qtkvs = qtkvs ++ tv_bndrs
+             skol_info = RuleSkol name
+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs
+                                         lhs_evs residual_lhs_wanted
+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs
+                                         lhs_evs rhs_wanted
+
+       ; emitImplications (lhs_implic `unionBags` rhs_implic)
+       ; return $ HsRule { rd_ext = ext
+                         , rd_name = rname
+                         , rd_act = act
+                         , rd_tyvs = ty_bndrs -- preserved for ppr-ing
+                         , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids)
+                         , rd_lhs  = mkHsDictLet lhs_binds lhs'
+                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }
+tcRule (XRuleDecl _) = panic "tcRule"
+
+generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+                        -> LHsExpr GhcRn -> LHsExpr GhcRn
+                        -> TcM ( [TyVar]
+                               , [TcId]
+                               , LHsExpr GhcTc, WantedConstraints
+                               , LHsExpr GhcTc, WantedConstraints
+                               , TcType )
+generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+  = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
+                                                tcRuleBndrs ty_bndrs tm_bndrs
+              -- bndr_wanted constraints can include wildcard hole
+              -- constraints, which we should not forget about.
+              -- It may mention the skolem type variables bound by
+              -- the RULE.  c.f. #10072
+
+       ; tcExtendTyVarEnv tv_bndrs $
+         tcExtendIdEnv    id_bndrs $
+    do { -- See Note [Solve order for RULES]
+         ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
+       ; (rhs',            rhs_wanted) <- captureConstraints $
+                                          tcMonoExpr rhs (mkCheckExpType rule_ty)
+       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
+       ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
+
+-- See Note [TcLevel in type checking rules]
+tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+            -> TcM ([TcTyVar], [Id])
+tcRuleBndrs (Just bndrs) xs
+  = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $
+                              tcRuleTmBndrs xs
+       ; return (tys1 ++ tys2, tms) }
+
+tcRuleBndrs Nothing xs
+  = tcRuleTmBndrs xs
+
+-- See Note [TcLevel in type checking rules]
+tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
+tcRuleTmBndrs [] = return ([],[])
+tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
+  = do  { ty <- newOpenFlexiTyVarTy
+        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs
+        ; return (tyvars, mkLocalId name ty : tmvars) }
+tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
+--  e.g         x :: a->a
+--  The tyvar 'a' is brought into scope first, just as if you'd written
+--              a::*, x :: a->a
+--  If there's an explicit forall, the renamer would have already reported an
+--   error for each out-of-scope type variable used
+  = do  { let ctxt = RuleSigCtxt name
+        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty
+        ; let id  = mkLocalIdOrCoVar name id_ty
+                    -- See Note [Pattern signature binders] in TcHsType
+
+              -- The type variables scope over subsequent bindings; yuk
+        ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
+                                   tcRuleTmBndrs rule_bndrs
+        ; return (map snd tvs ++ tyvars, id : tmvars) }
+tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"
+
+ruleCtxt :: FastString -> SDoc
+ruleCtxt name = text "When checking the transformation rule" <+>
+                doubleQuotes (ftext name)
+
+
+{-
+*********************************************************************************
+*                                                                                 *
+              Constraint simplification for rules
+*                                                                                 *
+***********************************************************************************
+
+Note [The SimplifyRule Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example.  Consider the following left-hand side of a rule
+        f (x == y) (y > z) = ...
+If we typecheck this expression we get constraints
+        d1 :: Ord a, d2 :: Eq a
+We do NOT want to "simplify" to the LHS
+        forall x::a, y::a, z::a, d1::Ord a.
+          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
+Instead we want
+        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
+          f ((==) d2 x y) ((>) d1 y z) = ...
+
+Here is another example:
+        fromIntegral :: (Integral a, Num b) => a -> b
+        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}
+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
+we *dont* want to get
+        forall dIntegralInt.
+           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+because the scsel will mess up RULE matching.  Instead we want
+        forall dIntegralInt, dNumInt.
+          fromIntegral Int Int dIntegralInt dNumInt = id Int
+
+Even if we have
+        g (x == y) (y == z) = ..
+where the two dictionaries are *identical*, we do NOT WANT
+        forall x::a, y::a, z::a, d1::Eq a
+          f ((==) d1 x y) ((>) d1 y z) = ...
+because that will only match if the dict args are (visibly) equal.
+Instead we want to quantify over the dictionaries separately.
+
+In short, simplifyRuleLhs must *only* squash equalities, leaving
+all dicts unchanged, with absolutely no sharing.
+
+Also note that we can't solve the LHS constraints in isolation:
+Example   foo :: Ord a => a -> a
+          foo_spec :: Int -> Int
+          {-# RULE "foo"  foo = foo_spec #-}
+Here, it's the RHS that fixes the type variable
+
+HOWEVER, under a nested implication things are different
+Consider
+  f :: (forall a. Eq a => a->a) -> Bool -> ...
+  {-# RULES "foo" forall (v::forall b. Eq b => b->b).
+       f b True = ...
+    #-}
+Here we *must* solve the wanted (Eq a) from the given (Eq a)
+resulting from skolemising the argument type of g.  So we
+revert to SimplCheck when going under an implication.
+
+
+--------- So the SimplifyRule Plan is this -----------------------
+
+* Step 0: typecheck the LHS and RHS to get constraints from each
+
+* Step 1: Simplify the LHS and RHS constraints all together in one bag
+          We do this to discover all unification equalities
+
+* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take
+          advantage of those unifications
+
+* Setp 3: Partition the LHS constraints into the ones we will
+          quantify over, and the others.
+          See Note [RULE quantification over equalities]
+
+* Step 4: Decide on the type variables to quantify over
+
+* Step 5: Simplify the LHS and RHS constraints separately, using the
+          quantified constraints as givens
+
+Note [Solve order for RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In step 1 above, we need to be a bit careful about solve order.
+Consider
+   f :: Int -> T Int
+   type instance T Int = Bool
+
+   RULE f 3 = True
+
+From the RULE we get
+   lhs-constraints:  T Int ~ alpha
+   rhs-constraints:  Bool ~ alpha
+where 'alpha' is the type that connects the two.  If we glom them
+all together, and solve the RHS constraint first, we might solve
+with alpha := Bool.  But then we'd end up with a RULE like
+
+    RULE: f 3 |> (co :: T Int ~ Bool) = True
+
+which is terrible.  We want
+
+    RULE: f 3 = True |> (sym co :: Bool ~ T Int)
+
+So we are careful to solve the LHS constraints first, and *then* the
+RHS constraints.  Actually much of this is done by the on-the-fly
+constraint solving, so the same order must be observed in
+tcRule.
+
+
+Note [RULE quantification over equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deciding which equalities to quantify over is tricky:
+ * We do not want to quantify over insoluble equalities (Int ~ Bool)
+    (a) because we prefer to report a LHS type error
+    (b) because if such things end up in 'givens' we get a bogus
+        "inaccessible code" error
+
+ * But we do want to quantify over things like (a ~ F b), where
+   F is a type function.
+
+The difficulty is that it's hard to tell what is insoluble!
+So we see whether the simplification step yielded any type errors,
+and if so refrain from quantifying over *any* equalities.
+
+Note [Quantifying over coercion holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Equality constraints from the LHS will emit coercion hole Wanteds.
+These don't have a name, so we can't quantify over them directly.
+Instead, because we really do want to quantify here, invent a new
+EvVar for the coercion, fill the hole with the invented EvVar, and
+then quantify over the EvVar. Not too tricky -- just some
+impedance matching, really.
+
+Note [Simplify cloned constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At this stage, we're simplifying constraints only for insolubility
+and for unification. Note that all the evidence is quickly discarded.
+We use a clone of the real constraint. If we don't do this,
+then RHS coercion-hole constraints get filled in, only to get filled
+in *again* when solving the implications emitted from tcRule. That's
+terrible, so we avoid the problem by cloning the constraints.
+
+-}
+
+simplifyRule :: RuleName
+             -> TcLevel                 -- Level at which to solve the constraints
+             -> WantedConstraints       -- Constraints from LHS
+             -> WantedConstraints       -- Constraints from RHS
+             -> TcM ( [EvVar]               -- Quantify over these LHS vars
+                    , WantedConstraints)    -- Residual un-quantified LHS constraints
+-- See Note [The SimplifyRule Plan]
+-- NB: This consumes all simple constraints on the LHS, but not
+-- any LHS implication constraints.
+simplifyRule name tc_lvl lhs_wanted rhs_wanted
+  = do {
+       -- Note [The SimplifyRule Plan] step 1
+       -- First solve the LHS and *then* solve the RHS
+       -- Crucially, this performs unifications
+       -- Why clone?  See Note [Simplify cloned constraints]
+       ; lhs_clone <- cloneWC lhs_wanted
+       ; rhs_clone <- cloneWC rhs_wanted
+       ; setTcLevel tc_lvl $
+         runTcSDeriveds    $
+         do { _ <- solveWanteds lhs_clone
+            ; _ <- solveWanteds rhs_clone
+                  -- Why do them separately?
+                  -- See Note [Solve order for RULES]
+            ; return () }
+
+       -- Note [The SimplifyRule Plan] step 2
+       ; lhs_wanted <- zonkWC lhs_wanted
+       ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
+
+       -- Note [The SimplifyRule Plan] step 3
+       ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
+
+       ; traceTc "simplifyRule" $
+         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
+              , text "lhs_wanted" <+> ppr lhs_wanted
+              , text "rhs_wanted" <+> ppr rhs_wanted
+              , text "quant_cts" <+> ppr quant_cts
+              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
+              ]
+
+       ; return (quant_evs, residual_lhs_wanted) }
+
+  where
+    mk_quant_ev :: Ct -> TcM EvVar
+    mk_quant_ev ct
+      | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
+      = case dest of
+          EvVarDest ev_id -> return ev_id
+          HoleDest hole   -> -- See Note [Quantifying over coercion holes]
+                             do { ev_id <- newEvVar pred
+                                ; fillCoercionHole hole (mkTcCoVarCo ev_id)
+                                ; return ev_id }
+    mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
+
+
+getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
+-- Extract all the constraints we can quantify over,
+--   also returning the depleted WantedConstraints
+--
+-- NB: we must look inside implications, because with
+--     -fdefer-type-errors we generate implications rather eagerly;
+--     see TcUnify.implicationNeeded. Not doing so caused #14732.
+--
+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
+--   and attempt to solve them from the quantified constraints.  That
+--   nearly works, but fails for a constraint like (d :: Eq Int).
+--   We /do/ want to quantify over it, but the short-cut solver
+--   (see TcInteract Note [Shortcut solving]) ignores the quantified
+--   and instead solves from the top level.
+--
+--   So we must partition the WantedConstraints ourselves
+--   Not hard, but tiresome.
+
+getRuleQuantCts wc
+  = float_wc emptyVarSet wc
+  where
+    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics })
+      = ( simple_yes `andCts` implic_yes
+        , WC { wc_simple = simple_no, wc_impl = implics_no })
+     where
+        (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples
+        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)
+                                                emptyBag implics
+
+    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)
+    float_implic skol_tvs yes1 imp
+      = (yes1 `andCts` yes2, imp { ic_wanted = no })
+      where
+        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)
+        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp
+
+    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool
+    rule_quant_ct skol_tvs ct
+      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)
+      , not (ok_eq t1 t2)
+       = False        -- Note [RULE quantification over equalities]
+      | isHoleCt ct
+      = False         -- Don't quantify over type holes, obviously
+      | otherwise
+      = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+
+    ok_eq t1 t2
+       | t1 `tcEqType` t2 = False
+       | otherwise        = is_fun_app t1 || is_fun_app t2
+
+    is_fun_app ty   -- ty is of form (F tys) where F is a type function
+      = case tyConAppTyCon_maybe ty of
+          Just tc -> isTypeFamilyTyCon tc
+          Nothing -> False
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSMonad.hs
@@ -0,0 +1,3522 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+
+-- Type definitions for the constraint solver
+module TcSMonad (
+
+    -- The work list
+    WorkList(..), isEmptyWorkList, emptyWorkList,
+    extendWorkListNonEq, extendWorkListCt,
+    extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
+    appendWorkList, extendWorkListImplic,
+    selectNextWorkItem,
+    workListSize, workListWantedCount,
+    getWorkList, updWorkListTcS,
+
+    -- The TcS monad
+    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
+    failTcS, warnTcS, addErrTcS,
+    runTcSEqualities,
+    nestTcS, nestImplicTcS, setEvBindsTcS,
+    checkConstraintsTcS, checkTvConstraintsTcS,
+
+    runTcPluginTcS, addUsedGRE, addUsedGREs,
+    matchGlobalInst, TcM.ClsInstResult(..),
+
+    QCInst(..),
+
+    -- Tracing etc
+    panicTcS, traceTcS,
+    traceFireTcS, bumpStepCountTcS, csTraceTcS,
+    wrapErrTcS, wrapWarnTcS,
+
+    -- Evidence creation and transformation
+    MaybeNew(..), freshGoals, isFresh, getEvExpr,
+
+    newTcEvBinds, newNoTcEvBinds,
+    newWantedEq, emitNewWantedEq,
+    newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,
+    newBoundEvVarId,
+    unifyTyVar, unflattenFmv, reportUnifications,
+    setEvBind, setWantedEq,
+    setWantedEvTerm, setEvBindIfWanted,
+    newEvVar, newGivenEvVar, newGivenEvVars,
+    emitNewDeriveds, emitNewDerivedEq,
+    checkReductionDepth,
+    getSolvedDicts, setSolvedDicts,
+
+    getInstEnvs, getFamInstEnvs,                -- Getting the environments
+    getTopEnv, getGblEnv, getLclEnv,
+    getTcEvBindsVar, getTcLevel,
+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+    tcLookupClass, tcLookupId,
+
+    -- Inerts
+    InertSet(..), InertCans(..),
+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,
+    getNoGivenEqs, setInertCans,
+    getInertEqs, getInertCans, getInertGivens,
+    getInertInsols,
+    getTcSInerts, setTcSInerts,
+    matchableGivens, prohibitedSuperClassSolve, mightMatchLater,
+    getUnsolvedInerts,
+    removeInertCts, getPendingGivenScs,
+    addInertCan, insertFunEq, addInertForAll,
+    emitWorkNC, emitWork,
+    isImprovable,
+
+    -- The Model
+    kickOutAfterUnification,
+
+    -- Inert Safe Haskell safe-overlap failures
+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
+    getSafeOverlapFailures,
+
+    -- Inert CDictCans
+    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,
+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,
+
+    -- Inert CTyEqCans
+    EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
+    lookupFlattenTyVar, lookupInertTyVar,
+
+    -- Inert solved dictionaries
+    addSolvedDict, lookupSolvedDict,
+
+    -- Irreds
+    foldIrreds,
+
+    -- The flattening cache
+    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems
+    dischargeFunEq, pprKicked,
+
+    -- Inert CFunEqCans
+    updInertFunEqs, findFunEq,
+    findFunEqsByTyCon,
+
+    instDFunType,                              -- Instantiation
+
+    -- MetaTyVars
+    newFlexiTcSTy, instFlexi, instFlexiX,
+    cloneMetaTyVar, demoteUnfilledFmv,
+    tcInstSkolTyVarsX,
+
+    TcLevel,
+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,
+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
+    zonkTyCoVarsAndFVList,
+    zonkSimples, zonkWC,
+    zonkTyCoVarKind,
+
+    -- References
+    newTcRef, readTcRef, writeTcRef, updTcRef,
+
+    -- Misc
+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
+    matchFam, matchFamTcM,
+    checkWellStagedDFun,
+    pprEq                                    -- Smaller utils, re-exported from TcM
+                                             -- TODO (DV): these are only really used in the
+                                             -- instance matcher in TcSimplify. I am wondering
+                                             -- if the whole instance matcher simply belongs
+                                             -- here
+) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HscTypes
+
+import qualified Inst as TcM
+import InstEnv
+import FamInst
+import FamInstEnv
+
+import qualified TcRnMonad as TcM
+import qualified TcMType as TcM
+import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) )
+import qualified TcEnv as TcM
+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )
+import ClsInst( InstanceWhat(..) )
+import Kind
+import TcType
+import DynFlags
+import Type
+import Coercion
+import Unify
+
+import TcEvidence
+import Class
+import TyCon
+import TcErrors   ( solverDepthErrorTcS )
+
+import Name
+import Module ( HasModule, getModule )
+import RdrName ( GlobalRdrEnv, GlobalRdrElt )
+import qualified RnEnv as TcM
+import Var
+import VarEnv
+import VarSet
+import Outputable
+import Bag
+import UniqSupply
+import Util
+import TcRnTypes
+
+import Unique
+import UniqFM
+import UniqDFM
+import Maybes
+
+import CoreMap
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+import MonadUtils
+import Data.IORef
+import Data.List ( partition, mapAccumL )
+
+#if defined(DEBUG)
+import Digraph
+import UniqSet
+#endif
+
+{-
+************************************************************************
+*                                                                      *
+*                            Worklists                                *
+*  Canonical and non-canonical constraints that the simplifier has to  *
+*  work on. Including their simplification depths.                     *
+*                                                                      *
+*                                                                      *
+************************************************************************
+
+Note [WorkList priorities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A WorkList contains canonical and non-canonical items (of all flavors).
+Notice that each Ct now has a simplification depth. We may
+consider using this depth for prioritization as well in the future.
+
+As a simple form of priority queue, our worklist separates out
+
+* equalities (wl_eqs); see Note [Prioritise equalities]
+* type-function equalities (wl_funeqs)
+* all the rest (wl_rest)
+
+Note [Prioritise equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very important to process equalities /first/:
+
+* (Efficiency)  The general reason to do so is that if we process a
+  class constraint first, we may end up putting it into the inert set
+  and then kicking it out later.  That's extra work compared to just
+  doing the equality first.
+
+* (Avoiding fundep iteration) As #14723 showed, it's possible to
+  get non-termination if we
+      - Emit the Derived fundep equalities for a class constraint,
+        generating some fresh unification variables.
+      - That leads to some unification
+      - Which kicks out the class constraint
+      - Which isn't solved (because there are still some more Derived
+        equalities in the work-list), but generates yet more fundeps
+  Solution: prioritise derived equalities over class constraints
+
+* (Class equalities) We need to prioritise equalities even if they
+  are hidden inside a class constraint;
+  see Note [Prioritise class equalities]
+
+* (Kick-out) We want to apply this priority scheme to kicked-out
+  constraints too (see the call to extendWorkListCt in kick_out_rewritable
+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become
+  homo-kinded when kicked out, and hence we want to priotitise it.
+
+* (Derived equalities) Originally we tried to postpone processing
+  Derived equalities, in the hope that we might never need to deal
+  with them at all; but in fact we must process Derived equalities
+  eagerly, partly for the (Efficiency) reason, and more importantly
+  for (Avoiding fundep iteration).
+
+Note [Prioritise class equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prioritise equalities in the solver (see selectWorkItem). But class
+constraints like (a ~ b) and (a ~~ b) are actually equalities too;
+see Note [The equality types story] in TysPrim.
+
+Failing to prioritise these is inefficient (more kick-outs etc).
+But, worse, it can prevent us spotting a "recursive knot" among
+Wanted constraints.  See comment:10 of #12734 for a worked-out
+example.
+
+So we arrange to put these particular class constraints in the wl_eqs.
+
+  NB: since we do not currently apply the substitution to the
+  inert_solved_dicts, the knot-tying still seems a bit fragile.
+  But this makes it better.
+-}
+
+-- See Note [WorkList priorities]
+data WorkList
+  = WL { wl_eqs     :: [Ct]  -- CTyEqCan, CDictCan, CIrredCan
+                             -- Given, Wanted, and Derived
+                       -- Contains both equality constraints and their
+                       -- class-level variants (a~b) and (a~~b);
+                       -- See Note [Prioritise equalities]
+                       -- See Note [Prioritise class equalities]
+
+       , wl_funeqs  :: [Ct]
+
+       , wl_rest    :: [Ct]
+
+       , wl_implics :: Bag Implication  -- See Note [Residual implications]
+    }
+
+appendWorkList :: WorkList -> WorkList -> WorkList
+appendWorkList
+    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
+        , wl_implics = implics1 })
+    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
+        , wl_implics = implics2 })
+   = WL { wl_eqs     = eqs1     ++ eqs2
+        , wl_funeqs  = funeqs1  ++ funeqs2
+        , wl_rest    = rest1    ++ rest2
+        , wl_implics = implics1 `unionBags`   implics2 }
+
+workListSize :: WorkList -> Int
+workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
+  = length eqs + length funeqs + length rest
+
+workListWantedCount :: WorkList -> Int
+-- Count the things we need to solve
+-- excluding the insolubles (c.f. inert_count)
+workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
+  = count isWantedCt eqs + count is_wanted rest
+  where
+    is_wanted ct
+     | CIrredCan { cc_ev = ev, cc_insol = insol } <- ct
+     = not insol && isWanted ev
+     | otherwise
+     = isWantedCt ct
+
+extendWorkListEq :: Ct -> WorkList -> WorkList
+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
+
+extendWorkListFunEq :: Ct -> WorkList -> WorkList
+extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
+
+extendWorkListNonEq :: Ct -> WorkList -> WorkList
+-- Extension by non equality
+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
+
+extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList
+extendWorkListDeriveds evs wl
+  = extendWorkListCts (map mkNonCanonical evs) wl
+
+extendWorkListImplic :: Bag Implication -> WorkList -> WorkList
+extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }
+
+extendWorkListCt :: Ct -> WorkList -> WorkList
+-- Agnostic
+extendWorkListCt ct wl
+ = case classifyPredType (ctPred ct) of
+     EqPred NomEq ty1 _
+       | Just tc <- tcTyConAppTyCon_maybe ty1
+       , isTypeFamilyTyCon tc
+       -> extendWorkListFunEq ct wl
+
+     EqPred {}
+       -> extendWorkListEq ct wl
+
+     ClassPred cls _  -- See Note [Prioritise class equalities]
+       |  isEqPredClass cls
+       -> extendWorkListEq ct wl
+
+     _ -> extendWorkListNonEq ct wl
+
+extendWorkListCts :: [Ct] -> WorkList -> WorkList
+-- Agnostic
+extendWorkListCts cts wl = foldr extendWorkListCt wl cts
+
+isEmptyWorkList :: WorkList -> Bool
+isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
+                    , wl_rest = rest, wl_implics = implics })
+  = null eqs && null rest && null funeqs && isEmptyBag implics
+
+emptyWorkList :: WorkList
+emptyWorkList = WL { wl_eqs  = [], wl_rest = []
+                   , wl_funeqs = [], wl_implics = emptyBag }
+
+selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
+-- See Note [Prioritise equalities]
+selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
+                      , wl_rest = rest })
+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })
+  | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })
+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })
+  | otherwise      = Nothing
+
+getWorkList :: TcS WorkList
+getWorkList = do { wl_var <- getTcSWorkListRef
+                 ; wrapTcS (TcM.readTcRef wl_var) }
+
+selectNextWorkItem :: TcS (Maybe Ct)
+-- Pick which work item to do next
+-- See Note [Prioritise equalities]
+selectNextWorkItem
+  = do { wl_var <- getTcSWorkListRef
+       ; wl <- readTcRef wl_var
+       ; case selectWorkItem wl of {
+           Nothing -> return Nothing ;
+           Just (ct, new_wl) ->
+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)
+         -- This is done by TcInteract.chooseInstance
+       ; writeTcRef wl_var new_wl
+       ; return (Just ct) } } }
+
+-- Pretty printing
+instance Outputable WorkList where
+  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
+          , wl_rest = rest, wl_implics = implics })
+   = text "WL" <+> (braces $
+     vcat [ ppUnless (null eqs) $
+            text "Eqs =" <+> vcat (map ppr eqs)
+          , ppUnless (null feqs) $
+            text "Funeqs =" <+> vcat (map ppr feqs)
+          , ppUnless (null rest) $
+            text "Non-eqs =" <+> vcat (map ppr rest)
+          , ppUnless (isEmptyBag implics) $
+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))
+                       (text "(Implics omitted)")
+          ])
+
+
+{- *********************************************************************
+*                                                                      *
+                InertSet: the inert set
+*                                                                      *
+*                                                                      *
+********************************************************************* -}
+
+data InertSet
+  = IS { inert_cans :: InertCans
+              -- Canonical Given, Wanted, Derived
+              -- Sometimes called "the inert set"
+
+       , inert_fsks :: [(TcTyVar, TcType)]
+              -- A list of (fsk, ty) pairs; we add one element when we flatten
+              -- a function application in a Given constraint, creating
+              -- a new fsk in newFlattenSkolem.  When leaving a nested scope,
+              -- unflattenGivens unifies fsk := ty
+              --
+              -- We could also get this info from inert_funeqs, filtered by
+              -- level, but it seems simpler and more direct to capture the
+              -- fsk as we generate them.
+
+       , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
+              -- See Note [Type family equations]
+              -- If    F tys :-> (co, rhs, flav),
+              -- then  co :: F tys ~ rhs
+              --       flav is [G] or [WD]
+              --
+              -- Just a hash-cons cache for use when flattening only
+              -- These include entirely un-processed goals, so don't use
+              -- them to solve a top-level goal, else you may end up solving
+              -- (w:F ty ~ a) by setting w:=w!  We just use the flat-cache
+              -- when allocating a new flatten-skolem.
+              -- Not necessarily inert wrt top-level equations (or inert_cans)
+
+              -- NB: An ExactFunEqMap -- this doesn't match via loose types!
+
+       , inert_solved_dicts   :: DictMap CtEvidence
+              -- All Wanteds, of form ev :: C t1 .. tn
+              -- See Note [Solved dictionaries]
+              -- and Note [Do not add superclasses of solved dictionaries]
+       }
+
+instance Outputable InertSet where
+  ppr (IS { inert_cans = ics
+          , inert_fsks = ifsks
+          , inert_solved_dicts = solved_dicts })
+      = vcat [ ppr ics
+             , text "Inert fsks =" <+> ppr ifsks
+             , ppUnless (null dicts) $
+               text "Solved dicts =" <+> vcat (map ppr dicts) ]
+         where
+           dicts = bagToList (dictsToBag solved_dicts)
+
+emptyInertCans :: InertCans
+emptyInertCans
+  = IC { inert_count    = 0
+       , inert_eqs      = emptyDVarEnv
+       , inert_dicts    = emptyDicts
+       , inert_safehask = emptyDicts
+       , inert_funeqs   = emptyFunEqs
+       , inert_insts    = []
+       , inert_irreds   = emptyCts }
+
+emptyInert :: InertSet
+emptyInert
+  = IS { inert_cans         = emptyInertCans
+       , inert_fsks         = []
+       , inert_flat_cache   = emptyExactFunEqs
+       , inert_solved_dicts = emptyDictMap }
+
+
+{- Note [Solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we apply a top-level instance declaration, we add the "solved"
+dictionary to the inert_solved_dicts.  In general, we use it to avoid
+creating a new EvVar when we have a new goal that we have solved in
+the past.
+
+But in particular, we can use it to create *recursive* dictionaries.
+The simplest, degnerate case is
+    instance C [a] => C [a] where ...
+If we have
+    [W] d1 :: C [x]
+then we can apply the instance to get
+    d1 = $dfCList d
+    [W] d2 :: C [x]
+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.
+    d1 = $dfCList d
+    d2 = d1
+
+See Note [Example of recursive dictionaries]
+Other notes about solved dictionaries
+
+* See also Note [Do not add superclasses of solved dictionaries]
+
+* The inert_solved_dicts field is not rewritten by equalities,
+  so it may get out of date.
+
+* THe inert_solved_dicts are all Wanteds, never givens
+
+* We only cache dictionaries from top-level instances, not from
+  local quantified constraints.  Reason: if we cached the latter
+  we'd need to purge the cache when bringing new quantified
+  constraints into scope, because quantified constraints "shadow"
+  top-level instances.
+
+Note [Do not add superclasses of solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Every member of inert_solved_dicts is the result of applying a dictionary
+function, NOT of applying superclass selection to anything.
+Consider
+
+        class Ord a => C a where
+        instance Ord [a] => C [a] where ...
+
+Suppose we are trying to solve
+  [G] d1 : Ord a
+  [W] d2 : C [a]
+
+Then we'll use the instance decl to give
+
+  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3
+  [W] d3 : Ord [a]
+
+We must not add d4 : Ord [a] to the 'solved' set (by taking the
+superclass of d2), otherwise we'll use it to solve d3, without ever
+using d1, which would be a catastrophe.
+
+Solution: when extending the solved dictionaries, do not add superclasses.
+That's why each element of the inert_solved_dicts is the result of applying
+a dictionary function.
+
+Note [Example of recursive dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--- Example 1
+
+    data D r = ZeroD | SuccD (r (D r));
+
+    instance (Eq (r (D r))) => Eq (D r) where
+        ZeroD     == ZeroD     = True
+        (SuccD a) == (SuccD b) = a == b
+        _         == _         = False;
+
+    equalDC :: D [] -> D [] -> Bool;
+    equalDC = (==);
+
+We need to prove (Eq (D [])). Here's how we go:
+
+   [W] d1 : Eq (D [])
+By instance decl of Eq (D r):
+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2
+By instance decl of Eq [a]:
+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3
+                                   d1 = dfEqD d2
+Now this wanted can interact with our "solved" d1 to get:
+    d3 = d1
+
+-- Example 2:
+This code arises in the context of "Scrap Your Boilerplate with Class"
+
+    class Sat a
+    class Data ctx a
+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1
+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2
+
+    class Data Maybe a => Foo a
+
+    instance Foo t => Sat (Maybe t)                             -- dfunSat
+
+    instance Data Maybe a => Foo a                              -- dfunFoo1
+    instance Foo a        => Foo [a]                            -- dfunFoo2
+    instance                 Foo [Char]                         -- dfunFoo3
+
+Consider generating the superclasses of the instance declaration
+         instance Foo a => Foo [a]
+
+So our problem is this
+    [G] d0 : Foo t
+    [W] d1 : Data Maybe [t]   -- Desired superclass
+
+We may add the given in the inert set, along with its superclasses
+  Inert:
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  WorkList
+    [W] d1 : Data Maybe [t]
+
+Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3
+  Inert:
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+  WorkList:
+    [W] d2 : Sat (Maybe [t])
+    [W] d3 : Data Maybe t
+
+Now, we may simplify d2 using dfunSat; d2 := dfunSat d4
+  Inert:
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+  WorkList:
+    [W] d3 : Data Maybe t
+    [W] d4 : Foo [t]
+
+Now, we can just solve d3 from d01; d3 := d01
+  Inert
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+  WorkList
+    [W] d4 : Foo [t]
+
+Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5
+  Inert
+    [G] d0  : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+        d4 : Foo [t]
+  WorkList:
+    [W] d5 : Foo t
+
+Now, d5 can be solved! d5 := d0
+
+Result
+   d1 := dfunData2 d2 d3
+   d2 := dfunSat d4
+   d3 := d01
+   d4 := dfunFoo2 d5
+   d5 := d0
+-}
+
+{- *********************************************************************
+*                                                                      *
+                InertCans: the canonical inerts
+*                                                                      *
+*                                                                      *
+********************************************************************* -}
+
+data InertCans   -- See Note [Detailed InertCans Invariants] for more
+  = IC { inert_eqs :: InertEqs
+              -- See Note [inert_eqs: the inert equalities]
+              -- All CTyEqCans; index is the LHS tyvar
+              -- Domain = skolems and untouchables; a touchable would be unified
+
+       , inert_funeqs :: FunEqMap Ct
+              -- All CFunEqCans; index is the whole family head type.
+              -- All Nominal (that's an invarint of all CFunEqCans)
+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)
+              --     wrt inert_eqs
+              -- Can include all flavours, [G], [W], [WD], [D]
+              -- See Note [Type family equations]
+
+       , inert_dicts :: DictMap Ct
+              -- Dictionaries only
+              -- All fully rewritten (modulo flavour constraints)
+              --     wrt inert_eqs
+
+       , inert_insts :: [QCInst]
+
+       , inert_safehask :: DictMap Ct
+              -- Failed dictionary resolution due to Safe Haskell overlapping
+              -- instances restriction. We keep this separate from inert_dicts
+              -- as it doesn't cause compilation failure, just safe inference
+              -- failure.
+              --
+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]
+              -- in TcSimplify
+
+       , inert_irreds :: Cts
+              -- Irreducible predicates that cannot be made canonical,
+              --     and which don't interact with others (e.g.  (c a))
+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])
+
+       , inert_count :: Int
+              -- Number of Wanted goals in
+              --     inert_eqs, inert_dicts, inert_safehask, inert_irreds
+              -- Does not include insolubles
+              -- When non-zero, keep trying to solve
+       }
+
+type InertEqs    = DTyVarEnv EqualCtList
+type EqualCtList = [Ct]  -- See Note [EqualCtList invariants]
+
+{- Note [Detailed InertCans Invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The InertCans represents a collection of constraints with the following properties:
+
+  * All canonical
+
+  * No two dictionaries with the same head
+  * No two CIrreds with the same type
+
+  * Family equations inert wrt top-level family axioms
+
+  * Dictionaries have no matching top-level instance
+
+  * Given family or dictionary constraints don't mention touchable
+    unification variables
+
+  * Non-CTyEqCan constraints are fully rewritten with respect
+    to the CTyEqCan equalities (modulo canRewrite of course;
+    eg a wanted cannot rewrite a given)
+
+  * CTyEqCan equalities: see Note [Applying the inert substitution]
+                         in TcFlatten
+
+Note [EqualCtList invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    * All are equalities
+    * All these equalities have the same LHS
+    * The list is never empty
+    * No element of the list can rewrite any other
+    * Derived before Wanted
+
+From the fourth invariant it follows that the list is
+   - A single [G], or
+   - Zero or one [D] or [WD], followd by any number of [W]
+
+The Wanteds can't rewrite anything which is why we put them last
+
+Note [Type family equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),
+live in three places
+
+  * The work-list, of course
+
+  * The inert_funeqs are un-solved but fully processed, and in
+    the InertCans. They can be [G], [W], [WD], or [D].
+
+  * The inert_flat_cache.  This is used when flattening, to get maximal
+    sharing. Everthing in the inert_flat_cache is [G] or [WD]
+
+    It contains lots of things that are still in the work-list.
+    E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the
+        work list.  Then we flatten w1, dumping (w3: G a ~ f1) in the work
+        list.  Now if we flatten w2 before we get to w3, we still want to
+        share that (G a).
+    Because it contains work-list things, DO NOT use the flat cache to solve
+    a top-level goal.  Eg in the above example we don't want to solve w3
+    using w3 itself!
+
+The CFunEqCan Ownership Invariant:
+
+  * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv
+    It "owns" that fsk/fmv, in the sense that:
+      - reducing a [W/WD] CFunEqCan fills in the fmv
+      - unflattening a [W/WD] CFunEqCan fills in the fmv
+      (in both cases unless an occurs-check would result)
+
+  * In contrast a [D] CFunEqCan does not "own" its fmv:
+      - reducing a [D] CFunEqCan does not fill in the fmv;
+        it just generates an equality
+      - unflattening ignores [D] CFunEqCans altogether
+
+
+Note [inert_eqs: the inert equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Definition [Can-rewrite relation]
+A "can-rewrite" relation between flavours, written f1 >= f2, is a
+binary relation with the following properties
+
+  (R1) >= is transitive
+  (R2) If f1 >= f, and f2 >= f,
+       then either f1 >= f2 or f2 >= f1
+
+Lemma.  If f1 >= f then f1 >= f1
+Proof.  By property (R2), with f1=f2
+
+Definition [Generalised substitution]
+A "generalised substitution" S is a set of triples (a -f-> t), where
+  a is a type variable
+  t is a type
+  f is a flavour
+such that
+  (WF1) if (a -f1-> t1) in S
+           (a -f2-> t2) in S
+        then neither (f1 >= f2) nor (f2 >= f1) hold
+  (WF2) if (a -f-> t) is in S, then t /= a
+
+Definition [Applying a generalised substitution]
+If S is a generalised substitution
+   S(f,a) = t,  if (a -fs-> t) in S, and fs >= f
+          = a,  otherwise
+Application extends naturally to types S(f,t), modulo roles.
+See Note [Flavours with roles].
+
+Theorem: S(f,a) is well defined as a function.
+Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,
+               and  f1 >= f and f2 >= f
+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)
+
+Notation: repeated application.
+  S^0(f,t)     = t
+  S^(n+1)(f,t) = S(f, S^n(t))
+
+Definition: inert generalised substitution
+A generalised substitution S is "inert" iff
+
+  (IG1) there is an n such that
+        for every f,t, S^n(f,t) = S^(n+1)(f,t)
+
+By (IG1) we define S*(f,t) to be the result of exahaustively
+applying S(f,_) to t.
+
+----------------------------------------------------------------
+Our main invariant:
+   the inert CTyEqCans should be an inert generalised substitution
+----------------------------------------------------------------
+
+Note that inertness is not the same as idempotence.  To apply S to a
+type, you may have to apply it recursive.  But inertness does
+guarantee that this recursive use will terminate.
+
+Note [Extending the inert equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Main Theorem [Stability under extension]
+   Suppose we have a "work item"
+       a -fw-> t
+   and an inert generalised substitution S,
+   THEN the extended substitution T = S+(a -fw-> t)
+        is an inert generalised substitution
+   PROVIDED
+      (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)
+      (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)
+      (T3) a not in t      -- No occurs check in the work item
+
+      AND, for every (b -fs-> s) in S:
+           (K0) not (fw >= fs)
+                Reason: suppose we kick out (a -fs-> s),
+                        and add (a -fw-> t) to the inert set.
+                        The latter can't rewrite the former,
+                        so the kick-out achieved nothing
+
+           OR { (K1) not (a = b)
+                     Reason: if fw >= fs, WF1 says we can't have both
+                             a -fw-> t  and  a -fs-> s
+
+                AND (K2): guarantees inertness of the new substitution
+                    {  (K2a) not (fs >= fs)
+                    OR (K2b) fs >= fw
+                    OR (K2d) a not in s }
+
+                AND (K3) See Note [K3: completeness of solving]
+                    { (K3a) If the role of fs is nominal: s /= a
+                      (K3b) If the role of fs is representational:
+                            s is not of form (a t1 .. tn) } }
+
+
+Conditions (T1-T3) are established by the canonicaliser
+Conditions (K1-K3) are established by TcSMonad.kickOutRewritable
+
+The idea is that
+* (T1-2) are guaranteed by exhaustively rewriting the work-item
+  with S(fw,_).
+
+* T3 is guaranteed by a simple occurs-check on the work item.
+  This is done during canonicalisation, in canEqTyVar;
+  (invariant: a CTyEqCan never has an occurs check).
+
+* (K1-3) are the "kick-out" criteria.  (As stated, they are really the
+  "keep" criteria.) If the current inert S contains a triple that does
+  not satisfy (K1-3), then we remove it from S by "kicking it out",
+  and re-processing it.
+
+* Note that kicking out is a Bad Thing, because it means we have to
+  re-process a constraint.  The less we kick out, the better.
+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed
+  this but haven't done the empirical study to check.
+
+* Assume we have  G>=G, G>=W and that's all.  Then, when performing
+  a unification we add a new given  a -G-> ty.  But doing so does NOT require
+  us to kick out an inert wanted that mentions a, because of (K2a).  This
+  is a common case, hence good not to kick out.
+
+* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing
+  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything
+         and so K0 holds.  Intuitively, since fw can't rewrite anything,
+         adding it cannot cause any loops
+  This is a common case, because Wanteds cannot rewrite Wanteds.
+  It's used to avoid even looking for constraint to kick out.
+
+* Lemma (L1): The conditions of the Main Theorem imply that there is no
+              (a -fs-> t) in S, s.t.  (fs >= fw).
+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),
+  S(fw,a)=a.  But since fs>=fw, S(fw,a) = s, hence s=a.  But now we
+  have (a -fs-> a) in S, which contradicts (WF2).
+
+* The extended substitution satisfies (WF1) and (WF2)
+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).
+  - (T3) guarantees (WF2).
+
+* (K2) is about inertness.  Intuitively, any infinite chain T^0(f,t),
+  T^1(f,t), T^2(f,T).... must pass through the new work item infinitely
+  often, since the substitution without the work item is inert; and must
+  pass through at least one of the triples in S infinitely often.
+
+  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),
+    and hence this triple never plays a role in application S(f,a).
+    It is always safe to extend S with such a triple.
+
+    (NB: we could strengten K1) in this way too, but see K3.
+
+  - (K2b): If this holds then, by (T2), b is not in t.  So applying the
+    work item does not generate any new opportunities for applying S
+
+  - (K2c): If this holds, we can't pass through this triple infinitely
+    often, because if we did then fs>=f, fw>=f, hence by (R2)
+      * either fw>=fs, contradicting K2c
+      * or fs>=fw; so by the argument in K2b we can't have a loop
+
+  - (K2d): if a not in s, we hae no further opportunity to apply the
+    work item, similar to (K2b)
+
+  NB: Dimitrios has a PDF that does this in more detail
+
+Key lemma to make it watertight.
+  Under the conditions of the Main Theorem,
+  forall f st fw >= f, a is not in S^k(f,t), for any k
+
+Also, consider roles more carefully. See Note [Flavours with roles]
+
+Note [K3: completeness of solving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(K3) is not necessary for the extended substitution
+to be inert.  In fact K1 could be made stronger by saying
+   ... then (not (fw >= fs) or not (fs >= fs))
+But it's not enough for S to be inert; we also want completeness.
+That is, we want to be able to solve all soluble wanted equalities.
+Suppose we have
+
+   work-item   b -G-> a
+   inert-item  a -W-> b
+
+Assuming (G >= W) but not (W >= W), this fulfills all the conditions,
+so we could extend the inerts, thus:
+
+   inert-items   b -G-> a
+                 a -W-> b
+
+But if we kicked-out the inert item, we'd get
+
+   work-item     a -W-> b
+   inert-item    b -G-> a
+
+Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.
+So we add one more clause to the kick-out criteria
+
+Another way to understand (K3) is that we treat an inert item
+        a -f-> b
+in the same way as
+        b -f-> a
+So if we kick out one, we should kick out the other.  The orientation
+is somewhat accidental.
+
+When considering roles, we also need the second clause (K3b). Consider
+
+  work-item    c -G/N-> a
+  inert-item   a -W/R-> b c
+
+The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.
+But we don't kick out the inert item because not (W/R >= W/R).  So we just
+add the work item. But then, consider if we hit the following:
+
+  work-item    b -G/N-> Id
+  inert-items  a -W/R-> b c
+               c -G/N-> a
+where
+  newtype Id x = Id x
+
+For similar reasons, if we only had (K3a), we wouldn't kick the
+representational inert out. And then, we'd miss solving the inert, which
+now reduced to reflexivity.
+
+The solution here is to kick out representational inerts whenever the
+tyvar of a work item is "exposed", where exposed means being at the
+head of the top-level application chain (a t1 .. tn).  See
+TcType.isTyVarHead. This is encoded in (K3b).
+
+Beware: if we make this test succeed too often, we kick out too much,
+and the solver might loop.  Consider (#14363)
+  work item:   [G] a ~R f b
+  inert item:  [G] b ~R f a
+In GHC 8.2 the completeness tests more aggressive, and kicked out
+the inert item; but no rewriting happened and there was an infinite
+loop.  All we need is to have the tyvar at the head.
+
+Note [Flavours with roles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The system described in Note [inert_eqs: the inert equalities]
+discusses an abstract
+set of flavours. In GHC, flavours have two components: the flavour proper,
+taken from {Wanted, Derived, Given} and the equality relation (often called
+role), taken from {NomEq, ReprEq}.
+When substituting w.r.t. the inert set,
+as described in Note [inert_eqs: the inert equalities],
+we must be careful to respect all components of a flavour.
+For example, if we have
+
+  inert set: a -G/R-> Int
+             b -G/R-> Bool
+
+  type role T nominal representational
+
+and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT
+T Int Bool. The reason is that T's first parameter has a nominal role, and
+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of
+substitution means that the proof in Note [The inert equalities] may need
+to be revisited, but we don't think that the end conclusion is wrong.
+-}
+
+instance Outputable InertCans where
+  ppr (IC { inert_eqs = eqs
+          , inert_funeqs = funeqs, inert_dicts = dicts
+          , inert_safehask = safehask, inert_irreds = irreds
+          , inert_insts = insts
+          , inert_count = count })
+    = braces $ vcat
+      [ ppUnless (isEmptyDVarEnv eqs) $
+        text "Equalities:"
+          <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)
+      , ppUnless (isEmptyTcAppMap funeqs) $
+        text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)
+      , ppUnless (isEmptyTcAppMap dicts) $
+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)
+      , ppUnless (isEmptyTcAppMap safehask) $
+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)
+      , ppUnless (isEmptyCts irreds) $
+        text "Irreds =" <+> pprCts irreds
+      , ppUnless (null insts) $
+        text "Given instances =" <+> vcat (map ppr insts)
+      , text "Unsolved goals =" <+> int count
+      ]
+
+{- *********************************************************************
+*                                                                      *
+             Shadow constraints and improvement
+*                                                                      *
+************************************************************************
+
+Note [The improvement story and derived shadows]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not
+rewrite Wanteds] in TcRnTypes), we may miss some opportunities for
+solving.  Here's a classic example (indexed-types/should_fail/T4093a)
+
+    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e
+
+    We get [G] Foo e ~ Maybe e
+           [W] Foo e ~ Foo ee      -- ee is a unification variable
+           [W] Foo ee ~ Maybe ee
+
+    Flatten: [G] Foo e ~ fsk
+             [G] fsk ~ Maybe e   -- (A)
+
+             [W] Foo ee ~ fmv
+             [W] fmv ~ fsk       -- (B) From Foo e ~ Foo ee
+             [W] fmv ~ Maybe ee
+
+    --> rewrite (B) with (A)
+             [W] Foo ee ~ fmv
+             [W] fmv ~ Maybe e
+             [W] fmv ~ Maybe ee
+
+    But now we appear to be stuck, since we don't rewrite Wanteds with
+    Wanteds.  This is silly because we can see that ee := e is the
+    only solution.
+
+The basic plan is
+  * generate Derived constraints that shadow Wanted constraints
+  * allow Derived to rewrite Derived
+  * in order to cause some unifications to take place
+  * that in turn solve the original Wanteds
+
+The ONLY reason for all these Derived equalities is to tell us how to
+unify a variable: that is, what Mark Jones calls "improvement".
+
+The same idea is sometimes also called "saturation"; find all the
+equalities that must hold in any solution.
+
+Or, equivalently, you can think of the derived shadows as implementing
+the "model": a non-idempotent but no-occurs-check substitution,
+reflecting *all* *Nominal* equalities (a ~N ty) that are not
+immediately soluble by unification.
+
+More specifically, here's how it works (Oct 16):
+
+* Wanted constraints are born as [WD]; this behaves like a
+  [W] and a [D] paired together.
+
+* When we are about to add a [WD] to the inert set, if it can
+  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],
+  putting the latter into the work list (see maybeEmitShadow).
+
+In the example above, we get to the point where we are stuck:
+    [WD] Foo ee ~ fmv
+    [WD] fmv ~ Maybe e
+    [WD] fmv ~ Maybe ee
+
+But now when [WD] fmv ~ Maybe ee is about to be added, we'll
+split it into [W] and [D], since the inert [WD] fmv ~ Maybe e
+can rewrite it.  Then:
+    work item: [D] fmv ~ Maybe ee
+    inert:     [W] fmv ~ Maybe ee
+               [WD] fmv ~ Maybe e   -- (C)
+               [WD] Foo ee ~ fmv
+
+See Note [Splitting WD constraints].  Now the work item is rewritten
+by (C) and we soon get ee := e.
+
+Additional notes:
+
+  * The derived shadow equalities live in inert_eqs, along with
+    the Givens and Wanteds; see Note [EqualCtList invariants].
+
+  * We make Derived shadows only for Wanteds, not Givens.  So we
+    have only [G], not [GD] and [G] plus splitting.  See
+    Note [Add derived shadows only for Wanteds]
+
+  * We also get Derived equalities from functional dependencies
+    and type-function injectivity; see calls to unifyDerived.
+
+  * This splitting business applies to CFunEqCans too; and then
+    we do apply type-function reductions to the [D] CFunEqCan.
+    See Note [Reduction for Derived CFunEqCans]
+
+  * It's worth having [WD] rather than just [W] and [D] because
+    * efficiency: silly to process the same thing twice
+    * inert_funeqs, inert_dicts is a finite map keyed by
+      the type; it's inconvenient for it to map to TWO constraints
+
+Note [Splitting WD constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are about to add a [WD] constraint to the inert set; and we
+know that the inert set has fully rewritten it.  Should we split
+it into [W] and [D], and put the [D] in the work list for further
+work?
+
+* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):
+  Yes if the inert set could rewrite tys to make the class constraint,
+  or type family, fire.  That is, yes if the inert_eqs intersects
+  with the free vars of tys.  For this test we use
+  (anyRewritableTyVar True) which ignores casts and coercions in tys,
+  because rewriting the casts or coercions won't make the thing fire
+  more often.
+
+* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.
+  We need to check both 'a' and 'ty' against the inert set:
+    - Inert set contains  [D] a ~ ty2
+      Then we want to put [D] a ~ ty in the worklist, so we'll
+      get [D] ty ~ ty2 with consequent good things
+
+    - Inert set contains [D] b ~ a, where b is in ty.
+      We can't just add [WD] a ~ ty[b] to the inert set, because
+      that breaks the inert-set invariants.  If we tried to
+      canonicalise another [D] constraint mentioning 'a', we'd
+      get an infinite loop
+
+  Moreover we must use (anyRewritableTyVar False) for the RHS,
+  because even tyvars in the casts and coercions could give
+  an infinite loop if we don't expose it
+
+* CIrredCan: Yes if the inert set can rewrite the constraint.
+  We used to think splitting irreds was unnecessary, but
+  see Note [Splitting Irred WD constraints]
+
+* Others: nothing is gained by splitting.
+
+Note [Splitting Irred WD constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Splitting Irred constraints can make a difference. Here is the
+scenario:
+
+  a[sk] :: F v     -- F is a type family
+  beta :: alpha
+
+  work item: [WD] a ~ beta
+
+This is heterogeneous, so we try flattening the kinds.
+
+  co :: F v ~ fmv
+  [WD] (a |> co) ~ beta
+
+This is still hetero, so we emit a kind equality and make the work item an
+inert Irred.
+
+  work item: [D] fmv ~ alpha
+  inert: [WD] (a |> co) ~ beta (CIrredCan)
+
+Can't make progress on the work item. Add to inert set. This kicks out the
+old inert, because a [D] can rewrite a [WD].
+
+  work item: [WD] (a |> co) ~ beta
+  inert: [D] fmv ~ alpha (CTyEqCan)
+
+Can't make progress on this work item either (although GHC tries by
+decomposing the cast and reflattening... but that doesn't make a difference),
+which is still hetero. Emit a new kind equality and add to inert set. But,
+critically, we split the Irred.
+
+  work list:
+   [D] fmv ~ alpha (CTyEqCan)
+   [D] (a |> co) ~ beta (CIrred) -- this one was split off
+  inert:
+   [W] (a |> co) ~ beta
+   [D] fmv ~ alpha
+
+We quickly solve the first work item, as it's the same as an inert.
+
+  work item: [D] (a |> co) ~ beta
+  inert:
+   [W] (a |> co) ~ beta
+   [D] fmv ~ alpha
+
+We decompose the cast, yielding
+
+  [D] a ~ beta
+
+We then flatten the kinds. The lhs kind is F v, which flattens to fmv which
+then rewrites to alpha.
+
+  co' :: F v ~ alpha
+  [D] (a |> co') ~ beta
+
+Now this equality is homo-kinded. So we swizzle it around to
+
+  [D] beta ~ (a |> co')
+
+and set beta := a |> co', and go home happy.
+
+If we don't split the Irreds, we loop. This is all dangerously subtle.
+
+This is triggered by test case typecheck/should_compile/SplitWD.
+
+Note [Examples of how Derived shadows helps completeness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#10009, a very nasty example:
+
+    f :: (UnF (F b) ~ b) => F b -> ()
+
+    g :: forall a. (UnF (F a) ~ a) => a -> ()
+    g _ = f (undefined :: F a)
+
+  For g we get [G] UnF (F a) ~ a
+               [WD] UnF (F beta) ~ beta
+               [WD] F a ~ F beta
+  Flatten:
+      [G] g1: F a ~ fsk1         fsk1 := F a
+      [G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1
+      [G] g3: fsk2 ~ a
+
+      [WD] w1: F beta ~ fmv1
+      [WD] w2: UnF fmv1 ~ fmv2
+      [WD] w3: fmv2 ~ beta
+      [WD] w4: fmv1 ~ fsk1   -- From F a ~ F beta using flat-cache
+                             -- and re-orient to put meta-var on left
+
+Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2
+React that with g2: [D] d2: fmv2 ~ fsk2
+React that with w3: [D] beta ~ fsk2
+            and g3: [D] beta ~ a -- Hooray beta := a
+And that is enough to solve everything
+
+Note [Add derived shadows only for Wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only add shadows for Wanted constraints. That is, we have
+[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]
+constraints.
+
+It does just possibly make sense ot add a derived shadow for a
+Given. If we created a Derived shadow of a Given, it could be
+rewritten by other Deriveds, and that could, conceivably, lead to a
+useful unification.
+
+But (a) I have been unable to come up with an example of this
+        happening
+    (b) see #12660 for how adding the derived shadows
+        of a Given led to an infinite loop.
+    (c) It's unlikely that rewriting derived Givens will lead
+        to a unification because Givens don't mention touchable
+        unification variables
+
+For (b) there may be other ways to solve the loop, but simply
+reraining from adding derived shadows of Givens is particularly
+simple.  And it's more efficient too!
+
+Still, here's one possible reason for adding derived shadows
+for Givens.  Consider
+           work-item [G] a ~ [b], inerts has [D] b ~ a.
+If we added the derived shadow (into the work list)
+         [D] a ~ [b]
+When we process it, we'll rewrite to a ~ [a] and get an
+occurs check.  Without it we'll miss the occurs check (reporting
+inaccessible code); but that's probably OK.
+
+Note [Keep CDictCan shadows as CDictCan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class C a => D a b
+and [G] D a b, [G] C a in the inert set.  Now we insert
+[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,
+so we can rewrite it with the new constraint, and perhaps get
+instance reduction or other consequences.
+
+BUT we do not want to kick out a *non-canonical* (D a b). If we
+did, we would do this:
+  - rewrite it to [D] D a c, with pend_sc = True
+  - use expandSuperClasses to add C a
+  - go round again, which solves C a from the givens
+This loop goes on for ever and triggers the simpl_loop limit.
+
+Solution: kick out the CDictCan which will have pend_sc = False,
+because we've already added its superclasses.  So we won't re-add
+them.  If we forget the pend_sc flag, our cunning scheme for avoiding
+generating superclasses repeatedly will fail.
+
+See #11379 for a case of this.
+
+Note [Do not do improvement for WOnly]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do improvement between two constraints (e.g. for injectivity
+or functional dependencies) only if both are "improvable". And
+we improve a constraint wrt the top-level instances only if
+it is improvable.
+
+Improvable:     [G] [WD] [D}
+Not improvable: [W]
+
+Reasons:
+
+* It's less work: fewer pairs to compare
+
+* Every [W] has a shadow [D] so nothing is lost
+
+* Consider [WD] C Int b,  where 'b' is a skolem, and
+    class C a b | a -> b
+    instance C Int Bool
+  We'll do a fundep on it and emit [D] b ~ Bool
+  That will kick out constraint [WD] C Int b
+  Then we'll split it to [W] C Int b (keep in inert)
+                     and [D] C Int b (in work list)
+  When processing the latter we'll rewrite it to
+        [D] C Int Bool
+  At that point it would be /stupid/ to interact it
+  with the inert [W] C Int b in the inert set; after all,
+  it's the very constraint from which the [D] C Int Bool
+  was split!  We can avoid this by not doing improvement
+  on [W] constraints. This came up in #12860.
+-}
+
+maybeEmitShadow :: InertCans -> Ct -> TcS Ct
+-- See Note [The improvement story and derived shadows]
+maybeEmitShadow ics ct
+  | let ev = ctEvidence ct
+  , CtWanted { ctev_pred = pred, ctev_loc = loc
+             , ctev_nosh = WDeriv } <- ev
+  , shouldSplitWD (inert_eqs ics) ct
+  = do { traceTcS "Emit derived shadow" (ppr ct)
+       ; let derived_ev = CtDerived { ctev_pred = pred
+                                    , ctev_loc  = loc }
+             shadow_ct = ct { cc_ev = derived_ev }
+               -- Te shadow constraint keeps the canonical shape.
+               -- This just saves work, but is sometimes important;
+               -- see Note [Keep CDictCan shadows as CDictCan]
+       ; emitWork [shadow_ct]
+
+       ; let ev' = ev { ctev_nosh = WOnly }
+             ct' = ct { cc_ev = ev' }
+                 -- Record that it now has a shadow
+                 -- This is /the/ place we set the flag to WOnly
+       ; return ct' }
+
+  | otherwise
+  = return ct
+
+shouldSplitWD :: InertEqs -> Ct -> Bool
+-- Precondition: 'ct' is [WD], and is inert
+-- True <=> we should split ct ito [W] and [D] because
+--          the inert_eqs can make progress on the [D]
+-- See Note [Splitting WD constraints]
+
+shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })
+  = should_split_match_args inert_eqs tys
+    -- We don't need to split if the tv is the RHS fsk
+
+shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })
+  = should_split_match_args inert_eqs tys
+    -- NB True: ignore coercions
+    -- See Note [Splitting WD constraints]
+
+shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
+                                  , cc_eq_rel = eq_rel })
+  =  tv `elemDVarEnv` inert_eqs
+  || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
+  -- NB False: do not ignore casts and coercions
+  -- See Note [Splitting WD constraints]
+
+shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
+  = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
+
+shouldSplitWD _ _ = False   -- No point in splitting otherwise
+
+should_split_match_args :: InertEqs -> [TcType] -> Bool
+-- True if the inert_eqs can rewrite anything in the argument
+-- types, ignoring casts and coercions
+should_split_match_args inert_eqs tys
+  = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys
+    -- NB True: ignore casts coercions
+    -- See Note [Splitting WD constraints]
+
+canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool
+canRewriteTv inert_eqs eq_rel tv
+  | Just (ct : _) <- lookupDVarEnv inert_eqs tv
+  , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct
+  = eq_rel1 `eqCanRewrite` eq_rel
+  | otherwise
+  = False
+
+isImprovable :: CtEvidence -> Bool
+-- See Note [Do not do improvement for WOnly]
+isImprovable (CtWanted { ctev_nosh = WOnly }) = False
+isImprovable _                                = True
+
+
+{- *********************************************************************
+*                                                                      *
+                   Inert equalities
+*                                                                      *
+********************************************************************* -}
+
+addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
+addTyEq old_eqs tv ct
+  = extendDVarEnv_C add_eq old_eqs tv [ct]
+  where
+    add_eq old_eqs _
+      | isWantedCt ct
+      , (eq1 : eqs) <- old_eqs
+      = eq1 : ct : eqs
+      | otherwise
+      = ct : old_eqs
+
+foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
+foldTyEqs k eqs z
+  = foldDVarEnv (\cts z -> foldr k z cts) z eqs
+
+findTyEqs :: InertCans -> TyVar -> EqualCtList
+findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []
+
+delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs
+delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv
+  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
+        isThisOne _                          = False
+
+lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType
+lookupInertTyVar ieqs tv
+  = case lookupDVarEnv ieqs tv of
+      Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs
+      _                                                        -> Nothing
+
+lookupFlattenTyVar :: InertEqs -> TcTyVar -> TcType
+-- See Note [lookupFlattenTyVar]
+lookupFlattenTyVar ieqs ftv
+  = lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv
+
+{- Note [lookupFlattenTyVar]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an injective function F and
+  inert_funeqs:   F t1 ~ fsk1
+                  F t2 ~ fsk2
+  inert_eqs:      fsk1 ~ fsk2
+
+We never rewrite the RHS (cc_fsk) of a CFunEqCan.  But we /do/ want to
+get the [D] t1 ~ t2 from the injectiveness of F.  So we look up the
+cc_fsk of CFunEqCans in the inert_eqs when trying to find derived
+equalities arising from injectivity.
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+                   Inert instances: inert_insts
+*                                                                      *
+********************************************************************* -}
+
+addInertForAll :: QCInst -> TcS ()
+-- Add a local Given instance, typically arising from a type signature
+addInertForAll new_qci
+  = updInertCans $ \ics ->
+    ics { inert_insts = add_qci (inert_insts ics) }
+  where
+    add_qci :: [QCInst] -> [QCInst]
+    -- See Note [Do not add duplicate quantified instances]
+    add_qci qcis | any same_qci qcis = qcis
+                 | otherwise         = new_qci : qcis
+
+    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))
+                                (ctEvPred (qci_ev new_qci))
+
+{- Note [Do not add duplicate quantified instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#15244):
+
+  f :: (C g, D g) => ....
+  class S g => C g where ...
+  class S g => D g where ...
+  class (forall a. Eq a => Eq (g a)) => S g where ...
+
+Then in f's RHS there are two identical quantified constraints
+available, one via the superclasses of C and one via the superclasses
+of D.  The two are identical, and it seems wrong to reject the program
+because of that. But without doing duplicate-elimination we will have
+two matching QCInsts when we try to solve constraints arising from f's
+RHS.
+
+The simplest thing is simply to eliminate duplicattes, which we do here.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                  Adding an inert
+*                                                                      *
+************************************************************************
+
+Note [Adding an equality to the InertCans]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When adding an equality to the inerts:
+
+* Split [WD] into [W] and [D] if the inerts can rewrite the latter;
+  done by maybeEmitShadow.
+
+* Kick out any constraints that can be rewritten by the thing
+  we are adding.  Done by kickOutRewritable.
+
+* Note that unifying a:=ty, is like adding [G] a~ty; just use
+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.
+
+Note [Kicking out CFunEqCan for fundeps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   New:    [D] fmv1 ~ fmv2
+   Inert:  [W] F alpha ~ fmv1
+           [W] F beta  ~ fmv2
+
+where F is injective. The new (derived) equality certainly can't
+rewrite the inerts. But we *must* kick out the first one, to get:
+
+   New:   [W] F alpha ~ fmv1
+   Inert: [W] F beta ~ fmv2
+          [D] fmv1 ~ fmv2
+
+and now improvement will discover [D] alpha ~ beta. This is important;
+eg in #9587.
+
+So in kickOutRewritable we look at all the tyvars of the
+CFunEqCan, including the fsk.
+-}
+
+addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities
+-- Precondition: item /is/ canonical
+-- See Note [Adding an equality to the InertCans]
+addInertCan ct
+  = do { traceTcS "insertInertCan {" $
+         text "Trying to insert new inert item:" <+> ppr ct
+
+       ; ics <- getInertCans
+       ; ct  <- maybeEmitShadow ics ct
+       ; ics <- maybeKickOut ics ct
+       ; setInertCans (add_item ics ct)
+
+       ; traceTcS "addInertCan }" $ empty }
+
+maybeKickOut :: InertCans -> Ct -> TcS InertCans
+-- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan
+maybeKickOut ics ct
+  | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics
+       ; return ics' }
+  | otherwise
+  = return ics
+
+add_item :: InertCans -> Ct -> InertCans
+add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
+  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
+
+add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })
+  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item
+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+
+add_item ics@(IC { inert_irreds = irreds, inert_count = count })
+         item@(CIrredCan { cc_ev = ev, cc_insol = insoluble })
+  = ics { inert_irreds = irreds `Bag.snocBag` item
+        , inert_count  = if insoluble
+                         then count  -- inert_count does not include insolubles
+                         else bumpUnsolvedCount ev count }
+
+add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
+  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item
+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+
+add_item _ item
+  = pprPanic "upd_inert set: can't happen! Inserting " $
+    ppr item   -- Can't be CNonCanonical, CHoleCan,
+               -- because they only land in inert_irreds
+
+bumpUnsolvedCount :: CtEvidence -> Int -> Int
+bumpUnsolvedCount ev n | isWanted ev = n+1
+                       | otherwise   = n
+
+
+-----------------------------------------
+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that
+                                      -- is being added to the inert set
+                    -> TcTyVar        -- The new equality is tv ~ ty
+                    -> InertCans
+                    -> TcS (Int, InertCans)
+kickOutRewritable new_fr new_tv ics
+  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics
+             n_kicked = workListSize kicked_out
+
+       ; unless (n_kicked == 0) $
+         do { updWorkListTcS (appendWorkList kicked_out)
+            ; csTraceTcS $
+              hang (text "Kick out, tv =" <+> ppr new_tv)
+                 2 (vcat [ text "n-kicked =" <+> int n_kicked
+                         , text "kicked_out =" <+> ppr kicked_out
+                         , text "Residual inerts =" <+> ppr ics' ]) }
+
+       ; return (n_kicked, ics') }
+
+kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that
+                                      -- is being added to the inert set
+                    -> TcTyVar        -- The new equality is tv ~ ty
+                    -> InertCans
+                    -> (WorkList, InertCans)
+-- See Note [kickOutRewritable]
+kick_out_rewritable new_fr new_tv
+                    ics@(IC { inert_eqs      = tv_eqs
+                            , inert_dicts    = dictmap
+                            , inert_safehask = safehask
+                            , inert_funeqs   = funeqmap
+                            , inert_irreds   = irreds
+                            , inert_insts    = old_insts
+                            , inert_count    = n })
+  | not (new_fr `eqMayRewriteFR` new_fr)
+  = (emptyWorkList, ics)
+        -- If new_fr can't rewrite itself, it can't rewrite
+        -- anything else, so no need to kick out anything.
+        -- (This is a common case: wanteds can't rewrite wanteds)
+        -- Lemma (L2) in Note [Extending the inert equalities]
+
+  | otherwise
+  = (kicked_out, inert_cans_in)
+  where
+    inert_cans_in = IC { inert_eqs      = tv_eqs_in
+                       , inert_dicts    = dicts_in
+                       , inert_safehask = safehask   -- ??
+                       , inert_funeqs   = feqs_in
+                       , inert_irreds   = irs_in
+                       , inert_insts    = insts_in
+                       , inert_count    = n - workListWantedCount kicked_out }
+
+    kicked_out :: WorkList
+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority
+    -- See Note [Prioritise equality constraints] (Kick-out).
+    -- The irreds may include non-canonical (hetero-kinded) equality
+    -- 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
+                          (emptyWorkList { wl_eqs    = tv_eqs_out
+                                         , wl_funeqs = feqs_out })
+                          ((dicts_out `andCts` irs_out)
+                            `extendCtsList` insts_out)
+
+    (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs
+    (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap
+           -- See Note [Kicking out CFunEqCan for fundeps]
+    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap
+    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds
+      -- Kick out even insolubles: See Note [Rewrite insolubles]
+      -- Of course we must kick out irreducibles like (c a), in case
+      -- we can rewrite 'c' to something more useful
+
+    -- Kick-out for inert instances
+    -- See Note [Quantified constraints] in TcCanonical
+    insts_out :: [Ct]
+    insts_in  :: [QCInst]
+    (insts_out, insts_in)
+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens
+       = partitionWith kick_out_qci old_insts
+       | otherwise
+       = ([], old_insts)
+    kick_out_qci qci
+      | let ev = qci_ev qci
+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))
+      = Left (mkNonCanonical ev)
+      | otherwise
+      = Right qci
+
+    (_, new_role) = new_fr
+
+    fr_can_rewrite_ty :: EqRel -> Type -> Bool
+    fr_can_rewrite_ty role ty = anyRewritableTyVar False role
+                                                   fr_can_rewrite_tv ty
+    fr_can_rewrite_tv :: EqRel -> TyVar -> Bool
+    fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role
+                             && tv == new_tv
+
+    fr_may_rewrite :: CtFlavourRole -> Bool
+    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs
+        -- Can the new item rewrite the inert item?
+
+    kick_out_ct :: Ct -> Bool
+    -- Kick it out if the new CTyEqCan can rewrite the inert one
+    -- See Note [kickOutRewritable]
+    kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct
+                   = fr_may_rewrite fs
+                   && fr_can_rewrite_ty role (ctPred ct)
+                  -- False: ignore casts and coercions
+                  -- NB: this includes the fsk of a CFunEqCan.  It can't
+                  --     actually be rewritten, but we need to kick it out
+                  --     so we get to take advantage of injectivity
+                  -- See Note [Kicking out CFunEqCan for fundeps]
+
+    kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)
+                 -> ([Ct], DTyVarEnv EqualCtList)
+    kick_out_eqs eqs (acc_out, acc_in)
+      = (eqs_out ++ acc_out, case eqs_in of
+                               []      -> acc_in
+                               (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)
+      where
+        (eqs_out, eqs_in) = partition kick_out_eq eqs
+
+    -- Implements criteria K1-K3 in Note [Extending the inert equalities]
+    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty
+                          , cc_ev = ev, cc_eq_rel = eq_rel })
+      | not (fr_may_rewrite fs)
+      = False  -- Keep it in the inert set if the new thing can't rewrite it
+
+      -- Below here (fr_may_rewrite fs) is True
+      | tv == new_tv              = True        -- (K1)
+      | kick_out_for_inertness    = True
+      | kick_out_for_completeness = True
+      | otherwise                 = False
+
+      where
+        fs = (ctEvFlavour ev, eq_rel)
+        kick_out_for_inertness
+          =        (fs `eqMayRewriteFR` fs)       -- (K2a)
+            && not (fs `eqMayRewriteFR` new_fr)   -- (K2b)
+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2d)
+            -- (K2c) is guaranteed by the first guard of keep_eq
+
+        kick_out_for_completeness
+          = case eq_rel of
+              NomEq  -> rhs_ty `eqType` mkTyVarTy new_tv
+              ReprEq -> isTyVarHead new_tv rhs_ty
+
+    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)
+
+kickOutAfterUnification :: TcTyVar -> TcS Int
+kickOutAfterUnification new_tv
+  = do { ics <- getInertCans
+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)
+                                                 new_tv ics
+                     -- Given because the tv := xi is given; NomEq because
+                     -- only nominal equalities are solved by unification
+
+       ; setInertCans ics2
+       ; return n_kicked }
+
+{- Note [kickOutRewritable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [inert_eqs: the inert equalities].
+
+When we add a new inert equality (a ~N ty) to the inert set,
+we must kick out any inert items that could be rewritten by the
+new equality, to maintain the inert-set invariants.
+
+  - We want to kick out an existing inert constraint if
+    a) the new constraint can rewrite the inert one
+    b) 'a' is free in the inert constraint (so that it *will*)
+       rewrite it if we kick it out.
+
+    For (b) we use tyCoVarsOfCt, which returns the type variables /and
+    the kind variables/ that are directly visible in the type. Hence
+    we will have exposed all the rewriting we care about to make the
+    most precise kinds visible for matching classes etc. No need to
+    kick out constraints that mention type variables whose kinds
+    contain this variable!
+
+  - A Derived equality can kick out [D] constraints in inert_eqs,
+    inert_dicts, inert_irreds etc.
+
+  - We don't kick out constraints from inert_solved_dicts, and
+    inert_solved_funeqs optimistically. But when we lookup we have to
+    take the substitution into account
+
+
+Note [Rewrite insolubles]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an insoluble alpha ~ [alpha], which is insoluble
+because an occurs check.  And then we unify alpha := [Int].  Then we
+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can
+be decomposed.  Otherwise we end up with a "Can't match [Int] ~
+[[Int]]" which is true, but a bit confusing because the outer type
+constructors match.
+
+Similarly, if we have a CHoleCan, we'd like to rewrite it with any
+Givens, to give as informative an error messasge as possible
+(#12468, #11325).
+
+Hence:
+ * In the main simlifier loops in TcSimplify (solveWanteds,
+   simpl_loop), we feed the insolubles in solveSimpleWanteds,
+   so that they get rewritten (albeit not solved).
+
+ * We kick insolubles out of the inert set, if they can be
+   rewritten (see TcSMonad.kick_out_rewritable)
+
+ * We rewrite those insolubles in TcCanonical.
+   See Note [Make sure that insolubles are fully rewritten]
+-}
+
+
+
+--------------
+addInertSafehask :: InertCans -> Ct -> InertCans
+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
+  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }
+
+addInertSafehask _ item
+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item
+
+insertSafeOverlapFailureTcS :: Ct -> TcS ()
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+insertSafeOverlapFailureTcS item
+  = updInertCans (\ics -> addInertSafehask ics item)
+
+getSafeOverlapFailures :: TcS Cts
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+getSafeOverlapFailures
+ = do { IC { inert_safehask = safehask } <- getInertCans
+      ; return $ foldDicts consCts safehask emptyCts }
+
+--------------
+addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS ()
+-- Add a new item in the solved set of the monad
+-- See Note [Solved dictionaries]
+addSolvedDict item cls tys
+  | isIPPred (ctEvPred item)    -- Never cache "solved" implicit parameters (not sure why!)
+  = return ()
+  | otherwise
+  = do { traceTcS "updSolvedSetTcs:" $ ppr item
+       ; updInertTcS $ \ ics ->
+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
+
+getSolvedDicts :: TcS (DictMap CtEvidence)
+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }
+
+setSolvedDicts :: DictMap CtEvidence -> TcS ()
+setSolvedDicts solved_dicts
+  = updInertTcS $ \ ics ->
+    ics { inert_solved_dicts = solved_dicts }
+
+
+{- *********************************************************************
+*                                                                      *
+                  Other inert-set operations
+*                                                                      *
+********************************************************************* -}
+
+updInertTcS :: (InertSet -> InertSet) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertTcS upd_fn
+  = do { is_var <- getTcSInertsRef
+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var
+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }
+
+getInertCans :: TcS InertCans
+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }
+
+setInertCans :: InertCans -> TcS ()
+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }
+
+updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a
+-- Modify the inert set with the supplied function
+updRetInertCans upd_fn
+  = do { is_var <- getTcSInertsRef
+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var
+                     ; let (res, cans') = upd_fn (inert_cans inerts)
+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })
+                     ; return res }) }
+
+updInertCans :: (InertCans -> InertCans) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertCans upd_fn
+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }
+
+updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertDicts upd_fn
+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }
+
+updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertSafehask upd_fn
+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }
+
+updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertFunEqs upd_fn
+  = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }
+
+updInertIrreds :: (Cts -> Cts) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertIrreds upd_fn
+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }
+
+getInertEqs :: TcS (DTyVarEnv EqualCtList)
+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }
+
+getInertInsols :: TcS Cts
+-- Returns insoluble equality constraints
+-- specifically including Givens
+getInertInsols = do { inert <- getInertCans
+                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }
+
+getInertGivens :: TcS [Ct]
+-- Returns the Given constraints in the inert set,
+-- with type functions *not* unflattened
+getInertGivens
+  = do { inerts <- getInertCans
+       ; let all_cts = foldDicts (:) (inert_dicts inerts)
+                     $ foldFunEqs (:) (inert_funeqs inerts)
+                     $ concat (dVarEnvElts (inert_eqs inerts))
+       ; return (filter isGivenCt all_cts) }
+
+getPendingGivenScs :: TcS [Ct]
+-- Find all inert Given dictionaries, or quantified constraints,
+--     whose cc_pend_sc flag is True
+--     and that belong to the current level
+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+getPendingGivenScs = do { lvl <- getTcLevel
+                        ; updRetInertCans (get_sc_pending lvl) }
+
+get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
+  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )
+       -- When getPendingScDics is called,
+       -- there are never any Wanteds in the inert set
+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })
+  where
+    sc_pending = sc_pend_insts ++ sc_pend_dicts
+
+    sc_pend_dicts = foldDicts get_pending dicts []
+    dicts' = foldr add dicts sc_pend_dicts
+
+    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
+
+    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True
+                                       -- but flipping the flag
+    get_pending dict dicts
+        | Just dict' <- isPendingScDict dict
+        , belongs_to_this_level (ctEvidence dict)
+        = dict' : dicts
+        | otherwise
+        = dicts
+
+    add :: Ct -> DictMap Ct -> DictMap Ct
+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
+        = addDict dicts cls tys ct
+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)
+
+    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
+    get_pending_inst cts qci@(QCI { qci_ev = ev })
+       | Just qci' <- isPendingScInst qci
+       , belongs_to_this_level ev
+       = (CQuantCan qci' : cts, qci')
+       | otherwise
+       = (cts, qci)
+
+    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl
+    -- We only want Givens from this level; see (3a) in
+    -- Note [The superclass story] in TcCanonical
+
+getUnsolvedInerts :: TcS ( Bag Implication
+                         , Cts     -- Tyvar eqs: a ~ ty
+                         , Cts     -- Fun eqs:   F a ~ ty
+                         , Cts )   -- All others
+-- Return all the unsolved [Wanted] or [Derived] constraints
+--
+-- Post-condition: the returned simple constraints are all fully zonked
+--                     (because they come from the inert set)
+--                 the unsolved implics may not be
+getUnsolvedInerts
+ = do { IC { inert_eqs    = tv_eqs
+           , inert_funeqs = fun_eqs
+           , inert_irreds = irreds
+           , inert_dicts  = idicts
+           } <- getInertCans
+
+      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts
+            unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts
+            unsolved_irreds  = Bag.filterBag is_unsolved irreds
+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
+            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts
+
+      ; implics <- getWorkListImplics
+
+      ; traceTcS "getUnsolvedInerts" $
+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs
+             , text "fun eqs =" <+> ppr unsolved_fun_eqs
+             , text "others =" <+> ppr unsolved_others
+             , text "implics =" <+> ppr implics ]
+
+      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }
+  where
+    add_if_unsolved :: Ct -> Cts -> Cts
+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts
+                           | otherwise      = cts
+
+    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived
+
+    -- For CFunEqCans we ignore the Derived ones, and keep
+    -- only the Wanteds for flattening.  The Derived ones
+    -- share a unification variable with the corresponding
+    -- Wanted, so we definitely don't want to participate
+    -- in unflattening
+    -- See Note [Type family equations]
+    add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts
+                         | otherwise     = cts
+
+isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool
+-- True if (a ~N ty) is in the inert set, in either Given or Wanted
+isInInertEqs eqs tv rhs
+  = case lookupDVarEnv eqs tv of
+      Nothing  -> False
+      Just cts -> any (same_pred rhs) cts
+  where
+    same_pred rhs ct
+      | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct
+      , NomEq <- eq_rel
+      , rhs `eqType` rhs2 = True
+      | otherwise         = False
+
+getNoGivenEqs :: TcLevel          -- TcLevel of this implication
+               -> [TcTyVar]       -- Skolems of this implication
+               -> TcS ( Bool      -- True <=> definitely no residual given equalities
+                      , Cts )     -- Insoluble equalities arising from givens
+-- See Note [When does an implication have given equalities?]
+getNoGivenEqs tclvl skol_tvs
+  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
+              <- getInertCans
+       ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds
+                          || anyDVarEnv eqs_given_here ieqs
+             insols = filterBag insolubleEqCt irreds
+                      -- Specifically includes ones that originated in some
+                      -- outer context but were refined to an insoluble by
+                      -- a local equality; so do /not/ add ct_given_here.
+
+       ; traceTcS "getNoGivenEqs" $
+         vcat [ if has_given_eqs then text "May have given equalities"
+                                 else text "No given equalities"
+              , text "Skols:" <+> ppr skol_tvs
+              , text "Inerts:" <+> ppr inerts
+              , text "Insols:" <+> ppr insols]
+       ; return (not has_given_eqs, insols) }
+  where
+    eqs_given_here :: EqualCtList -> Bool
+    eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]
+                              -- Givens are always a sigleton
+      = not (skolem_bound_here tv) && ct_given_here ct
+    eqs_given_here _ = False
+
+    ct_given_here :: Ct -> Bool
+    -- True for a Given bound by the current implication,
+    -- i.e. the current level
+    ct_given_here ct =  isGiven ev
+                     && tclvl == ctLocLevel (ctEvLoc ev)
+        where
+          ev = ctEvidence ct
+
+    skol_tv_set = mkVarSet skol_tvs
+    skolem_bound_here tv -- See Note [Let-bound skolems]
+      = case tcTyVarDetails tv of
+          SkolemTv {} -> tv `elemVarSet` skol_tv_set
+          _           -> False
+
+-- | Returns Given constraints that might,
+-- potentially, match the given pred. This is used when checking to see if a
+-- Given might overlap with an instance. See Note [Instance and Given overlap]
+-- in TcInteract.
+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts
+matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })
+  = filterBag matchable_given all_relevant_givens
+  where
+    -- just look in class constraints and irreds. matchableGivens does get called
+    -- for ~R constraints, but we don't need to look through equalities, because
+    -- canonical equalities are used for rewriting. We'll only get caught by
+    -- non-canonical -- that is, irreducible -- equalities.
+    all_relevant_givens :: Cts
+    all_relevant_givens
+      | Just (clas, _) <- getClassPredTys_maybe pred_w
+      = findDictsByClass (inert_dicts inert_cans) clas
+        `unionBags` inert_irreds inert_cans
+      | otherwise
+      = inert_irreds inert_cans
+
+    matchable_given :: Ct -> Bool
+    matchable_given ct
+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct
+      = mightMatchLater pred_g loc_g pred_w loc_w
+
+      | otherwise
+      = False
+
+mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
+mightMatchLater given_pred given_loc wanted_pred wanted_loc
+  =  not (prohibitedSuperClassSolve given_loc wanted_loc)
+  && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])
+  where
+    bind_meta_tv :: TcTyVar -> BindFlag
+    -- Any meta tyvar may be unified later, so we treat it as
+    -- bindable when unifying with givens. That ensures that we
+    -- conservatively assume that a meta tyvar might get unified with
+    -- something that matches the 'given', until demonstrated
+    -- otherwise.  More info in Note [Instance and Given overlap]
+    -- in TcInteract
+    bind_meta_tv tv | isMetaTyVar tv
+                    , not (isFskTyVar tv) = BindMe
+                    | otherwise           = Skolem
+
+prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
+-- See Note [Solving superclass constraints] in TcInstDcls
+prohibitedSuperClassSolve from_loc solve_loc
+  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc
+  , ScOrigin wanted_size <- ctLocOrigin solve_loc
+  = given_size >= wanted_size
+  | otherwise
+  = False
+
+{- Note [Unsolved Derived equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In getUnsolvedInerts, we return a derived equality from the inert_eqs
+because it is a candidate for floating out of this implication.  We
+only float equalities with a meta-tyvar on the left, so we only pull
+those out here.
+
+Note [When does an implication have given equalities?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider an implication
+   beta => alpha ~ Int
+where beta is a unification variable that has already been unified
+to () in an outer scope.  Then we can float the (alpha ~ Int) out
+just fine. So when deciding whether the givens contain an equality,
+we should canonicalise first, rather than just looking at the original
+givens (#8644).
+
+So we simply look at the inert, canonical Givens and see if there are
+any equalities among them, the calculation of has_given_eqs.  There
+are some wrinkles:
+
+ * We must know which ones are bound in *this* implication and which
+   are bound further out.  We can find that out from the TcLevel
+   of the Given, which is itself recorded in the tcl_tclvl field
+   of the TcLclEnv stored in the Given (ev_given_here).
+
+   What about interactions between inner and outer givens?
+      - Outer given is rewritten by an inner given, then there must
+        have been an inner given equality, hence the “given-eq” flag
+        will be true anyway.
+
+      - Inner given rewritten by outer, retains its level (ie. The inner one)
+
+ * We must take account of *potential* equalities, like the one above:
+      beta => ...blah...
+   If we still don't know what beta is, we conservatively treat it as potentially
+   becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.
+
+ * When flattening givens, we generate Given equalities like
+     <F [a]> : F [a] ~ f,
+   with Refl evidence, and we *don't* want those to count as an equality
+   in the givens!  After all, the entire flattening business is just an
+   internal matter, and the evidence does not mention any of the 'givens'
+   of this implication.  So we do not treat inert_funeqs as a 'given equality'.
+
+ * See Note [Let-bound skolems] for another wrinkle
+
+ * We do *not* need to worry about representational equalities, because
+   these do not affect the ability to float constraints.
+
+Note [Let-bound skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)
+and  * 'a' is a skolem bound in this very implication,
+
+then:
+a) The Given is pretty much a let-binding, like
+      f :: (a ~ b->c) => a -> a
+   Here the equality constraint is like saying
+      let a = b->c in ...
+   It is not adding any new, local equality  information,
+   and hence can be ignored by has_given_eqs
+
+b) 'a' will have been completely substituted out in the inert set,
+   so we can safely discard it.  Notably, it doesn't need to be
+   returned as part of 'fsks'
+
+For an example, see #9211.
+
+See also TcUnify Note [Deeper level on the left] for how we ensure
+that the right variable is on the left of the equality when both are
+tyvars.
+
+You might wonder whether the skokem really needs to be bound "in the
+very same implication" as the equuality constraint.
+(c.f. #15009) Consider this:
+
+  data S a where
+    MkS :: (a ~ Int) => S a
+
+  g :: forall a. S a -> a -> blah
+  g x y = let h = \z. ( z :: Int
+                      , case x of
+                           MkS -> [y,z])
+          in ...
+
+From the type signature for `g`, we get `y::a` .  Then when when we
+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the
+body of the lambda we'll get
+
+  [W] alpha[1] ~ Int                             -- From z::Int
+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]
+
+Now, suppose we decide to float `alpha ~ a` out of the implication
+and then unify `alpha := a`.  Now we are stuck!  But if treat
+`alpha ~ Int` first, and unify `alpha := Int`, all is fine.
+But we absolutely cannot float that equality or we will get stuck.
+-}
+
+removeInertCts :: [Ct] -> InertCans -> InertCans
+-- ^ Remove inert constraints from the 'InertCans', for use when a
+-- typechecker plugin wishes to discard a given.
+removeInertCts cts icans = foldl' removeInertCt icans cts
+
+removeInertCt :: InertCans -> Ct -> InertCans
+removeInertCt is ct =
+  case ct of
+
+    CDictCan  { cc_class = cl, cc_tyargs = tys } ->
+      is { inert_dicts = delDict (inert_dicts is) cl tys }
+
+    CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->
+      is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
+
+    CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->
+      is { inert_eqs    = delTyEq (inert_eqs is) x ty }
+
+    CQuantCan {}     -> panic "removeInertCt: CQuantCan"
+    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"
+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
+    CHoleCan {}      -> panic "removeInertCt: CHoleCan"
+
+
+lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
+lookupFlatCache fam_tc tys
+  = do { IS { inert_flat_cache = flat_cache
+            , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
+       ; return (firstJusts [lookup_inerts inert_funeqs,
+                             lookup_flats flat_cache]) }
+  where
+    lookup_inerts inert_funeqs
+      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })
+           <- findFunEq inert_funeqs fam_tc tys
+      , tys `eqTypes` xis   -- The lookup might find a near-match; see
+                            -- Note [Use loose types in inert set]
+      = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)
+      | otherwise = Nothing
+
+    lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
+
+
+lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?
+lookupInInerts loc pty
+  | ClassPred cls tys <- classifyPredType pty
+  = do { inerts <- getTcSInerts
+       ; return (lookupSolvedDict inerts loc cls tys `mplus`
+                 lookupInertDict (inert_cans inerts) loc cls tys) }
+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors
+  = return Nothing
+
+-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not
+-- match the input exactly. Note [Use loose types in inert set].
+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
+  = case findDict dicts loc cls tys of
+      Just ct -> Just (ctEvidence ct)
+      _       -> Nothing
+
+-- | Look up a solved inert. NB: the returned 'CtEvidence' might not
+-- match the input exactly. See Note [Use loose types in inert set].
+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
+-- Returns just if exactly this predicate type exists in the solved.
+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
+  = case findDict solved loc cls tys of
+      Just ev -> Just ev
+      _       -> Nothing
+
+{- *********************************************************************
+*                                                                      *
+                   Irreds
+*                                                                      *
+********************************************************************* -}
+
+foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
+foldIrreds k irreds z = foldrBag k z irreds
+
+
+{- *********************************************************************
+*                                                                      *
+                   TcAppMap
+*                                                                      *
+************************************************************************
+
+Note [Use loose types in inert set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly
+solvable from the other. So, we do lookup in the inert set using
+loose types, which omit the kind-check.
+
+We must be careful when using the result of a lookup because it may
+not match the requested info exactly!
+
+-}
+
+type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)
+    -- Indexed by tycon then the arg types, using "loose" matching, where
+    -- we don't require kind equality. This allows, for example, (a |> co)
+    -- to match (a).
+    -- See Note [Use loose types in inert set]
+    -- Used for types and classes; hence UniqDFM
+    -- See Note [foldTM determinism] for why we use UniqDFM here
+
+isEmptyTcAppMap :: TcAppMap a -> Bool
+isEmptyTcAppMap m = isNullUDFM m
+
+emptyTcAppMap :: TcAppMap a
+emptyTcAppMap = emptyUDFM
+
+findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a
+findTcApp m u tys = do { tys_map <- lookupUDFM m u
+                       ; lookupTM tys tys_map }
+
+delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a
+delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls
+
+insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a
+insertTcApp m cls tys ct = alterUDFM alter_tm m cls
+  where
+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
+
+-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b
+-- mapTcApp f = mapUDFM (mapTM f)
+
+filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
+filterTcAppMap f m
+  = mapUDFM do_tm m
+  where
+    do_tm tm = foldTM insert_mb tm emptyTM
+    insert_mb ct tm
+       | f ct      = insertTM tys ct tm
+       | otherwise = tm
+       where
+         tys = case ct of
+                CFunEqCan { cc_tyargs = tys } -> tys
+                CDictCan  { cc_tyargs = tys } -> tys
+                _ -> pprPanic "filterTcAppMap" (ppr ct)
+
+tcAppMapToBag :: TcAppMap a -> Bag a
+tcAppMapToBag m = foldTcAppMap consBag m emptyBag
+
+foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
+foldTcAppMap k m z = foldUDFM (foldTM k) z m
+
+
+{- *********************************************************************
+*                                                                      *
+                   DictMap
+*                                                                      *
+********************************************************************* -}
+
+
+{- Note [Tuples hiding implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f,g :: (?x::Int, C a) => a -> a
+   f v = let ?x = 4 in g v
+
+The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).
+We must /not/ solve this from the Given (?x::Int, C a), because of
+the intervening binding for (?x::Int).  #14218.
+
+We deal with this by arranging that we always fail when looking up a
+tuple constraint that hides an implicit parameter. Not that this applies
+  * both to the inert_dicts (lookupInertDict)
+  * and to the solved_dicts (looukpSolvedDict)
+An alternative would be not to extend these sets with such tuple
+constraints, but it seemed more direct to deal with the lookup.
+
+Note [Solving CallStack constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose f :: HasCallStack => blah.  Then
+
+* Each call to 'f' gives rise to
+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f
+  with a CtOrigin that says "OccurrenceOf f".
+  Remember that HasCallStack is just shorthand for
+    IP "callStack CallStack
+  See Note [Overview of implicit CallStacks] in TcEvidence
+
+* We cannonicalise such constraints, in TcCanonical.canClassNC, by
+  pushing the call-site info on the stack, and changing the CtOrigin
+  to record that has been done.
+   Bind:  s1 = pushCallStack <site-info> s2
+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin
+
+* Then, and only then, we can solve the constraint from an enclosing
+  Given.
+
+So we must be careful /not/ to solve 's1' from the Givens.  Again,
+we ensure this by arranging that findDict always misses when looking
+up souch constraints.
+-}
+
+type DictMap a = TcAppMap a
+
+emptyDictMap :: DictMap a
+emptyDictMap = emptyTcAppMap
+
+findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
+findDict m loc cls tys
+  | isCTupleClass cls
+  , any hasIPPred tys   -- See Note [Tuples hiding implicit parameters]
+  = Nothing
+
+  | Just {} <- isCallStackPred cls tys
+  , OccurrenceOf {} <- ctLocOrigin loc
+  = Nothing             -- See Note [Solving CallStack constraints]
+
+  | otherwise
+  = findTcApp m (getUnique cls) tys
+
+findDictsByClass :: DictMap a -> Class -> Bag a
+findDictsByClass m cls
+  | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag
+  | otherwise                  = emptyBag
+
+delDict :: DictMap a -> Class -> [Type] -> DictMap a
+delDict m cls tys = delTcApp m (getUnique cls) tys
+
+addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
+addDict m cls tys item = insertTcApp m (getUnique cls) tys item
+
+addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
+addDictsByClass m cls items
+  = addToUDFM m cls (foldrBag add emptyTM items)
+  where
+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
+    add ct _ = pprPanic "addDictsByClass" (ppr ct)
+
+filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
+filterDicts f m = filterTcAppMap f m
+
+partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)
+  where
+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)
+                       | otherwise = (yeses,              add ct noes)
+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m
+      = addDict m cls tys ct
+    add ct _ = pprPanic "partitionDicts" (ppr ct)
+
+dictsToBag :: DictMap a -> Bag a
+dictsToBag = tcAppMapToBag
+
+foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
+foldDicts = foldTcAppMap
+
+emptyDicts :: DictMap a
+emptyDicts = emptyTcAppMap
+
+
+{- *********************************************************************
+*                                                                      *
+                   FunEqMap
+*                                                                      *
+********************************************************************* -}
+
+type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair
+
+emptyFunEqs :: TcAppMap a
+emptyFunEqs = emptyTcAppMap
+
+findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
+findFunEq m tc tys = findTcApp m (getUnique tc) tys
+
+funEqsToBag :: FunEqMap a -> Bag a
+funEqsToBag m = foldTcAppMap consBag m emptyBag
+
+findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
+-- Get inert function equation constraints that have the given tycon
+-- in their head.  Not that the constraints remain in the inert set.
+-- We use this to check for derived interactions with built-in type-function
+-- constructors.
+findFunEqsByTyCon m tc
+  | Just tm <- lookupUDFM m tc = foldTM (:) tm []
+  | otherwise                 = []
+
+foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
+foldFunEqs = foldTcAppMap
+
+-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b
+-- mapFunEqs = mapTcApp
+
+-- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
+-- filterFunEqs = filterTcAppMap
+
+insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
+insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
+
+partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
+-- Optimise for the case where the predicate is false
+-- partitionFunEqs is called only from kick-out, and kick-out usually
+-- kicks out very few equalities, so we want to optimise for that case
+partitionFunEqs f m = (yeses, foldr del m yeses)
+  where
+    yeses = foldTcAppMap k m []
+    k ct yeses | f ct      = ct : yeses
+               | otherwise = yeses
+    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
+        = delFunEq m tc tys
+    del ct _ = pprPanic "partitionFunEqs" (ppr ct)
+
+delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
+delFunEq m tc tys = delTcApp m (getUnique tc) tys
+
+------------------------------
+type ExactFunEqMap a = UniqFM (ListMap TypeMap a)
+
+emptyExactFunEqs :: ExactFunEqMap a
+emptyExactFunEqs = emptyUFM
+
+findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
+findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)
+                             ; lookupTM tys tys_map }
+
+insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
+insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)
+  where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
+
+{-
+************************************************************************
+*                                                                      *
+*              The TcS solver monad                                    *
+*                                                                      *
+************************************************************************
+
+Note [The TcS monad]
+~~~~~~~~~~~~~~~~~~~~
+The TcS monad is a weak form of the main Tc monad
+
+All you can do is
+    * fail
+    * allocate new variables
+    * fill in evidence variables
+
+Filling in a dictionary evidence variable means to create a binding
+for it, so TcS carries a mutable location where the binding can be
+added.  This is initialised from the innermost implication constraint.
+-}
+
+data TcSEnv
+  = TcSEnv {
+      tcs_ev_binds    :: EvBindsVar,
+
+      tcs_unified     :: IORef Int,
+         -- The number of unification variables we have filled
+         -- The important thing is whether it is non-zero
+
+      tcs_count     :: IORef Int, -- Global step count
+
+      tcs_inerts    :: IORef InertSet, -- Current inert set
+
+      -- The main work-list and the flattening worklist
+      -- See Note [Work list priorities] and
+      tcs_worklist  :: IORef WorkList -- Current worklist
+    }
+
+---------------
+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
+
+instance Functor TcS where
+  fmap f m = TcS $ fmap f . unTcS m
+
+instance Applicative TcS where
+  pure x = TcS (\_ -> return x)
+  (<*>) = ap
+
+instance Monad TcS where
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
+
+instance MonadFail.MonadFail TcS where
+  fail err  = TcS (\_ -> fail err)
+
+instance MonadUnique TcS where
+   getUniqueSupplyM = wrapTcS getUniqueSupplyM
+
+instance HasModule TcS where
+   getModule = wrapTcS getModule
+
+instance MonadThings TcS where
+   lookupThing n = wrapTcS (lookupThing n)
+
+-- Basic functionality
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+wrapTcS :: TcM a -> TcS a
+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
+-- and TcS is supposed to have limited functionality
+wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
+
+wrapErrTcS :: TcM a -> TcS a
+-- The thing wrapped should just fail
+-- There's no static check; it's up to the user
+-- Having a variant for each error message is too painful
+wrapErrTcS = wrapTcS
+
+wrapWarnTcS :: TcM a -> TcS a
+-- The thing wrapped should just add a warning, or no-op
+-- There's no static check; it's up to the user
+wrapWarnTcS = wrapTcS
+
+failTcS, panicTcS  :: SDoc -> TcS a
+warnTcS   :: WarningFlag -> SDoc -> TcS ()
+addErrTcS :: SDoc -> TcS ()
+failTcS      = wrapTcS . TcM.failWith
+warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)
+addErrTcS    = wrapTcS . TcM.addErr
+panicTcS doc = pprPanic "TcCanonical" doc
+
+traceTcS :: String -> SDoc -> TcS ()
+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
+
+runTcPluginTcS :: TcPluginM a -> TcS a
+runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar
+
+instance HasDynFlags TcS where
+    getDynFlags = wrapTcS getDynFlags
+
+getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv
+
+bumpStepCountTcS :: TcS ()
+bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
+                                    ; n <- TcM.readTcRef ref
+                                    ; TcM.writeTcRef ref (n+1) }
+
+csTraceTcS :: SDoc -> TcS ()
+csTraceTcS doc
+  = wrapTcS $ csTraceTcM (return doc)
+
+traceFireTcS :: CtEvidence -> SDoc -> TcS ()
+-- Dump a rule-firing trace
+traceFireTcS ev doc
+  = TcS $ \env -> csTraceTcM $
+    do { n <- TcM.readTcRef (tcs_count env)
+       ; tclvl <- TcM.getTcLevel
+       ; return (hang (text "Step" <+> int n
+                       <> brackets (text "l:" <> ppr tclvl <> comma <>
+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))
+                       <+> doc <> colon)
+                     4 (ppr ev)) }
+
+csTraceTcM :: TcM SDoc -> TcM ()
+-- Constraint-solver tracing, -ddump-cs-trace
+csTraceTcM mk_doc
+  = do { dflags <- getDynFlags
+       ; when (  dopt Opt_D_dump_cs_trace dflags
+                  || dopt Opt_D_dump_tc_trace dflags )
+              ( do { msg <- mk_doc
+                   ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }
+
+runTcS :: TcS a                -- What to run
+       -> TcM (a, EvBindMap)
+runTcS tcs
+  = do { ev_binds_var <- TcM.newTcEvBinds
+       ; res <- runTcSWithEvBinds ev_binds_var tcs
+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
+       ; return (res, ev_binds) }
+
+-- | This variant of 'runTcS' will keep solving, even when only Deriveds
+-- are left around. It also doesn't return any evidence, as callers won't
+-- need it.
+runTcSDeriveds :: TcS a -> TcM a
+runTcSDeriveds tcs
+  = do { ev_binds_var <- TcM.newTcEvBinds
+       ; runTcSWithEvBinds ev_binds_var tcs }
+
+-- | This can deal only with equality constraints.
+runTcSEqualities :: TcS a -> TcM a
+runTcSEqualities thing_inside
+  = do { ev_binds_var <- TcM.newNoTcEvBinds
+       ; runTcSWithEvBinds ev_binds_var thing_inside }
+
+runTcSWithEvBinds :: EvBindsVar
+                  -> TcS a
+                  -> TcM a
+runTcSWithEvBinds ev_binds_var tcs
+  = do { unified_var <- TcM.newTcRef 0
+       ; step_count <- TcM.newTcRef 0
+       ; inert_var <- TcM.newTcRef emptyInert
+       ; wl_var <- TcM.newTcRef emptyWorkList
+       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var
+                          , tcs_unified       = unified_var
+                          , tcs_count         = step_count
+                          , tcs_inerts        = inert_var
+                          , tcs_worklist      = wl_var }
+
+             -- Run the computation
+       ; res <- unTcS tcs env
+
+       ; count <- TcM.readTcRef step_count
+       ; when (count > 0) $
+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
+
+       ; unflattenGivens inert_var
+
+#if defined(DEBUG)
+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
+       ; checkForCyclicBinds ev_binds
+#endif
+
+       ; return res }
+
+----------------------------
+#if defined(DEBUG)
+checkForCyclicBinds :: EvBindMap -> TcM ()
+checkForCyclicBinds ev_binds_map
+  | null cycles
+  = return ()
+  | null coercion_cycles
+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles
+  | otherwise
+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
+  where
+    ev_binds = evBindMapBinds ev_binds_map
+
+    cycles :: [[EvBind]]
+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]
+
+    coercion_cycles = [c | c <- cycles, any is_co_bind c]
+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)
+
+    edges :: [ Node EvVar EvBind ]
+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
+            -- It's OK to use nonDetEltsUFM here as
+            -- stronglyConnCompFromEdgedVertices is still deterministic even
+            -- if the edges are in nondeterministic order as explained in
+            -- Note [Deterministic SCC] in Digraph.
+#endif
+
+----------------------------
+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a
+setEvBindsTcS ref (TcS thing_inside)
+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })
+
+nestImplicTcS :: EvBindsVar
+              -> TcLevel -> TcS a
+              -> TcS a
+nestImplicTcS ref inner_tclvl (TcS thing_inside)
+  = TcS $ \ TcSEnv { tcs_unified       = unified_var
+                   , tcs_inerts        = old_inert_var
+                   , tcs_count         = count
+                   } ->
+    do { inerts <- TcM.readTcRef old_inert_var
+       ; let nest_inert = emptyInert
+                            { inert_cans = inert_cans inerts
+                            , inert_solved_dicts = inert_solved_dicts inerts }
+                              -- See Note [Do not inherit the flat cache]
+       ; new_inert_var <- TcM.newTcRef nest_inert
+       ; new_wl_var    <- TcM.newTcRef emptyWorkList
+       ; let nest_env = TcSEnv { tcs_ev_binds      = ref
+                               , tcs_unified       = unified_var
+                               , tcs_count         = count
+                               , tcs_inerts        = new_inert_var
+                               , tcs_worklist      = new_wl_var }
+       ; res <- TcM.setTcLevel inner_tclvl $
+                thing_inside nest_env
+
+       ; unflattenGivens new_inert_var
+
+#if defined(DEBUG)
+       -- Perform a check that the thing_inside did not cause cycles
+       ; ev_binds <- TcM.getTcEvBindsMap ref
+       ; checkForCyclicBinds ev_binds
+#endif
+       ; return res }
+
+{- Note [Do not inherit the flat cache]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want to inherit the flat cache when processing nested
+implications.  Consider
+   a ~ F b, forall c. b~Int => blah
+If we have F b ~ fsk in the flat-cache, and we push that into the
+nested implication, we might miss that F b can be rewritten to F Int,
+and hence perhpas solve it.  Moreover, the fsk from outside is
+flattened out after solving the outer level, but and we don't
+do that flattening recursively.
+-}
+
+nestTcS ::  TcS a -> TcS a
+-- Use the current untouchables, augmenting the current
+-- evidence bindings, and solved dictionaries
+-- But have no effect on the InertCans, or on the inert_flat_cache
+-- (we want to inherit the latter from processing the Givens)
+nestTcS (TcS thing_inside)
+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
+    do { inerts <- TcM.readTcRef inerts_var
+       ; new_inert_var <- TcM.newTcRef inerts
+       ; new_wl_var    <- TcM.newTcRef emptyWorkList
+       ; let nest_env = env { tcs_inerts   = new_inert_var
+                            , tcs_worklist = new_wl_var }
+
+       ; res <- thing_inside nest_env
+
+       ; new_inerts <- TcM.readTcRef new_inert_var
+
+       -- we want to propogate the safe haskell failures
+       ; let old_ic = inert_cans inerts
+             new_ic = inert_cans new_inerts
+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }
+
+       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]
+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts
+                                , inert_cans = nxt_ic })
+
+       ; return res }
+
+checkTvConstraintsTcS :: SkolemInfo
+                      -> [TcTyVar]        -- Skolems
+                      -> TcS (result, Cts)
+                      -> TcS result
+-- Just like TcUnify.checkTvConstraints, but
+--   - In the TcS monnad
+--   - The thing-inside should not put things in the work-list
+--     Instead, it returns the Wanted constraints it needs
+--   - No 'givens', and no TcEvBinds; this is type-level constraints only
+checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)
+  = TcS $ \ tcs_env ->
+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
+                         ppr skol_info $$ ppr skol_tvs
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
+
+       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
+                                        thing_inside new_tcs_env
+
+       ; unless (null wanteds) $
+         do { ev_binds_var <- TcM.newNoTcEvBinds
+            ; imp <- newImplication
+            ; let wc = emptyWC { wc_simple = wanteds }
+                  imp' = imp { ic_tclvl  = new_tclvl
+                             , ic_skols  = skol_tvs
+                             , ic_wanted = wc
+                             , ic_binds  = ev_binds_var
+                             , ic_info   = skol_info }
+
+           -- Add the implication to the work-list
+           ; TcM.updTcRef (tcs_worklist tcs_env)
+                          (extendWorkListImplic (unitBag imp')) }
+
+      ; return res }
+
+checkConstraintsTcS :: SkolemInfo
+                    -> [TcTyVar]        -- Skolems
+                    -> [EvVar]          -- Givens
+                    -> TcS (result, Cts)
+                    -> TcS (result, TcEvBinds)
+-- Just like checkConstraintsTcS, but
+--   - In the TcS monnad
+--   - The thing-inside should not put things in the work-list
+--     Instead, it returns the Wanted constraints it needs
+--   - I did not bother to put in the fast-path for
+--     empty-skols/empty-givens, or for empty-wanteds, because
+--     this function is used only for "quantified constraints" in
+--     with both tests are pretty much guaranteed to fail
+checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)
+  = TcS $ \ tcs_env ->
+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
+                         ppr skol_info $$ ppr skol_tvs
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
+
+       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
+                                        thing_inside new_tcs_env
+
+       ; ev_binds_var <- TcM.newTcEvBinds
+       ; imp <- newImplication
+       ; let wc = emptyWC { wc_simple = wanteds }
+             imp' = imp { ic_tclvl  = new_tclvl
+                        , ic_skols  = skol_tvs
+                        , ic_given  = given
+                        , ic_wanted = wc
+                        , ic_binds  = ev_binds_var
+                        , ic_info   = skol_info }
+
+           -- Add the implication to the work-list
+       ; TcM.updTcRef (tcs_worklist tcs_env)
+                      (extendWorkListImplic (unitBag imp'))
+
+       ; return (res, TcEvBinds ev_binds_var) }
+
+{-
+Note [Propagate the solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's really quite important that nestTcS does not discard the solved
+dictionaries from the thing_inside.
+Consider
+   Eq [a]
+   forall b. empty =>  Eq [a]
+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to
+the implications.  It's definitely fine to use the solved dictionaries on
+the inner implications, and it can make a signficant performance difference
+if you do so.
+-}
+
+-- Getters and setters of TcEnv fields
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- Getter of inerts and worklist
+getTcSInertsRef :: TcS (IORef InertSet)
+getTcSInertsRef = TcS (return . tcs_inerts)
+
+getTcSWorkListRef :: TcS (IORef WorkList)
+getTcSWorkListRef = TcS (return . tcs_worklist)
+
+getTcSInerts :: TcS InertSet
+getTcSInerts = getTcSInertsRef >>= readTcRef
+
+setTcSInerts :: InertSet -> TcS ()
+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }
+
+getWorkListImplics :: TcS (Bag Implication)
+getWorkListImplics
+  = do { wl_var <- getTcSWorkListRef
+       ; wl_curr <- readTcRef wl_var
+       ; return (wl_implics wl_curr) }
+
+updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
+updWorkListTcS f
+  = do { wl_var <- getTcSWorkListRef
+       ; updTcRef wl_var f }
+
+emitWorkNC :: [CtEvidence] -> TcS ()
+emitWorkNC evs
+  | null evs
+  = return ()
+  | otherwise
+  = emitWork (map mkNonCanonical evs)
+
+emitWork :: [Ct] -> TcS ()
+emitWork cts
+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
+       ; updWorkListTcS (extendWorkListCts cts) }
+
+newTcRef :: a -> TcS (TcRef a)
+newTcRef x = wrapTcS (TcM.newTcRef x)
+
+readTcRef :: TcRef a -> TcS a
+readTcRef ref = wrapTcS (TcM.readTcRef ref)
+
+writeTcRef :: TcRef a -> a -> TcS ()
+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)
+
+updTcRef :: TcRef a -> (a->a) -> TcS ()
+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
+
+getTcEvBindsVar :: TcS EvBindsVar
+getTcEvBindsVar = TcS (return . tcs_ev_binds)
+
+getTcLevel :: TcS TcLevel
+getTcLevel = wrapTcS TcM.getTcLevel
+
+getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var
+
+getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap
+getTcEvBindsMap ev_binds_var
+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()
+setTcEvBindsMap ev_binds_var binds
+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds
+
+unifyTyVar :: TcTyVar -> TcType -> TcS ()
+-- Unify a meta-tyvar with a type
+-- We keep track of how many unifications have happened in tcs_unified,
+--
+-- We should never unify the same variable twice!
+unifyTyVar tv ty
+  = ASSERT2( isMetaTyVar tv, ppr tv )
+    TcS $ \ env ->
+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)
+       ; TcM.writeMetaTyVar tv ty
+       ; TcM.updTcRef (tcs_unified env) (+1) }
+
+reportUnifications :: TcS a -> TcS (Int, a)
+reportUnifications (TcS thing_inside)
+  = TcS $ \ env ->
+    do { inner_unified <- TcM.newTcRef 0
+       ; res <- thing_inside (env { tcs_unified = inner_unified })
+       ; n_unifs <- TcM.readTcRef inner_unified
+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)
+       ; return (n_unifs, res) }
+
+getDefaultInfo ::  TcS ([Type], (Bool, Bool))
+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
+
+-- Just get some environments needed for instance looking up and matching
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+getInstEnvs :: TcS InstEnvs
+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs
+
+getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
+
+getTopEnv :: TcS HscEnv
+getTopEnv = wrapTcS $ TcM.getTopEnv
+
+getGblEnv :: TcS TcGblEnv
+getGblEnv = wrapTcS $ TcM.getGblEnv
+
+getLclEnv :: TcS TcLclEnv
+getLclEnv = wrapTcS $ TcM.getLclEnv
+
+tcLookupClass :: Name -> TcS Class
+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
+
+tcLookupId :: Name -> TcS Id
+tcLookupId n = wrapTcS $ TcM.tcLookupId n
+
+-- Setting names as used (used in the deriving of Coercible evidence)
+-- Too hackish to expose it to TcS? In that case somehow extract the used
+-- constructors from the result of solveInteract
+addUsedGREs :: [GlobalRdrElt] -> TcS ()
+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres
+
+addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
+
+
+-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
+-- Check that we do not try to use an instance before it is available.  E.g.
+--    instance Eq T where ...
+--    f x = $( ... (\(p::T) -> p == p)... )
+-- Here we can't use the equality function from the instance in the splice
+
+checkWellStagedDFun loc what pred
+  | TopLevInstance { iw_dfun_id = dfun_id } <- what
+  , let bind_lvl = TcM.topIdLvl dfun_id
+  , bind_lvl > impLevel
+  = wrapTcS $ TcM.setCtLocM loc $
+    do { use_stage <- TcM.getStage
+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
+
+  | otherwise
+  = return ()    -- Fast path for common case
+  where
+    pp_thing = text "instance for" <+> quotes (ppr pred)
+
+pprEq :: TcType -> TcType -> SDoc
+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
+
+isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)
+
+isFilledMetaTyVar :: TcTyVar -> TcS Bool
+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
+
+zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet
+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)
+
+zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]
+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)
+
+zonkCo :: Coercion -> TcS Coercion
+zonkCo = wrapTcS . TcM.zonkCo
+
+zonkTcType :: TcType -> TcS TcType
+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)
+
+zonkTcTypes :: [TcType] -> TcS [TcType]
+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)
+
+zonkTcTyVar :: TcTyVar -> TcS TcType
+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)
+
+zonkSimples :: Cts -> TcS Cts
+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
+
+zonkWC :: WantedConstraints -> TcS WantedConstraints
+zonkWC wc = wrapTcS (TcM.zonkWC wc)
+
+zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
+
+{- *********************************************************************
+*                                                                      *
+*                Flatten skolems                                       *
+*                                                                      *
+********************************************************************* -}
+
+newFlattenSkolem :: CtFlavour -> CtLoc
+                 -> TyCon -> [TcType]                    -- F xis
+                 -> TcS (CtEvidence, Coercion, TcTyVar)  -- [G/WD] x:: F xis ~ fsk
+newFlattenSkolem flav loc tc xis
+  = do { stuff@(ev, co, fsk) <- new_skolem
+       ; let fsk_ty = mkTyVarTy fsk
+       ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)
+       ; return stuff }
+  where
+    fam_ty = mkTyConApp tc xis
+
+    new_skolem
+      | Given <- flav
+      = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)
+
+           -- Extend the inert_fsks list, for use by unflattenGivens
+           ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is }
+
+           -- Construct the Refl evidence
+           ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
+                 co   = mkNomReflCo fam_ty
+           ; ev  <- newGivenEvVar loc (pred, evCoercion co)
+           ; return (ev, co, fsk) }
+
+      | otherwise  -- Generate a [WD] for both Wanted and Derived
+                   -- See Note [No Derived CFunEqCans]
+      = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)
+           ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)
+           ; return (ev, hole_co, fmv) }
+
+----------------------------
+unflattenGivens :: IORef InertSet -> TcM ()
+-- Unflatten all the fsks created by flattening types in Given
+-- constraints. We must be sure to do this, else we end up with
+-- flatten-skolems buried in any residual Wanteds
+--
+-- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)
+--     is filled in. Nothing else does so.
+--
+-- It's here (rather than in TcFlatten) because the Right Places
+-- to call it are in runTcSWithEvBinds/nestImplicTcS, where it
+-- is nicely paired with the creation an empty inert_fsks list.
+unflattenGivens inert_var
+ = do { inerts <- TcM.readTcRef inert_var
+       ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))
+       ; mapM_ flatten_one (inert_fsks inerts) }
+  where
+    flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty
+
+----------------------------
+extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()
+extendFlatCache tc xi_args stuff@(_, ty, fl)
+  | isGivenOrWDeriv fl  -- Maintain the invariant that inert_flat_cache
+                        -- only has [G] and [WD] CFunEqCans
+  = do { dflags <- getDynFlags
+       ; when (gopt Opt_FlatCache dflags) $
+    do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args
+                                          , ppr fl, ppr ty ])
+            -- 'co' can be bottom, in the case of derived items
+       ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->
+            is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }
+
+  | otherwise
+  = return ()
+
+----------------------------
+unflattenFmv :: TcTyVar -> TcType -> TcS ()
+-- Fill a flatten-meta-var, simply by unifying it.
+-- This does NOT count as a unification in tcs_unified.
+unflattenFmv tv ty
+  = ASSERT2( isMetaTyVar tv, ppr tv )
+    TcS $ \ _ ->
+    do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)
+       ; TcM.writeMetaTyVar tv ty }
+
+----------------------------
+demoteUnfilledFmv :: TcTyVar -> TcS ()
+-- If a flatten-meta-var is still un-filled,
+-- turn it into an ordinary meta-var
+demoteUnfilledFmv fmv
+  = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv
+                 ; unless is_filled $
+                   do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
+                      ; TcM.writeMetaTyVar fmv tv_ty } }
+
+-----------------------------
+dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
+-- (dischargeFunEq tv co ty)
+--     Preconditions
+--       - ev :: F tys ~ tv   is a CFunEqCan
+--       - tv is a FlatMetaTv of FlatSkolTv
+--       - co :: F tys ~ xi
+--       - fmv/fsk `notElem` xi
+--       - fmv not filled (for Wanteds)
+--
+-- Then for [W] or [WD], we actually fill in the fmv:
+--      set fmv := xi,
+--      set ev  := co
+--      kick out any inert things that are now rewritable
+--
+-- For [D], we instead emit an equality that must ultimately hold
+--      [D] xi ~ fmv
+--      Does not evaluate 'co' if 'ev' is Derived
+--
+-- For [G], emit this equality
+--     [G] (sym ev; co) :: fsk ~ xi
+
+-- See TcFlatten Note [The flattening story],
+-- especially "Ownership of fsk/fmv"
+dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi
+  = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co  )
+       ; emitWorkNC [new_ev] }
+  where
+    new_pred = mkPrimEqPred (mkTyVarTy fsk) xi
+    new_co   = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co
+
+dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi
+  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
+    do { setWantedEvTerm dest (evCoercion co)
+       ; unflattenFmv fmv xi
+       ; n_kicked <- kickOutAfterUnification fmv
+       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }
+
+dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi
+  = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)
+              -- FunEqs are always at Nominal role
+
+pprKicked :: Int -> SDoc
+pprKicked 0 = empty
+pprKicked n = parens (int n <+> text "kicked out")
+
+{- *********************************************************************
+*                                                                      *
+*                Instantiation etc.
+*                                                                      *
+********************************************************************* -}
+
+-- Instantiations
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)
+instDFunType dfun_id inst_tys
+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys
+
+newFlexiTcSTy :: Kind -> TcS TcType
+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
+
+cloneMetaTyVar :: TcTyVar -> TcS TcTyVar
+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
+
+instFlexi :: [TKVar] -> TcS TCvSubst
+instFlexi = instFlexiX emptyTCvSubst
+
+instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst
+instFlexiX subst tvs
+  = wrapTcS (foldlM instFlexiHelper subst tvs)
+
+instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst
+instFlexiHelper subst tv
+  = do { uniq <- TcM.newUnique
+       ; details <- TcM.newMetaDetails TauTv
+       ; let name = setNameUnique (tyVarName tv) uniq
+             kind = substTyUnchecked subst (tyVarKind tv)
+             ty'  = mkTyVarTy (mkTcTyVar name kind details)
+       ; TcM.traceTc "instFlexi" (ppr ty')
+       ; return (extendTvSubst subst tv ty') }
+
+matchGlobalInst :: DynFlags
+                -> Bool      -- True <=> caller is the short-cut solver
+                             -- See Note [Shortcut solving: overlap]
+                -> Class -> [Type] -> TcS TcM.ClsInstResult
+matchGlobalInst dflags short_cut cls tys
+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)
+
+tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])
+tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs
+
+-- Creating and setting evidence variables and CtFlavors
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+data MaybeNew = Fresh CtEvidence | Cached EvExpr
+
+isFresh :: MaybeNew -> Bool
+isFresh (Fresh {})  = True
+isFresh (Cached {}) = False
+
+freshGoals :: [MaybeNew] -> [CtEvidence]
+freshGoals mns = [ ctev | Fresh ctev <- mns ]
+
+getEvExpr :: MaybeNew -> EvExpr
+getEvExpr (Fresh ctev) = ctEvExpr ctev
+getEvExpr (Cached evt) = evt
+
+setEvBind :: EvBind -> TcS ()
+setEvBind ev_bind
+  = do { evb <- getTcEvBindsVar
+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }
+
+-- | Mark variables as used filling a coercion hole
+useVars :: CoVarSet -> TcS ()
+useVars co_vars
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; let ref = ebv_tcvs ev_binds_var
+       ; wrapTcS $
+         do { tcvs <- TcM.readTcRef ref
+            ; let tcvs' = tcvs `unionVarSet` co_vars
+            ; TcM.writeTcRef ref tcvs' } }
+
+-- | Equalities only
+setWantedEq :: TcEvDest -> Coercion -> TcS ()
+setWantedEq (HoleDest hole) co
+  = do { useVars (coVarsOfCo co)
+       ; wrapTcS $ TcM.fillCoercionHole hole co }
+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)
+
+-- | Good for both equalities and non-equalities
+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()
+setWantedEvTerm (HoleDest hole) tm
+  | Just co <- evTermCoercion_maybe tm
+  = do { useVars (coVarsOfCo co)
+       ; wrapTcS $ TcM.fillCoercionHole hole co }
+  | otherwise
+  = do { let co_var = coHoleCoVar hole
+       ; setEvBind (mkWantedEvBind co_var tm)
+       ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) }
+
+setWantedEvTerm (EvVarDest ev_id) tm
+  = setEvBind (mkWantedEvBind ev_id tm)
+
+setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
+setEvBindIfWanted ev tm
+  = case ev of
+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm
+      _                             -> return ()
+
+newTcEvBinds :: TcS EvBindsVar
+newTcEvBinds = wrapTcS TcM.newTcEvBinds
+
+newNoTcEvBinds :: TcS EvBindsVar
+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
+
+newEvVar :: TcPredType -> TcS EvVar
+newEvVar pred = wrapTcS (TcM.newEvVar pred)
+
+newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
+-- Make a new variable of the given PredType,
+-- immediately bind it to the given term
+-- and return its CtEvidence
+-- See Note [Bind new Givens immediately] in TcRnTypes
+newGivenEvVar loc (pred, rhs)
+  = do { new_ev <- newBoundEvVarId pred rhs
+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }
+
+-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the
+-- given term
+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar
+newBoundEvVarId pred rhs
+  = do { new_ev <- newEvVar pred
+       ; setEvBind (mkGivenEvBind new_ev rhs)
+       ; return new_ev }
+
+newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]
+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
+
+emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion
+-- | Emit a new Wanted equality into the work-list
+emitNewWantedEq loc role ty1 ty2
+  = do { (ev, co) <- newWantedEq loc role ty1 ty2
+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))
+       ; return co }
+
+-- | Make a new equality CtEvidence
+newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)
+newWantedEq loc role ty1 ty2
+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty
+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
+       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
+                           , ctev_nosh = WDeriv
+                           , ctev_loc = loc}
+                , mkHoleCo hole ) }
+  where
+    pty = mkPrimEqPredRole role ty1 ty2
+
+-- no equalities here. Use newWantedEq instead
+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
+-- Don't look up in the solved/inerts; we know it's not there
+newWantedEvVarNC loc pty
+  = do { new_ev <- newEvVar pty
+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
+                                         pprCtLoc loc)
+       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev
+                          , ctev_nosh = WDeriv
+                          , ctev_loc = loc })}
+
+newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
+-- For anything except ClassPred, this is the same as newWantedEvVarNC
+newWantedEvVar loc pty
+  = do { mb_ct <- lookupInInerts loc pty
+       ; case mb_ct of
+            Just ctev
+              | not (isDerived ctev)
+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
+                    ; return $ Cached (ctEvExpr ctev) }
+            _ -> do { ctev <- newWantedEvVarNC loc pty
+                    ; return (Fresh ctev) } }
+
+-- deals with both equalities and non equalities. Tries to look
+-- up non-equalities in the cache
+newWanted :: CtLoc -> PredType -> TcS MaybeNew
+newWanted loc pty
+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
+  = Fresh . fst <$> newWantedEq loc role ty1 ty2
+  | otherwise
+  = newWantedEvVar loc pty
+
+-- deals with both equalities and non equalities. Doesn't do any cache lookups.
+newWantedNC :: CtLoc -> PredType -> TcS CtEvidence
+newWantedNC loc pty
+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
+  = fst <$> newWantedEq loc role ty1 ty2
+  | otherwise
+  = newWantedEvVarNC loc pty
+
+emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()
+emitNewDeriveds loc preds
+  | null preds
+  = return ()
+  | otherwise
+  = do { evs <- mapM (newDerivedNC loc) preds
+       ; traceTcS "Emitting new deriveds" (ppr evs)
+       ; updWorkListTcS (extendWorkListDeriveds evs) }
+
+emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()
+-- Create new equality Derived and put it in the work list
+-- There's no caching, no lookupInInerts
+emitNewDerivedEq loc role ty1 ty2
+  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)
+       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)
+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }
+         -- Very important: put in the wl_eqs
+         -- See Note [Prioritise equalities] (Avoiding fundep iteration)
+
+newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence
+newDerivedNC loc pred
+  = do { -- checkReductionDepth loc pred
+       ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }
+
+-- --------- Check done in TcInteract.selectNewWorkItem???? ---------
+-- | Checks if the depth of the given location is too much. Fails if
+-- it's too big, with an appropriate error message.
+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced
+                    -> TcS ()
+checkReductionDepth loc ty
+  = do { dflags <- getDynFlags
+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $
+         wrapErrTcS $
+         solverDepthErrorTcS loc ty }
+
+matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType))
+matchFam tycon args = wrapTcS $ matchFamTcM tycon args
+
+matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))
+-- Given (F tys) return (ty, co), where co :: F tys ~ ty
+matchFamTcM tycon args
+  = do { fam_envs <- FamInst.tcGetFamInstEnvs
+       ; let match_fam_result
+              = reduceTyFamApp_maybe fam_envs Nominal tycon args
+       ; TcM.traceTc "matchFamTcM" $
+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)
+              , ppr_res match_fam_result ]
+       ; return match_fam_result }
+  where
+    ppr_res Nothing        = text "Match failed"
+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")
+                                2 (vcat [ text "Rewrites to:" <+> ppr ty
+                                        , text "Coercion:" <+> ppr co ])
+
+{-
+Note [Residual implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The wl_implics in the WorkList are the residual implication
+constraints that are generated while solving or canonicalising the
+current worklist.  Specifically, when canonicalising
+   (forall a. t1 ~ forall a. t2)
+from which we get the implication
+   (forall a. t1 ~ t2)
+See TcSMonad.deferTcSForAllEq
+-}
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSigs.hs
@@ -0,0 +1,847 @@
+{-
+(c) The University of Glasgow 2006-2012
+(c) The GRASP Project, Glasgow University, 1992-2002
+
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcSigs(
+       TcSigInfo(..),
+       TcIdSigInfo(..), TcIdSigInst,
+       TcPatSynInfo(..),
+       TcSigFun,
+
+       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
+       completeSigPolyId_maybe,
+
+       tcTySigs, tcUserTypeSig, completeSigFromId,
+       tcInstSig,
+
+       TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
+       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcHsType
+import TcRnTypes
+import TcRnMonad
+import TcType
+import TcMType
+import TcValidity ( checkValidType )
+import TcUnify( tcSkolemise, unifyType )
+import Inst( topInstantiate )
+import TcEnv( tcLookupId )
+import TcEvidence( HsWrapper, (<.>) )
+import Type( mkTyVarBinders )
+
+import DynFlags
+import Var      ( TyVar, tyVarKind )
+import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
+import PrelNames( mkUnboundName )
+import BasicTypes
+import Bag( foldrBag )
+import Module( getModule )
+import Name
+import NameEnv
+import Outputable
+import SrcLoc
+import Util( singleton )
+import Maybes( orElse )
+import Data.Maybe( mapMaybe )
+import Control.Monad( unless )
+
+
+{- -------------------------------------------------------------
+          Note [Overview of type signatures]
+----------------------------------------------------------------
+Type signatures, including partial signatures, are jolly tricky,
+especially on value bindings.  Here's an overview.
+
+    f :: forall a. [a] -> [a]
+    g :: forall b. _ -> b
+
+    f = ...g...
+    g = ...f...
+
+* HsSyn: a signature in a binding starts off as a TypeSig, in
+  type HsBinds.Sig
+
+* When starting a mutually recursive group, like f/g above, we
+  call tcTySig on each signature in the group.
+
+* tcTySig: Sig -> TcIdSigInfo
+  - For a /complete/ signature, like 'f' above, tcTySig kind-checks
+    the HsType, producing a Type, and wraps it in a CompleteSig, and
+    extend the type environment with this polymorphic 'f'.
+
+  - For a /partial/signature, like 'g' above, tcTySig does nothing
+    Instead it just wraps the pieces in a PartialSig, to be handled
+    later.
+
+* tcInstSig: TcIdSigInfo -> TcIdSigInst
+  In tcMonoBinds, when looking at an individual binding, we use
+  tcInstSig to instantiate the signature forall's in the signature,
+  and attribute that instantiated (monomorphic) type to the
+  binder.  You can see this in TcBinds.tcLhsId.
+
+  The instantiation does the obvious thing for complete signatures,
+  but for /partial/ signatures it starts from the HsSyn, so it
+  has to kind-check it etc: tcHsPartialSigType.  It's convenient
+  to do this at the same time as instantiation, because we can
+  make the wildcards into unification variables right away, raather
+  than somehow quantifying over them.  And the "TcLevel" of those
+  unification variables is correct because we are in tcMonoBinds.
+
+
+Note [Scoped tyvars]
+~~~~~~~~~~~~~~~~~~~~
+The -XScopedTypeVariables flag brings lexically-scoped type variables
+into scope for any explicitly forall-quantified type variables:
+        f :: forall a. a -> a
+        f x = e
+Then 'a' is in scope inside 'e'.
+
+However, we do *not* support this
+  - For pattern bindings e.g
+        f :: forall a. a->a
+        (f,g) = e
+
+Note [Binding scoped type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type variables *brought into lexical scope* by a type signature
+may be a subset of the *quantified type variables* of the signatures,
+for two reasons:
+
+* With kind polymorphism a signature like
+    f :: forall f a. f a -> f a
+  may actually give rise to
+    f :: forall k. forall (f::k -> *) (a:k). f a -> f a
+  So the sig_tvs will be [k,f,a], but only f,a are scoped.
+  NB: the scoped ones are not necessarily the *inital* ones!
+
+* Even aside from kind polymorphism, there may be more instantiated
+  type variables than lexically-scoped ones.  For example:
+        type T a = forall b. b -> (a,b)
+        f :: forall c. T c
+  Here, the signature for f will have one scoped type variable, c,
+  but two instantiated type variables, c' and b'.
+
+However, all of this only applies to the renamer.  The typechecker
+just puts all of them into the type environment; any lexical-scope
+errors were dealt with by the renamer.
+
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+             Utility functions for TcSigInfo
+*                                                                      *
+********************************************************************* -}
+
+tcIdSigName :: TcIdSigInfo -> Name
+tcIdSigName (CompleteSig { sig_bndr = id }) = idName id
+tcIdSigName (PartialSig { psig_name = n })  = n
+
+tcSigInfoName :: TcSigInfo -> Name
+tcSigInfoName (TcIdSig     idsi) = tcIdSigName idsi
+tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi
+
+completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
+completeSigPolyId_maybe sig
+  | TcIdSig sig_info <- sig
+  , CompleteSig { sig_bndr = id } <- sig_info = Just id
+  | otherwise                                 = Nothing
+
+
+{- *********************************************************************
+*                                                                      *
+               Typechecking user signatures
+*                                                                      *
+********************************************************************* -}
+
+tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
+tcTySigs hs_sigs
+  = checkNoErrs $
+    do { -- Fail if any of the signatures is duff
+         -- Hence mapAndReportM
+         -- See Note [Fail eagerly on bad signatures]
+         ty_sigs_s <- mapAndReportM tcTySig hs_sigs
+
+       ; let ty_sigs = concat ty_sigs_s
+             poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
+                        -- The returned [TcId] are the ones for which we have
+                        -- a complete type signature.
+                        -- See Note [Complete and partial type signatures]
+             env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
+
+       ; return (poly_ids, lookupNameEnv env) }
+
+tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
+tcTySig (L _ (IdSig _ id))
+  = do { let ctxt = FunSigCtxt (idName id) False
+                    -- False: do not report redundant constraints
+                    -- The user has no control over the signature!
+             sig = completeSigFromId ctxt id
+       ; return [TcIdSig sig] }
+
+tcTySig (L loc (TypeSig _ names sig_ty))
+  = setSrcSpan loc $
+    do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)
+                          | L _ name <- names ]
+       ; return (map TcIdSig sigs) }
+
+tcTySig (L loc (PatSynSig _ names sig_ty))
+  = setSrcSpan loc $
+    do { tpsigs <- sequence [ tcPatSynSig name sig_ty
+                            | L _ name <- names ]
+       ; return (map TcPatSynSig tpsigs) }
+
+tcTySig _ = return []
+
+
+tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
+              -> TcM TcIdSigInfo
+-- A function or expression type signature
+-- Returns a fully quantified type signature; even the wildcards
+-- are quantified with ordinary skolems that should be instantiated
+--
+-- The SrcSpan is what to declare as the binding site of the
+-- any skolems in the signature. For function signatures we
+-- use the whole `f :: ty' signature; for expression signatures
+-- just the type part.
+--
+-- Just n  => Function type signature       name :: type
+-- Nothing => Expression type signature   <expr> :: type
+tcUserTypeSig loc hs_sig_ty mb_name
+  | isCompleteHsSig hs_sig_ty
+  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
+       ; traceTc "tcuser" (ppr sigma_ty)
+       ; return $
+         CompleteSig { sig_bndr  = mkLocalId name sigma_ty
+                     , sig_ctxt  = ctxt_T
+                     , sig_loc   = loc } }
+                       -- Location of the <type> in   f :: <type>
+
+  -- Partial sig with wildcards
+  | otherwise
+  = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
+                       , sig_ctxt = ctxt_F, sig_loc = loc })
+  where
+    name   = case mb_name of
+               Just n  -> n
+               Nothing -> mkUnboundName (mkVarOcc "<expression>")
+    ctxt_F = case mb_name of
+               Just n  -> FunSigCtxt n False
+               Nothing -> ExprSigCtxt
+    ctxt_T = case mb_name of
+               Just n  -> FunSigCtxt n True
+               Nothing -> ExprSigCtxt
+
+
+
+completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
+-- Used for instance methods and record selectors
+completeSigFromId ctxt id
+  = CompleteSig { sig_bndr = id
+                , sig_ctxt = ctxt
+                , sig_loc  = getSrcSpan id }
+
+isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
+-- ^ If there are no wildcards, return a LHsSigType
+isCompleteHsSig (HsWC { hswc_ext  = wcs
+                      , hswc_body = HsIB { hsib_body = hs_ty } })
+   = null wcs && no_anon_wc hs_ty
+isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig"
+isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"
+
+no_anon_wc :: LHsType GhcRn -> Bool
+no_anon_wc lty = go lty
+  where
+    go (L _ ty) = case ty of
+      HsWildCardTy _                 -> False
+      HsAppTy _ ty1 ty2              -> go ty1 && go ty2
+      HsAppKindTy _ ty ki            -> go ty && go ki
+      HsFunTy _ ty1 ty2              -> go ty1 && go ty2
+      HsListTy _ ty                  -> go ty
+      HsTupleTy _ _ tys              -> gos tys
+      HsSumTy _ tys                  -> gos tys
+      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2
+      HsParTy _ ty                   -> go ty
+      HsIParamTy _ _ ty              -> go ty
+      HsKindSig _ ty kind            -> go ty && go kind
+      HsDocTy _ ty _                 -> go ty
+      HsBangTy _ _ ty                -> go ty
+      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds
+      HsExplicitListTy _ _ tys       -> gos tys
+      HsExplicitTupleTy _ tys        -> gos tys
+      HsForAllTy { hst_bndrs = bndrs
+                 , hst_body = ty } -> no_anon_wc_bndrs bndrs
+                                        && go ty
+      HsQualTy { hst_ctxt = L _ ctxt
+               , hst_body = ty }  -> gos ctxt && go ty
+      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
+      HsSpliceTy{} -> True
+      HsTyLit{} -> True
+      HsTyVar{} -> True
+      HsStarTy{} -> True
+      XHsType{} -> True      -- Core type, which does not have any wildcard
+
+    gos = all go
+
+no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool
+no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs
+  where
+    go (UserTyVar _ _)      = True
+    go (KindedTyVar _ _ ki) = no_anon_wc ki
+    go (XTyVarBndr{})       = panic "no_anon_wc_bndrs"
+
+{- Note [Fail eagerly on bad signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a type signature is wrong, fail immediately:
+
+ * the type sigs may bind type variables, so proceeding without them
+   can lead to a cascade of errors
+
+ * the type signature might be ambiguous, in which case checking
+   the code against the signature will give a very similar error
+   to the ambiguity error.
+
+ToDo: this means we fall over if any top-level type signature in the
+module is wrong, because we typecheck all the signatures together
+(see TcBinds.tcValBinds).  Moreover, because of top-level
+captureTopConstraints, only insoluble constraints will be reported.
+We typecheck all signatures at the same time because a signature
+like   f,g :: blah   might have f and g from different SCCs.
+
+So it's a bit awkward to get better error recovery, and no one
+has complained!
+-}
+
+{- *********************************************************************
+*                                                                      *
+        Type checking a pattern synonym signature
+*                                                                      *
+************************************************************************
+
+Note [Pattern synonym signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Pattern synonym signatures are surprisingly tricky (see #11224 for example).
+In general they look like this:
+
+   pattern P :: forall univ_tvs. req_theta
+             => forall ex_tvs. prov_theta
+             => arg1 -> .. -> argn -> res_ty
+
+For parsing and renaming we treat the signature as an ordinary LHsSigType.
+
+Once we get to type checking, we decompose it into its parts, in tcPatSynSig.
+
+* Note that 'forall univ_tvs' and 'req_theta =>'
+        and 'forall ex_tvs'   and 'prov_theta =>'
+  are all optional.  We gather the pieces at the top of tcPatSynSig
+
+* Initially the implicitly-bound tyvars (added by the renamer) include both
+  universal and existential vars.
+
+* After we kind-check the pieces and convert to Types, we do kind generalisation.
+
+Note [solveEqualities in tcPatSynSig]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important that we solve /all/ the equalities in a pattern
+synonym signature, because we are going to zonk the signature to
+a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that
+fails if there are un-filled-in coercion variables mentioned
+in the type (#15694).
+
+The best thing is simply to use solveEqualities to solve all the
+equalites, rather than leaving them in the ambient constraints
+to be solved later.  Pattern synonyms are top-level, so there's
+no problem with completely solving them.
+
+(NB: this solveEqualities wraps newImplicitTKBndrs, which itself
+does a solveLocalEqualities; so solveEqualities isn't going to
+make any further progress; it'll just report any unsolved ones,
+and fail, as it should.)
+-}
+
+tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
+-- See Note [Pattern synonym signatures]
+-- See Note [Recipe for checking a signature] in TcHsType
+tcPatSynSig name sig_ty
+  | HsIB { hsib_ext = implicit_hs_tvs
+         , hsib_body = hs_ty }  <- sig_ty
+  , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTyInvis hs_ty
+  , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1
+  = do {  traceTc "tcPatSynSig 1" (ppr sig_ty)
+       ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty))))
+           <- pushTcLevelM_   $
+              solveEqualities $ -- See Note [solveEqualities in tcPatSynSig]
+              bindImplicitTKBndrs_Skol implicit_hs_tvs $
+              bindExplicitTKBndrs_Skol univ_hs_tvs     $
+              bindExplicitTKBndrs_Skol ex_hs_tvs       $
+              do { req     <- tcHsContext hs_req
+                 ; prov    <- tcHsContext hs_prov
+                 ; body_ty <- tcHsOpenType hs_body_ty
+                     -- A (literal) pattern can be unlifted;
+                     -- e.g. pattern Zero <- 0#   (#12094)
+                 ; return (req, prov, body_ty) }
+
+       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs
+                                                 req ex_tvs prov body_ty
+
+       -- Kind generalisation
+       ; kvs <- kindGeneralize ungen_patsyn_ty
+       ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)
+
+       -- These are /signatures/ so we zonk to squeeze out any kind
+       -- unification variables.  Do this after kindGeneralize which may
+       -- default kind variables to *.
+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
+       ; univ_tvs     <- mapM zonkTyCoVarKind univ_tvs
+       ; ex_tvs       <- mapM zonkTyCoVarKind ex_tvs
+       ; req          <- zonkTcTypes req
+       ; prov         <- zonkTcTypes prov
+       ; body_ty      <- zonkTcType  body_ty
+
+       -- Skolems have TcLevels too, though they're used only for debugging.
+       -- If you don't do this, the debugging checks fail in TcPatSyn.
+       -- Test case: patsyn/should_compile/T13441
+{-
+       ; tclvl <- getTcLevel
+       ; let env0                  = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs
+             (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs
+             (env2, univ_tvs')     = promoteSkolemsX tclvl env1 univ_tvs
+             (env3, ex_tvs')       = promoteSkolemsX tclvl env2 ex_tvs
+             req'                  = substTys env3 req
+             prov'                 = substTys env3 prov
+             body_ty'              = substTy  env3 body_ty
+-}
+      ; let implicit_tvs' = implicit_tvs
+            univ_tvs'     = univ_tvs
+            ex_tvs'       = ex_tvs
+            req'          = req
+            prov'         = prov
+            body_ty'      = body_ty
+
+       -- Now do validity checking
+       ; checkValidType ctxt $
+         build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty'
+
+       -- arguments become the types of binders. We thus cannot allow
+       -- levity polymorphism here
+       ; let (arg_tys, _) = tcSplitFunTys body_ty'
+       ; mapM_ (checkForLevPoly empty) arg_tys
+
+       ; traceTc "tcTySig }" $
+         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'
+              , text "kvs" <+> ppr_tvs kvs
+              , text "univ_tvs" <+> ppr_tvs univ_tvs'
+              , text "req" <+> ppr req'
+              , text "ex_tvs" <+> ppr_tvs ex_tvs'
+              , text "prov" <+> ppr prov'
+              , text "body_ty" <+> ppr body_ty' ]
+       ; return (TPSI { patsig_name = name
+                      , patsig_implicit_bndrs = mkTyVarBinders Inferred  kvs ++
+                                                mkTyVarBinders Specified implicit_tvs'
+                      , patsig_univ_bndrs     = univ_tvs'
+                      , patsig_req            = req'
+                      , patsig_ex_bndrs       = ex_tvs'
+                      , patsig_prov           = prov'
+                      , patsig_body_ty        = body_ty' }) }
+  where
+    ctxt = PatSynCtxt name
+
+    build_patsyn_type kvs imp univ req ex prov body
+      = mkInvForAllTys kvs $
+        mkSpecForAllTys (imp ++ univ) $
+        mkPhiTy req $
+        mkSpecForAllTys ex $
+        mkPhiTy prov $
+        body
+tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig"
+
+ppr_tvs :: [TyVar] -> SDoc
+ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+                           | tv <- tvs])
+
+
+{- *********************************************************************
+*                                                                      *
+               Instantiating user signatures
+*                                                                      *
+********************************************************************* -}
+
+
+tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
+-- Instantiate a type signature; only used with plan InferGen
+tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+  = setSrcSpan loc $  -- Set the binding site of the tyvars
+    do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id
+              -- See Note [Pattern bindings and complete signatures]
+
+       ; return (TISI { sig_inst_sig   = sig
+                      , sig_inst_skols = tv_prs
+                      , sig_inst_wcs   = []
+                      , sig_inst_wcx   = Nothing
+                      , sig_inst_theta = theta
+                      , sig_inst_tau   = tau }) }
+
+tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty
+                             , sig_ctxt = ctxt
+                             , sig_loc = loc })
+  = setSrcSpan loc $  -- Set the binding site of the tyvars
+    do { traceTc "Staring partial sig {" (ppr hs_sig)
+       ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
+
+        -- Clone the quantified tyvars
+        -- Reason: we might have    f, g :: forall a. a -> _ -> a
+        --         and we want it to behave exactly as if there were
+        --         two separate signatures.  Cloning here seems like
+        --         the easiest way to do so, and is very similar to
+        --         the tcInstType in the CompleteSig case
+        -- See #14643
+       ; (subst, tvs') <- newMetaTyVarTyVars tvs
+                         -- Why newMetaTyVarTyVars?  See TcBinds
+                         -- Note [Quantified variables in partial type signatures]
+       ; let tv_prs = tv_names `zip` tvs'
+             inst_sig = TISI { sig_inst_sig   = hs_sig
+                             , sig_inst_skols = tv_prs
+                             , sig_inst_wcs   = wcs
+                             , sig_inst_wcx   = wcx
+                             , sig_inst_theta = substTysUnchecked subst theta
+                             , sig_inst_tau   = substTyUnchecked  subst tau }
+       ; traceTc "End partial sig }" (ppr inst_sig)
+       ; return inst_sig }
+
+
+{- Note [Pattern bindings and complete signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+      data T a = MkT a a
+      f :: forall a. a->a
+      g :: forall b. b->b
+      MkT f g = MkT (\x->x) (\y->y)
+Here we'll infer a type from the pattern of 'T a', but if we feed in
+the signature types for f and g, we'll end up unifying 'a' and 'b'
+
+So we instantiate f and g's signature with TyVarTv skolems
+(newMetaTyVarTyVars) that can unify with each other.  If too much
+unification takes place, we'll find out when we do the final
+impedance-matching check in TcBinds.mkExport
+
+See Note [Signature skolems] in TcType
+
+None of this applies to a function binding with a complete
+signature, which doesn't use tcInstSig.  See TcBinds.tcPolyCheck.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                   Pragmas and PragEnv
+*                                                                      *
+********************************************************************* -}
+
+type TcPragEnv = NameEnv [LSig GhcRn]
+
+emptyPragEnv :: TcPragEnv
+emptyPragEnv = emptyNameEnv
+
+lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
+lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
+
+extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
+extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
+
+---------------
+mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
+mkPragEnv sigs binds
+  = foldl' extendPragEnv emptyNameEnv prs
+  where
+    prs = mapMaybe get_sig sigs
+
+    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
+    get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))
+      = Just (nm, L l $ SpecSig   x lnm ty (add_arity nm inl))
+    get_sig (L l (InlineSig x lnm@(L _ nm) inl))
+      = Just (nm, L l $ InlineSig x lnm    (add_arity nm inl))
+    get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
+      = Just (nm, L l $ SCCFunSig x st lnm str)
+    get_sig _ = Nothing
+
+    add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function
+      | Inline <- inl_inline inl_prag
+        -- add arity only for real INLINE pragmas, not INLINABLE
+      = case lookupNameEnv ar_env n of
+          Just ar -> inl_prag { inl_sat = Just ar }
+          Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )
+                     -- There really should be a binding for every INLINE pragma
+                     inl_prag
+      | otherwise
+      = inl_prag
+
+    -- ar_env maps a local to the arity of its definition
+    ar_env :: NameEnv Arity
+    ar_env = foldrBag lhsBindArity emptyNameEnv binds
+
+lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+  = extendNameEnv env (unLoc id) (matchGroupArity ms)
+lhsBindArity _ env = env        -- PatBind/VarBind
+
+
+-----------------
+addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
+addInlinePrags poly_id prags_for_me
+  | inl@(L _ prag) : inls <- inl_prags
+  = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
+       ; unless (null inls) (warn_multiple_inlines inl inls)
+       ; return (poly_id `setInlinePragma` prag) }
+  | otherwise
+  = return poly_id
+  where
+    inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me]
+
+    warn_multiple_inlines _ [] = return ()
+
+    warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
+       | inlinePragmaActivation prag1 == inlinePragmaActivation prag2
+       , noUserInlineSpec (inlinePragmaSpec prag1)
+       =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
+            -- and inl2 is a user NOINLINE pragma; we don't want to complain
+         warn_multiple_inlines inl2 inls
+       | otherwise
+       = setSrcSpan loc $
+         addWarnTc NoReason
+                     (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)
+                       2 (vcat (text "Ignoring all but the first"
+                                : map pp_inl (inl1:inl2:inls))))
+
+    pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)
+
+
+{- *********************************************************************
+*                                                                      *
+                   SPECIALISE pragmas
+*                                                                      *
+************************************************************************
+
+Note [Handling SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea is this:
+
+   foo :: Num a => a -> b -> a
+   {-# SPECIALISE foo :: Int -> b -> Int #-}
+
+We check that
+   (forall a b. Num a => a -> b -> a)
+      is more polymorphic than
+   forall b. Int -> b -> Int
+(for which we could use tcSubType, but see below), generating a HsWrapper
+to connect the two, something like
+      wrap = /\b. <hole> Int b dNumInt
+This wrapper is put in the TcSpecPrag, in the ABExport record of
+the AbsBinds.
+
+
+        f :: (Eq a, Ix b) => a -> b -> Bool
+        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+        f = <poly_rhs>
+
+From this the typechecker generates
+
+    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+
+    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
+
+From these we generate:
+
+    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
+                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
+
+    Spec bind:  f_spec = wrap_fn <poly_rhs>
+
+Note that
+
+  * The LHS of the rule may mention dictionary *expressions* (eg
+    $dfIxPair dp dq), and that is essential because the dp, dq are
+    needed on the RHS.
+
+  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
+    can fully specialise it.
+
+
+
+From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
+
+   f_spec :: Int -> b -> Int
+   f_spec = wrap<f rhs>
+
+   RULE: forall b (d:Num b). f b d = f_spec b
+
+The RULE is generated by taking apart the HsWrapper, which is a little
+delicate, but works.
+
+Some wrinkles
+
+1. We don't use full-on tcSubType, because that does co and contra
+   variance and that in turn will generate too complex a LHS for the
+   RULE.  So we use a single invocation of skolemise /
+   topInstantiate in tcSpecWrapper.  (Actually I think that even
+   the "deeply" stuff may be too much, because it introduces lambdas,
+   though I think it can be made to work without too much trouble.)
+
+2. We need to take care with type families (#5821).  Consider
+      type instance F Int = Bool
+      f :: Num a => a -> F a
+      {-# SPECIALISE foo :: Int -> Bool #-}
+
+  We *could* try to generate an f_spec with precisely the declared type:
+      f_spec :: Int -> Bool
+      f_spec = <f rhs> Int dNumInt |> co
+
+      RULE: forall d. f Int d = f_spec |> sym co
+
+  but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
+  hard to generate.  At all costs we must avoid this:
+      RULE: forall d. f Int d |> co = f_spec
+  because the LHS will never match (indeed it's rejected in
+  decomposeRuleLhs).
+
+  So we simply do this:
+    - Generate a constraint to check that the specialised type (after
+      skolemiseation) is equal to the instantiated function type.
+    - But *discard* the evidence (coercion) for that constraint,
+      so that we ultimately generate the simpler code
+          f_spec :: Int -> F Int
+          f_spec = <f rhs> Int dNumInt
+
+          RULE: forall d. f Int d = f_spec
+      You can see this discarding happening in
+
+3. Note that the HsWrapper can transform *any* function with the right
+   type prefix
+       forall ab. (Eq a, Ix b) => XXX
+   regardless of XXX.  It's sort of polymorphic in XXX.  This is
+   useful: we use the same wrapper to transform each of the class ops, as
+   well as the dict.  That's what goes on in TcInstDcls.mk_meth_spec_prags
+-}
+
+tcSpecPrags :: Id -> [LSig GhcRn]
+            -> TcM [LTcSpecPrag]
+-- Add INLINE and SPECIALSE pragmas
+--    INLINE prags are added to the (polymorphic) Id directly
+--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
+-- Pre-condition: the poly_id is zonked
+-- Reason: required by tcSubExp
+tcSpecPrags poly_id prag_sigs
+  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
+       ; unless (null bad_sigs) warn_discarded_sigs
+       ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
+       ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
+  where
+    spec_sigs = filter isSpecLSig prag_sigs
+    bad_sigs  = filter is_bad_sig prag_sigs
+    is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
+
+    warn_discarded_sigs
+      = addWarnTc NoReason
+                  (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)
+                      2 (vcat (map (ppr . getLoc) bad_sigs)))
+
+--------------
+tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
+tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
+-- See Note [Handling SPECIALISE pragmas]
+--
+-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
+-- Example: SPECIALISE for a class method: the Name in the SpecSig is
+--          for the selector Id, but the poly_id is something like $cop
+-- However we want to use fun_name in the error message, since that is
+-- what the user wrote (#8537)
+  = addErrCtxt (spec_ctxt prag) $
+    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
+                 (text "SPECIALISE pragma for non-overloaded function"
+                  <+> quotes (ppr fun_name))
+                  -- Note [SPECIALISE pragmas]
+        ; spec_prags <- mapM tc_one hs_tys
+        ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
+        ; return spec_prags }
+  where
+    name      = idName poly_id
+    poly_ty   = idType poly_id
+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
+
+    tc_one hs_ty
+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty
+           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty
+           ; return (SpecPrag poly_id wrap inl) }
+
+tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
+
+--------------
+tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
+-- A simpler variant of tcSubType, used for SPECIALISE pragmas
+-- See Note [Handling SPECIALISE pragmas], wrinkle 1
+tcSpecWrapper ctxt poly_ty spec_ty
+  = do { (sk_wrap, inst_wrap)
+               <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->
+                  do { (inst_wrap, tau) <- topInstantiate orig poly_ty
+                     ; _ <- unifyType Nothing spec_tau tau
+                            -- Deliberately ignore the evidence
+                            -- See Note [Handling SPECIALISE pragmas],
+                            --   wrinkle (2)
+                     ; return inst_wrap }
+       ; return (sk_wrap <.> inst_wrap) }
+  where
+    orig = SpecPragOrigin ctxt
+
+--------------
+tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
+-- SPECIALISE pragmas for imported things
+tcImpPrags prags
+  = do { this_mod <- getModule
+       ; dflags <- getDynFlags
+       ; if (not_specialising dflags) then
+            return []
+         else do
+            { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
+                     [L loc (name,prag)
+                             | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
+                             , not (nameIsLocalOrFrom this_mod name) ]
+            ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
+  where
+    -- Ignore SPECIALISE pragmas for imported things
+    -- when we aren't specialising, or when we aren't generating
+    -- code.  The latter happens when Haddocking the base library;
+    -- we don't want complaints about lack of INLINABLE pragmas
+    not_specialising dflags
+      | not (gopt Opt_Specialise dflags) = True
+      | otherwise = case hscTarget dflags of
+                      HscNothing -> True
+                      HscInterpreted -> True
+                      _other         -> False
+
+tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
+tcImpSpec (name, prag)
+ = do { id <- tcLookupId name
+      ; unless (isAnyInlinePragma (idInlinePragma id))
+               (addWarnTc NoReason (impSpecErr name))
+      ; tcSpecPrag id prag }
+
+impSpecErr :: Name -> SDoc
+impSpecErr name
+  = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))
+       2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"
+               , parens $ sep
+                   [ text "or its defining module" <+> quotes (ppr mod)
+                   , text "was compiled without -O"]])
+  where
+    mod = nameModule name
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSimplify.hs
@@ -0,0 +1,2678 @@
+{-# LANGUAGE CPP #-}
+
+module TcSimplify(
+       simplifyInfer, InferMode(..),
+       growThetaTyVars,
+       simplifyAmbiguityCheck,
+       simplifyDefault,
+       simplifyTop, simplifyTopImplic,
+       simplifyInteractive,
+       solveEqualities, solveLocalEqualities, solveLocalEqualitiesX,
+       simplifyWantedsTcM,
+       tcCheckSatisfiability,
+       tcNormalise,
+
+       captureTopConstraints,
+
+       simpl_top,
+
+       promoteTyVar,
+       promoteTyVarSet,
+
+       -- For Rules we need these
+       solveWanteds, solveWantedsAndDrop,
+       approximateWC, runTcSDeriveds
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Bag
+import Class         ( Class, classKey, classTyCon )
+import DynFlags      ( WarningFlag ( Opt_WarnMonomorphism )
+                     , WarnReason ( Reason )
+                     , DynFlags( solverIterations ) )
+import HsExpr        ( UnboundVar(..) )
+import Id            ( idType, mkLocalId )
+import Inst
+import ListSetOps
+import Name
+import Outputable
+import PrelInfo
+import PrelNames
+import RdrName       ( emptyGlobalRdrEnv )
+import TcErrors
+import TcEvidence
+import TcInteract
+import TcCanonical   ( makeSuperClasses, solveCallStack )
+import TcMType   as TcM
+import TcRnMonad as TcM
+import TcSMonad  as TcS
+import TcType
+import TrieMap       () -- DV: for now
+import Type
+import TysWiredIn    ( liftedRepTy )
+import Unify         ( tcMatchTyKi )
+import Util
+import Var
+import VarSet
+import UniqSet
+import BasicTypes    ( IntWithInf, intGtLimit )
+import ErrUtils      ( emptyMessages )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable      ( toList )
+import Data.List          ( partition )
+import Data.List.NonEmpty ( NonEmpty(..) )
+import Maybes             ( isJust )
+
+{-
+*********************************************************************************
+*                                                                               *
+*                           External interface                                  *
+*                                                                               *
+*********************************************************************************
+-}
+
+captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureTopConstraints m) runs m, and returns the type constraints it
+-- generates plus the constraints produced by static forms inside.
+-- If it fails with an exception, it reports any insolubles
+-- (out of scope variables) before doing so
+--
+-- captureTopConstraints is used exclusively by TcRnDriver at the top
+-- level of a module.
+--
+-- Importantly, if captureTopConstraints propagates an exception, it
+-- reports any insoluble constraints first, lest they be lost
+-- altogether.  This is important, because solveLocalEqualities (maybe
+-- other things too) throws an exception without adding any error
+-- messages; it just puts the unsolved constraints back into the
+-- monad. See TcRnMonad Note [Constraints and errors]
+-- #16376 is an example of what goes wrong if you don't do this.
+--
+-- NB: the caller should bring any environments into scope before
+-- calling this, so that the reportUnsolved has access to the most
+-- complete GlobalRdrEnv
+captureTopConstraints thing_inside
+  = do { static_wc_var <- TcM.newTcRef emptyWC ;
+       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $
+                          TcM.tryCaptureConstraints thing_inside
+       ; stWC <- TcM.readTcRef static_wc_var
+
+       -- See TcRnMonad Note [Constraints and errors]
+       -- If the thing_inside threw an exception, but generated some insoluble
+       -- constraints, report the latter before propagating the exception
+       -- Otherwise they will be lost altogether
+       ; case mb_res of
+           Just res -> return (res, lie `andWC` stWC)
+           Nothing  -> do { _ <- simplifyTop lie; failM } }
+                -- This call to simplifyTop is the reason
+                -- this function is here instead of TcRnMonad
+                -- We call simplifyTop so that it does defaulting
+                -- (esp of runtime-reps) before reporting errors
+
+simplifyTopImplic :: Bag Implication -> TcM ()
+simplifyTopImplic implics
+  = do { empty_binds <- simplifyTop (mkImplicWC implics)
+
+       -- Since all the inputs are implications the returned bindings will be empty
+       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )
+
+       ; return () }
+
+simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
+-- Simplify top-level constraints
+-- Usually these will be implications,
+-- but when there is nothing to quantify we don't wrap
+-- in a degenerate implication, so we do that here instead
+simplifyTop wanteds
+  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds
+       ; ((final_wc, unsafe_ol), binds1) <- runTcS $
+            do { final_wc <- simpl_top wanteds
+               ; unsafe_ol <- getSafeOverlapFailures
+               ; return (final_wc, unsafe_ol) }
+       ; traceTc "End simplifyTop }" empty
+
+       ; binds2 <- reportUnsolved final_wc
+
+       ; traceTc "reportUnsolved (unsafe overlapping) {" empty
+       ; unless (isEmptyCts unsafe_ol) $ do {
+           -- grab current error messages and clear, warnAllUnsolved will
+           -- update error messages which we'll grab and then restore saved
+           -- messages.
+           ; errs_var  <- getErrsVar
+           ; saved_msg <- TcM.readTcRef errs_var
+           ; TcM.writeTcRef errs_var emptyMessages
+
+           ; warnAllUnsolved $ WC { wc_simple = unsafe_ol
+                                  , wc_impl = emptyBag }
+
+           ; whyUnsafe <- fst <$> TcM.readTcRef errs_var
+           ; TcM.writeTcRef errs_var saved_msg
+           ; recordUnsafeInfer whyUnsafe
+           }
+       ; traceTc "reportUnsolved (unsafe overlapping) }" empty
+
+       ; return (evBindMapBinds binds1 `unionBags` binds2) }
+
+
+-- | Type-check a thing that emits only equality constraints, solving any
+-- constraints we can and re-emitting constraints that we can't. The thing_inside
+-- should generally bump the TcLevel to make sure that this run of the solver
+-- doesn't affect anything lying around.
+solveLocalEqualities :: String -> TcM a -> TcM a
+solveLocalEqualities callsite thing_inside
+  = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside
+       ; emitConstraints wanted
+
+       -- See Note [Fail fast if there are insoluble kind equalities]
+       ; if insolubleWC wanted
+         then failM
+         else return res }
+
+{- Note [Fail fast if there are insoluble kind equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather like in simplifyInfer, fail fast if there is an insoluble
+constraint.  Otherwise we'll just succeed in kind-checking a nonsense
+type, with a cascade of follow-up errors.
+
+For example polykinds/T12593, T15577, and many others.
+
+Take care to ensure that you emit the insoluble constraints before
+failing, because they are what will ulimately lead to the error
+messsage!
+-}
+
+solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)
+solveLocalEqualitiesX callsite thing_inside
+  = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ])
+
+       ; (result, wanted) <- captureConstraints thing_inside
+
+       ; traceTc "solveLocalEqualities: running solver" (ppr wanted)
+       ; residual_wanted <- runTcSEqualities (solveWanteds wanted)
+
+       ; traceTc "solveLocalEqualitiesX end }" $
+         text "residual_wanted =" <+> ppr residual_wanted
+
+       ; return (residual_wanted, result) }
+
+-- | Type-check a thing that emits only equality constraints, then
+-- solve those constraints. Fails outright if there is trouble.
+-- Use this if you're not going to get another crack at solving
+-- (because, e.g., you're checking a datatype declaration)
+solveEqualities :: TcM a -> TcM a
+solveEqualities thing_inside
+  = checkNoErrs $  -- See Note [Fail fast on kind errors]
+    do { lvl <- TcM.getTcLevel
+       ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl)
+
+       ; (result, wanted) <- captureConstraints thing_inside
+
+       ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted
+       ; final_wc <- runTcSEqualities $ simpl_top wanted
+          -- NB: Use simpl_top here so that we potentially default RuntimeRep
+          -- vars to LiftedRep. This is needed to avoid #14991.
+
+       ; traceTc "End solveEqualities }" empty
+       ; reportAllUnsolved final_wc
+       ; return result }
+
+-- | Simplify top-level constraints, but without reporting any unsolved
+-- constraints nor unsafe overlapping.
+simpl_top :: WantedConstraints -> TcS WantedConstraints
+    -- See Note [Top-level Defaulting Plan]
+simpl_top wanteds
+  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)
+                            -- This is where the main work happens
+       ; try_tyvar_defaulting wc_first_go }
+  where
+    try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_tyvar_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise
+      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)
+           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs
+                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked
+                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,
+                   -- and we definitely don't want to try to assign to those!
+                   -- The isTyVar is needed to weed out coercion variables
+
+           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects
+           ; if or defaulted
+             then do { wc_residual <- nestTcS (solveWanteds wc)
+                            -- See Note [Must simplify after defaulting]
+                     ; try_class_defaulting wc_residual }
+             else try_class_defaulting wc }     -- No defaulting took place
+
+    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_class_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise  -- See Note [When to do type-class defaulting]
+      = do { something_happened <- applyDefaultingRules wc
+                                   -- See Note [Top-level Defaulting Plan]
+           ; if something_happened
+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
+                     ; try_class_defaulting wc_residual }
+                  -- See Note [Overview of implicit CallStacks] in TcEvidence
+             else try_callstack_defaulting wc }
+
+    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_callstack_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise
+      = defaultCallStacks wc
+
+-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.
+defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
+-- See Note [Overview of implicit CallStacks] in TcEvidence
+defaultCallStacks wanteds
+  = do simples <- handle_simples (wc_simple wanteds)
+       mb_implics <- mapBagM handle_implic (wc_impl wanteds)
+       return (wanteds { wc_simple = simples
+                       , wc_impl = catBagMaybes mb_implics })
+
+  where
+
+  handle_simples simples
+    = catBagMaybes <$> mapBagM defaultCallStack simples
+
+  handle_implic :: Implication -> TcS (Maybe Implication)
+  -- The Maybe is because solving the CallStack constraint
+  -- may well allow us to discard the implication entirely
+  handle_implic implic
+    | isSolvedStatus (ic_status implic)
+    = return (Just implic)
+    | otherwise
+    = do { wanteds <- setEvBindsTcS (ic_binds implic) $
+                      -- defaultCallStack sets a binding, so
+                      -- we must set the correct binding group
+                      defaultCallStacks (ic_wanted implic)
+         ; setImplicationStatus (implic { ic_wanted = wanteds }) }
+
+  defaultCallStack ct
+    | ClassPred cls tys <- classifyPredType (ctPred ct)
+    , Just {} <- isCallStackPred cls tys
+    = do { solveCallStack (ctEvidence ct) EvCsEmpty
+         ; return Nothing }
+
+  defaultCallStack ct
+    = return (Just ct)
+
+
+{- Note [Fail fast on kind errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+solveEqualities is used to solve kind equalities when kind-checking
+user-written types. If solving fails we should fail outright, rather
+than just accumulate an error message, for two reasons:
+
+  * A kind-bogus type signature may cause a cascade of knock-on
+    errors if we let it pass
+
+  * More seriously, we don't have a convenient term-level place to add
+    deferred bindings for unsolved kind-equality constraints, so we
+    don't build evidence bindings (by usine reportAllUnsolved). That
+    means that we'll be left with with a type that has coercion holes
+    in it, something like
+           <type> |> co-hole
+    where co-hole is not filled in.  Eeek!  That un-filled-in
+    hole actually causes GHC to crash with "fvProv falls into a hole"
+    See #11563, #11520, #11516, #11399
+
+So it's important to use 'checkNoErrs' here!
+
+Note [When to do type-class defaulting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC
+was false, on the grounds that defaulting can't help solve insoluble
+constraints.  But if we *don't* do defaulting we may report a whole
+lot of errors that would be solved by defaulting; these errors are
+quite spurious because fixing the single insoluble error means that
+defaulting happens again, which makes all the other errors go away.
+This is jolly confusing: #9033.
+
+So it seems better to always do type-class defaulting.
+
+However, always doing defaulting does mean that we'll do it in
+situations like this (#5934):
+   run :: (forall s. GenST s) -> Int
+   run = fromInteger 0
+We don't unify the return type of fromInteger with the given function
+type, because the latter involves foralls.  So we're left with
+    (Num alpha, alpha ~ (forall s. GenST s) -> Int)
+Now we do defaulting, get alpha := Integer, and report that we can't
+match Integer with (forall s. GenST s) -> Int.  That's not totally
+stupid, but perhaps a little strange.
+
+Another potential alternative would be to suppress *all* non-insoluble
+errors if there are *any* insoluble errors, anywhere, but that seems
+too drastic.
+
+Note [Must simplify after defaulting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may have a deeply buried constraint
+    (t:*) ~ (a:Open)
+which we couldn't solve because of the kind incompatibility, and 'a' is free.
+Then when we default 'a' we can solve the constraint.  And we want to do
+that before starting in on type classes.  We MUST do it before reporting
+errors, because it isn't an error!  #7967 was due to this.
+
+Note [Top-level Defaulting Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have considered two design choices for where/when to apply defaulting.
+   (i) Do it in SimplCheck mode only /whenever/ you try to solve some
+       simple constraints, maybe deep inside the context of implications.
+       This used to be the case in GHC 7.4.1.
+   (ii) Do it in a tight loop at simplifyTop, once all other constraints have
+        finished. This is the current story.
+
+Option (i) had many disadvantages:
+   a) Firstly, it was deep inside the actual solver.
+   b) Secondly, it was dependent on the context (Infer a type signature,
+      or Check a type signature, or Interactive) since we did not want
+      to always start defaulting when inferring (though there is an exception to
+      this, see Note [Default while Inferring]).
+   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:
+          f :: Int -> Bool
+          f x = const True (\y -> let w :: a -> a
+                                      w a = const a (y+1)
+                                  in w y)
+      We will get an implication constraint (for beta the type of y):
+               [untch=beta] forall a. 0 => Num beta
+      which we really cannot default /while solving/ the implication, since beta is
+      untouchable.
+
+Instead our new defaulting story is to pull defaulting out of the solver loop and
+go with option (ii), implemented at SimplifyTop. Namely:
+     - First, have a go at solving the residual constraint of the whole
+       program
+     - Try to approximate it with a simple constraint
+     - Figure out derived defaulting equations for that simple constraint
+     - Go round the loop again if you did manage to get some equations
+
+Now, that has to do with class defaulting. However there exists type variable /kind/
+defaulting. Again this is done at the top-level and the plan is:
+     - At the top-level, once you had a go at solving the constraint, do
+       figure out /all/ the touchable unification variables of the wanted constraints.
+     - Apply defaulting to their kinds
+
+More details in Note [DefaultTyVar].
+
+Note [Safe Haskell Overlapping Instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Safe Haskell, we apply an extra restriction to overlapping instances. The
+motive is to prevent untrusted code provided by a third-party, changing the
+behavior of trusted code through type-classes. This is due to the global and
+implicit nature of type-classes that can hide the source of the dictionary.
+
+Another way to state this is: if a module M compiles without importing another
+module N, changing M to import N shouldn't change the behavior of M.
+
+Overlapping instances with type-classes can violate this principle. However,
+overlapping instances aren't always unsafe. They are just unsafe when the most
+selected dictionary comes from untrusted code (code compiled with -XSafe) and
+overlaps instances provided by other modules.
+
+In particular, in Safe Haskell at a call site with overlapping instances, we
+apply the following rule to determine if it is a 'unsafe' overlap:
+
+ 1) Most specific instance, I1, defined in an `-XSafe` compiled module.
+ 2) I1 is an orphan instance or a MPTC.
+ 3) At least one overlapped instance, Ix, is both:
+    A) from a different module than I1
+    B) Ix is not marked `OVERLAPPABLE`
+
+This is a slightly involved heuristic, but captures the situation of an
+imported module N changing the behavior of existing code. For example, if
+condition (2) isn't violated, then the module author M must depend either on a
+type-class or type defined in N.
+
+Secondly, when should these heuristics be enforced? We enforced them when the
+type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.
+This allows `-XUnsafe` modules to operate without restriction, and for Safe
+Haskell inferrence to infer modules with unsafe overlaps as unsafe.
+
+One alternative design would be to also consider if an instance was imported as
+a `safe` import or not and only apply the restriction to instances imported
+safely. However, since instances are global and can be imported through more
+than one path, this alternative doesn't work.
+
+Note [Safe Haskell Overlapping Instances Implementation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+How is this implemented? It's complicated! So we'll step through it all:
+
+ 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where
+    we check if a particular type-class method call is safe or unsafe. We do this
+    through the return type, `ClsInstLookupResult`, where the last parameter is a
+    list of instances that are unsafe to overlap. When the method call is safe,
+    the list is null.
+
+ 2) `TcInteract.matchClassInst` -- This module drives the instance resolution
+    / dictionary generation. The return type is `ClsInstResult`, which either
+    says no instance matched, or one found, and if it was a safe or unsafe
+    overlap.
+
+ 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and
+     tries to resolve it by calling (in part) `matchClassInst`. The resolving
+     mechanism has a work list (of constraints) that it process one at a time. If
+     the constraint can't be resolved, it's added to an inert set. When compiling
+     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know
+     compilation should fail. These are handled as normal constraint resolution
+     failures from here-on (see step 6).
+
+     Otherwise, we may be inferring safety (or using `-Wunsafe`), and
+     compilation should succeed, but print warnings and/or mark the compiled module
+     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds
+     the unsafe (but resolved!) constraint to the `inert_safehask` field of
+     `InertCans`.
+
+ 4) `TcSimplify.simplifyTop`:
+       * Call simpl_top, the top-level function for driving the simplifier for
+         constraint resolution.
+
+       * Once finished, call `getSafeOverlapFailures` to retrieve the
+         list of overlapping instances that were successfully resolved,
+         but unsafe. Remember, this is only applicable for generating warnings
+         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`
+         cause compilation failure by not resolving the unsafe constraint at all.
+
+       * For unresolved constraints (all types), call `TcErrors.reportUnsolved`,
+         while for resolved but unsafe overlapping dictionary constraints, call
+         `TcErrors.warnAllUnsolved`. Both functions convert constraints into a
+         warning message for the user.
+
+       * In the case of `warnAllUnsolved` for resolved, but unsafe
+         dictionary constraints, we collect the generated warning
+         message (pop it) and call `TcRnMonad.recordUnsafeInfer` to
+         mark the module we are compiling as unsafe, passing the
+         warning message along as the reason.
+
+ 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by
+    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we
+    know is the constraint that is unresolved or unsafe. For dictionary, all we
+    know is that we need a dictionary of type C, but not what instances are
+    available and how they overlap. So we once again call `lookupInstEnv` to
+    figure that out so we can generate a helpful error message.
+
+ 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an
+      IORef called `tcg_safeInfer`.
+
+ 7) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling
+    `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence
+    failed.
+
+Note [No defaulting in the ambiguity check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When simplifying constraints for the ambiguity check, we use
+solveWantedsAndDrop, not simpl_top, so that we do no defaulting.
+#11947 was an example:
+   f :: Num a => Int -> Int
+This is ambiguous of course, but we don't want to default the
+(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting
+warning, but no error.
+-}
+
+------------------
+simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
+simplifyAmbiguityCheck ty wanteds
+  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)
+       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds
+             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]
+
+       ; traceTc "End simplifyAmbiguityCheck }" empty
+
+       -- Normally report all errors; but with -XAllowAmbiguousTypes
+       -- report only insoluble ones, since they represent genuinely
+       -- inaccessible code
+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
+       ; traceTc "reportUnsolved(ambig) {" empty
+       ; unless (allow_ambiguous && not (insolubleWC final_wc))
+                (discardResult (reportUnsolved final_wc))
+       ; traceTc "reportUnsolved(ambig) }" empty
+
+       ; return () }
+
+------------------
+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
+simplifyInteractive wanteds
+  = traceTc "simplifyInteractive" empty >>
+    simplifyTop wanteds
+
+------------------
+simplifyDefault :: ThetaType    -- Wanted; has no type variables in it
+                -> TcM ()       -- Succeeds if the constraint is soluble
+simplifyDefault theta
+  = do { traceTc "simplifyDefault" empty
+       ; wanteds  <- newWanteds DefaultOrigin theta
+       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))
+       ; reportAllUnsolved unsolved
+       ; return () }
+
+------------------
+tcCheckSatisfiability :: Bag EvVar -> TcM Bool
+-- Return True if satisfiable, False if definitely contradictory
+tcCheckSatisfiability given_ids
+  = do { lcl_env <- TcM.getLclEnv
+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env
+       ; (res, _ev_binds) <- runTcS $
+             do { traceTcS "checkSatisfiability {" (ppr given_ids)
+                ; let given_cts = mkGivens given_loc (bagToList given_ids)
+                     -- See Note [Superclasses and satisfiability]
+                ; solveSimpleGivens given_cts
+                ; insols <- getInertInsols
+                ; insols <- try_harder insols
+                ; traceTcS "checkSatisfiability }" (ppr insols)
+                ; return (isEmptyBag insols) }
+       ; return res }
+ where
+    try_harder :: Cts -> TcS Cts
+    -- Maybe we have to search up the superclass chain to find
+    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.
+    -- At the moment we try just once
+    try_harder insols
+      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable
+      = return insols             -- Hurrah -- stop now.
+      | otherwise
+      = do { pending_given <- getPendingGivenScs
+           ; new_given <- makeSuperClasses pending_given
+           ; solveSimpleGivens new_given
+           ; getInertInsols }
+
+-- | Normalise a type as much as possible using the given constraints.
+-- See @Note [tcNormalise]@.
+tcNormalise :: Bag EvVar -> Type -> TcM Type
+tcNormalise given_ids ty
+  = do { lcl_env <- TcM.getLclEnv
+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env
+       ; wanted_ct <- mk_wanted_ct
+       ; (res, _ev_binds) <- runTcS $
+             do { traceTcS "tcNormalise {" (ppr given_ids)
+                ; let given_cts = mkGivens given_loc (bagToList given_ids)
+                ; solveSimpleGivens given_cts
+                ; wcs <- solveSimpleWanteds (unitBag wanted_ct)
+                  -- It's an invariant that this wc_simple will always be
+                  -- a singleton Ct, since that's what we fed in as input.
+                ; let ty' = case bagToList (wc_simple wcs) of
+                              (ct:_) -> ctEvPred (ctEvidence ct)
+                              cts    -> pprPanic "tcNormalise" (ppr cts)
+                ; traceTcS "tcNormalise }" (ppr ty')
+                ; pure ty' }
+       ; return res }
+  where
+    mk_wanted_ct :: TcM Ct
+    mk_wanted_ct = do
+      let occ = mkVarOcc "$tcNorm"
+      name <- newSysName occ
+      let ev = mkLocalId name ty
+          hole = ExprHole $ OutOfScope occ emptyGlobalRdrEnv
+      newHoleCt hole ev ty
+
+{- Note [Superclasses and satisfiability]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Expand superclasses before starting, because (Int ~ Bool), has
+(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)
+as a superclass, and it's the latter that is insoluble.  See
+Note [The equality types story] in TysPrim.
+
+If we fail to prove unsatisfiability we (arbitrarily) try just once to
+find superclasses, using try_harder.  Reason: we might have a type
+signature
+   f :: F op (Implements push) => ..
+where F is a type function.  This happened in #3972.
+
+We could do more than once but we'd have to have /some/ limit: in the
+the recursive case, we would go on forever in the common case where
+the constraints /are/ satisfiable (#10592 comment:12!).
+
+For stratightforard situations without type functions the try_harder
+step does nothing.
+
+Note [tcNormalise]
+~~~~~~~~~~~~~~~~~~
+tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas
+most invocations of the constraint solver are intended to simplify a set of
+constraints or to decide if a particular set of constraints is satisfiable,
+the purpose of tcNormalise is to take a type, plus some local constraints, and
+normalise the type as much as possible with respect to those constraints.
+
+Why is this useful? As one example, when coverage-checking an EmptyCase
+expression, it's possible that the type of the scrutinee will only reduce
+if some local equalities are solved for. See "Wrinkle: Local equalities"
+in Note [Type normalisation for EmptyCase] in Check.
+
+To accomplish its stated goal, tcNormalise first feeds the local constraints
+into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds
+that singleton Ct into solveSimpleWanteds, which reduces the type in the
+CHoleCan as much as possible with respect to the local given constraints. When
+solveSimpleWanteds is finished, we dig out the type from the CHoleCan and
+return that.
+
+***********************************************************************************
+*                                                                                 *
+*                            Inference
+*                                                                                 *
+***********************************************************************************
+
+Note [Inferring the type of a let-bound variable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f x = rhs
+
+To infer f's type we do the following:
+ * Gather the constraints for the RHS with ambient level *one more than*
+   the current one.  This is done by the call
+        pushLevelAndCaptureConstraints (tcMonoBinds...)
+   in TcBinds.tcPolyInfer
+
+ * Call simplifyInfer to simplify the constraints and decide what to
+   quantify over. We pass in the level used for the RHS constraints,
+   here called rhs_tclvl.
+
+This ensures that the implication constraint we generate, if any,
+has a strictly-increased level compared to the ambient level outside
+the let binding.
+
+-}
+
+-- | How should we choose which constraints to quantify over?
+data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,
+                                  -- never quantifying over any constraints
+               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in TcRnDriver,
+                                  -- the :type +d case; this mode refuses
+                                  -- to quantify over any defaultable constraint
+               | NoRestrictions   -- ^ Quantify over any constraint that
+                                  -- satisfies TcType.pickQuantifiablePreds
+
+instance Outputable InferMode where
+  ppr ApplyMR         = text "ApplyMR"
+  ppr EagerDefaulting = text "EagerDefaulting"
+  ppr NoRestrictions  = text "NoRestrictions"
+
+simplifyInfer :: TcLevel               -- Used when generating the constraints
+              -> InferMode
+              -> [TcIdSigInst]         -- Any signatures (possibly partial)
+              -> [(Name, TcTauType)]   -- Variables to be generalised,
+                                       -- and their tau-types
+              -> WantedConstraints
+              -> TcM ([TcTyVar],    -- Quantify over these type variables
+                      [EvVar],      -- ... and these constraints (fully zonked)
+                      TcEvBinds,    -- ... binding these evidence variables
+                      WantedConstraints, -- Redidual as-yet-unsolved constraints
+                      Bool)         -- True <=> the residual constraints are insoluble
+
+simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
+  | isEmptyWC wanteds
+   = do { -- When quantifying, we want to preserve any order of variables as they
+          -- appear in partial signatures. cf. decideQuantifiedTyVars
+          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs
+                                          , (_,tv) <- sig_inst_skols sig ]
+              psig_theta  = [ pred | sig <- partial_sigs
+                                   , pred <- sig_inst_theta sig ]
+
+       ; gbl_tvs <- tcGetGlobalTyCoVars
+       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)
+       ; qtkvs <- quantifyTyVars gbl_tvs dep_vars
+       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
+       ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }
+
+  | otherwise
+  = do { traceTc "simplifyInfer {"  $ vcat
+             [ text "sigs =" <+> ppr sigs
+             , text "binds =" <+> ppr name_taus
+             , text "rhs_tclvl =" <+> ppr rhs_tclvl
+             , text "infer_mode =" <+> ppr infer_mode
+             , text "(unzonked) wanted =" <+> ppr wanteds
+             ]
+
+       ; let psig_theta = concatMap sig_inst_theta partial_sigs
+
+       -- First do full-blown solving
+       -- NB: we must gather up all the bindings from doing
+       -- this solving; hence (runTcSWithEvBinds ev_binds_var).
+       -- And note that since there are nested implications,
+       -- calling solveWanteds will side-effect their evidence
+       -- bindings, so we can't just revert to the input
+       -- constraint.
+
+       ; tc_env          <- TcM.getEnv
+       ; ev_binds_var    <- TcM.newTcEvBinds
+       ; psig_theta_vars <- mapM TcM.newEvVar psig_theta
+       ; wanted_transformed_incl_derivs
+            <- setTcLevel rhs_tclvl $
+               runTcSWithEvBinds ev_binds_var $
+               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $
+                                      env_lcl tc_env
+                        psig_givens = mkGivens loc psig_theta_vars
+                  ; _ <- solveSimpleGivens psig_givens
+                         -- See Note [Add signature contexts as givens]
+                  ; solveWanteds wanteds }
+
+       -- Find quant_pred_candidates, the predicates that
+       -- we'll consider quantifying over
+       -- NB1: wanted_transformed does not include anything provable from
+       --      the psig_theta; it's just the extra bit
+       -- NB2: We do not do any defaulting when inferring a type, this can lead
+       --      to less polymorphic types, see Note [Default while Inferring]
+       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs
+       ; let definite_error = insolubleWC wanted_transformed_incl_derivs
+                              -- See Note [Quantification with errors]
+                              -- NB: must include derived errors in this test,
+                              --     hence "incl_derivs"
+             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs
+             quant_pred_candidates
+               | definite_error = []
+               | otherwise      = ctsPreds (approximateWC False wanted_transformed)
+
+       -- Decide what type variables and constraints to quantify
+       -- NB: quant_pred_candidates is already fully zonked
+       -- NB: bound_theta are constraints we want to quantify over,
+       --     including the psig_theta, which we always quantify over
+       -- NB: bound_theta are fully zonked
+       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl
+                                                     name_taus partial_sigs
+                                                     quant_pred_candidates
+       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta
+
+       -- We must produce bindings for the psig_theta_vars, because we may have
+       -- used them in evidence bindings constructed by solveWanteds earlier
+       -- Easiest way to do this is to emit them as new Wanteds (#14643)
+       ; ct_loc <- getCtLocM AnnOrigin Nothing
+       ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var
+                                      , ctev_dest = EvVarDest psig_theta_var
+                                      , ctev_nosh = WDeriv
+                                      , ctev_loc  = ct_loc }
+                           | psig_theta_var <- psig_theta_vars ]
+
+       -- Now construct the residual constraint
+       ; residual_wanted <- mkResidualConstraints rhs_tclvl tc_env ev_binds_var
+                                 name_taus co_vars qtvs bound_theta_vars
+                                 (wanted_transformed `andWC` mkSimpleWC psig_wanted)
+
+         -- All done!
+       ; traceTc "} simplifyInfer/produced residual implication for quantification" $
+         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates
+              , text "psig_theta =" <+> ppr psig_theta
+              , text "bound_theta =" <+> ppr bound_theta
+              , text "qtvs ="       <+> ppr qtvs
+              , text "definite_error =" <+> ppr definite_error ]
+
+       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var
+                , residual_wanted, definite_error ) }
+         -- NB: bound_theta_vars must be fully zonked
+  where
+    partial_sigs = filter isPartialSig sigs
+
+--------------------
+mkResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar
+                      -> [(Name, TcTauType)]
+                      -> VarSet -> [TcTyVar] -> [EvVar]
+                      -> WantedConstraints -> TcM WantedConstraints
+-- Emit the remaining constraints from the RHS.
+-- See Note [Emitting the residual implication in simplifyInfer]
+mkResidualConstraints rhs_tclvl tc_env ev_binds_var
+                        name_taus co_vars qtvs full_theta_vars wanteds
+  | isEmptyWC wanteds
+  = return wanteds
+
+  | otherwise
+  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)
+       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple
+             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars
+
+        ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)
+
+        ; let inner_wanted = wanteds { wc_simple = inner_simple }
+        ; return (WC { wc_simple = outer_simple
+                     , wc_impl   = mk_implic inner_wanted })}
+  where
+    mk_implic inner_wanted
+      | isEmptyWC inner_wanted
+      = emptyBag
+      | otherwise
+      = unitBag (implicationPrototype { ic_tclvl  = rhs_tclvl
+                                      , ic_skols  = qtvs
+                                      , ic_telescope = Nothing
+                                      , ic_given  = full_theta_vars
+                                      , ic_wanted = inner_wanted
+                                      , ic_binds  = ev_binds_var
+                                      , ic_no_eqs = False
+                                      , ic_info   = skol_info
+                                      , ic_env    = tc_env })
+
+    full_theta = map idType full_theta_vars
+    skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)
+                           | (name, ty) <- name_taus ]
+                 -- Don't add the quantified variables here, because
+                 -- they are also bound in ic_skols and we want them
+                 -- to be tidied uniformly
+
+--------------------
+ctsPreds :: Cts -> [PredType]
+ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts
+                             , let ev = ctEvidence ct ]
+
+{- Note [Emitting the residual implication in simplifyInfer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f = e
+where f's type is inferred to be something like (a, Proxy k (Int |> co))
+and we have an as-yet-unsolved, or perhaps insoluble, constraint
+   [W] co :: Type ~ k
+We can't form types like (forall co. blah), so we can't generalise over
+the coercion variable, and hence we can't generalise over things free in
+its kind, in the case 'k'.  But we can still generalise over 'a'.  So
+we'll generalise to
+   f :: forall a. (a, Proxy k (Int |> co))
+Now we do NOT want to form the residual implication constraint
+   forall a. [W] co :: Type ~ k
+because then co's eventual binding (which will be a value binding if we
+use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose
+type mentions 'co').  Instead, just as we don't generalise over 'co', we
+should not bury its constraint inside the implication.  Instead, we must
+put it outside.
+
+That is the reason for the partitionBag in emitResidualConstraints,
+which takes the CoVars free in the inferred type, and pulls their
+constraints out.  (NB: this set of CoVars should be closed-over-kinds.)
+
+All rather subtle; see #14584.
+
+Note [Add signature contexts as givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#11016):
+  f2 :: (?x :: Int) => _
+  f2 = ?x
+or this
+  f3 :: a ~ Bool => (a, _)
+  f3 = (True, False)
+or theis
+  f4 :: (Ord a, _) => a -> Bool
+  f4 x = x==x
+
+We'll use plan InferGen because there are holes in the type.  But:
+ * For f2 we want to have the (?x :: Int) constraint floating around
+   so that the functional dependencies kick in.  Otherwise the
+   occurrence of ?x on the RHS produces constraint (?x :: alpha), and
+   we won't unify alpha:=Int.
+ * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool)
+   in the RHS
+ * For f4 we want to use the (Ord a) in the signature to solve the Eq a
+   constraint.
+
+Solution: in simplifyInfer, just before simplifying the constraints
+gathered from the RHS, add Given constraints for the context of any
+type signatures.
+
+************************************************************************
+*                                                                      *
+                Quantification
+*                                                                      *
+************************************************************************
+
+Note [Deciding quantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the monomorphism restriction does not apply, then we quantify as follows:
+
+* Step 1. Take the global tyvars, and "grow" them using the equality
+  constraints
+     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can
+          happen because alpha is untouchable here) then do not quantify over
+          beta, because alpha fixes beta, and beta is effectively free in
+          the environment too
+
+  We also account for the monomorphism restriction; if it applies,
+  add the free vars of all the constraints.
+
+  Result is mono_tvs; we will not quantify over these.
+
+* Step 2. Default any non-mono tyvars (i.e ones that are definitely
+  not going to become further constrained), and re-simplify the
+  candidate constraints.
+
+  Motivation for re-simplification (#7857): imagine we have a
+  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are
+  not free in the envt, and instance forall (a::*) (b::*). (C a) => C
+  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but
+  it will match when we default them to LiftedRep.
+
+  This is all very tiresome.
+
+* Step 3: decide which variables to quantify over, as follows:
+
+  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"
+    them using all the constraints.  These are tau_tvs_plus
+
+  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being
+    careful to close over kinds, and to skolemise the quantified tyvars.
+    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)
+
+  Result is qtvs.
+
+* Step 4: Filter the constraints using pickQuantifiablePreds and the
+  qtvs. We have to zonk the constraints first, so they "see" the
+  freshly created skolems.
+
+-}
+
+decideQuantification
+  :: InferMode
+  -> TcLevel
+  -> [(Name, TcTauType)]   -- Variables to be generalised
+  -> [TcIdSigInst]         -- Partial type signatures (if any)
+  -> [PredType]            -- Candidate theta; already zonked
+  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)
+         , [PredType]      -- and this context (fully zonked)
+         , VarSet)
+-- See Note [Deciding quantification]
+decideQuantification infer_mode rhs_tclvl name_taus psigs candidates
+  = do { -- Step 1: find the mono_tvs
+       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode
+                                              name_taus psigs candidates
+
+       -- Step 2: default any non-mono tyvars, and re-simplify
+       -- This step may do some unification, but result candidates is zonked
+       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
+
+       -- Step 3: decide which kind/type variables to quantify over
+       ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates
+
+       -- Step 4: choose which of the remaining candidate
+       --         predicates to actually quantify over
+       -- NB: decideQuantifiedTyVars turned some meta tyvars
+       -- into quantified skolems, so we have to zonk again
+       ; candidates <- TcM.zonkTcTypes candidates
+       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)
+       ; let quantifiable_candidates
+               = pickQuantifiablePreds (mkVarSet qtvs) candidates
+             -- NB: do /not/ run pickQuantifiablePreds over psig_theta,
+             -- because we always want to quantify over psig_theta, and not
+             -- drop any of them; e.g. CallStack constraints.  c.f #14658
+
+             theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]
+                     (psig_theta ++ quantifiable_candidates)
+
+       ; traceTc "decideQuantification"
+           (vcat [ text "infer_mode:" <+> ppr infer_mode
+                 , text "candidates:" <+> ppr candidates
+                 , text "psig_theta:" <+> ppr psig_theta
+                 , text "mono_tvs:"   <+> ppr mono_tvs
+                 , text "co_vars:"    <+> ppr co_vars
+                 , text "qtvs:"       <+> ppr qtvs
+                 , text "theta:"      <+> ppr theta ])
+       ; return (qtvs, theta, co_vars) }
+
+------------------
+decideMonoTyVars :: InferMode
+                 -> [(Name,TcType)]
+                 -> [TcIdSigInst]
+                 -> [PredType]
+                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)
+-- Decide which tyvars and covars cannot be generalised:
+--   (a) Free in the environment
+--   (b) Mentioned in a constraint we can't generalise
+--   (c) Connected by an equality to (a) or (b)
+-- Also return CoVars that appear free in the final quatified types
+--   we can't quantify over these, and we must make sure they are in scope
+decideMonoTyVars infer_mode name_taus psigs candidates
+  = do { (no_quant, maybe_quant) <- pick infer_mode candidates
+
+       -- If possible, we quantify over partial-sig qtvs, so they are
+       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs
+       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $
+                      concatMap (map snd . sig_inst_skols) psigs
+
+       ; psig_theta <- mapM TcM.zonkTcType $
+                       concatMap sig_inst_theta psigs
+
+       ; taus <- mapM (TcM.zonkTcType . snd) name_taus
+
+       ; mono_tvs0 <- tcGetGlobalTyCoVars
+       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta
+
+             co_vars = coVarsOfTypes (psig_tys ++ taus)
+             co_var_tvs = closeOverKinds co_vars
+               -- The co_var_tvs are tvs mentioned in the types of covars or
+               -- coercion holes. We can't quantify over these covars, so we
+               -- must include the variable in their types in the mono_tvs.
+               -- E.g.  If we can't quantify over co :: k~Type, then we can't
+               --       quantify over k either!  Hence closeOverKinds
+
+             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs
+
+             eq_constraints = filter isEqPrimPred candidates
+             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1
+
+             constrained_tvs = (growThetaTyVars eq_constraints
+                                               (tyCoVarsOfTypes no_quant)
+                                `minusVarSet` mono_tvs2)
+                               `delVarSetList` psig_qtvs
+             -- constrained_tvs: the tyvars that we are not going to
+             -- quantify solely because of the moonomorphism restriction
+             --
+             -- (`minusVarSet` mono_tvs1`): a type variable is only
+             --   "constrained" (so that the MR bites) if it is not
+             --   free in the environment (#13785)
+             --
+             -- (`delVarSetList` psig_qtvs): if the user has explicitly
+             --   asked for quantification, then that request "wins"
+             --   over the MR.  Note: do /not/ delete psig_qtvs from
+             --   mono_tvs1, because mono_tvs1 cannot under any circumstances
+             --   be quantified (#14479); see
+             --   Note [Quantification and partial signatures], Wrinkle 3, 4
+
+             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs
+
+           -- Warn about the monomorphism restriction
+       ; warn_mono <- woptM Opt_WarnMonomorphism
+       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $
+         warnTc (Reason Opt_WarnMonomorphism)
+                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)
+                mr_msg
+
+       ; traceTc "decideMonoTyVars" $ vcat
+           [ text "mono_tvs0 =" <+> ppr mono_tvs0
+           , text "mono_tvs1 =" <+> ppr mono_tvs1
+           , text "no_quant =" <+> ppr no_quant
+           , text "maybe_quant =" <+> ppr maybe_quant
+           , text "eq_constraints =" <+> ppr eq_constraints
+           , text "mono_tvs =" <+> ppr mono_tvs
+           , text "co_vars =" <+> ppr co_vars ]
+
+       ; return (mono_tvs, maybe_quant, co_vars) }
+  where
+    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])
+    -- Split the candidates into ones we definitely
+    -- won't quantify, and ones that we might
+    pick NoRestrictions  cand = return ([], cand)
+    pick ApplyMR         cand = return (cand, [])
+    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings
+                                   ; return (partition (is_int_ct os) cand) }
+
+    -- For EagerDefaulting, do not quantify over
+    -- over any interactive class constraint
+    is_int_ct ovl_strings pred
+      | Just (cls, _) <- getClassPredTys_maybe pred
+      = isInteractiveClass ovl_strings cls
+      | otherwise
+      = False
+
+    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus
+    mr_msg =
+         hang (sep [ text "The Monomorphism Restriction applies to the binding"
+                     <> plural name_taus
+                   , text "for" <+> pp_bndrs ])
+            2 (hsep [ text "Consider giving"
+                    , text (if isSingleton name_taus then "it" else "them")
+                    , text "a type signature"])
+
+-------------------
+defaultTyVarsAndSimplify :: TcLevel
+                         -> TyCoVarSet
+                         -> [PredType]          -- Assumed zonked
+                         -> TcM [PredType]      -- Guaranteed zonked
+-- Default any tyvar free in the constraints,
+-- and re-simplify in case the defaulting allows further simplification
+defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
+  = do {  -- Promote any tyvars that we cannot generalise
+          -- See Note [Promote momomorphic tyvars]
+       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)
+       ; (prom, _) <- promoteTyVarSet mono_tvs
+
+       -- Default any kind/levity vars
+       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
+                <- candidateQTyVarsOfTypes candidates
+                -- any covars should already be handled by
+                -- the logic in decideMonoTyVars, which looks at
+                -- the constraints generated
+
+       ; poly_kinds  <- xoptM LangExt.PolyKinds
+       ; default_kvs <- mapM (default_one poly_kinds True)
+                             (dVarSetElems cand_kvs)
+       ; default_tvs <- mapM (default_one poly_kinds False)
+                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))
+       ; let some_default = or default_kvs || or default_tvs
+
+       ; case () of
+           _ | some_default -> simplify_cand candidates
+             | prom         -> mapM TcM.zonkTcType candidates
+             | otherwise    -> return candidates
+       }
+  where
+    default_one poly_kinds is_kind_var tv
+      | not (isMetaTyVar tv)
+      = return False
+      | tv `elemVarSet` mono_tvs
+      = return False
+      | otherwise
+      = defaultTyVar (not poly_kinds && is_kind_var) tv
+
+    simplify_cand candidates
+      = do { clone_wanteds <- newWanteds DefaultOrigin candidates
+           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $
+                                           simplifyWantedsTcM clone_wanteds
+              -- Discard evidence; simples is fully zonked
+
+           ; let new_candidates = ctsPreds simples
+           ; traceTc "Simplified after defaulting" $
+                      vcat [ text "Before:" <+> ppr candidates
+                           , text "After:"  <+> ppr new_candidates ]
+           ; return new_candidates }
+
+------------------
+decideQuantifiedTyVars
+   :: TyCoVarSet        -- Monomorphic tyvars
+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs
+   -> [TcIdSigInst]     -- Partial signatures
+   -> [PredType]        -- Candidates, zonked
+   -> TcM [TyVar]
+-- Fix what tyvars we are going to quantify over, and quantify them
+decideQuantifiedTyVars mono_tvs name_taus psigs candidates
+  = do {     -- Why psig_tys? We try to quantify over everything free in here
+             -- See Note [Quantification and partial signatures]
+             --     Wrinkles 2 and 3
+       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs
+                                                  , (_,tv) <- sig_inst_skols sig ]
+       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs
+                                                  , pred <- sig_inst_theta sig ]
+       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus
+       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs
+
+       ; let -- Try to quantify over variables free in these types
+             psig_tys = psig_tv_tys ++ psig_theta
+             seed_tys = psig_tys ++ tau_tys
+
+             -- Now "grow" those seeds to find ones reachable via 'candidates'
+             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)
+
+       -- Now we have to classify them into kind variables and type variables
+       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars
+       --
+       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces
+       -- them in that order, so that the final qtvs quantifies in the same
+       -- order as the partial signatures do (#13524)
+       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $
+                                                         psig_tys ++ candidates ++ tau_tys
+       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)
+             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
+
+       ; traceTc "decideQuantifiedTyVars" (vcat
+           [ text "candidates =" <+> ppr candidates
+           , text "tau_tys =" <+> ppr tau_tys
+           , text "seed_tys =" <+> ppr seed_tys
+           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)
+           , text "grown_tcvs =" <+> ppr grown_tcvs
+           , text "dvs =" <+> ppr dvs_plus])
+
+       ; quantifyTyVars mono_tvs dvs_plus }
+
+------------------
+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet
+-- See Note [Growing the tau-tvs using constraints]
+growThetaTyVars theta tcvs
+  | null theta = tcvs
+  | otherwise  = transCloVarSet mk_next seed_tcvs
+  where
+    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
+    (ips, non_ips) = partition isIPPred theta
+                         -- See Note [Inheriting implicit parameters] in TcType
+
+    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips
+    grow_one so_far pred tcvs
+       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs
+       | otherwise                           = tcvs
+       where
+         pred_tcvs = tyCoVarsOfType pred
+
+
+{- Note [Promote momomorphic tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Promote any type variables that are free in the environment.  Eg
+   f :: forall qtvs. bound_theta => zonked_tau
+The free vars of f's type become free in the envt, and hence will show
+up whenever 'f' is called.  They may currently at rhs_tclvl, but they
+had better be unifiable at the outer_tclvl!  Example: envt mentions
+alpha[1]
+           tau_ty = beta[2] -> beta[2]
+           constraints = alpha ~ [beta]
+we don't quantify over beta (since it is fixed by envt)
+so we must promote it!  The inferred type is just
+  f :: beta -> beta
+
+NB: promoteTyVar ignores coercion variables
+
+Note [Quantification and partial signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When choosing type variables to quantify, the basic plan is to
+quantify over all type variables that are
+ * free in the tau_tvs, and
+ * not forced to be monomorphic (mono_tvs),
+   for example by being free in the environment.
+
+However, in the case of a partial type signature, be doing inference
+*in the presence of a type signature*. For example:
+   f :: _ -> a
+   f x = ...
+or
+   g :: (Eq _a) => _b -> _b
+In both cases we use plan InferGen, and hence call simplifyInfer.  But
+those 'a' variables are skolems (actually TyVarTvs), and we should be
+sure to quantify over them.  This leads to several wrinkles:
+
+* Wrinkle 1.  In the case of a type error
+     f :: _ -> Maybe a
+     f x = True && x
+  The inferred type of 'f' is f :: Bool -> Bool, but there's a
+  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting
+  machine expects to find a binding site for the skolem 'a', so we
+  add it to the quantified tyvars.
+
+* Wrinkle 2.  Consider the partial type signature
+     f :: (Eq _) => Int -> Int
+     f x = x
+  In normal cases that makes sense; e.g.
+     g :: Eq _a => _a -> _a
+     g x = x
+  where the signature makes the type less general than it could
+  be. But for 'f' we must therefore quantify over the user-annotated
+  constraints, to get
+     f :: forall a. Eq a => Int -> Int
+  (thereby correctly triggering an ambiguity error later).  If we don't
+  we'll end up with a strange open type
+     f :: Eq alpha => Int -> Int
+  which isn't ambiguous but is still very wrong.
+
+  Bottom line: Try to quantify over any variable free in psig_theta,
+  just like the tau-part of the type.
+
+* Wrinkle 3 (#13482). Also consider
+    f :: forall a. _ => Int -> Int
+    f x = if (undefined :: a) == undefined then x else 0
+  Here we get an (Eq a) constraint, but it's not mentioned in the
+  psig_theta nor the type of 'f'.  But we still want to quantify
+  over 'a' even if the monomorphism restriction is on.
+
+* Wrinkle 4 (#14479)
+    foo :: Num a => a -> a
+    foo xxx = g xxx
+      where
+        g :: forall b. Num b => _ -> b
+        g y = xxx + y
+
+  In the signature for 'g', we cannot quantify over 'b' because it turns out to
+  get unified with 'a', which is free in g's environment.  So we carefully
+  refrain from bogusly quantifying, in TcSimplify.decideMonoTyVars.  We
+  report the error later, in TcBinds.chooseInferredQuantifiers.
+
+Note [Growing the tau-tvs using constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(growThetaTyVars insts tvs) is the result of extending the set
+    of tyvars, tvs, using all conceivable links from pred
+
+E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
+Then growThetaTyVars preds tvs = {a,b,c}
+
+Notice that
+   growThetaTyVars is conservative       if v might be fixed by vs
+                                         => v `elem` grow(vs,C)
+
+Note [Quantification with errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find that the RHS of the definition has some absolutely-insoluble
+constraints (including especially "variable not in scope"), we
+
+* Abandon all attempts to find a context to quantify over,
+  and instead make the function fully-polymorphic in whatever
+  type we have found
+
+* Return a flag from simplifyInfer, indicating that we found an
+  insoluble constraint.  This flag is used to suppress the ambiguity
+  check for the inferred type, which may well be bogus, and which
+  tends to obscure the real error.  This fix feels a bit clunky,
+  but I failed to come up with anything better.
+
+Reasons:
+    - Avoid downstream errors
+    - Do not perform an ambiguity test on a bogus type, which might well
+      fail spuriously, thereby obfuscating the original insoluble error.
+      #14000 is an example
+
+I tried an alternative approach: simply failM, after emitting the
+residual implication constraint; the exception will be caught in
+TcBinds.tcPolyBinds, which gives all the binders in the group the type
+(forall a. a).  But that didn't work with -fdefer-type-errors, because
+the recovery from failM emits no code at all, so there is no function
+to run!   But -fdefer-type-errors aspires to produce a runnable program.
+
+NB that we must include *derived* errors in the check for insolubles.
+Example:
+    (a::*) ~ Int#
+We get an insoluble derived error *~#, and we don't want to discard
+it before doing the isInsolubleWC test!  (#8262)
+
+Note [Default while Inferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Our current plan is that defaulting only happens at simplifyTop and
+not simplifyInfer.  This may lead to some insoluble deferred constraints.
+Example:
+
+instance D g => C g Int b
+
+constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha
+type inferred       = gamma -> gamma
+
+Now, if we try to default (alpha := Int) we will be able to refine the implication to
+  (forall b. 0 => C gamma Int b)
+which can then be simplified further to
+  (forall b. 0 => D gamma)
+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified
+type:  forall g. D g => g -> g
+
+Instead what will currently happen is that we will get a quantified type
+(forall g. g -> g) and an implication:
+       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha
+
+Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an
+unsolvable implication:
+       forall g. 0 => (forall b. 0 => D g)
+
+The concrete example would be:
+       h :: C g a s => g -> a -> ST s a
+       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)
+
+But it is quite tedious to do defaulting and resolve the implication constraints, and
+we have not observed code breaking because of the lack of defaulting in inference, so
+we don't do it for now.
+
+
+
+Note [Minimize by Superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we quantify over a constraint, in simplifyInfer we need to
+quantify over a constraint that is minimal in some sense: For
+instance, if the final wanted constraint is (Eq alpha, Ord alpha),
+we'd like to quantify over Ord alpha, because we can just get Eq alpha
+from superclass selection from Ord alpha. This minimization is what
+mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
+to check the original wanted.
+
+
+Note [Avoid unnecessary constraint simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -------- NB NB NB (Jun 12) -------------
+    This note not longer applies; see the notes with #4361.
+    But I'm leaving it in here so we remember the issue.)
+    ----------------------------------------
+When inferring the type of a let-binding, with simplifyInfer,
+try to avoid unnecessarily simplifying class constraints.
+Doing so aids sharing, but it also helps with delicate
+situations like
+
+   instance C t => C [t] where ..
+
+   f :: C [t] => ....
+   f x = let g y = ...(constraint C [t])...
+         in ...
+When inferring a type for 'g', we don't want to apply the
+instance decl, because then we can't satisfy (C t).  So we
+just notice that g isn't quantified over 't' and partition
+the constraints before simplifying.
+
+This only half-works, but then let-generalisation only half-works.
+
+*********************************************************************************
+*                                                                                 *
+*                                 Main Simplifier                                 *
+*                                                                                 *
+***********************************************************************************
+
+-}
+
+simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
+-- Solve the specified Wanted constraints
+-- Discard the evidence binds
+-- Discards all Derived stuff in result
+-- Postcondition: fully zonked and unflattened constraints
+simplifyWantedsTcM wanted
+  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)
+       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))
+       ; result <- TcM.zonkWC result
+       ; traceTc "simplifyWantedsTcM }" (ppr result)
+       ; return result }
+
+solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints
+-- Since solveWanteds returns the residual WantedConstraints,
+-- it should always be called within a runTcS or something similar,
+-- Result is not zonked
+solveWantedsAndDrop wanted
+  = do { wc <- solveWanteds wanted
+       ; return (dropDerivedWC wc) }
+
+solveWanteds :: WantedConstraints -> TcS WantedConstraints
+-- so that the inert set doesn't mindlessly propagate.
+-- NB: wc_simples may be wanted /or/ derived now
+solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { cur_lvl <- TcS.getTcLevel
+       ; traceTcS "solveWanteds {" $
+         vcat [ text "Level =" <+> ppr cur_lvl
+              , ppr wc ]
+
+       ; wc1 <- solveSimpleWanteds simples
+                -- Any insoluble constraints are in 'simples' and so get rewritten
+                -- See Note [Rewrite insolubles] in TcSMonad
+
+       ; (floated_eqs, implics2) <- solveNestedImplications $
+                                    implics `unionBags` wc_impl wc1
+
+       ; dflags   <- getDynFlags
+       ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs
+                                (wc1 { wc_impl = implics2 })
+
+       ; ev_binds_var <- getTcEvBindsVar
+       ; bb <- TcS.getTcEvBindsMap ev_binds_var
+       ; traceTcS "solveWanteds }" $
+                 vcat [ text "final wc =" <+> ppr final_wc
+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]
+
+       ; return final_wc }
+
+simpl_loop :: Int -> IntWithInf -> Cts
+           -> WantedConstraints -> TcS WantedConstraints
+simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples })
+  | n `intGtLimit` limit
+  = do { -- Add an error (not a warning) if we blow the limit,
+         -- Typically if we blow the limit we are going to report some other error
+         -- (an unsolved constraint), and we don't want that error to suppress
+         -- the iteration limit warning!
+         addErrTcS (hang (text "solveWanteds: too many iterations"
+                   <+> parens (text "limit =" <+> ppr limit))
+                2 (vcat [ text "Unsolved:" <+> ppr wc
+                        , ppUnless (isEmptyBag floated_eqs) $
+                          text "Floated equalities:" <+> ppr floated_eqs
+                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
+                  ]))
+       ; return wc }
+
+  | not (isEmptyBag floated_eqs)
+  = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples })
+            -- Put floated_eqs first so they get solved first
+            -- NB: the floated_eqs may include /derived/ equalities
+            -- arising from fundeps inside an implication
+
+  | superClassesMightHelp wc
+  = -- We still have unsolved goals, and apparently no way to solve them,
+    -- so try expanding superclasses at this level, both Given and Wanted
+    do { pending_given <- getPendingGivenScs
+       ; let (pending_wanted, simples1) = getPendingWantedScs simples
+       ; if null pending_given && null pending_wanted
+           then return wc  -- After all, superclasses did not help
+           else
+    do { new_given  <- makeSuperClasses pending_given
+       ; new_wanted <- makeSuperClasses pending_wanted
+       ; solveSimpleGivens new_given -- Add the new Givens to the inert set
+       ; simplify_again n limit (null pending_given)
+         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
+
+  | otherwise
+  = return wc
+
+simplify_again :: Int -> IntWithInf -> Bool
+               -> WantedConstraints -> TcS WantedConstraints
+-- We have definitely decided to have another go at solving
+-- the wanted constraints (we have tried at least once already
+simplify_again n limit no_new_given_scs
+               wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { csTraceTcS $
+         text "simpl_loop iteration=" <> int n
+         <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma
+                            , int (lengthBag simples) <+> text "simples to solve" ])
+       ; traceTcS "simpl_loop: wc =" (ppr wc)
+
+       ; (unifs1, wc1) <- reportUnifications $
+                          solveSimpleWanteds $
+                          simples
+
+       -- See Note [Cutting off simpl_loop]
+       -- We have already tried to solve the nested implications once
+       -- Try again only if we have unified some meta-variables
+       -- (which is a bit like adding more givens), or we have some
+       -- new Given superclasses
+       ; let new_implics = wc_impl wc1
+       ; if unifs1 == 0       &&
+            no_new_given_scs  &&
+            isEmptyBag new_implics
+
+           then -- Do not even try to solve the implications
+                simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics })
+
+           else -- Try to solve the implications
+                do { (floated_eqs2, implics2) <- solveNestedImplications $
+                                                 implics `unionBags` new_implics
+                   ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 })
+    } }
+
+solveNestedImplications :: Bag Implication
+                        -> TcS (Cts, Bag Implication)
+-- Precondition: the TcS inerts may contain unsolved simples which have
+-- to be converted to givens before we go inside a nested implication.
+solveNestedImplications implics
+  | isEmptyBag implics
+  = return (emptyBag, emptyBag)
+  | otherwise
+  = do { traceTcS "solveNestedImplications starting {" empty
+       ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics
+       ; let floated_eqs = concatBag floated_eqs_s
+
+       -- ... and we are back in the original TcS inerts
+       -- Notice that the original includes the _insoluble_simples so it was safe to ignore
+       -- them in the beginning of this function.
+       ; traceTcS "solveNestedImplications end }" $
+                  vcat [ text "all floated_eqs ="  <+> ppr floated_eqs
+                       , text "unsolved_implics =" <+> ppr unsolved_implics ]
+
+       ; return (floated_eqs, catBagMaybes unsolved_implics) }
+
+solveImplication :: Implication    -- Wanted
+                 -> TcS (Cts,      -- All wanted or derived floated equalities: var = type
+                         Maybe Implication) -- Simplified implication (empty or singleton)
+-- Precondition: The TcS monad contains an empty worklist and given-only inerts
+-- which after trying to solve this implication we must restore to their original value
+solveImplication imp@(Implic { ic_tclvl  = tclvl
+                             , ic_binds  = ev_binds_var
+                             , ic_skols  = skols
+                             , ic_given  = given_ids
+                             , ic_wanted = wanteds
+                             , ic_info   = info
+                             , ic_status = status })
+  | isSolvedStatus status
+  = return (emptyCts, Just imp)  -- Do nothing
+
+  | otherwise  -- Even for IC_Insoluble it is worth doing more work
+               -- The insoluble stuff might be in one sub-implication
+               -- and other unsolved goals in another; and we want to
+               -- solve the latter as much as possible
+  = do { inerts <- getTcSInerts
+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
+
+       -- commented out; see `where` clause below
+       -- ; when debugIsOn check_tc_level
+
+         -- Solve the nested constraints
+       ; (no_given_eqs, given_insols, residual_wanted)
+            <- nestImplicTcS ev_binds_var tclvl $
+               do { let loc    = mkGivenLoc tclvl info (implicLclEnv imp)
+                        givens = mkGivens loc given_ids
+                  ; solveSimpleGivens givens
+
+                  ; residual_wanted <- solveWanteds wanteds
+                        -- solveWanteds, *not* solveWantedsAndDrop, because
+                        -- we want to retain derived equalities so we can float
+                        -- them out in floatEqualities
+
+                  ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols
+                        -- Call getNoGivenEqs /after/ solveWanteds, because
+                        -- solveWanteds can augment the givens, via expandSuperClasses,
+                        -- to reveal given superclass equalities
+
+                  ; return (no_eqs, given_insols, residual_wanted) }
+
+       ; (floated_eqs, residual_wanted)
+             <- floatEqualities skols given_ids ev_binds_var
+                                no_given_eqs residual_wanted
+
+       ; traceTcS "solveImplication 2"
+           (ppr given_insols $$ ppr residual_wanted)
+       ; let final_wanted = residual_wanted `addInsols` given_insols
+             -- Don't lose track of the insoluble givens,
+             -- which signal unreachable code; put them in ic_wanted
+
+       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs
+                                                 , ic_wanted = final_wanted })
+
+       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var
+       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var
+       ; traceTcS "solveImplication end }" $ vcat
+             [ text "no_given_eqs =" <+> ppr no_given_eqs
+             , text "floated_eqs =" <+> ppr floated_eqs
+             , text "res_implic =" <+> ppr res_implic
+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)
+             , text "implication tvcs =" <+> ppr tcvs ]
+
+       ; return (floated_eqs, res_implic) }
+
+  where
+    -- TcLevels must be strictly increasing (see (ImplicInv) in
+    -- Note [TcLevel and untouchable type variables] in TcType),
+    -- and in fact I thinkthey should always increase one level at a time.
+
+    -- Though sensible, this check causes lots of testsuite failures. It is
+    -- remaining commented out for now.
+    {-
+    check_tc_level = do { cur_lvl <- TcS.getTcLevel
+                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }
+    -}
+
+----------------------
+setImplicationStatus :: Implication -> TcS (Maybe Implication)
+-- Finalise the implication returned from solveImplication:
+--    * Set the ic_status field
+--    * Trim the ic_wanted field to remove Derived constraints
+-- Precondition: the ic_status field is not already IC_Solved
+-- Return Nothing if we can discard the implication altogether
+setImplicationStatus implic@(Implic { ic_status     = status
+                                    , ic_info       = info
+                                    , ic_wanted     = wc
+                                    , ic_given      = givens })
+ | ASSERT2( not (isSolvedStatus status ), ppr info )
+   -- Precondition: we only set the status if it is not already solved
+   not (isSolvedWC pruned_wc)
+ = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)
+
+      ; implic <- neededEvVars implic
+
+      ; let new_status | insolubleWC pruned_wc = IC_Insoluble
+                       | otherwise             = IC_Unsolved
+            new_implic = implic { ic_status = new_status
+                                , ic_wanted = pruned_wc }
+
+      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)
+
+      ; return $ Just new_implic }
+
+ | otherwise  -- Everything is solved
+              -- Set status to IC_Solved,
+              -- and compute the dead givens and outer needs
+              -- See Note [Tracking redundant constraints]
+ = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)
+
+      ; implic@(Implic { ic_need_inner = need_inner
+                       , ic_need_outer = need_outer }) <- neededEvVars implic
+
+      ; bad_telescope <- checkBadTelescope implic
+
+      ; let dead_givens | warnRedundantGivens info
+                        = filterOut (`elemVarSet` need_inner) givens
+                        | otherwise = []   -- None to report
+
+            discard_entire_implication  -- Can we discard the entire implication?
+              =  null dead_givens           -- No warning from this implication
+              && not bad_telescope
+              && isEmptyWC pruned_wc        -- No live children
+              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent
+
+            final_status
+              | bad_telescope = IC_BadTelescope
+              | otherwise     = IC_Solved { ics_dead = dead_givens }
+            final_implic = implic { ic_status = final_status
+                                  , ic_wanted = pruned_wc }
+
+      ; traceTcS "setImplicationStatus(all-solved) }" $
+        vcat [ text "discard:" <+> ppr discard_entire_implication
+             , text "new_implic:" <+> ppr final_implic ]
+
+      ; return $ if discard_entire_implication
+                 then Nothing
+                 else Just final_implic }
+ where
+   WC { wc_simple = simples, wc_impl = implics } = wc
+
+   pruned_simples = dropDerivedSimples simples
+   pruned_implics = filterBag keep_me implics
+   pruned_wc = WC { wc_simple = pruned_simples
+                  , wc_impl   = pruned_implics }
+
+   keep_me :: Implication -> Bool
+   keep_me ic
+     | IC_Solved { ics_dead = dead_givens } <- ic_status ic
+                          -- Fully solved
+     , null dead_givens   -- No redundant givens to report
+     , isEmptyBag (wc_impl (ic_wanted ic))
+           -- And no children that might have things to report
+     = False       -- Tnen we don't need to keep it
+     | otherwise
+     = True        -- Otherwise, keep it
+
+checkBadTelescope :: Implication -> TcS Bool
+-- True <=> the skolems form a bad telescope
+-- See Note [Keeping scoped variables in order: Explicit] in TcHsType
+checkBadTelescope (Implic { ic_telescope  = m_telescope
+                          , ic_skols      = skols })
+  | isJust m_telescope
+  = do{ skols <- mapM TcS.zonkTyCoVarKind skols
+      ; return (go emptyVarSet (reverse skols))}
+
+  | otherwise
+  = return False
+
+  where
+    go :: TyVarSet   -- skolems that appear *later* than the current ones
+       -> [TcTyVar]  -- ordered skolems, in reverse order
+       -> Bool       -- True <=> there is an out-of-order skolem
+    go _ [] = False
+    go later_skols (one_skol : earlier_skols)
+      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols
+      = True
+      | otherwise
+      = go (later_skols `extendVarSet` one_skol) earlier_skols
+
+warnRedundantGivens :: SkolemInfo -> Bool
+warnRedundantGivens (SigSkol ctxt _ _)
+  = case ctxt of
+       FunSigCtxt _ warn_redundant -> warn_redundant
+       ExprSigCtxt                 -> True
+       _                           -> False
+
+  -- To think about: do we want to report redundant givens for
+  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.
+warnRedundantGivens (InstSkol {}) = True
+warnRedundantGivens _             = False
+
+neededEvVars :: Implication -> TcS Implication
+-- Find all the evidence variables that are "needed",
+-- and delete dead evidence bindings
+--   See Note [Tracking redundant constraints]
+--   See Note [Delete dead Given evidence bindings]
+--
+--   - Start from initial_seeds (from nested implications)
+--
+--   - Add free vars of RHS of all Wanted evidence bindings
+--     and coercion variables accumulated in tcvs (all Wanted)
+--
+--   - Generate 'needed', the needed set of EvVars, by doing transitive
+--     closure through Given bindings
+--     e.g.   Needed {a,b}
+--            Given  a = sc_sel a2
+--            Then a2 is needed too
+--
+--   - Prune out all Given bindings that are not needed
+--
+--   - From the 'needed' set, delete ev_bndrs, the binders of the
+--     evidence bindings, to give the final needed variables
+--
+neededEvVars implic@(Implic { ic_given = givens
+                            , ic_binds = ev_binds_var
+                            , ic_wanted = WC { wc_impl = implics }
+                            , ic_need_inner = old_needs })
+ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
+      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var
+
+      ; let seeds1        = foldrBag add_implic_seeds old_needs implics
+            seeds2        = foldEvBindMap add_wanted seeds1 ev_binds
+            seeds3        = seeds2 `unionVarSet` tcvs
+            need_inner    = findNeededEvVars ev_binds seeds3
+            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
+            need_outer    = foldEvBindMap del_ev_bndr need_inner live_ev_binds
+                            `delVarSetList` givens
+
+      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
+           -- See Note [Delete dead Given evidence bindings]
+
+      ; traceTcS "neededEvVars" $
+        vcat [ text "old_needs:" <+> ppr old_needs
+             , text "seeds3:" <+> ppr seeds3
+             , text "tcvs:" <+> ppr tcvs
+             , text "ev_binds:" <+> ppr ev_binds
+             , text "live_ev_binds:" <+> ppr live_ev_binds ]
+
+      ; return (implic { ic_need_inner = need_inner
+                       , ic_need_outer = need_outer }) }
+ where
+   add_implic_seeds (Implic { ic_need_outer = needs }) acc
+      = needs `unionVarSet` acc
+
+   needed_ev_bind needed (EvBind { eb_lhs = ev_var
+                                 , eb_is_given = is_given })
+     | is_given  = ev_var `elemVarSet` needed
+     | otherwise = True   -- Keep all wanted bindings
+
+   del_ev_bndr :: EvBind -> VarSet -> VarSet
+   del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v
+
+   add_wanted :: EvBind -> VarSet -> VarSet
+   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
+     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only
+     | otherwise = evVarsOfTerm rhs `unionVarSet` needs
+
+
+{- Note [Delete dead Given evidence bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As a result of superclass expansion, we speculatively
+generate evidence bindings for Givens. E.g.
+   f :: (a ~ b) => a -> b -> Bool
+   f x y = ...
+We'll have
+   [G] d1 :: (a~b)
+and we'll specuatively generate the evidence binding
+   [G] d2 :: (a ~# b) = sc_sel d
+
+Now d2 is available for solving.  But it may not be needed!  Usually
+such dead superclass selections will eventually be dropped as dead
+code, but:
+
+ * It won't always be dropped (#13032).  In the case of an
+   unlifted-equality superclass like d2 above, we generate
+       case heq_sc d1 of d2 -> ...
+   and we can't (in general) drop that case exrpession in case
+   d1 is bottom.  So it's technically unsound to have added it
+   in the first place.
+
+ * Simply generating all those extra superclasses can generate lots of
+   code that has to be zonked, only to be discarded later.  Better not
+   to generate it in the first place.
+
+   Moreover, if we simplify this implication more than once
+   (e.g. because we can't solve it completely on the first iteration
+   of simpl_looop), we'll generate all the same bindings AGAIN!
+
+Easy solution: take advantage of the work we are doing to track dead
+(unused) Givens, and use it to prune the Given bindings too.  This is
+all done by neededEvVars.
+
+This led to a remarkable 25% overall compiler allocation decrease in
+test T12227.
+
+But we don't get to discard all redundant equality superclasses, alas;
+see #15205.
+
+Note [Tracking redundant constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With Opt_WarnRedundantConstraints, GHC can report which
+constraints of a type signature (or instance declaration) are
+redundant, and can be omitted.  Here is an overview of how it
+works:
+
+----- What is a redundant constraint?
+
+* The things that can be redundant are precisely the Given
+  constraints of an implication.
+
+* A constraint can be redundant in two different ways:
+  a) It is implied by other givens.  E.g.
+       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary
+       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary
+  b) It is not needed by the Wanted constraints covered by the
+     implication E.g.
+       f :: Eq a => a -> Bool
+       f x = True  -- Equality not used
+
+*  To find (a), when we have two Given constraints,
+   we must be careful to drop the one that is a naked variable (if poss).
+   So if we have
+       f :: (Eq a, Ord a) => blah
+   then we may find [G] sc_sel (d1::Ord a) :: Eq a
+                    [G] d2 :: Eq a
+   We want to discard d2 in favour of the superclass selection from
+   the Ord dictionary.  This is done by TcInteract.solveOneFromTheOther
+   See Note [Replacement vs keeping].
+
+* To find (b) we need to know which evidence bindings are 'wanted';
+  hence the eb_is_given field on an EvBind.
+
+----- How tracking works
+
+* The ic_need fields of an Implic records in-scope (given) evidence
+  variables bound by the context, that were needed to solve this
+  implication (so far).  See the declaration of Implication.
+
+* When the constraint solver finishes solving all the wanteds in
+  an implication, it sets its status to IC_Solved
+
+  - The ics_dead field, of IC_Solved, records the subset of this
+    implication's ic_given that are redundant (not needed).
+
+* We compute which evidence variables are needed by an implication
+  in setImplicationStatus.  A variable is needed if
+    a) it is free in the RHS of a Wanted EvBind,
+    b) it is free in the RHS of an EvBind whose LHS is needed,
+    c) it is in the ics_need of a nested implication.
+
+* We need to be careful not to discard an implication
+  prematurely, even one that is fully solved, because we might
+  thereby forget which variables it needs, and hence wrongly
+  report a constraint as redundant.  But we can discard it once
+  its free vars have been incorporated into its parent; or if it
+  simply has no free vars. This careful discarding is also
+  handled in setImplicationStatus.
+
+----- Reporting redundant constraints
+
+* TcErrors does the actual warning, in warnRedundantConstraints.
+
+* We don't report redundant givens for *every* implication; only
+  for those which reply True to TcSimplify.warnRedundantGivens:
+
+   - For example, in a class declaration, the default method *can*
+     use the class constraint, but it certainly doesn't *have* to,
+     and we don't want to report an error there.
+
+   - More subtly, in a function definition
+       f :: (Ord a, Ord a, Ix a) => a -> a
+       f x = rhs
+     we do an ambiguity check on the type (which would find that one
+     of the Ord a constraints was redundant), and then we check that
+     the definition has that type (which might find that both are
+     redundant).  We don't want to report the same error twice, so we
+     disable it for the ambiguity check.  Hence using two different
+     FunSigCtxts, one with the warn-redundant field set True, and the
+     other set False in
+        - TcBinds.tcSpecPrag
+        - TcBinds.tcTySig
+
+  This decision is taken in setImplicationStatus, rather than TcErrors
+  so that we can discard implication constraints that we don't need.
+  So ics_dead consists only of the *reportable* redundant givens.
+
+----- Shortcomings
+
+Consider (see #9939)
+    f2 :: (Eq a, Ord a) => a -> a -> Bool
+    -- Ord a redundant, but Eq a is reported
+    f2 x y = (x == y)
+
+We report (Eq a) as redundant, whereas actually (Ord a) is.  But it's
+really not easy to detect that!
+
+
+Note [Cutting off simpl_loop]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very important not to iterate in simpl_loop unless there is a chance
+of progress.  #8474 is a classic example:
+
+  * There's a deeply-nested chain of implication constraints.
+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int
+
+  * From the innermost one we get a [D] alpha ~ Int,
+    but alpha is untouchable until we get out to the outermost one
+
+  * We float [D] alpha~Int out (it is in floated_eqs), but since alpha
+    is untouchable, the solveInteract in simpl_loop makes no progress
+
+  * So there is no point in attempting to re-solve
+       ?yn:betan => [W] ?x:Int
+    via solveNestedImplications, because we'll just get the
+    same [D] again
+
+  * If we *do* re-solve, we'll get an ininite loop. It is cut off by
+    the fixed bound of 10, but solving the next takes 10*10*...*10 (ie
+    exponentially many) iterations!
+
+Conclusion: we should call solveNestedImplications only if we did
+some unification in solveSimpleWanteds; because that's the only way
+we'll get more Givens (a unification is like adding a Given) to
+allow the implication to make progress.
+-}
+
+promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar)
+-- When we float a constraint out of an implication we must restore
+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType
+-- Return True <=> we did some promotion
+-- Also returns either the original tyvar (no promotion) or the new one
+-- See Note [Promoting unification variables]
+promoteTyVar tv
+  = do { tclvl <- TcM.getTcLevel
+       ; if (isFloatedTouchableMetaTyVar tclvl tv)
+         then do { cloned_tv <- TcM.cloneMetaTyVar tv
+                 ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
+                 ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)
+                 ; return (True, rhs_tv) }
+         else return (False, tv) }
+
+-- Returns whether or not *any* tyvar is defaulted
+promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet)
+promoteTyVarSet tvs
+  = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs)
+           -- non-determinism is OK because order of promotion doesn't matter
+
+       ; return (or bools, mkVarSet tyvars) }
+
+promoteTyVarTcS :: TcTyVar  -> TcS ()
+-- When we float a constraint out of an implication we must restore
+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType
+-- See Note [Promoting unification variables]
+-- We don't just call promoteTyVar because we want to use unifyTyVar,
+-- not writeMetaTyVar
+promoteTyVarTcS tv
+  = do { tclvl <- TcS.getTcLevel
+       ; when (isFloatedTouchableMetaTyVar tclvl tv) $
+         do { cloned_tv <- TcS.cloneMetaTyVar tv
+            ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
+            ; unifyTyVar tv (mkTyVarTy rhs_tv) } }
+
+-- | Like 'defaultTyVar', but in the TcS monad.
+defaultTyVarTcS :: TcTyVar -> TcS Bool
+defaultTyVarTcS the_tv
+  | isRuntimeRepVar the_tv
+  , not (isTyVarTyVar the_tv)
+    -- TyVarTvs should only be unified with a tyvar
+    -- never with a type; c.f. TcMType.defaultTyVar
+    -- and Note [Inferring kinds for type declarations] in TcTyClsDecls
+  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)
+       ; unifyTyVar the_tv liftedRepTy
+       ; return True }
+  | otherwise
+  = return False  -- the common case
+
+approximateWC :: Bool -> WantedConstraints -> Cts
+-- Postcondition: Wanted or Derived Cts
+-- See Note [ApproximateWC]
+approximateWC float_past_equalities wc
+  = float_wc emptyVarSet wc
+  where
+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
+    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })
+      = filterBag (is_floatable trapping_tvs) simples `unionBags`
+        do_bag (float_implic trapping_tvs) implics
+      where
+
+    float_implic :: TcTyCoVarSet -> Implication -> Cts
+    float_implic trapping_tvs imp
+      | float_past_equalities || ic_no_eqs imp
+      = float_wc new_trapping_tvs (ic_wanted imp)
+      | otherwise   -- Take care with equalities
+      = emptyCts    -- See (1) under Note [ApproximateWC]
+      where
+        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
+
+    is_floatable skol_tvs ct
+       | isGivenCt ct     = False
+       | isHoleCt ct      = False
+       | insolubleEqCt ct = False
+       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+
+{- Note [ApproximateWC]
+~~~~~~~~~~~~~~~~~~~~~~~
+approximateWC takes a constraint, typically arising from the RHS of a
+let-binding whose type we are *inferring*, and extracts from it some
+*simple* constraints that we might plausibly abstract over.  Of course
+the top-level simple constraints are plausible, but we also float constraints
+out from inside, if they are not captured by skolems.
+
+The same function is used when doing type-class defaulting (see the call
+to applyDefaultingRules) to extract constraints that that might be defaulted.
+
+There is one caveat:
+
+1.  When infering most-general types (in simplifyInfer), we do *not*
+    float anything out if the implication binds equality constraints,
+    because that defeats the OutsideIn story.  Consider
+       data T a where
+         TInt :: T Int
+         MkT :: T a
+
+       f TInt = 3::Int
+
+    We get the implication (a ~ Int => res ~ Int), where so far we've decided
+      f :: T a -> res
+    We don't want to float (res~Int) out because then we'll infer
+      f :: T a -> Int
+    which is only on of the possible types. (GHC 7.6 accidentally *did*
+    float out of such implications, which meant it would happily infer
+    non-principal types.)
+
+   HOWEVER (#12797) in findDefaultableGroups we are not worried about
+   the most-general type; and we /do/ want to float out of equalities.
+   Hence the boolean flag to approximateWC.
+
+------ Historical note -----------
+There used to be a second caveat, driven by #8155
+
+   2. We do not float out an inner constraint that shares a type variable
+      (transitively) with one that is trapped by a skolem.  Eg
+          forall a.  F a ~ beta, Integral beta
+      We don't want to float out (Integral beta).  Doing so would be bad
+      when defaulting, because then we'll default beta:=Integer, and that
+      makes the error message much worse; we'd get
+          Can't solve  F a ~ Integer
+      rather than
+          Can't solve  Integral (F a)
+
+      Moreover, floating out these "contaminated" constraints doesn't help
+      when generalising either. If we generalise over (Integral b), we still
+      can't solve the retained implication (forall a. F a ~ b).  Indeed,
+      arguably that too would be a harder error to understand.
+
+But this transitive closure stuff gives rise to a complex rule for
+when defaulting actually happens, and one that was never documented.
+Moreover (#12923), the more complex rule is sometimes NOT what
+you want.  So I simply removed the extra code to implement the
+contamination stuff.  There was zero effect on the testsuite (not even
+#8155).
+------ End of historical note -----------
+
+
+Note [DefaultTyVar]
+~~~~~~~~~~~~~~~~~~~
+defaultTyVar is used on any un-instantiated meta type variables to
+default any RuntimeRep variables to LiftedRep.  This is important
+to ensure that instance declarations match.  For example consider
+
+     instance Show (a->b)
+     foo x = show (\_ -> True)
+
+Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),
+and that won't match the tcTypeKind (*) in the instance decl.  See tests
+tc217 and tc175.
+
+We look only at touchable type variables. No further constraints
+are going to affect these type variables, so it's time to do it by
+hand.  However we aren't ready to default them fully to () or
+whatever, because the type-class defaulting rules have yet to run.
+
+An alternate implementation would be to emit a derived constraint setting
+the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.
+
+Note [Promote _and_ default when inferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are inferring a type, we simplify the constraint, and then use
+approximateWC to produce a list of candidate constraints.  Then we MUST
+
+  a) Promote any meta-tyvars that have been floated out by
+     approximateWC, to restore invariant (WantedInv) described in
+     Note [TcLevel and untouchable type variables] in TcType.
+
+  b) Default the kind of any meta-tyvars that are not mentioned in
+     in the environment.
+
+To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we
+have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it
+should!  If we don't solve the constraint, we'll stupidly quantify over
+(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over
+(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.
+#7641 is a simpler example.
+
+Note [Promoting unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an equality out of an implication we must "promote" free
+unification variables of the equality, in order to maintain Invariant
+(WantedInv) from Note [TcLevel and untouchable type variables] in
+TcType.  for the leftover implication.
+
+This is absolutely necessary. Consider the following example. We start
+with two implications and a class with a functional dependency.
+
+    class C x y | x -> y
+    instance C [a] [a]
+
+    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]
+    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]
+
+We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.
+They may react to yield that (beta := [alpha]) which can then be pushed inwards
+the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that
+(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable
+beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
+
+    class C x y | x -> y where
+     op :: x -> y -> ()
+
+    instance C [a] [a]
+
+    type family F a :: *
+
+    h :: F Int -> ()
+    h = undefined
+
+    data TEx where
+      TEx :: a -> TEx
+
+    f (x::beta) =
+        let g1 :: forall b. b -> ()
+            g1 _ = h [x]
+            g2 z = case z of TEx y -> (h [[undefined]], op x [y])
+        in (g1 '3', g2 undefined)
+
+
+
+*********************************************************************************
+*                                                                               *
+*                          Floating equalities                                  *
+*                                                                               *
+*********************************************************************************
+
+Note [Float Equalities out of Implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For ordinary pattern matches (including existentials) we float
+equalities out of implications, for instance:
+     data T where
+       MkT :: Eq a => a -> T
+     f x y = case x of MkT _ -> (y::Int)
+We get the implication constraint (x::T) (y::alpha):
+     forall a. [untouchable=alpha] Eq a => alpha ~ Int
+We want to float out the equality into a scope where alpha is no
+longer untouchable, to solve the implication!
+
+But we cannot float equalities out of implications whose givens may
+yield or contain equalities:
+
+      data T a where
+        T1 :: T Int
+        T2 :: T Bool
+        T3 :: T a
+
+      h :: T a -> a -> Int
+
+      f x y = case x of
+                T1 -> y::Int
+                T2 -> y::Bool
+                T3 -> h x y
+
+We generate constraint, for (x::T alpha) and (y :: beta):
+   [untouchables = beta] (alpha ~ Int => beta ~ Int)   -- From 1st branch
+   [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch
+   (alpha ~ beta)                                      -- From 3rd branch
+
+If we float the equality (beta ~ Int) outside of the first implication and
+the equality (beta ~ Bool) out of the second we get an insoluble constraint.
+But if we just leave them inside the implications, we unify alpha := beta and
+solve everything.
+
+Principle:
+    We do not want to float equalities out which may
+    need the given *evidence* to become soluble.
+
+Consequence: classes with functional dependencies don't matter (since there is
+no evidence for a fundep equality), but equality superclasses do matter (since
+they carry evidence).
+-}
+
+floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool
+                -> WantedConstraints
+                -> TcS (Cts, WantedConstraints)
+-- Main idea: see Note [Float Equalities out of Implications]
+--
+-- Precondition: the wc_simple of the incoming WantedConstraints are
+--               fully zonked, so that we can see their free variables
+--
+-- Postcondition: The returned floated constraints (Cts) are only
+--                Wanted or Derived
+--
+-- Also performs some unifications (via promoteTyVar), adding to
+-- monadically-carried ty_binds. These will be used when processing
+-- floated_eqs later
+--
+-- Subtleties: Note [Float equalities from under a skolem binding]
+--             Note [Skolem escape]
+--             Note [What prevents a constraint from floating]
+floatEqualities skols given_ids ev_binds_var no_given_eqs
+                wanteds@(WC { wc_simple = simples })
+  | not no_given_eqs  -- There are some given equalities, so don't float
+  = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
+
+  | otherwise
+  = do { -- First zonk: the inert set (from whence they came) is fully
+         -- zonked, but unflattening may have filled in unification
+         -- variables, and we /must/ see them.  Otherwise we may float
+         -- constraints that mention the skolems!
+         simples <- TcS.zonkSimples simples
+       ; binds   <- TcS.getTcEvBindsMap ev_binds_var
+
+       -- Now we can pick the ones to float
+       -- The constraints are un-flattened and de-canonicalised
+       ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples
+
+             seed_skols = mkVarSet skols     `unionVarSet`
+                          mkVarSet given_ids `unionVarSet`
+                          foldrBag 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
+
+             extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols
+                 -- extended_skols contains the EvIds of all the trapped constraints
+                 -- See Note [What prevents a constraint from floating] (3)
+
+             (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols)
+                                                  candidate_eqs
+
+             remaining_simples = no_float_cts `andCts` no_flt_eqs
+
+       -- Promote any unification variables mentioned in the floated equalities
+       -- See Note [Promoting unification variables]
+       ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs)
+
+       ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols
+                                          , text "Extended skols =" <+> ppr extended_skols
+                                          , text "Simples =" <+> ppr simples
+                                          , text "Candidate eqs =" <+> ppr candidate_eqs
+                                          , text "Floated eqs =" <+> ppr flt_eqs])
+       ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }
+
+  where
+    add_one_bind :: EvBind -> VarSet -> VarSet
+    add_one_bind bind acc = extendVarSet acc (evBindVar bind)
+
+    add_non_flt_ct :: Ct -> VarSet -> VarSet
+    add_non_flt_ct ct acc | isDerivedCt ct = acc
+                          | otherwise      = extendVarSet acc (ctEvId ct)
+
+    is_floatable :: VarSet -> Ct -> Bool
+    is_floatable skols ct
+      | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols)
+      | otherwise      = not (ctEvId ct `elemVarSet` skols)
+
+    add_captured_ev_ids :: Cts -> VarSet -> VarSet
+    add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts
+       where
+         extra_skol ct acc
+           | isDerivedCt ct                           = acc
+           | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct)
+           | otherwise                                = acc
+
+    -- Identify which equalities are candidates for floating
+    -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside
+    -- See Note [Which equalities to float]
+    is_float_eq_candidate ct
+      | pred <- ctPred ct
+      , EqPred NomEq ty1 ty2 <- classifyPredType pred
+      , tcTypeKind ty1 `tcEqType` tcTypeKind ty2
+      = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of
+          (Just tv1, _) -> float_tv_eq_candidate tv1 ty2
+          (_, Just tv2) -> float_tv_eq_candidate tv2 ty1
+          _             -> False
+      | otherwise = False
+
+    float_tv_eq_candidate tv1 ty2  -- See Note [Which equalities to float]
+      =  isMetaTyVar tv1
+      && (not (isTyVarTyVar tv1) || isTyVarTy ty2)
+
+
+{- Note [Float equalities from under a skolem binding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Which of the simple equalities can we float out?  Obviously, only
+ones that don't mention the skolem-bound variables.  But that is
+over-eager. Consider
+   [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int
+The second constraint doesn't mention 'a'.  But if we float it,
+we'll promote gamma[2] to gamma'[1].  Now suppose that we learn that
+beta := Bool, and F a Bool = a, and G Bool _ = Int.  Then we'll
+we left with the constraint
+   [2] forall a. a ~ gamma'[1]
+which is insoluble because gamma became untouchable.
+
+Solution: float only constraints that stand a jolly good chance of
+being soluble simply by being floated, namely ones of form
+      a ~ ty
+where 'a' is a currently-untouchable unification variable, but may
+become touchable by being floated (perhaps by more than one level).
+
+We had a very complicated rule previously, but this is nice and
+simple.  (To see the notes, look at this Note in a version of
+TcSimplify prior to Oct 2014).
+
+Note [Which equalities to float]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Which equalities should we float?  We want to float ones where there
+is a decent chance that floating outwards will allow unification to
+happen.  In particular, float out equalities that are:
+
+* Of form (alpha ~# ty) or (ty ~# alpha), where
+   * alpha is a meta-tyvar.
+   * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar.  In that
+     case, floating out won't help either, and it may affect grouping
+     of error messages.
+
+* Homogeneous (both sides have the same kind). Why only homogeneous?
+  Because heterogeneous equalities have derived kind equalities.
+  See Note [Equalities with incompatible kinds] in TcCanonical.
+  If we float out a hetero equality, then it will spit out the same
+  derived kind equality again, which might create duplicate error
+  messages.
+
+  Instead, we do float out the kind equality (if it's worth floating
+  out, as above). If/when we solve it, we'll be able to rewrite the
+  original hetero equality to be homogeneous, and then perhaps make
+  progress / float it out. The duplicate error message was spotted in
+  typecheck/should_fail/T7368.
+
+* Nominal.  No point in floating (alpha ~R# ty), because we do not
+  unify representational equalities even if alpha is touchable.
+  See Note [Do not unify representational equalities] in TcInteract.
+
+Note [Skolem escape]
+~~~~~~~~~~~~~~~~~~~~
+You might worry about skolem escape with all this floating.
+For example, consider
+    [2] forall a. (a ~ F beta[2] delta,
+                   Maybe beta[2] ~ gamma[1])
+
+The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and
+solve with gamma := beta. But what if later delta:=Int, and
+  F b Int = b.
+Then we'd get a ~ beta[2], and solve to get beta:=a, and now the
+skolem has escaped!
+
+But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2]
+to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.
+
+Note [What prevents a constraint from floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What /prevents/ a constraint from floating?  If it mentions one of the
+"bound variables of the implication".  What are they?
+
+The "bound variables of the implication" are
+
+  1. The skolem type variables `ic_skols`
+
+  2. The "given" evidence variables `ic_given`.  Example:
+         forall a. (co :: t1 ~# t2) =>  [W] co2 : (a ~# b |> co)
+     Here 'co' is bound
+
+  3. The binders of all evidence bindings in `ic_binds`. Example
+         forall a. (d :: t1 ~ t2)
+            EvBinds { (co :: t1 ~# t2) = superclass-sel d }
+            => [W] co2 : (a ~# b |> co)
+     Here `co` is gotten by superclass selection from `d`, and the
+     wanted constraint co2 must not float.
+
+  4. And the evidence variable of any equality constraint (incl
+     Wanted ones) whose type mentions a bound variable.  Example:
+        forall k. [W] co1 :: t1 ~# t2 |> co2
+                  [W] co2 :: k ~# *
+     Here, since `k` is bound, so is `co2` and hence so is `co1`.
+
+Here (1,2,3) are handled by the "seed_skols" calculation, and
+(4) is done by the transCloVarSet call.
+
+The possible dependence on givens, and evidence bindings, is more
+subtle than we'd realised at first.  See #14584.
+
+
+*********************************************************************************
+*                                                                               *
+*                          Defaulting and disambiguation                        *
+*                                                                               *
+*********************************************************************************
+-}
+
+applyDefaultingRules :: WantedConstraints -> TcS Bool
+-- True <=> I did some defaulting, by unifying a meta-tyvar
+-- Input WantedConstraints are not necessarily zonked
+
+applyDefaultingRules wanteds
+  | isEmptyWC wanteds
+  = return False
+  | otherwise
+  = do { info@(default_tys, _) <- getDefaultInfo
+       ; wanteds               <- TcS.zonkWC wanteds
+
+       ; let groups = findDefaultableGroups info wanteds
+
+       ; traceTcS "applyDefaultingRules {" $
+                  vcat [ text "wanteds =" <+> ppr wanteds
+                       , text "groups  =" <+> ppr groups
+                       , text "info    =" <+> ppr info ]
+
+       ; something_happeneds <- mapM (disambigGroup default_tys) groups
+
+       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
+
+       ; return (or something_happeneds) }
+
+findDefaultableGroups
+    :: ( [Type]
+       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)
+    -> WantedConstraints   -- Unsolved (wanted or derived)
+    -> [(TyVar, [Ct])]
+findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
+  | null default_tys
+  = []
+  | otherwise
+  = [ (tv, map fstOf3 group)
+    | group'@((_,_,tv) :| _) <- unary_groups
+    , let group = toList group'
+    , defaultable_tyvar tv
+    , defaultable_classes (map sndOf3 group) ]
+  where
+    simples                = approximateWC True wanteds
+    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
+    unary_groups           = equivClasses cmp_tv unaries
+
+    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints
+    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints
+    non_unaries  :: [Ct]                            -- and *other* constraints
+
+        -- Finds unary type-class constraints
+        -- But take account of polykinded classes like Typeable,
+        -- which may look like (Typeable * (a:*))   (#8931)
+    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct
+    find_unary cc
+        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
+        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys
+              -- Ignore invisible arguments for this purpose
+        , Just tv <- tcGetTyVar_maybe ty
+        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and
+                          -- we definitely don't want to try to assign to those!
+        = Left (cc, cls, tv)
+    find_unary cc = Right cc  -- Non unary or non dictionary
+
+    bad_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries
+    bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries
+
+    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
+
+    defaultable_tyvar :: TcTyVar -> Bool
+    defaultable_tyvar tv
+        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]
+              b2 = not (tv `elemVarSet` bad_tvs)
+          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]
+
+    defaultable_classes :: [Class] -> Bool
+    defaultable_classes clss
+        | extended_defaults = any (isInteractiveClass ovl_strings) clss
+        | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)
+
+    -- is_std_class adds IsString to the standard numeric classes,
+    -- when -foverloaded-strings is enabled
+    is_std_class cls = isStandardClass cls ||
+                       (ovl_strings && (cls `hasKey` isStringClassKey))
+
+------------------------------
+disambigGroup :: [Type]            -- The default types
+              -> (TcTyVar, [Ct])   -- All classes of the form (C a)
+                                   --  sharing same type variable
+              -> TcS Bool   -- True <=> something happened, reflected in ty_binds
+
+disambigGroup [] _
+  = return False
+disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
+  = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])
+       ; fake_ev_binds_var <- TcS.newTcEvBinds
+       ; tclvl             <- TcS.getTcLevel
+       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group
+
+       ; if success then
+             -- Success: record the type variable binding, and return
+             do { unifyTyVar the_tv default_ty
+                ; wrapWarnTcS $ warnDefaulting wanteds default_ty
+                ; traceTcS "disambigGroup succeeded }" (ppr default_ty)
+                ; return True }
+         else
+             -- Failure: try with the next type
+             do { traceTcS "disambigGroup failed, will try other default types }"
+                           (ppr default_ty)
+                ; disambigGroup default_tys group } }
+  where
+    try_group
+      | Just subst <- mb_subst
+      = do { lcl_env <- TcS.getLclEnv
+           ; tc_lvl <- TcS.getTcLevel
+           ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env
+           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)
+                                wanteds
+           ; fmap isEmptyWC $
+             solveSimpleWanteds $ listToBag $
+             map mkNonCanonical wanted_evs }
+
+      | otherwise
+      = return False
+
+    the_ty   = mkTyVarTy the_tv
+    mb_subst = tcMatchTyKi the_ty default_ty
+      -- Make sure the kinds match too; hence this call to tcMatchTyKi
+      -- E.g. suppose the only constraint was (Typeable k (a::k))
+      -- With the addition of polykinded defaulting we also want to reject
+      -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.
+
+-- In interactive mode, or with -XExtendedDefaultRules,
+-- we default Show a to Show () to avoid graututious errors on "show []"
+isInteractiveClass :: Bool   -- -XOverloadedStrings?
+                   -> Class -> Bool
+isInteractiveClass ovl_strings cls
+    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)
+
+    -- isNumClass adds IsString to the standard numeric classes,
+    -- when -foverloaded-strings is enabled
+isNumClass :: Bool   -- -XOverloadedStrings?
+           -> Class -> Bool
+isNumClass ovl_strings cls
+  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
+
+
+{-
+Note [Avoiding spurious errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When doing the unification for defaulting, we check for skolem
+type variables, and simply don't default them.  For example:
+   f = (*)      -- Monomorphic
+   g :: Num a => a -> a
+   g x = f x x
+Here, we get a complaint when checking the type signature for g,
+that g isn't polymorphic enough; but then we get another one when
+dealing with the (Num a) context arising from f's definition;
+we try to unify a with Int (to default it), but find that it's
+already been unified with the rigid variable from g's type sig.
+
+Note [Multi-parameter defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XExtendedDefaultRules, we default only based on single-variable
+constraints, but do not exclude from defaulting any type variables which also
+appear in multi-variable constraints. This means that the following will
+default properly:
+
+   default (Integer, Double)
+
+   class A b (c :: Symbol) where
+      a :: b -> Proxy c
+
+   instance A Integer c where a _ = Proxy
+
+   main = print (a 5 :: Proxy "5")
+
+Note that if we change the above instance ("instance A Integer") to
+"instance A Double", we get an error:
+
+   No instance for (A Integer "5")
+
+This is because the first defaulted type (Integer) has successfully satisfied
+its single-parameter constraints (in this case Num).
+-}
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSplice.hs
@@ -0,0 +1,2100 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcSplice: Template Haskell splices
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module TcSplice(
+     tcSpliceExpr, tcTypedBracket, tcUntypedBracket,
+--     runQuasiQuoteExpr, runQuasiQuotePat,
+--     runQuasiQuoteDecl, runQuasiQuoteType,
+     runAnnotation,
+
+     runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
+     tcTopSpliceExpr, lookupThName_maybe,
+     defaultRunMeta, runMeta', runRemoteModFinalizers,
+     finishTH, runTopSplice
+      ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import Annotations
+import Finder
+import Name
+import TcRnMonad
+import TcType
+
+import Outputable
+import TcExpr
+import SrcLoc
+import THNames
+import TcUnify
+import TcEnv
+import Coercion( etaExpandCoAxBranch )
+import FileCleanup ( newTempName, TempFileLifetime(..) )
+
+import Control.Monad
+
+import GHCi.Message
+import GHCi.RemoteTypes
+import GHCi
+import HscMain
+        -- These imports are the reason that TcSplice
+        -- is very high up the module hierarchy
+import RnSplice( traceSplice, SpliceInfo(..))
+import RdrName
+import HscTypes
+import Convert
+import RnExpr
+import RnEnv
+import RnUtils ( HsDocContext(..) )
+import RnFixity ( lookupFixityRn_help )
+import RnTypes
+import TcHsSyn
+import TcSimplify
+import Type
+import NameSet
+import TcMType
+import TcHsType
+import TcIface
+import TyCoRep
+import FamInst
+import FamInstEnv
+import InstEnv
+import Inst
+import NameEnv
+import PrelNames
+import TysWiredIn
+import OccName
+import Hooks
+import Var
+import Module
+import LoadIface
+import Class
+import TyCon
+import CoAxiom
+import PatSyn
+import ConLike
+import DataCon
+import TcEvidence( TcEvBinds(..) )
+import Id
+import IdInfo
+import DsExpr
+import DsMonad
+import GHC.Serialized
+import ErrUtils
+import Util
+import Unique
+import VarSet
+import Data.List        ( find )
+import Data.Maybe
+import FastString
+import BasicTypes hiding( SuccessFlag(..) )
+import Maybes( MaybeErr(..) )
+import DynFlags
+import Panic
+import Lexeme
+import qualified EnumSet
+import Plugins
+import Bag
+
+import qualified Language.Haskell.TH as TH
+-- THSyntax gives access to internal functions and data types
+import qualified Language.Haskell.TH.Syntax as TH
+
+-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
+import GHC.Desugar      ( AnnotationWrapper(..) )
+
+import Control.Exception
+import Data.Binary
+import Data.Binary.Get
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Dynamic  ( fromDynamic, toDyn )
+import qualified Data.Map as Map
+import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
+import Data.Data (Data)
+import Data.Proxy    ( Proxy (..) )
+import GHC.Exts         ( unsafeCoerce# )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Main interface + stubs for the non-GHCI case
+*                                                                      *
+************************************************************************
+-}
+
+tcTypedBracket   :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
+                 -> TcM (HsExpr GhcTcId)
+tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTcId)
+        -- None of these functions add constraints to the LIE
+
+-- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
+-- runQuasiQuotePat  :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
+-- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
+-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
+
+runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
+{-
+************************************************************************
+*                                                                      *
+\subsection{Quoting an expression}
+*                                                                      *
+************************************************************************
+-}
+
+-- See Note [How brackets and nested splices are handled]
+-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
+tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
+  = addErrCtxt (quotationCtxtDoc brack) $
+    do { cur_stage <- getStage
+       ; ps_ref <- newMutVar []
+       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices
+                                       -- should get thrown into the constraint set
+                                       -- from outside the bracket
+
+       -- Typecheck expr to make sure it is valid,
+       -- Throw away the typechecked expression but return its type.
+       -- We'll typecheck it again when we splice it in somewhere
+       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
+                                tcInferRhoNC expr
+                                -- NC for no context; tcBracket does that
+       ; let rep = getRuntimeRep expr_ty
+
+       ; meta_ty <- tcTExpTy expr_ty
+       ; ps' <- readMutVar ps_ref
+       ; texpco <- tcLookupId unsafeTExpCoerceName
+       ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
+                       rn_expr
+                       (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])
+                                      (noLoc (HsTcBracketOut noExt brack ps'))))
+                       meta_ty res_ty }
+tcTypedBracket _ other_brack _
+  = pprPanic "tcTypedBracket" (ppr other_brack)
+
+-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
+tcUntypedBracket rn_expr brack ps res_ty
+  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
+       ; ps' <- mapM tcPendingSplice ps
+       ; meta_ty <- tcBrackTy brack
+       ; traceTc "tc_bracket done untyped" (ppr meta_ty)
+       ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
+                       rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }
+
+---------------
+tcBrackTy :: HsBracket GhcRn -> TcM TcType
+tcBrackTy (VarBr {})  = tcMetaTy nameTyConName
+                                           -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr {})  = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL {})   = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr {})   = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"
+
+---------------
+tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
+tcPendingSplice (PendingRnSplice flavour splice_name expr)
+  = do { res_ty <- tcMetaTy meta_ty_name
+       ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)
+       ; return (PendingTcSplice splice_name expr') }
+  where
+     meta_ty_name = case flavour of
+                       UntypedExpSplice  -> expQTyConName
+                       UntypedPatSplice  -> patQTyConName
+                       UntypedTypeSplice -> typeQTyConName
+                       UntypedDeclSplice -> decsQTyConName
+
+---------------
+-- Takes a tau and returns the type Q (TExp tau)
+tcTExpTy :: TcType -> TcM TcType
+tcTExpTy exp_ty
+  = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
+       ; q    <- tcLookupTyCon qTyConName
+       ; texp <- tcLookupTyCon tExpTyConName
+       ; let rep = getRuntimeRep exp_ty
+       ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }
+  where
+    err_msg ty
+      = vcat [ text "Illegal polytype:" <+> ppr ty
+             , text "The type of a Typed Template Haskell expression must" <+>
+               text "not have any quantification." ]
+
+quotationCtxtDoc :: HsBracket GhcRn -> SDoc
+quotationCtxtDoc br_body
+  = hang (text "In the Template Haskell quotation")
+         2 (ppr br_body)
+
+
+  -- The whole of the rest of the file is the else-branch (ie stage2 only)
+
+{-
+Note [How top-level splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level splices (those not inside a [| .. |] quotation bracket) are handled
+very straightforwardly:
+
+  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
+
+  2. runMetaT: desugar, compile, run it, and convert result back to
+     HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
+     HsExpr RdrName etc)
+
+  3. treat the result as if that's what you saw in the first place
+     e.g for HsType, rename and kind-check
+         for HsExpr, rename and type-check
+
+     (The last step is different for decls, because they can *only* be
+      top-level: we return the result of step 2.)
+
+Note [How brackets and nested splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Nested splices (those inside a [| .. |] quotation bracket),
+are treated quite differently.
+
+Remember, there are two forms of bracket
+         typed   [|| e ||]
+   and untyped   [|  e  |]
+
+The life cycle of a typed bracket:
+   * Starts as HsBracket
+
+   * When renaming:
+        * Set the ThStage to (Brack s RnPendingTyped)
+        * Rename the body
+        * Result is still a HsBracket
+
+   * When typechecking:
+        * Set the ThStage to (Brack s (TcPending ps_var lie_var))
+        * Typecheck the body, and throw away the elaborated result
+        * Nested splices (which must be typed) are typechecked, and
+          the results accumulated in ps_var; their constraints
+          accumulate in lie_var
+        * Result is a HsTcBracketOut rn_brack pending_splices
+          where rn_brack is the incoming renamed bracket
+
+The life cycle of a un-typed bracket:
+   * Starts as HsBracket
+
+   * When renaming:
+        * Set the ThStage to (Brack s (RnPendingUntyped ps_var))
+        * Rename the body
+        * Nested splices (which must be untyped) are renamed, and the
+          results accumulated in ps_var
+        * Result is still (HsRnBracketOut rn_body pending_splices)
+
+   * When typechecking a HsRnBracketOut
+        * Typecheck the pending_splices individually
+        * Ignore the body of the bracket; just check that the context
+          expects a bracket of that type (e.g. a [p| pat |] bracket should
+          be in a context needing a (Q Pat)
+        * Result is a HsTcBracketOut rn_brack pending_splices
+          where rn_brack is the incoming renamed bracket
+
+
+In both cases, desugaring happens like this:
+  * HsTcBracketOut is desugared by DsMeta.dsBracket.  It
+
+      a) Extends the ds_meta environment with the PendingSplices
+         attached to the bracket
+
+      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
+         run, will produce a suitable TH expression/type/decl.  This
+         is why we leave the *renamed* expression attached to the bracket:
+         the quoted expression should not be decorated with all the goop
+         added by the type checker
+
+  * Each splice carries a unique Name, called a "splice point", thus
+    ${n}(e).  The name is initialised to an (Unqual "splice") when the
+    splice is created; the renamer gives it a unique.
+
+  * When DsMeta (used to desugar the body of the bracket) comes across
+    a splice, it looks up the splice's Name, n, in the ds_meta envt,
+    to find an (HsExpr Id) that should be substituted for the splice;
+    it just desugars it to get a CoreExpr (DsMeta.repSplice).
+
+Example:
+    Source:       f = [| Just $(g 3) |]
+      The [| |] part is a HsBracket
+
+    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
+      The [| |] part is a HsBracketOut, containing *renamed*
+        (not typechecked) expression
+      The "s7" is the "splice point"; the (g Int 3) part
+        is a typechecked expression
+
+    Desugared:    f = do { s7 <- g Int 3
+                         ; return (ConE "Data.Maybe.Just" s7) }
+
+
+Note [Template Haskell state diagram]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here are the ThStages, s, their corresponding level numbers
+(the result of (thLevel s)), and their state transitions.
+The top level of the program is stage Comp:
+
+     Start here
+         |
+         V
+      -----------     $      ------------   $
+      |  Comp   | ---------> |  Splice  | -----|
+      |   1     |            |    0     | <----|
+      -----------            ------------
+        ^     |                ^      |
+      $ |     | [||]         $ |      | [||]
+        |     v                |      v
+   --------------          ----------------
+   | Brack Comp |          | Brack Splice |
+   |     2      |          |      1       |
+   --------------          ----------------
+
+* Normal top-level declarations start in state Comp
+       (which has level 1).
+  Annotations start in state Splice, since they are
+       treated very like a splice (only without a '$')
+
+* Code compiled in state Splice (and only such code)
+  will be *run at compile time*, with the result replacing
+  the splice
+
+* The original paper used level -1 instead of 0, etc.
+
+* The original paper did not allow a splice within a
+  splice, but there is no reason not to. This is the
+  $ transition in the top right.
+
+Note [Template Haskell levels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Imported things are impLevel (= 0)
+
+* However things at level 0 are not *necessarily* imported.
+      eg  $( \b -> ... )   here b is bound at level 0
+
+* In GHCi, variables bound by a previous command are treated
+  as impLevel, because we have bytecode for them.
+
+* Variables are bound at the "current level"
+
+* The current level starts off at outerLevel (= 1)
+
+* The level is decremented by splicing $(..)
+               incremented by brackets [| |]
+               incremented by name-quoting 'f
+
+When a variable is used, we compare
+        bind:  binding level, and
+        use:   current level at usage site
+
+  Generally
+        bind > use      Always error (bound later than used)
+                        [| \x -> $(f x) |]
+
+        bind = use      Always OK (bound same stage as used)
+                        [| \x -> $(f [| x |]) |]
+
+        bind < use      Inside brackets, it depends
+                        Inside splice, OK
+                        Inside neither, OK
+
+  For (bind < use) inside brackets, there are three cases:
+    - Imported things   OK      f = [| map |]
+    - Top-level things  OK      g = [| f |]
+    - Non-top-level     Only if there is a liftable instance
+                                h = \(x:Int) -> [| x |]
+
+  To track top-level-ness we use the ThBindEnv in TcLclEnv
+
+  For example:
+           f = ...
+           g1 = $(map ...)         is OK
+           g2 = $(f ...)           is not OK; because we havn't compiled f yet
+
+-}
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Splicing an expression}
+*                                                                      *
+************************************************************************
+-}
+
+tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty
+  = addErrCtxt (spliceCtxtDoc splice) $
+    setSrcSpan (getLoc expr)    $ do
+    { stage <- getStage
+    ; case stage of
+          Splice {}            -> tcTopSplice expr res_ty
+          Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
+          RunSplice _          ->
+            -- See Note [RunSplice ThLevel] in "TcRnTypes".
+            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
+                      "running another splice") (ppr splice)
+          Comp                 -> tcTopSplice expr res_ty
+    }
+tcSpliceExpr splice _
+  = pprPanic "tcSpliceExpr" (ppr splice)
+
+{- Note [Collecting modFinalizers in typed splices]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
+environment (see Note [Delaying modFinalizers in untyped splices] in
+"RnSplice"). Thus after executing the splice, we move the finalizers to the
+finalizer list in the global environment and set them to use the current local
+environment (with 'addModFinalizersWithLclEnv').
+
+-}
+
+tcNestedSplice :: ThStage -> PendingStuff -> Name
+                -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+    -- See Note [How brackets and nested splices are handled]
+    -- A splice inside brackets
+tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
+  = do { res_ty <- expTypeToType res_ty
+       ; let rep = getRuntimeRep res_ty
+       ; meta_exp_ty <- tcTExpTy res_ty
+       ; expr' <- setStage pop_stage $
+                  setConstraintVar lie_var $
+                  tcMonoExpr expr (mkCheckExpType meta_exp_ty)
+       ; untypeq <- tcLookupId unTypeQName
+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'
+       ; ps <- readMutVar ps_var
+       ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
+
+       -- The returned expression is ignored; it's in the pending splices
+       ; return (panic "tcSpliceExpr") }
+
+tcNestedSplice _ _ splice_name _ _
+  = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
+
+tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcTopSplice expr res_ty
+  = do { -- Typecheck the expression,
+         -- making sure it has type Q (T res_ty)
+         res_ty <- expTypeToType res_ty
+       ; meta_exp_ty <- tcTExpTy res_ty
+       ; q_expr <- tcTopSpliceExpr Typed $
+                          tcMonoExpr expr (mkCheckExpType meta_exp_ty)
+       ; lcl_env <- getLclEnv
+       ; let delayed_splice
+              = DelayedSplice lcl_env expr res_ty q_expr
+       ; return (HsSpliceE noExt (HsSplicedT delayed_splice))
+
+       }
+
+
+-- This is called in the zonker
+-- See Note [Running typed splices in the zonker]
+runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
+runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
+  = setLclEnv lcl_env $ do {
+         zonked_ty <- zonkTcType res_ty
+       ; zonked_q_expr <- zonkTopLExpr q_expr
+        -- See Note [Collecting modFinalizers in typed splices].
+       ; modfinalizers_ref <- newTcRef []
+         -- Run the expression
+       ; expr2 <- setStage (RunSplice modfinalizers_ref) $
+                    runMetaE zonked_q_expr
+       ; mod_finalizers <- readTcRef modfinalizers_ref
+       ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
+       -- We use orig_expr here and not q_expr when tracing as a call to
+       -- unsafeTExpCoerce is added to the original expression by the
+       -- typechecker when typed quotes are type checked.
+       ; traceSplice (SpliceInfo { spliceDescription = "expression"
+                                 , spliceIsDecl      = False
+                                 , spliceSource      = Just orig_expr
+                                 , spliceGenerated   = ppr expr2 })
+        -- Rename and typecheck the spliced-in expression,
+        -- making sure it has type res_ty
+        -- These steps should never fail; this is a *typed* splice
+       ; (res, wcs) <-
+            captureConstraints $
+              addErrCtxt (spliceResultDoc zonked_q_expr) $ do
+                { (exp3, _fvs) <- rnLExpr expr2
+                ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)}
+       ; ev <- simplifyTop wcs
+       ; return $ unLoc (mkHsDictLet (EvBinds ev) res)
+       }
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+spliceCtxtDoc :: HsSplice GhcRn -> SDoc
+spliceCtxtDoc splice
+  = hang (text "In the Template Haskell splice")
+         2 (pprSplice splice)
+
+spliceResultDoc :: LHsExpr GhcTc -> SDoc
+spliceResultDoc expr
+  = sep [ text "In the result of the splice:"
+        , nest 2 (char '$' <> ppr expr)
+        , text "To see what the splice expanded to, use -ddump-splices"]
+
+-------------------
+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
+-- Note [How top-level splices are handled]
+-- Type check an expression that is the body of a top-level splice
+--   (the caller will compile and run it)
+-- Note that set the level to Splice, regardless of the original level,
+-- before typechecking the expression.  For example:
+--      f x = $( ...$(g 3) ... )
+-- The recursive call to tcPolyExpr will simply expand the
+-- inner escape before dealing with the outer one
+
+tcTopSpliceExpr isTypedSplice tc_action
+  = checkNoErrs $  -- checkNoErrs: must not try to run the thing
+                   -- if the type checker fails!
+    unsetGOptM Opt_DeferTypeErrors $
+                   -- Don't defer type errors.  Not only are we
+                   -- going to run this code, but we do an unsafe
+                   -- coerce, so we get a seg-fault if, say we
+                   -- splice a type into a place where an expression
+                   -- is expected (#7276)
+    setStage (Splice isTypedSplice) $
+    do {    -- Typecheck the expression
+         (expr', wanted) <- captureConstraints tc_action
+       ; const_binds     <- simplifyTop wanted
+
+          -- Zonk it and tie the knot of dictionary bindings
+       ; return $ mkHsDictLet (EvBinds const_binds) expr' }
+
+{-
+************************************************************************
+*                                                                      *
+        Annotations
+*                                                                      *
+************************************************************************
+-}
+
+runAnnotation target expr = do
+    -- Find the classes we want instances for in order to call toAnnotationWrapper
+    loc <- getSrcSpanM
+    data_class <- tcLookupClass dataClassName
+    to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
+
+    -- Check the instances we require live in another module (we want to execute it..)
+    -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
+    -- also resolves the LIE constraints to detect e.g. instance ambiguity
+    zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (
+           do { (expr', expr_ty) <- tcInferRhoNC expr
+                -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
+                -- By instantiating the call >here< it gets registered in the
+                -- LIE consulted by tcTopSpliceExpr
+                -- and hence ensures the appropriate dictionary is bound by const_binds
+              ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
+              ; let specialised_to_annotation_wrapper_expr
+                      = L loc (mkHsWrap wrapper
+                                 (HsVar noExt (L loc to_annotation_wrapper_id)))
+              ; return (L loc (HsApp noExt
+                                specialised_to_annotation_wrapper_expr expr'))
+                                })
+
+    -- Run the appropriately wrapped expression to get the value of
+    -- the annotation and its dictionaries. The return value is of
+    -- type AnnotationWrapper by construction, so this conversion is
+    -- safe
+    serialized <- runMetaAW zonked_wrapped_expr'
+    return Annotation {
+               ann_target = target,
+               ann_value = serialized
+           }
+
+convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
+convertAnnotationWrapper fhv = do
+  dflags <- getDynFlags
+  if gopt Opt_ExternalInterpreter dflags
+    then do
+      Right <$> runTH THAnnWrapper fhv
+    else do
+      annotation_wrapper <- liftIO $ wormhole dflags fhv
+      return $ Right $
+        case unsafeCoerce# annotation_wrapper of
+           AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
+               -- Got the value and dictionaries: build the serialized value and
+               -- call it a day. We ensure that we seq the entire serialized value
+               -- in order that any errors in the user-written code for the
+               -- annotation are exposed at this point.  This is also why we are
+               -- doing all this stuff inside the context of runMeta: it has the
+               -- facilities to deal with user error in a meta-level expression
+               seqSerialized serialized `seq` serialized
+
+-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
+seqSerialized :: Serialized -> ()
+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Running an expression}
+*                                                                      *
+************************************************************************
+-}
+
+runQuasi :: TH.Q a -> TcM a
+runQuasi act = TH.runQ act
+
+runRemoteModFinalizers :: ThModFinalizers -> TcM ()
+runRemoteModFinalizers (ThModFinalizers finRefs) = do
+  dflags <- getDynFlags
+  let withForeignRefs [] f = f []
+      withForeignRefs (x : xs) f = withForeignRef x $ \r ->
+        withForeignRefs xs $ \rs -> f (r : rs)
+  if gopt Opt_ExternalInterpreter dflags then do
+    hsc_env <- env_top <$> getEnv
+    withIServ hsc_env $ \i -> do
+      tcg <- getGblEnv
+      th_state <- readTcRef (tcg_th_remote_state tcg)
+      case th_state of
+        Nothing -> return () -- TH was not started, nothing to do
+        Just fhv -> do
+          liftIO $ withForeignRef fhv $ \st ->
+            withForeignRefs finRefs $ \qrefs ->
+              writeIServ i (putMessage (RunModFinalizers st qrefs))
+          () <- runRemoteTH i []
+          readQResult i
+  else do
+    qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
+    runQuasi $ sequence_ qs
+
+runQResult
+  :: (a -> String)
+  -> (SrcSpan -> a -> b)
+  -> (ForeignHValue -> TcM a)
+  -> SrcSpan
+  -> ForeignHValue {- TH.Q a -}
+  -> TcM b
+runQResult show_th f runQ expr_span hval
+  = do { th_result <- runQ hval
+       ; traceTc "Got TH result:" (text (show_th th_result))
+       ; return (f expr_span th_result) }
+
+
+-----------------
+runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
+        -> LHsExpr GhcTc
+        -> TcM hs_syn
+runMeta unwrap e
+  = do { h <- getHooked runMetaHook defaultRunMeta
+       ; unwrap h e }
+
+defaultRunMeta :: MetaHook TcM
+defaultRunMeta (MetaE r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
+defaultRunMeta (MetaP r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
+defaultRunMeta (MetaT r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
+defaultRunMeta (MetaD r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
+defaultRunMeta (MetaAW r)
+  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
+    -- We turn off showing the code in meta-level exceptions because doing so exposes
+    -- the toAnnotationWrapper function that we slap around the user's code
+
+----------------
+runMetaAW :: LHsExpr GhcTc         -- Of type AnnotationWrapper
+          -> TcM Serialized
+runMetaAW = runMeta metaRequestAW
+
+runMetaE :: LHsExpr GhcTc          -- Of type (Q Exp)
+         -> TcM (LHsExpr GhcPs)
+runMetaE = runMeta metaRequestE
+
+runMetaP :: LHsExpr GhcTc          -- Of type (Q Pat)
+         -> TcM (LPat GhcPs)
+runMetaP = runMeta metaRequestP
+
+runMetaT :: LHsExpr GhcTc          -- Of type (Q Type)
+         -> TcM (LHsType GhcPs)
+runMetaT = runMeta metaRequestT
+
+runMetaD :: LHsExpr GhcTc          -- Of type Q [Dec]
+         -> TcM [LHsDecl GhcPs]
+runMetaD = runMeta metaRequestD
+
+---------------
+runMeta' :: Bool                 -- Whether code should be printed in the exception message
+         -> (hs_syn -> SDoc)                                    -- how to print the code
+         -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn))        -- How to run x
+         -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or
+                                 --    something like that
+         -> TcM hs_syn           -- Of type t
+runMeta' show_code ppr_hs run_and_convert expr
+  = do  { traceTc "About to run" (ppr expr)
+        ; recordThSpliceUse -- seems to be the best place to do this,
+                            -- we catch all kinds of splices and annotations.
+
+        -- Check that we've had no errors of any sort so far.
+        -- For example, if we found an error in an earlier defn f, but
+        -- recovered giving it type f :: forall a.a, it'd be very dodgy
+        -- to carry ont.  Mind you, the staging restrictions mean we won't
+        -- actually run f, but it still seems wrong. And, more concretely,
+        -- see #5358 for an example that fell over when trying to
+        -- reify a function with a "?" kind in it.  (These don't occur
+        -- in type-correct programs.
+        ; failIfErrsM
+
+        -- run plugins
+        ; hsc_env <- getTopEnv
+        ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
+
+        -- Desugar
+        ; ds_expr <- initDsTc (dsLExpr expr')
+        -- Compile and link it; might fail if linking fails
+        ; src_span <- getSrcSpanM
+        ; traceTc "About to run (desugared)" (ppr ds_expr)
+        ; either_hval <- tryM $ liftIO $
+                         HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
+        ; case either_hval of {
+            Left exn   -> fail_with_exn "compile and link" exn ;
+            Right hval -> do
+
+        {       -- Coerce it to Q t, and run it
+
+                -- Running might fail if it throws an exception of any kind (hence tryAllM)
+                -- including, say, a pattern-match exception in the code we are running
+                --
+                -- We also do the TH -> HS syntax conversion inside the same
+                -- exception-cacthing thing so that if there are any lurking
+                -- exceptions in the data structure returned by hval, we'll
+                -- encounter them inside the try
+                --
+                -- See Note [Exceptions in TH]
+          let expr_span = getLoc expr
+        ; either_tval <- tryAllM $
+                         setSrcSpan expr_span $ -- Set the span so that qLocation can
+                                                -- see where this splice is
+             do { mb_result <- run_and_convert expr_span hval
+                ; case mb_result of
+                    Left err     -> failWithTc err
+                    Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
+                                       ; return $! result } }
+
+        ; case either_tval of
+            Right v -> return v
+            Left se -> case fromException se of
+                         Just IOEnvFailure -> failM -- Error already in Tc monad
+                         _ -> fail_with_exn "run" se -- Exception
+        }}}
+  where
+    -- see Note [Concealed TH exceptions]
+    fail_with_exn :: Exception e => String -> e -> TcM a
+    fail_with_exn phase exn = do
+        exn_msg <- liftIO $ Panic.safeShowException exn
+        let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
+                        nest 2 (text exn_msg),
+                        if show_code then text "Code:" <+> ppr expr else empty]
+        failWithTc msg
+
+{-
+Note [Running typed splices in the zonker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+See #15471 for the full discussion.
+
+For many years typed splices were run immediately after they were type checked
+however, this is too early as it means to zonk some type variables before
+they can be unified with type variables in the surrounding context.
+
+For example,
+
+```
+module A where
+
+test_foo :: forall a . Q (TExp (a -> a))
+test_foo = [|| id ||]
+
+module B where
+
+import A
+
+qux = $$(test_foo)
+```
+
+We would expect `qux` to have inferred type `forall a . a -> a` but if
+we run the splices too early the unified variables are zonked to `Any`. The
+inferred type is the unusable `Any -> Any`.
+
+To run the splice, we must compile `test_foo` all the way to byte code.
+But at the moment when the type checker is looking at the splice, test_foo
+has type `Q (TExp (alpha -> alpha))` and we
+certainly can't compile code involving unification variables!
+
+We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`
+which definitely is not what we want.  Moreover, if we had
+  qux = [$$(test_foo), (\x -> x +1::Int)]
+then `alpha` would have to be `Int`.
+
+Conclusion: we must defer taking decisions about `alpha` until the
+typechecker is done; and *then* we can run the splice.  It's fine to do it
+later, because we know it'll produce type-correct code.
+
+Deferring running the splice until later, in the zonker, means that the
+unification variables propagate upwards from the splice into the surrounding
+context and are unified correctly.
+
+This is implemented by storing the arguments we need for running the splice
+in a `DelayedSplice`. In the zonker, the arguments are passed to
+`TcSplice.runTopSplice` and the expression inserted into the AST as normal.
+
+
+
+Note [Exceptions in TH]
+~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have something like this
+        $( f 4 )
+where
+        f :: Int -> Q [Dec]
+        f n | n>3       = fail "Too many declarations"
+            | otherwise = ...
+
+The 'fail' is a user-generated failure, and should be displayed as a
+perfectly ordinary compiler error message, not a panic or anything
+like that.  Here's how it's processed:
+
+  * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
+    effectively transforms (fail s) to
+        qReport True s >> fail
+    where 'qReport' comes from the Quasi class and fail from its monad
+    superclass.
+
+  * The TcM monad is an instance of Quasi (see TcSplice), and it implements
+    (qReport True s) by using addErr to add an error message to the bag of errors.
+    The 'fail' in TcM raises an IOEnvFailure exception
+
+ * 'qReport' forces the message to ensure any exception hidden in unevaluated
+   thunk doesn't get into the bag of errors. Otherwise the following splice
+   will triger panic (#8987):
+        $(fail undefined)
+   See also Note [Concealed TH exceptions]
+
+  * So, when running a splice, we catch all exceptions; then for
+        - an IOEnvFailure exception, we assume the error is already
+                in the error-bag (above)
+        - other errors, we add an error to the bag
+    and then fail
+
+Note [Concealed TH exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When displaying the error message contained in an exception originated from TH
+code, we need to make sure that the error message itself does not contain an
+exception.  For example, when executing the following splice:
+
+    $( error ("foo " ++ error "bar") )
+
+the message for the outer exception is a thunk which will throw the inner
+exception when evaluated.
+
+For this reason, we display the message of a TH exception using the
+'safeShowException' function, which recursively catches any exception thrown
+when showing an error message.
+
+
+To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
+-}
+
+instance TH.Quasi TcM where
+  qNewName s = do { u <- newUnique
+                  ; let i = toInteger (getKey u)
+                  ; return (TH.mkNameU s i) }
+
+  -- 'msg' is forced to ensure exceptions don't escape,
+  -- see Note [Exceptions in TH]
+  qReport True msg  = seqList msg $ addErr  (text msg)
+  qReport False msg = seqList msg $ addWarn NoReason (text msg)
+
+  qLocation = do { m <- getModule
+                 ; l <- getSrcSpanM
+                 ; r <- case l of
+                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+                                                    (ppr l)
+                        RealSrcSpan s -> return s
+                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+                                  , TH.loc_module   = moduleNameString (moduleName m)
+                                  , TH.loc_package  = unitIdString (moduleUnitId m)
+                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
+
+  qLookupName       = lookupName
+  qReify            = reify
+  qReifyFixity nm   = lookupThName nm >>= reifyFixity
+  qReifyInstances   = reifyInstances
+  qReifyRoles       = reifyRoles
+  qReifyAnnotations = reifyAnnotations
+  qReifyModule      = reifyModule
+  qReifyConStrictness nm = do { nm' <- lookupThName nm
+                              ; dc  <- tcLookupDataCon nm'
+                              ; let bangs = dataConImplBangs dc
+                              ; return (map reifyDecidedStrictness bangs) }
+
+        -- For qRecover, discard error messages if
+        -- the recovery action is chosen.  Otherwise
+        -- we'll only fail higher up.
+  qRecover recover main = tryTcDiscardingErrs recover main
+
+  qAddDependentFile fp = do
+    ref <- fmap tcg_dependent_files getGblEnv
+    dep_files <- readTcRef ref
+    writeTcRef ref (fp:dep_files)
+
+  qAddTempFile suffix = do
+    dflags <- getDynFlags
+    liftIO $ newTempName dflags TFL_GhcSession suffix
+
+  qAddTopDecls thds = do
+      l <- getSrcSpanM
+      let either_hval = convertToHsDecls l thds
+      ds <- case either_hval of
+              Left exn -> failWithTc $
+                hang (text "Error in a declaration passed to addTopDecls:")
+                   2 exn
+              Right ds -> return ds
+      mapM_ (checkTopDecl . unLoc) ds
+      th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
+      updTcRef th_topdecls_var (\topds -> ds ++ topds)
+    where
+      checkTopDecl :: HsDecl GhcPs -> TcM ()
+      checkTopDecl (ValD _ binds)
+        = mapM_ bindName (collectHsBindBinders binds)
+      checkTopDecl (SigD _ _)
+        = return ()
+      checkTopDecl (AnnD _ _)
+        = return ()
+      checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
+        = bindName name
+      checkTopDecl _
+        = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
+
+      bindName :: RdrName -> TcM ()
+      bindName (Exact n)
+        = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+             ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
+             }
+
+      bindName name =
+          addErr $
+          hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
+             2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
+
+  qAddForeignFilePath lang fp = do
+    var <- fmap tcg_th_foreign_files getGblEnv
+    updTcRef var ((lang, fp) :)
+
+  qAddModFinalizer fin = do
+      r <- liftIO $ mkRemoteRef fin
+      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+      addModFinalizerRef fref
+
+  qAddCorePlugin plugin = do
+      hsc_env <- env_top <$> getEnv
+      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
+      let err = hang
+            (text "addCorePlugin: invalid plugin module "
+               <+> text (show plugin)
+            )
+            2
+            (text "Plugins in the current package can't be specified.")
+      case r of
+        Found {} -> addErr err
+        FoundMultiple {} -> addErr err
+        _ -> return ()
+      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+      updTcRef th_coreplugins_var (plugin:)
+
+  qGetQ :: forall a. Typeable a => TcM (Maybe a)
+  qGetQ = do
+      th_state_var <- fmap tcg_th_state getGblEnv
+      th_state <- readTcRef th_state_var
+      -- See #10596 for why we use a scoped type variable here.
+      return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+
+  qPutQ x = do
+      th_state_var <- fmap tcg_th_state getGblEnv
+      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+
+  qIsExtEnabled = xoptM
+
+  qExtsEnabled =
+    EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+
+-- | Adds a mod finalizer reference to the local environment.
+addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
+addModFinalizerRef finRef = do
+    th_stage <- getStage
+    case th_stage of
+      RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
+      -- This case happens only if a splice is executed and the caller does
+      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
+      -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+      _ ->
+        pprPanic "addModFinalizer was called when no finalizers were collected"
+                 (ppr th_stage)
+
+-- | Releases the external interpreter state.
+finishTH :: TcM ()
+finishTH = do
+  dflags <- getDynFlags
+  when (gopt Opt_ExternalInterpreter dflags) $ do
+    tcg <- getGblEnv
+    writeTcRef (tcg_th_remote_state tcg) Nothing
+
+runTHExp :: ForeignHValue -> TcM TH.Exp
+runTHExp = runTH THExp
+
+runTHPat :: ForeignHValue -> TcM TH.Pat
+runTHPat = runTH THPat
+
+runTHType :: ForeignHValue -> TcM TH.Type
+runTHType = runTH THType
+
+runTHDec :: ForeignHValue -> TcM [TH.Dec]
+runTHDec = runTH THDec
+
+runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
+runTH ty fhv = do
+  hsc_env <- env_top <$> getEnv
+  dflags <- getDynFlags
+  if not (gopt Opt_ExternalInterpreter dflags)
+    then do
+       -- Run it in the local TcM
+      hv <- liftIO $ wormhole dflags fhv
+      r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
+      return r
+    else
+      -- Run it on the server.  For an overview of how TH works with
+      -- Remote GHCi, see Note [Remote Template Haskell] in
+      -- libraries/ghci/GHCi/TH.hs.
+      withIServ hsc_env $ \i -> do
+        rstate <- getTHState i
+        loc <- TH.qLocation
+        liftIO $
+          withForeignRef rstate $ \state_hv ->
+          withForeignRef fhv $ \q_hv ->
+            writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
+        runRemoteTH i []
+        bs <- readQResult i
+        return $! runGet get (LB.fromStrict bs)
+
+
+-- | communicate with a remotely-running TH computation until it finishes.
+-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
+runRemoteTH
+  :: IServ
+  -> [Messages]   --  saved from nested calls to qRecover
+  -> TcM ()
+runRemoteTH iserv recovers = do
+  THMsg msg <- liftIO $ readIServ iserv getTHMessage
+  case msg of
+    RunTHDone -> return ()
+    StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
+      v <- getErrsVar
+      msgs <- readTcRef v
+      writeTcRef v emptyMessages
+      runRemoteTH iserv (msgs : recovers)
+    EndRecover caught_error -> do
+      let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of
+             [] -> panic "EndRecover"
+             a : b -> (a,b)
+      v <- getErrsVar
+      (warn_msgs,_) <- readTcRef v
+      -- keep the warnings only if there were no errors
+      writeTcRef v $ if caught_error
+        then prev_msgs
+        else (prev_warns `unionBags` warn_msgs, prev_errs)
+      runRemoteTH iserv rest
+    _other -> do
+      r <- handleTHMessage msg
+      liftIO $ writeIServ iserv (put r)
+      runRemoteTH iserv recovers
+
+-- | Read a value of type QResult from the iserv
+readQResult :: Binary a => IServ -> TcM a
+readQResult i = do
+  qr <- liftIO $ readIServ i get
+  case qr of
+    QDone a -> return a
+    QException str -> liftIO $ throwIO (ErrorCall str)
+    QFail str -> fail str
+
+{- Note [TH recover with -fexternal-interpreter]
+
+Recover is slightly tricky to implement.
+
+The meaning of "recover a b" is
+ - Do a
+   - If it finished with no errors, then keep the warnings it generated
+   - If it failed, discard any messages it generated, and do b
+
+Note that "failed" here can mean either
+  (1) threw an exception (failTc)
+  (2) generated an error message (addErrTcM)
+
+The messages are managed by GHC in the TcM monad, whereas the
+exception-handling is done in the ghc-iserv process, so we have to
+coordinate between the two.
+
+On the server:
+  - emit a StartRecover message
+  - run "a; FailIfErrs" inside a try
+  - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed
+  - if "a; FailIfErrs" failed, run "b"
+
+Back in GHC, when we receive:
+
+  FailIfErrrs
+    failTc if there are any error messages (= failIfErrsM)
+  StartRecover
+    save the current messages and start with an empty set.
+  EndRecover caught_error
+    Restore the previous messages,
+    and merge in the new messages if caught_error is false.
+-}
+
+-- | Retrieve (or create, if it hasn't been created already), the
+-- remote TH state.  The TH state is a remote reference to an IORef
+-- QState living on the server, and we have to pass this to each RunTH
+-- call we make.
+--
+-- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
+--
+getTHState :: IServ -> TcM (ForeignRef (IORef QState))
+getTHState i = do
+  tcg <- getGblEnv
+  th_state <- readTcRef (tcg_th_remote_state tcg)
+  case th_state of
+    Just rhv -> return rhv
+    Nothing -> do
+      hsc_env <- env_top <$> getEnv
+      fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
+      writeTcRef (tcg_th_remote_state tcg) (Just fhv)
+      return fhv
+
+wrapTHResult :: TcM a -> TcM (THResult a)
+wrapTHResult tcm = do
+  e <- tryM tcm   -- only catch 'fail', treat everything else as catastrophic
+  case e of
+    Left e -> return (THException (show e))
+    Right a -> return (THComplete a)
+
+handleTHMessage :: THMessage a -> TcM a
+handleTHMessage msg = case msg of
+  NewName a -> wrapTHResult $ TH.qNewName a
+  Report b str -> wrapTHResult $ TH.qReport b str
+  LookupName b str -> wrapTHResult $ TH.qLookupName b str
+  Reify n -> wrapTHResult $ TH.qReify n
+  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
+  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
+  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+  ReifyAnnotations lookup tyrep ->
+    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
+  ReifyModule m -> wrapTHResult $ TH.qReifyModule m
+  ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
+  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
+  AddModFinalizer r -> do
+    hsc_env <- env_top <$> getEnv
+    wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
+  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
+  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
+  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
+  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
+  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
+  FailIfErrs -> wrapTHResult failIfErrsM
+  _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
+
+getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
+getAnnotationsByTypeRep th_name tyrep
+  = do { name <- lookupThAnnLookup th_name
+       ; topEnv <- getTopEnv
+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
+       ; tcg <- getGblEnv
+       ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
+       ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
+
+{-
+************************************************************************
+*                                                                      *
+            Instance Testing
+*                                                                      *
+************************************************************************
+-}
+
+reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
+reifyInstances th_nm th_tys
+   = addErrCtxt (text "In the argument of reifyInstances:"
+                 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
+     do { loc <- getSrcSpanM
+        ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
+          -- #9262 says to bring vars into scope, like in HsForAllTy case
+          -- of rnHsTyKi
+        ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty
+          -- Rename  to HsType Name
+        ; ((tv_names, rn_ty), _fvs)
+            <- checkNoErrs $ -- If there are out-of-scope Names here, then we
+                             -- must error before proceeding to typecheck the
+                             -- renamed type, as that will result in GHC
+                             -- internal errors (#13837).
+               bindLRdrNames tv_rdrs $ \ tv_names ->
+               do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
+                  ; return ((tv_names, rn_ty), fvs) }
+        ; (_tvs, ty)
+            <- pushTcLevelM_   $
+               solveEqualities $ -- Avoid error cascade if there are unsolved
+               bindImplicitTKBndrs_Skol tv_names $
+               fst <$> tcLHsType rn_ty
+        ; ty <- zonkTcTypeToType ty
+                -- Substitute out the meta type variables
+                -- In particular, the type might have kind
+                -- variables inside it (#7477)
+
+        ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))
+        ; case splitTyConApp_maybe ty of   -- This expands any type synonyms
+            Just (tc, tys)                 -- See #7910
+               | Just cls <- tyConClass_maybe tc
+               -> do { inst_envs <- tcGetInstEnvs
+                     ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
+                     ; traceTc "reifyInstances1" (ppr matches)
+                     ; reifyClassInstances cls (map fst matches ++ unifies) }
+               | isOpenFamilyTyCon tc
+               -> do { inst_envs <- tcGetFamInstEnvs
+                     ; let matches = lookupFamInstEnv inst_envs tc tys
+                     ; traceTc "reifyInstances2" (ppr matches)
+                     ; reifyFamilyInstances tc (map fim_instance matches) }
+            _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
+                               2 (text "is not a class constraint or type family application")) }
+  where
+    doc = ClassInstanceCtx
+    bale_out msg = failWithTc msg
+
+    cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
+    cvt loc th_ty = case convertToHsType loc th_ty of
+                      Left msg -> failWithTc msg
+                      Right ty -> return ty
+
+{-
+************************************************************************
+*                                                                      *
+                        Reification
+*                                                                      *
+************************************************************************
+-}
+
+lookupName :: Bool      -- True  <=> type namespace
+                        -- False <=> value namespace
+           -> String -> TcM (Maybe TH.Name)
+lookupName is_type_name s
+  = do { lcl_env <- getLocalRdrEnv
+       ; case lookupLocalRdrEnv lcl_env rdr_name of
+           Just n  -> return (Just (reifyName n))
+           Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
+                         ; return (fmap reifyName mb_nm) } }
+  where
+    th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M'
+
+    occ_fs :: FastString
+    occ_fs = mkFastString (TH.nameBase th_name)
+
+    occ :: OccName
+    occ | is_type_name
+        = if isLexVarSym occ_fs || isLexCon occ_fs
+                             then mkTcOccFS    occ_fs
+                             else mkTyVarOccFS occ_fs
+        | otherwise
+        = if isLexCon occ_fs then mkDataOccFS occ_fs
+                             else mkVarOccFS  occ_fs
+
+    rdr_name = case TH.nameModule th_name of
+                 Nothing  -> mkRdrUnqual occ
+                 Just mod -> mkRdrQual (mkModuleName mod) occ
+
+getThing :: TH.Name -> TcM TcTyThing
+getThing th_name
+  = do  { name <- lookupThName th_name
+        ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
+        ; tcLookupTh name }
+        -- ToDo: this tcLookup could fail, which would give a
+        --       rather unhelpful error message
+  where
+    ppr_ns (TH.Name _ (TH.NameG TH.DataName  _pkg _mod)) = text "data"
+    ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
+    ppr_ns (TH.Name _ (TH.NameG TH.VarName   _pkg _mod)) = text "var"
+    ppr_ns _ = panic "reify/ppr_ns"
+
+reify :: TH.Name -> TcM TH.Info
+reify th_name
+  = do  { traceTc "reify 1" (text (TH.showName th_name))
+        ; thing <- getThing th_name
+        ; traceTc "reify 2" (ppr thing)
+        ; reifyThing thing }
+
+lookupThName :: TH.Name -> TcM Name
+lookupThName th_name = do
+    mb_name <- lookupThName_maybe th_name
+    case mb_name of
+        Nothing   -> failWithTc (notInScope th_name)
+        Just name -> return name
+
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+lookupThName_maybe th_name
+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+          -- Pick the first that works
+          -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
+        ; return (listToMaybe names) }
+  where
+    lookup rdr_name
+        = do {  -- Repeat much of lookupOccRn, because we want
+                -- to report errors in a TH-relevant way
+             ; rdr_env <- getLocalRdrEnv
+             ; case lookupLocalRdrEnv rdr_env rdr_name of
+                 Just name -> return (Just name)
+                 Nothing   -> lookupGlobalOccRn_maybe rdr_name }
+
+tcLookupTh :: Name -> TcM TcTyThing
+-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
+-- it gives a reify-related error message on failure, whereas in the normal
+-- tcLookup, failure is a bug.
+tcLookupTh name
+  = do  { (gbl_env, lcl_env) <- getEnvs
+        ; case lookupNameEnv (tcl_env lcl_env) name of {
+                Just thing -> return thing;
+                Nothing    ->
+
+          case lookupNameEnv (tcg_type_env gbl_env) name of {
+                Just thing -> return (AGlobal thing);
+                Nothing    ->
+
+          -- EZY: I don't think this choice matters, no TH in signatures!
+          if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
+          then  -- It's defined in this module
+                failWithTc (notInEnv name)
+
+          else
+     do { mb_thing <- tcLookupImported_maybe name
+        ; case mb_thing of
+            Succeeded thing -> return (AGlobal thing)
+            Failed msg      -> failWithTc msg
+    }}}}
+
+notInScope :: TH.Name -> SDoc
+notInScope th_name = quotes (text (TH.pprint th_name)) <+>
+                     text "is not in scope at a reify"
+        -- Ugh! Rather an indirect way to display the name
+
+notInEnv :: Name -> SDoc
+notInEnv name = quotes (ppr name) <+>
+                     text "is not in the type environment at a reify"
+
+------------------------------
+reifyRoles :: TH.Name -> TcM [TH.Role]
+reifyRoles th_name
+  = do { thing <- getThing th_name
+       ; case thing of
+           AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
+           _ -> failWithTc (text "No roles associated with" <+> (ppr thing))
+       }
+  where
+    reify_role Nominal          = TH.NominalR
+    reify_role Representational = TH.RepresentationalR
+    reify_role Phantom          = TH.PhantomR
+
+------------------------------
+reifyThing :: TcTyThing -> TcM TH.Info
+-- The only reason this is monadic is for error reporting,
+-- which in turn is mainly for the case when TH can't express
+-- some random GHC extension
+
+reifyThing (AGlobal (AnId id))
+  = do  { ty <- reifyType (idType id)
+        ; let v = reifyName id
+        ; case idDetails id of
+            ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
+            RecSelId{sel_tycon=RecSelData tc}
+                          -> return (TH.VarI (reifySelector id tc) ty Nothing)
+            _             -> return (TH.VarI     v ty Nothing)
+    }
+
+reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc
+reifyThing (AGlobal (AConLike (RealDataCon dc)))
+  = do  { let name = dataConName dc
+        ; ty <- reifyType (idType (dataConWrapId dc))
+        ; return (TH.DataConI (reifyName name) ty
+                              (reifyName (dataConOrigTyCon dc)))
+        }
+
+reifyThing (AGlobal (AConLike (PatSynCon ps)))
+  = do { let name = reifyName ps
+       ; ty <- reifyPatSynType (patSynSig ps)
+       ; return (TH.PatSynI name ty) }
+
+reifyThing (ATcId {tct_id = id})
+  = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
+                                        -- though it may be incomplete
+        ; ty2 <- reifyType ty1
+        ; return (TH.VarI (reifyName id) ty2 Nothing) }
+
+reifyThing (ATyVar tv tv1)
+  = do { ty1 <- zonkTcTyVar tv1
+       ; ty2 <- reifyType ty1
+       ; return (TH.TyVarI (reifyName tv) ty2) }
+
+reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
+
+-------------------------------------------
+reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
+reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
+                                 , cab_lhs = lhs
+                                 , cab_rhs = rhs })
+            -- remove kind patterns (#8884)
+  = do { tvs' <- reifyTyVarsToMaybe tvs
+       ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+       ; lhs' <- reifyTypes lhs_types_only
+       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
+                                   lhs_types_only lhs'
+       ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs
+       ; rhs'  <- reifyType rhs
+       ; return (TH.TySynEqn tvs' lhs_type rhs') }
+  where
+    fam_tvs = tyConVisibleTyVars fam_tc
+
+reifyTyCon :: TyCon -> TcM TH.Info
+reifyTyCon tc
+  | Just cls <- tyConClass_maybe tc
+  = reifyClass cls
+
+  | isFunTyCon tc
+  = return (TH.PrimTyConI (reifyName tc) 2                False)
+
+  | isPrimTyCon tc
+  = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))
+                          (isUnliftedTyCon tc))
+
+  | isTypeFamilyTyCon tc
+  = do { let tvs      = tyConTyVars tc
+             res_kind = tyConResKind tc
+             resVar   = famTcResVar tc
+
+       ; kind' <- reifyKind res_kind
+       ; let (resultSig, injectivity) =
+                 case resVar of
+                   Nothing   -> (TH.KindSig kind', Nothing)
+                   Just name ->
+                     let thName   = reifyName name
+                         injAnnot = tyConInjectivityInfo tc
+                         sig = TH.TyVarSig (TH.KindedTV thName kind')
+                         inj = case injAnnot of
+                                 NotInjective -> Nothing
+                                 Injective ms ->
+                                     Just (TH.InjectivityAnn thName injRHS)
+                                   where
+                                     injRHS = map (reifyName . tyVarName)
+                                                  (filterByList ms tvs)
+                     in (sig, inj)
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
+       ; let tfHead =
+               TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
+       ; if isOpenTypeFamilyTyCon tc
+         then do { fam_envs <- tcGetFamInstEnvs
+                 ; instances <- reifyFamilyInstances tc
+                                  (familyInstances fam_envs tc)
+                 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
+         else do { eqns <-
+                     case isClosedSynFamilyTyConWithAxiom_maybe tc of
+                       Just ax -> mapM (reifyAxBranch tc) $
+                                  fromBranches $ coAxiomBranches ax
+                       Nothing -> return []
+                 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
+                      []) } }
+
+  | isDataFamilyTyCon tc
+  = do { let res_kind = tyConResKind tc
+
+       ; kind' <- fmap Just (reifyKind res_kind)
+
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
+       ; fam_envs <- tcGetFamInstEnvs
+       ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
+       ; return (TH.FamilyI
+                       (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
+
+  | Just (_, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym
+  = do { rhs' <- reifyType rhs
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
+       ; return (TH.TyConI
+                   (TH.TySynD (reifyName tc) tvs' rhs'))
+       }
+
+  | otherwise
+  = do  { cxt <- reifyCxt (tyConStupidTheta tc)
+        ; let tvs      = tyConTyVars tc
+              dataCons = tyConDataCons tc
+              isGadt   = isGadtSyntaxTyCon tc
+        ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
+        ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
+        ; let name = reifyName tc
+              deriv = []        -- Don't know about deriving
+              decl | isNewTyCon tc =
+                       TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
+                   | otherwise     =
+                       TH.DataD    cxt name r_tvs Nothing       cons  deriv
+        ; return (TH.TyConI decl) }
+
+reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
+reifyDataCon isGadtDataCon tys dc
+  = do { let -- used for H98 data constructors
+             (ex_tvs, theta, arg_tys)
+                 = dataConInstSig dc tys
+             -- used for GADTs data constructors
+             g_user_tvs' = dataConUserTyVars dc
+             (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
+                 = dataConFullSig dc
+             (srcUnpks, srcStricts)
+                 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
+             dcdBangs  = zipWith TH.Bang srcUnpks srcStricts
+             fields    = dataConFieldLabels dc
+             name      = reifyName dc
+             -- Universal tvs present in eq_spec need to be filtered out, as
+             -- they will not appear anywhere in the type.
+             eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
+
+       ; (univ_subst, _)
+              -- See Note [Freshen reified GADT constructors' universal tyvars]
+           <- freshenTyVarBndrs $
+              filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
+       ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs'
+             g_theta   = substTys tvb_subst g_theta'
+             g_arg_tys = substTys tvb_subst g_arg_tys'
+             g_res_ty  = substTy  tvb_subst g_res_ty'
+
+       ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
+
+       ; main_con <-
+           if | not (null fields) && not isGadtDataCon ->
+                  return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
+                                         dcdBangs r_arg_tys)
+              | not (null fields) -> do
+                  { res_ty <- reifyType g_res_ty
+                  ; return $ TH.RecGadtC [name]
+                                     (zip3 (map (reifyName . flSelector) fields)
+                                      dcdBangs r_arg_tys) res_ty }
+                -- We need to check not isGadtDataCon here because GADT
+                -- constructors can be declared infix.
+                -- See Note [Infix GADT constructors] in TcTyClsDecls.
+              | dataConIsInfix dc && not isGadtDataCon ->
+                  ASSERT( arg_tys `lengthIs` 2 ) do
+                  { let [r_a1, r_a2] = r_arg_tys
+                        [s1,   s2]   = dcdBangs
+                  ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
+              | isGadtDataCon -> do
+                  { res_ty <- reifyType g_res_ty
+                  ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
+              | otherwise ->
+                  return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
+
+       ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
+                               | otherwise     = ASSERT( all isTyVar ex_tvs )
+                                                 -- no covars for haskell syntax
+                                                 (ex_tvs, theta)
+             ret_con | null ex_tvs' && null theta' = return main_con
+                     | otherwise                   = do
+                         { cxt <- reifyCxt theta'
+                         ; ex_tvs'' <- reifyTyVars ex_tvs'
+                         ; return (TH.ForallC ex_tvs'' cxt main_con) }
+       ; ASSERT( arg_tys `equalLength` dcdBangs )
+         ret_con }
+
+{-
+Note [Freshen reified GADT constructors' universal tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose one were to reify this GADT:
+
+  data a :~: b where
+    Refl :: forall a b. (a ~ b) => a :~: b
+
+We ought to be careful here about the uniques we give to the occurrences of `a`
+and `b` in this definition. That is because in the original DataCon, all uses
+of `a` and `b` have the same unique, since `a` and `b` are both universally
+quantified type variables--that is, they are used in both the (:~:) tycon as
+well as in the constructor type signature. But when we turn the DataCon
+definition into the reified one, the `a` and `b` in the constructor type
+signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
+
+While it wouldn't technically be *wrong* per se to re-use the same uniques for
+`a` and `b` across these two different scopes, it's somewhat annoying for end
+users of Template Haskell, since they wouldn't be able to rely on the
+assumption that all TH names have globally distinct uniques (#13885). For this
+reason, we freshen the universally quantified tyvars that go into the reified
+GADT constructor type signature to give them distinct uniques from their
+counterparts in the tycon.
+-}
+
+------------------------------
+reifyClass :: Class -> TcM TH.Info
+reifyClass cls
+  = do  { cxt <- reifyCxt theta
+        ; inst_envs <- tcGetInstEnvs
+        ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
+        ; assocTys <- concatMapM reifyAT ats
+        ; ops <- concatMapM reify_op op_stuff
+        ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
+        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
+        ; return (TH.ClassI dec insts) }
+  where
+    (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
+    fds' = map reifyFunDep fds
+    reify_op (op, def_meth)
+      = do { let (_, _, ty) = tcSplitMethodTy (idType op)
+               -- Use tcSplitMethodTy to get rid of the extraneous class
+               -- variables and predicates at the beginning of op's type
+               -- (see #15551).
+           ; ty' <- reifyType ty
+           ; let nm' = reifyName op
+           ; case def_meth of
+                Just (_, GenericDM gdm_ty) ->
+                  do { gdm_ty' <- reifyType gdm_ty
+                     ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }
+                _ -> return [TH.SigD nm' ty'] }
+
+    reifyAT :: ClassATItem -> TcM [TH.Dec]
+    reifyAT (ATI tycon def) = do
+      tycon' <- reifyTyCon tycon
+      case tycon' of
+        TH.FamilyI dec _ -> do
+          let (tyName, tyArgs) = tfNames dec
+          (dec :) <$> maybe (return [])
+                            (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
+                            def
+        _ -> pprPanic "reifyAT" (text (show tycon'))
+
+    reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
+    reifyDefImpl n args ty =
+      TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))
+                                  <$> reifyType ty
+
+    tfNames :: TH.Dec -> (TH.Name, [TH.Name])
+    tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
+      = (n, map bndrName args)
+    tfNames d = pprPanic "tfNames" (text (show d))
+
+    bndrName :: TH.TyVarBndr -> TH.Name
+    bndrName (TH.PlainTV n)    = n
+    bndrName (TH.KindedTV n _) = n
+
+------------------------------
+-- | Annotate (with TH.SigT) a type if the first parameter is True
+-- and if the type contains a free variable.
+-- This is used to annotate type patterns for poly-kinded tyvars in
+-- reifying class and type instances. See #8953 and th/T8953.
+annotThType :: Bool   -- True <=> annotate
+            -> TyCoRep.Type -> TH.Type -> TcM TH.Type
+  -- tiny optimization: if the type is annotated, don't annotate again.
+annotThType _    _  th_ty@(TH.SigT {}) = return th_ty
+annotThType True ty th_ty
+  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
+  = do { let ki = tcTypeKind ty
+       ; th_ki <- reifyKind ki
+       ; return (TH.SigT th_ty th_ki) }
+annotThType _    _ th_ty = return th_ty
+
+-- | For every type variable in the input,
+-- report whether or not the tv is poly-kinded. This is used to eventually
+-- feed into 'annotThType'.
+mkIsPolyTvs :: [TyVar] -> [Bool]
+mkIsPolyTvs = map is_poly_tv
+  where
+    is_poly_tv tv = not $
+                    isEmptyVarSet $
+                    filterVarSet isTyVar $
+                    tyCoVarsOfType $
+                    tyVarKind tv
+
+------------------------------
+reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
+reifyClassInstances cls insts
+  = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
+  where
+    tvs = tyConVisibleTyVars (classTyCon cls)
+
+reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded
+                              -- includes only *visible* tvs
+                   -> ClsInst -> TcM TH.Dec
+reifyClassInstance is_poly_tvs i
+  = do { cxt <- reifyCxt theta
+       ; let vis_types = filterOutInvisibleTypes cls_tc types
+       ; thtypes <- reifyTypes vis_types
+       ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
+       ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
+       ; return $ (TH.InstanceD over cxt head_ty []) }
+  where
+     (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
+     cls_tc   = classTyCon cls
+     dfun     = instanceDFunId i
+     over     = case overlapMode (is_flag i) of
+                  NoOverlap _     -> Nothing
+                  Overlappable _  -> Just TH.Overlappable
+                  Overlapping _   -> Just TH.Overlapping
+                  Overlaps _      -> Just TH.Overlaps
+                  Incoherent _    -> Just TH.Incoherent
+
+------------------------------
+reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
+reifyFamilyInstances fam_tc fam_insts
+  = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
+  where
+    fam_tvs = tyConVisibleTyVars fam_tc
+
+reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
+                              -- includes only *visible* tvs
+                    -> FamInst -> TcM TH.Dec
+reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
+                                         , fi_axiom = ax
+                                         , fi_fam = fam })
+  | let fam_tc = coAxiomTyCon ax
+        branch = coAxiomSingleBranch ax
+  , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch
+  = case flavor of
+      SynFamilyInst ->
+               -- remove kind patterns (#8884)
+        do { th_tvs <- reifyTyVarsToMaybe tvs
+           ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+           ; th_lhs <- reifyTypes lhs_types_only
+           ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
+                                                   th_lhs
+           ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs
+           ; th_rhs <- reifyType rhs
+           ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }
+
+      DataFamilyInst rep_tc ->
+        do { let -- eta-expand lhs types, because sometimes data/newtype
+                 -- instances are eta-reduced; See #9692
+                 -- See Note [Eta reduction for data families] in FamInstEnv
+                 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
+                 fam'     = reifyName fam
+                 dataCons = tyConDataCons rep_tc
+                 isGadt   = isGadtSyntaxTyCon rep_tc
+           ; th_tvs <- reifyTyVarsToMaybe ee_tvs
+           ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons
+           ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
+           ; th_tys <- reifyTypes types_only
+           ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
+           ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys
+           ; return $
+               if isNewTyCon rep_tc
+               then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []
+               else TH.DataInstD    [] th_tvs lhs_type Nothing       cons  []
+           }
+
+------------------------------
+reifyType :: TyCoRep.Type -> TcM TH.Type
+-- Monadic only because of failure
+reifyType ty                | tcIsLiftedTypeKind ty = return TH.StarT
+  -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it
+  -- with Constraint (#14869).
+reifyType ty@(ForAllTy (Bndr _ argf) _)
+                            = reify_for_all argf ty
+reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) }
+reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
+reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
+reifyType ty@(AppTy {})     = do
+  let (ty_head, ty_args) = splitAppTys ty
+  ty_head' <- reifyType ty_head
+  ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)
+  pure $ mkThAppTs ty_head' ty_args'
+  where
+    -- Make sure to filter out any invisible arguments. For instance, if you
+    -- reify the following:
+    --
+    --   newtype T (f :: forall a. a -> Type) = MkT (f Bool)
+    --
+    -- Then you should receive back `f Bool`, not `f Type Bool`, since the
+    -- `Type` argument is invisible (#15792).
+    filter_out_invisible_args :: Type -> [Type] -> [Type]
+    filter_out_invisible_args ty_head ty_args =
+      filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
+                   ty_args
+reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 })
+  | InvisArg <- af = reify_for_all Inferred ty  -- Types like ((?x::Int) => Char -> Char)
+  | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
+reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH
+reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
+
+reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type
+-- Arg of reify_for_all is always ForAllTy or a predicate FunTy
+reify_for_all argf ty = do
+  tvs' <- reifyTyVars tvs
+  case argToForallVisFlag argf of
+    ForallVis   -> do phi' <- reifyType phi
+                      pure $ TH.ForallVisT tvs' phi'
+    ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi
+                      cxt' <- reifyCxt cxt
+                      tau' <- reifyType tau
+                      pure $ TH.ForallT tvs' cxt' tau'
+  where
+    (tvs, phi) = tcSplitForAllTysSameVis argf ty
+
+reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
+reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
+reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
+
+reifyTypes :: [Type] -> TcM [TH.Type]
+reifyTypes = mapM reifyType
+
+reifyPatSynType
+  :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
+-- reifies a pattern synonym's type and returns its *complete* type
+-- signature; see NOTE [Pattern synonym signatures and Template
+-- Haskell]
+reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
+  = do { univTyVars' <- reifyTyVars univTyVars
+       ; req'        <- reifyCxt req
+       ; exTyVars'   <- reifyTyVars exTyVars
+       ; prov'       <- reifyCxt prov
+       ; tau'        <- reifyType (mkVisFunTys argTys resTy)
+       ; return $ TH.ForallT univTyVars' req'
+                $ TH.ForallT exTyVars' prov' tau' }
+
+reifyKind :: Kind -> TcM TH.Kind
+reifyKind = reifyType
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
+reifyCxt   = mapM reifyType
+
+reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
+reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
+
+reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
+reifyTyVars tvs = mapM reify_tv tvs
+  where
+    -- even if the kind is *, we need to include a kind annotation,
+    -- in case a poly-kind would be inferred without the annotation.
+    -- See #8953 or test th/T8953
+    reify_tv tv = TH.KindedTV name <$> reifyKind kind
+      where
+        kind = tyVarKind tv
+        name = reifyName tv
+
+reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr])
+reifyTyVarsToMaybe []  = pure Nothing
+reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
+
+reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
+reify_tc_app tc tys
+  = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
+       ; maybe_sig_t (mkThAppTs r_tc tys') }
+  where
+    arity       = tyConArity tc
+
+    r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)
+         | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)
+         | isPromotedTupleTyCon tc        = TH.PromotedTupleT (arity `div` 2)
+             -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+         | isTupleTyCon tc                = if isPromotedDataCon tc
+                                            then TH.PromotedTupleT arity
+                                            else TH.TupleT arity
+         | tc `hasKey` constraintKindTyConKey
+                                          = TH.ConstraintT
+         | tc `hasKey` funTyConKey        = TH.ArrowT
+         | tc `hasKey` listTyConKey       = TH.ListT
+         | tc `hasKey` nilDataConKey      = TH.PromotedNilT
+         | tc `hasKey` consDataConKey     = TH.PromotedConsT
+         | tc `hasKey` heqTyConKey        = TH.EqualityT
+         | tc `hasKey` eqPrimTyConKey     = TH.EqualityT
+         | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
+         | isPromotedDataCon tc           = TH.PromotedT (reifyName tc)
+         | otherwise                      = TH.ConT (reifyName tc)
+
+    -- See Note [When does a tycon application need an explicit kind
+    -- signature?] in TyCoRep
+    maybe_sig_t th_type
+      | tyConAppNeedsKindSig
+          False -- We don't reify types using visible kind applications, so
+                -- don't count specified binders as contributing towards
+                -- injective positions in the kind of the tycon.
+          tc (length tys)
+      = do { let full_kind = tcTypeKind (mkTyConApp tc tys)
+           ; th_full_kind <- reifyKind full_kind
+           ; return (TH.SigT th_type th_full_kind) }
+      | otherwise
+      = return th_type
+
+------------------------------
+reifyName :: NamedThing n => n -> TH.Name
+reifyName thing
+  | isExternalName name
+              = mk_varg pkg_str mod_str occ_str
+  | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name))
+        -- Many of the things we reify have local bindings, and
+        -- NameL's aren't supposed to appear in binding positions, so
+        -- we use NameU.  When/if we start to reify nested things, that
+        -- have free variables, we may need to generate NameL's for them.
+  where
+    name    = getName thing
+    mod     = ASSERT( isExternalName name ) nameModule name
+    pkg_str = unitIdString (moduleUnitId mod)
+    mod_str = moduleNameString (moduleName mod)
+    occ_str = occNameString occ
+    occ     = nameOccName name
+    mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
+            | OccName.isVarOcc  occ = TH.mkNameG_v
+            | OccName.isTcOcc   occ = TH.mkNameG_tc
+            | otherwise             = pprPanic "reifyName" (ppr name)
+
+-- See Note [Reifying field labels]
+reifyFieldLabel :: FieldLabel -> TH.Name
+reifyFieldLabel fl
+  | flIsOverloaded fl
+              = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
+  | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
+  where
+    name    = flSelector fl
+    mod     = ASSERT( isExternalName name ) nameModule name
+    pkg_str = unitIdString (moduleUnitId mod)
+    mod_str = moduleNameString (moduleName mod)
+    occ_str = unpackFS (flLabel fl)
+
+reifySelector :: Id -> TyCon -> TH.Name
+reifySelector id tc
+  = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
+      Just fl -> reifyFieldLabel fl
+      Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
+
+------------------------------
+reifyFixity :: Name -> TcM (Maybe TH.Fixity)
+reifyFixity name
+  = do { (found, fix) <- lookupFixityRn_help name
+       ; return (if found then Just (conv_fix fix) else Nothing) }
+    where
+      conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)
+      conv_dir BasicTypes.InfixR = TH.InfixR
+      conv_dir BasicTypes.InfixL = TH.InfixL
+      conv_dir BasicTypes.InfixN = TH.InfixN
+
+reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
+reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
+reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
+reifyUnpackedness SrcUnpack   = TH.SourceUnpack
+
+reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
+reifyStrictness NoSrcStrict = TH.NoSourceStrictness
+reifyStrictness SrcStrict   = TH.SourceStrict
+reifyStrictness SrcLazy     = TH.SourceLazy
+
+reifySourceBang :: DataCon.HsSrcBang
+                -> (TH.SourceUnpackedness, TH.SourceStrictness)
+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
+
+reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
+reifyDecidedStrictness HsLazy     = TH.DecidedLazy
+reifyDecidedStrictness HsStrict   = TH.DecidedStrict
+reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
+
+------------------------------
+lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
+lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
+lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
+  = return $ ModuleTarget $
+    mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
+
+reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
+reifyAnnotations th_name
+  = do { name <- lookupThAnnLookup th_name
+       ; topEnv <- getTopEnv
+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
+       ; tcg <- getGblEnv
+       ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
+       ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
+
+------------------------------
+modToTHMod :: Module -> TH.Module
+modToTHMod m = TH.Module (TH.PkgName $ unitIdString  $ moduleUnitId m)
+                         (TH.ModName $ moduleNameString $ moduleName m)
+
+reifyModule :: TH.Module -> TcM TH.ModuleInfo
+reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
+  this_mod <- getModule
+  let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
+  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
+    where
+      reifyThisModule = do
+        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
+        return $ TH.ModuleInfo usages
+
+      reifyFromIface reifMod = do
+        iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
+        let usages = [modToTHMod m | usage <- mi_usages iface,
+                                     Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
+        return $ TH.ModuleInfo usages
+
+      usageToModule :: UnitId -> Usage -> Maybe Module
+      usageToModule _ (UsageFile {}) = Nothing
+      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
+      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
+      usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m
+
+------------------------------
+mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
+mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
+
+noTH :: PtrString -> SDoc -> TcM a
+noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>
+                                text "in Template Haskell:",
+                             nest 2 d])
+
+ppr_th :: TH.Ppr a => a -> SDoc
+ppr_th x = text (TH.pprint x)
+
+{-
+Note [Reifying field labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When reifying a datatype declared with DuplicateRecordFields enabled, we want
+the reified names of the fields to be labels rather than selector functions.
+That is, we want (reify ''T) and (reify 'foo) to produce
+
+    data T = MkT { foo :: Int }
+    foo :: T -> Int
+
+rather than
+
+    data T = MkT { $sel:foo:MkT :: Int }
+    $sel:foo:MkT :: T -> Int
+
+because otherwise TH code that uses the field names as strings will silently do
+the wrong thing.  Thus we use the field label (e.g. foo) as the OccName, rather
+than the selector (e.g. $sel:foo:MkT).  Since the Orig name M.foo isn't in the
+environment, NameG can't be used to represent such fields.  Instead,
+reifyFieldLabel uses NameQ.
+
+However, this means that extracting the field name from the output of reify, and
+trying to reify it again, may fail with an ambiguity error if there are multiple
+such fields defined in the module (see the test case
+overloadedrecflds/should_fail/T11103.hs).  The "proper" fix requires changes to
+the TH AST to make it able to represent duplicate record fields.
+-}
diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSplice.hs-boot
@@ -0,0 +1,46 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcSplice where
+
+import GhcPrelude
+import Name
+import HsExpr   ( PendingRnSplice, DelayedSplice )
+import TcRnTypes( TcM , SpliceType )
+import TcType   ( ExpRhoType )
+import Annotations ( Annotation, CoreAnnTarget )
+import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc )
+
+import HsSyn      ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,
+                    LHsDecl, ThModFinalizers )
+import qualified Language.Haskell.TH as TH
+
+tcSpliceExpr :: HsSplice GhcRn
+             -> ExpRhoType
+             -> TcM (HsExpr GhcTcId)
+
+tcUntypedBracket :: HsExpr GhcRn
+                 -> HsBracket GhcRn
+                 -> [PendingRnSplice]
+                 -> ExpRhoType
+                 -> TcM (HsExpr GhcTcId)
+tcTypedBracket :: HsExpr GhcRn
+               -> HsBracket GhcRn
+               -> ExpRhoType
+               -> TcM (HsExpr GhcTcId)
+
+runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
+
+runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
+
+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
+
+runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs)
+runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs)
+runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs)
+runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs]
+
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+runQuasi :: TH.Q a -> TcM a
+runRemoteModFinalizers :: ThModFinalizers -> TcM ()
+finishTH :: TcM ()
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -0,0 +1,4014 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
+
+TcTyClsDecls: Typecheck type and class declarations
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcTyClsDecls (
+        tcTyAndClassDecls,
+
+        -- Functions used by TcInstDcls to check
+        -- data/type family instance declarations
+        kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
+        tcFamTyPats, tcTyFamInstEqn,
+        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
+        unravelFamInstPats, addConsistencyConstraints,
+        wrongKindOfFamily
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import HscTypes
+import BuildTyCl
+import TcRnMonad
+import TcEnv
+import TcValidity
+import TcHsSyn
+import TcTyDecls
+import TcClassDcl
+import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
+import TcDeriv (DerivInfo)
+import TcHsType
+import ClsInst( AssocInstInfo(..) )
+import TcMType
+import TysWiredIn ( unitTy, makeRecoveryTyCon )
+import TcType
+import RnEnv( lookupConstructorFields )
+import FamInst
+import FamInstEnv
+import Coercion
+import Type
+import TyCoRep   -- for checkValidRoles
+import Class
+import CoAxiom
+import TyCon
+import DataCon
+import Id
+import Var
+import VarEnv
+import VarSet
+import Module
+import Name
+import NameSet
+import NameEnv
+import Outputable
+import Maybes
+import Unify
+import Util
+import SrcLoc
+import ListSetOps
+import DynFlags
+import Unique
+import ConLike( ConLike(..) )
+import BasicTypes
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable
+import Data.Function ( on )
+import Data.List
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.Set as Set
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Type checking for type and class declarations}
+*                                                                      *
+************************************************************************
+
+Note [Grouping of type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly
+connected component of mutually dependent types and classes. We kind check and
+type check each group separately to enhance kind polymorphism. Take the
+following example:
+
+  type Id a = a
+  data X = X (Id Int)
+
+If we were to kind check the two declarations together, we would give Id the
+kind * -> *, since we apply it to an Int in the definition of X. But we can do
+better than that, since Id really is kind polymorphic, and should get kind
+forall (k::*). k -> k. Since it does not depend on anything else, it can be
+kind-checked by itself, hence getting the most general kind. We then kind check
+X, which works fine because we then know the polymorphic kind of Id, and simply
+instantiate k to *.
+
+Note [Check role annotations in a second pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Role inference potentially depends on the types of all of the datacons declared
+in a mutually recursive group. The validity of a role annotation, in turn,
+depends on the result of role inference. Because the types of datacons might
+be ill-formed (see #7175 and Note [Checking GADT return types]) we must check
+*all* the tycons in a group for validity before checking *any* of the roles.
+Thus, we take two passes over the resulting tycons, first checking for general
+validity and then checking for valid role annotations.
+-}
+
+tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in
+                                            -- dependency order
+                  -> TcM ( TcGblEnv         -- Input env extended by types and
+                                            -- classes
+                                            -- and their implicit Ids,DataCons
+                         , [InstInfo GhcRn] -- Source-code instance decls info
+                         , [DerivInfo]      -- data family deriving info
+                         )
+-- Fails if there are any errors
+tcTyAndClassDecls tyclds_s
+  -- The code recovers internally, but if anything gave rise to
+  -- an error we'd better stop now, to avoid a cascade
+  -- Type check each group in dependency order folding the global env
+  = checkNoErrs $ fold_env [] [] tyclds_s
+  where
+    fold_env :: [InstInfo GhcRn]
+             -> [DerivInfo]
+             -> [TyClGroup GhcRn]
+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+    fold_env inst_info deriv_info []
+      = do { gbl_env <- getGblEnv
+           ; return (gbl_env, inst_info, deriv_info) }
+    fold_env inst_info deriv_info (tyclds:tyclds_s)
+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+           ; setGblEnv tcg_env $
+               -- remaining groups are typechecked in the extended global env.
+             fold_env (inst_info' ++ inst_info)
+                      (deriv_info' ++ deriv_info)
+                      tyclds_s }
+
+tcTyClGroup :: TyClGroup GhcRn
+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+-- Typecheck one strongly-connected component of type, class, and instance decls
+-- See Note [TyClGroups and dependency analysis] in HsDecls
+tcTyClGroup (TyClGroup { group_tyclds = tyclds
+                       , group_roles  = roles
+                       , group_instds = instds })
+  = do { let role_annots = mkRoleAnnotEnv roles
+
+           -- Step 1: Typecheck the type/class declarations
+       ; traceTc "---- tcTyClGroup ---- {" empty
+       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
+       ; tyclss <- tcTyClDecls tyclds role_annots
+
+           -- Step 1.5: Make sure we don't have any type synonym cycles
+       ; traceTc "Starting synonym cycle check" (ppr tyclss)
+       ; this_uid <- fmap thisPackage getDynFlags
+       ; checkSynCycles this_uid tyclss tyclds
+       ; traceTc "Done synonym cycle check" (ppr tyclss)
+
+           -- Step 2: Perform the validity check on those types/classes
+           -- We can do this now because we are done with the recursive knot
+           -- Do it before Step 3 (adding implicit things) because the latter
+           -- expects well-formed TyCons
+       ; traceTc "Starting validity check" (ppr tyclss)
+       ; tyclss <- concatMapM checkValidTyCl tyclss
+       ; traceTc "Done validity check" (ppr tyclss)
+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
+           -- See Note [Check role annotations in a second pass]
+
+       ; traceTc "---- end tcTyClGroup ---- }" empty
+
+           -- Step 3: Add the implicit things;
+           -- we want them in the environment because
+           -- they may be mentioned in interface files
+       ; gbl_env <- addTyConsToGblEnv tyclss
+
+           -- Step 4: check instance declarations
+       ; setGblEnv gbl_env $
+         tcInstDecls1 instds }
+
+tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"
+
+tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
+tcTyClDecls tyclds role_annots
+  = tcExtendKindEnv promotion_err_env $   --- See Note [Type environment evolution]
+    do {    -- Step 1: kind-check this group and returns the final
+            -- (possibly-polymorphic) kind of each TyCon and Class
+            -- See Note [Kind checking for type and class decls]
+         tc_tycons <- kcTyClGroup tyclds
+       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
+
+            -- Step 2: type-check all groups together, returning
+            -- the final TyCons and Classes
+            --
+            -- NB: We have to be careful here to NOT eagerly unfold
+            -- type synonyms, as we have not tested for type synonym
+            -- loops yet and could fall into a black hole.
+       ; fixM $ \ ~rec_tyclss -> do
+           { tcg_env <- getGblEnv
+           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss
+
+                 -- Populate environment with knot-tied ATyCon for TyCons
+                 -- NB: if the decls mention any ill-staged data cons
+                 -- (see Note [Recursion and promoting data constructors])
+                 -- we will have failed already in kcTyClGroup, so no worries here
+           ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
+
+                 -- Also extend the local type envt with bindings giving
+                 -- a TcTyCon for each each knot-tied TyCon or Class
+                 -- See Note [Type checking recursive type and class declarations]
+                 -- and Note [Type environment evolution]
+             tcExtendKindEnvWithTyCons tc_tycons $
+
+                 -- Kind and type check declarations for this group
+               mapM (tcTyClDecl roles) tyclds
+           } }
+  where
+    promotion_err_env = mkPromotionErrorEnv tyclds
+    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
+                                  , ppr (tyConBinders tc) <> comma
+                                  , ppr (tyConResKind tc)
+                                  , ppr (isTcTyCon tc) ])
+
+zipRecTyClss :: [TcTyCon]
+             -> [TyCon]           -- Knot-tied
+             -> [(Name,TyThing)]
+-- Build a name-TyThing mapping for the TyCons bound by decls
+-- being careful not to look at the knot-tied [TyThing]
+-- The TyThings in the result list must have a visible ATyCon,
+-- because typechecking types (in, say, tcTyClDecl) looks at
+-- this outer constructor
+zipRecTyClss tc_tycons rec_tycons
+  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]
+  where
+    rec_tc_env :: NameEnv TyCon
+    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons
+
+    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
+    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)
+
+    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
+    add_one_tc tc env = extendNameEnv env (tyConName tc) tc
+
+    get name = case lookupNameEnv rec_tc_env name of
+                 Just tc -> tc
+                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
+
+{-
+************************************************************************
+*                                                                      *
+                Kind checking
+*                                                                      *
+************************************************************************
+
+Note [Kind checking for type and class decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Kind checking is done thus:
+
+   1. Make up a kind variable for each parameter of the declarations,
+      and extend the kind environment (which is in the TcLclEnv)
+
+   2. Kind check the declarations
+
+We need to kind check all types in the mutually recursive group
+before we know the kind of the type variables.  For example:
+
+  class C a where
+     op :: D b => a -> b -> b
+
+  class D c where
+     bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+depends on *all the uses of class D*.  For example, the use of
+Monad c in bop's type signature means that D must have kind Type->Type.
+
+Note: we don't treat type synonyms specially (we used to, in the past);
+in particular, even if we have a type synonym cycle, we still kind check
+it normally, and test for cycles later (checkSynCycles).  The reason
+we can get away with this is because we have more systematic TYPE r
+inference, which means that we can do unification between kinds that
+aren't lifted (this historically was not true.)
+
+The downside of not directly reading off the kinds of the RHS of
+type synonyms in topological order is that we don't transparently
+support making synonyms of types with higher-rank kinds.  But
+you can always specify a CUSK directly to make this work out.
+See tc269 for an example.
+
+Note [Skip decls with CUSKs in kcLTyClDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+    data T (a :: *) = MkT (S a)   -- Has CUSK
+    data S a = MkS (T Int) (S a)  -- No CUSK
+
+Via getInitialKinds we get
+  T :: * -> *
+  S :: kappa -> *
+
+Then we call kcTyClDecl on each decl in the group, to constrain the
+kind unification variables.  BUT we /skip/ the RHS of any decl with
+a CUSK.  Here we skip the RHS of T, so we eventually get
+  S :: forall k. k -> *
+
+This gets us more polymorphism than we would otherwise get, similar
+(but implemented strangely differently from) the treatment of type
+signatures in value declarations.
+
+However, we only want to do so when we have PolyKinds.
+When we have NoPolyKinds, we don't skip those decls, because we have defaulting
+(#16609). Skipping won't bring us more polymorphism when we have defaulting.
+Consider
+
+  data T1 a = MkT1 T2        -- No CUSK
+  data T2 = MkT2 (T1 Maybe)  -- Has CUSK
+
+If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.
+With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the
+program type-checks.
+But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens
+in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking
+(T1 Maybe) will throw a type error.
+
+Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.
+
+Open type families
+~~~~~~~~~~~~~~~~~~
+This treatment of type synonyms only applies to Haskell 98-style synonyms.
+General type functions can be recursive, and hence, appear in `alg_decls'.
+
+The kind of an open type family is solely determinded by its kind signature;
+hence, only kind signatures participate in the construction of the initial
+kind environment (as constructed by `getInitialKind'). In fact, we ignore
+instances of families altogether in the following. However, we need to include
+the kinds of *associated* families into the construction of the initial kind
+environment. (This is handled by `allDecls').
+
+See also Note [Kind checking recursive type and class declarations]
+
+Note [How TcTyCons work]
+~~~~~~~~~~~~~~~~~~~~~~~~
+TcTyCons are used for two distinct purposes
+
+1.  When recovering from a type error in a type declaration,
+    we want to put the erroneous TyCon in the environment in a
+    way that won't lead to more errors.  We use a TcTyCon for this;
+    see makeRecoveryTyCon.
+
+2.  When checking a type/class declaration (in module TcTyClsDecls), we come
+    upon knowledge of the eventual tycon in bits and pieces.
+
+      S1) First, we use getInitialKinds to look over the user-provided
+          kind signature of a tycon (including, for example, the number
+          of parameters written to the tycon) to get an initial shape of
+          the tycon's kind.  We record that shape in a TcTyCon.
+
+          For CUSK tycons, the TcTyCon has the final, generalised kind.
+          For non-CUSK tycons, the TcTyCon has as its tyConBinders only
+          the explicit arguments given -- no kind variables, etc.
+
+      S2) Then, using these initial kinds, we kind-check the body of the
+          tycon (class methods, data constructors, etc.), filling in the
+          metavariables in the tycon's initial kind.
+
+      S3) We then generalize to get the (non-CUSK) tycon's final, fixed
+          kind. Finally, once this has happened for all tycons in a
+          mutually recursive group, we can desugar the lot.
+
+    For convenience, we store partially-known tycons in TcTyCons, which
+    might store meta-variables. These TcTyCons are stored in the local
+    environment in TcTyClsDecls, until the real full TyCons can be created
+    during desugaring. A desugared program should never have a TcTyCon.
+
+3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).
+
+4.  tyConScopedTyVars.  A challenging piece in all of this is that we
+    end up taking three separate passes over every declaration:
+      - one in getInitialKind (this pass look only at the head, not the body)
+      - one in kcTyClDecls (to kind-check the body)
+      - a final one in tcTyClDecls (to desugar)
+
+    In the latter two passes, we need to connect the user-written type
+    variables in an LHsQTyVars with the variables in the tycon's
+    inferred kind. Because the tycon might not have a CUSK, this
+    matching up is, in general, quite hard to do.  (Look through the
+    git history between Dec 2015 and Apr 2016 for
+    TcHsType.splitTelescopeTvs!)
+
+    Instead of trying, we just store the list of type variables to
+    bring into scope, in the tyConScopedTyVars field of the TcTyCon.
+    These tyvars are brought into scope in TcHsType.bindTyClTyVars.
+
+    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather
+    than just [TcTyVar]?  Consider these mutually-recursive decls
+       data T (a :: k1) b = MkT (S a b)
+       data S (c :: k2) d = MkS (T c d)
+    We start with k1 bound to kappa1, and k2 to kappa2; so initially
+    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But
+    then kappa1 and kappa2 get unified; so after the zonking in
+    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.
+
+See also Note [Type checking recursive type and class declarations].
+
+Note [Type environment evolution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As we typecheck a group of declarations the type environment evolves.
+Consider for example:
+  data B (a :: Type) = MkB (Proxy 'MkB)
+
+We do the following steps:
+
+  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the
+     type env with promotion errors
+            B   :-> TyConPE
+            MkB :-> DataConPE
+
+  2. kcTyCLGroup
+      - Do getInitialKinds, which will signal a promotion
+        error if B is used in any of the kinds needed to initialise
+        B's kind (e.g. (a :: Type)) here
+
+      - Extend the type env with these initial kinds (monomorphic for
+        decls that lack a CUSK)
+            B :-> TcTyCon <initial kind>
+        (thereby overriding the B :-> TyConPE binding)
+        and do kcLTyClDecl on each decl to get equality constraints on
+        all those inital kinds
+
+      - Generalise the inital kind, making a poly-kinded TcTyCon
+
+  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded
+     TcTyCons, again overriding the promotion-error bindings.
+
+     But note that the data constructor promotion errors are still in place
+     so that (in our example) a use of MkB will sitll be signalled as
+     an error.
+
+  4. Typecheck the decls.
+
+  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons
+
+
+Note [Missed opportunity to retain higher-rank kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In 'kcTyClGroup', there is a missed opportunity to make kind
+inference work in a few more cases.  The idea is analogous
+to Note [Single function non-recursive binding special-case]:
+
+     * If we have an SCC with a single decl, which is non-recursive,
+       instead of creating a unification variable representing the
+       kind of the decl and unifying it with the rhs, we can just
+       read the type directly of the rhs.
+
+     * Furthermore, we can update our SCC analysis to ignore
+       dependencies on declarations which have CUSKs: we don't
+       have to kind-check these all at once, since we can use
+       the CUSK to initialize the kind environment.
+
+Unfortunately this requires reworking a bit of the code in
+'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
+
+Note [Don't process associated types in kcLHsQTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, we processed associated types in the thing_inside in kcLHsQTyVars,
+but this was wrong -- we want to do ATs sepearately.
+The consequence for not doing it this way is #15142:
+
+  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where
+    type ListToTuple as :: Type
+
+We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify
+kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring
+`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't
+unified with Type. And then, when we generalize the kind of ListToTuple (which
+indeed has a CUSK, according to the rules), we skolemize the free metavariable
+kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,
+because the solveEqualities in kcLHsQTyVars is at TcLevel 1 and so kappa[1]
+will unify with Type.
+
+Bottom line: as associated types should have no effect on a CUSK enclosing class,
+we move processing them to a separate action, run after the outer kind has
+been generalized.
+
+-}
+
+kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
+
+-- Kind check this group, kind generalize, and return the resulting local env
+-- This binds the TyCons and Classes of the group, but not the DataCons
+-- See Note [Kind checking for type and class decls]
+-- and Note [Inferring kinds for type declarations]
+kcTyClGroup decls
+  = do  { mod <- getModule
+        ; traceTc "---- kcTyClGroup ---- {"
+                  (text "module" <+> ppr mod $$ vcat (map ppr decls))
+
+          -- Kind checking;
+          --    1. Bind kind variables for decls
+          --    2. Kind-check decls
+          --    3. Generalise the inferred kinds
+          -- See Note [Kind checking for type and class decls]
+
+        ; cusks_enabled <- xoptM LangExt.CUSKs
+        ; let (cusk_decls, no_cusk_decls)
+                 = partition (hsDeclHasCusk cusks_enabled . unLoc) decls
+
+        ; poly_cusk_tcs <- getInitialKinds True cusk_decls
+
+        ; mono_tcs
+            <- tcExtendKindEnvWithTyCons poly_cusk_tcs $
+               pushTcLevelM_   $  -- We are going to kind-generalise, so
+                                  -- unification variables in here must
+                                  -- be one level in
+               solveEqualities $
+               do {  -- Step 1: Bind kind variables for all decls
+                    mono_tcs <- getInitialKinds False no_cusk_decls
+
+                  ; traceTc "kcTyClGroup: initial kinds" $
+                    ppr_tc_kinds mono_tcs
+
+                    -- Step 2: Set extended envt, kind-check the decls
+                    -- NB: the environment extension overrides the tycon
+                    --     promotion-errors bindings
+                    --     See Note [Type environment evolution]
+                  ; poly_kinds  <- xoptM LangExt.PolyKinds
+                  ; tcExtendKindEnvWithTyCons mono_tcs $
+                    mapM_ kcLTyClDecl (if poly_kinds then no_cusk_decls else decls)
+                    -- See Note [Skip decls with CUSKs in kcLTyClDecl]
+
+                  ; return mono_tcs }
+
+        -- Step 3: generalisation
+        -- Finally, go through each tycon and give it its final kind,
+        -- with all the required, specified, and inferred variables
+        -- in order.
+        ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs
+
+        ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_tcs
+        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
+        ; return poly_tcs }
+
+  where
+    ppr_tc_kinds tcs = vcat (map pp_tc tcs)
+    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
+
+generaliseTcTyCon :: TcTyCon -> TcM TcTyCon
+generaliseTcTyCon tc
+  -- See Note [Required, Specified, and Inferred for types]
+  = setSrcSpan (getSrcSpan tc) $
+    addTyConCtxt tc $
+    do { let tc_name      = tyConName tc
+             tc_res_kind  = tyConResKind tc
+             spec_req_prs = tcTyConScopedTyVars tc
+
+             (spec_req_names, spec_req_tvs) = unzip spec_req_prs
+             -- NB: spec_req_tvs includes both Specified and Required
+             -- Running example in Note [Inferring kinds for type declarations]
+             --    spec_req_prs = [ ("k1",kk1), ("a", (aa::kk1))
+             --                   , ("k2",kk2), ("x", (xx::kk2))]
+             -- where "k1" dnotes the Name k1, and kk1, aa, etc are MetaTyVarss,
+             -- specifically TyVarTvs
+
+       -- Step 0: zonk and skolemise the Specified and Required binders
+       -- It's essential that they are skolems, not MetaTyVars,
+       -- for Step 3 to work right
+       ; spec_req_tvs <- mapM zonkAndSkolemise spec_req_tvs
+             -- Running example, where kk1 := kk2, so we get
+             --   [kk2,kk2]
+
+       -- Step 1: Check for duplicates
+       -- E.g. data SameKind (a::k) (b::k)
+       --      data T (a::k1) (b::k2) = MkT (SameKind a b)
+       -- Here k1 and k2 start as TyVarTvs, and get unified with each other
+       -- If this happens, things get very confused later, so fail fast
+       ; checkDuplicateTyConBinders spec_req_names spec_req_tvs
+
+       -- Step 2a: find all the Inferred variables we want to quantify over
+       -- NB: candidateQTyVarsOfKinds zonks as it goes
+       ; dvs1 <- candidateQTyVarsOfKinds $
+                (tc_res_kind : map tyVarKind spec_req_tvs)
+       ; let dvs2 = dvs1 `delCandidates` spec_req_tvs
+
+       -- Step 2b: quantify, mainly meaning skolemise the free variables
+       -- Returned 'inferred' are scope-sorted and skolemised
+       ; inferred <- quantifyTyVars emptyVarSet dvs2
+
+       -- Step 3a: rename all the Specified and Required tyvars back to
+       -- TyVars with their oroginal user-specified name.  Example
+       --     class C a_r23 where ....
+       -- By this point we have scoped_prs = [(a_r23, a_r89[TyVarTv])]
+       -- We return with the TyVar a_r23[TyVar],
+       --    and ze mapping a_r89 :-> a_r23[TyVar]
+       ; traceTc "generaliseTcTyCon: before zonkRec"
+           (vcat [ text "spec_req_tvs =" <+> pprTyVars spec_req_tvs
+                 , text "inferred =" <+> pprTyVars inferred ])
+       ; (ze, final_spec_req_tvs) <- zonkRecTyVarBndrs spec_req_names spec_req_tvs
+           -- So ze maps from the tyvars that have ended up
+
+       -- Step 3b: Apply that mapping to the other variables
+       -- (remember they all started as TyVarTvs).
+       -- They have been skolemised by quantifyTyVars.
+       ; (ze, inferred) <- zonkTyBndrsX ze inferred
+       ; tc_res_kind    <- zonkTcTypeToTypeX ze tc_res_kind
+
+       ; traceTc "generaliseTcTyCon: post zonk" $
+         vcat [ text "tycon =" <+> ppr tc
+              , text "inferred =" <+> pprTyVars inferred
+              , text "ze =" <+> ppr ze
+              , text "spec_req_prs =" <+> ppr spec_req_prs
+              , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs
+              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs ]
+
+       -- Step 4: Find the Specified and Inferred variables
+       -- NB: spec_req_tvs = spec_tvs ++ req_tvs
+       --     And req_tvs is 1-1 with tyConTyVars
+       --     See Note [Scoped tyvars in a TcTyCon] in TyCon
+       ; let n_spec        = length final_spec_req_tvs - tyConArity tc
+             (spec_tvs, req_tvs) = splitAt n_spec final_spec_req_tvs
+             specified     = scopedSort spec_tvs
+                             -- NB: maintain the L-R order of scoped_tvs
+
+       -- Step 5: Make the TyConBinders.
+             to_user tv     = lookupTyVarOcc ze tv `orElse` tv
+             dep_fv_set     = mapVarSet to_user (candidateKindVars dvs1)
+             inferred_tcbs  = mkNamedTyConBinders Inferred inferred
+             specified_tcbs = mkNamedTyConBinders Specified specified
+             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs
+
+       -- Step 6: Assemble the final list.
+             final_tcbs = concat [ inferred_tcbs
+                                 , specified_tcbs
+                                 , required_tcbs ]
+
+       -- Step 7: Make the result TcTyCon
+             tycon = mkTcTyCon tc_name final_tcbs tc_res_kind
+                            (mkTyVarNamePairs final_spec_req_tvs)
+                            True {- it's generalised now -}
+                            (tyConFlavour tc)
+
+       ; traceTc "generaliseTcTyCon done" $
+         vcat [ text "tycon =" <+> ppr tc
+              , text "tc_res_kind =" <+> ppr tc_res_kind
+              , text "dep_fv_set =" <+> ppr dep_fv_set
+              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs
+              , text "inferred =" <+> pprTyVars inferred
+              , text "specified =" <+> pprTyVars specified
+              , text "required_tcbs =" <+> ppr required_tcbs
+              , text "final_tcbs =" <+> ppr final_tcbs ]
+
+       -- Step 8: Check for validity.
+       -- We do this here because we're about to put the tycon into the
+       -- the environment, and we don't want anything malformed there
+       ; checkTyConTelescope tycon
+
+       ; return tycon }
+
+checkDuplicateTyConBinders :: [Name] -> [TcTyVar] -> TcM ()
+checkDuplicateTyConBinders spec_req_names spec_req_tvs
+  | null dups = return ()
+  | otherwise = mapM_ report_dup dups >> failM
+  where
+    dups :: [(Name,Name)]
+    dups = findDupTyVarTvs $ spec_req_names `zip` spec_req_tvs
+
+    report_dup (n1, n2)
+      = setSrcSpan (getSrcSpan n2) $
+        addErrTc (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
+
+{- Note [Required, Specified, and Inferred for types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each forall'd type variable in a type or kind is one of
+
+  * Required: an argument must be provided at every call site
+
+  * Specified: the argument can be inferred at call sites, but
+    may be instantiated with visible type/kind application
+
+  * Inferred: the must be inferred at call sites; it
+    is unavailable for use with visible type/kind application.
+
+Why have Inferred at all? Because we just can't make user-facing
+promises about the ordering of some variables. These might swizzle
+around even between minor released. By forbidding visible type
+application, we ensure users aren't caught unawares.
+
+Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.
+
+The question for this Note is this:
+   given a TyClDecl, how are its quantified type variables classified?
+Much of the debate is memorialized in #15743.
+
+Here is our design choice. When inferring the ordering of variables
+for a TyCl declaration (that is, for those variables that he user
+has not specified the order with an explicit `forall`), we use the
+following order:
+
+ 1. Inferred variables
+ 2. Specified variables; in the left-to-right order in which
+    the user wrote them, modified by scopedSort (see below)
+    to put them in depdendency order.
+ 3. Required variables before a top-level ::
+ 4. All variables after a top-level ::
+
+If this ordering does not make a valid telescope, we reject the definition.
+
+Example:
+  data SameKind :: k -> k -> *
+  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
+
+For Bad:
+  - a, c, d, x are Required; they are explicitly listed by the user
+    as the positional arguments of Bad
+  - b is Specified; it appears explicitly in a kind signature
+  - k, the kind of a, is Inferred; it is not mentioned explicitly at all
+
+Putting variables in the order Inferred, Specified, Required
+gives us this telescope:
+  Inferred:  k
+  Specified: b : Proxy a
+  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)
+
+But this order is ill-scoped, because b's kind mentions a, which occurs
+after b in the telescope. So we reject Bad.
+
+Associated types
+~~~~~~~~~~~~~~~~
+For associated types everything above is determined by the
+associated-type declaration alone, ignoring the class header.
+Here is an example (#15592)
+  class C (a :: k) b where
+    type F (x :: b a)
+
+In the kind of C, 'k' is Specified.  But what about F?
+In the kind of F,
+
+ * Should k be Inferred or Specified?  It's Specified for C,
+   but not mentioned in F's declaration.
+
+ * In which order should the Specified variables a and b occur?
+   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering
+   in F's declaration is 'b' then 'a'.
+
+In both cases we make the choice by looking at F's declaration alone,
+so it gets the kind
+   F :: forall {k}. forall b a. b a -> Type
+
+How it works
+~~~~~~~~~~~~
+These design choices are implemented by two completely different code
+paths for
+
+  * Declarations with a complete user-specified kind signature (CUSK)
+    Handed by the CUSK case of kcLHsQTyVars.
+
+  * Declarations without a CUSK are handled by kcTyClDecl; see
+    Note [Inferring kinds for type declarations].
+
+Note that neither code path worries about point (4) above, as this
+is nicely handled by not mangling the res_kind. (Mangling res_kinds is done
+*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)
+
+We can tell Inferred apart from Specified by looking at the scoped
+tyvars; Specified are always included there.
+
+Design alternatives
+~~~~~~~~~~~~~~~~~~~
+* For associated types we considered putting the class variables
+  before the local variables, in a nod to the treatment for class
+  methods. But it got too compilicated; see #15592, comment:21ff.
+
+* We rigidly require the ordering above, even though we could be much more
+  permissive. Relevant musings are at
+  https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623
+  The bottom line conclusion is that, if the user wants a different ordering,
+  then can specify it themselves, and it is better to be predictable and dumb
+  than clever and capricious.
+
+  I (Richard) conjecture we could be fully permissive, allowing all classes
+  of variables to intermix. We would have to augment ScopedSort to refuse to
+  reorder Required variables (or check that it wouldn't have). But this would
+  allow more programs. See #15743 for examples. Interestingly, Idris seems
+  to allow this intermixing. The intermixing would be fully specified, in that
+  we can be sure that inference wouldn't change between versions. However,
+  would users be able to predict it? That I cannot answer.
+
+Test cases (and tickets) relevant to these design decisions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  T15591*
+  T15592*
+  T15743*
+
+Note [Inferring kinds for type declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note deals with /inference/ for type declarations
+that do not have a CUSK.  Consider
+  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)
+  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)
+
+We do kind inference as follows:
+
+* Step 1: getInitialKinds, and in particular kcLHsQTyVars_NonCusk.
+  Make a unification variable for each of the Required and Specified
+  type varialbes in the header.
+
+  Record the connection between the Names the user wrote and the
+  fresh unification variables in the tcTyConScopedTyVars field
+  of the TcTyCon we are making
+      [ (a,  aa)
+      , (k1, kk1)
+      , (k2, kk2)
+      , (x,  xx) ]
+  (I'm using the convention that double letter like 'aa' or 'kk'
+  mean a unification variable.)
+
+  These unification variables
+    - Are TyVarTvs: that is, unification variables that can
+      unify only with other type variables.
+      See Note [Signature skolems] in TcType
+
+    - Have complete fresh Names; see TcMType
+      Note [Unification variables need fresh Names]
+
+  Assign initial monomorophic kinds to S, T
+          T :: kk1 -> * -> kk2 -> *
+          S :: kk3 -> * -> kk4 -> *
+
+* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and
+  T, with these monomophic kinds.  Now kind-check the declarations,
+  and solve the resulting equalities.  The goal here is to discover
+  constraints on all these unification variables.
+
+  Here we find that kk1 := kk3, and kk2 := kk4.
+
+  This is why we can't use skolems for kk1 etc; they have to
+  unify with each other.
+
+* Step 3: generaliseTcTyCon. Generalise each TyCon in turn.
+  We find the free variables of the kind, skolemise them,
+  sort them out into Inferred/Required/Specified (see the above
+  Note [Required, Specified, and Inferred for types]),
+  and perform some validity checks.
+
+  This makes the utterly-final TyConBinders for the TyCon.
+
+  All this is very similar at the level of terms: see TcBinds
+  Note [Quantified variables in partial type signatures]
+
+  But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon]
+
+* Step 4.  Extend the type environment with a TcTyCon for S and T, now
+  with their utterly-final polymorphic kinds (needed for recursive
+  occurrences of S, T).  Now typecheck the declarations, and build the
+  final AlgTyCOn for S and T resp.
+
+The first three steps are in kcTyClGroup; the fourth is in
+tcTyClDecls.
+
+There are some wrinkles
+
+* Do not default TyVarTvs.  We always want to kind-generalise over
+  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is
+  not allowed to unify with a type; it must stand for a type
+  variable. Hence the check in TcSimplify.defaultTyVarTcS, and
+  TcMType.defaultTyVar.  Here's another example (#14555):
+     data Exp :: [TYPE rep] -> TYPE rep -> Type where
+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)
+  We want to kind-generalise over the 'rep' variable.
+  #14563 is another example.
+
+* Duplicate type variables. Consider #11203
+    data SameKind :: k -> k -> *
+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
+  Here we will unify k1 with k2, but this time doing so is an error,
+  because k1 and k2 are bound in the same declaration.
+
+  We spot this during validity checking (findDupTyVarTvs),
+  in generaliseTcTyCon.
+
+* Required arguments.  Even the Required arguments should be made
+  into TyVarTvs, not skolems.  Consider
+    data T k (a :: k)
+  Here, k is a Required, dependent variable. For uniformity, it is helpful
+  to have k be a TyVarTv, in parallel with other dependent variables.
+
+* Duplicate skolemisation is expected.  When generalising in Step 3,
+  we may find that one of the variables we want to quantify has
+  already been skolemised.  For example, suppose we have already
+  generalise S. When we come to T we'll find that kk1 (now the same as
+  kk3) has already been skolemised.
+
+  That's fine -- but it means that
+    a) when collecting quantification candidates, in
+       candidateQTyVarsOfKind, we must collect skolems
+    b) quantifyTyVars should be a no-op on such a skolem
+
+Note [Tricky scoping in generaliseTcTyCon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider #16342
+  class C (a::ka) x where
+    cop :: D a x => x -> Proxy a -> Proxy a
+    cop _ x = x :: Proxy (a::ka)
+
+  class D (b::kb) y where
+    dop :: C b y => y -> Proxy b -> Proxy b
+    dop _ x = x :: Proxy (b::kb)
+
+C and D are mutually recursive, by the time we get to
+generaliseTcTyCon we'll have unified kka := kkb.
+
+But when typechecking the default declarations for 'cop' and 'dop' in
+tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.
+But at that point all we have is the utterly-final Class itself.
+
+Conclusion: the classTyVars of a class must have the same Name as
+that originally assigned by the user.  In our example, C must have
+classTyVars {a, ka, x} while D has classTyVars {a, kb, y}.  Despite
+the fact that kka and kkb got unified!
+
+We achieve this sleight of hand in generaliseTcTyCon, using
+the specialised function zonkRecTyVarBndrs.  We make the call
+   zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx]
+where the [ka,a,x] are the Names originally assigned by the user, and
+[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars.
+zonkRecTyVarBndrs builds a recursive ZonkEnv that binds
+   kkb :-> (ka :: <zonked kind of kkb>)
+   aa  :-> (a  :: <konked kind of aa>)
+   etc
+That is, it maps each skolemised TcTyVars to the utterly-final
+TyVar to put in the class, with its correct user-specified name.
+When generalising D we'll do the same thing, but the ZonkEnv will map
+   kkb :-> (kb :: <zonked kind of kkb>)
+   bb  :-> (b  :: <konked kind of bb>)
+   etc
+Note that 'kkb' again appears in the domain of the mapping, but this
+time mapped to 'kb'.  That's how C and D end up with differently-named
+final TyVars despite the fact that we unified kka:=kkb
+
+zonkRecTyVarBndrs we need to do knot-tying because of the need to
+apply this same substitution to the kind of each.  -}
+
+--------------
+tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
+tcExtendKindEnvWithTyCons tcs
+  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]
+
+--------------
+mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
+-- Maps each tycon/datacon to a suitable promotion error
+--    tc :-> APromotionErr TyConPE
+--    dc :-> APromotionErr RecDataConPE
+--    See Note [Recursion and promoting data constructors]
+
+mkPromotionErrorEnv decls
+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)
+          emptyNameEnv decls
+
+mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })
+  = unitNameEnv nm (APromotionErr ClassPE)
+    `plusNameEnv`
+    mkNameEnv [ (name, APromotionErr TyConPE)
+              | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]
+
+mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)
+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })
+  = unitNameEnv name (APromotionErr TyConPE)
+    `plusNameEnv`
+    mkNameEnv [ (con, APromotionErr RecDataConPE)
+              | (dL->L _ con') <- cons
+              , (dL->L _ con)  <- getConNames con' ]
+
+mk_prom_err_env decl
+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)
+    -- Works for family declarations too
+
+--------------
+getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
+-- Returns a TcTyCon for each TyCon bound by the decls,
+-- each with its initial kind
+
+getInitialKinds cusk decls
+  = do { traceTc "getInitialKinds {" empty
+       ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls
+       ; traceTc "getInitialKinds done }" empty
+       ; return tcs }
+
+getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]
+-- Allocate a fresh kind variable for each TyCon and Class
+-- For each tycon, return a TcTyCon with kind k
+-- where k is the kind of tc, derived from the LHS
+--         of the definition (and probably including
+--         kind unification variables)
+--      Example: data T a b = ...
+--      return (T, kv1 -> kv2 -> kv3)
+--
+-- This pass deals with (ie incorporates into the kind it produces)
+--   * The kind signatures on type-variable binders
+--   * The result kinds signature on a TyClDecl
+--
+-- No family instances are passed to getInitialKinds
+
+getInitialKind cusk
+    (ClassDecl { tcdLName = dL->L _ name
+               , tcdTyVars = ktvs
+               , tcdATs = ats })
+  = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $
+                  return constraintKind
+       ; let parent_tv_prs = tcTyConScopedTyVars tycon
+            -- See Note [Don't process associated types in kcLHsQTyVars]
+       ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $
+                      getFamDeclInitialKinds cusk (Just tycon) ats
+       ; return (tycon : inner_tcs) }
+
+getInitialKind cusk
+    (DataDecl { tcdLName = dL->L _ name
+              , tcdTyVars = ktvs
+              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+                                         , dd_ND = new_or_data } })
+  = do  { let flav = newOrDataToFlavour new_or_data
+        ; tc <- kcLHsQTyVars name flav cusk ktvs $
+                case m_sig of
+                   Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig
+                   Nothing   -> return liftedTypeKind
+        ; return [tc] }
+
+getInitialKind cusk (FamDecl { tcdFam = decl })
+  = do { tc <- getFamDeclInitialKind cusk Nothing decl
+       ; return [tc] }
+
+getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
+                             , tcdTyVars = ktvs
+                             , tcdRhs = rhs })
+  = do  { cusks_enabled <- xoptM LangExt.CUSKs
+        ; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
+                   case kind_annotation cusks_enabled rhs of
+                     Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
+                     Nothing -> newMetaKindVar
+        ; return [tycon] }
+  where
+    -- Keep this synchronized with 'hsDeclHasCusk'.
+    kind_annotation
+      :: Bool           --  cusks_enabled?
+      -> LHsType GhcRn  --  rhs
+      -> Maybe (LHsKind GhcRn)
+    kind_annotation False = const Nothing
+    kind_annotation True = go
+      where
+        go (dL->L _ ty) = case ty of
+          HsParTy _ lty     -> go lty
+          HsKindSig _ _ k   -> Just k
+          _                 -> Nothing
+
+getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
+getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
+
+---------------------------------
+getFamDeclInitialKinds
+  :: Bool        -- ^ True <=> cusk
+  -> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls
+  -> [LFamilyDecl GhcRn]
+  -> TcM [TcTyCon]
+getFamDeclInitialKinds cusk mb_parent_tycon decls
+  = mapM (addLocM (getFamDeclInitialKind cusk mb_parent_tycon)) decls
+
+getFamDeclInitialKind
+  :: Bool        -- ^ True <=> cusk
+  -> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls
+  -> FamilyDecl GhcRn
+  -> TcM TcTyCon
+getFamDeclInitialKind parent_cusk mb_parent_tycon
+    decl@(FamilyDecl { fdLName     = (dL->L _ name)
+                     , fdTyVars    = ktvs
+                     , fdResultSig = (dL->L _ resultSig)
+                     , fdInfo      = info })
+  = do { cusks_enabled <- xoptM LangExt.CUSKs
+       ; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $
+         case resultSig of
+           KindSig _ ki                              -> tcLHsKindSig ctxt ki
+           TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
+           _ -- open type families have * return kind by default
+             | tcFlavourIsOpen flav              -> return liftedTypeKind
+                    -- closed type families have their return kind inferred
+                    -- by default
+             | otherwise                         -> newMetaKindVar
+       }
+  where
+    assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk
+    fam_cusk cusks_enabled = famDeclHasCusk cusks_enabled assoc_with_no_cusk decl
+    flav = case info of
+      DataFamily         -> DataFamilyFlavour mb_parent_tycon
+      OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon
+      ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )
+                            ClosedTypeFamilyFlavour
+    ctxt  = TyFamResKindCtxt name
+getFamDeclInitialKind _ _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
+
+------------------------------------------------------------------------
+kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
+  -- See Note [Kind checking for type and class decls]
+kcLTyClDecl (dL->L loc decl)
+  = setSrcSpan loc $
+    tcAddDeclCtxt decl $
+    do { traceTc "kcTyClDecl {" (ppr tc_name)
+       ; kcTyClDecl decl
+       ; traceTc "kcTyClDecl done }" (ppr tc_name) }
+  where
+    tc_name = tyClDeclLName decl
+
+kcTyClDecl :: TyClDecl GhcRn -> TcM ()
+-- This function is used solely for its side effect on kind variables
+-- NB kind signatures on the type variables and
+--    result kind signature have already been dealt with
+--    by getInitialKind, so we can ignore them here.
+
+kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)
+                     , tcdDataDefn = defn })
+  | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)
+               , dd_ctxt = (dL->L _ []) } <- defn
+  = mapM_ (wrapLocM_ kcConDecl) cons
+    -- hs_tvs and dd_kindSig already dealt with in getInitialKind
+    -- This must be a GADT-style decl,
+    --        (see invariants of DataDefn declaration)
+    -- so (a) we don't need to bring the hs_tvs into scope, because the
+    --        ConDecls bind all their own variables
+    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it
+
+  | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn
+  = bindTyClTyVars name $ \ _ _ ->
+    do  { _ <- tcHsContext ctxt
+        ; mapM_ (wrapLocM_ kcConDecl) cons }
+
+kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })
+  = bindTyClTyVars name $ \ _ res_kind ->
+    discardResult $ tcCheckLHsType rhs res_kind
+        -- NB: check against the result kind that we allocated
+        -- in getInitialKinds.
+
+kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)
+                      , tcdCtxt = ctxt, tcdSigs = sigs })
+  = bindTyClTyVars name $ \ _ _ ->
+    do  { _ <- tcHsContext ctxt
+        ; mapM_ (wrapLocM_ kc_sig) sigs }
+  where
+    kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty
+    kc_sig _                          = return ()
+
+kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = (dL->L _ fam_tc_name)
+                                  , fdInfo   = fd_info }))
+-- closed type families look at their equations, but other families don't
+-- do anything here
+  = case fd_info of
+      ClosedTypeFamily (Just eqns) ->
+        do { fam_tc <- kcLookupTcTyCon fam_tc_name
+           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }
+      _ -> return ()
+kcTyClDecl (FamDecl _ (XFamilyDecl _))              = panic "kcTyClDecl"
+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl"
+kcTyClDecl (XTyClDecl _)                            = panic "kcTyClDecl"
+
+-------------------
+kcConDecl :: ConDecl GhcRn -> TcM ()
+kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                      , con_mb_cxt = ex_ctxt, con_args = args })
+  = addErrCtxt (dataConCtxtName [name]) $
+    discardResult                   $
+    bindExplicitTKBndrs_Tv ex_tvs $
+    do { _ <- tcHsMbContext ex_ctxt
+       ; traceTc "kcConDecl {" (ppr name $$ ppr args)
+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+       ; traceTc "kcConDecl }" (ppr name)
+       }
+              -- We don't need to check the telescope here, because that's
+              -- done in tcConDecl
+
+kcConDecl (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs, con_mb_cxt = cxt
+                       , con_args = args, con_res_ty = res_ty })
+  | HsQTvs { hsq_ext = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = -- Even though the data constructor's type is closed, we
+    -- must still kind-check the type, because that may influence
+    -- the inferred kind of the /type/ constructor.  Example:
+    --    data T f a where
+    --      MkT :: f a -> T f a
+    -- If we don't look at MkT we won't get the correct kind
+    -- for the type constructor T
+    addErrCtxt (dataConCtxtName names) $
+    discardResult $
+    bindImplicitTKBndrs_Tv implicit_tkv_nms $
+    bindExplicitTKBndrs_Tv explicit_tkv_nms $
+        -- Why "_Tv"?  See Note [Kind-checking for GADTs]
+    do { _ <- tcHsMbContext cxt
+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+       ; _ <- tcHsOpenType res_ty
+       ; return () }
+kcConDecl (XConDecl _) = panic "kcConDecl"
+kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl"
+
+{-
+Note [Recursion and promoting data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't want to allow promotion in a strongly connected component
+when kind checking.
+
+Consider:
+  data T f = K (f (K Any))
+
+When kind checking the `data T' declaration the local env contains the
+mappings:
+  T -> ATcTyCon <some initial kind>
+  K -> APromotionErr
+
+APromotionErr is only used for DataCons, and only used during type checking
+in tcTyClGroup.
+
+Note [Kind-checking for GADTs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data Proxy a where
+    MkProxy1 :: forall k (b :: k). Proxy b
+    MkProxy2 :: forall j (c :: j). Proxy c
+
+It seems reasonable that this should be accepted. But something very strange
+is going on here: when we're kind-checking this declaration, we need to unify
+the kind of `a` with k and j -- even though k and j's scopes are local to the type of
+MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during
+the kind-checking pass. First off, note that it's OK if the kind-checking pass
+is too permissive: we'll snag the problems in the type-checking pass later.
+(This extra permissiveness might happen with something like
+
+  data SameKind :: k -> k -> Type
+  data Bad a where
+    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)
+
+which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected
+in the second pass, though. Test case: polykinds/TyVarTvKinds3)
+Recall that the kind-checking pass exists solely to collect constraints
+on the kinds and to power unification.
+
+To achieve the use of TyVarTvs, we must be careful to use specialized functions
+that produce TyVarTvs, not ordinary skolems. This is why we need
+kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their
+tc... variants.
+
+The drawback of this approach is sometimes it will accept a definition that
+a (hypothetical) declarative specification would likely reject. As a general
+rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,
+the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs
+approach allows a limited form of polymorphic recursion *without* a CUSK.
+
+To wit:
+  data T a = forall k (b :: k). MkT (T b) Int
+  (test case: dependent/should_compile/T14066a)
+
+Note that this is polymorphically recursive, with the recursive occurrence
+of T used at a kind other than a's kind. The approach outlined here accepts
+this definition, because this kind is still a kind variable (and so the
+TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a
+way to describe exactly what declarations will be accepted and which will
+be rejected (without a CUSK). However, the accepted definitions are indeed
+well-kinded and any rejected definitions would be accepted with a CUSK,
+and so this wrinkle need not cause anyone to lose sleep.
+
+************************************************************************
+*                                                                      *
+\subsection{Type checking}
+*                                                                      *
+************************************************************************
+
+Note [Type checking recursive type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At this point we have completed *kind-checking* of a mutually
+recursive group of type/class decls (done in kcTyClGroup). However,
+we discarded the kind-checked types (eg RHSs of data type decls);
+note that kcTyClDecl returns ().  There are two reasons:
+
+  * It's convenient, because we don't have to rebuild a
+    kinded HsDecl (a fairly elaborate type)
+
+  * It's necessary, because after kind-generalisation, the
+    TyCons/Classes may now be kind-polymorphic, and hence need
+    to be given kind arguments.
+
+Example:
+       data T f a = MkT (f a) (T f a)
+During kind-checking, we give T the kind T :: k1 -> k2 -> *
+and figure out constraints on k1, k2 etc. Then we generalise
+to get   T :: forall k. (k->*) -> k -> *
+So now the (T f a) in the RHS must be elaborated to (T k f a).
+
+However, during tcTyClDecl of T (above) we will be in a recursive
+"knot". So we aren't allowed to look at the TyCon T itself; we are only
+allowed to put it (lazily) in the returned structures.  But when
+kind-checking the RHS of T's decl, we *do* need to know T's kind (so
+that we can correctly elaboarate (T k f a).  How can we get T's kind
+without looking at T?  Delicate answer: during tcTyClDecl, we extend
+
+  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)
+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)
+
+Then:
+
+  * During TcHsType.tcTyVar we look in the *local* env, to get the
+    fully-known, not knot-tied TcTyCon for T.
+
+  * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular)
+    we look in the *global* env to get the TyCon.
+
+This fancy footwork (with two bindings for T) is only necessary for the
+TyCons or Classes of this recursive group.  Earlier, finished groups,
+live in the global env only.
+
+See also Note [Kind checking recursive type and class declarations]
+
+Note [Kind checking recursive type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before we can type-check the decls, we must kind check them. This
+is done by establishing an "initial kind", which is a rather uninformed
+guess at a tycon's kind (by counting arguments, mainly) and then
+using this initial kind for recursive occurrences.
+
+The initial kind is stored in exactly the same way during
+kind-checking as it is during type-checking (Note [Type checking
+recursive type and class declarations]): in the *local* environment,
+with ATcTyCon. But we still must store *something* in the *global*
+environment. Even though we discard the result of kind-checking, we
+sometimes need to produce error messages. These error messages will
+want to refer to the tycons being checked, except that they don't
+exist yet, and it would be Terribly Annoying to get the error messages
+to refer back to HsSyn. So we create a TcTyCon and put it in the
+global env. This tycon can print out its name and knows its kind, but
+any other action taken on it will panic. Note that TcTyCons are *not*
+knot-tied, unlike the rather valid but knot-tied ones that occur
+during type-checking.
+
+Note [Declarations for wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For wired-in things we simply ignore the declaration
+and take the wired-in information.  That avoids complications.
+e.g. the need to make the data constructor worker name for
+     a constraint tuple match the wired-in one
+-}
+
+tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon
+tcTyClDecl roles_info (dL->L loc decl)
+  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)
+  = case thing of -- See Note [Declarations for wired-in things]
+      ATyCon tc -> return tc
+      _ -> pprPanic "tcTyClDecl" (ppr thing)
+
+  | otherwise
+  = setSrcSpan loc $ tcAddDeclCtxt decl $
+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
+       ; tc <- tcTyClDecl1 Nothing roles_info decl
+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
+       ; return tc }
+
+  -- "type family" declarations
+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon
+tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })
+  = tcFamDecl1 parent fd
+
+  -- "type" synonym declaration
+tcTyClDecl1 _parent roles_info
+            (SynDecl { tcdLName = (dL->L _ tc_name)
+                     , tcdRhs   = rhs })
+  = ASSERT( isNothing _parent )
+    bindTyClTyVars tc_name $ \ binders res_kind ->
+    tcTySynRhs roles_info tc_name binders res_kind rhs
+
+  -- "data/newtype" declaration
+tcTyClDecl1 _parent roles_info
+            (DataDecl { tcdLName = (dL->L _ tc_name)
+                      , tcdDataDefn = defn })
+  = ASSERT( isNothing _parent )
+    bindTyClTyVars tc_name $ \ tycon_binders res_kind ->
+    tcDataDefn roles_info tc_name tycon_binders res_kind defn
+
+tcTyClDecl1 _parent roles_info
+            (ClassDecl { tcdLName = (dL->L _ class_name)
+                       , tcdCtxt = hs_ctxt
+                       , tcdMeths = meths
+                       , tcdFDs = fundeps
+                       , tcdSigs = sigs
+                       , tcdATs = ats
+                       , tcdATDefs = at_defs })
+  = ASSERT( isNothing _parent )
+    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt
+                              meths fundeps sigs ats at_defs
+       ; return (classTyCon clas) }
+
+tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1"
+
+
+{- *********************************************************************
+*                                                                      *
+          Class declarations
+*                                                                      *
+********************************************************************* -}
+
+tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn
+             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
+             -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]
+             -> TcM Class
+tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
+  = fixM $ \ clas ->
+    -- We need the knot because 'clas' is passed into tcClassATs
+    bindTyClTyVars class_name $ \ binders res_kind ->
+    do { MASSERT2( tcIsConstraintKind res_kind
+                 , ppr class_name $$ ppr res_kind )
+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)
+       ; let tycon_name = class_name        -- We use the same name
+             roles = roles_info tycon_name  -- for TyCon and Class
+
+       ; (ctxt, fds, sig_stuff, at_stuff)
+            <- pushTcLevelM_   $
+               solveEqualities $
+               do { ctxt <- tcHsContext hs_ctxt
+                  ; fds  <- mapM (addLocM tc_fundep) fundeps
+                  ; sig_stuff <- tcClassSigs class_name sigs meths
+                  ; at_stuff  <- tcClassATs class_name clas ats at_defs
+                  ; return (ctxt, fds, sig_stuff, at_stuff) }
+
+       -- The solveEqualities will report errors for any
+       -- unsolved equalities, so these zonks should not encounter
+       -- any unfilled coercion variables unless there is such an error
+       -- The zonk also squeeze out the TcTyCons, and converts
+       -- Skolems to tyvars.
+       ; ze        <- emptyZonkEnv
+       ; ctxt      <- zonkTcTypesToTypesX ze ctxt
+       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff
+         -- ToDo: do we need to zonk at_stuff?
+
+       -- TODO: Allow us to distinguish between abstract class,
+       -- and concrete class with no methods (maybe by
+       -- specifying a trailing where or not
+
+       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
+       ; is_boot <- tcIsHsBootOrSig
+       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff
+                  = Nothing
+                  | otherwise
+                  = Just (ctxt, at_stuff, sig_stuff, mindef)
+
+       ; clas <- buildClass class_name binders roles fds body
+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$
+                                ppr fds)
+       ; return clas }
+  where
+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
+                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
+                                ; return (tvs1', tvs2') }
+
+
+{- Note [Associated type defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The following is an example of associated type defaults:
+             class C a where
+               data D a
+
+               type F a b :: *
+               type F a b = [a]        -- Default
+
+Note that we can get default definitions only for type families, not data
+families.
+-}
+
+tcClassATs :: Name                    -- The class name (not knot-tied)
+           -> Class                   -- The class parent of this associated type
+           -> [LFamilyDecl GhcRn]     -- Associated types.
+           -> [LTyFamDefltDecl GhcRn] -- Associated type defaults.
+           -> TcM [ClassATItem]
+tcClassATs class_name cls ats at_defs
+  = do {  -- Complain about associated type defaults for non associated-types
+         sequence_ [ failWithTc (badATErr class_name n)
+                   | n <- map at_def_tycon at_defs
+                   , not (n `elemNameSet` at_names) ]
+       ; mapM tc_at ats }
+  where
+    at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
+    at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn
+
+    at_fam_name :: LFamilyDecl GhcRn -> Name
+    at_fam_name (dL->L _ decl) = unLoc (fdLName decl)
+
+    at_names = mkNameSet (map at_fam_name ats)
+
+    at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
+                                          (at_def_tycon at_def) [at_def])
+                        emptyNameEnv at_defs
+
+    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at
+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
+                                  `orElse` []
+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs
+                  ; return (ATI fam_tc atd) }
+
+-------------------------
+tcDefaultAssocDecl ::
+     TyCon                                -- ^ Family TyCon (not knot-tied)
+  -> [LTyFamDefltDecl GhcRn]              -- ^ Defaults
+  -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS
+tcDefaultAssocDecl _ []
+  = return Nothing  -- No default declaration
+
+tcDefaultAssocDecl _ (d1:_:_)
+  = failWithTc (text "More than one default declaration for"
+                <+> ppr (tyFamInstDeclName (unLoc d1)))
+
+tcDefaultAssocDecl fam_tc
+  [dL->L loc (TyFamInstDecl { tfid_eqn =
+         HsIB { hsib_ext  = imp_vars
+              , hsib_body = FamEqn { feqn_tycon = L _ tc_name
+                                   , feqn_bndrs = mb_expl_bndrs
+                                   , feqn_pats  = hs_pats
+                                   , feqn_rhs   = hs_rhs_ty }}})]
+  = -- See Note [Type-checking default assoc decls]
+    setSrcSpan loc $
+    tcAddFamInstCtxt (text "default type instance") tc_name $
+    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)
+       ; let fam_tc_name = tyConName fam_tc
+             vis_arity = length (tyConVisibleTyVars fam_tc)
+             vis_pats  = numVisibleArgs hs_pats
+
+       -- Kind of family check
+       ; ASSERT( fam_tc_name == tc_name )
+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+
+       -- Arity check
+       ; checkTc (vis_pats == vis_arity)
+                 (wrongNumberOfParmsErr vis_arity)
+
+       -- Typecheck RHS
+       --
+       -- You might think we should pass in some AssocInstInfo, as we're looking
+       -- at an associated type. But this would be wrong, because an associated
+       -- type default LHS can mention *different* type variables than the
+       -- enclosing class. So it's treated more as a freestanding beast.
+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated
+                                                    imp_vars (mb_expl_bndrs `orElse` [])
+                                                    hs_pats hs_rhs_ty
+
+       ; let fam_tvs  = tyConTyVars fam_tc
+             ppr_eqn  = ppr_default_eqn pats rhs_ty
+             pats_vis = tyConArgFlags fam_tc pats
+       ; traceTc "tcDefaultAssocDecl 2" (vcat
+           [ text "fam_tvs" <+> ppr fam_tvs
+           , text "qtvs"    <+> ppr qtvs
+           , text "pats"    <+> ppr pats
+           , text "rhs_ty"  <+> ppr rhs_ty
+           ])
+       ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
+       ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis
+       ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)
+       ; pure $ Just (substTyUnchecked subst rhs_ty, loc)
+           -- We also perform other checks for well-formedness and validity
+           -- later, in checkValidClass
+     }
+  where
+    -- Checks that a pattern on the LHS of a default is a type
+    -- variable. If so, return the underlying type variable, and if
+    -- not, throw an error.
+    -- See Note [Type-checking default assoc decls]
+    extract_tv :: SDoc    -- The pretty-printed default equation
+                          -- (only used for error message purposes)
+               -> Type    -- The particular type pattern from which to extract
+                          -- its underlying type variable
+               -> ArgFlag -- The visibility of the type pattern
+                          -- (only used for error message purposes)
+               -> TcM TyVar
+    extract_tv ppr_eqn pat pat_vis =
+      case getTyVar_maybe pat of
+        Just tv -> pure tv
+        Nothing -> failWithTc $
+          pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $
+          hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")
+             2 (vcat [ppr_eqn, suggestion])
+
+
+    -- Checks that no type variables in an associated default declaration are
+    -- duplicated. If that is the case, throw an error.
+    -- See Note [Type-checking default assoc decls]
+    check_all_distinct_tvs ::
+         SDoc               -- The pretty-printed default equation (only used
+                            -- for error message purposes)
+      -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated
+                            -- default declaration, along with their respective
+                            -- visibilities (the latter are only used for error
+                            -- message purposes)
+      -> TcM ()
+    check_all_distinct_tvs ppr_eqn pat_tvs_vis =
+      let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in
+      traverse_
+        (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $
+               pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $
+               hang (text "Illegal duplicate variable"
+                       <+> quotes (ppr pat_tv) <+> text "in:")
+                  2 (vcat [ppr_eqn, suggestion]))
+        dups
+
+    ppr_default_eqn :: [Type] -> Type -> SDoc
+    ppr_default_eqn pats rhs_ty =
+      quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)
+                <+> equals <+> ppr rhs_ty)
+
+    suggestion :: SDoc
+    suggestion = text "The arguments to" <+> quotes (ppr fam_tc)
+             <+> text "must all be distinct type variables"
+tcDefaultAssocDecl _ [_]
+  = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884
+
+
+{- Note [Type-checking default assoc decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this default declaration for an associated type
+
+   class C a where
+      type F (a :: k) b :: Type
+      type F (x :: j) y = Proxy x -> y
+
+Note that the class variable 'a' doesn't scope over the default assoc
+decl (rather oddly I think), and (less oddly) neither does the second
+argument 'b' of the associated type 'F', or the kind variable 'k'.
+Instead, the default decl is treated more like a top-level type
+instance.
+
+However we store the default rhs (Proxy x -> y) in F's TyCon, using
+F's own type variables, so we need to convert it to (Proxy a -> b).
+We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and
+applying this substitution to the RHS.
+
+In order to create this substitution, we must first ensure that all of
+the arguments in the default instance consist of distinct type variables.
+One might think that this is a simple task that could be implemented earlier
+in the compiler, perhaps in the parser or the renamer. However, there are some
+tricky corner cases that really do require the full power of typechecking to
+weed out, as the examples below should illustrate.
+
+First, we must check that all arguments are type variables. As a motivating
+example, consider this erroneous program (inspired by #11361):
+
+   class C a where
+      type F (a :: k) b :: Type
+      type F x        b = x
+
+If you squint, you'll notice that the kind of `x` is actually Type. However,
+we cannot substitute from [Type |-> k], so we reject this default.
+
+Next, we must check that all arguments are distinct. Here is another offending
+example, this time taken from #13971:
+
+   class C2 (a :: j) where
+      type F2 (a :: j) (b :: k)
+      type F2 (x :: z) y = SameKind x y
+   data SameKind :: k -> k -> Type
+
+All of the arguments in the default equation for `F2` are type variables, so
+that passes the first check. However, if we were to build this substitution,
+then both `j` and `k` map to `z`! In terms of visible kind application, it's as
+if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear
+that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is
+also rejected.
+
+Since the LHS of an associated type family default is always just variables,
+it won't contain any tycons. Accordingly, the patterns used in the substitution
+won't actually be knot-tied, even though we're in the knot. This is too
+delicate for my taste, but it works.
+-}
+
+{- *********************************************************************
+*                                                                      *
+          Type family declarations
+*                                                                      *
+********************************************************************* -}
+
+tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
+tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
+                              , fdLName = tc_lname@(dL->L _ tc_name)
+                              , fdResultSig = (dL->L _ sig)
+                              , fdInjectivityAnn = inj })
+  | DataFamily <- fam_info
+  = bindTyClTyVars tc_name $ \ binders res_kind -> do
+  { traceTc "data family:" (ppr tc_name)
+  ; checkFamFlag tc_name
+
+  -- Check that the result kind is OK
+  -- We allow things like
+  --   data family T (a :: Type) :: forall k. k -> Type
+  -- We treat T as having arity 1, but result kind forall k. k -> Type
+  -- But we want to check that the result kind finishes in
+  --   Type or a kind-variable
+  -- For the latter, consider
+  --   data family D a :: forall k. Type -> k
+  ; let (_, final_res_kind) = splitPiTys res_kind
+  ; checkTc (tcIsLiftedTypeKind final_res_kind
+             || isJust (tcGetCastedTyVar_maybe final_res_kind))
+            (badKindSig False res_kind)
+
+  ; tc_rep_name <- newTyConRepName tc_name
+  ; let tycon = mkFamilyTyCon tc_name binders
+                              res_kind
+                              (resultVariableName sig)
+                              (DataFamilyTyCon tc_rep_name)
+                              parent NotInjective
+  ; return tycon }
+
+  | OpenTypeFamily <- fam_info
+  = bindTyClTyVars tc_name $ \ binders res_kind -> do
+  { traceTc "open type family:" (ppr tc_name)
+  ; checkFamFlag tc_name
+  ; inj' <- tcInjectivity binders inj
+  ; let tycon = mkFamilyTyCon tc_name binders res_kind
+                               (resultVariableName sig) OpenSynFamilyTyCon
+                               parent inj'
+  ; return tycon }
+
+  | ClosedTypeFamily mb_eqns <- fam_info
+  = -- Closed type families are a little tricky, because they contain the definition
+    -- of both the type family and the equations for a CoAxiom.
+    do { traceTc "Closed type family:" (ppr tc_name)
+         -- the variables in the header scope only over the injectivity
+         -- declaration but this is not involved here
+       ; (inj', binders, res_kind)
+            <- bindTyClTyVars tc_name $ \ binders res_kind ->
+               do { inj' <- tcInjectivity binders inj
+                  ; return (inj', binders, res_kind) }
+
+       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies
+
+         -- If Nothing, this is an abstract family in a hs-boot file;
+         -- but eqns might be empty in the Just case as well
+       ; case mb_eqns of
+           Nothing   ->
+               return $ mkFamilyTyCon tc_name binders res_kind
+                                      (resultVariableName sig)
+                                      AbstractClosedSynFamilyTyCon parent
+                                      inj'
+           Just eqns -> do {
+
+         -- Process the equations, creating CoAxBranches
+       ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind
+                                   [] False {- this doesn't matter here -}
+                                   ClosedTypeFamilyFlavour
+
+       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns
+         -- Do not attempt to drop equations dominated by earlier
+         -- ones here; in the case of mutual recursion with a data
+         -- type, we get a knot-tying failure.  Instead we check
+         -- for this afterwards, in TcValidity.checkValidCoAxiom
+         -- Example: tc265
+
+         -- Create a CoAxiom, with the correct src location.
+       ; co_ax_name <- newFamInstAxiomName tc_lname []
+
+       ; let mb_co_ax
+              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list
+              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
+
+             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)
+                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'
+
+         -- We check for instance validity later, when doing validity
+         -- checking for the tycon. Exception: checking equations
+         -- overlap done by dropDominatedAxioms
+       ; return fam_tc } }
+
+  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker
+tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1"
+
+-- | Maybe return a list of Bools that say whether a type family was declared
+-- injective in the corresponding type arguments. Length of the list is equal to
+-- the number of arguments (including implicit kind/coercion arguments).
+-- True on position
+-- N means that a function is injective in its Nth argument. False means it is
+-- not.
+tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)
+              -> TcM Injectivity
+tcInjectivity _ Nothing
+  = return NotInjective
+
+  -- User provided an injectivity annotation, so for each tyvar argument we
+  -- check whether a type family was declared injective in that argument. We
+  -- return a list of Bools, where True means that corresponding type variable
+  -- was mentioned in lInjNames (type family is injective in that argument) and
+  -- False means that it was not mentioned in lInjNames (type family is not
+  -- injective in that type variable). We also extend injectivity information to
+  -- kind variables, so if a user declares:
+  --
+  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a
+  --
+  -- then we mark both `a` and `k1` as injective.
+  -- NB: the return kind is considered to be *input* argument to a type family.
+  -- Since injectivity allows to infer input arguments from the result in theory
+  -- we should always mark the result kind variable (`k3` in this example) as
+  -- injective.  The reason is that result type has always an assigned kind and
+  -- therefore we can always infer the result kind if we know the result type.
+  -- But this does not seem to be useful in any way so we don't do it.  (Another
+  -- reason is that the implementation would not be straightforward.)
+tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames)))
+  = setSrcSpan loc $
+    do { let tvs = binderVars tcbs
+       ; dflags <- getDynFlags
+       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)
+                 (text "Illegal injectivity annotation" $$
+                  text "Use TypeFamilyDependencies to allow this")
+       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames
+       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds
+       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars
+                        closeOverKinds (mkVarSet inj_tvs)
+       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs
+       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs
+                                       , ppr inj_ktvs, ppr inj_bools ])
+       ; return $ Injective inj_bools }
+
+tcTySynRhs :: RolesInfo
+           -> Name
+           -> [TyConBinder] -> Kind
+           -> LHsType GhcRn -> TcM TyCon
+tcTySynRhs roles_info tc_name binders res_kind hs_ty
+  = do { env <- getLclEnv
+       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
+       ; rhs_ty <- pushTcLevelM_   $
+                   solveEqualities $
+                   tcCheckLHsType hs_ty res_kind
+       ; rhs_ty <- zonkTcTypeToType rhs_ty
+       ; let roles = roles_info tc_name
+             tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty
+       ; return tycon }
+
+tcDataDefn :: RolesInfo -> Name
+           -> [TyConBinder] -> Kind
+           -> HsDataDefn GhcRn -> TcM TyCon
+  -- NB: not used for newtype/data instances (whether associated or not)
+tcDataDefn roles_info
+           tc_name tycon_binders res_kind
+           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                       , dd_ctxt = ctxt
+                       , dd_kindSig = mb_ksig  -- Already in tc's kind
+                                               -- via getInitialKinds
+                       , dd_cons = cons })
+ =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons
+
+       ; tcg_env <- getGblEnv
+       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind
+
+       ; let hsc_src = tcg_src tcg_env
+       ; unless (mk_permissive_kind hsc_src cons) $
+         checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)
+
+       ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt
+       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta
+       ; kind_signatures <- xoptM LangExt.KindSignatures
+
+             -- Check that we don't use kind signatures without Glasgow extensions
+       ; when (isJust mb_ksig) $
+         checkTc (kind_signatures) (badSigTyDecl tc_name)
+
+       ; tycon <- fixM $ \ tycon -> do
+             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs
+                   res_ty      = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))
+                   roles       = roles_info tc_name
+
+             ; data_cons <- tcConDecls tycon final_bndrs res_ty cons
+             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons
+             ; tc_rep_nm <- newTyConRepName tc_name
+             ; return (mkAlgTyCon tc_name
+                                  final_bndrs
+                                  final_res_kind
+                                  roles
+                                  (fmap unLoc cType)
+                                  stupid_theta tc_rhs
+                                  (VanillaAlgTyCon tc_rep_nm)
+                                  gadt_syntax) }
+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)
+       ; return tycon }
+  where
+    -- Abstract data types in hsig files can have arbitrary kinds,
+    -- because they may be implemented by type synonyms
+    -- (which themselves can have arbitrary kinds, not just *)
+    mk_permissive_kind HsigFile [] = True
+    mk_permissive_kind _ _ = False
+
+    -- In hs-boot, a 'data' declaration with no constructors
+    -- indicates a nominally distinct abstract data type.
+    mk_tc_rhs HsBootFile _ []
+      = return AbstractTyCon
+
+    mk_tc_rhs HsigFile _ [] -- ditto
+      = return AbstractTyCon
+
+    mk_tc_rhs _ tycon data_cons
+      = case new_or_data of
+          DataType -> return (mkDataTyConRhs data_cons)
+          NewType  -> ASSERT( not (null data_cons) )
+                      mkNewTyConRhs tc_name tycon (head data_cons)
+tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"
+
+
+-------------------------
+kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
+-- Used for the equations of a closed type family only
+-- Not used for data/type instances
+kcTyFamInstEqn tc_fam_tc
+    (dL->L loc (HsIB { hsib_ext = imp_vars
+                     , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name
+                                          , feqn_bndrs = mb_expl_bndrs
+                                          , feqn_pats  = hs_pats
+                                          , feqn_rhs   = hs_rhs_ty }}))
+  = setSrcSpan loc $
+    do { traceTc "kcTyFamInstEqn" (vcat
+           [ text "tc_name ="    <+> ppr eqn_tc_name
+           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
+           , text "hsib_vars ="  <+> ppr imp_vars
+           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
+           , text "feqn_pats ="  <+> ppr hs_pats ])
+          -- this check reports an arity error instead of a kind error; easier for user
+       ; let vis_pats = numVisibleArgs hs_pats
+       ; checkTc (vis_pats == vis_arity) $
+                  wrongNumberOfParmsErr vis_arity
+       ; discardResult $
+         bindImplicitTKBndrs_Q_Tv imp_vars $
+         bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
+         do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
+            ; tcCheckLHsType hs_rhs_ty res_kind }
+             -- Why "_Tv" here?  Consider (#14066
+             --  type family Bar x y where
+             --      Bar (x :: a) (y :: b) = Int
+             --      Bar (x :: c) (y :: d) = Bool
+             -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately
+    }
+  where
+    vis_arity = length (tyConVisibleTyVars tc_fam_tc)
+
+kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"
+kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn"
+kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884
+
+
+--------------------------
+tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
+               -> TcM (KnotTied CoAxBranch)
+-- Needs to be here, not in TcInstDcls, because closed families
+-- (typechecked here) have TyFamInstEqns
+
+tcTyFamInstEqn fam_tc mb_clsinfo
+    (dL->L loc (HsIB { hsib_ext = imp_vars
+                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
+                                      , feqn_bndrs  = mb_expl_bndrs
+                                      , feqn_pats   = hs_pats
+                                      , feqn_rhs    = hs_rhs_ty }}))
+  = ASSERT( getName fam_tc == eqn_tc_name )
+    setSrcSpan loc $
+    do {
+       -- First, check the arity of visible arguments
+       -- If we wait until validity checking, we'll get kind errors
+       -- below when an arity error will be much easier to understand.
+       ; let vis_arity = length (tyConVisibleTyVars fam_tc)
+             vis_pats  = numVisibleArgs hs_pats
+       ; checkTc (vis_pats == vis_arity) $
+         wrongNumberOfParmsErr vis_arity
+
+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo
+                                      imp_vars (mb_expl_bndrs `orElse` [])
+                                      hs_pats hs_rhs_ty
+
+       -- Don't print results they may be knot-tied
+       -- (tcFamInstEqnGuts zonks to Type)
+       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty
+                              (map (const Nominal) qtvs)
+                              loc) }
+
+tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"
+
+{-
+Kind check type patterns and kind annotate the embedded type variables.
+     type instance F [a] = rhs
+
+ * Here we check that a type instance matches its kind signature, but we do
+   not check whether there is a pattern for each type index; the latter
+   check is only required for type synonym instances.
+
+Note [Instantiating a family tycon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's possible that kind-checking the result of a family tycon applied to
+its patterns will instantiate the tycon further. For example, we might
+have
+
+  type family F :: k where
+    F = Int
+    F = Maybe
+
+After checking (F :: forall k. k) (with no visible patterns), we still need
+to instantiate the k. With data family instances, this problem can be even
+more intricate, due to Note [Arity of data families] in FamInstEnv. See
+indexed-types/should_compile/T12369 for an example.
+
+So, the kind-checker must return the new skolems and args (that is, Type
+or (Type -> Type) for the equations above) and the instantiated kind.
+
+Note [Generalising in tcFamTyPatsGuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have something like
+  type instance forall (a::k) b. F t1 t2 = rhs
+
+Then  imp_vars = [k], exp_bndrs = [a::k, b]
+
+We want to quantify over
+  * k, a, and b  (all user-specified)
+  * and any inferred free kind vars from
+      - the kinds of k, a, b
+      - the types t1, t2
+
+However, unlike a type signature like
+  f :: forall (a::k). blah
+
+we do /not/ care about the Inferred/Specified designation
+or order for the final quantified tyvars.  Type-family
+instances are not invoked directly in Haskell source code,
+so visible type application etc plays no role.
+
+So, the simple thing is
+   - gather candiates from [k, a, b] and pats
+   - quantify over them
+
+Hence the sligtly mysterious call:
+    candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)
+
+Simple, neat, but a little non-obvious!
+-}
+
+--------------------------
+tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
+                   -> [Name] -> [LHsTyVarBndr GhcRn]  -- Implicit and explicicit binder
+                   -> HsTyPats GhcRn                  -- Patterns
+                   -> LHsType GhcRn                   -- RHS
+                   -> TcM ([TyVar], [TcType], TcType)      -- (tyvars, pats, rhs)
+-- Used only for type families, not data families
+tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
+  = do { traceTc "tcTyFamInstEqnGuts {" (vcat [ ppr fam_tc <+> ppr hs_pats ])
+
+       -- By now, for type families (but not data families) we should
+       -- have checked that the number of patterns matches tyConArity
+
+       -- This code is closely related to the code
+       -- in TcHsType.kcLHsQTyVars_Cusk
+       ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))
+               <- pushTcLevelM_                                $
+                  solveEqualities                              $
+                  bindImplicitTKBndrs_Q_Skol imp_vars          $
+                  bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+                  do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
+                       -- Ensure that the instance is consistent with its
+                       -- parent class (#16008)
+                     ; addConsistencyConstraints mb_clsinfo lhs_ty
+                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind
+                     ; return (lhs_ty, rhs_ty) }
+
+       -- See Note [Generalising in tcFamTyPatsGuts]
+       -- This code (and the stuff immediately above) is very similar
+       -- to that in tcDataFamHeader.  Maybe we should abstract the
+       -- common code; but for the moment I concluded that it's
+       -- clearer to duplicate it.  Still, if you fix a bug here,
+       -- check there too!
+       ; let scoped_tvs = imp_tvs ++ exp_tvs
+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
+       ; qtvs <- quantifyTyVars emptyVarSet dvs
+
+       ; (ze, qtvs) <- zonkTyBndrs qtvs
+       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty
+       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty
+
+       ; let pats = unravelFamInstPats lhs_ty
+             -- Note that we do this after solveEqualities
+             -- so that any strange coercions inside lhs_ty
+             -- have been solved before we attempt to unravel it
+       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)
+       ; return (qtvs, pats, rhs_ty) }
+
+-----------------
+tcFamTyPats :: TyCon
+            -> HsTyPats GhcRn                -- Patterns
+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)
+-- Used for both type and data families
+tcFamTyPats fam_tc hs_pats
+  = do { traceTc "tcFamTyPats {" $
+         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]
+
+       ; let fun_ty = mkTyConApp fam_tc []
+
+       ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $
+                                setXOptM LangExt.PartialTypeSignatures $
+                                -- See Note [Wildcards in family instances] in
+                                -- RnSource.hs
+                                tcInferApps typeLevelMode lhs_fun fun_ty hs_pats
+
+       ; traceTc "End tcFamTyPats }" $
+         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]
+
+       ; return (fam_app, res_kind) }
+  where
+    fam_name  = tyConName fam_tc
+    fam_arity = tyConArity fam_tc
+    lhs_fun   = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))
+
+unravelFamInstPats :: TcType -> [TcType]
+-- Decompose fam_app to get the argument patterns
+--
+-- We expect fam_app to look like (F t1 .. tn)
+-- tcInferApps is capable of returning ((F ty1 |> co) ty2),
+-- but that can't happen here because we already checked the
+-- arity of F matches the number of pattern
+unravelFamInstPats fam_app
+  = case splitTyConApp_maybe fam_app of
+      Just (_, pats) -> pats
+      Nothing        -> WARN( True, bad_lhs fam_app ) []
+        -- The Nothing case cannot happen for type families, because
+        -- we don't call unravelFamInstPats until we've solved the
+        -- equalities.  For data families I wasn't quite as convinced
+        -- so I've let it as a warning rather than a panic.
+  where
+    bad_lhs fam_app
+      = hang (text "Ill-typed LHS of family instance")
+           2 (debugPprType fam_app)
+
+addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()
+-- In the corresponding positions of the class and type-family,
+-- ensure the the family argument is the same as the class argument
+--   E.g    class C a b c d where
+--             F c x y a :: Type
+-- Here the first  arg of F should be the same as the third of C
+--  and the fourth arg of F should be the same as the first of C
+--
+-- We emit /Derived/ constraints (a bit like fundeps) to encourage
+-- unification to happen, but without actually reporting errors.
+-- If, despite the efforts, corresponding positions do not match,
+-- checkConsistentFamInst will complain
+addConsistencyConstraints mb_clsinfo fam_app
+  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo
+  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app
+  = do { let eqs = [ (cls_ty, pat)
+                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats
+                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]
+       ; traceTc "addConsistencyConstraints" (ppr eqs)
+       ; emitDerivedEqs AssocFamPatOrigin eqs }
+    -- Improve inference
+    -- Any mis-match is reports by checkConsistentFamInst
+  | otherwise
+  = return ()
+
+{- Note [Constraints in patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: This isn't the whole story. See comment in tcFamTyPats.
+
+At first glance, it seems there is a complicated story to tell in tcFamTyPats
+around constraint solving. After all, type family patterns can now do
+GADT pattern-matching, which is jolly complicated. But, there's a key fact
+which makes this all simple: everything is at top level! There cannot
+be untouchable type variables. There can't be weird interaction between
+case branches. There can't be global skolems.
+
+This means that the semantics of type-level GADT matching is a little
+different than term level. If we have
+
+  data G a where
+    MkGBool :: G Bool
+
+And then
+
+  type family F (a :: G k) :: k
+  type instance F MkGBool = True
+
+we get
+
+  axF : F Bool (MkGBool <Bool>) ~ True
+
+Simple! No casting on the RHS, because we can affect the kind parameter
+to F.
+
+If we ever introduce local type families, this all gets a lot more
+complicated, and will end up looking awfully like term-level GADT
+pattern-matching.
+
+
+** The new story **
+
+Here is really what we want:
+
+The matcher really can't deal with covars in arbitrary spots in coercions.
+But it can deal with covars that are arguments to GADT data constructors.
+So we somehow want to allow covars only in precisely those spots, then use
+them as givens when checking the RHS. TODO (RAE): Implement plan.
+
+
+Note [Quantifying over family patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to quantify over two different lots of kind variables:
+
+First, the ones that come from the kinds of the tyvar args of
+tcTyVarBndrsKindGen, as usual
+  data family Dist a
+
+  -- Proxy :: forall k. k -> *
+  data instance Dist (Proxy a) = DP
+  -- Generates  data DistProxy = DP
+  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a
+  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)
+
+Second, the ones that come from the kind argument of the type family
+which we pick up using the (tyCoVarsOfTypes typats) in the result of
+the thing_inside of tcHsTyvarBndrsGen.
+  -- Any :: forall k. k
+  data instance Dist Any = DA
+  -- Generates  data DistAny k = DA
+  --            ax7 k :: Dist k (Any k) ~ DistAny k
+  -- The 'k' comes from kindGeneralizeKinds (Any k)
+
+Note [Quantified kind variables of a family pattern]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   type family KindFam (p :: k1) (q :: k1)
+           data T :: Maybe k1 -> k2 -> *
+           type instance KindFam (a :: Maybe k) b = T a b -> Int
+The HsBSig for the family patterns will be ([k], [a])
+
+Then in the family instance we want to
+  * Bring into scope [ "k" -> k:*, "a" -> a:k ]
+  * Kind-check the RHS
+  * Quantify the type instance over k and k', as well as a,b, thus
+       type instance [k, k', a:Maybe k, b:k']
+                     KindFam (Maybe k) k' a b = T k k' a b -> Int
+
+Notice that in the third step we quantify over all the visibly-mentioned
+type variables (a,b), but also over the implicitly mentioned kind variables
+(k, k').  In this case one is bound explicitly but often there will be
+none. The role of the kind signature (a :: Maybe k) is to add a constraint
+that 'a' must have that kind, and to bring 'k' into scope.
+
+
+
+************************************************************************
+*                                                                      *
+               Data types
+*                                                                      *
+************************************************************************
+-}
+
+dataDeclChecks :: Name -> NewOrData
+               -> LHsContext GhcRn -> [LConDecl GhcRn]
+               -> TcM Bool
+dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons
+  = do {   -- Check that we don't use GADT syntax in H98 world
+         gadtSyntax_ok <- xoptM LangExt.GADTSyntax
+       ; let gadt_syntax = consUseGadtSyntax cons
+       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)
+
+           -- Check that the stupid theta is empty for a GADT-style declaration
+       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)
+
+         -- Check that a newtype has exactly one constructor
+         -- Do this before checking for empty data decls, so that
+         -- we don't suggest -XEmptyDataDecls for newtypes
+       ; checkTc (new_or_data == DataType || isSingleton cons)
+                (newtypeConError tc_name (length cons))
+
+         -- Check that there's at least one condecl,
+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls
+       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls
+       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?
+       ; checkTc (not (null cons) || empty_data_decls || is_boot)
+                 (emptyConDeclsErr tc_name)
+       ; return gadt_syntax }
+
+
+-----------------------------------
+consUseGadtSyntax :: [LConDecl a] -> Bool
+consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True
+consUseGadtSyntax _                                = False
+                 -- All constructors have same shape
+
+-----------------------------------
+tcConDecls :: KnotTied TyCon -> [KnotTied TyConBinder] -> KnotTied Type
+           -> [LConDecl GhcRn] -> TcM [DataCon]
+  -- Why both the tycon tyvars and binders? Because the tyvars
+  -- have all the names and the binders have the visibilities.
+tcConDecls rep_tycon tmpl_bndrs res_tmpl
+  = concatMapM $ addLocM $
+    tcConDecl rep_tycon (mkTyConTagMap rep_tycon) tmpl_bndrs res_tmpl
+    -- It's important that we pay for tag allocation here, once per TyCon,
+    -- See Note [Constructor tag allocation], fixes #14657
+
+tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!
+          -> NameEnv ConTag
+          -> [KnotTied TyConBinder] -> KnotTied Type
+                 -- Return type template (with its template tyvars)
+                 --    (tvs, T tys), where T is the family TyCon
+          -> ConDecl GhcRn
+          -> TcM [DataCon]
+
+tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl
+          (ConDeclH98 { con_name = name
+                      , con_ex_tvs = explicit_tkv_nms
+                      , con_mb_cxt = hs_ctxt
+                      , con_args = hs_args })
+  = addErrCtxt (dataConCtxtName [name]) $
+    do { -- NB: the tyvars from the declaration header are in scope
+
+         -- Get hold of the existential type variables
+         -- e.g. data T a = forall k (b::k) f. MkT a (f b)
+         -- Here tmpl_bndrs = {a}
+         --      hs_qvars = HsQTvs { hsq_implicit = {k}
+         --                        , hsq_explicit = {f,b} }
+
+       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])
+
+       ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts))
+           <- pushTcLevelM_                             $
+              solveEqualities                           $
+              bindExplicitTKBndrs_Skol explicit_tkv_nms $
+              do { ctxt <- tcHsMbContext hs_ctxt
+                 ; btys <- tcConArgs hs_args
+                 ; field_lbls <- lookupConstructorFields (unLoc name)
+                 ; let (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, field_lbls, stricts)
+                 }
+
+         -- exp_tvs have explicit, user-written binding sites
+         -- the kvs below are those kind variables entirely unmentioned by the user
+         --   and discovered only by generalization
+
+       ; kvs <- kindGeneralize (mkSpecForAllTys (binderVars tmpl_bndrs) $
+                                mkSpecForAllTys exp_tvs $
+                                mkPhiTy ctxt $
+                                mkVisFunTys arg_tys $
+                                unitTy)
+                 -- That type is a lie, of course. (It shouldn't end in ()!)
+                 -- And we could construct a proper result type from the info
+                 -- at hand. But the result would mention only the tmpl_tvs,
+                 -- and so it just creates more work to do it right. Really,
+                 -- we're only doing this to find the right kind variables to
+                 -- quantify over, and this type is fine for that purpose.
+
+             -- Zonk to Types
+       ; (ze, qkvs)      <- zonkTyBndrs kvs
+       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs
+       ; arg_tys         <- zonkTcTypesToTypesX ze arg_tys
+       ; ctxt            <- zonkTcTypesToTypesX ze ctxt
+
+       ; fam_envs <- tcGetFamInstEnvs
+
+       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
+       ; let
+           univ_tvbs = tyConTyVarBinders tmpl_bndrs
+           univ_tvs  = binderVars univ_tvbs
+           ex_tvbs   = mkTyVarBinders Inferred qkvs ++
+                       mkTyVarBinders Specified user_qtvs
+           ex_tvs    = qkvs ++ user_qtvs
+           -- For H98 datatypes, the user-written tyvar binders are precisely
+           -- the universals followed by the existentials.
+           -- See Note [DataCon user type variable binders] in DataCon.
+           user_tvbs = univ_tvbs ++ ex_tvbs
+           buildOneDataCon (dL->L _ name) = do
+             { is_infix <- tcConIsInfixH98 name hs_args
+             ; rep_nm   <- newTyConRepName name
+
+             ; buildDataCon fam_envs name is_infix rep_nm
+                            stricts Nothing field_lbls
+                            univ_tvs ex_tvs user_tvbs
+                            [{- no eq_preds -}] ctxt arg_tys
+                            res_tmpl rep_tycon tag_map
+                  -- NB:  we put data_tc, the type constructor gotten from the
+                  --      constructor type signature into the data constructor;
+                  --      that way checkValidDataCon can complain if it's wrong.
+             }
+       ; traceTc "tcConDecl 2" (ppr name)
+       ; mapM buildOneDataCon [name]
+       }
+
+tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl
+          (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs
+                       , con_mb_cxt = cxt, con_args = hs_args
+                       , con_res_ty = hs_res_ty })
+  | HsQTvs { hsq_ext = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = addErrCtxt (dataConCtxtName names) $
+    do { traceTc "tcConDecl 1 gadt" (ppr names)
+       ; let ((dL->L _ name) : _) = names
+
+       ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
+           <- pushTcLevelM_    $  -- We are going to generalise
+              solveEqualities  $  -- We won't get another crack, and we don't
+                                  -- want an error cascade
+              bindImplicitTKBndrs_Skol implicit_tkv_nms $
+              bindExplicitTKBndrs_Skol explicit_tkv_nms $
+              do { ctxt <- tcHsMbContext cxt
+                 ; btys <- tcConArgs hs_args
+                 ; res_ty <- tcHsLiftedType hs_res_ty
+                 ; field_lbls <- lookupConstructorFields name
+                 ; let (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+                 }
+       ; imp_tvs <- zonkAndScopedSort imp_tvs
+       ; let user_tvs = imp_tvs ++ exp_tvs
+
+       ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $
+                                 mkPhiTy ctxt $
+                                 mkVisFunTys arg_tys $
+                                 res_ty)
+
+             -- Zonk to Types
+       ; (ze, tkvs)     <- zonkTyBndrs tkvs
+       ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs
+       ; arg_tys <- zonkTcTypesToTypesX ze arg_tys
+       ; ctxt    <- zonkTcTypesToTypesX ze ctxt
+       ; res_ty  <- zonkTcTypeToTypeX   ze res_ty
+
+       ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst)
+               = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty
+             -- NB: this is a /lazy/ binding, so we pass six thunks to
+             --     buildDataCon without yet forcing the guards in rejigConRes
+             -- See Note [Checking GADT return types]
+
+             -- Compute the user-written tyvar binders. These have the same
+             -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.
+             -- See Note [DataCon user type variable binders] in DataCon.
+             tkv_bndrs      = mkTyVarBinders Inferred  tkvs'
+             user_tv_bndrs  = mkTyVarBinders Specified user_tvs'
+             all_user_bndrs = tkv_bndrs ++ user_tv_bndrs
+
+             ctxt'      = substTys arg_subst ctxt
+             arg_tys'   = substTys arg_subst arg_tys
+             res_ty'    = substTy  arg_subst res_ty
+
+
+       ; fam_envs <- tcGetFamInstEnvs
+
+       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
+       ; let
+           buildOneDataCon (dL->L _ name) = do
+             { is_infix <- tcConIsInfixGADT name hs_args
+             ; rep_nm   <- newTyConRepName name
+
+             ; buildDataCon fam_envs name is_infix
+                            rep_nm
+                            stricts Nothing field_lbls
+                            univ_tvs ex_tvs all_user_bndrs eq_preds
+                            ctxt' arg_tys' res_ty' rep_tycon tag_map
+                  -- NB:  we put data_tc, the type constructor gotten from the
+                  --      constructor type signature into the data constructor;
+                  --      that way checkValidDataCon can complain if it's wrong.
+             }
+       ; traceTc "tcConDecl 2" (ppr names)
+       ; mapM buildOneDataCon names
+       }
+tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _)
+  = panic "tcConDecl"
+tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl"
+
+tcConIsInfixH98 :: Name
+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
+             -> TcM Bool
+tcConIsInfixH98 _   details
+  = case details of
+           InfixCon {}  -> return True
+           _            -> return False
+
+tcConIsInfixGADT :: Name
+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
+             -> TcM Bool
+tcConIsInfixGADT con details
+  = case details of
+           InfixCon {}  -> return True
+           RecCon {}    -> return False
+           PrefixCon arg_tys           -- See Note [Infix GADT constructors]
+               | isSymOcc (getOccName con)
+               , [_ty1,_ty2] <- arg_tys
+                  -> do { fix_env <- getFixityEnv
+                        ; return (con `elemNameEnv` fix_env) }
+               | otherwise -> return False
+
+tcConArgs :: HsConDeclDetails GhcRn
+          -> TcM [(TcType, HsSrcBang)]
+tcConArgs (PrefixCon btys)
+  = mapM tcConArg btys
+tcConArgs (InfixCon bty1 bty2)
+  = do { bty1' <- tcConArg bty1
+       ; bty2' <- tcConArg bty2
+       ; return [bty1', bty2'] }
+tcConArgs (RecCon fields)
+  = mapM tcConArg btys
+  where
+    -- We need a one-to-one mapping from field_names to btys
+    combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))
+                   (unLoc fields)
+    explode (ns,ty) = zip ns (repeat ty)
+    exploded = concatMap explode combined
+    (_,btys) = unzip exploded
+
+
+tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)
+tcConArg bty
+  = do  { traceTc "tcConArg 1" (ppr bty)
+        ; arg_ty <- tcHsOpenType (getBangType bty)
+             -- Newtypes can't have unboxed types, but we check
+             -- that in checkValidDataCon; this tcConArg stuff
+             -- doesn't happen for GADT-style declarations
+        ; traceTc "tcConArg 2" (ppr bty)
+        ; return (arg_ty, getBangStrictness bty) }
+
+{-
+Note [Infix GADT constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not currently have syntax to declare an infix constructor in GADT syntax,
+but it makes a (small) difference to the Show instance.  So as a slightly
+ad-hoc solution, we regard a GADT data constructor as infix if
+  a) it is an operator symbol
+  b) it has two arguments
+  c) there is a fixity declaration for it
+For example:
+   infix 6 (:--:)
+   data T a where
+     (:--:) :: t1 -> t2 -> T Int
+
+
+Note [Checking GADT return types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is a delicacy around checking the return types of a datacon. The
+central problem is dealing with a declaration like
+
+  data T a where
+    MkT :: T a -> Q a
+
+Note that the return type of MkT is totally bogus. When creating the T
+tycon, we also need to create the MkT datacon, which must have a "rejigged"
+return type. That is, the MkT datacon's type must be transformed to have
+a uniform return type with explicit coercions for GADT-like type parameters.
+This rejigging is what rejigConRes does. The problem is, though, that checking
+that the return type is appropriate is much easier when done over *Type*,
+not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully
+defined yet.
+
+So, we want to make rejigConRes lazy and then check the validity of
+the return type in checkValidDataCon.  To do this we /always/ return a
+6-tuple from rejigConRes (so that we can compute the return type from it, which
+checkValidDataCon needs), but the first three fields may be bogus if
+the return type isn't valid (the last equation for rejigConRes).
+
+This is better than an earlier solution which reduced the number of
+errors reported in one pass.  See #7175, and #10836.
+-}
+
+-- Example
+--   data instance T (b,c) where
+--      TI :: forall e. e -> T (e,e)
+--
+-- The representation tycon looks like this:
+--   data :R7T b c where
+--      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
+-- In this case orig_res_ty = T (e,e)
+
+rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.
+                                  -- data instance T [a] b c ...
+                                  --      gives template ([a,b,c], T [a] b c)
+                                  -- Type must be of kind *!
+            -> [TyVar]            -- The constructor's inferred type variables
+            -> [TyVar]            -- The constructor's user-written, specified
+                                  -- type variables
+            -> KnotTied Type      -- res_ty type must be of kind *
+            -> ([TyVar],          -- Universal
+                [TyVar],          -- Existential (distinct OccNames from univs)
+                [TyVar],          -- The constructor's rejigged, user-written,
+                                  -- inferred type variables
+                [TyVar],          -- The constructor's rejigged, user-written,
+                                  -- specified type variables
+                [EqSpec],      -- Equality predicates
+                TCvSubst)      -- Substitution to apply to argument types
+        -- We don't check that the TyCon given in the ResTy is
+        -- the same as the parent tycon, because checkValidDataCon will do it
+-- NB: All arguments may potentially be knot-tied
+rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty
+        -- E.g.  data T [a] b c where
+        --         MkT :: forall x y z. T [(x,y)] z z
+        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs
+        --     (NB: unlike the H98 case, the dc_tvs are not all existential)
+        -- Then we generate
+        --      Univ tyvars     Eq-spec
+        --          a              a~(x,y)
+        --          b              b~z
+        --          z
+        -- Existentials are the leftover type vars: [x,y]
+        -- The user-written type variables are what is listed in the forall:
+        --   [x, y, z] (all specified). We must rejig these as well.
+        --   See Note [DataCon user type variable binders] in DataCon.
+        -- So we return ( [a,b,z], [x,y]
+        --              , [], [x,y,z]
+        --              , [a~(x,y),b~z], <arg-subst> )
+  | Just subst <- ASSERT( isLiftedTypeKind (tcTypeKind res_ty) )
+                  ASSERT( isLiftedTypeKind (tcTypeKind res_tmpl) )
+                  tcMatchTy res_tmpl res_ty
+  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst
+        raw_ex_tvs = dc_tvs `minusList` univ_tvs
+        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs
+
+        -- After rejigging the existential tyvars, the resulting substitution
+        -- gives us exactly what we need to rejig the user-written tyvars,
+        -- since the dcUserTyVarBinders invariant guarantees that the
+        -- substitution has *all* the tyvars in its domain.
+        -- See Note [DataCon user type variable binders] in DataCon.
+        subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)
+        substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs
+        substed_specified_tvs = subst_user_tvs dc_specified_tvs
+
+        substed_eqs = map (substEqSpec arg_subst) raw_eqs
+    in
+    (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs,
+     substed_eqs, arg_subst)
+
+  | otherwise
+        -- If the return type of the data constructor doesn't match the parent
+        -- type constructor, or the arity is wrong, the tcMatchTy will fail
+        --    e.g   data T a b where
+        --            T1 :: Maybe a   -- Wrong tycon
+        --            T2 :: T [a]     -- Wrong arity
+        -- We are detect that later, in checkValidDataCon, but meanwhile
+        -- we must do *something*, not just crash.  So we do something simple
+        -- albeit bogus, relying on checkValidDataCon to check the
+        --  bad-result-type error before seeing that the other fields look odd
+        -- See Note [Checking GADT return types]
+  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs,
+     [], emptyTCvSubst)
+  where
+    dc_tvs   = dc_inferred_tvs ++ dc_specified_tvs
+    tmpl_tvs = binderVars tmpl_bndrs
+
+{- Note [mkGADTVars]
+~~~~~~~~~~~~~~~~~~~~
+Running example:
+
+data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where
+  MkT :: forall (x1 : *) (y :: x1) (z :: *).
+         T x1 * (Proxy (y :: x1), z) z
+
+We need the rejigged type to be
+
+  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).
+         forall (y :: x1) (z :: *).
+         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)
+      => T x1 k2 a b
+
+You might naively expect that z should become a universal tyvar,
+not an existential. (After all, x1 becomes a universal tyvar.)
+But z has kind * while b has kind k2, so the return type
+   T x1 k2 a z
+is ill-kinded.  Another way to say it is this: the universal
+tyvars must have exactly the same kinds as the tyConTyVars.
+
+So we need an existential tyvar and a heterogeneous equality
+constraint. (The b ~ z is a bit redundant with the k2 ~ * that
+comes before in that b ~ z implies k2 ~ *. I'm sure we could do
+some analysis that could eliminate k2 ~ *. But we don't do this
+yet.)
+
+The data con signature has already been fully kind-checked.
+The return type
+
+  T x1 * (Proxy (y :: x1), z) z
+becomes
+  qtkvs    = [x1 :: *, y :: x1, z :: *]
+  res_tmpl = T x1 * (Proxy x1 y, z) z
+
+We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We
+know this match will succeed because of the validity check (actually done
+later, but laziness saves us -- see Note [Checking GADT return types]).
+Thus, we get
+
+  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }
+
+Now, we need to figure out what the GADT equalities should be. In this case,
+we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a
+renaming. The others should be GADT equalities. We also need to make
+sure that the universally-quantified variables of the datacon match up
+with the tyvars of the tycon, as required for Core context well-formedness.
+(This last bit is why we have to rejig at all!)
+
+`choose` walks down the tycon tyvars, figuring out what to do with each one.
+It carries two substitutions:
+  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables
+    mentioned in the datacon signature.
+  - r_sub's domain is *result* tyvars, names written by the programmer in
+    the datacon signature. The final rejigged type will use these names, but
+    the subst is still needed because sometimes the printed name of these variables
+    is different. (See choose_tv_name, below.)
+
+Before explaining the details of `choose`, let's just look at its operation
+on our example:
+
+  choose [] [] {} {} [k1, k2, a, b]
+  -->          -- first branch of `case` statement
+  choose
+    univs:    [x1 :: *]
+    eq_spec:  []
+    t_sub:    {k1 |-> x1}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    [k2, a, b]
+  -->          -- second branch of `case` statement
+  choose
+    univs:    [k2 :: *, x1 :: *]
+    eq_spec:  [k2 ~ *]
+    t_sub:    {k1 |-> x1, k2 |-> k2}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    [a, b]
+  -->          -- second branch of `case` statement
+  choose
+    univs:    [a :: k2, k2 :: *, x1 :: *]
+    eq_spec:  [ a ~ (Proxy x1 y, z)
+              , k2 ~ * ]
+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    [b]
+  -->          -- second branch of `case` statement
+  choose
+    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]
+    eq_spec:  [ b ~ z
+              , a ~ (Proxy x1 y, z)
+              , k2 ~ * ]
+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    []
+  -->          -- end of recursion
+  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]
+  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]
+  , {x1 |-> x1} )
+
+`choose` looks up each tycon tyvar in the matching (it *must* be matched!).
+
+* If it finds a bare result tyvar (the first branch of the `case`
+  statement), it checks to make sure that the result tyvar isn't yet
+  in the list of univ_tvs.  If it is in that list, then we have a
+  repeated variable in the return type, and we in fact need a GADT
+  equality.
+
+* It then checks to make sure that the kind of the result tyvar
+  matches the kind of the template tyvar. This check is what forces
+  `z` to be existential, as it should be, explained above.
+
+* Assuming no repeated variables or kind-changing, we wish to use the
+  variable name given in the datacon signature (that is, `x1` not
+  `k1`), not the tycon signature (which may have been made up by
+  GHC). So, we add a mapping from the tycon tyvar to the result tyvar
+  to t_sub.
+
+* If we discover that a mapping in `subst` gives us a non-tyvar (the
+  second branch of the `case` statement), then we have a GADT equality
+  to create.  We create a fresh equality, but we don't extend any
+  substitutions. The template variable substitution is meant for use
+  in universal tyvar kinds, and these shouldn't be affected by any
+  GADT equalities.
+
+This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways
+of simplifying it:
+
+1) The first branch of the `case` statement is really an optimization, used
+in order to get fewer GADT equalities. It might be possible to make a GADT
+equality for *every* univ. tyvar, even if the equality is trivial, and then
+either deal with the bigger type or somehow reduce it later.
+
+2) This algorithm strives to use the names for type variables as specified
+by the user in the datacon signature. If we always used the tycon tyvar
+names, for example, this would be simplified. This change would almost
+certainly degrade error messages a bit, though.
+-}
+
+-- ^ From information about a source datacon definition, extract out
+-- what the universal variables and the GADT equalities should be.
+-- See Note [mkGADTVars].
+mkGADTVars :: [TyVar]    -- ^ The tycon vars
+           -> [TyVar]    -- ^ The datacon vars
+           -> TCvSubst   -- ^ The matching between the template result type
+                         -- and the actual result type
+           -> ( [TyVar]
+              , [EqSpec]
+              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,
+                           -- and a subst to apply to the GADT equalities
+                           -- and existentials.
+mkGADTVars tmpl_tvs dc_tvs subst
+  = choose [] [] empty_subst empty_subst tmpl_tvs
+  where
+    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)
+               `unionInScope` getTCvInScope subst
+    empty_subst = mkEmptyTCvSubst in_scope
+
+    choose :: [TyVar]           -- accumulator of univ tvs, reversed
+           -> [EqSpec]          -- accumulator of GADT equalities, reversed
+           -> TCvSubst          -- template substitution
+           -> TCvSubst          -- res. substitution
+           -> [TyVar]           -- template tvs (the univ tvs passed in)
+           -> ( [TyVar]         -- the univ_tvs
+              , [EqSpec]        -- GADT equalities
+              , TCvSubst )       -- a substitution to fix kinds in ex_tvs
+
+    choose univs eqs _t_sub r_sub []
+      = (reverse univs, reverse eqs, r_sub)
+    choose univs eqs t_sub r_sub (t_tv:t_tvs)
+      | Just r_ty <- lookupTyVar subst t_tv
+      = case getTyVar_maybe r_ty of
+          Just r_tv
+            |  not (r_tv `elem` univs)
+            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))
+            -> -- simple, well-kinded variable substitution.
+               choose (r_tv:univs) eqs
+                      (extendTvSubst t_sub t_tv r_ty')
+                      (extendTvSubst r_sub r_tv r_ty')
+                      t_tvs
+            where
+              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)
+              r_ty'  = mkTyVarTy r_tv1
+
+               -- Not a simple substitution: make an equality predicate
+          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)
+                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))
+                         -- We've updated the kind of t_tv,
+                         -- so add it to t_sub (#14162)
+                      r_sub t_tvs
+            where
+              t_tv' = updateTyVarKind (substTy t_sub) t_tv
+
+      | otherwise
+      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)
+
+      -- choose an appropriate name for a univ tyvar.
+      -- This *must* preserve the Unique of the result tv, so that we
+      -- can detect repeated variables. It prefers user-specified names
+      -- over system names. A result variable with a system name can
+      -- happen with GHC-generated implicit kind variables.
+    choose_tv_name :: TyVar -> TyVar -> Name
+    choose_tv_name r_tv t_tv
+      | isSystemName r_tv_name
+      = setNameUnique t_tv_name (getUnique r_tv_name)
+
+      | otherwise
+      = r_tv_name
+
+      where
+        r_tv_name = getName r_tv
+        t_tv_name = getName t_tv
+
+{-
+Note [Substitution in template variables kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+data G (a :: Maybe k) where
+  MkG :: G Nothing
+
+With explicit kind variables
+
+data G k (a :: Maybe k) where
+  MkG :: G k1 (Nothing k1)
+
+Note how k1 is distinct from k. So, when we match the template
+`G k a` against `G k1 (Nothing k1)`, we get a subst
+[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two
+mappings, we surely don't want to add (k, k1) to the list of
+GADT equalities -- that would be overly complex and would create
+more untouchable variables than we need. So, when figuring out
+which tyvars are GADT-like and which aren't (the fundamental
+job of `choose`), we want to treat `k` as *not* GADT-like.
+Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)
+instead of (a :: Maybe k). This is the reason for dealing
+with a substitution in here.
+
+However, we do not *always* want to substitute. Consider
+
+data H (a :: k) where
+  MkH :: H Int
+
+With explicit kind variables:
+
+data H k (a :: k) where
+  MkH :: H * Int
+
+Here, we have a kind-indexed GADT. The subst in question is
+[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s
+kind, because that would give a constructor with the type
+
+MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a
+
+The problem here is that a's kind is wrong -- it needs to be k, not *!
+So, if the matching for a variable is anything but another bare variable,
+we drop the mapping from the substitution before proceeding. This
+was not an issue before kind-indexed GADTs because this case could
+never happen.
+
+************************************************************************
+*                                                                      *
+                Validity checking
+*                                                                      *
+************************************************************************
+
+Validity checking is done once the mutually-recursive knot has been
+tied, so we can look at things freely.
+-}
+
+checkValidTyCl :: TyCon -> TcM [TyCon]
+-- The returned list is either a singleton (if valid)
+-- or a list of "fake tycons" (if not); the fake tycons
+-- include any implicits, like promoted data constructors
+-- See Note [Recover from validity error]
+checkValidTyCl tc
+  = setSrcSpan (getSrcSpan tc) $
+    addTyConCtxt tc            $
+    recoverM recovery_code     $
+    do { traceTc "Starting validity for tycon" (ppr tc)
+       ; checkValidTyCon tc
+       ; traceTc "Done validity for tycon" (ppr tc)
+       ; return [tc] }
+  where
+    recovery_code -- See Note [Recover from validity error]
+      = do { traceTc "Aborted validity for tycon" (ppr tc)
+           ; return (concatMap mk_fake_tc $
+                     ATyCon tc : implicitTyConThings tc) }
+
+    mk_fake_tc (ATyCon tc)
+      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]
+      | otherwise       = [makeRecoveryTyCon tc]
+    mk_fake_tc (AConLike (RealDataCon dc))
+                        = [makeRecoveryTyCon (promoteDataCon dc)]
+    mk_fake_tc _        = []
+
+{- Note [Recover from validity error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We recover from a validity error in a type or class, which allows us
+to report multiple validity errors. In the failure case we return a
+TyCon of the right kind, but with no interesting behaviour
+(makeRecoveryTyCon). Why?  Suppose we have
+   type T a = Fun
+where Fun is a type family of arity 1.  The RHS is invalid, but we
+want to go on checking validity of subsequent type declarations.
+So we replace T with an abstract TyCon which will do no harm.
+See indexed-types/should_fail/BadSock and #10896
+
+Some notes:
+
+* We must make fakes for promoted DataCons too. Consider (#15215)
+      data T a = MkT ...
+      data S a = ...T...MkT....
+  If there is an error in the definition of 'T' we add a "fake type
+  constructor" to the type environment, so that we can continue to
+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'
+  and so there was an internal error when we met 'MkT' in the body of
+  'S'.
+
+* Painfully, we *don't* want to do this for classes.
+  Consider tcfail041:
+     class (?x::Int) => C a where ...
+     instance C Int
+  The class is invalid because of the superclass constraint.  But
+  we still want it to look like a /class/, else the instance bleats
+  that the instance is mal-formed because it hasn't got a class in
+  the head.
+
+  This is really bogus; now we have in scope a Class that is invalid
+  in some way, with unknown downstream consequences.  A better
+  alterantive might be to make a fake class TyCon.  A job for another day.
+-}
+
+-------------------------
+-- For data types declared with record syntax, we require
+-- that each constructor that has a field 'f'
+--      (a) has the same result type
+--      (b) has the same type for 'f'
+-- module alpha conversion of the quantified type variables
+-- of the constructor.
+--
+-- Note that we allow existentials to match because the
+-- fields can never meet. E.g
+--      data T where
+--        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
+--        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
+-- Here we do not complain about f1,f2 because they are existential
+
+checkValidTyCon :: TyCon -> TcM ()
+checkValidTyCon tc
+  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim
+  = return ()
+
+  | otherwise
+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))
+       ; if | Just cl <- tyConClass_maybe tc
+              -> checkValidClass cl
+
+            | Just syn_rhs <- synTyConRhs_maybe tc
+              -> do { checkValidType syn_ctxt syn_rhs
+                    ; checkTySynRhs syn_ctxt syn_rhs }
+
+            | Just fam_flav <- famTyConFlav_maybe tc
+              -> case fam_flav of
+               { ClosedSynFamilyTyCon (Just ax)
+                   -> tcAddClosedTypeFamilyDeclCtxt tc $
+                      checkValidCoAxiom ax
+               ; ClosedSynFamilyTyCon Nothing   -> return ()
+               ; AbstractClosedSynFamilyTyCon ->
+                 do { hsBoot <- tcIsHsBootOrSig
+                    ; checkTc hsBoot $
+                      text "You may define an abstract closed type family" $$
+                      text "only in a .hs-boot file" }
+               ; DataFamilyTyCon {}           -> return ()
+               ; OpenSynFamilyTyCon           -> return ()
+               ; BuiltInSynFamTyCon _         -> return () }
+
+             | otherwise -> do
+               { -- Check the context on the data decl
+                 traceTc "cvtc1" (ppr tc)
+               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
+
+               ; traceTc "cvtc2" (ppr tc)
+
+               ; dflags          <- getDynFlags
+               ; existential_ok  <- xoptM LangExt.ExistentialQuantification
+               ; gadt_ok         <- xoptM LangExt.GADTs
+               ; let ex_ok = existential_ok || gadt_ok
+                     -- Data cons can have existential context
+               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)
+
+                -- Check that fields with the same name share a type
+               ; mapM_ check_fields groups }}
+  where
+    syn_ctxt  = TySynCtxt name
+    name      = tyConName tc
+    data_cons = tyConDataCons tc
+
+    groups = equivClasses cmp_fld (concatMap get_fields data_cons)
+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2
+    get_fields con = dataConFieldLabels con `zip` repeat con
+        -- dataConFieldLabels may return the empty list, which is fine
+
+    -- See Note [GADT record selectors] in TcTyDecls
+    -- We must check (a) that the named field has the same
+    --                   type in each constructor
+    --               (b) that those constructors have the same result type
+    --
+    -- However, the constructors may have differently named type variable
+    -- and (worse) we don't know how the correspond to each other.  E.g.
+    --     C1 :: forall a b. { f :: a, g :: b } -> T a b
+    --     C2 :: forall d c. { f :: c, g :: c } -> T c d
+    --
+    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
+    -- result type against other candidates' types BOTH WAYS ROUND.
+    -- If they magically agrees, take the substitution and
+    -- apply them to the latter ones, and see if they match perfectly.
+    check_fields ((label, con1) :| other_fields)
+        -- These fields all have the same name, but are from
+        -- different constructors in the data type
+        = recoverM (return ()) $ mapM_ checkOne other_fields
+                -- Check that all the fields in the group have the same type
+                -- NB: this check assumes that all the constructors of a given
+                -- data type use the same type variables
+        where
+        (_, _, _, res1) = dataConSig con1
+        fty1 = dataConFieldType con1 lbl
+        lbl = flLabel label
+
+        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical
+            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
+                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
+            where
+                (_, _, _, res2) = dataConSig con2
+                fty2 = dataConFieldType con2 lbl
+
+checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
+-- Checks the partial record field selector, and warns.
+-- See Note [Checking partial record field]
+checkPartialRecordField all_cons fld
+  = setSrcSpan loc $
+      warnIfFlag Opt_WarnPartialFields
+        (not is_exhaustive && not (startsWithUnderscore occ_name))
+        (sep [text "Use of partial record field selector" <> colon,
+              nest 2 $ quotes (ppr occ_name)])
+  where
+    sel_name = flSelector fld
+    loc    = getSrcSpan sel_name
+    occ_name = getOccName sel_name
+
+    (cons_with_field, cons_without_field) = partition has_field all_cons
+    has_field con = fld `elem` (dataConFieldLabels con)
+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field
+
+    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field
+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1
+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
+    inst_tys = substTyVars eq_subst univ_tvs
+
+checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
+                 -> Type -> Type -> Type -> Type -> TcM ()
+checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
+  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
+        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
+  where
+    mb_subst1 = tcMatchTy res1 res2
+    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
+
+-------------------------------
+checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
+checkValidDataCon dflags existential_ok tc con
+  = setSrcSpan (getSrcSpan con)  $
+    addErrCtxt (dataConCtxt con) $
+    do  { -- Check that the return type of the data constructor
+          -- matches the type constructor; eg reject this:
+          --   data T a where { MkT :: Bogus a }
+          -- It's important to do this first:
+          --  see Note [Checking GADT return types]
+          --  and c.f. Note [Check role annotations in a second pass]
+          let tc_tvs      = tyConTyVars tc
+              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
+              orig_res_ty = dataConOrigResTy con
+        ; traceTc "checkValidDataCon" (vcat
+              [ ppr con, ppr tc, ppr tc_tvs
+              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)
+              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])
+
+
+        ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty))
+                  (badDataConTyCon con res_ty_tmpl)
+            -- Note that checkTc aborts if it finds an error. This is
+            -- critical to avoid panicking when we call dataConUserType
+            -- on an un-rejiggable datacon!
+
+        ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))
+
+          -- Check that the result type is a *monotype*
+          --  e.g. reject this:   MkT :: T (forall a. a->a)
+          -- Reason: it's really the argument of an equality constraint
+        ; checkValidMonoType orig_res_ty
+
+          -- Check all argument types for validity
+        ; checkValidType ctxt (dataConUserType con)
+        ; mapM_ (checkForLevPoly empty)
+                (dataConOrigArgTys con)
+
+          -- Extra checks for newtype data constructors
+        ; when (isNewTyCon tc) (checkNewDataCon con)
+
+          -- Check that existentials are allowed if they are used
+        ; checkTc (existential_ok || isVanillaDataCon con)
+                  (badExistential con)
+
+          -- Check that UNPACK pragmas and bangs work out
+          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"
+          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
+        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
+
+          -- Check the dcUserTyVarBinders invariant
+          -- See Note [DataCon user type variable binders] in DataCon
+          -- checked here because we sometimes build invalid DataCons before
+          -- erroring above here
+        ; when debugIsOn $
+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con
+                   user_tvs                       = dataConUserTyVars con
+                   user_tvbs_invariant
+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)
+                       == Set.fromList user_tvs
+             ; WARN( not user_tvbs_invariant
+                       , vcat ([ ppr con
+                               , ppr univs
+                               , ppr exs
+                               , ppr eq_spec
+                               , ppr user_tvs ])) return () }
+
+        ; traceTc "Done validity of data con" $
+          vcat [ ppr con
+               , text "Datacon user type:" <+> ppr (dataConUserType con)
+               , text "Datacon rep type:" <+> ppr (dataConRepType con)
+               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
+               , case tyConFamInst_maybe (dataConTyCon con) of
+                   Nothing -> text "not family"
+                   Just (f, _) -> ppr (tyConBinders f) ]
+    }
+  where
+    ctxt = ConArgCtxt (dataConName con)
+
+    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
+    check_bang (HsSrcBang _ _ SrcLazy) _ n
+      | not (xopt LangExt.StrictData dflags)
+      = addErrTc
+          (bad_bang n (text "Lazy annotation (~) without StrictData"))
+    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n
+      | isSrcUnpacked want_unpack, not is_strict
+      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))
+      | isSrcUnpacked want_unpack
+      , case rep_bang of { HsUnpack {} -> False; _ -> True }
+      -- If not optimising, we don't unpack (rep_bang is never
+      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.
+      -- See dataConSrcToImplBang.
+      , not (gopt Opt_OmitInterfacePragmas dflags)
+      -- When typechecking an indefinite package in Backpack, we
+      -- may attempt to UNPACK an abstract type.  The test here will
+      -- conclude that this is unusable, but it might become usable
+      -- when we actually fill in the abstract type.  As such, don't
+      -- warn in this case (it gives users the wrong idea about whether
+      -- or not UNPACK on abstract types is supported; it is!)
+      , unitIdIsDefinite (thisPackage dflags)
+      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
+      where
+        is_strict = case strict_mark of
+                      NoSrcStrict -> xopt LangExt.StrictData dflags
+                      bang        -> isSrcStrict bang
+
+    check_bang _ _ _
+      = return ()
+
+    bad_bang n herald
+      = hang herald 2 (text "on the" <+> speakNth n
+                       <+> text "argument of" <+> quotes (ppr con))
+-------------------------------
+checkNewDataCon :: DataCon -> TcM ()
+-- Further checks for the data constructor of a newtype
+checkNewDataCon con
+  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
+              -- One argument
+
+        ; checkTc (not (isUnliftedType arg_ty1)) $
+          text "A newtype cannot have an unlifted argument type"
+
+        ; check_con (null eq_spec) $
+          text "A newtype constructor must have a return type of form T a1 ... an"
+                -- Return type is (T a b c)
+
+        ; check_con (null theta) $
+          text "A newtype constructor cannot have a context in its type"
+
+        ; check_con (null ex_tvs) $
+          text "A newtype constructor cannot have existential type variables"
+                -- No existentials
+
+        ; checkTc (all ok_bang (dataConSrcBangs con))
+                  (newtypeStrictError con)
+                -- No strictness annotations
+    }
+  where
+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
+      = dataConFullSig con
+    check_con what msg
+       = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))
+
+    (arg_ty1 : _) = arg_tys
+
+    ok_bang (HsSrcBang _ _ SrcStrict) = False
+    ok_bang (HsSrcBang _ _ SrcLazy)   = False
+    ok_bang _                         = True
+
+-------------------------------
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods
+        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses
+        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses
+        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies
+        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses
+
+        -- Check that the class is unary, unless multiparameter type classes
+        -- are enabled; also recognize deprecated nullary type classes
+        -- extension (subsumed by multiparameter type classes, #8993)
+        ; checkTc (multi_param_type_classes || cls_arity == 1 ||
+                    (nullary_type_classes && cls_arity == 0))
+                  (classArityErr cls_arity cls)
+        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
+
+        -- Check the super-classes
+        ; checkValidTheta (ClassSCCtxt (className cls)) theta
+
+          -- Now check for cyclic superclasses
+          -- If there are superclass cycles, checkClassCycleErrs bails.
+        ; unless undecidable_super_classes $
+          case checkClassCycles cls of
+             Just err -> setSrcSpan (getSrcSpan cls) $
+                         addErrTc err
+             Nothing  -> return ()
+
+        -- Check the class operations.
+        -- But only if there have been no earlier errors
+        -- See Note [Abort when superclass cycle is detected]
+        ; whenNoErrs $
+          mapM_ (check_op constrained_class_methods) op_stuff
+
+        -- Check the associated type defaults are well-formed and instantiated
+        ; mapM_ check_at at_stuff  }
+  where
+    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
+    cls_arity = length (tyConVisibleTyVars (classTyCon cls))
+       -- Ignore invisible variables
+    cls_tv_set = mkVarSet tyvars
+
+    check_op constrained_class_methods (sel_id, dm)
+      = setSrcSpan (getSrcSpan sel_id) $
+        addErrCtxt (classOpCtxt sel_id op_ty) $ do
+        { traceTc "class op type" (ppr op_ty)
+        ; checkValidType ctxt op_ty
+                -- This implements the ambiguity check, among other things
+                -- Example: tc223
+                --   class Error e => Game b mv e | b -> mv e where
+                --      newBoard :: MonadState b m => m ()
+                -- Here, MonadState has a fundep m->b, so newBoard is fine
+
+           -- a method cannot be levity polymorphic, as we have to store the
+           -- method in a dictionary
+           -- example of what this prevents:
+           --   class BoundedX (a :: TYPE r) where minBound :: a
+           -- See Note [Levity polymorphism checking] in DsMonad
+        ; checkForLevPoly empty tau1
+
+        ; unless constrained_class_methods $
+          mapM_ check_constraint (tail (cls_pred:op_theta))
+
+        ; check_dm ctxt sel_id cls_pred tau2 dm
+        }
+        where
+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints
+          op_name = idName sel_id
+          op_ty   = idType sel_id
+          (_,cls_pred,tau1) = tcSplitMethodTy op_ty
+          -- See Note [Splitting nested sigma types in class type signatures]
+          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1
+
+          check_constraint :: TcPredType -> TcM ()
+          check_constraint pred -- See Note [Class method constraints]
+            = when (not (isEmptyVarSet pred_tvs) &&
+                    pred_tvs `subVarSet` cls_tv_set)
+                   (addErrTc (badMethPred sel_id pred))
+            where
+              pred_tvs = tyCoVarsOfType pred
+
+    check_at (ATI fam_tc m_dflt_rhs)
+      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)
+                     (noClassTyVarErr cls fam_tc)
+                        -- Check that the associated type mentions at least
+                        -- one of the class type variables
+                        -- The check is disabled for nullary type classes,
+                        -- since there is no possible ambiguity (#10020)
+
+             -- Check that any default declarations for associated types are valid
+           ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->
+             setSrcSpan loc $
+             tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $
+             checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }
+        where
+          fam_tvs = tyConTyVars fam_tc
+
+    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()
+    -- Check validity of the /top-level/ generic-default type
+    -- E.g for   class C a where
+    --             default op :: forall b. (a~b) => blah
+    -- we do not want to do an ambiguity check on a type with
+    -- a free TyVar 'a' (#11608).  See TcType
+    -- Note [TyVars and TcTyVars during type checking] in TcType
+    -- Hence the mkDefaultMethodType to close the type.
+    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau
+             (Just (dm_name, dm_spec@(GenericDM dm_ty)))
+      = setSrcSpan (getSrcSpan dm_name) $ do
+            -- We have carefully set the SrcSpan on the generic
+            -- default-method Name to be that of the generic
+            -- default type signature
+
+          -- First, we check that that the method's default type signature
+          -- aligns with the non-default type signature.
+          -- See Note [Default method type signatures must align]
+          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls
+              -- Note that the second field of this tuple contains the context
+              -- of the default type signature, making it apparent that we
+              -- ignore method contexts completely when validity-checking
+              -- default type signatures. See the end of
+              -- Note [Default method type signatures must align]
+              -- to learn why this is OK.
+              --
+              -- See also
+              -- Note [Splitting nested sigma types in class type signatures]
+              -- for an explanation of why we don't use tcSplitSigmaTy here.
+              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty
+
+              -- Given this class definition:
+              --
+              --  class C a b where
+              --    op         :: forall p q. (Ord a, D p q)
+              --               => a -> b -> p -> (a, b)
+              --    default op :: forall r s. E r
+              --               => a -> b -> s -> (a, b)
+              --
+              -- We want to match up two types of the form:
+              --
+              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)
+              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)
+              --
+              -- Notice that the two type signatures can be quantified over
+              -- different class type variables! Therefore, it's important that
+              -- we include the class predicate parts to match up a with aa and
+              -- b with bb.
+              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau
+              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau
+
+          traceTc "check_dm" $ vcat
+              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty
+              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]
+
+          -- Actually checking that the types align is done with a call to
+          -- tcMatchTys. We need to get a match in both directions to rule
+          -- out degenerate cases like these:
+          --
+          --  class Foo a where
+          --    foo1         :: a -> b
+          --    default foo1 :: a -> Int
+          --
+          --    foo2         :: a -> Int
+          --    default foo2 :: a -> b
+          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]
+                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $
+               hang (text "The default type signature for"
+                     <+> ppr sel_id <> colon)
+                 2 (ppr dm_ty)
+            $$ (text "does not match its corresponding"
+                <+> text "non-default type signature")
+
+          -- Now do an ambiguity check on the default type signature.
+          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)
+    check_dm _ _ _ _ _ = return ()
+
+checkFamFlag :: Name -> TcM ()
+-- Check that we don't use families without -XTypeFamilies
+-- The parser won't even parse them, but I suppose a GHC API
+-- client might have a go!
+checkFamFlag tc_name
+  = do { idx_tys <- xoptM LangExt.TypeFamilies
+       ; checkTc idx_tys err_msg }
+  where
+    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))
+                 2 (text "Enable TypeFamilies to allow indexed type families")
+
+{- Note [Class method constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Haskell 2010 is supposed to reject
+  class C a where
+    op :: Eq a => a -> a
+where the method type constrains only the class variable(s).  (The extension
+-XConstrainedClassMethods switches off this check.)  But regardless
+we should not reject
+  class C a where
+    op :: (?x::Int) => a -> a
+as pointed out in #11793. So the test here rejects the program if
+  * -XConstrainedClassMethods is off
+  * the tyvars of the constraint are non-empty
+  * all the tyvars are class tyvars, none are locally quantified
+
+Note [Abort when superclass cycle is detected]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must avoid doing the ambiguity check for the methods (in
+checkValidClass.check_op) when there are already errors accumulated.
+This is because one of the errors may be a superclass cycle, and
+superclass cycles cause canonicalization to loop. Here is a
+representative example:
+
+  class D a => C a where
+    meth :: D a => ()
+  class C a => D a
+
+This fixes #9415, #9739
+
+Note [Default method type signatures must align]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC enforces the invariant that a class method's default type signature
+must "align" with that of the method's non-default type signature, as per
+GHC #12918. For instance, if you have:
+
+  class Foo a where
+    bar :: forall b. Context => a -> b
+
+Then a default type signature for bar must be alpha equivalent to
+(forall b. a -> b). That is, the types must be the same modulo differences in
+contexts. So the following would be acceptable default type signatures:
+
+    default bar :: forall b. Context1 => a -> b
+    default bar :: forall x. Context2 => a -> x
+
+But the following are NOT acceptable default type signatures:
+
+    default bar :: forall b. b -> a
+    default bar :: forall x. x
+    default bar :: a -> Int
+
+Note that a is bound by the class declaration for Foo itself, so it is
+not allowed to differ in the default type signature.
+
+The default type signature (default bar :: a -> Int) deserves special mention,
+since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To
+write this, you need to declare the default type signature like so:
+
+    default bar :: forall b. (b ~ Int). a -> b
+
+As noted in #12918, there are several reasons to do this:
+
+1. It would make no sense to have a type that was flat-out incompatible with
+   the non-default type signature. For instance, if you had:
+
+     class Foo a where
+       bar :: a -> Int
+       default bar :: a -> Bool
+
+   Then that would always fail in an instance declaration. So this check
+   nips such cases in the bud before they have the chance to produce
+   confusing error messages.
+
+2. Internally, GHC uses TypeApplications to instantiate the default method in
+   an instance. See Note [Default methods in instances] in TcInstDcls.
+   Thus, GHC needs to know exactly what the universally quantified type
+   variables are, and when instantiated that way, the default method's type
+   must match the expected type.
+
+3. Aesthetically, by only allowing the default type signature to differ in its
+   context, we are making it more explicit the ways in which the default type
+   signature is less polymorphic than the non-default type signature.
+
+You might be wondering: why are the contexts allowed to be different, but not
+the rest of the type signature? That's because default implementations often
+rely on assumptions that the more general, non-default type signatures do not.
+For instance, in the Enum class declaration:
+
+    class Enum a where
+      enum :: [a]
+      default enum :: (Generic a, GEnum (Rep a)) => [a]
+      enum = map to genum
+
+    class GEnum f where
+      genum :: [f a]
+
+The default implementation for enum only works for types that are instances of
+Generic, and for which their generic Rep type is an instance of GEnum. But
+clearly enum doesn't _have_ to use this implementation, so naturally, the
+context for enum is allowed to be different to accomodate this. As a result,
+when we validity-check default type signatures, we ignore contexts completely.
+
+Note that when checking whether two type signatures match, we must take care to
+split as many foralls as it takes to retrieve the tau types we which to check.
+See Note [Splitting nested sigma types in class type signatures].
+
+Note [Splitting nested sigma types in class type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this type synonym and class definition:
+
+  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
+
+  class Each s t a b where
+    each         ::                                      Traversal s t a b
+    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b
+
+It might seem obvious that the tau types in both type signatures for `each`
+are the same, but actually getting GHC to conclude this is surprisingly tricky.
+That is because in general, the form of a class method's non-default type
+signature is:
+
+  forall a. C a => forall d. D d => E a b
+
+And the general form of a default type signature is:
+
+  forall f. F f => E a f -- The variable `a` comes from the class
+
+So it you want to get the tau types in each type signature, you might find it
+reasonable to call tcSplitSigmaTy twice on the non-default type signature, and
+call it once on the default type signature. For most classes and methods, this
+will work, but Each is a bit of an exceptional case. The way `each` is written,
+it doesn't quantify any additional type variables besides those of the Each
+class itself, so the non-default type signature for `each` is actually this:
+
+  forall s t a b. Each s t a b => Traversal s t a b
+
+Notice that there _appears_ to only be one forall. But there's actually another
+forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy
+twice, you'll also go under the forall in Traversal! That is, you'll end up
+with:
+
+  (a -> f b) -> s -> f t
+
+A problem arises because you only call tcSplitSigmaTy once on the default type
+signature for `each`, which gives you
+
+  Traversal s t a b
+
+Or, equivalently:
+
+  forall f. Applicative f => (a -> f b) -> s -> f t
+
+This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will
+say that the tau types for `each` are not equal.
+
+A solution to this problem is to use tcSplitNestedSigmaTys instead of
+tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it
+sees until it can't go any further, so if you called it on the default type
+signature for `each`, it would return (a -> f b) -> s -> f t like we desired.
+
+Note [Checking partial record field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This check checks the partial record field selector, and warns (#7169).
+
+For example:
+
+  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }
+
+The function 'm2' is partial record field, and will fail when it is applied to
+'B'. The warning identifies such partial fields. The check is performed at the
+declaration of T, not at the call-sites of m2.
+
+The warning can be suppressed by prefixing the field-name with an underscore.
+For example:
+
+  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }
+
+************************************************************************
+*                                                                      *
+                Checking role validity
+*                                                                      *
+************************************************************************
+-}
+
+checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()
+checkValidRoleAnnots role_annots tc
+  | isTypeSynonymTyCon tc = check_no_roles
+  | isFamilyTyCon tc      = check_no_roles
+  | isAlgTyCon tc         = check_roles
+  | otherwise             = return ()
+  where
+    -- Role annotations are given only on *explicit* variables,
+    -- but a tycon stores roles for all variables.
+    -- So, we drop the implicit roles (which are all Nominal, anyway).
+    name                   = tyConName tc
+    roles                  = tyConRoles tc
+    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $
+                             zip roles (tyConBinders tc)
+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name
+
+    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)
+    pick_vis (role, tvb)
+      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)
+      | otherwise                = Nothing
+
+    check_roles
+      = whenIsJust role_annot_decl_maybe $
+          \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->
+          addRoleAnnotCtxt name $
+          setSrcSpan loc $ do
+          { role_annots_ok <- xoptM LangExt.RoleAnnotations
+          ; checkTc role_annots_ok $ needXRoleAnnotations tc
+          ; checkTc (vis_vars `equalLength` the_role_annots)
+                    (wrongNumberOfRoles vis_vars decl)
+          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles
+          -- Representational or phantom roles for class parameters
+          -- quickly lead to incoherence. So, we require
+          -- IncoherentInstances to have them. See #8773, #14292
+          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances
+          ; checkTc (  incoherent_roles_ok
+                    || (not $ isClassTyCon tc)
+                    || (all (== Nominal) vis_roles))
+                    incoherentRoles
+
+          ; lint <- goptM Opt_DoCoreLinting
+          ; when lint $ checkValidRoles tc }
+
+    check_no_roles
+      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
+
+checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
+checkRoleAnnot _  (dL->L _ Nothing)   _  = return ()
+checkRoleAnnot tv (dL->L _ (Just r1)) r2
+  = when (r1 /= r2) $
+    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2
+checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884
+
+-- This is a double-check on the role inference algorithm. It is only run when
+-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls
+checkValidRoles :: TyCon -> TcM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in CoreLint
+checkValidRoles tc
+  | isAlgTyCon tc
+    -- tyConDataCons returns an empty list for data families
+  = mapM_ check_dc_roles (tyConDataCons tc)
+  | Just rhs <- synTyConRhs_maybe tc
+  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs
+  | otherwise
+  = return ()
+  where
+    check_dc_roles datacon
+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))
+           ; mapM_ (check_ty_roles role_env Representational) $
+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }
+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls
+      where
+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
+          = dataConFullSig datacon
+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
+              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs
+        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)
+        role_env   = univ_roles `plusVarEnv` ex_roles
+
+    check_ty_roles env role ty
+      | Just ty' <- coreView ty -- #14101
+      = check_ty_roles env role ty'
+
+    check_ty_roles env role (TyVarTy tv)
+      = case lookupVarEnv env tv of
+          Just role' -> unless (role' `ltRole` role || role' == role) $
+                        report_error $ text "type variable" <+> quotes (ppr tv) <+>
+                                       text "cannot have role" <+> ppr role <+>
+                                       text "because it was assigned role" <+> ppr role'
+          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>
+                                       text "missing in environment"
+
+    check_ty_roles env Representational (TyConApp tc tys)
+      = let roles' = tyConRoles tc in
+        zipWithM_ (maybe_check_ty_roles env) roles' tys
+
+    check_ty_roles env Nominal (TyConApp _ tys)
+      = mapM_ (check_ty_roles env Nominal) tys
+
+    check_ty_roles _   Phantom ty@(TyConApp {})
+      = pprPanic "check_ty_roles" (ppr ty)
+
+    check_ty_roles env role (AppTy ty1 ty2)
+      =  check_ty_roles env role    ty1
+      >> check_ty_roles env Nominal ty2
+
+    check_ty_roles env role (FunTy _ ty1 ty2)
+      =  check_ty_roles env role ty1
+      >> check_ty_roles env role ty2
+
+    check_ty_roles env role (ForAllTy (Bndr tv _) ty)
+      =  check_ty_roles env Nominal (tyVarKind tv)
+      >> check_ty_roles (extendVarEnv env tv Nominal) role ty
+
+    check_ty_roles _   _    (LitTy {}) = return ()
+
+    check_ty_roles env role (CastTy t _)
+      = check_ty_roles env role t
+
+    check_ty_roles _   role (CoercionTy co)
+      = unless (role == Phantom) $
+        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role
+
+    maybe_check_ty_roles env role ty
+      = when (role == Nominal || role == Representational) $
+        check_ty_roles env role ty
+
+    report_error doc
+      = addErrTc $ vcat [text "Internal error in role inference:",
+                         doc,
+                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]
+
+{-
+************************************************************************
+*                                                                      *
+                Error messages
+*                                                                      *
+************************************************************************
+-}
+
+tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a
+tcAddTyFamInstCtxt decl
+  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
+
+tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
+                            HsIB { hsib_body = eqn }})
+  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
+                    (unLoc (feqn_tycon eqn))
+tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "tcMkDataFamInstCtxt"
+
+tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
+tcAddDataFamInstCtxt decl
+  = addErrCtxt (tcMkDataFamInstCtxt decl)
+
+tcMkFamInstCtxt :: SDoc -> Name -> SDoc
+tcMkFamInstCtxt flavour tycon
+  = hsep [ text "In the" <+> flavour <+> text "declaration for"
+         , quotes (ppr tycon) ]
+
+tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
+tcAddFamInstCtxt flavour tycon thing_inside
+  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside
+
+tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
+tcAddClosedTypeFamilyDeclCtxt tc
+  = addErrCtxt ctxt
+  where
+    ctxt = text "In the equations for closed type family" <+>
+           quotes (ppr tc)
+
+resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
+resultTypeMisMatch field_name con1 con2
+  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
+                text "have a common field" <+> quotes (ppr field_name) <> comma],
+          nest 2 $ text "but have different result types"]
+
+fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
+fieldTypeMisMatch field_name con1 con2
+  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
+         text "give different types for field", quotes (ppr field_name)]
+
+dataConCtxtName :: [Located Name] -> SDoc
+dataConCtxtName [con]
+   = text "In the definition of data constructor" <+> quotes (ppr con)
+dataConCtxtName con
+   = text "In the definition of data constructors" <+> interpp'SP con
+
+dataConCtxt :: Outputable a => a -> SDoc
+dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)
+
+classOpCtxt :: Var -> Type -> SDoc
+classOpCtxt sel_id tau = sep [text "When checking the class method:",
+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]
+
+classArityErr :: Int -> Class -> SDoc
+classArityErr n cls
+    | n == 0 = mkErr "No" "no-parameter"
+    | otherwise = mkErr "Too many" "multi-parameter"
+  where
+    mkErr howMany allowWhat =
+        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),
+              parens (text ("Enable MultiParamTypeClasses to allow "
+                                    ++ allowWhat ++ " classes"))]
+
+classFunDepsErr :: Class -> SDoc
+classFunDepsErr cls
+  = vcat [text "Fundeps in class" <+> quotes (ppr cls),
+          parens (text "Enable FunctionalDependencies to allow fundeps")]
+
+badMethPred :: Id -> TcPredType -> SDoc
+badMethPred sel_id pred
+  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)
+                 <+> text "in the type of" <+> quotes (ppr sel_id))
+              2 (text "constrains only the class type variables")
+         , text "Enable ConstrainedClassMethods to allow it" ]
+
+noClassTyVarErr :: Class -> TyCon -> SDoc
+noClassTyVarErr clas fam_tc
+  = sep [ text "The associated type" <+> quotes (ppr fam_tc)
+        , text "mentions none of the type or kind variables of the class" <+>
+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
+
+badDataConTyCon :: DataCon -> Type -> SDoc
+badDataConTyCon data_con res_ty_tmpl
+  | ASSERT( all isTyVar tvs )
+    tcIsForAllTy actual_res_ty
+  = nested_foralls_contexts_suggestion
+  | isJust (tcSplitPredFunTy_maybe actual_res_ty)
+  = nested_foralls_contexts_suggestion
+  | otherwise
+  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>
+                text "returns type" <+> quotes (ppr actual_res_ty))
+       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))
+  where
+    actual_res_ty = dataConOrigResTy data_con
+
+    -- This suggestion is useful for suggesting how to correct code like what
+    -- was reported in #12087:
+    --
+    --   data F a where
+    --     MkF :: Ord a => Eq a => a -> F a
+    --
+    -- Although nested foralls or contexts are allowed in function type
+    -- signatures, it is much more difficult to engineer GADT constructor type
+    -- signatures to allow something similar, so we error in the latter case.
+    -- Nevertheless, we can at least suggest how a user might reshuffle their
+    -- exotic GADT constructor type signature so that GHC will accept.
+    nested_foralls_contexts_suggestion =
+      text "GADT constructor type signature cannot contain nested"
+      <+> quotes forAllLit <> text "s or contexts"
+      $+$ hang (text "Suggestion: instead use this type signature:")
+             2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty)
+
+    -- To construct a type that GHC would accept (suggested_ty), we:
+    --
+    -- 1) Find the existentially quantified type variables and the class
+    --    predicates from the datacon. (NB: We don't need the universally
+    --    quantified type variables, since rejigConRes won't substitute them in
+    --    the result type if it fails, as in this scenario.)
+    -- 2) Split apart the return type (which is headed by a forall or a
+    --    context) using tcSplitNestedSigmaTys, collecting the type variables
+    --    and class predicates we find, as well as the rho type lurking
+    --    underneath the nested foralls and contexts.
+    -- 3) Smash together the type variables and class predicates from 1) and
+    --    2), and prepend them to the rho type from 2).
+    (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con)
+    suggested_ty = mkSpecSigmaTy tvs theta rho
+
+badGadtDecl :: Name -> SDoc
+badGadtDecl tc_name
+  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)
+         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]
+
+badExistential :: DataCon -> SDoc
+badExistential con
+  = hang (text "Data constructor" <+> quotes (ppr con) <+>
+                text "has existential type variables, a context, or a specialised result type")
+       2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)
+               , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])
+
+badStupidTheta :: Name -> SDoc
+badStupidTheta tc_name
+  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)
+
+newtypeConError :: Name -> Int -> SDoc
+newtypeConError tycon n
+  = sep [text "A newtype must have exactly one constructor,",
+         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]
+
+newtypeStrictError :: DataCon -> SDoc
+newtypeStrictError con
+  = sep [text "A newtype constructor cannot have a strictness annotation,",
+         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]
+
+newtypeFieldErr :: DataCon -> Int -> SDoc
+newtypeFieldErr con_name n_flds
+  = sep [text "The constructor of a newtype must have exactly one field",
+         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]
+
+badSigTyDecl :: Name -> SDoc
+badSigTyDecl tc_name
+  = vcat [ text "Illegal kind signature" <+>
+           quotes (ppr tc_name)
+         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]
+
+emptyConDeclsErr :: Name -> SDoc
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> text "has no constructors",
+         nest 2 $ text "(EmptyDataDecls permits this)"]
+
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+  = text "Wrong category of family instance; declaration was for a"
+    <+> kindOfFamily
+  where
+    kindOfFamily | isTypeFamilyTyCon family = text "type family"
+                 | isDataFamilyTyCon family = text "data family"
+                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
+
+-- | Produce an error for oversaturated type family equations with too many
+-- required arguments.
+-- See Note [Oversaturated type family equations] in TcValidity.
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr max_args
+  = text "Number of parameters must match family declaration; expected"
+    <+> ppr max_args
+
+badRoleAnnot :: Name -> Role -> Role -> SDoc
+badRoleAnnot var annot inferred
+  = hang (text "Role mismatch on variable" <+> ppr var <> colon)
+       2 (sep [ text "Annotation says", ppr annot
+              , text "but role", ppr inferred
+              , text "is required" ])
+
+wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc
+wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))
+  = hang (text "Wrong number of roles listed in role annotation;" $$
+          text "Expected" <+> (ppr $ length tyvars) <> comma <+>
+          text "got" <+> (ppr $ length annots) <> colon)
+       2 (ppr d)
+wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles"
+wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"
+                         -- due to #15884
+
+
+illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
+illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))
+  = setErrCtxt [] $
+    setSrcSpan loc $
+    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
+              text "they are allowed only for datatypes and classes.")
+illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl"
+illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match"
+                         -- due to #15884
+
+needXRoleAnnotations :: TyCon -> SDoc
+needXRoleAnnotations tc
+  = text "Illegal role annotation for" <+> ppr tc <> char ';' $$
+    text "did you intend to use RoleAnnotations?"
+
+incoherentRoles :: SDoc
+incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>
+                   text "for class parameters can lead to incoherence.") $$
+                  (text "Use IncoherentInstances to allow this; bad role found")
+
+addTyConCtxt :: TyCon -> TcM a -> TcM a
+addTyConCtxt tc = addTyConFlavCtxt name flav
+  where
+    name = getName tc
+    flav = tyConFlavour tc
+
+addRoleAnnotCtxt :: Name -> TcM a -> TcM a
+addRoleAnnotCtxt name
+  = addErrCtxt $
+    text "while checking a role annotation for" <+> quotes (ppr name)
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -0,0 +1,1033 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+
+
+Analysis functions over data types.  Specifically, detecting recursive types.
+
+This stuff is only used for source-code decls; it's recorded in interface
+files for imported data types.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcTyDecls(
+        RolesInfo,
+        inferRoles,
+        checkSynCycles,
+        checkClassCycles,
+
+        -- * Implicits
+        addTyConsToGblEnv, mkDefaultMethodType,
+
+        -- * Record selectors
+        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import TcEnv
+import TcBinds( tcValBinds, addTypecheckedBinds )
+import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
+import TcType
+import TysWiredIn( unitTy )
+import MkCore( rEC_SEL_ERROR_ID )
+import HsSyn
+import Class
+import Type
+import HscTypes
+import TyCon
+import ConLike
+import DataCon
+import Name
+import NameEnv
+import NameSet hiding (unitFV)
+import RdrName ( mkVarUnqual )
+import Id
+import IdInfo
+import VarEnv
+import VarSet
+import Coercion ( ltRole )
+import BasicTypes
+import SrcLoc
+import Unique ( mkBuiltinUnique )
+import Outputable
+import Util
+import Maybes
+import Bag
+import FastString
+import FV
+import Module
+
+import Control.Monad
+
+{-
+************************************************************************
+*                                                                      *
+        Cycles in type synonym declarations
+*                                                                      *
+************************************************************************
+-}
+
+synonymTyConsOfType :: Type -> [TyCon]
+-- Does not look through type synonyms at all
+-- Return a list of synonym tycons
+-- Keep this synchronized with 'expandTypeSynonyms'
+synonymTyConsOfType ty
+  = nameEnvElts (go ty)
+  where
+     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
+     go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys
+     go (LitTy _)         = emptyNameEnv
+     go (TyVarTy _)       = emptyNameEnv
+     go (AppTy a b)       = go a `plusNameEnv` go b
+     go (FunTy _ a b)     = go a `plusNameEnv` go b
+     go (ForAllTy _ ty)   = go ty
+     go (CastTy ty co)    = go ty `plusNameEnv` go_co co
+     go (CoercionTy co)   = go_co co
+
+     -- Note [TyCon cycles through coercions?!]
+     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+     -- Although, in principle, it's possible for a type synonym loop
+     -- could go through a coercion (since a coercion can refer to
+     -- a TyCon or Type), it doesn't seem possible to actually construct
+     -- a Haskell program which tickles this case.  Here is an example
+     -- program which causes a coercion:
+     --
+     --   type family Star where
+     --       Star = Type
+     --
+     --   data T :: Star -> Type
+     --   data S :: forall (a :: Type). T a -> Type
+     --
+     -- Here, the application 'T a' must first coerce a :: Type to a :: Star,
+     -- witnessed by the type family.  But if we now try to make Type refer
+     -- to a type synonym which in turn refers to Star, we'll run into
+     -- trouble: we're trying to define and use the type constructor
+     -- in the same recursive group.  Possibly this restriction will be
+     -- lifted in the future but for now, this code is "just for completeness
+     -- sake".
+     go_mco MRefl    = emptyNameEnv
+     go_mco (MCo co) = go_co co
+
+     go_co (Refl ty)              = go ty
+     go_co (GRefl _ ty mco)       = go ty `plusNameEnv` go_mco mco
+     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs
+     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'
+     go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'
+     go_co (FunCo _ co co')       = go_co co `plusNameEnv` go_co co'
+     go_co (CoVarCo _)            = emptyNameEnv
+     go_co (HoleCo {})            = emptyNameEnv
+     go_co (AxiomInstCo _ _ cs)   = go_co_s cs
+     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
+     go_co (SymCo co)             = go_co co
+     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'
+     go_co (NthCo _ _ co)         = go_co co
+     go_co (LRCo _ co)            = go_co co
+     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'
+     go_co (KindCo co)            = go_co co
+     go_co (SubCo co)             = go_co co
+     go_co (AxiomRuleCo _ cs)     = go_co_s cs
+
+     go_prov UnsafeCoerceProv     = emptyNameEnv
+     go_prov (PhantomProv co)     = go_co co
+     go_prov (ProofIrrelProv co)  = go_co co
+     go_prov (PluginProv _)       = emptyNameEnv
+
+     go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
+              | otherwise             = emptyNameEnv
+     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
+     go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
+
+-- | A monad for type synonym cycle checking, which keeps
+-- track of the TyCons which are known to be acyclic, or
+-- a failure message reporting that a cycle was found.
+newtype SynCycleM a = SynCycleM {
+    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+
+type SynCycleState = NameSet
+
+instance Functor SynCycleM where
+    fmap = liftM
+
+instance Applicative SynCycleM where
+    pure x = SynCycleM $ \state -> Right (x, state)
+    (<*>) = ap
+
+instance Monad SynCycleM where
+    m >>= f = SynCycleM $ \state ->
+        case runSynCycleM m state of
+            Right (x, state') ->
+                runSynCycleM (f x) state'
+            Left err -> Left err
+
+failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
+failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
+
+-- | Test if a 'Name' is acyclic, short-circuiting if we've
+-- seen it already.
+checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
+checkNameIsAcyclic n m = SynCycleM $ \s ->
+    if n `elemNameSet` s
+        then Right ((), s) -- short circuit
+        else case runSynCycleM m s of
+                Right ((), s') -> Right ((), extendNameSet s' n)
+                Left err -> Left err
+
+-- | Checks if any of the passed in 'TyCon's have cycles.
+-- Takes the 'UnitId' of the home package (as we can avoid
+-- checking those TyCons: cycles never go through foreign packages) and
+-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we
+-- can give better error messages.
+checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
+checkSynCycles this_uid tcs tyclds = do
+    case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of
+        Left (loc, err) -> setSrcSpan loc $ failWithTc err
+        Right _  -> return ()
+  where
+    -- Try our best to print the LTyClDecl for locally defined things
+    lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)
+
+    -- Short circuit if we've already seen this Name and concluded
+    -- it was acyclic.
+    go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+    go so_far seen_tcs tc =
+        checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc
+
+    -- Expand type synonyms, complaining if you find the same
+    -- type synonym a second time.
+    go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+    go' so_far seen_tcs tc
+        | n `elemNameSet` so_far
+            = failSynCycleM (getSrcSpan (head seen_tcs)) $
+                  sep [ text "Cycle in type synonym declarations:"
+                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]
+        -- Optimization: we don't allow cycles through external packages,
+        -- so once we find a non-local name we are guaranteed to not
+        -- have a cycle.
+        --
+        -- This won't hold once we get recursive packages with Backpack,
+        -- but for now it's fine.
+        | not (isHoleModule mod ||
+               moduleUnitId mod == this_uid ||
+               isInteractiveModule mod)
+            = return ()
+        | Just ty <- synTyConRhs_maybe tc =
+            go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty
+        | otherwise = return ()
+      where
+        n = tyConName tc
+        mod = nameModule n
+        ppr_decl tc =
+          case lookupNameEnv lcl_decls n of
+            Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl
+            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
+                       <+> text "from external module"
+         where
+          n = tyConName tc
+
+    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
+    go_ty so_far seen_tcs ty =
+        mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)
+
+{- Note [Superclass cycle check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The superclass cycle check for C decides if we can statically
+guarantee that expanding C's superclass cycles transitively is
+guaranteed to terminate.  This is a Haskell98 requirement,
+but one that we lift with -XUndecidableSuperClasses.
+
+The worry is that a superclass cycle could make the type checker loop.
+More precisely, with a constraint (Given or Wanted)
+    C ty1 .. tyn
+one approach is to instantiate all of C's superclasses, transitively.
+We can only do so if that set is finite.
+
+This potential loop occurs only through superclasses.  This, for
+example, is fine
+  class C a where
+    op :: C b => a -> b -> b
+even though C's full definition uses C.
+
+Making the check static also makes it conservative.  Eg
+  type family F a
+  class F a => C a
+Here an instance of (F a) might mention C:
+  type instance F [a] = C a
+and now we'd have a loop.
+
+The static check works like this, starting with C
+  * Look at C's superclass predicates
+  * If any is a type-function application,
+    or is headed by a type variable, fail
+  * If any has C at the head, fail
+  * If any has a type class D at the head,
+    make the same test with D
+
+A tricky point is: what if there is a type variable at the head?
+Consider this:
+   class f (C f) => C f
+   class c       => Id c
+and now expand superclasses for constraint (C Id):
+     C Id
+ --> Id (C Id)
+ --> C Id
+ --> ....
+Each step expands superclasses one layer, and clearly does not terminate.
+-}
+
+checkClassCycles :: Class -> Maybe SDoc
+-- Nothing  <=> ok
+-- Just err <=> possible cycle error
+checkClassCycles cls
+  = do { (definite_cycle, err) <- go (unitNameSet (getName cls))
+                                     cls (mkTyVarTys (classTyVars cls))
+       ; let herald | definite_cycle = text "Superclass cycle for"
+                    | otherwise      = text "Potential superclass cycle for"
+       ; return (vcat [ herald <+> quotes (ppr cls)
+                      , nest 2 err, hint]) }
+  where
+    hint = text "Use UndecidableSuperClasses to accept this"
+
+    -- Expand superclasses starting with (C a b), complaining
+    -- if you find the same class a second time, or a type function
+    -- or predicate headed by a type variable
+    --
+    -- NB: this code duplicates TcType.transSuperClasses, but
+    --     with more error message generation clobber
+    -- Make sure the two stay in sync.
+    go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+    go so_far cls tys = firstJusts $
+                        map (go_pred so_far) $
+                        immSuperClasses cls tys
+
+    go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
+       -- Nothing <=> ok
+       -- Just (True, err)  <=> definite cycle
+       -- Just (False, err) <=> possible cycle
+    go_pred so_far pred  -- NB: tcSplitTyConApp looks through synonyms
+       | Just (tc, tys) <- tcSplitTyConApp_maybe pred
+       = go_tc so_far pred tc tys
+       | hasTyVarHead pred
+       = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:")
+                         2 (quotes (ppr pred)))
+       | otherwise
+       = Nothing
+
+    go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
+    go_tc so_far pred tc tys
+      | isFamilyTyCon tc
+      = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")
+                        2 (quotes (ppr pred)))
+      | Just cls <- tyConClass_maybe tc
+      = go_cls so_far cls tys
+      | otherwise   -- Equality predicate, for example
+      = Nothing
+
+    go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+    go_cls so_far cls tys
+       | cls_nm `elemNameSet` so_far
+       = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))
+       | isCTupleClass cls
+       = go so_far cls tys
+       | otherwise
+       = do { (b,err) <- go  (so_far `extendNameSet` cls_nm) cls tys
+          ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)
+                       $$ err) }
+       where
+         cls_nm = getName cls
+
+{-
+************************************************************************
+*                                                                      *
+        Role inference
+*                                                                      *
+************************************************************************
+
+Note [Role inference]
+~~~~~~~~~~~~~~~~~~~~~
+The role inference algorithm datatype definitions to infer the roles on the
+parameters. Although these roles are stored in the tycons, we can perform this
+algorithm on the built tycons, as long as we don't peek at an as-yet-unknown
+roles field! Ah, the magic of laziness.
+
+First, we choose appropriate initial roles. For families and classes, roles
+(including initial roles) are N. For datatypes, we start with the role in the
+role annotation (if any), or otherwise use Phantom. This is done in
+initialRoleEnv1.
+
+The function irGroup then propagates role information until it reaches a
+fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a
+monad RoleM, which is a combination reader and state monad. In its state are
+the current RoleEnv, which gets updated by role propagation, and an update
+bit, which we use to know whether or not we've reached the fixpoint. The
+environment of RoleM contains the tycon whose parameters we are inferring, and
+a VarEnv from parameters to their positions, so we can update the RoleEnv.
+Between tycons, this reader information is missing; it is added by
+addRoleInferenceInfo.
+
+There are two kinds of tycons to consider: algebraic ones (excluding classes)
+and type synonyms. (Remember, families don't participate -- all their parameters
+are N.) An algebraic tycon processes each of its datacons, in turn. Note that
+a datacon's universally quantified parameters might be different from the parent
+tycon's parameters, so we use the datacon's univ parameters in the mapping from
+vars to positions. Note also that we don't want to infer roles for existentials
+(they're all at N, too), so we put them in the set of local variables. As an
+optimisation, we skip any tycons whose roles are already all Nominal, as there
+nowhere else for them to go. For synonyms, we just analyse their right-hand sides.
+
+irType walks through a type, looking for uses of a variable of interest and
+propagating role information. Because anything used under a phantom position
+is at phantom and anything used under a nominal position is at nominal, the
+irType function can assume that anything it sees is at representational. (The
+other possibilities are pruned when they're encountered.)
+
+The rest of the code is just plumbing.
+
+How do we know that this algorithm is correct? It should meet the following
+specification:
+
+Let Z be a role context -- a mapping from variables to roles. The following
+rules define the property (Z |- t : r), where t is a type and r is a role:
+
+Z(a) = r'        r' <= r
+------------------------- RCVar
+Z |- a : r
+
+---------- RCConst
+Z |- T : r               -- T is a type constructor
+
+Z |- t1 : r
+Z |- t2 : N
+-------------- RCApp
+Z |- t1 t2 : r
+
+forall i<=n. (r_i is R or N) implies Z |- t_i : r_i
+roles(T) = r_1 .. r_n
+---------------------------------------------------- RCDApp
+Z |- T t_1 .. t_n : R
+
+Z, a:N |- t : r
+---------------------- RCAll
+Z |- forall a:k.t : r
+
+
+We also have the following rules:
+
+For all datacon_i in type T, where a_1 .. a_n are universally quantified
+and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,
+then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,
+then roles(T) = r_1 .. r_n
+
+roles(->) = R, R
+roles(~#) = N, N
+
+With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
+called from checkValidTycon.
+
+Note [Role-checking data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a where
+    MkT :: Eq b => F a -> (a->a) -> T (G a)
+
+Then we want to check the roles at which 'a' is used
+in MkT's type.  We want to work on the user-written type,
+so we need to take into account
+  * the arguments:   (F a) and (a->a)
+  * the context:     C a b
+  * the result type: (G a)   -- this is in the eq_spec
+
+
+Note [Coercions in role inference]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing
+the kind of a type is totally irrelevant to the representation of that type. So,
+we want to totally ignore coercions when doing role inference. This includes omitting
+any type variables that appear in nominal positions but only within coercions.
+-}
+
+type RolesInfo = Name -> [Role]
+
+type RoleEnv = NameEnv [Role]        -- from tycon names to roles
+
+-- This, and any of the functions it calls, must *not* look at the roles
+-- field of a tycon we are inferring roles about!
+-- See Note [Role inference]
+inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
+inferRoles hsc_src annots tycons
+  = let role_env  = initialRoleEnv hsc_src annots tycons
+        role_env' = irGroup role_env tycons in
+    \name -> case lookupNameEnv role_env' name of
+      Just roles -> roles
+      Nothing    -> pprPanic "inferRoles" (ppr name)
+
+initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
+initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv .
+                                map (initialRoleEnv1 hsc_src annots)
+
+initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
+initialRoleEnv1 hsc_src annots_env tc
+  | isFamilyTyCon tc      = (name, map (const Nominal) bndrs)
+  | isAlgTyCon tc         = (name, default_roles)
+  | isTypeSynonymTyCon tc = (name, default_roles)
+  | otherwise             = pprPanic "initialRoleEnv1" (ppr tc)
+  where name         = tyConName tc
+        bndrs        = tyConBinders tc
+        argflags     = map tyConBinderArgFlag bndrs
+        num_exps     = count isVisibleArgFlag argflags
+
+          -- if the number of annotations in the role annotation decl
+          -- is wrong, just ignore it. We check this in the validity check.
+        role_annots
+          = case lookupRoleAnnot annots_env name of
+              Just (dL->L _ (RoleAnnotDecl _ _ annots))
+                | annots `lengthIs` num_exps -> map unLoc annots
+              _                              -> replicate num_exps Nothing
+        default_roles = build_default_roles argflags role_annots
+
+        build_default_roles (argf : argfs) (m_annot : ras)
+          | isVisibleArgFlag argf
+          = (m_annot `orElse` default_role) : build_default_roles argfs ras
+        build_default_roles (_argf : argfs) ras
+          = Nominal : build_default_roles argfs ras
+        build_default_roles [] [] = []
+        build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)"
+                                           (vcat [ppr tc, ppr role_annots])
+
+        default_role
+          | isClassTyCon tc               = Nominal
+          -- Note [Default roles for abstract TyCons in hs-boot/hsig]
+          | HsBootFile <- hsc_src
+          , isAbstractTyCon tc            = Representational
+          | HsigFile   <- hsc_src
+          , isAbstractTyCon tc            = Nominal
+          | otherwise                     = Phantom
+
+-- Note [Default roles for abstract TyCons in hs-boot/hsig]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- What should the default role for an abstract TyCon be?
+--
+-- Originally, we inferred phantom role for abstract TyCons
+-- in hs-boot files, because the type variables were never used.
+--
+-- This was silly, because the role of the abstract TyCon
+-- was required to match the implementation, and the roles of
+-- data types are almost never phantom.  Thus, in ticket #9204,
+-- the default was changed so be representational (the most common case).  If
+-- the implementing data type was actually nominal, you'd get an easy
+-- to understand error, and add the role annotation yourself.
+--
+-- Then Backpack was added, and with it we added role *subtyping*
+-- the matching judgment: if an abstract TyCon has a nominal
+-- parameter, it's OK to implement it with a representational
+-- parameter.  But now, the representational default is not a good
+-- one, because you should *only* request representational if
+-- you're planning to do coercions. To be maximally flexible
+-- with what data types you will accept, you want the default
+-- for hsig files is nominal.  We don't allow role subtyping
+-- with hs-boot files (it's good practice to give an exactly
+-- accurate role here, because any types that use the abstract
+-- type will propagate the role information.)
+
+irGroup :: RoleEnv -> [TyCon] -> RoleEnv
+irGroup env tcs
+  = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in
+    if update
+    then irGroup env' tcs
+    else env'
+
+irTyCon :: TyCon -> RoleM ()
+irTyCon tc
+  | isAlgTyCon tc
+  = do { old_roles <- lookupRoles tc
+       ; unless (all (== Nominal) old_roles) $  -- also catches data families,
+                                                -- which don't want or need role inference
+         irTcTyVars tc $
+         do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc)  -- See #8958
+            ; whenIsJust (tyConClass_maybe tc) irClass
+            ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }}
+
+  | Just ty <- synTyConRhs_maybe tc
+  = irTcTyVars tc $
+    irType emptyVarSet ty
+
+  | otherwise
+  = return ()
+
+-- any type variable used in an associated type must be Nominal
+irClass :: Class -> RoleM ()
+irClass cls
+  = mapM_ ir_at (classATs cls)
+  where
+    cls_tvs    = classTyVars cls
+    cls_tv_set = mkVarSet cls_tvs
+
+    ir_at at_tc
+      = mapM_ (updateRole Nominal) nvars
+      where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc
+
+-- See Note [Role inference]
+irDataCon :: DataCon -> RoleM ()
+irDataCon datacon
+  = setRoleInferenceVars univ_tvs $
+    irExTyVars ex_tvs $ \ ex_var_set ->
+    mapM_ (irType ex_var_set)
+          (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys)
+      -- See Note [Role-checking data constructor arguments]
+  where
+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
+      = dataConFullSig datacon
+
+irType :: VarSet -> Type -> RoleM ()
+irType = go
+  where
+    go lcls ty                 | Just ty' <- coreView ty -- #14101
+                               = go lcls ty'
+    go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $
+                                 updateRole Representational tv
+    go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2
+    go lcls (TyConApp tc tys)  = do { roles <- lookupRolesX tc
+                                    ; zipWithM_ (go_app lcls) roles tys }
+    go lcls (ForAllTy tvb ty)  = do { let tv = binderVar tvb
+                                          lcls' = extendVarSet lcls tv
+                                    ; markNominal lcls (tyVarKind tv)
+                                    ; go lcls' ty }
+    go lcls (FunTy _ arg res)  = go lcls arg >> go lcls res
+    go _    (LitTy {})         = return ()
+      -- See Note [Coercions in role inference]
+    go lcls (CastTy ty _)      = go lcls ty
+    go _    (CoercionTy _)     = return ()
+
+    go_app _ Phantom _ = return ()                 -- nothing to do here
+    go_app lcls Nominal ty = markNominal lcls ty  -- all vars below here are N
+    go_app lcls Representational ty = go lcls ty
+
+irTcTyVars :: TyCon -> RoleM a -> RoleM a
+irTcTyVars tc thing
+  = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc)
+  where
+    go []       = thing
+    go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv)
+                     ; addRoleInferenceVar tv $ go tvs }
+
+irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a
+irExTyVars orig_tvs thing = go emptyVarSet orig_tvs
+  where
+    go lcls []       = thing lcls
+    go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv)
+                          ; go (extendVarSet lcls tv) tvs }
+
+markNominal :: TyVarSet   -- local variables
+            -> Type -> RoleM ()
+markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in
+                      mapM_ (updateRole Nominal) nvars
+  where
+     -- get_ty_vars gets all the tyvars (no covars!) from a type *without*
+     -- recurring into coercions. Recall: coercions are totally ignored during
+     -- role inference. See [Coercions in role inference]
+    get_ty_vars :: Type -> FV
+    get_ty_vars (TyVarTy tv)      = unitFV tv
+    get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2
+    get_ty_vars (FunTy _ t1 t2)   = get_ty_vars t1 `unionFV` get_ty_vars t2
+    get_ty_vars (TyConApp _ tys)  = mapUnionFV get_ty_vars tys
+    get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty)
+    get_ty_vars (LitTy {})        = emptyFV
+    get_ty_vars (CastTy ty _)     = get_ty_vars ty
+    get_ty_vars (CoercionTy _)    = emptyFV
+
+-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps
+lookupRolesX :: TyCon -> RoleM [Role]
+lookupRolesX tc
+  = do { roles <- lookupRoles tc
+       ; return $ roles ++ repeat Nominal }
+
+-- gets the roles either from the environment or the tycon
+lookupRoles :: TyCon -> RoleM [Role]
+lookupRoles tc
+  = do { env <- getRoleEnv
+       ; case lookupNameEnv env (tyConName tc) of
+           Just roles -> return roles
+           Nothing    -> return $ tyConRoles tc }
+
+-- tries to update a role; won't ever update a role "downwards"
+updateRole :: Role -> TyVar -> RoleM ()
+updateRole role tv
+  = do { var_ns <- getVarNs
+       ; name <- getTyConName
+       ; case lookupVarEnv var_ns tv of
+           Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns)
+           Just n  -> updateRoleEnv name n role }
+
+-- the state in the RoleM monad
+data RoleInferenceState = RIS { role_env  :: RoleEnv
+                              , update    :: Bool }
+
+-- the environment in the RoleM monad
+type VarPositions = VarEnv Int
+
+-- See [Role inference]
+newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon
+                            -> VarPositions
+                            -> Int          -- size of VarPositions
+                            -> RoleInferenceState
+                            -> (a, RoleInferenceState) }
+
+instance Functor RoleM where
+    fmap = liftM
+
+instance Applicative RoleM where
+    pure x = RM $ \_ _ _ state -> (x, state)
+    (<*>) = ap
+
+instance Monad RoleM where
+  a >>= f  = RM $ \m_info vps nvps state ->
+                  let (a', state') = unRM a m_info vps nvps state in
+                  unRM (f a') m_info vps nvps state'
+
+runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
+runRoleM env thing = (env', update)
+  where RIS { role_env = env', update = update }
+          = snd $ unRM thing Nothing emptyVarEnv 0 state
+        state = RIS { role_env  = env
+                    , update    = False }
+
+setRoleInferenceTc :: Name -> RoleM a -> RoleM a
+setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->
+                                ASSERT( isNothing m_name )
+                                ASSERT( isEmptyVarEnv vps )
+                                ASSERT( nvps == 0 )
+                                unRM thing (Just name) vps nvps state
+
+addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
+addRoleInferenceVar tv thing
+  = RM $ \m_name vps nvps state ->
+    ASSERT( isJust m_name )
+    unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state
+
+setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
+setRoleInferenceVars tvs thing
+  = RM $ \m_name _vps _nvps state ->
+    ASSERT( isJust m_name )
+    unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")
+         state
+
+getRoleEnv :: RoleM RoleEnv
+getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state)
+
+getVarNs :: RoleM VarPositions
+getVarNs = RM $ \_ vps _ state -> (vps, state)
+
+getTyConName :: RoleM Name
+getTyConName = RM $ \m_name _ _ state ->
+                    case m_name of
+                      Nothing   -> panic "getTyConName"
+                      Just name -> (name, state)
+
+updateRoleEnv :: Name -> Int -> Role -> RoleM ()
+updateRoleEnv name n role
+  = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),
+         case lookupNameEnv role_env name of
+           Nothing -> pprPanic "updateRoleEnv" (ppr name)
+           Just roles -> let (before, old_role : after) = splitAt n roles in
+                         if role `ltRole` old_role
+                         then let roles' = before ++ role : after
+                                  role_env' = extendNameEnv role_env name roles' in
+                              RIS { role_env = role_env', update = True }
+                         else state )
+
+
+{- *********************************************************************
+*                                                                      *
+                Building implicits
+*                                                                      *
+********************************************************************* -}
+
+addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
+-- Given a [TyCon], add to the TcGblEnv
+--   * extend the TypeEnv with the tycons
+--   * extend the TypeEnv with their implicitTyThings
+--   * extend the TypeEnv with any default method Ids
+--   * add bindings for record selectors
+addTyConsToGblEnv tyclss
+  = tcExtendTyConEnv tyclss                    $
+    tcExtendGlobalEnvImplicit implicit_things  $
+    tcExtendGlobalValEnv def_meth_ids          $
+    do { traceTc "tcAddTyCons" $ vcat
+            [ text "tycons" <+> ppr tyclss
+            , text "implicits" <+> ppr implicit_things ]
+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
+       ; return gbl_env }
+ where
+   implicit_things = concatMap implicitTyConThings tyclss
+   def_meth_ids    = mkDefaultMethodIds tyclss
+
+mkDefaultMethodIds :: [TyCon] -> [Id]
+-- We want to put the default-method Ids (both vanilla and generic)
+-- into the type environment so that they are found when we typecheck
+-- the filled-in default methods of each instance declaration
+-- See Note [Default method Ids and Template Haskell]
+mkDefaultMethodIds tycons
+  = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)
+    | tc <- tycons
+    , Just cls <- [tyConClass_maybe tc]
+    , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
+
+mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
+-- Returns the top-level type of the default method
+mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id
+mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty
+   where
+     pred      = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs))
+     cls_bndrs = tyConBinders (classTyCon cls)
+     tv_bndrs  = tyConTyVarBinders cls_bndrs
+     -- NB: the Class doesn't have TyConBinders; we reach into its
+     --     TyCon to get those.  We /do/ need the TyConBinders because
+     --     we need the correct visibility: these default methods are
+     --     used in code generated by the fill-in for missing
+     --     methods in instances (TcInstDcls.mkDefMethBind), and
+     --     then typechecked.  So we need the right visibilty info
+     --     (#13998)
+
+{-
+************************************************************************
+*                                                                      *
+                Building record selectors
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [Default method Ids and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#4169):
+   class Numeric a where
+     fromIntegerNum :: a
+     fromIntegerNum = ...
+
+   ast :: Q [Dec]
+   ast = [d| instance Numeric Int |]
+
+When we typecheck 'ast' we have done the first pass over the class decl
+(in tcTyClDecls), but we have not yet typechecked the default-method
+declarations (because they can mention value declarations).  So we
+must bring the default method Ids into scope first (so they can be seen
+when typechecking the [d| .. |] quote, and typecheck them later.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                Building record selectors
+*                                                                      *
+************************************************************************
+-}
+
+tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
+tcRecSelBinds sel_bind_prs
+  = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $
+    do { (rec_sel_binds, tcg_env) <- discardWarnings $
+                                     tcValBinds TopLevel binds sigs getGblEnv
+       ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
+  where
+    sigs = [ cL loc (IdSig noExt sel_id)   | (sel_id, _) <- sel_bind_prs
+                                          , let loc = getSrcSpan sel_id ]
+    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
+
+mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+--    This makes life easier, because the later type checking will add
+--    all necessary type abstractions and applications
+mkRecSelBinds tycons
+  = map mkRecSelBind [ (tc,fld) | tc <- tycons
+                                , fld <- tyConFieldLabels tc ]
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
+mkRecSelBind (tycon, fl)
+  = mkOneRecordSelector all_cons (RecSelData tycon) fl
+  where
+    all_cons = map RealDataCon (tyConDataCons tycon)
+
+mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
+                    -> (Id, LHsBind GhcRn)
+mkOneRecordSelector all_cons idDetails fl
+  = (sel_id, cL loc sel_bind)
+  where
+    loc      = getSrcSpan sel_name
+    lbl      = flLabel fl
+    sel_name = flSelector fl
+
+    sel_id = mkExportedLocalId rec_details sel_name sel_ty
+    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
+
+    -- Find a representative constructor, con1
+    cons_w_field = conLikesWithFields all_cons [lbl]
+    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+
+    -- Selector type; Note [Polymorphic selectors]
+    field_ty   = conLikeFieldType con1 lbl
+    data_tvs   = tyCoVarsOfTypesWellScoped inst_tys
+    data_tv_set= mkVarSet data_tvs
+    is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
+    (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
+           | otherwise  = mkSpecForAllTys data_tvs          $
+                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!
+                          mkVisFunTy data_ty                $
+                          mkSpecForAllTys field_tvs         $
+                          mkPhiTy field_theta               $
+                          -- req_theta is empty for normal DataCon
+                          mkPhiTy req_theta                 $
+                          field_tau
+
+    -- Make the binding: sel (C2 { fld = x }) = x
+    --                   sel (C7 { fld = x }) = x
+    --    where cons_w_field = [C2,C7]
+    sel_bind = mkTopFunBind Generated sel_lname alts
+      where
+        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
+                                           [] unit_rhs]
+             | otherwise =  map mk_match cons_w_field ++ deflt
+    mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
+                                 [cL loc (mk_sel_pat con)]
+                                 (cL loc (HsVar noExt (cL loc field_var)))
+    mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields)
+    rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
+    rec_field  = noLoc (HsRecField
+                        { hsRecFieldLbl
+                           = cL loc (FieldOcc sel_name
+                                     (cL loc $ mkVarUnqual lbl))
+                        , hsRecFieldArg
+                           = cL loc (VarPat noExt (cL loc field_var))
+                        , hsRecPun = False })
+    sel_lname = cL loc sel_name
+    field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
+
+    -- Add catch-all default case unless the case is exhaustive
+    -- We do this explicitly so that we get a nice error message that
+    -- mentions this particular record selector
+    deflt | all dealt_with all_cons = []
+          | otherwise = [mkSimpleMatch CaseAlt
+                            [cL loc (WildPat noExt)]
+                            (mkHsApp (cL loc (HsVar noExt
+                                         (cL loc (getName rEC_SEL_ERROR_ID))))
+                                     (cL loc (HsLit noExt msg_lit)))]
+
+        -- Do not add a default case unless there are unmatched
+        -- constructors.  We must take account of GADTs, else we
+        -- get overlap warning messages from the pattern-match checker
+        -- NB: we need to pass type args for the *representation* TyCon
+        --     to dataConCannotMatch, hence the calculation of inst_tys
+        --     This matters in data families
+        --              data instance T Int a where
+        --                 A :: { fld :: Int } -> T Int Bool
+        --                 B :: { fld :: Int } -> T Int Char
+    dealt_with :: ConLike -> Bool
+    dealt_with (PatSynCon _) = False -- We can't predict overlap
+    dealt_with con@(RealDataCon dc) =
+      con `elem` cons_w_field || dataConCannotMatch inst_tys dc
+
+    (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1
+
+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
+    inst_tys = substTyVars eq_subst univ_tvs
+
+    unit_rhs = mkLHsTupleExpr []
+    msg_lit = HsStringPrim NoSourceText (bytesFS lbl)
+
+{-
+Note [Polymorphic selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take care to build the type of a polymorphic selector in the right
+order, so that visible type application works.
+
+  data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) }
+
+We want
+
+  field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b)
+
+Note [Naughty record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "naughty" field is one for which we can't define a record
+selector, because an existential type variable would escape.  For example:
+        data T = forall a. MkT { x,y::a }
+We obviously can't define
+        x (MkT v _) = v
+Nevertheless we *do* put a RecSelId into the type environment
+so that if the user tries to use 'x' as a selector we can bleat
+helpfully, rather than saying unhelpfully that 'x' is not in scope.
+Hence the sel_naughty flag, to identify record selectors that don't really exist.
+
+In general, a field is "naughty" if its type mentions a type variable that
+isn't in the result type of the constructor.  Note that this *allows*
+GADT record selectors (Note [GADT record selectors]) whose types may look
+like     sel :: T [a] -> a
+
+For naughty selectors we make a dummy binding
+   sel = ()
+so that the later type-check will add them to the environment, and they'll be
+exported.  The function is never called, because the typechecker spots the
+sel_naughty field.
+
+Note [GADT record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For GADTs, we require that all constructors with a common field 'f' have the same
+result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
+E.g.
+        data T where
+          T1 { f :: Maybe a } :: T [a]
+          T2 { f :: Maybe a, y :: b  } :: T [a]
+          T3 :: T Int
+
+and now the selector takes that result type as its argument:
+   f :: forall a. T [a] -> Maybe a
+
+Details: the "real" types of T1,T2 are:
+   T1 :: forall r a.   (r~[a]) => a -> T r
+   T2 :: forall r a b. (r~[a]) => a -> b -> T r
+
+So the selector loooks like this:
+   f :: forall a. T [a] -> Maybe a
+   f (a:*) (t:T [a])
+     = case t of
+         T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))
+         T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
+         T3 -> error "T3 does not have field f"
+
+Note the forall'd tyvars of the selector are just the free tyvars
+of the result type; there may be other tyvars in the constructor's
+type (e.g. 'b' in T2).
+
+Note the need for casts in the result!
+
+Note [Selector running example]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's OK to combine GADTs and type families.  Here's a running example:
+
+        data instance T [a] where
+          T1 { fld :: b } :: T [Maybe b]
+
+The representation type looks like this
+        data :R7T a where
+          T1 { fld :: b } :: :R7T (Maybe b)
+
+and there's coercion from the family type to the representation type
+        :CoR7T a :: T [a] ~ :R7T a
+
+The selector we want for fld looks like this:
+
+        fld :: forall b. T [Maybe b] -> b
+        fld = /\b. \(d::T [Maybe b]).
+              case d `cast` :CoR7T (Maybe b) of
+                T1 (x::b) -> x
+
+The scrutinee of the case has type :R7T (Maybe b), which can be
+gotten by appying the eq_spec to the univ_tvs of the data con.
+
+-}
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -0,0 +1,992 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TcTypeNats
+  ( typeNatTyCons
+  , typeNatCoAxiomRules
+  , BuiltInSynFamily(..)
+
+    -- If you define a new built-in type family, make sure to export its TyCon
+    -- from here as well.
+    -- See Note [Adding built-in type families]
+  , typeNatAddTyCon
+  , typeNatMulTyCon
+  , typeNatExpTyCon
+  , typeNatLeqTyCon
+  , typeNatSubTyCon
+  , typeNatDivTyCon
+  , typeNatModTyCon
+  , typeNatLogTyCon
+  , typeNatCmpTyCon
+  , typeSymbolCmpTyCon
+  , typeSymbolAppendTyCon
+  ) where
+
+import GhcPrelude
+
+import Type
+import Pair
+import TcType     ( TcType, tcEqType )
+import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon
+                  , Injectivity(..) )
+import Coercion   ( Role(..) )
+import TcRnTypes  ( Xi )
+import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )
+import Name       ( Name, BuiltInSyntax(..) )
+import TysWiredIn
+import TysPrim    ( mkTemplateAnonTyConBinders )
+import PrelNames  ( gHC_TYPELITS
+                  , gHC_TYPENATS
+                  , typeNatAddTyFamNameKey
+                  , typeNatMulTyFamNameKey
+                  , typeNatExpTyFamNameKey
+                  , typeNatLeqTyFamNameKey
+                  , typeNatSubTyFamNameKey
+                  , typeNatDivTyFamNameKey
+                  , typeNatModTyFamNameKey
+                  , typeNatLogTyFamNameKey
+                  , typeNatCmpTyFamNameKey
+                  , typeSymbolCmpTyFamNameKey
+                  , typeSymbolAppendFamNameKey
+                  )
+import FastString ( FastString
+                  , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS
+                  )
+import qualified Data.Map as Map
+import Data.Maybe ( isJust )
+import Control.Monad ( guard )
+import Data.List  ( isPrefixOf, isSuffixOf )
+
+{-
+Note [Type-level literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are currently two forms of type-level literals: natural numbers, and
+symbols (even though this module is named TcTypeNats, it covers both).
+
+Type-level literals are supported by CoAxiomRules (conditional axioms), which
+power the built-in type families (see Note [Adding built-in type families]).
+Currently, all built-in type families are for the express purpose of supporting
+type-level literals.
+
+See also the Wiki page:
+
+    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats
+
+Note [Adding built-in type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are a few steps to adding a built-in type family:
+
+* Adding a unique for the type family TyCon
+
+  These go in PrelNames. It will likely be of the form
+  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that
+  has not been chosen before in PrelNames. There are several examples already
+  in PrelNames—see, for instance, typeNatAddTyFamNameKey.
+
+* Adding the type family TyCon itself
+
+  This goes in TcTypeNats. There are plenty of examples of how to define
+  these—see, for instance, typeNatAddTyCon.
+
+  Once your TyCon has been defined, be sure to:
+
+  - Export it from TcTypeNats. (Not doing so caused #14632.)
+  - Include it in the typeNatTyCons list, defined in TcTypeNats.
+
+* Exposing associated type family axioms
+
+  When defining the type family TyCon, you will need to define an axiom for
+  the type family in general (see, for instance, axAddDef), and perhaps other
+  auxiliary axioms for special cases of the type family (see, for instance,
+  axAdd0L and axAdd0R).
+
+  After you have defined all of these axioms, be sure to include them in the
+  typeNatCoAxiomRules list, defined in TcTypeNats.
+  (Not doing so caused #14934.)
+
+* Define the type family somewhere
+
+  Finally, you will need to define the type family somewhere, likely in @base@.
+  Currently, all of the built-in type families are defined in GHC.TypeLits or
+  GHC.TypeNats, so those are likely candidates.
+
+  Since the behavior of your built-in type family is specified in TcTypeNats,
+  you should give an open type family definition with no instances, like so:
+
+    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat
+
+  Changing the argument and result kinds as appropriate.
+
+* Update the relevant test cases
+
+  The GHC test suite will likely need to be updated after you add your built-in
+  type family. For instance:
+
+  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added
+    a test there, the expected output of T9181 will need to change.
+  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit
+    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have
+    runtime unit tests. Consider adding further unit tests to those if your
+    built-in type family deals with Nats or Symbols, respectively.
+-}
+
+{-------------------------------------------------------------------------------
+Built-in type constructors for functions on type-level nats
+-}
+
+-- The list of built-in type family TyCons that GHC uses.
+-- If you define a built-in type family, make sure to add it to this list.
+-- See Note [Adding built-in type families]
+typeNatTyCons :: [TyCon]
+typeNatTyCons =
+  [ typeNatAddTyCon
+  , typeNatMulTyCon
+  , typeNatExpTyCon
+  , typeNatLeqTyCon
+  , typeNatSubTyCon
+  , typeNatDivTyCon
+  , typeNatModTyCon
+  , typeNatLogTyCon
+  , typeNatCmpTyCon
+  , typeSymbolCmpTyCon
+  , typeSymbolAppendTyCon
+  ]
+
+typeNatAddTyCon :: TyCon
+typeNatAddTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamAdd
+    , sfInteractTop   = interactTopAdd
+    , sfInteractInert = interactInertAdd
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+")
+            typeNatAddTyFamNameKey typeNatAddTyCon
+
+typeNatSubTyCon :: TyCon
+typeNatSubTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamSub
+    , sfInteractTop   = interactTopSub
+    , sfInteractInert = interactInertSub
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-")
+            typeNatSubTyFamNameKey typeNatSubTyCon
+
+typeNatMulTyCon :: TyCon
+typeNatMulTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamMul
+    , sfInteractTop   = interactTopMul
+    , sfInteractInert = interactInertMul
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")
+            typeNatMulTyFamNameKey typeNatMulTyCon
+
+typeNatDivTyCon :: TyCon
+typeNatDivTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamDiv
+    , sfInteractTop   = interactTopDiv
+    , sfInteractInert = interactInertDiv
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")
+            typeNatDivTyFamNameKey typeNatDivTyCon
+
+typeNatModTyCon :: TyCon
+typeNatModTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamMod
+    , sfInteractTop   = interactTopMod
+    , sfInteractInert = interactInertMod
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")
+            typeNatModTyFamNameKey typeNatModTyCon
+
+
+
+
+
+typeNatExpTyCon :: TyCon
+typeNatExpTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamExp
+    , sfInteractTop   = interactTopExp
+    , sfInteractInert = interactInertExp
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")
+                typeNatExpTyFamNameKey typeNatExpTyCon
+
+typeNatLogTyCon :: TyCon
+typeNatLogTyCon = mkTypeNatFunTyCon1 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamLog
+    , sfInteractTop   = interactTopLog
+    , sfInteractInert = interactInertLog
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")
+            typeNatLogTyFamNameKey typeNatLogTyCon
+
+
+
+typeNatLeqTyCon :: TyCon
+typeNatLeqTyCon =
+  mkFamilyTyCon name
+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])
+    boolTy
+    Nothing
+    (BuiltInSynFamTyCon ops)
+    Nothing
+    NotInjective
+
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?")
+                typeNatLeqTyFamNameKey typeNatLeqTyCon
+  ops = BuiltInSynFamily
+    { sfMatchFam      = matchFamLeq
+    , sfInteractTop   = interactTopLeq
+    , sfInteractInert = interactInertLeq
+    }
+
+typeNatCmpTyCon :: TyCon
+typeNatCmpTyCon =
+  mkFamilyTyCon name
+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])
+    orderingKind
+    Nothing
+    (BuiltInSynFamTyCon ops)
+    Nothing
+    NotInjective
+
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat")
+                typeNatCmpTyFamNameKey typeNatCmpTyCon
+  ops = BuiltInSynFamily
+    { sfMatchFam      = matchFamCmpNat
+    , sfInteractTop   = interactTopCmpNat
+    , sfInteractInert = \_ _ _ _ -> []
+    }
+
+typeSymbolCmpTyCon :: TyCon
+typeSymbolCmpTyCon =
+  mkFamilyTyCon name
+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])
+    orderingKind
+    Nothing
+    (BuiltInSynFamTyCon ops)
+    Nothing
+    NotInjective
+
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol")
+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon
+  ops = BuiltInSynFamily
+    { sfMatchFam      = matchFamCmpSymbol
+    , sfInteractTop   = interactTopCmpSymbol
+    , sfInteractInert = \_ _ _ _ -> []
+    }
+
+typeSymbolAppendTyCon :: TyCon
+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamAppendSymbol
+    , sfInteractTop   = interactTopAppendSymbol
+    , sfInteractInert = interactInertAppendSymbol
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")
+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon
+
+
+
+-- Make a unary built-in constructor of kind: Nat -> Nat
+mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeNatFunTyCon1 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeNatKind ])
+    typeNatKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
+
+-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat
+mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeNatFunTyCon2 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])
+    typeNatKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
+-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol
+mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeSymbolFunTyCon2 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])
+    typeSymbolKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
+
+{-------------------------------------------------------------------------------
+Built-in rules axioms
+-------------------------------------------------------------------------------}
+
+-- If you add additional rules, please remember to add them to
+-- `typeNatCoAxiomRules` also.
+-- See Note [Adding built-in type families]
+axAddDef
+  , axMulDef
+  , axExpDef
+  , axLeqDef
+  , axCmpNatDef
+  , axCmpSymbolDef
+  , axAppendSymbolDef
+  , axAdd0L
+  , axAdd0R
+  , axMul0L
+  , axMul0R
+  , axMul1L
+  , axMul1R
+  , axExp1L
+  , axExp0R
+  , axExp1R
+  , axLeqRefl
+  , axCmpNatRefl
+  , axCmpSymbolRefl
+  , axLeq0L
+  , axSubDef
+  , axSub0R
+  , axAppendSymbol0R
+  , axAppendSymbol0L
+  , axDivDef
+  , axDiv1
+  , axModDef
+  , axMod1
+  , axLogDef
+  :: CoAxiomRule
+
+axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $
+              \x y -> Just $ num (x + y)
+
+axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $
+              \x y -> Just $ num (x * y)
+
+axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $
+              \x y -> Just $ num (x ^ y)
+
+axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $
+              \x y -> Just $ bool (x <= y)
+
+axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon
+              $ \x y -> Just $ ordering (compare x y)
+
+axCmpSymbolDef =
+  CoAxiomRule
+    { coaxrName      = fsLit "CmpSymbolDef"
+    , coaxrAsmpRoles = [Nominal, Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2, Pair t1 t2] <- return cs
+           s2' <- isStrLitTy s2
+           t2' <- isStrLitTy t2
+           return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===
+                   ordering (compare s2' t2')) }
+
+axAppendSymbolDef = CoAxiomRule
+    { coaxrName      = fsLit "AppendSymbolDef"
+    , coaxrAsmpRoles = [Nominal, Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2, Pair t1 t2] <- return cs
+           s2' <- isStrLitTy s2
+           t2' <- isStrLitTy t2
+           let z = mkStrLitTy (appendFS s2' t2')
+           return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)
+    }
+
+axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $
+              \x y -> fmap num (minus x y)
+
+axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $
+              \x y -> do guard (y /= 0)
+                         return (num (div x y))
+
+axModDef = mkBinAxiom "ModDef" typeNatModTyCon $
+              \x y -> do guard (y /= 0)
+                         return (num (mod x y))
+
+axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $
+              \x -> do (a,_) <- genLog x 2
+                       return (num a)
+
+axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t
+axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t
+axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t
+axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0
+axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0
+axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t
+axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t
+axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)
+axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)
+                                    -- XXX: Shouldn't we check that _ is 0?
+axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1
+axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1
+axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t
+axLeqRefl   = mkAxiom1 "LeqRefl"  $ \(Pair s _) -> (s <== s) === bool True
+axCmpNatRefl    = mkAxiom1 "CmpNatRefl"
+                $ \(Pair s _) -> (cmpNat s s) === ordering EQ
+axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"
+                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ
+axLeq0L     = mkAxiom1 "Leq0L"    $ \(Pair s _) -> (num 0 <== s) === bool True
+axAppendSymbol0R  = mkAxiom1 "Concat0R"
+            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t
+axAppendSymbol0L  = mkAxiom1 "Concat0L"
+            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t
+
+-- The list of built-in type family axioms that GHC uses.
+-- If you define new axioms, make sure to include them in this list.
+-- See Note [Adding built-in type families]
+typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule
+typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))
+  [ axAddDef
+  , axMulDef
+  , axExpDef
+  , axLeqDef
+  , axCmpNatDef
+  , axCmpSymbolDef
+  , axAppendSymbolDef
+  , axAdd0L
+  , axAdd0R
+  , axMul0L
+  , axMul0R
+  , axMul1L
+  , axMul1R
+  , axExp1L
+  , axExp0R
+  , axExp1R
+  , axLeqRefl
+  , axCmpNatRefl
+  , axCmpSymbolRefl
+  , axLeq0L
+  , axSubDef
+  , axSub0R
+  , axAppendSymbol0R
+  , axAppendSymbol0L
+  , axDivDef
+  , axDiv1
+  , axModDef
+  , axMod1
+  , axLogDef
+  ]
+
+
+
+{-------------------------------------------------------------------------------
+Various utilities for making axioms and types
+-------------------------------------------------------------------------------}
+
+(.+.) :: Type -> Type -> Type
+s .+. t = mkTyConApp typeNatAddTyCon [s,t]
+
+(.-.) :: Type -> Type -> Type
+s .-. t = mkTyConApp typeNatSubTyCon [s,t]
+
+(.*.) :: Type -> Type -> Type
+s .*. t = mkTyConApp typeNatMulTyCon [s,t]
+
+tDiv :: Type -> Type -> Type
+tDiv s t = mkTyConApp typeNatDivTyCon [s,t]
+
+tMod :: Type -> Type -> Type
+tMod s t = mkTyConApp typeNatModTyCon [s,t]
+
+(.^.) :: Type -> Type -> Type
+s .^. t = mkTyConApp typeNatExpTyCon [s,t]
+
+(<==) :: Type -> Type -> Type
+s <== t = mkTyConApp typeNatLeqTyCon [s,t]
+
+cmpNat :: Type -> Type -> Type
+cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]
+
+cmpSymbol :: Type -> Type -> Type
+cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]
+
+appendSymbol :: Type -> Type -> Type
+appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]
+
+(===) :: Type -> Type -> Pair Type
+x === y = Pair x y
+
+num :: Integer -> Type
+num = mkNumLitTy
+
+bool :: Bool -> Type
+bool b = if b then mkTyConApp promotedTrueDataCon []
+              else mkTyConApp promotedFalseDataCon []
+
+isBoolLitTy :: Type -> Maybe Bool
+isBoolLitTy tc =
+  do (tc,[]) <- splitTyConApp_maybe tc
+     case () of
+       _ | tc == promotedFalseDataCon -> return False
+         | tc == promotedTrueDataCon  -> return True
+         | otherwise                   -> Nothing
+
+orderingKind :: Kind
+orderingKind = mkTyConApp orderingTyCon []
+
+ordering :: Ordering -> Type
+ordering o =
+  case o of
+    LT -> mkTyConApp promotedLTDataCon []
+    EQ -> mkTyConApp promotedEQDataCon []
+    GT -> mkTyConApp promotedGTDataCon []
+
+isOrderingLitTy :: Type -> Maybe Ordering
+isOrderingLitTy tc =
+  do (tc1,[]) <- splitTyConApp_maybe tc
+     case () of
+       _ | tc1 == promotedLTDataCon -> return LT
+         | tc1 == promotedEQDataCon -> return EQ
+         | tc1 == promotedGTDataCon -> return GT
+         | otherwise                -> Nothing
+
+known :: (Integer -> Bool) -> TcType -> Bool
+known p x = case isNumLitTy x of
+              Just a  -> p a
+              Nothing -> False
+
+
+mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule
+mkUnAxiom str tc f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2] <- return cs
+           s2' <- isNumLitTy s2
+           z   <- f s2'
+           return (mkTyConApp tc [s1] === z)
+    }
+
+
+
+-- For the definitional axioms
+mkBinAxiom :: String -> TyCon ->
+              (Integer -> Integer -> Maybe Type) -> CoAxiomRule
+mkBinAxiom str tc f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal, Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2, Pair t1 t2] <- return cs
+           s2' <- isNumLitTy s2
+           t2' <- isNumLitTy t2
+           z   <- f s2' t2'
+           return (mkTyConApp tc [s1,t1] === z)
+    }
+
+
+
+mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule
+mkAxiom1 str f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \case [eqn] -> Just (f eqn)
+                             _     -> Nothing
+    }
+
+
+{-------------------------------------------------------------------------------
+Evaluation
+-------------------------------------------------------------------------------}
+
+matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamAdd [s,t]
+  | Just 0 <- mbX = Just (axAdd0L, [t], t)
+  | Just 0 <- mbY = Just (axAdd0R, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axAddDef, [s,t], num (x + y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamAdd _ = Nothing
+
+matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamSub [s,t]
+  | Just 0 <- mbY = Just (axSub0R, [s], s)
+  | Just x <- mbX, Just y <- mbY, Just z <- minus x y =
+    Just (axSubDef, [s,t], num z)
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamSub _ = Nothing
+
+matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamMul [s,t]
+  | Just 0 <- mbX = Just (axMul0L, [t], num 0)
+  | Just 0 <- mbY = Just (axMul0R, [s], num 0)
+  | Just 1 <- mbX = Just (axMul1L, [t], t)
+  | Just 1 <- mbY = Just (axMul1R, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axMulDef, [s,t], num (x * y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamMul _ = Nothing
+
+matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamDiv [s,t]
+  | Just 1 <- mbY = Just (axDiv1, [s], s)
+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamDiv _ = Nothing
+
+matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamMod [s,t]
+  | Just 1 <- mbY = Just (axMod1, [s], num 0)
+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamMod _ = Nothing
+
+
+
+matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamExp [s,t]
+  | Just 0 <- mbY = Just (axExp0R, [s], num 1)
+  | Just 1 <- mbX = Just (axExp1L, [t], num 1)
+  | Just 1 <- mbY = Just (axExp1R, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axExpDef, [s,t], num (x ^ y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamExp _ = Nothing
+
+matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamLog [s]
+  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)
+  where mbX = isNumLitTy s
+matchFamLog _ = Nothing
+
+
+matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamLeq [s,t]
+  | Just 0 <- mbX = Just (axLeq0L, [t], bool True)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axLeqDef, [s,t], bool (x <= y))
+  | tcEqType s t  = Just (axLeqRefl, [s], bool True)
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamLeq _ = Nothing
+
+matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamCmpNat [s,t]
+  | Just x <- mbX, Just y <- mbY =
+    Just (axCmpNatDef, [s,t], ordering (compare x y))
+  | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ)
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamCmpNat _ = Nothing
+
+matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamCmpSymbol [s,t]
+  | Just x <- mbX, Just y <- mbY =
+    Just (axCmpSymbolDef, [s,t], ordering (compare x y))
+  | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)
+  where mbX = isStrLitTy s
+        mbY = isStrLitTy t
+matchFamCmpSymbol _ = Nothing
+
+matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamAppendSymbol [s,t]
+  | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t)
+  | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y))
+  where
+  mbX = isStrLitTy s
+  mbY = isStrLitTy t
+matchFamAppendSymbol _ = Nothing
+
+{-------------------------------------------------------------------------------
+Interact with axioms
+-------------------------------------------------------------------------------}
+
+interactTopAdd :: [Xi] -> Xi -> [Pair Type]
+interactTopAdd [s,t] r
+  | Just 0 <- mbZ = [ s === num 0, t === num 0 ]                          -- (s + t ~ 0) => (s ~ 0, t ~ 0)
+  | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y]     -- (5 + t ~ 8) => (t ~ 3)
+  | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x]     -- (s + 5 ~ 8) => (s ~ 3)
+  where
+  mbX = isNumLitTy s
+  mbY = isNumLitTy t
+  mbZ = isNumLitTy r
+interactTopAdd _ _ = []
+
+{-
+Note [Weakened interaction rule for subtraction]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A simpler interaction here might be:
+
+  `s - t ~ r` --> `t + r ~ s`
+
+This would enable us to reuse all the code for addition.
+Unfortunately, this works a little too well at the moment.
+Consider the following example:
+
+    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)
+
+This (correctly) spots that the constraint cannot be solved.
+
+However, this may be a problem if the constraint did not
+need to be solved in the first place!  Consider the following example:
+
+f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5
+f = id
+
+Currently, GHC is strict while evaluating functions, so this does not
+work, because even though the `If` should evaluate to `5 - 0`, we
+also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,
+which fails.
+
+So, for the time being, we only add an improvement when the RHS is a constant,
+which happens to work OK for the moment, although clearly we need to do
+something more general.
+-}
+interactTopSub :: [Xi] -> Xi -> [Pair Type]
+interactTopSub [s,t] r
+  | Just z <- mbZ = [ s === (num z .+. t) ]         -- (s - t ~ 5) => (5 + t ~ s)
+  where
+  mbZ = isNumLitTy r
+interactTopSub _ _ = []
+
+
+
+
+
+interactTopMul :: [Xi] -> Xi -> [Pair Type]
+interactTopMul [s,t] r
+  | Just 1 <- mbZ = [ s === num 1, t === num 1 ]                        -- (s * t ~ 1)  => (s ~ 1, t ~ 1)
+  | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y]  -- (3 * t ~ 15) => (t ~ 5)
+  | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x]  -- (s * 3 ~ 15) => (s ~ 5)
+  where
+  mbX = isNumLitTy s
+  mbY = isNumLitTy t
+  mbZ = isNumLitTy r
+interactTopMul _ _ = []
+
+interactTopDiv :: [Xi] -> Xi -> [Pair Type]
+interactTopDiv _ _ = []   -- I can't think of anything...
+
+interactTopMod :: [Xi] -> Xi -> [Pair Type]
+interactTopMod _ _ = []   -- I can't think of anything...
+
+interactTopExp :: [Xi] -> Xi -> [Pair Type]
+interactTopExp [s,t] r
+  | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)
+  | Just x <- mbX, Just z <- mbZ, Just y <- logExact  z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3)
+  | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3)
+  where
+  mbX = isNumLitTy s
+  mbY = isNumLitTy t
+  mbZ = isNumLitTy r
+interactTopExp _ _ = []
+
+interactTopLog :: [Xi] -> Xi -> [Pair Type]
+interactTopLog _ _ = []   -- I can't think of anything...
+
+
+
+interactTopLeq :: [Xi] -> Xi -> [Pair Type]
+interactTopLeq [s,t] r
+  | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)
+  where
+  mbY = isNumLitTy t
+  mbZ = isBoolLitTy r
+interactTopLeq _ _ = []
+
+interactTopCmpNat :: [Xi] -> Xi -> [Pair Type]
+interactTopCmpNat [s,t] r
+  | Just EQ <- isOrderingLitTy r = [ s === t ]
+interactTopCmpNat _ _ = []
+
+interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type]
+interactTopCmpSymbol [s,t] r
+  | Just EQ <- isOrderingLitTy r = [ s === t ]
+interactTopCmpSymbol _ _ = []
+
+interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type]
+interactTopAppendSymbol [s,t] r
+  -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "")
+  | Just z <- mbZ, nullFS z =
+    [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ]
+
+  -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")
+  | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z =
+    [ t === mkStrLitTy (mkFastString $ drop (length x) z) ]
+
+  -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")
+  | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z =
+    [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ]
+
+  where
+  mbX = isStrLitTy s
+  mbY = isStrLitTy t
+  mbZ = isStrLitTy r
+
+interactTopAppendSymbol _ _ = []
+
+{-------------------------------------------------------------------------------
+Interaction with inerts
+-------------------------------------------------------------------------------}
+
+interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertAdd [x1,y1] z1 [x2,y2] z2
+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+interactInertAdd _ _ _ _ = []
+
+interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertSub [x1,y1] z1 [x2,y2] z2
+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+interactInertSub _ _ _ _ = []
+
+interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertMul [x1,y1] z1 [x2,y2] z2
+  | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ]
+  | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]
+  where sameZ   = tcEqType z1 z2
+
+interactInertMul _ _ _ _ = []
+
+interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertDiv _ _ _ _ = []
+
+interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertMod _ _ _ _ = []
+
+interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertExp [x1,y1] z1 [x2,y2] z2
+  | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]
+  | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+
+interactInertExp _ _ _ _ = []
+
+interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertLog _ _ _ _ = []
+
+
+interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertLeq [x1,y1] z1 [x2,y2] z2
+  | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ]
+  | bothTrue && tcEqType y1 x2                 = [ (x1 <== y2) === bool True ]
+  | bothTrue && tcEqType y2 x1                 = [ (x2 <== y1) === bool True ]
+  where bothTrue = isJust $ do True <- isBoolLitTy z1
+                               True <- isBoolLitTy z2
+                               return ()
+
+interactInertLeq _ _ _ _ = []
+
+
+interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2
+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+interactInertAppendSymbol _ _ _ _ = []
+
+
+
+{- -----------------------------------------------------------------------------
+These inverse functions are used for simplifying propositions using
+concrete natural numbers.
+----------------------------------------------------------------------------- -}
+
+-- | Subtract two natural numbers.
+minus :: Integer -> Integer -> Maybe Integer
+minus x y = if x >= y then Just (x - y) else Nothing
+
+-- | Compute the exact logarithm of a natural number.
+-- The logarithm base is the second argument.
+logExact :: Integer -> Integer -> Maybe Integer
+logExact x y = do (z,True) <- genLog x y
+                  return z
+
+
+-- | Divide two natural numbers.
+divide :: Integer -> Integer -> Maybe Integer
+divide _ 0  = Nothing
+divide x y  = case divMod x y of
+                (a,0) -> Just a
+                _     -> Nothing
+
+-- | Compute the exact root of a natural number.
+-- The second argument specifies which root we are computing.
+rootExact :: Integer -> Integer -> Maybe Integer
+rootExact x y = do (z,True) <- genRoot x y
+                   return z
+
+
+
+{- | Compute the n-th root of a natural number, rounded down to
+the closest natural number.  The boolean indicates if the result
+is exact (i.e., True means no rounding was done, False means rounded down).
+The second argument specifies which root we are computing. -}
+genRoot :: Integer -> Integer -> Maybe (Integer, Bool)
+genRoot _  0    = Nothing
+genRoot x0 1    = Just (x0, True)
+genRoot x0 root = Just (search 0 (x0+1))
+  where
+  search from to = let x = from + div (to - from) 2
+                       a = x ^ root
+                   in case compare a x0 of
+                        EQ              -> (x, True)
+                        LT | x /= from  -> search x to
+                           | otherwise  -> (from, False)
+                        GT | x /= to    -> search from x
+                           | otherwise  -> (from, False)
+
+{- | Compute the logarithm of a number in the given base, rounded down to the
+closest integer.  The boolean indicates if we the result is exact
+(i.e., True means no rounding happened, False means we rounded down).
+The logarithm base is the second argument. -}
+genLog :: Integer -> Integer -> Maybe (Integer, Bool)
+genLog x 0    = if x == 1 then Just (0, True) else Nothing
+genLog _ 1    = Nothing
+genLog 0 _    = Nothing
+genLog x base = Just (exactLoop 0 x)
+  where
+  exactLoop s i
+    | i == 1     = (s,True)
+    | i < base   = (s,False)
+    | otherwise  =
+        let s1 = s + 1
+        in s1 `seq` case divMod i base of
+                      (j,r)
+                        | r == 0    -> exactLoop s1 j
+                        | otherwise -> (underLoop s1 j, False)
+
+  underLoop s i
+    | i < base  = s
+    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTypeable.hs
@@ -0,0 +1,717 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcTypeable(mkTypeableBinds) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
+import TcBinds( addTypecheckedBinds )
+import IfaceEnv( newGlobalBinder )
+import TyCoRep( Type(..), TyLit(..) )
+import TcEnv
+import TcEvidence ( mkWpTyApps )
+import TcRnMonad
+import HscTypes ( lookupId )
+import PrelNames
+import TysPrim ( primTyCons )
+import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
+                  , vecCountTyCon, vecElemTyCon
+                  , nilDataCon, consDataCon )
+import Name
+import Id
+import Type
+import TyCon
+import DataCon
+import Module
+import HsSyn
+import DynFlags
+import Bag
+import Var ( VarBndr(..) )
+import CoreMap
+import Constants
+import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
+import Outputable
+import FastString ( FastString, mkFastString, fsLit )
+
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class (lift)
+import Data.Maybe ( isJust )
+import Data.Word( Word64 )
+
+{- Note [Grand plan for Typeable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The overall plan is this:
+
+1. Generate a binding for each module p:M
+   (done in TcTypeable by mkModIdBindings)
+       M.$trModule :: GHC.Types.Module
+       M.$trModule = Module "p" "M"
+   ("tr" is short for "type representation"; see GHC.Types)
+
+   We might want to add the filename too.
+   This can be used for the lightweight stack-tracing stuff too
+
+   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
+
+2. Generate a binding for every data type declaration T in module M,
+       M.$tcT :: GHC.Types.TyCon
+       M.$tcT = TyCon ...fingerprint info...
+                      $trModule
+                      "T"
+                      0#
+                      kind_rep
+
+   Here 0# is the number of arguments expected by the tycon to fully determine
+   its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a
+   recipe for computing the kind of an instantiation of the tycon (see
+   Note [Representing TyCon kinds: KindRep] later in this file for details).
+
+   We define (in TyCon)
+
+        type TyConRepName = Name
+
+   to use for these M.$tcT "tycon rep names". Note that these must be
+   treated as "never exported" names by Backpack (see
+   Note [Handling never-exported TyThings under Backpack]). Consequently
+   they get slightly special treatment in RnModIface.rnIfaceDecl.
+
+3. Record the TyConRepName in T's TyCon, including for promoted
+   data and type constructors, and kinds like * and #.
+
+   The TyConRepName is not an "implicit Id".  It's more like a record
+   selector: the TyCon knows its name but you have to go to the
+   interface file to find its type, value, etc
+
+4. Solve Typeable constraints.  This is done by a custom Typeable solver,
+   currently in TcInteract, that use M.$tcT so solve (Typeable T).
+
+There are many wrinkles:
+
+* The timing of when we produce this bindings is rather important: they must be
+  defined after the rest of the module has been typechecked since we need to be
+  able to lookup Module and TyCon in the type environment and we may be
+  currently compiling GHC.Types (where they are defined).
+
+* GHC.Prim doesn't have any associated object code, so we need to put the
+  representations for types defined in this module elsewhere. We chose this
+  place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for
+  injecting the bindings for the GHC.Prim representions when compiling
+  GHC.Types.
+
+* TyCon.tyConRepModOcc is responsible for determining where to find
+  the representation binding for a given type. This is where we handle
+  the special case for GHC.Prim.
+
+* To save space and reduce dependencies, we need use quite low-level
+  representations for TyCon and Module.  See GHC.Types
+  Note [Runtime representation of modules and tycons]
+
+* The KindReps can unfortunately get quite large. Moreover, the simplifier will
+  float out various pieces of them, resulting in numerous top-level bindings.
+  Consequently we mark the KindRep bindings as noinline, ensuring that the
+  float-outs don't make it into the interface file. This is important since
+  there is generally little benefit to inlining KindReps and they would
+  otherwise strongly affect compiler performance.
+
+* In general there are lots of things of kind *, * -> *, and * -> * -> *. To
+  reduce the number of bindings we need to produce, we generate their KindReps
+  once in GHC.Types. These are referred to as "built-in" KindReps below.
+
+* Even though KindReps aren't inlined, this scheme still has more of an effect on
+  compilation time than I'd like. This is especially true in the case of
+  families of type constructors (e.g. tuples and unboxed sums). The problem is
+  particularly bad in the case of sums, since each arity-N tycon brings with it
+  N promoted datacons, each with a KindRep whose size also scales with N.
+  Consequently we currently simply don't allow sums to be Typeable.
+
+  In general we might consider moving some or all of this generation logic back
+  to the solver since the performance hit we take in doing this at
+  type-definition time is non-trivial and Typeable isn't very widely used. This
+  is discussed in #13261.
+
+-}
+
+-- | Generate the Typeable bindings for a module. This is the only
+-- entry-point of this module and is invoked by the typechecker driver in
+-- 'tcRnSrcDecls'.
+--
+-- See Note [Grand plan for Typeable] in TcTypeable.
+mkTypeableBinds :: TcM TcGblEnv
+mkTypeableBinds
+  = do { -- Create a binding for $trModule.
+         -- Do this before processing any data type declarations,
+         -- which need tcg_tr_module to be initialised
+       ; tcg_env <- mkModIdBindings
+         -- Now we can generate the TyCon representations...
+         -- First we handle the primitive TyCons if we are compiling GHC.Types
+       ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
+
+         -- Then we produce bindings for the user-defined types in this module.
+       ; setGblEnv tcg_env $
+    do { mod <- getModule
+       ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
+             mod_id = case tcg_tr_module tcg_env of  -- Should be set by now
+                        Just mod_id -> mod_id
+                        Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
+       ; traceTc "mkTypeableBinds" (ppr tycons)
+       ; this_mod_todos <- todoForTyCons mod mod_id tycons
+       ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)
+       } }
+  where
+    needs_typeable_binds tc
+      | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]
+      = False
+      | otherwise =
+          isAlgTyCon tc
+       || isDataFamilyTyCon tc
+       || isClassTyCon tc
+
+
+{- *********************************************************************
+*                                                                      *
+            Building top-level binding for $trModule
+*                                                                      *
+********************************************************************* -}
+
+mkModIdBindings :: TcM TcGblEnv
+mkModIdBindings
+  = do { mod <- getModule
+       ; loc <- getSrcSpanM
+       ; mod_nm        <- newGlobalBinder mod (mkVarOcc "$trModule") loc
+       ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
+       ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
+       ; mod_bind      <- mkVarBind mod_id <$> mkModIdRHS mod
+
+       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
+       ; return (tcg_env { tcg_tr_module = Just mod_id }
+                 `addTypecheckedBinds` [unitBag mod_bind]) }
+
+mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
+mkModIdRHS mod
+  = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
+       ; trNameLit <- mkTrNameLit
+       ; return $ nlHsDataCon trModuleDataCon
+                  `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
+                  `nlHsApp` trNameLit (moduleNameFS (moduleName mod))
+       }
+
+{- *********************************************************************
+*                                                                      *
+                Building type-representation bindings
+*                                                                      *
+********************************************************************* -}
+
+-- | Information we need about a 'TyCon' to generate its representation. We
+-- carry the 'Id' in order to share it between the generation of the @TyCon@ and
+-- @KindRep@ bindings.
+data TypeableTyCon
+    = TypeableTyCon
+      { tycon        :: !TyCon
+      , tycon_rep_id :: !Id
+      }
+
+-- | A group of 'TyCon's in need of type-rep bindings.
+data TypeRepTodo
+    = TypeRepTodo
+      { mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding
+      , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint
+      , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint
+      , todo_tycons     :: [TypeableTyCon]
+        -- ^ The 'TyCon's in need of bindings kinds
+      }
+    | ExportedKindRepsTodo [(Kind, Id)]
+      -- ^ Build exported 'KindRep' bindings for the given set of kinds.
+
+todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
+todoForTyCons mod mod_id tycons = do
+    trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName
+    let mk_rep_id :: TyConRepName -> Id
+        mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy
+
+    let typeable_tycons :: [TypeableTyCon]
+        typeable_tycons =
+            [ TypeableTyCon { tycon = tc''
+                            , tycon_rep_id = mk_rep_id rep_name
+                            }
+            | tc     <- tycons
+            , tc'    <- tc : tyConATs tc
+              -- We need type representations for any associated types
+            , let promoted = map promoteDataCon (tyConDataCons tc')
+            , tc''   <- tc' : promoted
+              -- Don't make bindings for data-family instance tycons.
+              -- Do, however, make them for their promoted datacon (see #13915).
+            , not $ isFamInstTyCon tc''
+            , Just rep_name <- pure $ tyConRepName_maybe tc''
+            , typeIsTypeable $ dropForAlls $ tyConKind tc''
+            ]
+    return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id
+                       , pkg_fingerprint = pkg_fpr
+                       , mod_fingerprint = mod_fpr
+                       , todo_tycons     = typeable_tycons
+                       }
+  where
+    mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
+    pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
+
+todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
+todoForExportedKindReps kinds = do
+    trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName
+    let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)
+    return $ ExportedKindRepsTodo $ map mkId kinds
+
+-- | Generate TyCon bindings for a set of type constructors
+mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
+mkTypeRepTodoBinds [] = getGblEnv
+mkTypeRepTodoBinds todos
+  = do { stuff <- collect_stuff
+
+         -- First extend the type environment with all of the bindings
+         -- which we are going to produce since we may need to refer to them
+         -- while generating kind representations (namely, when we want to
+         -- represent a TyConApp in a kind, we must be able to look up the
+         -- TyCon associated with the applied type constructor).
+       ; let produced_bndrs :: [Id]
+             produced_bndrs = [ tycon_rep_id
+                              | todo@(TypeRepTodo{}) <- todos
+                              , TypeableTyCon {..} <- todo_tycons todo
+                              ] ++
+                              [ rep_id
+                              | ExportedKindRepsTodo kinds <- todos
+                              , (_, rep_id) <- kinds
+                              ]
+       ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv
+
+       ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
+             mk_binds todo@(TypeRepTodo {}) =
+                 mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)
+             mk_binds (ExportedKindRepsTodo kinds) =
+                 mkExportedKindReps stuff kinds >> return []
+
+       ; (gbl_env, binds) <- setGblEnv gbl_env
+                             $ runKindRepM (mapM mk_binds todos)
+       ; return $ gbl_env `addTypecheckedBinds` concat binds }
+
+-- | Generate bindings for the type representation of a wired-in 'TyCon's
+-- defined by the virtual "GHC.Prim" module. This is where we inject the
+-- representation bindings for these primitive types into "GHC.Types"
+--
+-- See Note [Grand plan for Typeable] in this module.
+mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
+mkPrimTypeableTodos
+  = do { mod <- getModule
+       ; if mod == gHC_TYPES
+           then do { -- Build Module binding for GHC.Prim
+                     trModuleTyCon <- tcLookupTyCon trModuleTyConName
+                   ; let ghc_prim_module_id =
+                             mkExportedVanillaId trGhcPrimModuleName
+                                                 (mkTyConTy trModuleTyCon)
+
+                   ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
+                                             <$> mkModIdRHS gHC_PRIM
+
+                     -- Extend our environment with above
+                   ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
+                                                     getGblEnv
+                   ; let gbl_env' = gbl_env `addTypecheckedBinds`
+                                    [unitBag ghc_prim_module_bind]
+
+                     -- Build TypeRepTodos for built-in KindReps
+                   ; todo1 <- todoForExportedKindReps builtInKindReps
+                     -- Build TypeRepTodos for types in GHC.Prim
+                   ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
+                                            ghcPrimTypeableTyCons
+                   ; return ( gbl_env' , [todo1, todo2])
+                   }
+           else do gbl_env <- getGblEnv
+                   return (gbl_env, [])
+       }
+
+-- | This is the list of primitive 'TyCon's for which we must generate bindings
+-- in "GHC.Types". This should include all types defined in "GHC.Prim".
+--
+-- The majority of the types we need here are contained in 'primTyCons'.
+-- However, not all of them: in particular unboxed tuples are absent since we
+-- don't want to include them in the original name cache. See
+-- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.
+ghcPrimTypeableTyCons :: [TyCon]
+ghcPrimTypeableTyCons = concat
+    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]
+    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
+    , map sumTyCon [2..mAX_SUM_SIZE]
+    , primTyCons
+    ]
+
+data TypeableStuff
+    = Stuff { dflags         :: DynFlags
+            , trTyConDataCon :: DataCon         -- ^ of @TyCon@
+            , trNameLit      :: FastString -> LHsExpr GhcTc
+                                                -- ^ To construct @TrName@s
+              -- The various TyCon and DataCons of KindRep
+            , kindRepTyCon           :: TyCon
+            , kindRepTyConAppDataCon :: DataCon
+            , kindRepVarDataCon      :: DataCon
+            , kindRepAppDataCon      :: DataCon
+            , kindRepFunDataCon      :: DataCon
+            , kindRepTYPEDataCon     :: DataCon
+            , kindRepTypeLitSDataCon :: DataCon
+            , typeLitSymbolDataCon   :: DataCon
+            , typeLitNatDataCon      :: DataCon
+            }
+
+-- | Collect various tidbits which we'll need to generate TyCon representations.
+collect_stuff :: TcM TypeableStuff
+collect_stuff = do
+    dflags <- getDynFlags
+    trTyConDataCon         <- tcLookupDataCon trTyConDataConName
+    kindRepTyCon           <- tcLookupTyCon   kindRepTyConName
+    kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
+    kindRepVarDataCon      <- tcLookupDataCon kindRepVarDataConName
+    kindRepAppDataCon      <- tcLookupDataCon kindRepAppDataConName
+    kindRepFunDataCon      <- tcLookupDataCon kindRepFunDataConName
+    kindRepTYPEDataCon     <- tcLookupDataCon kindRepTYPEDataConName
+    kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
+    typeLitSymbolDataCon   <- tcLookupDataCon typeLitSymbolDataConName
+    typeLitNatDataCon      <- tcLookupDataCon typeLitNatDataConName
+    trNameLit              <- mkTrNameLit
+    return Stuff {..}
+
+-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
+-- can save the work of repeating lookups when constructing many TyCon
+-- representations.
+mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
+mkTrNameLit = do
+    trNameSDataCon <- tcLookupDataCon trNameSDataConName
+    let trNameLit :: FastString -> LHsExpr GhcTc
+        trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
+                       `nlHsApp` nlHsLit (mkHsStringPrimLit fs)
+    return trNameLit
+
+-- | Make Typeable bindings for the given 'TyCon'.
+mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
+                -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
+mkTyConRepBinds stuff todo (TypeableTyCon {..})
+  = do -- Make a KindRep
+       let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)
+       liftTc $ traceTc "mkTyConKindRepBinds"
+                        (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)
+       let ctx = mkDeBruijnContext (map binderVar bndrs)
+       kind_rep <- getKindRep stuff ctx kind
+
+       -- Make the TyCon binding
+       let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
+           tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
+       return $ unitBag tycon_rep_bind
+
+-- | Here is where we define the set of Typeable types. These exclude type
+-- families and polytypes.
+tyConIsTypeable :: TyCon -> Bool
+tyConIsTypeable tc =
+       isJust (tyConRepName_maybe tc)
+    && typeIsTypeable (dropForAlls $ tyConKind tc)
+      -- Ensure that the kind of the TyCon, with its initial foralls removed,
+      -- is representable (e.g. has no higher-rank polymorphism or type
+      -- synonyms).
+
+-- | Is a particular 'Type' representable by @Typeable@? Here we look for
+-- polytypes and types containing casts (which may be, for instance, a type
+-- family).
+typeIsTypeable :: Type -> Bool
+-- We handle types of the form (TYPE rep) specifically to avoid
+-- looping on (tyConIsTypeable RuntimeRep)
+typeIsTypeable ty
+  | Just ty' <- coreView ty         = typeIsTypeable ty'
+typeIsTypeable ty
+  | isJust (kindRep_maybe ty)       = True
+typeIsTypeable (TyVarTy _)          = True
+typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b
+typeIsTypeable (FunTy _ a b)        = typeIsTypeable a && typeIsTypeable b
+typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc
+                                   && all typeIsTypeable args
+typeIsTypeable (ForAllTy{})         = False
+typeIsTypeable (LitTy _)            = True
+typeIsTypeable (CastTy{})           = False
+typeIsTypeable (CoercionTy{})       = False
+
+-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
+-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
+-- or a binding which we generated in the current module (in which case it will
+-- be 'Just' the RHS of the binding).
+type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
+
+-- | A monad within which we will generate 'KindRep's. Here we keep an
+-- environment containing 'KindRep's which we've already generated so we can
+-- re-use them opportunistically.
+newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
+                   deriving (Functor, Applicative, Monad)
+
+liftTc :: TcRn a -> KindRepM a
+liftTc = KindRepM . lift
+
+-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they
+-- can be reused across modules.
+builtInKindReps :: [(Kind, Name)]
+builtInKindReps =
+    [ (star, starKindRepName)
+    , (mkVisFunTy star star, starArrStarKindRepName)
+    , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName)
+    ]
+  where
+    star = liftedTypeKind
+
+initialKindRepEnv :: TcRn KindRepEnv
+initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
+  where
+    add_kind_rep acc (k,n) = do
+        id <- tcLookupId n
+        return $! extendTypeMap acc k (id, Nothing)
+
+-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
+mkExportedKindReps :: TypeableStuff
+                   -> [(Kind, Id)]  -- ^ the kinds to generate bindings for
+                   -> KindRepM ()
+mkExportedKindReps stuff = mapM_ kindrep_binding
+  where
+    empty_scope = mkDeBruijnContext []
+
+    kindrep_binding :: (Kind, Id) -> KindRepM ()
+    kindrep_binding (kind, rep_bndr) = do
+        -- We build the binding manually here instead of using mkKindRepRhs
+        -- since the latter would find the built-in 'KindRep's in the
+        -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
+        rhs <- mkKindRepRhs stuff empty_scope kind
+        addKindRepBind empty_scope kind rep_bndr rhs
+
+addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
+addKindRepBind in_scope k bndr rhs =
+    KindRepM $ modify' $
+    \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)
+
+-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
+-- environment.
+runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
+runKindRepM (KindRepM action) = do
+    kindRepEnv <- initialKindRepEnv
+    (res, reps_env) <- runStateT action kindRepEnv
+    let rep_binds = foldTypeMap to_bind_pair [] reps_env
+        to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest
+        to_bind_pair (_, Nothing) rest = rest
+    tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
+    let binds = map (uncurry mkVarBind) rep_binds
+        tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]
+    return (tcg_env', res)
+
+-- | Produce or find a 'KindRep' for the given kind.
+getKindRep :: TypeableStuff -> CmEnv  -- ^ in-scope kind variables
+           -> Kind   -- ^ the kind we want a 'KindRep' for
+           -> KindRepM (LHsExpr GhcTc)
+getKindRep stuff@(Stuff {..}) in_scope = go
+  where
+    go :: Kind -> KindRepM (LHsExpr GhcTc)
+    go = KindRepM . StateT . go'
+
+    go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
+    go' k env
+        -- Look through type synonyms
+      | Just k' <- tcView k = go' k' env
+
+        -- We've already generated the needed KindRep
+      | Just (id, _) <- lookupTypeMapWithScope env in_scope k
+      = return (nlHsVar id, env)
+
+        -- We need to construct a new KindRep binding
+      | otherwise
+      = do -- Place a NOINLINE pragma on KindReps since they tend to be quite
+           -- large and bloat interface files.
+           rep_bndr <- (`setInlinePragma` neverInlinePragma)
+                   <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
+
+           -- do we need to tie a knot here?
+           flip runStateT env $ unKindRepM $ do
+               rhs <- mkKindRepRhs stuff in_scope k
+               addKindRepBind in_scope k rep_bndr rhs
+               return $ nlHsVar rep_bndr
+
+-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and
+-- in-scope kind variable set.
+mkKindRepRhs :: TypeableStuff
+             -> CmEnv       -- ^ in-scope kind variables
+             -> Kind        -- ^ the kind we want a 'KindRep' for
+             -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression
+mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
+  where
+    new_kind_rep k
+        -- We handle (TYPE LiftedRep) etc separately to make it
+        -- clear to consumers (e.g. serializers) that there is
+        -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)
+      | not (tcIsConstraintKind k)
+              -- Typeable respects the Constraint/Type distinction
+              -- so do not follow the special case here
+      , Just arg <- kindRep_maybe k
+      , Just (tc, []) <- splitTyConApp_maybe arg
+      , Just dc <- isPromotedDataCon_maybe tc
+      = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc
+
+    new_kind_rep (TyVarTy v)
+      | Just idx <- lookupCME in_scope v
+      = return $ nlHsDataCon kindRepVarDataCon
+                 `nlHsApp` nlHsIntLit (fromIntegral idx)
+      | otherwise
+      = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
+
+    new_kind_rep (AppTy t1 t2)
+      = do rep1 <- getKindRep stuff in_scope t1
+           rep2 <- getKindRep stuff in_scope t2
+           return $ nlHsDataCon kindRepAppDataCon
+                    `nlHsApp` rep1 `nlHsApp` rep2
+
+    new_kind_rep k@(TyConApp tc tys)
+      | Just rep_name <- tyConRepName_maybe tc
+      = do rep_id <- liftTc $ lookupId rep_name
+           tys' <- mapM (getKindRep stuff in_scope) tys
+           return $ nlHsDataCon kindRepTyConAppDataCon
+                    `nlHsApp` nlHsVar rep_id
+                    `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
+      | otherwise
+      = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
+
+    new_kind_rep (ForAllTy (Bndr var _) ty)
+      = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
+
+    new_kind_rep (FunTy _ t1 t2)
+      = do rep1 <- getKindRep stuff in_scope t1
+           rep2 <- getKindRep stuff in_scope t2
+           return $ nlHsDataCon kindRepFunDataCon
+                    `nlHsApp` rep1 `nlHsApp` rep2
+
+    new_kind_rep (LitTy (NumTyLit n))
+      = return $ nlHsDataCon kindRepTypeLitSDataCon
+                 `nlHsApp` nlHsDataCon typeLitNatDataCon
+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
+
+    new_kind_rep (LitTy (StrTyLit s))
+      = return $ nlHsDataCon kindRepTypeLitSDataCon
+                 `nlHsApp` nlHsDataCon typeLitSymbolDataCon
+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
+
+    new_kind_rep (CastTy ty co)
+      = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
+
+    new_kind_rep (CoercionTy co)
+      = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
+
+-- | Produce the right-hand-side of a @TyCon@ representation.
+mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
+                   -> TyCon      -- ^ the 'TyCon' we are producing a binding for
+                   -> LHsExpr GhcTc -- ^ its 'KindRep'
+                   -> LHsExpr GhcTc
+mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
+  =           nlHsDataCon trTyConDataCon
+    `nlHsApp` nlHsLit (word64 dflags high)
+    `nlHsApp` nlHsLit (word64 dflags low)
+    `nlHsApp` mod_rep_expr todo
+    `nlHsApp` trNameLit (mkFastString tycon_str)
+    `nlHsApp` nlHsLit (int n_kind_vars)
+    `nlHsApp` kind_rep
+  where
+    n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
+    tycon_str = add_tick (occNameString (getOccName tycon))
+    add_tick s | isPromotedDataCon tycon = '\'' : s
+               | otherwise               = s
+
+    -- This must match the computation done in
+    -- Data.Typeable.Internal.mkTyConFingerprint.
+    Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
+                                                   , mod_fingerprint todo
+                                                   , fingerprintString tycon_str
+                                                   ]
+
+    int :: Int -> HsLit GhcTc
+    int n = HsIntPrim (SourceText $ show n) (toInteger n)
+
+word64 :: DynFlags -> Word64 -> HsLit GhcTc
+word64 dflags n
+  | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
+  | otherwise             = HsWordPrim   NoSourceText (toInteger n)
+
+{-
+Note [Representing TyCon kinds: KindRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One of the operations supported by Typeable is typeRepKind,
+
+    typeRepKind :: TypeRep (a :: k) -> TypeRep k
+
+Implementing this is a bit tricky for poly-kinded types like
+
+    data Proxy (a :: k) :: Type
+    -- Proxy :: forall k. k -> Type
+
+The TypeRep encoding of `Proxy Type Int` looks like this:
+
+    $tcProxy :: GHC.Types.TyCon
+    $trInt   :: TypeRep Int
+    TrType   :: TypeRep Type
+
+    $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
+    $trProxyType = TrTyCon $tcProxy
+                           [TrType]  -- kind variable instantiation
+                           (tyConKind $tcProxy [TrType]) -- The TypeRep of
+                                                         -- Type -> Type
+
+    $trProxy :: TypeRep (Proxy Type Int)
+    $trProxy = TrApp $trProxyType $trInt TrType
+
+    $tkProxy :: GHC.Types.KindRep
+    $tkProxy = KindRepFun (KindRepVar 0)
+                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])
+
+Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
+polymorphic types.  So instead
+
+ * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)
+   of all its kind arguments. We can't represent a tycon that is
+   applied to only some of its kind arguments.
+
+ * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a
+   GHC.Types.KindRep, which represents the polymorphic kind of Proxy
+       Proxy :: forall k. k->Type
+
+ * A KindRep is just a recipe that we can instantiate with the
+   argument kinds, using Data.Typeable.Internal.tyConKind and
+   store in the relevant 'TypeRep' constructor.
+
+   Data.Typeable.Internal.typeRepKind looks up the stored kinds.
+
+ * In a KindRep, the kind variables are represented by 0-indexed
+   de Bruijn numbers:
+
+    type KindBndr = Int   -- de Bruijn index
+
+    data KindRep = KindRepTyConApp TyCon [KindRep]
+                 | KindRepVar !KindBndr
+                 | KindRepApp KindRep KindRep
+                 | KindRepFun KindRep KindRep
+                 ...
+-}
+
+mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
+mkList ty = foldr consApp (nilExpr ty)
+  where
+    cons = consExpr ty
+    consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
+    consApp x xs = cons `nlHsApp` x `nlHsApp` xs
+
+    nilExpr :: Type -> LHsExpr GhcTc
+    nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
+
+    consExpr :: Type -> LHsExpr GhcTc
+    consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcUnify.hs
@@ -0,0 +1,2254 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Type subsumption and unification
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-}
+
+module TcUnify (
+  -- Full-blown subsumption
+  tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,
+  tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS,
+  tcSubTypeDS_NC_O, tcSubTypeET,
+  checkConstraints, checkTvConstraints,
+  buildImplicationFor, emitResidualTvConstraint,
+
+  -- Various unifications
+  unifyType, unifyKind,
+  uType, promoteTcType,
+  swapOverTyVars, canSolveByUnification,
+
+  --------------------------------
+  -- Holes
+  tcInferInst, tcInferNoInst,
+  matchExpectedListTy,
+  matchExpectedTyConApp,
+  matchExpectedAppTy,
+  matchExpectedFunTys,
+  matchActualFunTys, matchActualFunTysPart,
+  matchExpectedFunKind,
+
+  metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)
+
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TyCoRep
+import TcMType
+import TcRnMonad
+import TcType
+import Type
+import Coercion
+import TcEvidence
+import Name( isSystemName )
+import Inst
+import TyCon
+import TysWiredIn
+import TysPrim( tYPE )
+import Var
+import VarSet
+import VarEnv
+import ErrUtils
+import DynFlags
+import BasicTypes
+import Bag
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import Outputable
+
+import Control.Monad
+import Control.Arrow ( second )
+
+{-
+************************************************************************
+*                                                                      *
+             matchExpected functions
+*                                                                      *
+************************************************************************
+
+Note [Herald for matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'herald' always looks like:
+   "The equation(s) for 'f' have"
+   "The abstraction (\x.e) takes"
+   "The section (+ x) expects"
+   "The function 'f' is applied to"
+
+This is used to construct a message of form
+
+   The abstraction `\Just 1 -> ...' takes two arguments
+   but its type `Maybe a -> a' has only one
+
+   The equation(s) for `f' have two arguments
+   but its type `Maybe a -> a' has only one
+
+   The section `(f 3)' requires 'f' to take two arguments
+   but its type `Int -> Int' has only one
+
+   The function 'f' is applied to two arguments
+   but its type `Int -> Int' has only one
+
+When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the
+picture, we have a choice in deciding whether to count the type applications as
+proper arguments:
+
+   The function 'f' is applied to one visible type argument
+     and two value arguments
+   but its type `forall a. a -> a` has only one visible type argument
+     and one value argument
+
+Or whether to include the type applications as part of the herald itself:
+
+   The expression 'f @Int' is applied to two arguments
+   but its type `Int -> Int` has only one
+
+The latter is easier to implement and is arguably easier to understand, so we
+choose to implement that option.
+
+Note [matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+matchExpectedFunTys checks that a sigma has the form
+of an n-ary function.  It passes the decomposed type to the
+thing_inside, and returns a wrapper to coerce between the two types
+
+It's used wherever a language construct must have a functional type,
+namely:
+        A lambda expression
+        A function definition
+     An operator section
+
+This function must be written CPS'd because it needs to fill in the
+ExpTypes produced for arguments before it can fill in the ExpType
+passed in.
+
+-}
+
+-- Use this one when you have an "expected" type.
+matchExpectedFunTys :: forall a.
+                       SDoc   -- See Note [Herald for matchExpectedFunTys]
+                    -> Arity
+                    -> ExpRhoType  -- deeply skolemised
+                    -> ([ExpSigmaType] -> ExpRhoType -> TcM a)
+                          -- must fill in these ExpTypes here
+                    -> TcM (a, HsWrapper)
+-- If    matchExpectedFunTys n ty = (_, wrap)
+-- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,
+--   where [t1, ..., tn], ty_r are passed to the thing_inside
+matchExpectedFunTys herald arity orig_ty thing_inside
+  = case orig_ty of
+      Check ty -> go [] arity ty
+      _        -> defer [] arity orig_ty
+  where
+    go acc_arg_tys 0 ty
+      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty)
+           ; return (result, idHsWrapper) }
+
+    go acc_arg_tys n ty
+      | Just ty' <- tcView ty = go acc_arg_tys n ty'
+
+    go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })
+      = ASSERT( af == VisArg )
+        do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys)
+                                      (n-1) res_ty
+           ; return ( result
+                    , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) }
+      where
+        doc = text "When inferring the argument type of a function with type" <+>
+              quotes (ppr orig_ty)
+
+    go acc_arg_tys n ty@(TyVarTy tv)
+      | isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty' -> go acc_arg_tys n ty'
+               Flexi        -> defer acc_arg_tys n (mkCheckExpType ty) }
+
+       -- In all other cases we bale out into ordinary unification
+       -- However unlike the meta-tyvar case, we are sure that the
+       -- number of arguments doesn't match arity of the original
+       -- type, so we can add a bit more context to the error message
+       -- (cf #7869).
+       --
+       -- It is not always an error, because specialized type may have
+       -- different arity, for example:
+       --
+       -- > f1 = f2 'a'
+       -- > f2 :: Monad m => m Bool
+       -- > f2 = undefined
+       --
+       -- But in that case we add specialized type into error context
+       -- anyway, because it may be useful. See also #9605.
+    go acc_arg_tys n ty = addErrCtxtM mk_ctxt $
+                          defer acc_arg_tys n (mkCheckExpType ty)
+
+    ------------
+    defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper)
+    defer acc_arg_tys n fun_ty
+      = do { more_arg_tys <- replicateM n newInferExpTypeNoInst
+           ; res_ty       <- newInferExpTypeInst
+           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty
+           ; more_arg_tys <- mapM readExpType more_arg_tys
+           ; res_ty       <- readExpType res_ty
+           ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty
+           ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty
+                         -- Not a good origin at all :-(
+           ; return (result, wrap) }
+
+    ------------
+    mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc)
+    mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty
+                     ; let (args, _) = tcSplitFunTys ty
+                           n_actual = length args
+                           (env'', orig_ty') = tidyOpenType env' orig_tc_ty
+                     ; return ( env''
+                              , mk_fun_tys_msg orig_ty' ty n_actual arity herald) }
+      where
+        orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty
+            -- this is safe b/c we're called from "go"
+
+-- Like 'matchExpectedFunTys', but used when you have an "actual" type,
+-- for example in function application
+matchActualFunTys :: SDoc   -- See Note [Herald for matchExpectedFunTys]
+                  -> CtOrigin
+                  -> Maybe (HsExpr GhcRn)   -- the thing with type TcSigmaType
+                  -> Arity
+                  -> TcSigmaType
+                  -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+-- If    matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r)
+-- then  wrap : ty ~> (t1 -> ... -> tn -> ty_r)
+matchActualFunTys herald ct_orig mb_thing arity ty
+  = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity
+
+-- | Variant of 'matchActualFunTys' that works when supplied only part
+-- (that is, to the right of some arrows) of the full function type
+matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys]
+                      -> CtOrigin
+                      -> Maybe (HsExpr GhcRn)  -- the thing with type TcSigmaType
+                      -> Arity
+                      -> TcSigmaType
+                      -> [TcSigmaType] -- reversed args. See (*) below.
+                      -> Arity   -- overall arity of the function, for errs
+                      -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+matchActualFunTysPart herald ct_orig mb_thing arity orig_ty
+                      orig_old_args full_arity
+  = go arity orig_old_args orig_ty
+-- Does not allocate unnecessary meta variables: if the input already is
+-- a function, we just take it apart.  Not only is this efficient,
+-- it's important for higher rank: the argument might be of form
+--              (forall a. ty) -> other
+-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
+-- hide the forall inside a meta-variable
+
+-- (*) Sometimes it's necessary to call matchActualFunTys with only part
+-- (that is, to the right of some arrows) of the type of the function in
+-- question. (See TcExpr.tcArgs.) This argument is the reversed list of
+-- arguments already seen (that is, not part of the TcSigmaType passed
+-- in elsewhere).
+
+  where
+    -- This function has a bizarre mechanic: it accumulates arguments on
+    -- the way down and also builds an argument list on the way up. Why:
+    -- 1. The returns args list and the accumulated args list might be different.
+    --    The accumulated args include all the arg types for the function,
+    --    including those from before this function was called. The returned
+    --    list should include only those arguments produced by this call of
+    --    matchActualFunTys
+    --
+    -- 2. The HsWrapper can be built only on the way up. It seems (more)
+    --    bizarre to build the HsWrapper but not the arg_tys.
+    --
+    -- Refactoring is welcome.
+    go :: Arity
+       -> [TcSigmaType] -- accumulator of arguments (reversed)
+       -> TcSigmaType   -- the remainder of the type as we're processing
+       -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+    go 0 _ ty = return (idHsWrapper, [], ty)
+
+    go n acc_args ty
+      | not (null tvs && null theta)
+      = do { (wrap1, rho) <- topInstantiate ct_orig ty
+           ; (wrap2, arg_tys, res_ty) <- go n acc_args rho
+           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
+      where
+        (tvs, theta, _) = tcSplitSigmaTy ty
+
+    go n acc_args ty
+      | Just ty' <- tcView ty = go n acc_args ty'
+
+    go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })
+      = ASSERT( af == VisArg )
+        do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty
+           ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc
+                    , arg_ty : tys, ty_r ) }
+      where
+        doc = text "When inferring the argument type of a function with type" <+>
+              quotes (ppr orig_ty)
+
+    go n acc_args ty@(TyVarTy tv)
+      | isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty' -> go n acc_args ty'
+               Flexi        -> defer n ty }
+
+       -- In all other cases we bale out into ordinary unification
+       -- However unlike the meta-tyvar case, we are sure that the
+       -- number of arguments doesn't match arity of the original
+       -- type, so we can add a bit more context to the error message
+       -- (cf #7869).
+       --
+       -- It is not always an error, because specialized type may have
+       -- different arity, for example:
+       --
+       -- > f1 = f2 'a'
+       -- > f2 :: Monad m => m Bool
+       -- > f2 = undefined
+       --
+       -- But in that case we add specialized type into error context
+       -- anyway, because it may be useful. See also #9605.
+    go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $
+                       defer n ty
+
+    ------------
+    defer n fun_ty
+      = do { arg_tys <- replicateM n newOpenFlexiTyVarTy
+           ; res_ty  <- newOpenFlexiTyVarTy
+           ; let unif_fun_ty = mkVisFunTys arg_tys res_ty
+           ; co <- unifyType mb_thing fun_ty unif_fun_ty
+           ; return (mkWpCastN co, arg_tys, res_ty) }
+
+    ------------
+    mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
+    mk_ctxt arg_tys res_ty env
+      = do { let ty = mkVisFunTys arg_tys res_ty
+           ; (env1, zonked) <- zonkTidyTcType env ty
+                   -- zonking might change # of args
+           ; let (zonked_args, _) = tcSplitFunTys zonked
+                 n_actual         = length zonked_args
+                 (env2, unzonked) = tidyOpenType env1 ty
+           ; return ( env2
+                    , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) }
+
+mk_fun_tys_msg :: TcType  -- the full type passed in (unzonked)
+               -> TcType  -- the full type passed in (zonked)
+               -> Arity   -- the # of args found
+               -> Arity   -- the # of args wanted
+               -> SDoc    -- overall herald
+               -> SDoc
+mk_fun_tys_msg full_ty ty n_args full_arity herald
+  = herald <+> speakNOf full_arity (text "argument") <> comma $$
+    if n_args == full_arity
+      then text "its type is" <+> quotes (pprType full_ty) <>
+           comma $$
+           text "it is specialized to" <+> quotes (pprType ty)
+      else sep [text "but its type" <+> quotes (pprType ty),
+                if n_args == 0 then text "has none"
+                else text "has only" <+> speakN n_args]
+
+----------------------
+matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)
+-- Special case for lists
+matchExpectedListTy exp_ty
+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
+      ; return (co, elt_ty) }
+
+---------------------
+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *
+                      -> TcRhoType            -- orig_ty
+                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty
+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c
+
+-- It's used for wired-in tycons, so we call checkWiredInTyCon
+-- Precondition: never called with FunTyCon
+-- Precondition: input type :: *
+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded
+
+matchExpectedTyConApp tc orig_ty
+  = ASSERT(tc /= funTyCon) go orig_ty
+  where
+    go ty
+       | Just ty' <- tcView ty
+       = go ty'
+
+    go ty@(TyConApp tycon args)
+       | tc == tycon  -- Common case
+       = return (mkTcNomReflCo ty, args)
+
+    go (TyVarTy tv)
+       | isMetaTyVar tv
+       = do { cts <- readMetaTyVar tv
+            ; case cts of
+                Indirect ty -> go ty
+                Flexi       -> defer }
+
+    go _ = defer
+
+    -- If the common case does not occur, instantiate a template
+    -- T k1 .. kn t1 .. tm, and unify with the original type
+    -- Doing it this way ensures that the types we return are
+    -- kind-compatible with T.  For example, suppose we have
+    --       matchExpectedTyConApp T (f Maybe)
+    -- where data T a = MkT a
+    -- Then we don't want to instantiate T's data constructors with
+    --    (a::*) ~ Maybe
+    -- because that'll make types that are utterly ill-kinded.
+    -- This happened in #7368
+    defer
+      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)
+           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)
+           ; let args = mkTyVarTys arg_tvs
+                 tc_template = mkTyConApp tc args
+           ; co <- unifyType Nothing tc_template orig_ty
+           ; return (co, args) }
+
+----------------------
+matchExpectedAppTy :: TcRhoType                         -- orig_ty
+                   -> TcM (TcCoercion,                   -- m a ~N orig_ty
+                           (TcSigmaType, TcSigmaType))  -- Returns m, a
+-- If the incoming type is a mutable type variable of kind k, then
+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
+
+matchExpectedAppTy orig_ty
+  = go orig_ty
+  where
+    go ty
+      | Just ty' <- tcView ty = go ty'
+
+      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+      = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))
+
+    go (TyVarTy tv)
+      | isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty -> go ty
+               Flexi       -> defer }
+
+    go _ = defer
+
+    -- Defer splitting by generating an equality constraint
+    defer
+      = do { ty1 <- newFlexiTyVarTy kind1
+           ; ty2 <- newFlexiTyVarTy kind2
+           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty
+           ; return (co, (ty1, ty2)) }
+
+    orig_kind = tcTypeKind orig_ty
+    kind1 = mkVisFunTy liftedTypeKind orig_kind
+    kind2 = liftedTypeKind    -- m :: * -> k
+                              -- arg type :: *
+
+{-
+************************************************************************
+*                                                                      *
+                Subsumption checking
+*                                                                      *
+************************************************************************
+
+Note [Subsumption checking: tcSubType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+All the tcSubType calls have the form
+                tcSubType actual_ty expected_ty
+which checks
+                actual_ty <= expected_ty
+
+That is, that a value of type actual_ty is acceptable in
+a place expecting a value of type expected_ty.  I.e. that
+
+    actual ty   is more polymorphic than   expected_ty
+
+It returns a coercion function
+        co_fn :: actual_ty ~ expected_ty
+which takes an HsExpr of type actual_ty into one of type
+expected_ty.
+
+These functions do not actually check for subsumption. They check if
+expected_ty is an appropriate annotation to use for something of type
+actual_ty. This difference matters when thinking about visible type
+application. For example,
+
+   forall a. a -> forall b. b -> b
+      DOES NOT SUBSUME
+   forall a b. a -> b -> b
+
+because the type arguments appear in a different order. (Neither does
+it work the other way around.) BUT, these types are appropriate annotations
+for one another. Because the user directs annotations, it's OK if some
+arguments shuffle around -- after all, it's what the user wants.
+Bottom line: none of this changes with visible type application.
+
+There are a number of wrinkles (below).
+
+Notice that Wrinkle 1 and 2 both require eta-expansion, which technically
+may increase termination.  We just put up with this, in exchange for getting
+more predictable type inference.
+
+Wrinkle 1: Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want   (forall a. Int -> a -> a)  <=  (Int -> forall a. a->a)
+(see section 4.6 of "Practical type inference for higher rank types")
+So we must deeply-skolemise the RHS before we instantiate the LHS.
+
+That is why tc_sub_type starts with a call to tcSkolemise (which does the
+deep skolemisation), and then calls the DS variant (which assumes
+that expected_ty is deeply skolemised)
+
+Wrinkle 2: Note [Co/contra-variance of subsumption checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider  g :: (Int -> Int) -> Int
+  f1 :: (forall a. a -> a) -> Int
+  f1 = g
+
+  f2 :: (forall a. a -> a) -> Int
+  f2 x = g x
+f2 will typecheck, and it would be odd/fragile if f1 did not.
+But f1 will only typecheck if we have that
+    (Int->Int) -> Int  <=  (forall a. a->a) -> Int
+And that is only true if we do the full co/contravariant thing
+in the subsumption check.  That happens in the FunTy case of
+tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of
+HsWrapper.
+
+Another powerful reason for doing this co/contra stuff is visible
+in #9569, involving instantiation of constraint variables,
+and again involving eta-expansion.
+
+Wrinkle 3: Note [Higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider tc150:
+  f y = \ (x::forall a. a->a). blah
+The following happens:
+* We will infer the type of the RHS, ie with a res_ty = alpha.
+* Then the lambda will split  alpha := beta -> gamma.
+* And then we'll check tcSubType IsSwapped beta (forall a. a->a)
+
+So it's important that we unify beta := forall a. a->a, rather than
+skolemising the type.
+-}
+
+
+-- | Call this variant when you are in a higher-rank situation and
+-- you know the right-hand type is deeply skolemised.
+tcSubTypeHR :: CtOrigin               -- ^ of the actual type
+            -> Maybe (HsExpr GhcRn)   -- ^ If present, it has type ty_actual
+            -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt
+
+------------------------
+tcSubTypeET :: CtOrigin -> UserTypeCtxt
+            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+-- If wrap = tc_sub_type_et t1 t2
+--    => wrap :: t1 ~> t2
+tcSubTypeET orig ctxt (Check ty_actual) ty_expected
+  = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected
+  where
+    eq_orig = TypeEqOrigin { uo_actual   = ty_expected
+                           , uo_expected = ty_actual
+                           , uo_thing    = Nothing
+                           , uo_visible  = True }
+
+tcSubTypeET _ _ (Infer inf_res) ty_expected
+  = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )
+      -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never
+      -- has the ir_inst field set.  Reason: in patterns (which is what
+      -- tcSubTypeET is used for) do not aggressively instantiate
+    do { co <- fill_infer_result ty_expected inf_res
+               -- Since ir_inst is false, we can skip fillInferResult
+               -- and go straight to fill_infer_result
+
+       ; return (mkWpCastN (mkTcSymCo co)) }
+
+------------------------
+tcSubTypeO :: CtOrigin      -- ^ of the actual type
+           -> UserTypeCtxt  -- ^ of the expected type
+           -> TcSigmaType
+           -> ExpRhoType
+           -> TcM HsWrapper
+tcSubTypeO orig ctxt ty_actual ty_expected
+  = addSubTypeCtxt ty_actual ty_expected $
+    do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig
+                                       , pprUserTypeCtxt ctxt
+                                       , ppr ty_actual
+                                       , ppr ty_expected ])
+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
+
+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a
+addSubTypeCtxt ty_actual ty_expected thing_inside
+ | isRhoTy ty_actual        -- If there is no polymorphism involved, the
+ , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)
+ = thing_inside             -- gives enough context by itself
+ | otherwise
+ = addErrCtxtM mk_msg thing_inside
+  where
+    mk_msg tidy_env
+      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual
+                   -- might not be filled if we're debugging. ugh.
+           ; mb_ty_expected          <- readExpType_maybe ty_expected
+           ; (tidy_env, ty_expected) <- case mb_ty_expected of
+                                          Just ty -> second mkCheckExpType <$>
+                                                     zonkTidyTcType tidy_env ty
+                                          Nothing -> return (tidy_env, ty_expected)
+           ; ty_expected             <- readExpType ty_expected
+           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected
+           ; let msg = vcat [ hang (text "When checking that:")
+                                 4 (ppr ty_actual)
+                            , nest 2 (hang (text "is more polymorphic than:")
+                                         2 (ppr ty_expected)) ]
+           ; return (tidy_env, msg) }
+
+---------------
+-- The "_NC" variants do not add a typechecker-error context;
+-- the caller is assumed to do that
+
+tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- Checks that actual <= expected
+-- Returns HsWrapper :: actual ~ expected
+tcSubType_NC ctxt ty_actual ty_expected
+  = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
+       ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected }
+  where
+    origin = TypeEqOrigin { uo_actual   = ty_actual
+                          , uo_expected = ty_expected
+                          , uo_thing    = Nothing
+                          , uo_visible  = True }
+
+tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+-- Just like tcSubType, but with the additional precondition that
+-- ty_expected is deeply skolemised (hence "DS")
+tcSubTypeDS orig ctxt ty_actual ty_expected
+  = addSubTypeCtxt ty_actual ty_expected $
+    do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
+
+tcSubTypeDS_NC_O :: CtOrigin   -- origin used for instantiation only
+                 -> UserTypeCtxt
+                 -> Maybe (HsExpr GhcRn)
+                 -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+-- Just like tcSubType, but with the additional precondition that
+-- ty_expected is deeply skolemised
+tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected
+  = case ty_expected of
+      Infer inf_res -> fillInferResult inst_orig ty_actual inf_res
+      Check ty      -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty
+         where
+           eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty
+                                  , uo_thing  = ppr <$> m_thing
+                                  , uo_visible = True }
+
+---------------
+tc_sub_tc_type :: CtOrigin   -- used when calling uType
+               -> CtOrigin   -- used when instantiating
+               -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- If wrap = tc_sub_type t1 t2
+--    => wrap :: t1 ~> t2
+tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected
+  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]
+  , not (possibly_poly ty_actual)
+  = do { traceTc "tc_sub_tc_type (drop to equality)" $
+         vcat [ text "ty_actual   =" <+> ppr ty_actual
+              , text "ty_expected =" <+> ppr ty_expected ]
+       ; mkWpCastN <$>
+         uType TypeLevel eq_orig ty_actual ty_expected }
+
+  | otherwise   -- This is the general case
+  = do { traceTc "tc_sub_tc_type (general case)" $
+         vcat [ text "ty_actual   =" <+> ppr ty_actual
+              , text "ty_expected =" <+> ppr ty_expected ]
+       ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $
+                                                   \ _ sk_rho ->
+                                  tc_sub_type_ds eq_orig inst_orig ctxt
+                                                 ty_actual sk_rho
+       ; return (sk_wrap <.> inner_wrap) }
+  where
+    possibly_poly ty
+      | isForAllTy ty                        = True
+      | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res
+      | otherwise                            = False
+      -- NB *not* tcSplitFunTy, because here we want
+      -- to decompose type-class arguments too
+
+    definitely_poly ty
+      | (tvs, theta, tau) <- tcSplitSigmaTy ty
+      , (tv:_) <- tvs
+      , null theta
+      , isInsolubleOccursCheck NomEq tv tau
+      = True
+      | otherwise
+      = False
+
+{- Note [Don't skolemise unnecessarily]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are trying to solve
+    (Char->Char) <= (forall a. a->a)
+We could skolemise the 'forall a', and then complain
+that (Char ~ a) is insoluble; but that's a pretty obscure
+error.  It's better to say that
+    (Char->Char) ~ (forall a. a->a)
+fails.
+
+So roughly:
+ * if the ty_expected has an outermost forall
+      (i.e. skolemisation is the next thing we'd do)
+ * and the ty_actual has no top-level polymorphism (but looking deeply)
+then we can revert to simple equality.  But we need to be careful.
+These examples are all fine:
+
+ * (Char -> forall a. a->a) <= (forall a. Char -> a -> a)
+      Polymorphism is buried in ty_actual
+
+ * (Char->Char) <= (forall a. Char -> Char)
+      ty_expected isn't really polymorphic
+
+ * (Char->Char) <= (forall a. (a~Char) => a -> a)
+      ty_expected isn't really polymorphic
+
+ * (Char->Char) <= (forall a. F [a] Char -> Char)
+                   where type instance F [x] t = t
+     ty_expected isn't really polymorphic
+
+If we prematurely go to equality we'll reject a program we should
+accept (e.g. #13752).  So the test (which is only to improve
+error message) is very conservative:
+ * ty_actual is /definitely/ monomorphic
+ * ty_expected is /definitely/ polymorphic
+-}
+
+---------------
+tc_sub_type_ds :: CtOrigin    -- used when calling uType
+               -> CtOrigin    -- used when instantiating
+               -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper
+-- If wrap = tc_sub_type_ds t1 t2
+--    => wrap :: t1 ~> t2
+-- Here is where the work actually happens!
+-- Precondition: ty_expected is deeply skolemised
+tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
+  = do { traceTc "tc_sub_type_ds" $
+         vcat [ text "ty_actual   =" <+> ppr ty_actual
+              , text "ty_expected =" <+> ppr ty_expected ]
+       ; go ty_actual ty_expected }
+  where
+    go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e
+                 | Just ty_e' <- tcView ty_e = go ty_a  ty_e'
+
+    go (TyVarTy tv_a) ty_e
+      = do { lookup_res <- lookupTcTyVar tv_a
+           ; case lookup_res of
+               Filled ty_a' ->
+                 do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:"
+                        (ppr tv_a <+> text "-->" <+> ppr ty_a')
+                    ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e }
+               Unfilled _   -> unify }
+
+    -- Historical note (Sept 16): there was a case here for
+    --    go ty_a (TyVarTy alpha)
+    -- which, in the impredicative case unified  alpha := ty_a
+    -- where th_a is a polytype.  Not only is this probably bogus (we
+    -- simply do not have decent story for impredicative types), but it
+    -- caused #12616 because (also bizarrely) 'deriving' code had
+    -- -XImpredicativeTypes on.  I deleted the entire case.
+
+    go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res })
+       (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res })
+      = -- See Note [Co/contra-variance of subsumption checking]
+        do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt       act_res exp_res
+           ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg
+                         -- GenSigCtxt: See Note [Setting the argument context]
+           ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) }
+               -- arg_wrap :: exp_arg ~> act_arg
+               -- res_wrap :: act-res ~> exp_res
+      where
+        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])
+        doc = text "When checking that" <+> quotes (ppr ty_actual) <+>
+              text "is more polymorphic than" <+> quotes (ppr ty_expected)
+
+    go ty_a ty_e
+      | let (tvs, theta, _) = tcSplitSigmaTy ty_a
+      , not (null tvs && null theta)
+      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a
+           ; body_wrap <- tc_sub_type_ds
+                            (eq_orig { uo_actual = in_rho
+                                     , uo_expected = ty_expected })
+                            inst_orig ctxt in_rho ty_e
+           ; return (body_wrap <.> in_wrap) }
+
+      | otherwise   -- Revert to unification
+      = inst_and_unify
+         -- It's still possible that ty_actual has nested foralls. Instantiate
+         -- these, as there's no way unification will succeed with them in.
+         -- See typecheck/should_compile/T11305 for an example of when this
+         -- is important. The problem is that we're checking something like
+         --  a -> forall b. b -> b     <=   alpha beta gamma
+         -- where we end up with alpha := (->)
+
+    inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual
+
+                           -- If we haven't recurred through an arrow, then
+                           -- the eq_orig will list ty_actual. In this case,
+                           -- we want to update the origin to reflect the
+                           -- instantiation. If we *have* recurred through
+                           -- an arrow, it's better not to update.
+                        ; let eq_orig' = case eq_orig of
+                                TypeEqOrigin { uo_actual   = orig_ty_actual }
+                                  |  orig_ty_actual `tcEqType` ty_actual
+                                  ,  not (isIdHsWrapper wrap)
+                                  -> eq_orig { uo_actual = rho_a }
+                                _ -> eq_orig
+
+                        ; cow <- uType TypeLevel eq_orig' rho_a ty_expected
+                        ; return (mkWpCastN cow <.> wrap) }
+
+
+     -- use versions without synonyms expanded
+    unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected
+
+{- Note [Settting the argument context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider we are doing the ambiguity check for the (bogus)
+  f :: (forall a b. C b => a -> a) -> Int
+
+We'll call
+   tcSubType ((forall a b. C b => a->a) -> Int )
+             ((forall a b. C b => a->a) -> Int )
+
+with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing
+on the argument type of the (->) -- and at that point we want to switch
+to a UserTypeCtxt of GenSigCtxt.  Why?
+
+* Error messages.  If we stick with FunSigCtxt we get errors like
+     * Could not deduce: C b
+       from the context: C b0
+        bound by the type signature for:
+            f :: forall a b. C b => a->a
+  But of course f does not have that type signature!
+  Example tests: T10508, T7220a, Simple14
+
+* Implications. We may decide to build an implication for the whole
+  ambiguity check, but we don't need one for each level within it,
+  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.
+  See Note [When to build an implication]
+-}
+
+-----------------
+-- needs both un-type-checked (for origins) and type-checked (for wrapping)
+-- expressions
+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+             -> TcM (HsExpr GhcTcId)
+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr
+
+-- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more
+-- convenient.
+tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+               -> TcM (HsExpr GhcTcId)
+tcWrapResultO orig rn_expr expr actual_ty res_ty
+  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty
+                                      , text "Expected:" <+> ppr res_ty ])
+       ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt
+                                 (Just rn_expr) actual_ty res_ty
+       ; return (mkHsWrap cow expr) }
+
+
+{- **********************************************************************
+%*                                                                      *
+            ExpType functions: tcInfer, fillInferResult
+%*                                                                      *
+%********************************************************************* -}
+
+-- | Infer a type using a fresh ExpType
+-- See also Note [ExpType] in TcMType
+-- Does not attempt to instantiate the inferred type
+tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+tcInferNoInst = tcInfer False
+
+tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)
+tcInferInst = tcInfer True
+
+tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+tcInfer instantiate tc_check
+  = do { res_ty <- newInferExpType instantiate
+       ; result <- tc_check res_ty
+       ; res_ty <- readExpType res_ty
+       ; return (result, res_ty) }
+
+fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
+-- If wrap = fillInferResult t1 t2
+--    => wrap :: t1 ~> t2
+-- See Note [Deep instantiation of InferResult]
+fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me })
+  | instantiate_me
+  = do { (wrap, rho) <- deeplyInstantiate orig ty
+       ; co <- fill_infer_result rho inf_res
+       ; return (mkWpCastN co <.> wrap) }
+
+  | otherwise
+  = do { co <- fill_infer_result ty inf_res
+       ; return (mkWpCastN co) }
+
+fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN
+-- If wrap = fill_infer_result t1 t2
+--    => wrap :: t1 ~> t2
+fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl
+                            , ir_ref = ref })
+  = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty
+
+       ; traceTc "Filling ExpType" $
+         ppr u <+> text ":=" <+> ppr ty_to_fill_with
+
+       ; when debugIsOn (check_hole ty_to_fill_with)
+
+       ; writeTcRef ref (Just ty_to_fill_with)
+
+       ; return ty_co }
+  where
+    check_hole ty   -- Debug check only
+      = do { let ty_lvl = tcTypeLevel ty
+           ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),
+                       ppr u $$ ppr res_lvl $$ ppr ty_lvl $$
+                       ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty )
+           ; cts <- readTcRef ref
+           ; case cts of
+               Just already_there -> pprPanic "writeExpType"
+                                       (vcat [ ppr u
+                                             , ppr ty
+                                             , ppr already_there ])
+               Nothing -> return () }
+
+{- Note [Deep instantiation of InferResult]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some cases we want to deeply instantiate before filling in
+an InferResult, and in some cases not.  That's why InferReult
+has the ir_inst flag.
+
+* ir_inst = True: deeply instantiate
+
+  Consider
+    f x = (*)
+  We want to instantiate the type of (*) before returning, else we
+  will infer the type
+    f :: forall {a}. a -> forall b. Num b => b -> b -> b
+  This is surely confusing for users.
+
+  And worse, the monomorphism restriction won't work properly. The MR is
+  dealt with in simplifyInfer, and simplifyInfer has no way of
+  instantiating. This could perhaps be worked around, but it may be
+  hard to know even when instantiation should happen.
+
+  Another reason.  Consider
+       f :: (?x :: Int) => a -> a
+       g y = let ?x = 3::Int in f
+  Here want to instantiate f's type so that the ?x::Int constraint
+  gets discharged by the enclosing implicit-parameter binding.
+
+* ir_inst = False: do not instantiate
+
+  Consider this (which uses visible type application):
+
+    (let { f :: forall a. a -> a; f x = x } in f) @Int
+
+  We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)
+  And we don't want to instantite the type of 'f' when we reach it,
+  else the outer visible type application won't work
+-}
+
+{- *********************************************************************
+*                                                                      *
+              Promoting types
+*                                                                      *
+********************************************************************* -}
+
+promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType)
+-- See Note [Promoting a type]
+-- promoteTcType level ty = (co, ty')
+--   * Returns ty'  whose max level is just 'level'
+--             and  whose kind is ~# to the kind of 'ty'
+--             and  whose kind has form TYPE rr
+--   * and co :: ty ~ ty'
+--   * and emits constraints to justify the coercion
+promoteTcType dest_lvl ty
+  = do { cur_lvl <- getTcLevel
+       ; if (cur_lvl `sameDepthAs` dest_lvl)
+         then dont_promote_it
+         else promote_it }
+  where
+    promote_it :: TcM (TcCoercion, TcType)
+    promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty
+                -- where alpha and rr are fresh and from level dest_lvl
+      = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy
+           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)
+           ; let eq_orig = TypeEqOrigin { uo_actual   = ty
+                                        , uo_expected = prom_ty
+                                        , uo_thing    = Nothing
+                                        , uo_visible  = False }
+
+           ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty
+           ; return (co, prom_ty) }
+
+    dont_promote_it :: TcM (TcCoercion, TcType)
+    dont_promote_it  -- Check that ty :: TYPE rr, for some (fresh) rr
+      = do { res_kind <- newOpenTypeKind
+           ; let ty_kind = tcTypeKind ty
+                 kind_orig = TypeEqOrigin { uo_actual   = ty_kind
+                                          , uo_expected = res_kind
+                                          , uo_thing    = Nothing
+                                          , uo_visible  = False }
+           ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind
+           ; let co = mkTcGReflRightCo Nominal ty ki_co
+           ; return (co, ty `mkCastTy` ki_co) }
+
+{- Note [Promoting a type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#12427)
+
+  data T where
+    MkT :: (Int -> Int) -> a -> T
+
+  h y = case y of MkT v w -> v
+
+We'll infer the RHS type with an expected type ExpType of
+  (IR { ir_lvl = l, ir_ref = ref, ... )
+where 'l' is the TcLevel of the RHS of 'h'.  Then the MkT pattern
+match will increase the level, so we'll end up in tcSubType, trying to
+unify the type of v,
+  v :: Int -> Int
+with the expected type.  But this attempt takes place at level (l+1),
+rightly so, since v's type could have mentioned existential variables,
+(like w's does) and we want to catch that.
+
+So we
+  - create a new meta-var alpha[l+1]
+  - fill in the InferRes ref cell 'ref' with alpha
+  - emit an equality constraint, thus
+        [W] alpha[l+1] ~ (Int -> Int)
+
+That constraint will float outwards, as it should, unless v's
+type mentions a skolem-captured variable.
+
+This approach fails if v has a higher rank type; see
+Note [Promotion and higher rank types]
+
+
+Note [Promotion and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If v had a higher-rank type, say v :: (forall a. a->a) -> Int,
+then we'd emit an equality
+        [W] alpha[l+1] ~ ((forall a. a->a) -> Int)
+which will sadly fail because we can't unify a unification variable
+with a polytype.  But there is nothing really wrong with the program
+here.
+
+We could just about solve this by "promote the type" of v, to expose
+its polymorphic "shape" while still leaving constraints that will
+prevent existential escape.  But we must be careful!  Exposing
+the "shape" of the type is precisely what we must NOT do under
+a GADT pattern match!  So in this case we might promote the type
+to
+        (forall a. a->a) -> alpha[l+1]
+and emit the constraint
+        [W] alpha[l+1] ~ Int
+Now the promoted type can fill the ref cell, while the emitted
+equality can float or not, according to the usual rules.
+
+But that's not quite right!  We are exposing the arrow! We could
+deal with that too:
+        (forall a. mu[l+1] a a) -> alpha[l+1]
+with constraints
+        [W] alpha[l+1] ~ Int
+        [W] mu[l+1] ~ (->)
+Here we abstract over the '->' inside the forall, in case that
+is subject to an equality constraint from a GADT match.
+
+Note that we kept the outer (->) because that's part of
+the polymorphic "shape".  And because of impredicativity,
+GADT matches can't give equalities that affect polymorphic
+shape.
+
+This reasoning just seems too complicated, so I decided not
+to do it.  These higher-rank notes are just here to record
+the thinking.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                    Generalisation
+*                                                                      *
+********************************************************************* -}
+
+-- | Take an "expected type" and strip off quantifiers to expose the
+-- type underneath, binding the new skolems for the @thing_inside@.
+-- The returned 'HsWrapper' has type @specific_ty -> expected_ty@.
+tcSkolemise :: UserTypeCtxt -> TcSigmaType
+            -> ([TcTyVar] -> TcType -> TcM result)
+         -- ^ These are only ever used for scoped type variables.
+            -> TcM (HsWrapper, result)
+        -- ^ The expression has type: spec_ty -> expected_ty
+
+tcSkolemise ctxt expected_ty thing_inside
+   -- We expect expected_ty to be a forall-type
+   -- If not, the call is a no-op
+  = do  { traceTc "tcSkolemise" Outputable.empty
+        ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty
+
+        ; lvl <- getTcLevel
+        ; when debugIsOn $
+              traceTc "tcSkolemise" $ vcat [
+                ppr lvl,
+                text "expected_ty" <+> ppr expected_ty,
+                text "inst tyvars" <+> ppr tv_prs,
+                text "given"       <+> ppr given,
+                text "inst type"   <+> ppr rho' ]
+
+        -- Generally we must check that the "forall_tvs" havn't been constrained
+        -- The interesting bit here is that we must include the free variables
+        -- of the expected_ty.  Here's an example:
+        --       runST (newVar True)
+        -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
+        -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
+        -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
+        -- So now s' isn't unconstrained because it's linked to a.
+        --
+        -- However [Oct 10] now that the untouchables are a range of
+        -- TcTyVars, all this is handled automatically with no need for
+        -- extra faffing around
+
+        ; let tvs' = map snd tv_prs
+              skol_info = SigSkol ctxt expected_ty tv_prs
+
+        ; (ev_binds, result) <- checkConstraints skol_info tvs' given $
+                                thing_inside tvs' rho'
+
+        ; return (wrap <.> mkWpLet ev_binds, result) }
+          -- The ev_binds returned by checkConstraints is very
+          -- often empty, in which case mkWpLet is a no-op
+
+-- | Variant of 'tcSkolemise' that takes an ExpType
+tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType
+              -> (ExpRhoType -> TcM result)
+              -> TcM (HsWrapper, result)
+tcSkolemiseET _ et@(Infer {}) thing_inside
+  = (idHsWrapper, ) <$> thing_inside et
+tcSkolemiseET ctxt (Check ty) thing_inside
+  = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType
+
+checkConstraints :: SkolemInfo
+                 -> [TcTyVar]           -- Skolems
+                 -> [EvVar]             -- Given
+                 -> TcM result
+                 -> TcM (TcEvBinds, result)
+
+checkConstraints skol_info skol_tvs given thing_inside
+  = do { implication_needed <- implicationNeeded skol_info skol_tvs given
+
+       ; if implication_needed
+         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
+                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted
+                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)
+                 ; emitImplications implics
+                 ; return (ev_binds, result) }
+
+         else -- Fast path.  We check every function argument with
+              -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.
+              -- So this fast path is well-exercised
+              do { res <- thing_inside
+                 ; return (emptyTcEvBinds, res) } }
+
+checkTvConstraints :: SkolemInfo
+                   -> Maybe SDoc  -- User-written telescope, if present
+                   -> TcM ([TcTyVar], result)
+                   -> TcM ([TcTyVar], result)
+
+checkTvConstraints skol_info m_telescope thing_inside
+  = do { (tclvl, wanted, (skol_tvs, result))
+             <- pushLevelAndCaptureConstraints thing_inside
+
+       ; emitResidualTvConstraint skol_info m_telescope
+                                  skol_tvs tclvl wanted
+
+       ; return (skol_tvs, result) }
+
+emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar]
+                         -> TcLevel -> WantedConstraints -> TcM ()
+emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted
+  | isEmptyWC wanted
+  = return ()
+  | otherwise
+  = do { ev_binds <- newNoTcEvBinds
+       ; implic   <- newImplication
+       ; let status | insolubleWC wanted = IC_Insoluble
+                    | otherwise          = IC_Unsolved
+             -- If the inner constraints are insoluble,
+             -- we should mark the outer one similarly,
+             -- so that insolubleWC works on the outer one
+
+       ; emitImplication $
+         implic { ic_status    = status
+                , ic_tclvl     = tclvl
+                , ic_skols     = skol_tvs
+                , ic_no_eqs    = True
+                , ic_telescope = m_telescope
+                , ic_wanted    = wanted
+                , ic_binds     = ev_binds
+                , ic_info      = skol_info } }
+
+implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool
+-- See Note [When to build an implication]
+implicationNeeded skol_info skol_tvs given
+  | null skol_tvs
+  , null given
+  , not (alwaysBuildImplication skol_info)
+  = -- Empty skolems and givens
+    do { tc_lvl <- getTcLevel
+       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are
+         then return False             -- already inside an implication
+         else
+    do { dflags <- getDynFlags       -- If any deferral can happen,
+                                     -- we must build an implication
+       ; return (gopt Opt_DeferTypeErrors dflags ||
+                 gopt Opt_DeferTypedHoles dflags ||
+                 gopt Opt_DeferOutOfScopeVariables dflags) } }
+
+  | otherwise     -- Non-empty skolems or givens
+  = return True   -- Definitely need an implication
+
+alwaysBuildImplication :: SkolemInfo -> Bool
+-- See Note [When to build an implication]
+alwaysBuildImplication _ = False
+
+{-  Commmented out for now while I figure out about error messages.
+    See #14185
+
+alwaysBuildImplication (SigSkol ctxt _ _)
+  = case ctxt of
+      FunSigCtxt {} -> True  -- RHS of a binding with a signature
+      _             -> False
+alwaysBuildImplication (RuleSkol {})      = True
+alwaysBuildImplication (InstSkol {})      = True
+alwaysBuildImplication (FamInstSkol {})   = True
+alwaysBuildImplication _                  = False
+-}
+
+buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]
+                   -> [EvVar] -> WantedConstraints
+                   -> TcM (Bag Implication, TcEvBinds)
+buildImplicationFor tclvl skol_info skol_tvs given wanted
+  | isEmptyWC wanted && null given
+             -- Optimisation : if there are no wanteds, and no givens
+             -- don't generate an implication at all.
+             -- Reason for the (null given): we don't want to lose
+             -- the "inaccessible alternative" error check
+  = return (emptyBag, emptyTcEvBinds)
+
+  | otherwise
+  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )
+      -- Why allow TyVarTvs? Because implicitly declared kind variables in
+      -- non-CUSK type declarations are TyVarTvs, and we need to bring them
+      -- into scope as a skolem in an implication. This is OK, though,
+      -- because TyVarTvs will always remain tyvars, even after unification.
+    do { ev_binds_var <- newTcEvBinds
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_skols  = skol_tvs
+                              , ic_given  = given
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = skol_info }
+
+       ; return (unitBag implic', TcEvBinds ev_binds_var) }
+
+{- Note [When to build an implication]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have some 'skolems' and some 'givens', and we are
+considering whether to wrap the constraints in their scope into an
+implication.  We must /always/ so if either 'skolems' or 'givens' are
+non-empty.  But what if both are empty?  You might think we could
+always drop the implication.  Other things being equal, the fewer
+implications the better.  Less clutter and overhead.  But we must
+take care:
+
+* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,
+  we'll make a /term-level/ evidence binding for 'g = error "blah"'.
+  We must have an EvBindsVar those bindings!, otherwise they end up as
+  top-level unlifted bindings, which are verboten. This only matters
+  at top level, so we check for that
+  See also Note [Deferred errors for coercion holes] in TcErrors.
+  cf #14149 for an example of what goes wrong.
+
+* If you have
+     f :: Int;  f = f_blah
+     g :: Bool; g = g_blah
+  If we don't build an implication for f or g (no tyvars, no givens),
+  the constraints for f_blah and g_blah are solved together.  And that
+  can yield /very/ confusing error messages, because we can get
+      [W] C Int b1    -- from f_blah
+      [W] C Int b2    -- from g_blan
+  and fundpes can yield [D] b1 ~ b2, even though the two functions have
+  literally nothing to do with each other.  #14185 is an example.
+  Building an implication keeps them separage.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                Boxy unification
+*                                                                      *
+************************************************************************
+
+The exported functions are all defined as versions of some
+non-exported generic functions.
+-}
+
+unifyType :: Maybe (HsExpr GhcRn)   -- ^ If present, has type 'ty1'
+          -> TcTauType -> TcTauType -> TcM TcCoercionN
+-- Actual and expected types
+-- Returns a coercion : ty1 ~ ty2
+unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
+                          uType TypeLevel origin ty1 ty2
+  where
+    origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
+                          , uo_thing  = ppr <$> thing
+                          , uo_visible = True } -- always called from a visible context
+
+unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN
+unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
+                          uType KindLevel origin ty1 ty2
+  where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
+                              , uo_thing  = ppr <$> thing
+                              , uo_visible = True } -- also always from a visible context
+
+---------------
+
+{-
+%************************************************************************
+%*                                                                      *
+                 uType and friends
+%*                                                                      *
+%************************************************************************
+
+uType is the heart of the unifier.
+-}
+
+uType, uType_defer
+  :: TypeOrKind
+  -> CtOrigin
+  -> TcType    -- ty1 is the *actual* type
+  -> TcType    -- ty2 is the *expected* type
+  -> TcM CoercionN
+
+--------------
+-- It is always safe to defer unification to the main constraint solver
+-- See Note [Deferred unification]
+uType_defer t_or_k origin ty1 ty2
+  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2
+
+       -- Error trace only
+       -- NB. do *not* call mkErrInfo unless tracing is on,
+       --     because it is hugely expensive (#5631)
+       ; whenDOptM Opt_D_dump_tc_trace $ do
+            { ctxt <- getErrCtxt
+            ; doc <- mkErrInfo emptyTidyEnv ctxt
+            ; traceTc "utype_defer" (vcat [ debugPprType ty1
+                                          , debugPprType ty2
+                                          , pprCtOrigin origin
+                                          , doc])
+            ; traceTc "utype_defer2" (ppr co)
+            }
+       ; return co }
+
+--------------
+uType t_or_k origin orig_ty1 orig_ty2
+  = do { tclvl <- getTcLevel
+       ; traceTc "u_tys" $ vcat
+              [ text "tclvl" <+> ppr tclvl
+              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]
+              , pprCtOrigin origin]
+       ; co <- go orig_ty1 orig_ty2
+       ; if isReflCo co
+            then traceTc "u_tys yields no coercion" Outputable.empty
+            else traceTc "u_tys yields coercion:" (ppr co)
+       ; return co }
+  where
+    go :: TcType -> TcType -> TcM CoercionN
+        -- The arguments to 'go' are always semantically identical
+        -- to orig_ty{1,2} except for looking through type synonyms
+
+     -- Unwrap casts before looking for variables. This way, we can easily
+     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we
+     -- didn't do it this way, and then the unification above was deferred.
+    go (CastTy t1 co1) t2
+      = do { co_tys <- uType t_or_k origin t1 t2
+           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }
+
+    go t1 (CastTy t2 co2)
+      = do { co_tys <- uType t_or_k origin t1 t2
+           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }
+
+        -- Variables; go for uVar
+        -- Note that we pass in *original* (before synonym expansion),
+        -- so that type variables tend to get filled in with
+        -- the most informative version of the type
+    go (TyVarTy tv1) ty2
+      = do { lookup_res <- lookupTcTyVar tv1
+           ; case lookup_res of
+               Filled ty1   -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)
+                                  ; go ty1 ty2 }
+               Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }
+    go ty1 (TyVarTy tv2)
+      = do { lookup_res <- lookupTcTyVar tv2
+           ; case lookup_res of
+               Filled ty2   -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)
+                                  ; go ty1 ty2 }
+               Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }
+
+      -- See Note [Expanding synonyms during unification]
+    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])
+      | tc1 == tc2
+      = return $ mkNomReflCo ty1
+
+        -- See Note [Expanding synonyms during unification]
+        --
+        -- Also NB that we recurse to 'go' so that we don't push a
+        -- new item on the origin stack. As a result if we have
+        --   type Foo = Int
+        -- and we try to unify  Foo ~ Bool
+        -- we'll end up saying "can't match Foo with Bool"
+        -- rather than "can't match "Int with Bool".  See #4535.
+    go ty1 ty2
+      | Just ty1' <- tcView ty1 = go ty1' ty2
+      | Just ty2' <- tcView ty2 = go ty1  ty2'
+
+        -- Functions (or predicate functions) just check the two parts
+    go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2)
+      = do { co_l <- uType t_or_k origin fun1 fun2
+           ; co_r <- uType t_or_k origin arg1 arg2
+           ; return $ mkFunCo Nominal co_l co_r }
+
+        -- Always defer if a type synonym family (type function)
+        -- is involved.  (Data families behave rigidly.)
+    go ty1@(TyConApp tc1 _) ty2
+      | isTypeFamilyTyCon tc1 = defer ty1 ty2
+    go ty1 ty2@(TyConApp tc2 _)
+      | isTypeFamilyTyCon tc2 = defer ty1 ty2
+
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      -- See Note [Mismatched type lists and application decomposition]
+      | tc1 == tc2, equalLength tys1 tys2
+      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
+        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
+           ; return $ mkTyConAppCo Nominal tc1 cos }
+      where
+        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)
+                       (tcTyConVisibilities tc1)
+
+    go (LitTy m) ty@(LitTy n)
+      | m == n
+      = return $ mkNomReflCo ty
+
+        -- See Note [Care with type applications]
+        -- Do not decompose FunTy against App;
+        -- it's often a type error, so leave it for the constraint solver
+    go (AppTy s1 t1) (AppTy s2 t2)
+      = go_app (isNextArgVisible s1) s1 t1 s2 t2
+
+    go (AppTy s1 t1) (TyConApp tc2 ts2)
+      | Just (ts2', t2') <- snocView ts2
+      = ASSERT( not (mustBeSaturated tc2) )
+        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
+
+    go (TyConApp tc1 ts1) (AppTy s2 t2)
+      | Just (ts1', t1') <- snocView ts1
+      = ASSERT( not (mustBeSaturated tc1) )
+        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
+
+    go (CoercionTy co1) (CoercionTy co2)
+      = do { let ty1 = coercionType co1
+                 ty2 = coercionType co2
+           ; kco <- uType KindLevel
+                          (KindEqOrigin orig_ty1 (Just orig_ty2) origin
+                                        (Just t_or_k))
+                          ty1 ty2
+           ; return $ mkProofIrrelCo Nominal kco co1 co2 }
+
+        -- Anything else fails
+        -- E.g. unifying for-all types, which is relative unusual
+    go ty1 ty2 = defer ty1 ty2
+
+    ------------------
+    defer ty1 ty2   -- See Note [Check for equality before deferring]
+      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)
+      | otherwise          = uType_defer t_or_k origin ty1 ty2
+
+    ------------------
+    go_app vis s1 t1 s2 t2
+      = do { co_s <- uType t_or_k origin s1 s2
+           ; let arg_origin
+                   | vis       = origin
+                   | otherwise = toInvisibleOrigin origin
+           ; co_t <- uType t_or_k arg_origin t1 t2
+           ; return $ mkAppCo co_s co_t }
+
+{- Note [Check for equality before deferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Particularly in ambiguity checks we can get equalities like (ty ~ ty).
+If ty involves a type function we may defer, which isn't very sensible.
+An egregious example of this was in test T9872a, which has a type signature
+       Proxy :: Proxy (Solutions Cubes)
+Doing the ambiguity check on this signature generates the equality
+   Solutions Cubes ~ Solutions Cubes
+and currently the constraint solver normalises both sides at vast cost.
+This little short-cut in 'defer' helps quite a bit.
+
+Note [Care with type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note: type applications need a bit of care!
+They can match FunTy and TyConApp, so use splitAppTy_maybe
+NB: we've already dealt with type variables and Notes,
+so if one type is an App the other one jolly well better be too
+
+Note [Mismatched type lists and application decomposition]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we find two TyConApps, you might think that the argument lists
+are guaranteed equal length.  But they aren't. Consider matching
+        w (T x) ~ Foo (T x y)
+We do match (w ~ Foo) first, but in some circumstances we simply create
+a deferred constraint; and then go ahead and match (T x ~ T x y).
+This came up in #3950.
+
+So either
+   (a) either we must check for identical argument kinds
+       when decomposing applications,
+
+   (b) or we must be prepared for ill-kinded unification sub-problems
+
+Currently we adopt (b) since it seems more robust -- no need to maintain
+a global invariant.
+
+Note [Expanding synonyms during unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand synonyms during unification, but:
+ * We expand *after* the variable case so that we tend to unify
+   variables with un-expanded type synonym. This just makes it
+   more likely that the inferred types will mention type synonyms
+   understandable to the user
+
+ * Similarly, we expand *after* the CastTy case, just in case the
+   CastTy wraps a variable.
+
+ * We expand *before* the TyConApp case.  For example, if we have
+      type Phantom a = Int
+   and are unifying
+      Phantom Int ~ Phantom Char
+   it is *wrong* to unify Int and Char.
+
+ * The problem case immediately above can happen only with arguments
+   to the tycon. So we check for nullary tycons *before* expanding.
+   This is particularly helpful when checking (* ~ *), because * is
+   now a type synonym.
+
+Note [Deferred Unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,
+and yet its consistency is undetermined. Previously, there was no way to still
+make it consistent. So a mismatch error was issued.
+
+Now these unifications are deferred until constraint simplification, where type
+family instances and given equations may (or may not) establish the consistency.
+Deferred unifications are of the form
+                F ... ~ ...
+or              x ~ ...
+where F is a type function and x is a type variable.
+E.g.
+        id :: x ~ y => x -> y
+        id e = e
+
+involves the unification x = y. It is deferred until we bring into account the
+context x ~ y to establish that it holds.
+
+If available, we defer original types (rather than those where closed type
+synonyms have already been expanded via tcCoreView).  This is, as usual, to
+improve error messages.
+
+
+************************************************************************
+*                                                                      *
+                 uVar and friends
+*                                                                      *
+************************************************************************
+
+@uVar@ is called when at least one of the types being unified is a
+variable.  It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @uVar@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
+-}
+
+----------
+uUnfilledVar :: CtOrigin
+             -> TypeOrKind
+             -> SwapFlag
+             -> TcTyVar        -- Tyvar 1
+             -> TcTauType      -- Type 2
+             -> TcM Coercion
+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
+--            It might be a skolem, or untouchable, or meta
+
+uUnfilledVar origin t_or_k swapped tv1 ty2
+  = do { ty2 <- zonkTcType ty2
+             -- Zonk to expose things to the
+             -- occurs check, and so that if ty2
+             -- looks like a type variable then it
+             -- /is/ a type variable
+       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }
+
+----------
+uUnfilledVar1 :: CtOrigin
+              -> TypeOrKind
+              -> SwapFlag
+              -> TcTyVar        -- Tyvar 1
+              -> TcTauType      -- Type 2, zonked
+              -> TcM Coercion
+uUnfilledVar1 origin t_or_k swapped tv1 ty2
+  | Just tv2 <- tcGetTyVar_maybe ty2
+  = go tv2
+
+  | otherwise
+  = uUnfilledVar2 origin t_or_k swapped tv1 ty2
+
+  where
+    -- 'go' handles the case where both are
+    -- tyvars so we might want to swap
+    go tv2 | tv1 == tv2  -- Same type variable => no-op
+           = return (mkNomReflCo (mkTyVarTy tv1))
+
+           | swapOverTyVars tv1 tv2   -- Distinct type variables
+           = uUnfilledVar2 origin t_or_k (flipSwap swapped)
+                           tv2 (mkTyVarTy tv1)
+
+           | otherwise
+           = uUnfilledVar2 origin t_or_k swapped tv1 ty2
+
+----------
+uUnfilledVar2 :: CtOrigin
+              -> TypeOrKind
+              -> SwapFlag
+              -> TcTyVar        -- Tyvar 1
+              -> TcTauType      -- Type 2, zonked
+              -> TcM Coercion
+uUnfilledVar2 origin t_or_k swapped tv1 ty2
+  = do { dflags  <- getDynFlags
+       ; cur_lvl <- getTcLevel
+       ; go dflags cur_lvl }
+  where
+    go dflags cur_lvl
+      | canSolveByUnification cur_lvl tv1 ty2
+      , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2
+      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)
+           ; traceTc "uUnfilledVar2 ok" $
+             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
+                  , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)
+                  , ppr (isTcReflCo co_k), ppr co_k ]
+
+           ; if isTcReflCo co_k  -- only proceed if the kinds matched.
+
+             then do { writeMetaTyVar tv1 ty2'
+                     ; return (mkTcNomReflCo ty2') }
+
+             else defer } -- This cannot be solved now.  See TcCanonical
+                          -- Note [Equalities with incompatible kinds]
+
+      | otherwise
+      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)
+               -- Occurs check or an untouchable: just defer
+               -- NB: occurs check isn't necessarily fatal:
+               --     eg tv1 occured in type family parameter
+            ; defer }
+
+    ty1 = mkTyVarTy tv1
+    kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)
+
+    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2
+
+swapOverTyVars :: TcTyVar -> TcTyVar -> Bool
+swapOverTyVars tv1 tv2
+  -- Level comparison: see Note [TyVar/TyVar orientation]
+  | lvl1 `strictlyDeeperThan` lvl2 = False
+  | lvl2 `strictlyDeeperThan` lvl1 = True
+
+  -- Priority: see Note [TyVar/TyVar orientation]
+  | pri1 > pri2 = False
+  | pri2 > pri1 = True
+
+  -- Names: see Note [TyVar/TyVar orientation]
+  | isSystemName tv2_name, not (isSystemName tv1_name) = True
+
+  | otherwise = False
+
+  where
+    lvl1 = tcTyVarLevel tv1
+    lvl2 = tcTyVarLevel tv2
+    pri1 = lhsPriority tv1
+    pri2 = lhsPriority tv2
+    tv1_name = Var.varName tv1
+    tv2_name = Var.varName tv2
+
+
+lhsPriority :: TcTyVar -> Int
+-- Higher => more important to be on the LHS
+-- See Note [TyVar/TyVar orientation]
+lhsPriority tv
+  = ASSERT2( isTyVar tv, ppr tv)
+    case tcTyVarDetails tv of
+      RuntimeUnk  -> 0
+      SkolemTv {} -> 0
+      MetaTv { mtv_info = info } -> case info of
+                                     FlatSkolTv -> 1
+                                     TyVarTv    -> 2
+                                     TauTv      -> 3
+                                     FlatMetaTv -> 4
+{- Note [TyVar/TyVar orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?
+This is a surprisingly tricky question!
+
+First note: only swap if you have to!
+   See Note [Avoid unnecessary swaps]
+
+So we look for a positive reason to swap, using a three-step test:
+
+* Level comparison. If 'a' has deeper level than 'b',
+  put 'a' on the left.  See Note [Deeper level on the left]
+
+* Priority.  If the levels are the same, look at what kind of
+  type variable it is, using 'lhsPriority'
+
+  - FlatMetaTv: Always put on the left.
+    See Note [Fmv Orientation Invariant]
+    NB: FlatMetaTvs always have the current level, never an
+        outer one.  So nothing can be deeper than a FlatMetaTv
+
+
+  - TyVarTv/TauTv: if we have  tyv_tv ~ tau_tv, put tau_tv
+                   on the left because there are fewer
+                   restrictions on updating TauTvs
+
+  - TyVarTv/TauTv:  put on the left either
+     a) Because it's touchable and can be unified, or
+     b) Even if it's not touchable, TcSimplify.floatEqualities
+        looks for meta tyvars on the left
+
+  - FlatSkolTv: Put on the left in preference to a SkolemTv
+                See Note [Eliminate flat-skols]
+
+* Names. If the level and priority comparisons are all
+  equal, try to eliminate a TyVars with a System Name in
+  favour of ones with a Name derived from a user type signature
+
+* Age.  At one point in the past we tried to break any remaining
+  ties by eliminating the younger type variable, based on their
+  Uniques.  See Note [Eliminate younger unification variables]
+  (which also explains why we don't do this any more)
+
+Note [Deeper level on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The most important thing is that we want to put tyvars with
+the deepest level on the left.  The reason to do so differs for
+Wanteds and Givens, but either way, deepest wins!  Simple.
+
+* Wanteds.  Putting the deepest variable on the left maximise the
+  chances that it's a touchable meta-tyvar which can be solved.
+
+* Givens. Suppose we have something like
+     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]
+
+  If we orient the Given a[2] on the left, we'll rewrite the Wanted to
+  (beta[1] ~ b[1]), and that can float out of the implication.
+  Otherwise it can't.  By putting the deepest variable on the left
+  we maximise our changes of eliminating skolem capture.
+
+  See also TcSMonad Note [Let-bound skolems] for another reason
+  to orient with the deepest skolem on the left.
+
+  IMPORTANT NOTE: this test does a level-number comparison on
+  skolems, so it's important that skolems have (accurate) level
+  numbers.
+
+See #15009 for an further analysis of why "deepest on the left"
+is a good plan.
+
+Note [Fmv Orientation Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   * We always orient a constraint
+        fmv ~ alpha
+     with fmv on the left, even if alpha is
+     a touchable unification variable
+
+Reason: doing it the other way round would unify alpha:=fmv, but that
+really doesn't add any info to alpha.  But a later constraint alpha ~
+Int might unlock everything.  Comment:9 of #12526 gives a detailed
+example.
+
+WARNING: I've gone to and fro on this one several times.
+I'm now pretty sure that unifying alpha:=fmv is a bad idea!
+So orienting with fmvs on the left is a good thing.
+
+This example comes from IndTypesPerfMerge. (Others include
+T10226, T10009.)
+    From the ambiguity check for
+      f :: (F a ~ a) => a
+    we get:
+          [G] F a ~ a
+          [WD] F alpha ~ alpha, alpha ~ a
+
+    From Givens we get
+          [G] F a ~ fsk, fsk ~ a
+
+    Now if we flatten we get
+          [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a
+
+    Now, if we unified alpha := fmv, we'd get
+          [WD] F fmv ~ fmv, [WD] fmv ~ a
+    And now we are stuck.
+
+So instead the Fmv Orientation Invariant puts the fmv on the
+left, giving
+      [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a
+
+    Now we get alpha:=a, and everything works out
+
+Note [Eliminate flat-skols]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have  [G] Num (F [a])
+then we flatten to
+     [G] Num fsk
+     [G] F [a] ~ fsk
+where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
+      type instance F [a] = a
+then we'll reduce the second constraint to
+     [G] a ~ fsk
+and then replace all uses of 'a' with fsk.  That's bad because
+in error messages instead of saying 'a' we'll say (F [a]).  In all
+places, including those where the programmer wrote 'a' in the first
+place.  Very confusing!  See #7862.
+
+Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
+the fsk.
+
+Note [Avoid unnecessary swaps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we swap without actually improving matters, we can get an infinite loop.
+Consider
+    work item:  a ~ b
+   inert item:  b ~ c
+We canonicalise the work-item to (a ~ c).  If we then swap it before
+adding to the inert set, we'll add (c ~ a), and therefore kick out the
+inert guy, so we get
+   new work item:  b ~ c
+   inert item:     c ~ a
+And now the cycle just repeats
+
+Note [Eliminate younger unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a choice of unifying
+     alpha := beta   or   beta := alpha
+we try, if possible, to eliminate the "younger" one, as determined
+by `ltUnique`.  Reason: the younger one is less likely to appear free in
+an existing inert constraint, and hence we are less likely to be forced
+into kicking out and rewriting inert constraints.
+
+This is a performance optimisation only.  It turns out to fix
+#14723 all by itself, but clearly not reliably so!
+
+It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).
+But, to my surprise, it didn't seem to make any significant difference
+to the compiler's performance, so I didn't take it any further.  Still
+it seemed to too nice to discard altogether, so I'm leaving these
+notes.  SLPJ Jan 18.
+-}
+
+-- @trySpontaneousSolve wi@ solves equalities where one side is a
+-- touchable unification variable.
+-- Returns True <=> spontaneous solve happened
+canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool
+canSolveByUnification tclvl tv xi
+  | isTouchableMetaTyVar tclvl tv
+  = case metaTyVarInfo tv of
+      TyVarTv -> is_tyvar xi
+      _       -> True
+
+  | otherwise    -- Untouchable
+  = False
+  where
+    is_tyvar xi
+      = case tcGetTyVar_maybe xi of
+          Nothing -> False
+          Just tv -> case tcTyVarDetails tv of
+                       MetaTv { mtv_info = info }
+                                   -> case info of
+                                        TyVarTv -> True
+                                        _       -> False
+                       SkolemTv {} -> True
+                       RuntimeUnk  -> True
+
+{- Note [Prevent unification with type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prevent unification with type families because of an uneasy compromise.
+It's perfectly sound to unify with type families, and it even improves the
+error messages in the testsuite. It also modestly improves performance, at
+least in some cases. But it's disastrous for test case perf/compiler/T3064.
+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.
+What do we do? Do we reduce F? Or do we use the given? Hard to know what's
+best. GHC reduces. This is a disaster for T3064, where the type's size
+spirals out of control during reduction. (We're not helped by the fact that
+the flattener re-flattens all the arguments every time around.) If we prevent
+unification with type families, then the solver happens to use the equality
+before expanding the type family.
+
+It would be lovely in the future to revisit this problem and remove this
+extra, unnecessary check. But we retain it for now as it seems to work
+better in practice.
+
+Note [Refactoring hazard: checkTauTvUpdate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I (Richard E.) have a sad story about refactoring this code, retained here
+to prevent others (or a future me!) from falling into the same traps.
+
+It all started with #11407, which was caused by the fact that the TyVarTy
+case of defer_me didn't look in the kind. But it seemed reasonable to
+simply remove the defer_me check instead.
+
+It referred to two Notes (since removed) that were out of date, and the
+fast_check code in occurCheckExpand seemed to do just about the same thing as
+defer_me. The one piece that defer_me did that wasn't repeated by
+occurCheckExpand was the type-family check. (See Note [Prevent unification
+with type families].) So I checked the result of occurCheckExpand for any
+type family occurrences and deferred if there were any. This was done
+in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .
+
+This approach turned out not to be performant, because the expanded
+type was bigger than the original type, and tyConsOfType (needed to
+see if there are any type family occurrences) looks through type
+synonyms. So it then struck me that we could dispense with the
+defer_me check entirely. This simplified the code nicely, and it cut
+the allocations in T5030 by half. But, as documented in Note [Prevent
+unification with type families], this destroyed performance in
+T3064. Regardless, I missed this regression and the change was
+committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .
+
+Bottom lines:
+ * defer_me is back, but now fixed w.r.t. #11407.
+ * Tread carefully before you start to refactor here. There can be
+   lots of hard-to-predict consequences.
+
+Note [Type synonyms and the occur check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking we try to update a variable with type synonyms not
+expanded, which improves later error messages, unless looking
+inside a type synonym may help resolve a spurious occurs check
+error. Consider:
+          type A a = ()
+
+          f :: (A a -> a -> ()) -> ()
+          f = \ _ -> ()
+
+          x :: ()
+          x = f (\ x p -> p x)
+
+We will eventually get a constraint of the form t ~ A t. The ok function above will
+properly expand the type (A t) to just (), which is ok to be unified with t. If we had
+unified with the original type A t, we would lead the type checker into an infinite loop.
+
+Hence, if the occurs check fails for a type synonym application, then (and *only* then),
+the ok function expands the synonym to detect opportunities for occurs check success using
+the underlying definition of the type synonym.
+
+The same applies later on in the constraint interaction code; see TcInteract,
+function @occ_check_ok@.
+
+Note [Non-TcTyVars in TcUnify]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because the same code is now shared between unifying types and unifying
+kinds, we sometimes will see proper TyVars floating around the unifier.
+Example (from test case polykinds/PolyKinds12):
+
+    type family Apply (f :: k1 -> k2) (x :: k1) :: k2
+    type instance Apply g y = g y
+
+When checking the instance declaration, we first *kind-check* the LHS
+and RHS, discovering that the instance really should be
+
+    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y
+
+During this kind-checking, all the tyvars will be TcTyVars. Then, however,
+as a second pass, we desugar the RHS (which is done in functions prefixed
+with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper
+TyVars, not TcTyVars, get some kind unification must happen.
+
+Thus, we always check if a TyVar is a TcTyVar before asking if it's a
+meta-tyvar.
+
+This used to not be necessary for type-checking (that is, before * :: *)
+because expressions get desugared via an algorithm separate from
+type-checking (with wrappers, etc.). Types get desugared very differently,
+causing this wibble in behavior seen here.
+-}
+
+data LookupTyVarResult  -- The result of a lookupTcTyVar call
+  = Unfilled TcTyVarDetails     -- SkolemTv or virgin MetaTv
+  | Filled   TcType
+
+lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
+lookupTcTyVar tyvar
+  | MetaTv { mtv_ref = ref } <- details
+  = do { meta_details <- readMutVar ref
+       ; case meta_details of
+           Indirect ty -> return (Filled ty)
+           Flexi -> do { is_touchable <- isTouchableTcM tyvar
+                             -- Note [Unifying untouchables]
+                       ; if is_touchable then
+                            return (Unfilled details)
+                         else
+                            return (Unfilled vanillaSkolemTv) } }
+  | otherwise
+  = return (Unfilled details)
+  where
+    details = tcTyVarDetails tyvar
+
+{-
+Note [Unifying untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat an untouchable type variable as if it was a skolem.  That
+ensures it won't unify with anything.  It's a slight hack, because
+we return a made-up TcTyVarDetails, but I think it works smoothly.
+-}
+
+-- | Breaks apart a function kind into its pieces.
+matchExpectedFunKind
+  :: Outputable fun
+  => fun             -- ^ type, only for errors
+  -> Arity           -- ^ n: number of desired arrows
+  -> TcKind          -- ^ fun_ kind
+  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)
+
+matchExpectedFunKind hs_ty n k = go n k
+  where
+    go 0 k = return (mkNomReflCo k)
+
+    go n k | Just k' <- tcView k = go n k'
+
+    go n k@(TyVarTy kvar)
+      | isMetaTyVar kvar
+      = do { maybe_kind <- readMetaTyVar kvar
+           ; case maybe_kind of
+                Indirect fun_kind -> go n fun_kind
+                Flexi ->             defer n k }
+
+    go n (FunTy _ arg res)
+      = do { co <- go (n-1) res
+           ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) }
+
+    go n other
+     = defer n other
+
+    defer n k
+      = do { arg_kinds <- newMetaKindVars n
+           ; res_kind  <- newMetaKindVar
+           ; let new_fun = mkVisFunTys arg_kinds res_kind
+                 origin  = TypeEqOrigin { uo_actual   = k
+                                        , uo_expected = new_fun
+                                        , uo_thing    = Just (ppr hs_ty)
+                                        , uo_visible  = True
+                                        }
+           ; uType KindLevel origin k new_fun }
+
+{- *********************************************************************
+*                                                                      *
+                 Occurrence checking
+*                                                                      *
+********************************************************************* -}
+
+
+{-  Note [Occurrence checking: look inside kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are considering unifying
+   (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)
+This may be an error (what is that alpha doing inside beta's kind?),
+but we must not make the mistake of actually unifying or we'll
+build an infinite data structure.  So when looking for occurrences
+of alpha in the rhs, we must look in the kinds of type variables
+that occur there.
+
+NB: we may be able to remove the problem via expansion; see
+    Note [Occurs check expansion].  So we have to try that.
+
+Note [Checking for foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unless we have -XImpredicativeTypes (which is a totally unsupported
+feature), we do not want to unify
+    alpha ~ (forall a. a->a) -> Int
+So we look for foralls hidden inside the type, and it's convenient
+to do that at the same time as the occurs check (which looks for
+occurrences of alpha).
+
+However, it's not just a question of looking for foralls /anywhere/!
+Consider
+   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)
+This is legal; e.g. dependent/should_compile/T11635.
+
+We don't want to reject it because of the forall in beta's kind,
+but (see Note [Occurrence checking: look inside kinds]) we do
+need to look in beta's kind.  So we carry a flag saying if a 'forall'
+is OK, and sitch the flag on when stepping inside a kind.
+
+Why is it OK?  Why does it not count as impredicative polymorphism?
+The reason foralls are bad is because we reply on "seeing" foralls
+when doing implicit instantiation.  But the forall inside the kind is
+fine.  We'll generate a kind equality constraint
+  (forall k. k->*) ~ (forall k. k->*)
+to check that the kinds of lhs and rhs are compatible.  If alpha's
+kind had instead been
+  (alpha :: kappa)
+then this kind equality would rightly complain about unifying kappa
+with (forall k. k->*)
+
+-}
+
+data MetaTyVarUpdateResult a
+  = MTVU_OK a
+  | MTVU_Bad     -- Forall, predicate, or type family
+  | MTVU_Occurs
+
+instance Functor MetaTyVarUpdateResult where
+      fmap = liftM
+
+instance Applicative MetaTyVarUpdateResult where
+      pure = MTVU_OK
+      (<*>) = ap
+
+instance Monad MetaTyVarUpdateResult where
+  MTVU_OK x    >>= k = k x
+  MTVU_Bad     >>= _ = MTVU_Bad
+  MTVU_Occurs  >>= _ = MTVU_Occurs
+
+occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()
+-- Just for error-message generation; so we return MetaTyVarUpdateResult
+-- so the caller can report the right kind of error
+-- Check whether
+--   a) the given variable occurs in the given type.
+--   b) there is a forall in the type (unless we have -XImpredicativeTypes)
+occCheckForErrors dflags tv ty
+  = case preCheck dflags True tv ty of
+      MTVU_OK _   -> MTVU_OK ()
+      MTVU_Bad    -> MTVU_Bad
+      MTVU_Occurs -> case occCheckExpand [tv] ty of
+                       Nothing -> MTVU_Occurs
+                       Just _  -> MTVU_OK ()
+
+----------------
+metaTyVarUpdateOK :: DynFlags
+                  -> TcTyVar             -- tv :: k1
+                  -> TcType              -- ty :: k2
+                  -> Maybe TcType        -- possibly-expanded ty
+-- (metaTyVarUpdateOK tv ty)
+-- We are about to update the meta-tyvar tv with ty
+-- Check (a) that tv doesn't occur in ty (occurs check)
+--       (b) that ty does not have any foralls
+--           (in the impredicative case), or type functions
+--
+-- We have two possible outcomes:
+-- (1) Return the type to update the type variable with,
+--        [we know the update is ok]
+-- (2) Return Nothing,
+--        [the update might be dodgy]
+--
+-- Note that "Nothing" does not mean "definite error".  For example
+--   type family F a
+--   type instance F Int = Int
+-- consider
+--   a ~ F a
+-- This is perfectly reasonable, if we later get a ~ Int.  For now, though,
+-- we return Nothing, leaving it to the later constraint simplifier to
+-- sort matters out.
+--
+-- See Note [Refactoring hazard: checkTauTvUpdate]
+
+metaTyVarUpdateOK dflags tv ty
+  = case preCheck dflags False tv ty of
+         -- False <=> type families not ok
+         -- See Note [Prevent unification with type families]
+      MTVU_OK _   -> Just ty
+      MTVU_Bad    -> Nothing  -- forall, predicate, or type function
+      MTVU_Occurs -> occCheckExpand [tv] ty
+
+preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()
+-- A quick check for
+--   (a) a forall type (unless -XImpredicativeTypes)
+--   (b) a predicate type (unless -XImpredicativeTypes)
+--   (c) a type family
+--   (d) an occurrence of the type variable (occurs check)
+--
+-- For (a), (b), and (c) we check only the top level of the type, NOT
+-- inside the kinds of variables it mentions.  But for (c) we do
+-- look in the kinds of course.
+
+preCheck dflags ty_fam_ok tv ty
+  = fast_check ty
+  where
+    details          = tcTyVarDetails tv
+    impredicative_ok = canUnifyWithPolyType dflags details
+
+    ok :: MetaTyVarUpdateResult ()
+    ok = MTVU_OK ()
+
+    fast_check :: TcType -> MetaTyVarUpdateResult ()
+    fast_check (TyVarTy tv')
+      | tv == tv' = MTVU_Occurs
+      | otherwise = fast_check_occ (tyVarKind tv')
+           -- See Note [Occurrence checking: look inside kinds]
+
+    fast_check (TyConApp tc tys)
+      | bad_tc tc              = MTVU_Bad
+      | otherwise              = mapM fast_check tys >> ok
+    fast_check (LitTy {})      = ok
+    fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r})
+      | InvisArg <- af
+      , not impredicative_ok   = MTVU_Bad
+      | otherwise              = fast_check a   >> fast_check r
+    fast_check (AppTy fun arg) = fast_check fun >> fast_check arg
+    fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co
+    fast_check (CoercionTy co) = fast_check_co co
+    fast_check (ForAllTy (Bndr tv' _) ty)
+       | not impredicative_ok = MTVU_Bad
+       | tv == tv'            = ok
+       | otherwise = do { fast_check_occ (tyVarKind tv')
+                        ; fast_check_occ ty }
+       -- Under a forall we look only for occurrences of
+       -- the type variable
+
+     -- For kinds, we only do an occurs check; we do not worry
+     -- about type families or foralls
+     -- See Note [Checking for foralls]
+    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs
+                     | otherwise                        = ok
+
+     -- For coercions, we are only doing an occurs check here;
+     -- no bother about impredicativity in coercions, as they're
+     -- inferred
+    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs
+                     | otherwise                       = ok
+
+    bad_tc :: TyCon -> Bool
+    bad_tc tc
+      | not (impredicative_ok || isTauTyCon tc)     = True
+      | not (ty_fam_ok        || isFamFreeTyCon tc) = True
+      | otherwise                                   = False
+
+canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool
+canUnifyWithPolyType dflags details
+  = case details of
+      MetaTv { mtv_info = TyVarTv }    -> False
+      MetaTv { mtv_info = TauTv }      -> xopt LangExt.ImpredicativeTypes dflags
+      _other                           -> True
+          -- We can have non-meta tyvars in given constraints
diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcUnify.hs-boot
@@ -0,0 +1,15 @@
+module TcUnify where
+
+import GhcPrelude
+import TcType      ( TcTauType )
+import TcRnTypes   ( TcM )
+import TcEvidence  ( TcCoercion )
+import HsExpr      ( HsExpr )
+import HsTypes     ( HsType )
+import HsExtension ( GhcRn )
+
+-- This boot file exists only to tie the knot between
+--              TcUnify and Inst
+
+unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
+unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcValidity.hs
@@ -0,0 +1,2845 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}
+
+module TcValidity (
+  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
+  checkValidTheta,
+  checkValidInstance, checkValidInstHead, validDerivPred,
+  checkTySynRhs,
+  checkValidCoAxiom, checkValidCoAxBranch,
+  checkValidTyFamEqn, checkConsistentFamInst,
+  badATErr, arityErr,
+  checkTyConTelescope,
+  allDistinctTyVars
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Maybes
+
+-- friends:
+import TcUnify    ( tcSubType_NC )
+import TcSimplify ( simplifyAmbiguityCheck )
+import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )
+import TyCoRep
+import TcType hiding ( sizeType, sizeTypes )
+import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName )
+import PrelNames
+import Type
+import Unify      ( tcMatchTyX_BM, BindFlag(..) )
+import Coercion
+import CoAxiom
+import Class
+import TyCon
+
+-- others:
+import IfaceType( pprIfaceType, pprIfaceTypeApp )
+import ToIface  ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )
+import HsSyn            -- HsType
+import TcRnMonad        -- TcType, amongst others
+import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv )
+import FunDeps
+import FamInstEnv  ( isDominatedBy, injectiveBranches,
+                     InjectivityCheckResult(..) )
+import FamInst     ( makeInjectivityErrors )
+import Name
+import VarEnv
+import VarSet
+import Var         ( VarBndr(..), mkTyVar )
+import Id          ( idType, idName )
+import FV
+import ErrUtils
+import DynFlags
+import Util
+import ListSetOps
+import SrcLoc
+import Outputable
+import Unique      ( mkAlphaTyVarUnique )
+import Bag         ( emptyBag )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable
+import Data.List        ( (\\), nub )
+import qualified Data.List.NonEmpty as NE
+
+{-
+************************************************************************
+*                                                                      *
+          Checking for ambiguity
+*                                                                      *
+************************************************************************
+
+Note [The ambiguity check for type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+checkAmbiguity is a check on *user-supplied type signatures*.  It is
+*purely* there to report functions that cannot possibly be called.  So for
+example we want to reject:
+   f :: C a => Int
+The idea is there can be no legal calls to 'f' because every call will
+give rise to an ambiguous constraint.  We could soundly omit the
+ambiguity check on type signatures entirely, at the expense of
+delaying ambiguity errors to call sites.  Indeed, the flag
+-XAllowAmbiguousTypes switches off the ambiguity check.
+
+What about things like this:
+   class D a b | a -> b where ..
+   h :: D Int b => Int
+The Int may well fix 'b' at the call site, so that signature should
+not be rejected.  Moreover, using *visible* fundeps is too
+conservative.  Consider
+   class X a b where ...
+   class D a b | a -> b where ...
+   instance D a b => X [a] b where...
+   h :: X a b => a -> a
+Here h's type looks ambiguous in 'b', but here's a legal call:
+   ...(h [True])...
+That gives rise to a (X [Bool] beta) constraint, and using the
+instance means we need (D Bool beta) and that fixes 'beta' via D's
+fundep!
+
+Behind all these special cases there is a simple guiding principle.
+Consider
+
+  f :: <type>
+  f = ...blah...
+
+  g :: <type>
+  g = f
+
+You would think that the definition of g would surely typecheck!
+After all f has exactly the same type, and g=f. But in fact f's type
+is instantiated and the instantiated constraints are solved against
+the originals, so in the case an ambiguous type it won't work.
+Consider our earlier example f :: C a => Int.  Then in g's definition,
+we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
+and fail.
+
+So in fact we use this as our *definition* of ambiguity.  We use a
+very similar test for *inferred* types, to ensure that they are
+unambiguous. See Note [Impedance matching] in TcBinds.
+
+This test is very conveniently implemented by calling
+    tcSubType <type> <type>
+This neatly takes account of the functional dependecy stuff above,
+and implicit parameter (see Note [Implicit parameters and ambiguity]).
+And this is what checkAmbiguity does.
+
+What about this, though?
+   g :: C [a] => Int
+Is every call to 'g' ambiguous?  After all, we might have
+   instance C [a] where ...
+at the call site.  So maybe that type is ok!  Indeed even f's
+quintessentially ambiguous type might, just possibly be callable:
+with -XFlexibleInstances we could have
+  instance C a where ...
+and now a call could be legal after all!  Well, we'll reject this
+unless the instance is available *here*.
+
+Note [When to call checkAmbiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We call checkAmbiguity
+   (a) on user-specified type signatures
+   (b) in checkValidType
+
+Conncerning (b), you might wonder about nested foralls.  What about
+    f :: forall b. (forall a. Eq a => b) -> b
+The nested forall is ambiguous.  Originally we called checkAmbiguity
+in the forall case of check_type, but that had two bad consequences:
+  * We got two error messages about (Eq b) in a nested forall like this:
+       g :: forall a. Eq a => forall b. Eq b => a -> a
+  * If we try to check for ambiguity of a nested forall like
+    (forall a. Eq a => b), the implication constraint doesn't bind
+    all the skolems, which results in "No skolem info" in error
+    messages (see #10432).
+
+To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
+(I'm still a bit worried about unbound skolems when the type mentions
+in-scope type variables.)
+
+In fact, because of the co/contra-variance implemented in tcSubType,
+this *does* catch function f above. too.
+
+Concerning (a) the ambiguity check is only used for *user* types, not
+for types coming from inteface files.  The latter can legitimately
+have ambiguous types. Example
+
+   class S a where s :: a -> (Int,Int)
+   instance S Char where s _ = (1,1)
+   f:: S a => [a] -> Int -> (Int,Int)
+   f (_::[a]) x = (a*x,b)
+        where (a,b) = s (undefined::a)
+
+Here the worker for f gets the type
+        fw :: forall a. S a => Int -> (# Int, Int #)
+
+
+Note [Implicit parameters and ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only a *class* predicate can give rise to ambiguity
+An *implicit parameter* cannot.  For example:
+        foo :: (?x :: [a]) => Int
+        foo = length ?x
+is fine.  The call site will supply a particular 'x'
+
+Furthermore, the type variables fixed by an implicit parameter
+propagate to the others.  E.g.
+        foo :: (Show a, ?x::[a]) => Int
+        foo = show (?x++?x)
+The type of foo looks ambiguous.  But it isn't, because at a call site
+we might have
+        let ?x = 5::Int in foo
+and all is well.  In effect, implicit parameters are, well, parameters,
+so we can take their type variables into account as part of the
+"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.
+-}
+
+checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
+checkAmbiguity ctxt ty
+  | wantAmbiguityCheck ctxt
+  = do { traceTc "Ambiguity check for" (ppr ty)
+         -- Solve the constraints eagerly because an ambiguous type
+         -- can cause a cascade of further errors.  Since the free
+         -- tyvars are skolemised, we can safely use tcSimplifyTop
+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
+       ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
+                            captureConstraints $
+                            tcSubType_NC ctxt ty ty
+       ; simplifyAmbiguityCheck ty wanted
+
+       ; traceTc "Done ambiguity check for" (ppr ty) }
+
+  | otherwise
+  = return ()
+ where
+   mk_msg allow_ambiguous
+     = vcat [ text "In the ambiguity check for" <+> what
+            , ppUnless allow_ambiguous ambig_msg ]
+   ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
+   what | Just n <- isSigMaybe ctxt = quotes (ppr n)
+        | otherwise                 = pprUserTypeCtxt ctxt
+
+wantAmbiguityCheck :: UserTypeCtxt -> Bool
+wantAmbiguityCheck ctxt
+  = case ctxt of  -- See Note [When we don't check for ambiguity]
+      GhciCtxt {}  -> False
+      TySynCtxt {} -> False
+      TypeAppCtxt  -> False
+      _            -> True
+
+checkUserTypeError :: Type -> TcM ()
+-- Check to see if the type signature mentions "TypeError blah"
+-- anywhere in it, and fail if so.
+--
+-- Very unsatisfactorily (#11144) we need to tidy the type
+-- because it may have come from an /inferred/ signature, not a
+-- user-supplied one.  This is really only a half-baked fix;
+-- the other errors in checkValidType don't do tidying, and so
+-- may give bad error messages when given an inferred type.
+checkUserTypeError = check
+  where
+  check ty
+    | Just msg     <- userTypeError_maybe ty  = fail_with msg
+    | Just (_,ts)  <- splitTyConApp_maybe ty  = mapM_ check ts
+    | Just (t1,t2) <- splitAppTy_maybe ty     = check t1 >> check t2
+    | Just (_,t1)  <- splitForAllTy_maybe ty  = check t1
+    | otherwise                               = return ()
+
+  fail_with msg = do { env0 <- tcInitTidyEnv
+                     ; let (env1, tidy_msg) = tidyOpenType env0 msg
+                     ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }
+
+
+{- Note [When we don't check for ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a few places we do not want to check a user-specified type for ambiguity
+
+* GhciCtxt: Allow ambiguous types in GHCi's :kind command
+  E.g.   type family T a :: *  -- T :: forall k. k -> *
+  Then :k T should work in GHCi, not complain that
+  (T k) is ambiguous!
+
+* TySynCtxt: type T a b = C a b => blah
+  It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow
+  cure the ambiguity.  So we defer the ambiguity check to the use site.
+
+  There is also an implementation reason (#11608).  In the RHS of
+  a type synonym we don't (currently) instantiate 'a' and 'b' with
+  TcTyVars before calling checkValidType, so we get asertion failures
+  from doing an ambiguity check on a type with TyVars in it.  Fixing this
+  would not be hard, but let's wait till there's a reason.
+
+* TypeAppCtxt: visible type application
+     f @ty
+  No need to check ty for ambiguity
+
+
+************************************************************************
+*                                                                      *
+          Checking validity of a user-defined type
+*                                                                      *
+************************************************************************
+
+When dealing with a user-written type, we first translate it from an HsType
+to a Type, performing kind checking, and then check various things that should
+be true about it.  We don't want to perform these checks at the same time
+as the initial translation because (a) they are unnecessary for interface-file
+types and (b) when checking a mutually recursive group of type and class decls,
+we can't "look" at the tycons/classes yet.  Also, the checks are rather
+diverse, and used to really mess up the other code.
+
+One thing we check for is 'rank'.
+
+        Rank 0:         monotypes (no foralls)
+        Rank 1:         foralls at the front only, Rank 0 inside
+        Rank 2:         foralls at the front, Rank 1 on left of fn arrow,
+
+        basic ::= tyvar | T basic ... basic
+
+        r2  ::= forall tvs. cxt => r2a
+        r2a ::= r1 -> r2a | basic
+        r1  ::= forall tvs. cxt => r0
+        r0  ::= r0 -> r0 | basic
+
+Another thing is to check that type synonyms are saturated.
+This might not necessarily show up in kind checking.
+        type A i = i
+        data T k = MkT (k Int)
+        f :: T A        -- BAD!
+-}
+
+checkValidType :: UserTypeCtxt -> Type -> TcM ()
+-- Checks that a user-written type is valid for the given context
+-- Assumes argument is fully zonked
+-- Not used for instance decls; checkValidInstance instead
+checkValidType ctxt ty
+  = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty))
+       ; rankn_flag  <- xoptM LangExt.RankNTypes
+       ; impred_flag <- xoptM LangExt.ImpredicativeTypes
+       ; let gen_rank :: Rank -> Rank
+             gen_rank r | rankn_flag = ArbitraryRank
+                        | otherwise  = r
+
+             rank1 = gen_rank r1
+             rank0 = gen_rank r0
+
+             r0 = rankZeroMonoType
+             r1 = LimitedRank True r0
+
+             rank
+               = case ctxt of
+                 DefaultDeclCtxt-> MustBeMonoType
+                 ResSigCtxt     -> MustBeMonoType
+                 PatSigCtxt     -> rank0
+                 RuleSigCtxt _  -> rank1
+                 TySynCtxt _    -> rank0
+
+                 ExprSigCtxt    -> rank1
+                 KindSigCtxt    -> rank1
+                 TypeAppCtxt | impred_flag -> ArbitraryRank
+                             | otherwise   -> tyConArgMonoType
+                    -- Normally, ImpredicativeTypes is handled in check_arg_type,
+                    -- but visible type applications don't go through there.
+                    -- So we do this check here.
+
+                 FunSigCtxt {}  -> rank1
+                 InfSigCtxt _   -> ArbitraryRank        -- Inferred type
+                 ConArgCtxt _   -> rank1 -- We are given the type of the entire
+                                         -- constructor, hence rank 1
+                 PatSynCtxt _   -> rank1
+
+                 ForSigCtxt _   -> rank1
+                 SpecInstCtxt   -> rank1
+                 ThBrackCtxt    -> rank1
+                 GhciCtxt {}    -> ArbitraryRank
+
+                 TyVarBndrKindCtxt _ -> rank0
+                 DataKindCtxt _      -> rank1
+                 TySynKindCtxt _     -> rank1
+                 TyFamResKindCtxt _  -> rank1
+
+                 _              -> panic "checkValidType"
+                                          -- Can't happen; not used for *user* sigs
+
+       ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
+       ; expand <- initialExpandMode
+       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+                             , ve_rank = rank, ve_expand = expand }
+
+       -- Check the internal validity of the type itself
+       -- Fail if bad things happen, else we misleading
+       -- (and more complicated) errors in checkAmbiguity
+       ; checkNoErrs $
+         do { check_type ve ty
+            ; checkUserTypeError ty
+            ; traceTc "done ct" (ppr ty) }
+
+       -- Check for ambiguous types.  See Note [When to call checkAmbiguity]
+       -- NB: this will happen even for monotypes, but that should be cheap;
+       --     and there may be nested foralls for the subtype test to examine
+       ; checkAmbiguity ctxt ty
+
+       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) }
+
+checkValidMonoType :: Type -> TcM ()
+-- Assumes argument is fully zonked
+checkValidMonoType ty
+  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
+       ; expand <- initialExpandMode
+       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt
+                             , ve_rank = MustBeMonoType, ve_expand = expand }
+       ; check_type ve ty }
+
+checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
+checkTySynRhs ctxt ty
+  | tcReturnsConstraintKind actual_kind
+  = do { ck <- xoptM LangExt.ConstraintKinds
+       ; if ck
+         then  when (tcIsConstraintKind actual_kind)
+                    (do { dflags <- getDynFlags
+                        ; expand <- initialExpandMode
+                        ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })
+         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }
+
+  | otherwise
+  = return ()
+  where
+    actual_kind = tcTypeKind ty
+
+{-
+Note [Higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Technically
+            Int -> forall a. a->a
+is still a rank-1 type, but it's not Haskell 98 (#5957).  So the
+validity checker allow a forall after an arrow only if we allow it
+before -- that is, with Rank2Types or RankNTypes
+-}
+
+data Rank = ArbitraryRank         -- Any rank ok
+
+          | LimitedRank   -- Note [Higher rank types]
+                 Bool     -- Forall ok at top
+                 Rank     -- Use for function arguments
+
+          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype
+
+          | MustBeMonoType  -- Monotype regardless of flags
+
+instance Outputable Rank where
+  ppr ArbitraryRank  = text "ArbitraryRank"
+  ppr (LimitedRank top_forall_ok r)
+                     = text "LimitedRank" <+> ppr top_forall_ok
+                                          <+> parens (ppr r)
+  ppr (MonoType msg) = text "MonoType" <+> parens msg
+  ppr MustBeMonoType = text "MustBeMonoType"
+
+rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank
+rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes")
+tyConArgMonoType   = MonoType (text "GHC doesn't yet support impredicative polymorphism")
+synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")
+constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"
+                                    , text "Perhaps you intended to use QuantifiedConstraints" ])
+
+funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result
+funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
+funArgResRank other_rank               = (other_rank, other_rank)
+
+forAllAllowed :: Rank -> Bool
+forAllAllowed ArbitraryRank             = True
+forAllAllowed (LimitedRank forall_ok _) = forall_ok
+forAllAllowed _                         = False
+
+allConstraintsAllowed :: UserTypeCtxt -> Bool
+-- We don't allow arbitrary constraints in kinds
+allConstraintsAllowed (TyVarBndrKindCtxt {}) = False
+allConstraintsAllowed (DataKindCtxt {})      = False
+allConstraintsAllowed (TySynKindCtxt {})     = False
+allConstraintsAllowed (TyFamResKindCtxt {})  = False
+allConstraintsAllowed _ = True
+
+-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
+-- context for the type of a term, where visible, dependent quantification is
+-- currently disallowed.
+--
+-- An example of something that is unambiguously the type of a term is the
+-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the
+-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the
+-- kind of a type, not the type of a term, so it is permitted.
+--
+-- For more examples, see
+-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places
+-- where VDQ is permitted) and
+-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where
+-- VDQ is disallowed).
+vdqAllowed :: UserTypeCtxt -> Bool
+-- Currently allowed in the kinds of types...
+vdqAllowed (KindSigCtxt {}) = True
+vdqAllowed (TySynCtxt {}) = True
+vdqAllowed (ThBrackCtxt {}) = True
+vdqAllowed (GhciCtxt {}) = True
+vdqAllowed (TyVarBndrKindCtxt {}) = True
+vdqAllowed (DataKindCtxt {}) = True
+vdqAllowed (TySynKindCtxt {}) = True
+vdqAllowed (TyFamResKindCtxt {}) = True
+-- ...but not in the types of terms.
+vdqAllowed (ConArgCtxt {}) = False
+  -- We could envision allowing VDQ in data constructor types so long as the
+  -- constructor is only ever used at the type level, but for now, GHC adopts
+  -- the stance that VDQ is never allowed in data constructor types.
+vdqAllowed (FunSigCtxt {}) = False
+vdqAllowed (InfSigCtxt {}) = False
+vdqAllowed (ExprSigCtxt {}) = False
+vdqAllowed (TypeAppCtxt {}) = False
+vdqAllowed (PatSynCtxt {}) = False
+vdqAllowed (PatSigCtxt {}) = False
+vdqAllowed (RuleSigCtxt {}) = False
+vdqAllowed (ResSigCtxt {}) = False
+vdqAllowed (ForSigCtxt {}) = False
+vdqAllowed (DefaultDeclCtxt {}) = False
+-- We count class constraints as "types of terms". All of the cases below deal
+-- with class constraints.
+vdqAllowed (InstDeclCtxt {}) = False
+vdqAllowed (SpecInstCtxt {}) = False
+vdqAllowed (GenSigCtxt {}) = False
+vdqAllowed (ClassSCCtxt {}) = False
+vdqAllowed (SigmaCtxt {}) = False
+vdqAllowed (DataTyCtxt {}) = False
+vdqAllowed (DerivClauseCtxt {}) = False
+
+{-
+Note [Correctness and performance of type synonym validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the type A arg1 arg2, where A is a type synonym. How should we check
+this type for validity? We have three distinct choices, corresponding to the
+three constructors of ExpandMode:
+
+1. Expand the application of A, and check the resulting type (`Expand`).
+2. Don't expand the application of A. Only check the arguments (`NoExpand`).
+3. Check the arguments *and* check the expanded type (`Both`).
+
+It's tempting to think that we could always just pick choice (3), but this
+results in serious performance issues when checking a type like in the
+signature for `f` below:
+
+  type S = ...
+  f :: S (S (S (S (S (S ....(S Int)...))))
+
+When checking the type of `f`, we'll check the outer `S` application with and
+without expansion, and in *each* of those checks, we'll check the next `S`
+application with and without expansion... the result is exponential blowup! So
+clearly we don't want to use `Both` 100% of the time.
+
+On the other hand, neither is it correct to use exclusively `Expand` or
+exclusively `NoExpand` 100% of the time:
+
+* If one always expands, then one can miss erroneous programs like the one in
+  the `tcfail129` test case:
+
+    type Foo a = String -> Maybe a
+    type Bar m = m Int
+    blah = undefined :: Bar Foo
+
+  If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type
+  synonyms is unsaturated.
+* If one never expands and only checks the arguments, then one can miss
+  erroneous programs like the one in #16059:
+
+    type Foo b = Eq b => b
+    f :: forall b (a :: Foo b). Int
+
+  The kind of `a` contains a constraint, which is illegal, but this will only
+  be caught if `Foo b` is expanded.
+
+Therefore, it's impossible to have these validity checks be simultaneously
+correct and performant if one sticks exclusively to a single `ExpandMode`. In
+that case, the solution is to vary the `ExpandMode`s! In more detail:
+
+1. When we start validity checking, we start with `Expand` if
+   LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we
+   do this), and we start with `Both` otherwise. The `initialExpandMode`
+   function is responsible for this.
+2. When expanding an application of a type synonym (in `check_syn_tc_app`), we
+   determine which things to check based on the current `ExpandMode` argument.
+   Importantly, if the current mode is `Both`, then we check the arguments in
+   `NoExpand` mode and check the expanded type in `Both` mode.
+
+   Switching to `NoExpand` when checking the arguments is vital to avoid
+   exponential blowup. One consequence of this choice is that if you have
+   the following type synonym in one module (with RankNTypes enabled):
+
+     {-# LANGUAGE RankNTypes #-}
+     module A where
+     type A = forall a. a
+
+   And you define the following in a separate module *without* RankNTypes
+   enabled:
+
+     module B where
+
+     import A
+
+     type Const a b = a
+     f :: Const Int A -> Int
+
+   Then `f` will be accepted, even though `A` (which is technically a rank-n
+   type) appears in its type. We view this as an acceptable compromise, since
+   `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in
+   a type post-expansion, such as in the following variant:
+
+     g :: Const A A -> Int
+
+   Then that would be rejected unless RankNTypes were enabled.
+-}
+
+-- | When validity-checking an application of a type synonym, should we
+-- check the arguments, check the expanded type, or both?
+-- See Note [Correctness and performance of type synonym validity checking]
+data ExpandMode
+  = Expand   -- ^ Only check the expanded type.
+  | NoExpand -- ^ Only check the arguments.
+  | Both     -- ^ Check both the arguments and the expanded type.
+
+instance Outputable ExpandMode where
+  ppr e = text $ case e of
+                   Expand   -> "Expand"
+                   NoExpand -> "NoExpand"
+                   Both     -> "Both"
+
+-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the
+-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start
+-- in 'Both' mode.
+initialExpandMode :: TcM ExpandMode
+initialExpandMode = do
+  liberal_flag <- xoptM LangExt.LiberalTypeSynonyms
+  pure $ if liberal_flag then Expand else Both
+
+-- | Information about a type being validity-checked.
+data ValidityEnv = ValidityEnv
+  { ve_tidy_env :: TidyEnv
+  , ve_ctxt     :: UserTypeCtxt
+  , ve_rank     :: Rank
+  , ve_expand   :: ExpandMode }
+
+instance Outputable ValidityEnv where
+  ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+                  , ve_rank = rank, ve_expand = expand }) =
+    hang (text "ValidityEnv")
+       2 (vcat [ text "ve_tidy_env" <+> ppr env
+               , text "ve_ctxt"     <+> pprUserTypeCtxt ctxt
+               , text "ve_rank"     <+> ppr rank
+               , text "ve_expand"   <+> ppr expand ])
+
+----------------------------------------
+check_type :: ValidityEnv -> Type -> TcM ()
+-- The args say what the *type context* requires, independent
+-- of *flag* settings.  You test the flag settings at usage sites.
+--
+-- Rank is allowed rank for function args
+-- Rank 0 means no for-alls anywhere
+
+check_type _ (TyVarTy _) = return ()
+
+check_type ve (AppTy ty1 ty2)
+  = do  { check_type ve ty1
+        ; check_arg_type False ve ty2 }
+
+check_type ve ty@(TyConApp tc tys)
+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+  = check_syn_tc_app ve ty tc tys
+  | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys
+  | otherwise              = mapM_ (check_arg_type False ve) tys
+
+check_type _ (LitTy {}) = return ()
+
+check_type ve (CastTy ty _) = check_type ve ty
+
+-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x).
+--
+-- Critically, this case must come *after* the case for TyConApp.
+-- See Note [Liberal type synonyms].
+check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+                          , ve_rank = rank, ve_expand = expand }) ty
+  | not (null tvbs && null theta)
+  = do  { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))
+        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)
+                -- Reject e.g. (Maybe (?x::Int => Int)),
+                -- with a decent error message
+
+        ; checkConstraintsOK ve theta ty
+                -- Reject forall (a :: Eq b => b). blah
+                -- In a kind signature we don't allow constraints
+
+        ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs
+                         || vdqAllowed ctxt)
+                   (illegalVDQTyErr env ty)
+                -- Reject visible, dependent quantification in the type of a
+                -- term (e.g., `f :: forall a -> a -> Maybe a`)
+
+        ; check_valid_theta env' SigmaCtxt expand theta
+                -- Allow     type T = ?x::Int => Int -> Int
+                -- but not   type T = ?x::Int
+
+        ; check_type (ve{ve_tidy_env = env'}) tau
+                -- Allow foralls to right of arrow
+
+        ; checkEscapingKind env' tvbs' theta tau }
+  where
+    (tvbs, phi)   = tcSplitForAllVarBndrs ty
+    (theta, tau)  = tcSplitPhiTy phi
+    (env', tvbs') = tidyTyCoVarBinders env tvbs
+
+check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty)
+  = do  { check_type (ve{ve_rank = arg_rank}) arg_ty
+        ; check_type (ve{ve_rank = res_rank}) res_ty }
+  where
+    (arg_rank, res_rank) = funArgResRank rank
+
+check_type _ ty = pprPanic "check_type" (ppr ty)
+
+----------------------------------------
+check_syn_tc_app :: ValidityEnv
+                 -> KindOrType -> TyCon -> [KindOrType] -> TcM ()
+-- Used for type synonyms and type synonym families,
+-- which must be saturated,
+-- but not data families, which need not be saturated
+check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand })
+                 ty tc tys
+  | tys `lengthAtLeast` tc_arity   -- Saturated
+       -- Check that the synonym has enough args
+       -- This applies equally to open and closed synonyms
+       -- It's OK to have an *over-applied* type synonym
+       --      data Tree a b = ...
+       --      type Foo a = Tree [a]
+       --      f :: Foo a b -> ...
+  = case expand of
+      _ |  isTypeFamilyTyCon tc
+        -> check_args_only expand
+      -- See Note [Correctness and performance of type synonym validity
+      --           checking]
+      Expand   -> check_expansion_only expand
+      NoExpand -> check_args_only expand
+      Both     -> check_args_only NoExpand *> check_expansion_only Both
+
+  | GhciCtxt True <- ctxt  -- Accept outermost under-saturated type synonym or
+                           -- type family constructors in GHCi :kind commands.
+                           -- See Note [Unsaturated type synonyms in GHCi]
+  = check_args_only expand
+
+  | otherwise
+  = failWithTc (tyConArityErr tc tys)
+  where
+    tc_arity  = tyConArity tc
+
+    check_arg :: ExpandMode -> KindOrType -> TcM ()
+    check_arg expand =
+      check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand})
+
+    check_args_only, check_expansion_only :: ExpandMode -> TcM ()
+    check_args_only expand = mapM_ (check_arg expand) tys
+
+    check_expansion_only expand
+      = ASSERT2( isTypeSynonymTyCon tc, ppr tc )
+        case tcView ty of
+         Just ty' -> let err_ctxt = text "In the expansion of type synonym"
+                                    <+> quotes (ppr tc)
+                     in addErrCtxt err_ctxt $
+                        check_type (ve{ve_expand = expand}) ty'
+         Nothing  -> pprPanic "check_syn_tc_app" (ppr ty)
+
+{-
+Note [Unsaturated type synonyms in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking, GHC disallows unsaturated uses of type synonyms or type
+families. For instance, if one defines `type Const a b = a`, then GHC will not
+permit using `Const` unless it is applied to (at least) two arguments. There is
+an exception to this rule, however: GHCi's :kind command. For instance, it
+is quite common to look up the kind of a type constructor like so:
+
+  λ> :kind Const
+  Const :: j -> k -> j
+  λ> :kind Const Int
+  Const Int :: k -> Type
+
+Strictly speaking, the two uses of `Const` above are unsaturated, but this
+is an extremely benign (and useful) example of unsaturation, so we allow it
+here as a special case.
+
+That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise,
+this GHCi interaction would be possible:
+
+  λ> newtype Fix f = MkFix (f (Fix f))
+  λ> type Id a = a
+  λ> :kind Fix Id
+  Fix Id :: Type
+
+This is rather dodgy, so we move to disallow this. We only permit unsaturated
+synonyms in GHCi if they are *top-level*—that is, if the synonym is the
+outermost type being applied. This allows `Const` and `Const Int` in the
+first example, but not `Fix Id` in the second example, as `Id` is not the
+outermost type being applied (`Fix` is).
+
+We track this outermost property in the GhciCtxt constructor of UserTypeCtxt.
+A field of True in GhciCtxt indicates that we're in an outermost position. Any
+time we invoke `check_arg` to check the validity of an argument, we switch the
+field to False.
+-}
+
+----------------------------------------
+check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
+check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys
+  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples
+        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)
+
+        ; impred <- xoptM LangExt.ImpredicativeTypes
+        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType
+                -- c.f. check_arg_type
+                -- However, args are allowed to be unlifted, or
+                -- more unboxed tuples, so can't use check_arg_ty
+        ; mapM_ (check_type (ve{ve_rank = rank'})) tys }
+
+----------------------------------------
+check_arg_type
+  :: Bool -- ^ Is this the argument to a type synonym?
+  -> ValidityEnv -> KindOrType -> TcM ()
+-- The sort of type that can instantiate a type variable,
+-- or be the argument of a type constructor.
+-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
+-- Other unboxed types are very occasionally allowed as type
+-- arguments depending on the kind of the type constructor
+--
+-- For example, we want to reject things like:
+--
+--      instance Ord a => Ord (forall s. T s a)
+-- and
+--      g :: T s (forall b.b)
+--
+-- NB: unboxed tuples can have polymorphic or unboxed args.
+--     This happens in the workers for functions returning
+--     product types with polymorphic components.
+--     But not in user code.
+-- Anyway, they are dealt with by a special case in check_tau_type
+
+check_arg_type _ _ (CoercionTy {}) = return ()
+
+check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty
+  = do  { impred <- xoptM LangExt.ImpredicativeTypes
+        ; let rank' = case rank of          -- Predictive => must be monotype
+                        -- Rank-n arguments to type synonyms are OK, provided
+                        -- that LiberalTypeSynonyms is enabled.
+                        _ | type_syn       -> synArgMonoType
+                        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
+                        _other | impred    -> ArbitraryRank
+                               | otherwise -> tyConArgMonoType
+                        -- Make sure that MustBeMonoType is propagated,
+                        -- so that we don't suggest -XImpredicativeTypes in
+                        --    (Ord (forall a.a)) => a -> a
+                        -- and so that if it Must be a monotype, we check that it is!
+              ctxt' :: UserTypeCtxt
+              ctxt'
+                | GhciCtxt _ <- ctxt = GhciCtxt False
+                    -- When checking an argument, set the field of GhciCtxt to
+                    -- False to indicate that we are no longer in an outermost
+                    -- position (and thus unsaturated synonyms are no longer
+                    -- allowed).
+                    -- See Note [Unsaturated type synonyms in GHCi]
+                | otherwise          = ctxt
+
+        ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }
+
+----------------------------------------
+forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
+forAllTyErr env rank ty
+   = ( env
+     , vcat [ hang herald 2 (ppr_tidy env ty)
+            , suggestion ] )
+  where
+    (tvs, _theta, _tau) = tcSplitSigmaTy ty
+    herald | null tvs  = text "Illegal qualified type:"
+           | otherwise = text "Illegal polymorphic type:"
+    suggestion = case rank of
+                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes"
+                   MonoType d     -> d
+                   _              -> Outputable.empty -- Polytype is always illegal
+
+-- | Reject type variables that would escape their escape through a kind.
+-- See @Note [Type variables escaping through kinds]@.
+checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM ()
+checkEscapingKind env tvbs theta tau =
+  case occCheckExpand (binderVars tvbs) phi_kind of
+    -- Ensure that none of the tvs occur in the kind of the forall
+    -- /after/ expanding type synonyms.
+    -- See Note [Phantom type variables in kinds] in Type
+    Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind
+    Just _  -> pure ()
+  where
+    tau_kind              = tcTypeKind tau
+    phi_kind | null theta = tau_kind
+             | otherwise  = liftedTypeKind
+        -- If there are any constraints, the kind is *. (#11405)
+
+forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind
+                -> (TidyEnv, SDoc)
+forAllEscapeErr env tvbs theta tau tau_kind
+  = ( env
+    , vcat [ hang (text "Quantified type's kind mentions quantified type variable")
+                2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau)))
+                -- NB: Don't tidy this type since the tvbs were already tidied
+                -- previously, and re-tidying them will make the names of type
+                -- variables different from tau_kind.
+           , hang (text "where the body of the forall has this kind:")
+                2 (quotes (ppr_tidy env tau_kind)) ] )
+
+{-
+Note [Type variables escaping through kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+
+  type family T (r :: RuntimeRep) :: TYPE r
+  foo :: forall r. T r
+
+Something smells funny about the type of `foo`. If you spell out the kind
+explicitly, it becomes clearer from where the smell originates:
+
+  foo :: ((forall r. T r) :: TYPE r)
+
+The type variable `r` appears in the result kind, which escapes the scope of
+its binding site! This is not desirable, so we establish a validity check
+(`checkEscapingKind`) to catch any type variables that might escape through
+kinds in this way.
+-}
+
+ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+ubxArgTyErr env ty
+  = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"
+                      , ppr_tidy env ty ]
+                , text "Perhaps you intended to use UnboxedTuples" ] )
+
+checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM ()
+checkConstraintsOK ve theta ty
+  | null theta                         = return ()
+  | allConstraintsAllowed (ve_ctxt ve) = return ()
+  | otherwise
+  = -- We are in a kind, where we allow only equality predicates
+    -- See Note [Constraints in kinds] in TyCoRep, and #16263
+    checkTcM (all isEqPred theta) $
+    constraintTyErr (ve_tidy_env ve) ty
+
+constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+constraintTyErr env ty
+  = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty)
+
+-- | Reject a use of visible, dependent quantification in the type of a term.
+illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+illegalVDQTyErr env ty =
+  (env, vcat
+  [ hang (text "Illegal visible, dependent quantification" <+>
+          text "in the type of a term:")
+       2 (ppr_tidy env ty)
+  , text "(GHC does not yet support this)" ] )
+
+{-
+Note [Liberal type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
+doing validity checking.  This allows us to instantiate a synonym defn
+with a for-all type, or with a partially-applied type synonym.
+        e.g.   type T a b = a
+               type S m   = m ()
+               f :: S (T Int)
+Here, T is partially applied, so it's illegal in H98.  But if you
+expand S first, then T we get just
+               f :: Int
+which is fine.
+
+IMPORTANT: suppose T is a type synonym.  Then we must do validity
+checking on an appliation (T ty1 ty2)
+
+        *either* before expansion (i.e. check ty1, ty2)
+        *or* after expansion (i.e. expand T ty1 ty2, and then check)
+        BUT NOT BOTH
+
+If we do both, we get exponential behaviour!!
+
+  data TIACons1 i r c = c i ::: r c
+  type TIACons2 t x = TIACons1 t (TIACons1 t x)
+  type TIACons3 t x = TIACons2 t (TIACons1 t x)
+  type TIACons4 t x = TIACons2 t (TIACons2 t x)
+  type TIACons7 t x = TIACons4 t (TIACons3 t x)
+
+The order in which you do validity checking is also somewhat delicate. Consider
+the `check_type` function, which drives the validity checking for unsaturated
+uses of type synonyms. There is a special case for rank-n types, such as
+(forall x. x -> x) or (Show x => x), since those require at least one language
+extension to use. It used to be the case that this case came before every other
+case, but this can lead to bugs. Imagine you have this scenario (from #15954):
+
+  type A a = Int
+  type B (a :: Type -> Type) = forall x. x -> x
+  type C = B A
+
+If the rank-n case came first, then in the process of checking for `forall`s
+or contexts, we would expand away `B A` to `forall x. x -> x`. This is because
+the functions that split apart `forall`s/contexts
+(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded
+away to `forall x. x -> x` before the actually validity checks occur, we will
+have completely obfuscated the fact that we had an unsaturated application of
+the `A` type synonym.
+
+We have since learned from our mistakes and now put this rank-n case /after/
+the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be
+caught properly. But be careful! We can't make the rank-n case /last/ either,
+as the FunTy case must came after the rank-n case. Otherwise, something like
+(Eq a => Int) would be treated as a function type (FunTy), which just
+wouldn't do.
+
+************************************************************************
+*                                                                      *
+\subsection{Checking a theta or source type}
+*                                                                      *
+************************************************************************
+
+Note [Implicit parameters in instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Implicit parameters _only_ allowed in type signatures; not in instance
+decls, superclasses etc. The reason for not allowing implicit params in
+instances is a bit subtle.  If we allowed
+  instance (?x::Int, Eq a) => Foo [a] where ...
+then when we saw
+     (e :: (?x::Int) => t)
+it would be unclear how to discharge all the potential uses of the ?x
+in e.  For example, a constraint Foo [Int] might come out of e, and
+applying the instance decl would show up two uses of ?x.  #8912.
+-}
+
+checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
+-- Assumes argument is fully zonked
+checkValidTheta ctxt theta
+  = addErrCtxtM (checkThetaCtxt ctxt theta) $
+    do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)
+       ; expand <- initialExpandMode
+       ; check_valid_theta env ctxt expand theta }
+
+-------------------------
+check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode
+                  -> [PredType] -> TcM ()
+check_valid_theta _ _ _ []
+  = return ()
+check_valid_theta env ctxt expand theta
+  = do { dflags <- getDynFlags
+       ; warnTcM (Reason Opt_WarnDuplicateConstraints)
+                 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)
+                 (dupPredWarn env dups)
+       ; traceTc "check_valid_theta" (ppr theta)
+       ; mapM_ (check_pred_ty env dflags ctxt expand) theta }
+  where
+    (_,dups) = removeDups nonDetCmpType theta
+    -- It's OK to use nonDetCmpType because dups only appears in the
+    -- warning
+
+-------------------------
+{- Note [Validity checking for constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We look through constraint synonyms so that we can see the underlying
+constraint(s).  For example
+   type Foo = ?x::Int
+   instance Foo => C T
+We should reject the instance because it has an implicit parameter in
+the context.
+
+But we record, in 'under_syn', whether we have looked under a synonym
+to avoid requiring language extensions at the use site.  Main example
+(#9838):
+
+   {-# LANGUAGE ConstraintKinds #-}
+   module A where
+      type EqShow a = (Eq a, Show a)
+
+   module B where
+      import A
+      foo :: EqShow a => a -> String
+
+We don't want to require ConstraintKinds in module B.
+-}
+
+check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode
+              -> PredType -> TcM ()
+-- Check the validity of a predicate in a signature
+-- See Note [Validity checking for constraints]
+check_pred_ty env dflags ctxt expand pred
+  = do { check_type ve pred
+       ; check_pred_help False env dflags ctxt pred }
+  where
+    rank | xopt LangExt.QuantifiedConstraints dflags
+         = ArbitraryRank
+         | otherwise
+         = constraintMonoType
+
+    ve :: ValidityEnv
+    ve = ValidityEnv{ ve_tidy_env = env
+                    , ve_ctxt     = SigmaCtxt
+                    , ve_rank     = rank
+                    , ve_expand   = expand }
+
+check_pred_help :: Bool    -- True <=> under a type synonym
+                -> TidyEnv
+                -> DynFlags -> UserTypeCtxt
+                -> PredType -> TcM ()
+check_pred_help under_syn env dflags ctxt pred
+  | Just pred' <- tcView pred  -- Switch on under_syn when going under a
+                                 -- synonym (#9838, yuk)
+  = check_pred_help True env dflags ctxt pred'
+
+  | otherwise  -- A bit like classifyPredType, but not the same
+               -- E.g. we treat (~) like (~#); and we look inside tuples
+  = case classifyPredType pred of
+      ClassPred cls tys
+        | isCTupleClass cls   -> check_tuple_pred under_syn env dflags ctxt pred tys
+        | otherwise           -> check_class_pred env dflags ctxt pred cls tys
+
+      EqPred NomEq _ _  -> -- a ~# b
+                           check_eq_pred env dflags pred
+
+      EqPred ReprEq _ _ -> -- Ugh!  When inferring types we may get
+                           -- f :: (a ~R# b) => blha
+                           -- And we want to treat that like (Coercible a b)
+                           -- We should probably check argument shapes, but we
+                           -- didn't do so before, so I'm leaving it for now
+                           return ()
+
+      ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head
+      IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred
+
+check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()
+check_eq_pred env dflags pred
+  =         -- Equational constraints are valid in all contexts if type
+            -- families are permitted
+    checkTcM (xopt LangExt.TypeFamilies dflags
+              || xopt LangExt.GADTs dflags)
+             (eqPredTyErr env pred)
+
+check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> ThetaType -> PredType -> TcM ()
+check_quant_pred env dflags _ctxt pred theta head_pred
+  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $
+    do { -- Check the instance head
+         case classifyPredType head_pred of
+            ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys
+                                 -- SigmaCtxt tells checkValidInstHead that
+                                 -- this is the head of a quantified constraint
+            IrredPred {}      | hasTyVarHead head_pred
+                              -> return ()
+            _                 -> failWithTcM (badQuantHeadErr env pred)
+
+         -- Check for termination
+       ; unless (xopt LangExt.UndecidableInstances dflags) $
+         checkInstTermination theta head_pred
+    }
+
+check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
+check_tuple_pred under_syn env dflags ctxt pred ts
+  = do { -- See Note [ConstraintKinds in predicates]
+         checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)
+                  (predTupleErr env pred)
+       ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }
+    -- This case will not normally be executed because without
+    -- -XConstraintKinds tuple types are only kind-checked as *
+
+check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
+check_irred_pred under_syn env dflags ctxt pred
+    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
+    -- where X is a type function
+  = do { -- If it looks like (x t1 t2), require ConstraintKinds
+         --   see Note [ConstraintKinds in predicates]
+         -- But (X t1 t2) is always ok because we just require ConstraintKinds
+         -- at the definition site (#9838)
+        failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)
+                                && hasTyVarHead pred)
+                  (predIrredErr env pred)
+
+         -- Make sure it is OK to have an irred pred in this context
+         -- See Note [Irreducible predicates in superclasses]
+       ; failIfTcM (is_superclass ctxt
+                    && not (xopt LangExt.UndecidableInstances dflags)
+                    && has_tyfun_head pred)
+                   (predSuperClassErr env pred) }
+  where
+    is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }
+    has_tyfun_head ty
+      = case tcSplitTyConApp_maybe ty of
+          Just (tc, _) -> isTypeFamilyTyCon tc
+          Nothing      -> False
+
+{- Note [ConstraintKinds in predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Don't check for -XConstraintKinds under a type synonym, because that
+was done at the type synonym definition site; see #9838
+e.g.   module A where
+          type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds
+       module B where
+          import A
+          f :: C a => a -> a        -- Does *not* need -XConstraintKinds
+
+Note [Irreducible predicates in superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Allowing type-family calls in class superclasses is somewhat dangerous
+because we can write:
+
+ type family Fooish x :: * -> Constraint
+ type instance Fooish () = Foo
+ class Fooish () a => Foo a where
+
+This will cause the constraint simplifier to loop because every time we canonicalise a
+(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
+solved to add+canonicalise another (Foo a) constraint.  -}
+
+-------------------------
+check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> Class -> [TcType] -> TcM ()
+check_class_pred env dflags ctxt pred cls tys
+  |  isEqPredClass cls    -- (~) and (~~) are classified as classes,
+                          -- but here we want to treat them as equalities
+  = -- pprTrace "check_class" (ppr cls) $
+    check_eq_pred env dflags pred
+
+  | isIPClass cls
+  = do { check_arity
+       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }
+
+  | otherwise     -- Includes Coercible
+  = do { check_arity
+       ; checkSimplifiableClassConstraint env dflags ctxt cls tys
+       ; checkTcM arg_tys_ok (predTyVarErr env pred) }
+  where
+    check_arity = checkTc (tys `lengthIs` classArity cls)
+                          (tyConArityErr (classTyCon cls) tys)
+
+    -- Check the arguments of a class constraint
+    flexible_contexts = xopt LangExt.FlexibleContexts     dflags
+    undecidable_ok    = xopt LangExt.UndecidableInstances dflags
+    arg_tys_ok = case ctxt of
+        SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
+        InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
+                                -- Further checks on head and theta
+                                -- in checkInstTermination
+        _               -> checkValidClsArgs flexible_contexts cls tys
+
+checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt
+                                 -> Class -> [TcType] -> TcM ()
+-- See Note [Simplifiable given constraints]
+checkSimplifiableClassConstraint env dflags ctxt cls tys
+  | not (wopt Opt_WarnSimplifiableClassConstraints dflags)
+  = return ()
+  | xopt LangExt.MonoLocalBinds dflags
+  = return ()
+
+  | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"
+  = return ()               -- of a data type declaration
+
+  | cls `hasKey` coercibleTyConKey
+  = return ()   -- Oddly, we treat (Coercible t1 t2) as unconditionally OK
+                -- matchGlobalInst will reply "yes" because we can reduce
+                -- (Coercible a b) to (a ~R# b)
+
+  | otherwise
+  = do { result <- matchGlobalInst dflags False cls tys
+       ; case result of
+           OneInst { cir_what = what }
+              -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)
+                                   (simplifiable_constraint_warn what)
+           _          -> return () }
+  where
+    pred = mkClassPred cls tys
+
+    simplifiable_constraint_warn :: InstanceWhat -> SDoc
+    simplifiable_constraint_warn what
+     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))
+                    <+> text "matches")
+                 2 (ppr_what what)
+            , hang (text "This makes type inference for inner bindings fragile;")
+                 2 (text "either use MonoLocalBinds, or simplify it using the instance") ]
+
+    ppr_what BuiltinInstance = text "a built-in instance"
+    ppr_what LocalInstance   = text "a locally-quantified instance"
+    ppr_what (TopLevInstance { iw_dfun_id = dfun })
+      = hang (text "instance" <+> pprSigmaType (idType dfun))
+           2 (text "--" <+> pprDefinedAt (idName dfun))
+
+
+{- Note [Simplifiable given constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A type signature like
+   f :: Eq [(a,b)] => a -> b
+is very fragile, for reasons described at length in TcInteract
+Note [Instance and Given overlap].  As that Note discusses, for the
+most part the clever stuff in TcInteract means that we don't use a
+top-level instance if a local Given might fire, so there is no
+fragility. But if we /infer/ the type of a local let-binding, things
+can go wrong (#11948 is an example, discussed in the Note).
+
+So this warning is switched on only if we have NoMonoLocalBinds; in
+that case the warning discourages users from writing simplifiable
+class constraints.
+
+The warning only fires if the constraint in the signature
+matches the top-level instances in only one way, and with no
+unifiers -- that is, under the same circumstances that
+TcInteract.matchInstEnv fires an interaction with the top
+level instances.  For example (#13526), consider
+
+  instance {-# OVERLAPPABLE #-} Eq (T a) where ...
+  instance                   Eq (T Char) where ..
+  f :: Eq (T a) => ...
+
+We don't want to complain about this, even though the context
+(Eq (T a)) matches an instance, because the user may be
+deliberately deferring the choice so that the Eq (T Char)
+has a chance to fire when 'f' is called.  And the fragility
+only matters when there's a risk that the instance might
+fire instead of the local 'given'; and there is no such
+risk in this case.  Just use the same rules as for instance
+firing!
+-}
+
+-------------------------
+okIPCtxt :: UserTypeCtxt -> Bool
+  -- See Note [Implicit parameters in instance decls]
+okIPCtxt (FunSigCtxt {})        = True
+okIPCtxt (InfSigCtxt {})        = True
+okIPCtxt ExprSigCtxt            = True
+okIPCtxt TypeAppCtxt            = True
+okIPCtxt PatSigCtxt             = True
+okIPCtxt ResSigCtxt             = True
+okIPCtxt GenSigCtxt             = True
+okIPCtxt (ConArgCtxt {})        = True
+okIPCtxt (ForSigCtxt {})        = True  -- ??
+okIPCtxt ThBrackCtxt            = True
+okIPCtxt (GhciCtxt {})          = True
+okIPCtxt SigmaCtxt              = True
+okIPCtxt (DataTyCtxt {})        = True
+okIPCtxt (PatSynCtxt {})        = True
+okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int
+                                         -- #11466
+
+okIPCtxt (KindSigCtxt {})       = False
+okIPCtxt (ClassSCCtxt {})       = False
+okIPCtxt (InstDeclCtxt {})      = False
+okIPCtxt (SpecInstCtxt {})      = False
+okIPCtxt (RuleSigCtxt {})       = False
+okIPCtxt DefaultDeclCtxt        = False
+okIPCtxt DerivClauseCtxt        = False
+okIPCtxt (TyVarBndrKindCtxt {}) = False
+okIPCtxt (DataKindCtxt {})      = False
+okIPCtxt (TySynKindCtxt {})     = False
+okIPCtxt (TyFamResKindCtxt {})  = False
+
+{-
+Note [Kind polymorphic type classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+MultiParam check:
+
+    class C f where...   -- C :: forall k. k -> Constraint
+    instance C Maybe where...
+
+  The dictionary gets type [C * Maybe] even if it's not a MultiParam
+  type class.
+
+Flexibility check:
+
+    class C f where...   -- C :: forall k. k -> Constraint
+    data D a = D a
+    instance C D where
+
+  The dictionary gets type [C * (D *)]. IA0_TODO it should be
+  generalized actually.
+-}
+
+checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)
+checkThetaCtxt ctxt theta env
+  = return ( env
+           , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)
+                  , text "While checking" <+> pprUserTypeCtxt ctxt ] )
+
+eqPredTyErr, predTupleErr, predIrredErr,
+   predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+badQuantHeadErr env pred
+  = ( env
+    , hang (text "Quantified predicate must have a class or type variable head:")
+         2 (ppr_tidy env pred) )
+eqPredTyErr  env pred
+  = ( env
+    , text "Illegal equational constraint" <+> ppr_tidy env pred $$
+      parens (text "Use GADTs or TypeFamilies to permit this") )
+predTupleErr env pred
+  = ( env
+    , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)
+         2 (parens constraintKindsMsg) )
+predIrredErr env pred
+  = ( env
+    , hang (text "Illegal constraint:" <+> ppr_tidy env pred)
+         2 (parens constraintKindsMsg) )
+predSuperClassErr env pred
+  = ( env
+    , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)
+            <+> text "in a superclass context")
+         2 (parens undecidableMsg) )
+
+predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+predTyVarErr env pred
+  = (env
+    , vcat [ hang (text "Non type-variable argument")
+                2 (text "in the constraint:" <+> ppr_tidy env pred)
+           , parens (text "Use FlexibleContexts to permit this") ])
+
+badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+badIPPred env pred
+  = ( env
+    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )
+
+constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+constraintSynErr env kind
+  = ( env
+    , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))
+         2 (parens constraintKindsMsg) )
+
+dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)
+dupPredWarn env dups
+  = ( env
+    , text "Duplicate constraint" <> plural primaryDups <> text ":"
+      <+> pprWithCommas (ppr_tidy env) primaryDups )
+  where
+    primaryDups = map NE.head dups
+
+tyConArityErr :: TyCon -> [TcType] -> SDoc
+-- For type-constructor arity errors, be careful to report
+-- the number of /visible/ arguments required and supplied,
+-- ignoring the /invisible/ arguments, which the user does not see.
+-- (e.g. #10516)
+tyConArityErr tc tks
+  = arityErr (ppr (tyConFlavour tc)) (tyConName tc)
+             tc_type_arity tc_type_args
+  where
+    vis_tks = filterOutInvisibleTypes tc tks
+
+    -- tc_type_arity = number of *type* args expected
+    -- tc_type_args  = number of *type* args encountered
+    tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)
+    tc_type_args  = length vis_tks
+
+arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc
+arityErr what name n m
+  = hsep [ text "The" <+> what, quotes (ppr name), text "should have",
+           n_arguments <> comma, text "but has been given",
+           if m==0 then text "none" else int m]
+    where
+        n_arguments | n == 0 = text "no arguments"
+                    | n == 1 = text "1 argument"
+                    | True   = hsep [int n, text "arguments"]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Checking for a decent instance head type}
+*                                                                      *
+************************************************************************
+
+@checkValidInstHead@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@
+
+The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
+flag is on, or (2)~the instance is imported (they must have been
+compiled elsewhere). In these cases, we let them go through anyway.
+
+We can also have instances for functions: @instance Foo (a -> b) ...@.
+-}
+
+checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
+checkValidInstHead ctxt clas cls_args
+  = do { dflags   <- getDynFlags
+       ; is_boot  <- tcIsHsBootOrSig
+       ; is_sig   <- tcIsHsig
+       ; check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
+       }
+
+{-
+
+Note [Instances of built-in classes in signature files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+User defined instances for KnownNat, KnownSymbol and Typeable are
+disallowed -- they are generated when needed by GHC itself on-the-fly.
+
+However, if they occur in a Backpack signature file, they have an
+entirely different meaning. Suppose in M.hsig we see
+
+  signature M where
+    data T :: Nat
+    instance KnownNat T
+
+That says that any module satisfying M.hsig must provide a KnownNat
+instance for T.  We absolultely need that instance when compiling a
+module that imports M.hsig: see #15379 and
+Note [Fabricating Evidence for Literals in Backpack] in ClsInst.
+
+Hence, checkValidInstHead accepts a user-written instance declaration
+in hsig files, where `is_sig` is True.
+
+-}
+
+check_valid_inst_head :: DynFlags -> Bool -> Bool
+                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()
+-- Wow!  There are a surprising number of ad-hoc special cases here.
+check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
+
+  -- If not in an hs-boot file, abstract classes cannot have instances
+  | isAbstractClass clas
+  , not is_boot
+  = failWithTc abstract_class_msg
+
+  -- For Typeable, don't complain about instances for
+  -- standalone deriving; they are no-ops, and we warn about
+  -- it in TcDeriv.deriveStandalone.
+  | clas_nm == typeableClassName
+  , not is_sig
+    -- Note [Instances of built-in classes in signature files]
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- Handwritten instances of KnownNat/KnownSymbol class
+  -- are always forbidden (#12837)
+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]
+  , not is_sig
+    -- Note [Instances of built-in classes in signature files]
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- For the most part we don't allow
+  -- instances for (~), (~~), or Coercible;
+  -- but we DO want to allow them in quantified constraints:
+  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...
+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]
+  , not quantified_constraint
+  = failWithTc rejected_class_msg
+
+  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
+  | clas_nm `elem` genericClassNames
+  , hand_written_bindings
+  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err
+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
+
+  | clas_nm == hasFieldClassName
+  = checkHasFieldInst clas cls_args
+
+  | isCTupleClass clas
+  = failWithTc tuple_class_msg
+
+  -- Check language restrictions on the args to the class
+  | check_h98_arg_shape
+  , Just msg <- mb_ty_args_msg
+  = failWithTc (instTypeErr clas cls_args msg)
+
+  | otherwise
+  = checkValidTypePats (classTyCon clas) cls_args
+  where
+    clas_nm = getName clas
+    ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
+
+    hand_written_bindings
+        = case ctxt of
+            InstDeclCtxt stand_alone -> not stand_alone
+            SpecInstCtxt             -> False
+            DerivClauseCtxt          -> False
+            _                        -> True
+
+    check_h98_arg_shape = case ctxt of
+                            SpecInstCtxt    -> False
+                            DerivClauseCtxt -> False
+                            SigmaCtxt       -> False
+                            _               -> True
+        -- SigmaCtxt: once we are in quantified-constraint land, we
+        -- aren't so picky about enforcing H98-language restrictions
+        -- E.g. we want to allow a head like Coercible (m a) (m b)
+
+
+    -- When we are looking at the head of a quantified constraint,
+    -- check_quant_pred sets ctxt to SigmaCtxt
+    quantified_constraint = case ctxt of
+                              SigmaCtxt -> True
+                              _         -> False
+
+    head_type_synonym_msg = parens (
+                text "All instance types must be of the form (T t1 ... tn)" $$
+                text "where T is not a synonym." $$
+                text "Use TypeSynonymInstances if you want to disable this.")
+
+    head_type_args_tyvars_msg = parens (vcat [
+                text "All instance types must be of the form (T a1 ... an)",
+                text "where a1 ... an are *distinct type variables*,",
+                text "and each type variable appears at most once in the instance head.",
+                text "Use FlexibleInstances if you want to disable this."])
+
+    head_one_type_msg = parens $
+                        text "Only one type can be given in an instance head." $$
+                        text "Use MultiParamTypeClasses if you want to allow more, or zero."
+
+    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)
+                         <+> text "does not support user-specified instances"
+    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"
+
+    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")
+
+    abstract_class_msg = text "Cannot define instance for abstract class"
+                         <+> quotes (ppr clas_nm)
+
+    mb_ty_args_msg
+      | not (xopt LangExt.TypeSynonymInstances dflags)
+      , not (all tcInstHeadTyNotSynonym ty_args)
+      = Just head_type_synonym_msg
+
+      | not (xopt LangExt.FlexibleInstances dflags)
+      , not (all tcInstHeadTyAppAllTyVars ty_args)
+      = Just head_type_args_tyvars_msg
+
+      | length ty_args /= 1
+      , not (xopt LangExt.MultiParamTypeClasses dflags)
+      , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)
+      = Just head_one_type_msg
+
+      | otherwise
+      = Nothing
+
+tcInstHeadTyNotSynonym :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must not be type synonyms, but everywhere else type synonyms
+-- are transparent, so we need a special function here
+tcInstHeadTyNotSynonym ty
+  = case ty of  -- Do not use splitTyConApp,
+                -- because that expands synonyms!
+        TyConApp tc _ -> not (isTypeSynonymTyCon tc)
+        _ -> True
+
+tcInstHeadTyAppAllTyVars :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must be a constructor applied to type variable arguments
+-- or a type-level literal.
+-- But we allow kind instantiations.
+tcInstHeadTyAppAllTyVars ty
+  | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)
+  = ok (filterOutInvisibleTypes tc tys)  -- avoid kinds
+  | LitTy _ <- ty = True  -- accept type literals (#13833)
+  | otherwise
+  = False
+  where
+        -- Check that all the types are type variables,
+        -- and that each is distinct
+    ok tys = equalLength tvs tys && hasNoDups tvs
+           where
+             tvs = mapMaybe tcGetTyVar_maybe tys
+
+dropCasts :: Type -> Type
+-- See Note [Casts during validity checking]
+-- This function can turn a well-kinded type into an ill-kinded
+-- one, so I've kept it local to this module
+-- To consider: drop only HoleCo casts
+dropCasts (CastTy ty _)       = dropCasts ty
+dropCasts (AppTy t1 t2)       = mkAppTy (dropCasts t1) (dropCasts t2)
+dropCasts ty@(FunTy _ t1 t2)  = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 }
+dropCasts (TyConApp tc tys)   = mkTyConApp tc (map dropCasts tys)
+dropCasts (ForAllTy b ty)     = ForAllTy (dropCastsB b) (dropCasts ty)
+dropCasts ty                  = ty  -- LitTy, TyVarTy, CoercionTy
+
+dropCastsB :: TyVarBinder -> TyVarBinder
+dropCastsB b = b   -- Don't bother in the kind of a forall
+
+instTypeErr :: Class -> [Type] -> SDoc -> SDoc
+instTypeErr cls tys msg
+  = hang (hang (text "Illegal instance declaration for")
+             2 (quotes (pprClassPred cls tys)))
+       2 msg
+
+-- | See Note [Validity checking of HasField instances]
+checkHasFieldInst :: Class -> [Type] -> TcM ()
+checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
+  case splitTyConApp_maybe r_ty of
+    Nothing -> whoops (text "Record data type must be specified")
+    Just (tc, _)
+      | isFamilyTyCon tc
+                  -> whoops (text "Record data type may not be a data family")
+      | otherwise -> case isStrLitTy x_ty of
+       Just lbl
+         | isJust (lookupTyConFieldLabel lbl tc)
+                     -> whoops (ppr tc <+> text "already has a field"
+                                       <+> quotes (ppr lbl))
+         | otherwise -> return ()
+       Nothing
+         | null (tyConFieldLabels tc) -> return ()
+         | otherwise -> whoops (ppr tc <+> text "has fields")
+  where
+    whoops = addErrTc . instTypeErr cls tys
+checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
+
+{- Note [Casts during validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the (bogus)
+     instance Eq Char#
+We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an
+insoluble equality constraint for * ~ #.  We'll report the insoluble
+constraint separately, but we don't want to *also* complain that Eq is
+not applied to a type constructor.  So we look gaily look through
+CastTys here.
+
+Another example:  Eq (Either a).  Then we actually get a cast in
+the middle:
+   Eq ((Either |> g) a)
+
+
+Note [Validity checking of HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The HasField class has magic constraint solving behaviour (see Note
+[HasField instances] in TcInteract).  However, we permit users to
+declare their own instances, provided they do not clash with the
+built-in behaviour.  In particular, we forbid:
+
+  1. `HasField _ r _` where r is a variable
+
+  2. `HasField _ (T ...) _` if T is a data family
+     (because it might have fields introduced later)
+
+  3. `HasField x (T ...) _` where x is a variable,
+      if T has any fields at all
+
+  4. `HasField "foo" (T ...) _` if T has a "foo" field
+
+The usual functional dependency checks also apply.
+
+
+Note [Valid 'deriving' predicate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+validDerivPred checks for OK 'deriving' context.  See Note [Exotic
+derived instance contexts] in TcDeriv.  However the predicate is
+here because it uses sizeTypes, fvTypes.
+
+It checks for three things
+
+  * No repeated variables (hasNoDups fvs)
+
+  * No type constructors.  This is done by comparing
+        sizeTypes tys == length (fvTypes tys)
+    sizeTypes counts variables and constructors; fvTypes returns variables.
+    So if they are the same, there must be no constructors.  But there
+    might be applications thus (f (g x)).
+
+    Note that tys only includes the visible arguments of the class type
+    constructor. Including the non-visible arguments can cause the following,
+    perfectly valid instance to be rejected:
+       class Category (cat :: k -> k -> *) where ...
+       newtype T (c :: * -> * -> *) a b = MkT (c a b)
+       instance Category c => Category (T c) where ...
+    since the first argument to Category is a non-visible *, which sizeTypes
+    would count as a constructor! See #11833.
+
+  * Also check for a bizarre corner case, when the derived instance decl
+    would look like
+       instance C a b => D (T a) where ...
+    Note that 'b' isn't a parameter of T.  This gives rise to all sorts of
+    problems; in particular, it's hard to compare solutions for equality
+    when finding the fixpoint, and that means the inferContext loop does
+    not converge.  See #5287.
+
+Note [Equality class instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We can't have users writing instances for the equality classes. But we
+still need to be able to write instances for them ourselves. So we allow
+instances only in the defining module.
+
+-}
+
+validDerivPred :: TyVarSet -> PredType -> Bool
+-- See Note [Valid 'deriving' predicate]
+validDerivPred tv_set pred
+  = case classifyPredType pred of
+       ClassPred cls tys -> cls `hasKey` typeableClassKey
+                -- Typeable constraints are bigger than they appear due
+                -- to kind polymorphism, but that's OK
+                       || check_tys cls tys
+       EqPred {}       -> False  -- reject equality constraints
+       _               -> True   -- Non-class predicates are ok
+  where
+    check_tys cls tys
+              = hasNoDups fvs
+                   -- use sizePred to ignore implicit args
+                && lengthIs fvs (sizePred pred)
+                && all (`elemVarSet` tv_set) fvs
+      where tys' = filterOutInvisibleTypes (classTyCon cls) tys
+            fvs  = fvTypes tys'
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Checking instance for termination}
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Instances and constraint synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, we don't allow instances for constraint synonyms at all.
+Consider these (#13267):
+  type C1 a = Show (a -> Bool)
+  instance C1 Int where    -- I1
+    show _ = "ur"
+
+This elicits "show is not a (visible) method of class C1", which isn't
+a great message. But it comes from the renamer, so it's hard to improve.
+
+This needs a bit more care:
+  type C2 a = (Show a, Show Int)
+  instance C2 Int           -- I2
+
+If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose
+the instance head, we'll expand the synonym on fly, and it'll look like
+  instance (%,%) (Show Int, Show Int)
+and we /really/ don't want that.  So we carefully do /not/ expand
+synonyms, by matching on TyConApp directly.
+-}
+
+checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
+checkValidInstance ctxt hs_type ty
+  | not is_tc_app
+  = failWithTc (hang (text "Instance head is not headed by a class:")
+                   2 ( ppr tau))
+
+  | isNothing mb_cls
+  = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)
+                     , text "A class instance must be for a class" ])
+
+  | not arity_ok
+  = failWithTc (text "Arity mis-match in instance head")
+
+  | otherwise
+  = do  { setSrcSpan head_loc $
+          checkValidInstHead ctxt clas inst_tys
+
+        ; traceTc "checkValidInstance {" (ppr ty)
+
+        ; env0 <- tcInitTidyEnv
+        ; expand <- initialExpandMode
+        ; check_valid_theta env0 ctxt expand theta
+
+        -- The Termination and Coverate Conditions
+        -- Check that instance inference will terminate (if we care)
+        -- For Haskell 98 this will already have been done by checkValidTheta,
+        -- but as we may be using other extensions we need to check.
+        --
+        -- Note that the Termination Condition is *more conservative* than
+        -- the checkAmbiguity test we do on other type signatures
+        --   e.g.  Bar a => Bar Int is ambiguous, but it also fails
+        --   the termination condition, because 'a' appears more often
+        --   in the constraint than in the head
+        ; undecidable_ok <- xoptM LangExt.UndecidableInstances
+        ; if undecidable_ok
+          then checkAmbiguity ctxt ty
+          else checkInstTermination theta tau
+
+        ; traceTc "cvi 2" (ppr ty)
+
+        ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
+            IsValid      -> return ()   -- Check succeeded
+            NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
+
+        ; traceTc "End checkValidInstance }" empty
+
+        ; return () }
+  where
+    (_tvs, theta, tau)   = tcSplitSigmaTy ty
+    is_tc_app            = case tau of { TyConApp {} -> True; _ -> False }
+    TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]
+    mb_cls               = tyConClass_maybe tc
+    Just clas            = mb_cls
+    arity_ok             = inst_tys `lengthIs` classArity clas
+
+        -- The location of the "head" of the instance
+    head_loc = getLoc (getLHsInstDeclHead hs_type)
+
+{-
+Note [Paterson conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Termination test: the so-called "Paterson conditions" (see Section 5 of
+"Understanding functional dependencies via Constraint Handling Rules,
+JFP Jan 2007).
+
+We check that each assertion in the context satisfies:
+ (1) no variable has more occurrences in the assertion than in the head, and
+ (2) the assertion has fewer constructors and variables (taken together
+     and counting repetitions) than the head.
+This is only needed with -fglasgow-exts, as Haskell 98 restrictions
+(which have already been checked) guarantee termination.
+
+The underlying idea is that
+
+    for any ground substitution, each assertion in the
+    context has fewer type constructors than the head.
+-}
+
+checkInstTermination :: ThetaType -> TcPredType -> TcM ()
+-- See Note [Paterson conditions]
+checkInstTermination theta head_pred
+  = check_preds emptyVarSet theta
+  where
+   head_fvs  = fvType head_pred
+   head_size = sizeType head_pred
+
+   check_preds :: VarSet -> [PredType] -> TcM ()
+   check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds
+
+   check :: VarSet -> PredType -> TcM ()
+   check foralld_tvs pred
+     = case classifyPredType pred of
+         EqPred {}    -> return ()  -- See #4200.
+         IrredPred {} -> check2 foralld_tvs pred (sizeType pred)
+         ClassPred cls tys
+           | isTerminatingClass cls
+           -> return ()
+
+           | isCTupleClass cls  -- Look inside tuple predicates; #8359
+           -> check_preds foralld_tvs tys
+
+           | otherwise          -- Other ClassPreds
+           -> check2 foralld_tvs pred bogus_size
+           where
+              bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys)
+                               -- See Note [Invisible arguments and termination]
+
+         ForAllPred tvs _ head_pred'
+           -> check (foralld_tvs `extendVarSetList` binderVars tvs) head_pred'
+              -- Termination of the quantified predicate itself is checked
+              -- when the predicates are individually checked for validity
+
+   check2 foralld_tvs pred pred_size
+     | not (null bad_tvs)     = failWithTc (noMoreMsg bad_tvs what (ppr head_pred))
+     | not (isTyFamFree pred) = failWithTc (nestedMsg what)
+     | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred))
+     | otherwise              = return ()
+     -- isTyFamFree: see Note [Type families in instance contexts]
+     where
+        what    = text "constraint" <+> quotes (ppr pred)
+        bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred)
+                  \\ head_fvs
+
+smallerMsg :: SDoc -> SDoc -> SDoc
+smallerMsg what inst_head
+  = vcat [ hang (text "The" <+> what)
+              2 (sep [ text "is no smaller than"
+                     , text "the instance head" <+> quotes inst_head ])
+         , parens undecidableMsg ]
+
+noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc
+noMoreMsg tvs what inst_head
+  = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1)
+                <+> occurs <+> text "more often")
+              2 (sep [ text "in the" <+> what
+                     , text "than in the instance head" <+> quotes inst_head ])
+         , parens undecidableMsg ]
+  where
+   tvs1   = nub tvs
+   occurs = if isSingleton tvs1 then text "occurs"
+                               else text "occur"
+
+undecidableMsg, constraintKindsMsg :: SDoc
+undecidableMsg     = text "Use UndecidableInstances to permit this"
+constraintKindsMsg = text "Use ConstraintKinds to permit this"
+
+{- Note [Type families in instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Are these OK?
+  type family F a
+  instance F a    => C (Maybe [a]) where ...
+  intance C (F a) => C [[[a]]]     where ...
+
+No: the type family in the instance head might blow up to an
+arbitrarily large type, depending on how 'a' is instantiated.
+So we require UndecidableInstances if we have a type family
+in the instance head.  #15172.
+
+Note [Invisible arguments and termination]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking the ​Paterson conditions for termination an instance
+declaration, we check for the number of "constructors and variables"
+in the instance head and constraints. Question: Do we look at
+
+ * All the arguments, visible or invisible?
+ * Just the visible arguments?
+
+I think both will ensure termination, provided we are consistent.
+Currently we are /not/ consistent, which is really a bug.  It's
+described in #15177, which contains a number of examples.
+The suspicious bits are the calls to filterOutInvisibleTypes.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+        Checking type instance well-formedness and termination
+*                                                                      *
+************************************************************************
+-}
+
+checkValidCoAxiom :: CoAxiom Branched -> TcM ()
+checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
+  = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list
+       ; foldlM_ check_branch_compat [] branch_list }
+  where
+    branch_list = fromBranches branches
+    injectivity = tyConInjectivityInfo fam_tc
+
+    check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order
+                        -> CoAxBranch      -- current branch
+                        -> TcM [CoAxBranch]-- current branch : previous branches
+    -- Check for
+    --   (a) this branch is dominated by previous ones
+    --   (b) failure of injectivity
+    check_branch_compat prev_branches cur_branch
+      | cur_branch `isDominatedBy` prev_branches
+      = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $
+             inaccessibleCoAxBranch fam_tc cur_branch
+           ; return prev_branches }
+      | otherwise
+      = do { check_injectivity prev_branches cur_branch
+           ; return (cur_branch : prev_branches) }
+
+     -- Injectivity check: check whether a new (CoAxBranch) can extend
+     -- already checked equations without violating injectivity
+     -- annotation supplied by the user.
+     -- See Note [Verifying injectivity annotation] in FamInstEnv
+    check_injectivity prev_branches cur_branch
+      | Injective inj <- injectivity
+      = do { let conflicts =
+                     fst $ foldl' (gather_conflicts inj prev_branches cur_branch)
+                                 ([], 0) prev_branches
+           ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
+                   (makeInjectivityErrors ax cur_branch inj conflicts) }
+      | otherwise
+      = return ()
+
+    gather_conflicts inj prev_branches cur_branch (acc, n) branch
+               -- n is 0-based index of branch in prev_branches
+      = case injectiveBranches inj cur_branch branch of
+          InjectivityUnified ax1 ax2
+            | ax1 `isDominatedBy` (replace_br prev_branches n ax2)
+                -> (acc, n + 1)
+            | otherwise
+                -> (branch : acc, n + 1)
+          InjectivityAccepted -> (acc, n + 1)
+
+    -- Replace n-th element in the list. Assumes 0-based indexing.
+    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
+    replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
+
+
+-- Check that a "type instance" is well-formed (which includes decidability
+-- unless -XUndecidableInstances is given).
+--
+checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
+checkValidCoAxBranch fam_tc
+                    (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+                                , cab_lhs = typats
+                                , cab_rhs = rhs, cab_loc = loc })
+  = setSrcSpan loc $
+    checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs
+
+-- | Do validity checks on a type family equation, including consistency
+-- with any enclosing class instance head, termination, and lack of
+-- polytypes.
+checkValidTyFamEqn :: TyCon   -- ^ of the type family
+                   -> [Var]   -- ^ Bound variables in the equation
+                   -> [Type]  -- ^ Type patterns
+                   -> Type    -- ^ Rhs
+                   -> TcM ()
+checkValidTyFamEqn fam_tc qvs typats rhs
+  = do { checkValidTypePats fam_tc typats
+
+         -- Check for things used on the right but not bound on the left
+       ; checkFamPatBinders fam_tc qvs typats rhs
+
+         -- Check for oversaturated visible kind arguments in a type family
+         -- equation.
+         -- See Note [Oversaturated type family equations]
+       ; when (isTypeFamilyTyCon fam_tc) $
+           case drop (tyConArity fam_tc) typats of
+             [] -> pure ()
+             spec_arg:_ ->
+               addErr $ text "Illegal oversaturated visible kind argument:"
+                    <+> quotes (char '@' <> pprParendType spec_arg)
+
+         -- The argument patterns, and RHS, are all boxed tau types
+         -- E.g  Reject type family F (a :: k1) :: k2
+         --             type instance F (forall a. a->a) = ...
+         --             type instance F Int#             = ...
+         --             type instance F Int              = forall a. a->a
+         --             type instance F Int              = Int#
+         -- See #9357
+       ; checkValidMonoType rhs
+
+         -- We have a decidable instance unless otherwise permitted
+       ; undecidable_ok <- xoptM LangExt.UndecidableInstances
+       ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs))
+       ; unless undecidable_ok $
+         mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }
+
+-- Make sure that each type family application is
+--   (1) strictly smaller than the lhs,
+--   (2) mentions no type variable more often than the lhs, and
+--   (3) does not contain any further type family instances.
+--
+checkFamInstRhs :: TyCon -> [Type]         -- LHS
+                -> [(TyCon, [Type])]       -- type family calls in RHS
+                -> [MsgDoc]
+checkFamInstRhs lhs_tc lhs_tys famInsts
+  = mapMaybe check famInsts
+  where
+   lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys
+   inst_head = pprType (TyConApp lhs_tc lhs_tys)
+   lhs_fvs   = fvTypes lhs_tys
+   check (tc, tys)
+      | not (all isTyFamFree tys) = Just (nestedMsg what)
+      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what inst_head)
+      | lhs_size <= fam_app_size  = Just (smallerMsg what inst_head)
+      | otherwise                 = Nothing
+      where
+        what = text "type family application"
+               <+> quotes (pprType (TyConApp tc tys))
+        fam_app_size = sizeTyConAppArgs tc tys
+        bad_tvs      = fvTypes tys \\ lhs_fvs
+                       -- The (\\) is list difference; e.g.
+                       --   [a,b,a,a] \\ [a,a] = [b,a]
+                       -- So we are counting repetitions
+
+-----------------
+checkFamPatBinders :: TyCon
+                   -> [TcTyVar]   -- Bound on LHS of family instance
+                   -> [TcType]    -- LHS patterns
+                   -> Type        -- RHS
+                   -> TcM ()
+-- We do these binder checks now, in tcFamTyPatsAndGen, rather
+-- than later, in checkValidFamEqn, for two reasons:
+--   - We have the implicitly and explicitly
+--     bound type variables conveniently to hand
+--   - If implicit variables are out of scope it may
+--     cause a crash; notably in tcConDecl in tcDataFamInstDecl
+checkFamPatBinders fam_tc qtvs pats rhs
+  = do { traceTc "checkFamPatBinders" $
+         vcat [ debugPprType (mkTyConApp fam_tc pats)
+              , ppr (mkTyConApp fam_tc pats)
+              , text "qtvs:" <+> ppr qtvs
+              , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)
+              , text "pat_tvs:" <+> ppr pat_tvs
+              , text "exact_pat_tvs:" <+> ppr exact_pat_tvs ]
+
+         -- Check for implicitly-bound tyvars, mentioned on the
+         -- RHS but not bound on the LHS
+         --    data T            = MkT (forall (a::k). blah)
+         --    data family D Int = MkD (forall (a::k). blah)
+         -- In both cases, 'k' is not bound on the LHS, but is used on the RHS
+         -- We catch the former in kcLHsQTyVars, and the latter right here
+         -- See Note [Check type-family instance binders]
+       ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")
+                               (text "bound on the LHS of")
+
+         -- Check for explicitly forall'd variable that is not bound on LHS
+         --    data instance forall a.  T Int = MkT Int
+         -- See Note [Unused explicitly bound variables in a family pattern]
+         -- See Note [Check type-family instance binders]
+       ; check_tvs bad_qtvs (text "bound by a forall")
+                            (text "used in")
+       }
+  where
+    pat_tvs       = tyCoVarsOfTypes pats
+    exact_pat_tvs = exactTyCoVarsOfTypes pats
+    rhs_fvs       = tyCoFVsOfType rhs
+    used_tvs      = pat_tvs `unionVarSet` fvVarSet rhs_fvs
+    bad_qtvs      = filterOut (`elemVarSet` used_tvs) qtvs
+                    -- Bound but not used at all
+    bad_rhs_tvs   = filterOut (`elemVarSet` exact_pat_tvs) (fvVarList rhs_fvs)
+                    -- Used on RHS but not bound on LHS
+    dodgy_tvs     = pat_tvs `minusVarSet` exact_pat_tvs
+
+    check_tvs tvs what what2
+      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $
+        hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs
+              <+> isOrAre tvs <+> what <> comma)
+           2 (vcat [ text "but not" <+> what2 <+> text "the family instance"
+                   , mk_extra tvs ])
+
+    -- mk_extra: #7536: give a decent error message for
+    --         type T a = Int
+    --         type instance F (T a) = a
+    mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $
+                   hang (text "The real LHS (expanding synonyms) is:")
+                      2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))
+
+
+-- | Checks that a list of type patterns is valid in a matching (LHS)
+-- position of a class instances or type/data family instance.
+--
+-- Specifically:
+--    * All monotypes
+--    * No type-family applications
+checkValidTypePats :: TyCon -> [Type] -> TcM ()
+checkValidTypePats tc pat_ty_args
+  = do { -- Check that each of pat_ty_args is a monotype.
+         -- One could imagine generalising to allow
+         --      instance C (forall a. a->a)
+         -- but we don't know what all the consequences might be.
+         traverse_ checkValidMonoType pat_ty_args
+
+       -- Ensure that no type family applications occur a type pattern
+       ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of
+            [] -> pure ()
+            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $
+               ty_fam_inst_illegal_err tf_is_invis_arg
+                                       (mkTyConApp tf_tc tf_args) }
+  where
+    inst_ty = mkTyConApp tc pat_ty_args
+
+    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
+    ty_fam_inst_illegal_err invis_arg ty
+      = pprWithExplicitKindsWhen invis_arg $
+        hang (text "Illegal type synonym family application"
+                <+> quotes (ppr ty) <+> text "in instance" <> colon)
+           2 (ppr inst_ty)
+
+-- Error messages
+
+inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
+inaccessibleCoAxBranch fam_tc cur_branch
+  = text "Type family instance equation is overlapped:" $$
+    nest 2 (pprCoAxBranchUser fam_tc cur_branch)
+
+nestedMsg :: SDoc -> SDoc
+nestedMsg what
+  = sep [ text "Illegal nested" <+> what
+        , parens undecidableMsg ]
+
+badATErr :: Name -> Name -> SDoc
+badATErr clas op
+  = hsep [text "Class", quotes (ppr clas),
+          text "does not have an associated type", quotes (ppr op)]
+
+
+-------------------------
+checkConsistentFamInst :: AssocInstInfo
+                       -> TyCon     -- ^ Family tycon
+                       -> CoAxBranch
+                       -> TcM ()
+-- See Note [Checking consistent instantiation]
+
+checkConsistentFamInst NotAssociated _ _
+  = return ()
+
+checkConsistentFamInst (InClsInst { ai_class = clas
+                                  , ai_tyvars = inst_tvs
+                                  , ai_inst_env = mini_env })
+                       fam_tc branch
+  = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs
+                                                , ppr arg_triples
+                                                , ppr mini_env
+                                                , ppr ax_tvs
+                                                , ppr ax_arg_tys
+                                                , ppr arg_triples ])
+       -- Check that the associated type indeed comes from this class
+       -- See [Mismatched class methods and associated type families]
+       -- in TcInstDecls.
+       ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)
+                 (badATErr (className clas) (tyConName fam_tc))
+
+       ; check_match arg_triples
+       }
+  where
+    (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch
+
+    arg_triples :: [(Type,Type, ArgFlag)]
+    arg_triples = [ (cls_arg_ty, at_arg_ty, vis)
+                  | (fam_tc_tv, vis, at_arg_ty)
+                       <- zip3 (tyConTyVars fam_tc)
+                               (tyConArgFlags fam_tc ax_arg_tys)
+                               ax_arg_tys
+                  , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ]
+
+    pp_wrong_at_arg vis
+      = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $
+        vcat [ text "Type indexes must match class instance head"
+             , text "Expected:" <+> pp_expected_ty
+             , text "  Actual:" <+> pp_actual_ty ]
+
+    -- Fiddling around to arrange that wildcards unconditionally print as "_"
+    -- We only need to print the LHS, not the RHS at all
+    -- See Note [Printing conflicts with class header]
+    (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs
+    (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs)
+
+    pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
+                     toIfaceTcArgs fam_tc $
+                     [ case lookupVarEnv mini_env at_tv of
+                         Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty
+                         Nothing         -> mk_wildcard at_tv
+                     | at_tv <- tyConTyVars fam_tc ]
+
+    pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
+                   toIfaceTcArgs fam_tc $
+                   tidyTypes tidy_env2 ax_arg_tys
+
+    mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv))
+    tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan
+
+    -- For check_match, bind_me, see
+    -- Note [Matching in the consistent-instantation check]
+    check_match :: [(Type,Type,ArgFlag)] -> TcM ()
+    check_match triples = go emptyTCvSubst emptyTCvSubst triples
+
+    go _ _ [] = return ()
+    go lr_subst rl_subst ((ty1,ty2,vis):triples)
+      | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2
+      , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1
+      = go lr_subst1 rl_subst1 triples
+      | otherwise
+      = addErrTc (pp_wrong_at_arg vis)
+
+    -- The /scoped/ type variables from the class-instance header
+    -- should not be alpha-renamed.  Inferred ones can be.
+    no_bind_set = mkVarSet inst_tvs
+    bind_me tv | tv `elemVarSet` no_bind_set = Skolem
+               | otherwise                   = BindMe
+
+
+{- Note [Check type-family instance binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a type family instance, we require (of course), type variables
+used on the RHS are matched on the LHS. This is checked by
+checkFamPatBinders.  Here is an interesting example:
+
+    type family   T :: k
+    type instance T = (Nothing :: Maybe a)
+
+Upon a cursory glance, it may appear that the kind variable `a` is
+free-floating above, since there are no (visible) LHS patterns in
+`T`. However, there is an *invisible* pattern due to the return kind,
+so inside of GHC, the instance looks closer to this:
+
+    type family T @k :: k
+    type instance T @(Maybe a) = (Nothing :: Maybe a)
+
+Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
+fact not unbound. Contrast that with this example (#13985)
+
+    type instance T = Proxy (Nothing :: Maybe a)
+
+This would looks like this inside of GHC:
+
+    type instance T @(*) = Proxy (Nothing :: Maybe a)
+
+So this time, `a` is neither bound by a visible nor invisible type pattern on
+the LHS, so it would be reported as free-floating.
+
+Finally, here's one more brain-teaser (from #9574). In the example below:
+
+    class Funct f where
+      type Codomain f :: *
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
+
+As it turns out, `o` is not free-floating in this example. That is because `o`
+bound by the kind signature of the LHS type pattern 'KProxy. To make this more
+obvious, one can also write the instance like so:
+
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
+
+
+Note [Matching in the consistent-instantation check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Matching the class-instance header to family-instance tyvars is
+tricker than it sounds.  Consider (#13972)
+    class C (a :: k) where
+      type T k :: Type
+    instance C Left where
+      type T (a -> Either a b) = Int
+
+Here there are no lexically-scoped variables from (C Left).
+Yet the real class-instance header is   C @(p -> Either @p @q)) (Left @p @q)
+while the type-family instance is       T (a -> Either @a @b)
+So we allow alpha-renaming of variables that don't come
+from the class-instance header.
+
+We track the lexically-scoped type variables from the
+class-instance header in ai_tyvars.
+
+Here's another example (#14045a)
+    class C (a :: k) where
+      data S (a :: k)
+    instance C (z :: Bool) where
+      data S :: Bool -> Type where
+
+Again, there is no lexical connection, but we will get
+   class-instance header:   C @Bool (z::Bool)
+   family instance          S @Bool (a::Bool)
+
+When looking for mis-matches, we check left-to-right,
+kinds first.  If we look at types first, we'll fail to
+suggest -fprint-explicit-kinds for a mis-match with
+      T @k    vs    T @Type
+somewhere deep inside the type
+
+Note [Checking consistent instantiation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #11450 for background discussion on this check.
+
+  class C a b where
+    type T a x b
+
+With this class decl, if we have an instance decl
+  instance C ty1 ty2 where ...
+then the type instance must look like
+     type T ty1 v ty2 = ...
+with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.
+For example:
+
+  instance C [p] Int
+    type T [p] y Int = (p,y,y)
+
+Note that
+
+* We used to allow completely different bound variables in the
+  associated type instance; e.g.
+    instance C [p] Int
+      type T [q] y Int = ...
+  But from GHC 8.2 onwards, we don't.  It's much simpler this way.
+  See #11450.
+
+* When the class variable isn't used on the RHS of the type instance,
+  it's tempting to allow wildcards, thus
+    instance C [p] Int
+      type T [_] y Int = (y,y)
+  But it's awkward to do the test, and it doesn't work if the
+  variable is repeated:
+    instance C (p,p) Int
+      type T (_,_) y Int = (y,y)
+  Even though 'p' is not used on the RHS, we still need to use 'p'
+  on the LHS to establish the repeated pattern.  So to keep it simple
+  we just require equality.
+
+* For variables in associated type families that are not bound by the class
+  itself, we do _not_ check if they are over-specific. In other words,
+  it's perfectly acceptable to have an instance like this:
+
+    instance C [p] Int where
+      type T [p] (Maybe x) Int = x
+
+  While the first and third arguments to T are required to be exactly [p] and
+  Int, respectively, since they are bound by C, the second argument is allowed
+  to be more specific than just a type variable. Furthermore, it is permissible
+  to define multiple equations for T that differ only in the non-class-bound
+  argument:
+
+    instance C [p] Int where
+      type T [p] (Maybe x)    Int = x
+      type T [p] (Either x y) Int = x -> y
+
+  We once considered requiring that non-class-bound variables in associated
+  type family instances be instantiated with distinct type variables. However,
+  that requirement proved too restrictive in practice, as there were examples
+  of extremely simple associated type family instances that this check would
+  reject, and fixing them required tiresome boilerplate in the form of
+  auxiliary type families. For instance, you would have to define the above
+  example as:
+
+    instance C [p] Int where
+      type T [p] x Int = CAux x
+
+    type family CAux x where
+      CAux (Maybe x)    = x
+      CAux (Either x y) = x -> y
+
+  We decided that this restriction wasn't buying us much, so we opted not
+  to pursue that design (see also GHC #13398).
+
+Implementation
+  * Form the mini-envt from the class type variables a,b
+    to the instance decl types [p],Int:   [a->[p], b->Int]
+
+  * Look at the tyvars a,x,b of the type family constructor T
+    (it shares tyvars with the class C)
+
+  * Apply the mini-evnt to them, and check that the result is
+    consistent with the instance types [p] y Int. (where y can be any type, as
+    it is not scoped over the class type variables.
+
+We make all the instance type variables scope over the
+type instances, of course, which picks up non-obvious kinds.  Eg
+   class Foo (a :: k) where
+      type F a
+   instance Foo (b :: k -> k) where
+      type F b = Int
+Here the instance is kind-indexed and really looks like
+      type F (k->k) (b::k->k) = Int
+But if the 'b' didn't scope, we would make F's instance too
+poly-kinded.
+
+Note [Printing conflicts with class header]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's remarkably painful to give a decent error message for conflicts
+with the class header.  Consider
+   clase C b where
+     type F a b c
+   instance C [b] where
+     type F x Int _ _ = ...
+
+Here we want to report a conflict between
+    Expected: F _ [b] _
+    Actual:   F x Int _ _
+
+But if the type instance shadows the class variable like this
+(rename/should_fail/T15828):
+   instance C [b] where
+     type forall b. F x (Tree b) _ _ = ...
+
+then we must use a fresh variable name
+    Expected: F _ [b] _
+    Actual:   F x [b1] _ _
+
+Notice that:
+  - We want to print an underscore in the "Expected" type in
+    positions where the class header has no influence over the
+    parameter.  Hence the fancy footwork in pp_expected_ty
+
+  - Although the binders in the axiom are aready tidy, we must
+    re-tidy them to get a fresh variable name when we shadow
+
+  - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the
+    class-instance variables a second time, from 'a' to 'a1' say.
+    Remember, the ax_tvs of the axiom share identity with the
+    class-instance variables, inst_tvs..
+
+  - We use tidyCoAxBndrsForUser to get underscores rather than
+    _1, _2, etc in the axiom tyvars; see the definition of
+    tidyCoAxBndrsForUser
+
+This all seems absurdly complicated.
+
+Note [Unused explicitly bound variables in a family pattern]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Why is 'unusedExplicitForAllErr' not just a warning?
+
+Consider the following examples:
+
+  type instance F a = Maybe b
+  type instance forall b. F a = Bool
+  type instance forall b. F a = Maybe b
+
+In every case, b is a type variable not determined by the LHS pattern. The
+first is caught by the renamer, but we catch the last two here. Perhaps one
+could argue that the second should be accepted, albeit with a warning, but
+consider the fact that in a type family instance, there is no way to interact
+with such a varable. At least with @x :: forall a. Int@ we can use visibile
+type application, like @x \@Bool 1@. (Of course it does nothing, but it is
+permissible.) In the type family case, the only sensible explanation is that
+the user has made a mistake -- thus we throw an error.
+
+Note [Oversaturated type family equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Type family tycons have very rigid arities. We want to reject something like
+this:
+
+  type family Foo :: Type -> Type where
+    Foo x = ...
+
+Because Foo has arity zero (i.e., it doesn't bind anything to the left of the
+double colon), we want to disallow any equation for Foo that has more than zero
+arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an
+equation has more arguments than the arity of the type family, reject.
+
+Things get trickier when visible kind application enters the picture. Consider
+the following example:
+
+  type family Bar (x :: j) :: forall k. Either j k where
+    Bar 5 @Symbol = ...
+
+The arity of Bar is two, since it binds two variables, `j` and `x`. But even
+though Bar's equation has two arguments, it's still invalid. Imagine the same
+equation in Core:
+
+    Bar Nat 5 Symbol = ...
+
+Here, it becomes apparent that Bar is actually taking /three/ arguments! So
+we can't just rely on a simple counting argument to reject
+`Bar 5 @Symbol = ...`, since it only has two user-written arguments.
+Moreover, there's one explicit argument (5) and one visible kind argument
+(@Symbol), which matches up perfectly with the fact that Bar has one required
+binder (x) and one specified binder (j), so that's not a valid way to detect
+oversaturation either.
+
+To solve this problem in a robust way, we do the following:
+
+1. When kind-checking, we count the number of user-written *required*
+   arguments and check if there is an equal number of required tycon binders.
+   If not, reject. (See `wrongNumberOfParmsErr` in TcTyClsDecls.)
+
+   We perform this step during kind-checking, not during validity checking,
+   since we can give better error messages if we catch it early.
+2. When validity checking, take all of the (Core) type patterns from on
+   equation, drop the first n of them (where n is the arity of the type family
+   tycon), and check if there are any types leftover. If so, reject.
+
+   Why does this work? We know that after dropping the first n type patterns,
+   none of the leftover types can be required arguments, since step (1) would
+   have already caught that. Moreover, the only places where visible kind
+   applications should be allowed are in the first n types, since those are the
+   only arguments that can correspond to binding forms. Therefore, the
+   remaining arguments must correspond to oversaturated uses of visible kind
+   applications, which are precisely what we want to reject.
+
+Note that we only perform this check for type families, and not for data
+families. This is because it is perfectly acceptable to oversaturate data
+family instance equations: see Note [Arity of data families] in FamInstEnv.
+
+************************************************************************
+*                                                                      *
+   Telescope checking
+*                                                                      *
+************************************************************************
+
+Note [Bad TyCon telescopes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Now that we can mix type and kind variables, there are an awful lot of
+ways to shoot yourself in the foot. Here are some.
+
+  data SameKind :: k -> k -> *   -- just to force unification
+
+1.  data T1 a k (b :: k) (x :: SameKind a b)
+
+The problem here is that we discover that a and b should have the same
+kind. But this kind mentions k, which is bound *after* a.
+(Testcase: dependent/should_fail/BadTelescope)
+
+2.  data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
+
+Note that b is not bound. Yet its kind mentions a. Because we have
+a nice rule that all implicitly bound variables come before others,
+this is bogus.
+
+To catch these errors, we call checkTyConTelescope during kind-checking
+datatype declarations.  This checks for
+
+* Ill-scoped binders. From (1) and (2) above we can get putative
+  kinds like
+       T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> *
+  where 'k' is mentioned a's kind before k is bound
+
+  This is easy to check for: just look for
+  out-of-scope variables in the kind
+
+* We should arguably also check for ambiguous binders
+  but we don't.  See Note [Ambiguous kind vars].
+
+See also
+  * Note [Required, Specified, and Inferred for types] in TcTyClsDecls.
+  * Note [Keeping scoped variables in order: Explicit] discusses how
+    this check works for `forall x y z.` written in a type.
+
+Note [Ambiguous kind vars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to be concerned about ambiguous binders. Suppose we have the kind
+     S1 :: forall k -> * -> *
+     S2 :: forall k. * -> *
+Here S1 is OK, because k is Required, and at a use of S1 we will
+see (S1 *) or (S1 (*->*)) or whatever.
+
+But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and
+we have no way (ever) to figure out how 'k' should be instantiated.
+For example if we see (S2 Int), that tells us nothing about k's
+instantiation.  (In this case we'll instantiate it to Any, but that
+seems wrong.)  This is really the same test as we make for ambiguous
+type in term type signatures.
+
+Now, it's impossible for a Specified variable not to occur
+at all in the kind -- after all, it is Specified so it must have
+occurred.  (It /used/ to be possible; see tests T13983 and T7873.  But
+with the advent of the forall-or-nothing rule for kind variables,
+those strange cases went away.)
+
+But one might worry about
+    type v k = *
+    S3 :: forall k. V k -> *
+which appears to mention 'k' but doesn't really.  Or
+    S4 :: forall k. F k -> *
+where F is a type function.  But we simply don't check for
+those cases of ambiguity, yet anyway.  The worst that can happen
+is ambiguity at the call sites.
+
+Historical note: this test used to be called reportFloatingKvs.
+-}
+
+-- | Check a list of binders to see if they make a valid telescope.
+-- See Note [Bad TyCon telescopes]
+type TelescopeAcc
+      = ( TyVarSet   -- Bound earlier in the telescope
+        , Bool       -- At least one binder occurred (in a kind) before
+                     -- it was bound in the telescope.  E.g.
+        )            --    T :: forall (a::k) k. blah
+
+checkTyConTelescope :: TyCon -> TcM ()
+checkTyConTelescope tc
+  | bad_scope
+  = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]
+    addErr $
+    vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")
+              2 pp_tc_kind
+         , extra
+         , hang (text "Perhaps try this order instead:")
+              2 (pprTyVars sorted_tvs) ]
+
+  | otherwise
+  = return ()
+  where
+    tcbs = tyConBinders tc
+    tvs  = binderVars tcbs
+    sorted_tvs = scopedSort tvs
+
+    (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs
+
+    add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc
+    add_one (bound, bad_scope) tcb
+      = ( bound `extendVarSet` tv
+        , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) )
+      where
+        tv = binderVar tcb
+        fkvs = tyCoVarsOfType (tyVarKind tv)
+
+    inferred_tvs  = [ binderVar tcb
+                    | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ]
+    specified_tvs = [ binderVar tcb
+                    | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ]
+
+    pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)
+    pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)
+
+    pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)
+    ppr_untidy ty = pprIfaceType (toIfaceType ty)
+      -- We need ppr_untidy here because pprType will tidy the type, which
+      -- will turn the bogus kind we are trying to report
+      --     T :: forall (a::k) k (b::k) -> blah
+      -- into a misleadingly sanitised version
+      --     T :: forall (a::k) k1 (b::k1) -> blah
+
+    extra
+      | null inferred_tvs && null specified_tvs
+      = empty
+      | null inferred_tvs
+      = hang (text "NB: Specified variables")
+           2 (sep [pp_spec, text "always come first"])
+      | null specified_tvs
+      = hang (text "NB: Inferred variables")
+           2 (sep [pp_inf, text "always come first"])
+      | otherwise
+      = hang (text "NB: Inferred variables")
+           2 (vcat [ sep [ pp_inf, text "always come first"]
+                   , sep [text "then Specified variables", pp_spec]])
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Auxiliary functions}
+*                                                                      *
+************************************************************************
+-}
+
+-- Free variables of a type, retaining repetitions, and expanding synonyms
+-- This ignores coercions, as coercions aren't user-written
+fvType :: Type -> [TyCoVar]
+fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
+fvType (TyVarTy tv)          = [tv]
+fvType (TyConApp _ tys)      = fvTypes tys
+fvType (LitTy {})            = []
+fvType (AppTy fun arg)       = fvType fun ++ fvType arg
+fvType (FunTy _ arg res)     = fvType arg ++ fvType res
+fvType (ForAllTy (Bndr tv _) ty)
+  = fvType (tyVarKind tv) ++
+    filter (/= tv) (fvType ty)
+fvType (CastTy ty _)         = fvType ty
+fvType (CoercionTy {})       = []
+
+fvTypes :: [Type] -> [TyVar]
+fvTypes tys                = concat (map fvType tys)
+
+sizeType :: Type -> Int
+-- Size of a type: the number of variables and constructors
+sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
+sizeType (TyVarTy {})      = 1
+sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys
+sizeType (LitTy {})        = 1
+sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
+sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1
+sizeType (ForAllTy _ ty)   = sizeType ty
+sizeType (CastTy ty _)     = sizeType ty
+sizeType (CoercionTy _)    = 0
+
+sizeTypes :: [Type] -> Int
+sizeTypes = foldr ((+) . sizeType) 0
+
+sizeTyConAppArgs :: TyCon -> [Type] -> Int
+sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)
+                           -- See Note [Invisible arguments and termination]
+
+-- Size of a predicate
+--
+-- We are considering whether class constraints terminate.
+-- Equality constraints and constraints for the implicit
+-- parameter class always terminate so it is safe to say "size 0".
+-- See #4200.
+sizePred :: PredType -> Int
+sizePred ty = goClass ty
+  where
+    goClass p = go (classifyPredType p)
+
+    go (ClassPred cls tys')
+      | isTerminatingClass cls = 0
+      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')
+                    -- The filtering looks bogus
+                    -- See Note [Invisible arguments and termination]
+    go (EqPred {})           = 0
+    go (IrredPred ty)        = sizeType ty
+    go (ForAllPred _ _ pred) = goClass pred
+
+-- | When this says "True", ignore this class constraint during
+-- a termination check
+isTerminatingClass :: Class -> Bool
+isTerminatingClass cls
+  = isIPClass cls    -- Implicit parameter constraints always terminate because
+                     -- there are no instances for them --- they are only solved
+                     -- by "local instances" in expressions
+    || isEqPredClass cls
+    || cls `hasKey` typeableClassKey
+    || cls `hasKey` coercibleTyConKey
+
+-- | Tidy before printing a type
+ppr_tidy :: TidyEnv -> Type -> SDoc
+ppr_tidy env ty = pprType (tidyType env ty)
+
+allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool
+-- (allDistinctTyVars tvs tys) returns True if tys are
+-- a) all tyvars
+-- b) all distinct
+-- c) disjoint from tvs
+allDistinctTyVars _    [] = True
+allDistinctTyVars tkvs (ty : tys)
+  = case getTyVar_maybe ty of
+      Nothing -> False
+      Just tv | tv `elemVarSet` tkvs -> False
+              | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys
diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/AsmUtils.hs
@@ -0,0 +1,20 @@
+-- | Various utilities used in generating assembler.
+--
+-- These are used not only by the native code generator, but also by the
+-- "DriverPipeline".
+module AsmUtils
+    ( sectionType
+    ) where
+
+import GhcPrelude
+
+import Platform
+import Outputable
+
+-- | Generate a section type (e.g. @\@progbits@). See #13937.
+sectionType :: String -- ^ section type
+            -> SDoc   -- ^ pretty assembler fragment
+sectionType ty = sdocWithPlatform $ \platform ->
+    case platformArch platform of
+      ArchARM{} -> char '%' <> text ty
+      _         -> char '@' <> text ty
diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphBase.hs
@@ -0,0 +1,107 @@
+
+-- | Types for the general graph colorer.
+module GraphBase (
+        Triv,
+        Graph (..),
+        initGraph,
+        graphMapModify,
+
+        Node  (..),     newNode,
+)
+
+
+where
+
+import GhcPrelude
+
+import UniqSet
+import UniqFM
+
+
+-- | A fn to check if a node is trivially colorable
+--      For graphs who's color classes are disjoint then a node is 'trivially colorable'
+--      when it has less neighbors and exclusions than available colors for that node.
+--
+--      For graph's who's color classes overlap, ie some colors alias other colors, then
+--      this can be a bit more tricky. There is a general way to calculate this, but
+--      it's likely be too slow for use in the code. The coloring algorithm takes
+--      a canned function which can be optimised by the user to be specific to the
+--      specific graph being colored.
+--
+--      for details, see  "A Generalised Algorithm for Graph-Coloring Register Allocation"
+--                              Smith, Ramsey, Holloway - PLDI 2004.
+--
+type Triv k cls color
+        =  cls                  -- the class of the node we're trying to color.
+        -> UniqSet k            -- the node's neighbors.
+        -> UniqSet color        -- the node's exclusions.
+        -> Bool
+
+
+-- | The Interference graph.
+--      There used to be more fields, but they were turfed out in a previous revision.
+--      maybe we'll want more later..
+--
+data Graph k cls color
+        = Graph {
+        -- | All active nodes in the graph.
+          graphMap              :: UniqFM (Node k cls color)  }
+
+
+-- | An empty graph.
+initGraph :: Graph k cls color
+initGraph
+        = Graph
+        { graphMap              = emptyUFM }
+
+
+-- | Modify the finite map holding the nodes in the graph.
+graphMapModify
+        :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))
+        -> Graph k cls color -> Graph k cls color
+
+graphMapModify f graph
+        = graph { graphMap      = f (graphMap graph) }
+
+
+
+-- | Graph nodes.
+--      Represents a thing that can conflict with another thing.
+--      For the register allocater the nodes represent registers.
+--
+data Node k cls color
+        = Node {
+        -- | A unique identifier for this node.
+          nodeId                :: k
+
+        -- | The class of this node,
+        --      determines the set of colors that can be used.
+        , nodeClass             :: cls
+
+        -- | The color of this node, if any.
+        , nodeColor             :: Maybe color
+
+        -- | Neighbors which must be colored differently to this node.
+        , nodeConflicts         :: UniqSet k
+
+        -- | Colors that cannot be used by this node.
+        , nodeExclusions        :: UniqSet color
+
+        -- | Colors that this node would prefer to be, in decending order.
+        , nodePreference        :: [color]
+
+        -- | Neighbors that this node would like to be colored the same as.
+        , nodeCoalesce          :: UniqSet k }
+
+
+-- | An empty node.
+newNode :: k -> cls -> Node k cls color
+newNode k cls
+        = Node
+        { nodeId                = k
+        , nodeClass             = cls
+        , nodeColor             = Nothing
+        , nodeConflicts         = emptyUniqSet
+        , nodeExclusions        = emptyUniqSet
+        , nodePreference        = []
+        , nodeCoalesce          = emptyUniqSet }
diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphColor.hs
@@ -0,0 +1,373 @@
+-- | Graph Coloring.
+--      This is a generic graph coloring library, abstracted over the type of
+--      the node keys, nodes and colors.
+--
+
+module GraphColor (
+        module GraphBase,
+        module GraphOps,
+        module GraphPpr,
+        colorGraph
+)
+
+where
+
+import GhcPrelude
+
+import GraphBase
+import GraphOps
+import GraphPpr
+
+import Unique
+import UniqFM
+import UniqSet
+import Outputable
+
+import Data.Maybe
+import Data.List
+
+
+-- | Try to color a graph with this set of colors.
+--      Uses Chaitin's algorithm to color the graph.
+--      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
+--      are pushed onto a stack and removed from the graph.
+--      Once this process is complete the graph can be colored by removing nodes from
+--      the stack (ie in reverse order) and assigning them colors different to their neighbors.
+--
+colorGraph
+        :: ( Uniquable  k, Uniquable cls,  Uniquable  color
+           , Eq cls, Ord k
+           , Outputable k, Outputable cls, Outputable color)
+        => Bool                         -- ^ whether to do iterative coalescing
+        -> Int                          -- ^ how many times we've tried to color this graph so far.
+        -> UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+        -> Graph  k cls color           -- ^ the graph to color.
+
+        -> ( Graph k cls color          -- the colored graph.
+           , UniqSet k                  -- the set of nodes that we couldn't find a color for.
+           , UniqFM  k )                -- map of regs (r1 -> r2) that were coalesced
+                                        --       r1 should be replaced by r2 in the source
+
+colorGraph iterative spinCount colors triv spill graph0
+ = let
+        -- If we're not doing iterative coalescing then do an aggressive coalescing first time
+        --      around and then conservative coalescing for subsequent passes.
+        --
+        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
+        --      there is a lot of register pressure and we do it on every round then it can make the
+        --      graph less colorable and prevent the algorithm from converging in a sensible number
+        --      of cycles.
+        --
+        (graph_coalesced, kksCoalesce1)
+         = if iterative
+                then (graph0, [])
+                else if spinCount == 0
+                        then coalesceGraph True  triv graph0
+                        else coalesceGraph False triv graph0
+
+        -- run the scanner to slurp out all the trivially colorable nodes
+        --      (and do coalescing if iterative coalescing is enabled)
+        (ksTriv, ksProblems, kksCoalesce2)
+                = colorScan iterative triv spill graph_coalesced
+
+        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
+        --      We need to apply all the coalescences found by the scanner to the original
+        --      graph before doing assignColors.
+        --
+        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalecing
+        --      to force all the (conservative) coalescences found during scanning.
+        --
+        (graph_scan_coalesced, _)
+                = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
+
+        -- color the trivially colorable nodes
+        --      during scanning, keys of triv nodes were added to the front of the list as they were found
+        --      this colors them in the reverse order, as required by the algorithm.
+        (graph_triv, ksNoTriv)
+                = assignColors colors graph_scan_coalesced ksTriv
+
+        -- try and color the problem nodes
+        --      problem nodes are the ones that were left uncolored because they weren't triv.
+        --      theres a change we can color them here anyway.
+        (graph_prob, ksNoColor)
+                = assignColors colors graph_triv ksProblems
+
+        -- if the trivially colorable nodes didn't color then something is probably wrong
+        --      with the provided triv function.
+        --
+   in   if not $ null ksNoTriv
+         then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
+                        (  empty
+                        $$ text "ksTriv    = " <> ppr ksTriv
+                        $$ text "ksNoTriv  = " <> ppr ksNoTriv
+                        $$ text "colors    = " <> ppr colors
+                        $$ empty
+                        $$ dotGraph (\_ -> text "white") triv graph_triv)
+
+         else   ( graph_prob
+                , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)
+                , if iterative
+                        then (listToUFM kksCoalesce2)
+                        else (listToUFM kksCoalesce1))
+
+
+-- | Scan through the conflict graph separating out trivially colorable and
+--      potentially uncolorable (problem) nodes.
+--
+--      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
+--      so after a triv node is found and removed from the graph it's no good to return to the 'start'
+--      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
+--
+--      To ward against this, during each pass through the graph we collect up a list of triv nodes
+--      that were found, and only remove them once we've finished the pass. The more nodes we can delete
+--      at once the more likely it is that nodes we've already checked will become trivially colorable
+--      for the next pass.
+--
+--      TODO:   add work lists to finding triv nodes is easier.
+--              If we've just scanned the graph, and removed triv nodes, then the only
+--              nodes that we need to rescan are the ones we've removed edges from.
+
+colorScan
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool                         -- ^ whether to do iterative coalescing
+        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+        -> Graph k cls color            -- ^ the graph to scan
+
+        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce
+
+colorScan iterative triv spill graph
+        = colorScan_spin iterative triv spill graph [] [] []
+
+colorScan_spin
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool
+        -> Triv k cls color
+        -> (Graph k cls color -> k)
+        -> Graph k cls color
+        -> [k]
+        -> [k]
+        -> [(k, k)]
+        -> ([k], [k], [(k, k)])
+
+colorScan_spin iterative triv spill graph
+        ksTriv ksSpill kksCoalesce
+
+        -- if the graph is empty then we're done
+        | isNullUFM $ graphMap graph
+        = (ksTriv, ksSpill, reverse kksCoalesce)
+
+        -- Simplify:
+        --      Look for trivially colorable nodes.
+        --      If we can find some then remove them from the graph and go back for more.
+        --
+        | nsTrivFound@(_:_)
+                <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+
+                                  -- for iterative coalescing we only want non-move related
+                                  --    nodes here
+                                  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
+                        $ graph
+
+        , ksTrivFound   <- map nodeId nsTrivFound
+        , graph2        <- foldr (\k g -> let Just g' = delNode k g
+                                          in  g')
+                                graph ksTrivFound
+
+        = colorScan_spin iterative triv spill graph2
+                (ksTrivFound ++ ksTriv)
+                ksSpill
+                kksCoalesce
+
+        -- Coalesce:
+        --      If we're doing iterative coalescing and no triv nodes are available
+        --      then it's time for a coalescing pass.
+        | iterative
+        = case coalesceGraph False triv graph of
+
+                -- we were able to coalesce something
+                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
+                (graph2, kksCoalesceFound@(_:_))
+                 -> colorScan_spin iterative triv spill graph2
+                        ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
+
+                -- Freeze:
+                -- nothing could be coalesced (or was triv),
+                --      time to choose a node to freeze and give up on ever coalescing it.
+                (graph2, [])
+                 -> case freezeOneInGraph graph2 of
+
+                        -- we were able to freeze something
+                        --      hopefully this will free up something for Simplify
+                        (graph3, True)
+                         -> colorScan_spin iterative triv spill graph3
+                                ksTriv ksSpill kksCoalesce
+
+                        -- we couldn't find something to freeze either
+                        --      time for a spill
+                        (graph3, False)
+                         -> colorScan_spill iterative triv spill graph3
+                                ksTriv ksSpill kksCoalesce
+
+        -- spill time
+        | otherwise
+        = colorScan_spill iterative triv spill graph
+                ksTriv ksSpill kksCoalesce
+
+
+-- Select:
+-- we couldn't find any triv nodes or things to freeze or coalesce,
+--      and the graph isn't empty yet.. We'll have to choose a spill
+--      candidate and leave it uncolored.
+--
+colorScan_spill
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool
+        -> Triv k cls color
+        -> (Graph k cls color -> k)
+        -> Graph k cls color
+        -> [k]
+        -> [k]
+        -> [(k, k)]
+        -> ([k], [k], [(k, k)])
+
+colorScan_spill iterative triv spill graph
+        ksTriv ksSpill kksCoalesce
+
+ = let  kSpill          = spill graph
+        Just graph'     = delNode kSpill graph
+   in   colorScan_spin iterative triv spill graph'
+                ksTriv (kSpill : ksSpill) kksCoalesce
+
+
+-- | Try to assign a color to all these nodes.
+
+assignColors
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Outputable cls)
+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Graph k cls color            -- ^ the graph
+        -> [k]                          -- ^ nodes to assign a color to.
+        -> ( Graph k cls color          -- the colored graph
+           , [k])                       -- the nodes that didn't color.
+
+assignColors colors graph ks
+        = assignColors' colors graph [] ks
+
+ where  assignColors' _ graph prob []
+                = (graph, prob)
+
+        assignColors' colors graph prob (k:ks)
+         = case assignColor colors k graph of
+
+                -- couldn't color this node
+                Nothing         -> assignColors' colors graph (k : prob) ks
+
+                -- this node colored ok, so do the rest
+                Just graph'     -> assignColors' colors graph' prob ks
+
+
+        assignColor colors u graph
+                | Just c        <- selectColor colors graph u
+                = Just (setColor u c graph)
+
+                | otherwise
+                = Nothing
+
+
+
+-- | Select a color for a certain node
+--      taking into account preferences, neighbors and exclusions.
+--      returns Nothing if no color can be assigned to this node.
+--
+selectColor
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Outputable cls)
+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Graph k cls color            -- ^ the graph
+        -> k                            -- ^ key of the node to select a color for.
+        -> Maybe color
+
+selectColor colors graph u
+ = let  -- lookup the node
+        Just node       = lookupNode graph u
+
+        -- lookup the available colors for the class of this node.
+        colors_avail
+         = case lookupUFM colors (nodeClass node) of
+                Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
+                Just cs -> cs
+
+        -- find colors we can't use because they're already being used
+        --      by a node that conflicts with this one.
+        Just nsConflicts
+                        = sequence
+                        $ map (lookupNode graph)
+                        $ nonDetEltsUniqSet
+                        $ nodeConflicts node
+                        -- See Note [Unique Determinism and code generation]
+
+        colors_conflict = mkUniqSet
+                        $ catMaybes
+                        $ map nodeColor nsConflicts
+
+        -- the prefs of our neighbors
+        colors_neighbor_prefs
+                        = mkUniqSet
+                        $ concat $ map nodePreference nsConflicts
+
+        -- colors that are still valid for us
+        colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
+        colors_ok       = minusUniqSet colors_ok_ex colors_conflict
+
+        -- the colors that we prefer, and are still ok
+        colors_ok_pref  = intersectUniqSets
+                                (mkUniqSet $ nodePreference node) colors_ok
+
+        -- the colors that we could choose while being nice to our neighbors
+        colors_ok_nice  = minusUniqSet
+                                colors_ok colors_neighbor_prefs
+
+        -- the best of all possible worlds..
+        colors_ok_pref_nice
+                        = intersectUniqSets
+                                colors_ok_nice colors_ok_pref
+
+        -- make the decision
+        chooseColor
+
+                -- everyone is happy, yay!
+                | not $ isEmptyUniqSet colors_ok_pref_nice
+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
+                                        (nodePreference node)
+                = Just c
+
+                -- we've got one of our preferences
+                | not $ isEmptyUniqSet colors_ok_pref
+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)
+                                        (nodePreference node)
+                = Just c
+
+                -- it wasn't a preference, but it was still ok
+                | not $ isEmptyUniqSet colors_ok
+                , c : _         <- nonDetEltsUniqSet colors_ok
+                -- See Note [Unique Determinism and code generation]
+                = Just c
+
+                -- no colors were available for us this time.
+                --      looks like we're going around the loop again..
+                | otherwise
+                = Nothing
+
+   in   chooseColor
+
+
+
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphOps.hs
@@ -0,0 +1,680 @@
+-- | Basic operations on graphs.
+--
+
+module GraphOps (
+        addNode,        delNode,        getNode,       lookupNode,     modNode,
+        size,
+        union,
+        addConflict,    delConflict,    addConflicts,
+        addCoalesce,    delCoalesce,
+        addExclusion,   addExclusions,
+        addPreference,
+        coalesceNodes,  coalesceGraph,
+        freezeNode,     freezeOneInGraph, freezeAllInGraph,
+        scanGraph,
+        setColor,
+        validateGraph,
+        slurpNodeConflictCount
+)
+where
+
+import GhcPrelude
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List        hiding (union)
+import Data.Maybe
+
+-- | Lookup a node from the graph.
+lookupNode
+        :: Uniquable k
+        => Graph k cls color
+        -> k -> Maybe (Node  k cls color)
+
+lookupNode graph k
+        = lookupUFM (graphMap graph) k
+
+
+-- | Get a node from the graph, throwing an error if it's not there
+getNode
+        :: Uniquable k
+        => Graph k cls color
+        -> k -> Node k cls color
+
+getNode graph k
+ = case lookupUFM (graphMap graph) k of
+        Just node       -> node
+        Nothing         -> panic "ColorOps.getNode: not found"
+
+
+-- | Add a node to the graph, linking up its edges
+addNode :: Uniquable k
+        => k -> Node k cls color
+        -> Graph k cls color -> Graph k cls color
+
+addNode k node graph
+ = let
+        -- add back conflict edges from other nodes to this one
+        map_conflict =
+          nonDetFoldUniqSet
+            -- It's OK to use nonDetFoldUFM here because the
+            -- operation is commutative
+            (adjustUFM_C (\n -> n { nodeConflicts =
+                                      addOneToUniqSet (nodeConflicts n) k}))
+            (graphMap graph)
+            (nodeConflicts node)
+
+        -- add back coalesce edges from other nodes to this one
+        map_coalesce =
+          nonDetFoldUniqSet
+            -- It's OK to use nonDetFoldUFM here because the
+            -- operation is commutative
+            (adjustUFM_C (\n -> n { nodeCoalesce =
+                                      addOneToUniqSet (nodeCoalesce n) k}))
+            map_conflict
+            (nodeCoalesce node)
+
+  in    graph
+        { graphMap      = addToUFM map_coalesce k node}
+
+
+-- | Delete a node and all its edges from the graph.
+delNode :: (Uniquable k)
+        => k -> Graph k cls color -> Maybe (Graph k cls color)
+
+delNode k graph
+        | Just node     <- lookupNode graph k
+        = let   -- delete conflict edges from other nodes to this one.
+                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
+                        $ nonDetEltsUniqSet (nodeConflicts node)
+
+                -- delete coalesce edge from other nodes to this one.
+                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
+                        $ nonDetEltsUniqSet (nodeCoalesce node)
+                        -- See Note [Unique Determinism and code generation]
+
+                -- delete the node
+                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2
+
+          in    Just graph3
+
+        | otherwise
+        = Nothing
+
+
+-- | Modify a node in the graph.
+--      returns Nothing if the node isn't present.
+--
+modNode :: Uniquable k
+        => (Node k cls color -> Node k cls color)
+        -> k -> Graph k cls color -> Maybe (Graph k cls color)
+
+modNode f k graph
+ = case lookupNode graph k of
+        Just Node{}
+         -> Just
+         $  graphMapModify
+                 (\fm   -> let  Just node       = lookupUFM fm k
+                                node'           = f node
+                           in   addToUFM fm k node')
+                graph
+
+        Nothing -> Nothing
+
+
+-- | Get the size of the graph, O(n)
+size    :: Graph k cls color -> Int
+
+size graph
+        = sizeUFM $ graphMap graph
+
+
+-- | Union two graphs together.
+union   :: Graph k cls color -> Graph k cls color -> Graph k cls color
+
+union   graph1 graph2
+        = Graph
+        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
+
+
+-- | Add a conflict between nodes to the graph, creating the nodes required.
+--      Conflicts are virtual regs which need to be colored differently.
+addConflict
+        :: Uniquable k
+        => (k, cls) -> (k, cls)
+        -> Graph k cls color -> Graph k cls color
+
+addConflict (u1, c1) (u2, c2)
+ = let  addNeighbor u c u'
+                = adjustWithDefaultUFM
+                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
+                        (newNode u c)  { nodeConflicts = unitUniqSet u' }
+                        u
+
+   in   graphMapModify
+        ( addNeighbor u1 c1 u2
+        . addNeighbor u2 c2 u1)
+
+
+-- | Delete a conflict edge. k1 -> k2
+--      returns Nothing if the node isn't in the graph
+delConflict
+        :: Uniquable k
+        => k -> k
+        -> Graph k cls color -> Maybe (Graph k cls color)
+
+delConflict k1 k2
+        = modNode
+                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
+                k1
+
+
+-- | Add some conflicts to the graph, creating nodes if required.
+--      All the nodes in the set are taken to conflict with each other.
+addConflicts
+        :: Uniquable k
+        => UniqSet k -> (k -> cls)
+        -> Graph k cls color -> Graph k cls color
+
+addConflicts conflicts getClass
+
+        -- just a single node, but no conflicts, create the node anyway.
+        | (u : [])      <- nonDetEltsUniqSet conflicts
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                id
+                (newNode u (getClass u))
+                u
+
+        | otherwise
+        = graphMapModify
+        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
+                $ nonDetEltsUniqSet conflicts
+                -- See Note [Unique Determinism and code generation]
+
+
+addConflictSet1 :: Uniquable k
+                => k -> (k -> cls) -> UniqSet k
+                -> UniqFM (Node k cls color)
+                -> UniqFM (Node k cls color)
+addConflictSet1 u getClass set
+ = case delOneFromUniqSet set u of
+    set' -> adjustWithDefaultUFM
+                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
+                (newNode u (getClass u))        { nodeConflicts = set' }
+                u
+
+
+-- | Add an exclusion to the graph, creating nodes if required.
+--      These are extra colors that the node cannot use.
+addExclusion
+        :: (Uniquable k, Uniquable color)
+        => k -> (k -> cls) -> color
+        -> Graph k cls color -> Graph k cls color
+
+addExclusion u getClass color
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
+                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
+                u
+
+addExclusions
+        :: (Uniquable k, Uniquable color)
+        => k -> (k -> cls) -> [color]
+        -> Graph k cls color -> Graph k cls color
+
+addExclusions u getClass colors graph
+        = foldr (addExclusion u getClass) graph colors
+
+
+-- | Add a coalescence edge to the graph, creating nodes if requried.
+--      It is considered adventageous to assign the same color to nodes in a coalesence.
+addCoalesce
+        :: Uniquable k
+        => (k, cls) -> (k, cls)
+        -> Graph k cls color -> Graph k cls color
+
+addCoalesce (u1, c1) (u2, c2)
+ = let  addCoalesce u c u'
+         =      adjustWithDefaultUFM
+                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
+                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }
+                        u
+
+   in   graphMapModify
+        ( addCoalesce u1 c1 u2
+        . addCoalesce u2 c2 u1)
+
+
+-- | Delete a coalescence edge (k1 -> k2) from the graph.
+delCoalesce
+        :: Uniquable k
+        => k -> k
+        -> Graph k cls color    -> Maybe (Graph k cls color)
+
+delCoalesce k1 k2
+        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
+                k1
+
+
+-- | Add a color preference to the graph, creating nodes if required.
+--      The most recently added preference is the most prefered.
+--      The algorithm tries to assign a node it's prefered color if possible.
+--
+addPreference
+        :: Uniquable k
+        => (k, cls) -> color
+        -> Graph k cls color -> Graph k cls color
+
+addPreference (u, c) color
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                (\node -> node { nodePreference = color : (nodePreference node) })
+                (newNode u c)  { nodePreference = [color] }
+                u
+
+
+-- | Do aggressive coalescing on this graph.
+--      returns the new graph and the list of pairs of nodes that got coalesced together.
+--      for each pair, the resulting node will have the least key and be second in the pair.
+--
+coalesceGraph
+        :: (Uniquable k, Ord k, Eq cls, Outputable k)
+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                                --      less colorable (aggressive coalescing)
+        -> Triv k cls color
+        -> Graph k cls color
+        -> ( Graph k cls color
+           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
+                                --      coalescing was applied.
+
+coalesceGraph aggressive triv graph
+        = coalesceGraph' aggressive triv graph []
+
+coalesceGraph'
+        :: (Uniquable k, Ord k, Eq cls, Outputable k)
+        => Bool
+        -> Triv k cls color
+        -> Graph k cls color
+        -> [(k, k)]
+        -> ( Graph k cls color
+           , [(k, k)])
+coalesceGraph' aggressive triv graph kkPairsAcc
+ = let
+        -- find all the nodes that have coalescence edges
+        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+        -- build a list of pairs of keys for node's we'll try and coalesce
+        --      every pair of nodes will appear twice in this list
+        --      ie [(k1, k2), (k2, k1) ... ]
+        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
+        --      build a list of what nodes get coalesced together for later on.
+        --
+        cList   = [ (nodeId node1, k2)
+                        | node1 <- cNodes
+                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]
+                        -- See Note [Unique Determinism and code generation]
+
+        -- do the coalescing, returning the new graph and a list of pairs of keys
+        --      that got coalesced together.
+        (graph', mPairs)
+                = mapAccumL (coalesceNodes aggressive triv) graph cList
+
+        -- keep running until there are no more coalesces can be found
+   in   case catMaybes mPairs of
+         []     -> (graph', reverse kkPairsAcc)
+         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
+
+
+-- | Coalesce this pair of nodes unconditionally \/ aggressively.
+--      The resulting node is the one with the least key.
+--
+--      returns: Just    the pair of keys if the nodes were coalesced
+--                       the second element of the pair being the least one
+--
+--               Nothing if either of the nodes weren't in the graph
+
+coalesceNodes
+        :: (Uniquable k, Ord k, Eq cls)
+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                                --      less colorable (aggressive coalescing)
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> (k, k)               -- ^ keys of the nodes to be coalesced
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes aggressive triv graph (k1, k2)
+        | (kMin, kMax)  <- if k1 < k2
+                                then (k1, k2)
+                                else (k2, k1)
+
+        -- the nodes being coalesced must be in the graph
+        , Just nMin     <- lookupNode graph kMin
+        , Just nMax     <- lookupNode graph kMax
+
+        -- can't coalesce conflicting modes
+        , not $ elementOfUniqSet kMin (nodeConflicts nMax)
+        , not $ elementOfUniqSet kMax (nodeConflicts nMin)
+
+        -- can't coalesce the same node
+        , nodeId nMin /= nodeId nMax
+
+        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+        -- don't do the coalescing after all
+        | otherwise
+        = (graph, Nothing)
+
+coalesceNodes_merge
+        :: (Uniquable k, Eq cls)
+        => Bool
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> k -> k
+        -> Node k cls color
+        -> Node k cls color
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+        -- sanity checks
+        | nodeClass nMin /= nodeClass nMax
+        = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
+
+        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
+        = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
+
+        ---
+        | otherwise
+        = let
+                -- the new node gets all the edges from its two components
+                node    =
+                 Node   { nodeId                = kMin
+                        , nodeClass             = nodeClass nMin
+                        , nodeColor             = Nothing
+
+                        -- nodes don't conflict with themselves..
+                        , nodeConflicts
+                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
+                                        `delOneFromUniqSet` kMin
+                                        `delOneFromUniqSet` kMax
+
+                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
+                        , nodePreference        = nodePreference nMin ++ nodePreference nMax
+
+                        -- nodes don't coalesce with themselves..
+                        , nodeCoalesce
+                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
+                                        `delOneFromUniqSet` kMin
+                                        `delOneFromUniqSet` kMax
+                        }
+
+          in    coalesceNodes_check aggressive triv graph kMin kMax node
+
+coalesceNodes_check
+        :: Uniquable k
+        => Bool
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> k -> k
+        -> Node k cls color
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes_check aggressive triv graph kMin kMax node
+
+        -- Unless we're coalescing aggressively, if the result node is not trivially
+        --      colorable then don't do the coalescing.
+        | not aggressive
+        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+        = (graph, Nothing)
+
+        | otherwise
+        = let -- delete the old nodes from the graph and add the new one
+                Just graph1     = delNode kMax graph
+                Just graph2     = delNode kMin graph1
+                graph3          = addNode kMin node graph2
+
+          in    (graph3, Just (kMax, kMin))
+
+
+-- | Freeze a node
+--      This is for the iterative coalescer.
+--      By freezing a node we give up on ever coalescing it.
+--      Move all its coalesce edges into the frozen set - and update
+--      back edges from other nodes.
+--
+freezeNode
+        :: Uniquable k
+        => k                    -- ^ key of the node to freeze
+        -> Graph k cls color    -- ^ the graph
+        -> Graph k cls color    -- ^ graph with that node frozen
+
+freezeNode k
+  = graphMapModify
+  $ \fm ->
+    let -- freeze all the edges in the node to be frozen
+        Just node = lookupUFM fm k
+        node'   = node
+                { nodeCoalesce          = emptyUniqSet }
+
+        fm1     = addToUFM fm k node'
+
+        -- update back edges pointing to this node
+        freezeEdge k node
+         = if elementOfUniqSet k (nodeCoalesce node)
+                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
+                else node       -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
+                                -- If the edge isn't actually in the coelesce set then just ignore it.
+
+        fm2     = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
+                    -- It's OK to use nonDetFoldUFM here because the operation
+                    -- is commutative
+                        $ nodeCoalesce node
+
+    in  fm2
+
+
+-- | Freeze one node in the graph
+--      This if for the iterative coalescer.
+--      Look for a move related node of low degree and freeze it.
+--
+--      We probably don't need to scan the whole graph looking for the node of absolute
+--      lowest degree. Just sample the first few and choose the one with the lowest
+--      degree out of those. Also, we don't make any distinction between conflicts of different
+--      classes.. this is just a heuristic, after all.
+--
+--      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
+--              right here, and add it to a worklist if known triv\/non-move nodes.
+--
+freezeOneInGraph
+        :: (Uniquable k)
+        => Graph k cls color
+        -> ( Graph k cls color          -- the new graph
+           , Bool )                     -- whether we found a node to freeze
+
+freezeOneInGraph graph
+ = let  compareNodeDegree n1 n2
+                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
+
+        candidates
+                = sortBy compareNodeDegree
+                $ take 5        -- 5 isn't special, it's just a small number.
+                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
+
+   in   case candidates of
+
+         -- there wasn't anything available to freeze
+         []     -> (graph, False)
+
+         -- we found something to freeze
+         (n : _)
+          -> ( freezeNode (nodeId n) graph
+             , True)
+
+
+-- | Freeze all the nodes in the graph
+--      for debugging the iterative allocator.
+--
+freezeAllInGraph
+        :: (Uniquable k)
+        => Graph k cls color
+        -> Graph k cls color
+
+freezeAllInGraph graph
+        = foldr freezeNode graph
+                $ map nodeId
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+
+-- | Find all the nodes in the graph that meet some criteria
+--
+scanGraph
+        :: (Node k cls color -> Bool)
+        -> Graph k cls color
+        -> [Node k cls color]
+
+scanGraph match graph
+        = filter match $ nonDetEltsUFM $ graphMap graph
+          -- See Note [Unique Determinism and code generation]
+
+
+-- | validate the internal structure of a graph
+--      all its edges should point to valid nodes
+--      If they don't then throw an error
+--
+validateGraph
+        :: (Uniquable k, Outputable k, Eq color)
+        => SDoc                         -- ^ extra debugging info to display on error
+        -> Bool                         -- ^ whether this graph is supposed to be colored.
+        -> Graph k cls color            -- ^ graph to validate
+        -> Graph k cls color            -- ^ validated graph
+
+validateGraph doc isColored graph
+
+        -- Check that all edges point to valid nodes.
+        | edges         <- unionManyUniqSets
+                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)
+                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))
+
+        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph
+        , badEdges      <- minusUniqSet edges nodes
+        , not $ isEmptyUniqSet badEdges
+        = pprPanic "GraphOps.validateGraph"
+                (  text "Graph has edges that point to non-existent nodes"
+                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)
+                $$ doc )
+
+        -- Check that no conflicting nodes have the same color
+        | badNodes      <- filter (not . (checkNode graph))
+                        $ nonDetEltsUFM $ graphMap graph
+                           -- See Note [Unique Determinism and code generation]
+        , not $ null badNodes
+        = pprPanic "GraphOps.validateGraph"
+                (  text "Node has same color as one of it's conflicts"
+                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
+                $$ doc)
+
+        -- If this is supposed to be a colored graph,
+        --      check that all nodes have a color.
+        | isColored
+        , badNodes      <- filter (\n -> isNothing $ nodeColor n)
+                        $  nonDetEltsUFM $ graphMap graph
+        , not $ null badNodes
+        = pprPanic "GraphOps.validateGraph"
+                (  text "Supposably colored graph has uncolored nodes."
+                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
+                $$ doc )
+
+
+        -- graph looks ok
+        | otherwise
+        = graph
+
+
+-- | If this node is colored, check that all the nodes which
+--      conflict with it have different colors.
+checkNode
+        :: (Uniquable k, Eq color)
+        => Graph k cls color
+        -> Node  k cls color
+        -> Bool                 -- ^ True if this node is ok
+
+checkNode graph node
+        | Just color            <- nodeColor node
+        , Just neighbors        <- sequence $ map (lookupNode graph)
+                                $  nonDetEltsUniqSet $ nodeConflicts node
+            -- See Note [Unique Determinism and code generation]
+
+        , neighbourColors       <- catMaybes $ map nodeColor neighbors
+        , elem color neighbourColors
+        = False
+
+        | otherwise
+        = True
+
+
+
+-- | Slurp out a map of how many nodes had a certain number of conflict neighbours
+
+slurpNodeConflictCount
+        :: Graph k cls color
+        -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
+
+slurpNodeConflictCount graph
+        = addListToUFM_C
+                (\(c1, n1) (_, n2) -> (c1, n1 + n2))
+                emptyUFM
+        $ map   (\node
+                  -> let count  = sizeUniqSet $ nodeConflicts node
+                     in  (count, (count, 1)))
+        $ nonDetEltsUFM
+        -- See Note [Unique Determinism and code generation]
+        $ graphMap graph
+
+
+-- | Set the color of a certain node
+setColor
+        :: Uniquable k
+        => k -> color
+        -> Graph k cls color -> Graph k cls color
+
+setColor u color
+        = graphMapModify
+        $ adjustUFM_C
+                (\n -> n { nodeColor = Just color })
+                u
+
+
+{-# INLINE adjustWithDefaultUFM #-}
+adjustWithDefaultUFM
+        :: Uniquable k
+        => (a -> a) -> a -> k
+        -> UniqFM a -> UniqFM a
+
+adjustWithDefaultUFM f def k map
+        = addToUFM_C
+                (\old _ -> f old)
+                map
+                k def
+
+-- Argument order different from UniqFM's adjustUFM
+{-# INLINE adjustUFM_C #-}
+adjustUFM_C
+        :: Uniquable k
+        => (a -> a)
+        -> k -> UniqFM a -> UniqFM a
+
+adjustUFM_C f k map
+ = case lookupUFM map k of
+        Nothing -> map
+        Just a  -> addToUFM map k (f a)
+
diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphPpr.hs
@@ -0,0 +1,173 @@
+
+-- | Pretty printing of graphs.
+
+module GraphPpr (
+        dumpGraph,
+        dotGraph
+)
+where
+
+import GhcPrelude
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List
+import Data.Maybe
+
+
+-- | Pretty print a graph in a somewhat human readable format.
+dumpGraph
+        :: (Outputable k, Outputable color)
+        => Graph k cls color -> SDoc
+
+dumpGraph graph
+        =  text "Graph"
+        $$ pprUFM (graphMap graph) (vcat . map dumpNode)
+
+dumpNode
+        :: (Outputable k, Outputable color)
+        => Node k cls color -> SDoc
+
+dumpNode node
+        =  text "Node " <> ppr (nodeId node)
+        $$ text "conflicts "
+                <> parens (int (sizeUniqSet $ nodeConflicts node))
+                <> text " = "
+                <> ppr (nodeConflicts node)
+
+        $$ text "exclusions "
+                <> parens (int (sizeUniqSet $ nodeExclusions node))
+                <> text " = "
+                <> ppr (nodeExclusions node)
+
+        $$ text "coalesce "
+                <> parens (int (sizeUniqSet $ nodeCoalesce node))
+                <> text " = "
+                <> ppr (nodeCoalesce node)
+
+        $$ space
+
+
+
+-- | Pretty print a graph in graphviz .dot format.
+--      Conflicts get solid edges.
+--      Coalescences get dashed edges.
+dotGraph
+        :: ( Uniquable k
+           , Outputable k, Outputable cls, Outputable color)
+        => (color -> SDoc)  -- ^ What graphviz color to use for each node color
+                            --  It's usually safe to return X11 style colors here,
+                            --  ie "red", "green" etc or a hex triplet #aaff55 etc
+        -> Triv k cls color
+        -> Graph k cls color -> SDoc
+
+dotGraph colorMap triv graph
+ = let  nodes   = nonDetEltsUFM $ graphMap graph
+                  -- See Note [Unique Determinism and code generation]
+   in   vcat
+                (  [ text "graph G {" ]
+                ++ map (dotNode colorMap triv) nodes
+                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
+                ++ [ text "}"
+                   , space ])
+
+
+dotNode :: ( Outputable k, Outputable cls, Outputable color)
+        => (color -> SDoc)
+        -> Triv k cls color
+        -> Node k cls color -> SDoc
+
+dotNode colorMap triv node
+ = let  name    = ppr $ nodeId node
+        cls     = ppr $ nodeClass node
+
+        excludes
+                = hcat $ punctuate space
+                $ map (\n -> text "-" <> ppr n)
+                $ nonDetEltsUniqSet $ nodeExclusions node
+                -- See Note [Unique Determinism and code generation]
+
+        preferences
+                = hcat $ punctuate space
+                $ map (\n -> text "+" <> ppr n)
+                $ nodePreference node
+
+        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
+                        then empty
+                        else text "\\n" <> (excludes <+> preferences)
+
+        -- if the node has been colored then show that,
+        --      otherwise indicate whether it looks trivially colorable.
+        color
+                | Just c        <- nodeColor node
+                = text "\\n(" <> ppr c <> text ")"
+
+                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+                = text "\\n(" <> text "triv" <> text ")"
+
+                | otherwise
+                = text "\\n(" <> text "spill?" <> text ")"
+
+        label   =  name <> text " :: " <> cls
+                <> expref
+                <> color
+
+        pcolorC = case nodeColor node of
+                        Nothing -> text "style=filled fillcolor=white"
+                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
+
+
+        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
+                <> space <> doubleQuotes name
+                <> text ";"
+
+ in     pout
+
+
+-- | Nodes in the graph are doubly linked, but we only want one edge for each
+--      conflict if the graphviz graph. Traverse over the graph, but make sure
+--      to only print the edges for each node once.
+
+dotNodeEdges
+        :: ( Uniquable k
+           , Outputable k)
+        => UniqSet k
+        -> Node k cls color
+        -> (UniqSet k, Maybe SDoc)
+
+dotNodeEdges visited node
+        | elementOfUniqSet (nodeId node) visited
+        = ( visited
+          , Nothing)
+
+        | otherwise
+        = let   dconflicts
+                        = map (dotEdgeConflict (nodeId node))
+                        $ nonDetEltsUniqSet
+                        -- See Note [Unique Determinism and code generation]
+                        $ minusUniqSet (nodeConflicts node) visited
+
+                dcoalesces
+                        = map (dotEdgeCoalesce (nodeId node))
+                        $ nonDetEltsUniqSet
+                        -- See Note [Unique Determinism and code generation]
+                        $ minusUniqSet (nodeCoalesce node) visited
+
+                out     =  vcat dconflicts
+                        $$ vcat dcoalesces
+
+          in    ( addOneToUniqSet visited (nodeId node)
+                , Just out)
+
+        where   dotEdgeConflict u1 u2
+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+                        <> text ";"
+
+                dotEdgeCoalesce u1 u2
+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+                        <> space <> text "[ style = dashed ];"
diff --git a/compiler/utils/ListT.hs b/compiler/utils/ListT.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/ListT.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-------------------------------------------------------------------------
+-- |
+-- Module      : Control.Monad.Logic
+-- Copyright   : (c) Dan Doel
+-- License     : BSD3
+--
+-- Maintainer  : dan.doel@gmail.com
+-- Stability   : experimental
+-- Portability : non-portable (multi-parameter type classes)
+--
+-- A backtracking, logic programming monad.
+--
+--    Adapted from the paper
+--    /Backtracking, Interleaving, and Terminating
+--        Monad Transformers/, by
+--    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry
+--    (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).
+-------------------------------------------------------------------------
+
+module ListT (
+    ListT(..),
+    runListT,
+    select,
+    fold
+  ) where
+
+import GhcPrelude
+
+import Control.Applicative
+
+import Control.Monad
+import Control.Monad.Fail as MonadFail
+
+-------------------------------------------------------------------------
+-- | A monad transformer for performing backtracking computations
+-- layered over another monad 'm'
+newtype ListT m a =
+    ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }
+
+select :: Monad m => [a] -> ListT m a
+select xs = foldr (<|>) mzero (map pure xs)
+
+fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r
+fold = runListT
+
+-------------------------------------------------------------------------
+-- | Runs a ListT computation with the specified initial success and
+-- failure continuations.
+runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r
+runListT = unListT
+
+instance Functor (ListT f) where
+    fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk
+
+instance Applicative (ListT f) where
+    pure a = ListT $ \sk fk -> sk a fk
+    f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk
+
+instance Alternative (ListT f) where
+    empty = ListT $ \_ fk -> fk
+    f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)
+
+instance Monad (ListT m) where
+    m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk
+#if !MIN_VERSION_base(4,13,0)
+    fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail (ListT m) where
+    fail _ = ListT $ \_ fk -> fk
+
+instance MonadPlus (ListT m) where
+    mzero = ListT $ \_ fk -> fk
+    m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/State.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module State where
+
+import GhcPrelude
+
+newtype State s a = State { runState' :: s -> (# a, s #) }
+
+instance Functor (State s) where
+    fmap f m  = State $ \s -> case runState' m s of
+                              (# r, s' #) -> (# f r, s' #)
+
+instance Applicative (State s) where
+   pure x   = State $ \s -> (# x, s #)
+   m <*> n  = State $ \s -> case runState' m s of
+                            (# f, s' #) -> case runState' n s' of
+                                           (# x, s'' #) -> (# f x, s'' #)
+
+instance Monad (State s) where
+    m >>= n  = State $ \s -> case runState' m s of
+                             (# r, s' #) -> runState' (n r) s'
+
+get :: State s s
+get = State $ \s -> (# s, s #)
+
+gets :: (s -> a) -> State s a
+gets f = State $ \s -> (# f s, s #)
+
+put :: s -> State s ()
+put s' = State $ \_ -> (# (), s' #)
+
+modify :: (s -> s) -> State s ()
+modify f = State $ \s -> (# (), f s #)
+
+
+evalState :: State s a -> s -> a
+evalState s i = case runState' s i of
+                (# a, _ #) -> a
+
+
+execState :: State s a -> s -> s
+execState s i = case runState' s i of
+                (# _, s' #) -> s'
+
+
+runState :: State s a -> s -> (a, s)
+runState s i = case runState' s i of
+               (# a, s' #) -> (a, s')
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/Stream.hs
@@ -0,0 +1,106 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2012
+--
+-- Monadic streams
+--
+-- -----------------------------------------------------------------------------
+module Stream (
+    Stream(..), yield, liftIO,
+    collect, fromList,
+    Stream.map, Stream.mapM, Stream.mapAccumL
+  ) where
+
+import GhcPrelude
+
+import Control.Monad
+
+-- |
+-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence
+-- of elements of type @a@ followed by a result of type @b@.
+--
+-- More concretely, a value of type @Stream m a b@ can be run using @runStream@
+-- in the Monad @m@, and it delivers either
+--
+--  * the final result: @Left b@, or
+--  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@
+--    is a computation to get the rest of the stream.
+--
+-- Stream is itself a Monad, and provides an operation 'yield' that
+-- produces a new element of the stream.  This makes it convenient to turn
+-- existing monadic computations into streams.
+--
+-- The idea is that Stream is useful for making a monadic computation
+-- that produces values from time to time.  This can be used for
+-- knitting together two complex monadic operations, so that the
+-- producer does not have to produce all its values before the
+-- consumer starts consuming them.  We make the producer into a
+-- Stream, and the consumer pulls on the stream each time it wants a
+-- new value.
+--
+newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }
+
+instance Monad f => Functor (Stream f a) where
+  fmap = liftM
+
+instance Monad m => Applicative (Stream m a) where
+  pure a = Stream (return (Left a))
+  (<*>) = ap
+
+instance Monad m => Monad (Stream m a) where
+
+  Stream m >>= k = Stream $ do
+                r <- m
+                case r of
+                  Left b        -> runStream (k b)
+                  Right (a,str) -> return (Right (a, str >>= k))
+
+yield :: Monad m => a -> Stream m a ()
+yield a = Stream (return (Right (a, return ())))
+
+liftIO :: IO a -> Stream IO b a
+liftIO io = Stream $ io >>= return . Left
+
+-- | Turn a Stream into an ordinary list, by demanding all the elements.
+collect :: Monad m => Stream m a () -> m [a]
+collect str = go str []
+ where
+  go str acc = do
+    r <- runStream str
+    case r of
+      Left () -> return (reverse acc)
+      Right (a, str') -> go str' (a:acc)
+
+-- | Turn a list into a 'Stream', by yielding each element in turn.
+fromList :: Monad m => [a] -> Stream m a ()
+fromList = mapM_ yield
+
+-- | Apply a function to each element of a 'Stream', lazily
+map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x
+map f str = Stream $ do
+   r <- runStream str
+   case r of
+     Left x -> return (Left x)
+     Right (a, str') -> return (Right (f a, Stream.map f str'))
+
+-- | Apply a monadic operation to each element of a 'Stream', lazily
+mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x
+mapM f str = Stream $ do
+   r <- runStream str
+   case r of
+     Left x -> return (Left x)
+     Right (a, str') -> do
+        b <- f a
+        return (Right (b, Stream.mapM f str'))
+
+-- | analog of the list-based 'mapAccumL' on Streams.  This is a simple
+-- way to map over a Stream while carrying some state around.
+mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()
+          -> Stream m b c
+mapAccumL f c str = Stream $ do
+  r <- runStream str
+  case r of
+    Left  () -> return (Left c)
+    Right (a, str') -> do
+      (c',b) <- f c a
+      return (Right (b, mapAccumL f c' str'))
diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/UnVarGraph.hs
@@ -0,0 +1,145 @@
+{-
+
+Copyright (c) 2014 Joachim Breitner
+
+A data structure for undirected graphs of variables
+(or in plain terms: Sets of unordered pairs of numbers)
+
+
+This is very specifically tailored for the use in CallArity. In particular it
+stores the graph as a union of complete and complete bipartite graph, which
+would be very expensive to store as sets of edges or as adjanceny lists.
+
+It does not normalize the graphs. This means that g `unionUnVarGraph` g is
+equal to g, but twice as expensive and large.
+
+-}
+module UnVarGraph
+    ( UnVarSet
+    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
+    , delUnVarSet
+    , elemUnVarSet, isEmptyUnVarSet
+    , UnVarGraph
+    , emptyUnVarGraph
+    , unionUnVarGraph, unionUnVarGraphs
+    , completeGraph, completeBipartiteGraph
+    , neighbors
+    , hasLoopAt
+    , delNode
+    ) where
+
+import GhcPrelude
+
+import Id
+import VarEnv
+import UniqFM
+import Outputable
+import Bag
+import Unique
+
+import qualified Data.IntSet as S
+
+-- We need a type for sets of variables (UnVarSet).
+-- We do not use VarSet, because for that we need to have the actual variable
+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
+
+-- Set of uniques, i.e. for adjancet nodes
+newtype UnVarSet = UnVarSet (S.IntSet)
+    deriving Eq
+
+k :: Var -> Int
+k v = getKey (getUnique v)
+
+emptyUnVarSet :: UnVarSet
+emptyUnVarSet = UnVarSet S.empty
+
+elemUnVarSet :: Var -> UnVarSet -> Bool
+elemUnVarSet v (UnVarSet s) = k v `S.member` s
+
+
+isEmptyUnVarSet :: UnVarSet -> Bool
+isEmptyUnVarSet (UnVarSet s) = S.null s
+
+delUnVarSet :: UnVarSet -> Var -> UnVarSet
+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
+
+mkUnVarSet :: [Var] -> UnVarSet
+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
+
+varEnvDom :: VarEnv a -> UnVarSet
+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
+
+unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
+
+unionUnVarSets :: [UnVarSet] -> UnVarSet
+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
+
+instance Outputable UnVarSet where
+    ppr (UnVarSet s) = braces $
+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
+
+
+-- The graph type. A list of complete bipartite graphs
+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
+         | CG   UnVarSet          -- complete
+newtype UnVarGraph = UnVarGraph (Bag Gen)
+
+emptyUnVarGraph :: UnVarGraph
+emptyUnVarGraph = UnVarGraph emptyBag
+
+unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
+{-
+Premature optimisation, it seems.
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s1 == s3 && s2 == s4
+    = pprTrace "unionUnVarGraph fired" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s2 == s3 && s1 == s4
+    = pprTrace "unionUnVarGraph fired2" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+-}
+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
+    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
+      UnVarGraph (g1 `unionBags` g2)
+
+unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
+
+-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
+
+completeGraph :: UnVarSet -> UnVarGraph
+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
+
+neighbors :: UnVarGraph -> Var -> UnVarSet
+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
+  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])
+        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
+                          (if v `elemUnVarSet` s2 then [s1] else [])
+
+-- hasLoopAt G v <=> v--v ∈ G
+hasLoopAt :: UnVarGraph -> Var -> Bool
+hasLoopAt (UnVarGraph g) v = any go $ bagToList g
+  where go (CG s)       = v `elemUnVarSet` s
+        go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
+
+
+delNode :: UnVarGraph -> Var -> UnVarGraph
+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
+  where go (CG s)       = CG (s `delUnVarSet` v)
+        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
+
+prune :: UnVarGraph -> UnVarGraph
+prune (UnVarGraph g) = UnVarGraph $ filterBag go g
+  where go (CG s)       = not (isEmptyUnVarSet s)
+        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
+
+instance Outputable Gen where
+    ppr (CG s)       = ppr s  <> char '²'
+    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
+instance Outputable UnVarGraph where
+    ppr (UnVarGraph g) = ppr g
diff --git a/compiler/utils/UniqMap.hs b/compiler/utils/UniqMap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/UniqMap.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- Like 'UniqFM', these are maps for keys which are Uniquable.
+-- Unlike 'UniqFM', these maps also remember their keys, which
+-- makes them a much better drop in replacement for 'Data.Map.Map'.
+--
+-- Key preservation is right-biased.
+module UniqMap (
+    UniqMap,
+    emptyUniqMap,
+    isNullUniqMap,
+    unitUniqMap,
+    listToUniqMap,
+    listToUniqMap_C,
+    addToUniqMap,
+    addListToUniqMap,
+    addToUniqMap_C,
+    addToUniqMap_Acc,
+    alterUniqMap,
+    addListToUniqMap_C,
+    adjustUniqMap,
+    delFromUniqMap,
+    delListFromUniqMap,
+    plusUniqMap,
+    plusUniqMap_C,
+    plusMaybeUniqMap_C,
+    plusUniqMapList,
+    minusUniqMap,
+    intersectUniqMap,
+    disjointUniqMap,
+    mapUniqMap,
+    filterUniqMap,
+    partitionUniqMap,
+    sizeUniqMap,
+    elemUniqMap,
+    lookupUniqMap,
+    lookupWithDefaultUniqMap,
+    anyUniqMap,
+    allUniqMap,
+    -- Non-deterministic functions omitted
+) where
+
+import GhcPrelude
+
+import UniqFM
+
+import Unique
+import Outputable
+
+import Data.Semigroup as Semi ( Semigroup(..) )
+import Data.Coerce
+import Data.Maybe
+import Data.Data
+
+-- | Maps indexed by 'Uniquable' keys
+newtype UniqMap k a = UniqMap (UniqFM (k, a))
+    deriving (Data, Eq, Functor)
+type role UniqMap nominal representational
+
+instance Semigroup (UniqMap k a) where
+  (<>) = plusUniqMap
+
+instance Monoid (UniqMap k a) where
+    mempty = emptyUniqMap
+    mappend = (Semi.<>)
+
+instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where
+    ppr (UniqMap m) =
+        brackets $ fsep $ punctuate comma $
+        [ ppr k <+> text "->" <+> ppr v
+        | (k, v) <- eltsUFM m ]
+
+liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)
+liftC f (_, v) (k', v') = (k', f v v')
+
+emptyUniqMap :: UniqMap k a
+emptyUniqMap = UniqMap emptyUFM
+
+isNullUniqMap :: UniqMap k a -> Bool
+isNullUniqMap (UniqMap m) = isNullUFM m
+
+unitUniqMap :: Uniquable k => k -> a -> UniqMap k a
+unitUniqMap k v = UniqMap (unitUFM k (k, v))
+
+listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a
+listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])
+
+listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a
+listToUniqMap_C f kvs = UniqMap $
+    listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]
+
+addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
+addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)
+
+addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a
+addListToUniqMap (UniqMap m) kvs = UniqMap $
+    addListToUFM m [(k,(k,v)) | (k,v) <- kvs]
+
+addToUniqMap_C :: Uniquable k
+               => (a -> a -> a)
+               -> UniqMap k a
+               -> k
+               -> a
+               -> UniqMap k a
+addToUniqMap_C f (UniqMap m) k v = UniqMap $
+    addToUFM_C (liftC f) m k (k, v)
+
+addToUniqMap_Acc :: Uniquable k
+                 => (b -> a -> a)
+                 -> (b -> a)
+                 -> UniqMap k a
+                 -> k
+                 -> b
+                 -> UniqMap k a
+addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $
+    addToUFM_Acc (\b (k, v) -> (k, exi b v))
+                 (\b -> (k0, new b))
+                 m k0 v0
+
+alterUniqMap :: Uniquable k
+             => (Maybe a -> Maybe a)
+             -> UniqMap k a
+             -> k
+             -> UniqMap k a
+alterUniqMap f (UniqMap m) k = UniqMap $
+    alterUFM (fmap (k,) . f . fmap snd) m k
+
+addListToUniqMap_C
+    :: Uniquable k
+    => (a -> a -> a)
+    -> UniqMap k a
+    -> [(k, a)]
+    -> UniqMap k a
+addListToUniqMap_C f (UniqMap m) kvs = UniqMap $
+    addListToUFM_C (liftC f) m
+        [(k,(k,v)) | (k,v) <- kvs]
+
+adjustUniqMap
+    :: Uniquable k
+    => (a -> a)
+    -> UniqMap k a
+    -> k
+    -> UniqMap k a
+adjustUniqMap f (UniqMap m) k = UniqMap $
+    adjustUFM (\(_,v) -> (k,f v)) m k
+
+delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a
+delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k
+
+delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a
+delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks
+
+plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a
+plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2
+
+plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
+plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
+    plusUFM_C (liftC f) m1 m2
+
+plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
+plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
+    plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2
+
+plusUniqMapList :: [UniqMap k a] -> UniqMap k a
+plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)
+
+minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
+minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2
+
+intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
+intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2
+
+disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool
+disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2
+
+mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b
+mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance
+
+filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a
+filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m
+
+partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)
+partitionUniqMap f (UniqMap m) =
+    coerce $ partitionUFM (f . snd) m
+
+sizeUniqMap :: UniqMap k a -> Int
+sizeUniqMap (UniqMap m) = sizeUFM m
+
+elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool
+elemUniqMap k (UniqMap m) = elemUFM k m
+
+lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a
+lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)
+
+lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a
+lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))
+
+anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
+anyUniqMap f (UniqMap m) = anyUFM (f . snd) m
+
+allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
+allUniqMap f (UniqMap m) = allUFM (f . snd) m
diff --git a/compiler/utils/md5.h b/compiler/utils/md5.h
new file mode 100644
--- /dev/null
+++ b/compiler/utils/md5.h
@@ -0,0 +1,18 @@
+/* MD5 message digest */
+#pragma once
+
+#include "HsFFI.h"
+
+typedef HsWord32 word32;
+typedef HsWord8  byte;
+
+struct MD5Context {
+        word32 buf[4];
+        word32 bytes[2];
+        word32 in[16];
+};
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
diff --git a/ghc-lib.cabal b/ghc-lib.cabal
new file mode 100644
--- /dev/null
+++ b/ghc-lib.cabal
@@ -0,0 +1,692 @@
+cabal-version: >=1.22
+build-type: Simple
+name: ghc-lib
+version: 0.1.0
+license: BSD3
+license-file: LICENSE
+category: Development
+author: The GHC Team and Digital Asset
+maintainer: Digital Asset
+synopsis: The GHC API, decoupled from GHC versions
+description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions.
+homepage: https://github.com/digital-asset/ghc-lib
+bug-reports: https://github.com/digital-asset/ghc-lib/issues
+data-dir: ghc-lib/stage1/lib
+data-files:
+    settings
+    llvm-targets
+    llvm-passes
+    platformConstants
+extra-source-files:
+    ghc-lib/generated/ghcautoconf.h
+    ghc-lib/generated/ghcplatform.h
+    ghc-lib/generated/ghcversion.h
+    ghc-lib/generated/DerivedConstants.h
+    ghc-lib/generated/GHCConstantsHaskellExports.hs
+    ghc-lib/generated/GHCConstantsHaskellType.hs
+    ghc-lib/generated/GHCConstantsHaskellWrappers.hs
+    ghc-lib/stage1/compiler/build/ghc_boot_platform.h
+    ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl
+    ghc-lib/stage1/compiler/build/primop-code-size.hs-incl
+    ghc-lib/stage1/compiler/build/primop-commutable.hs-incl
+    ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl
+    ghc-lib/stage1/compiler/build/primop-fixity.hs-incl
+    ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl
+    ghc-lib/stage1/compiler/build/primop-list.hs-incl
+    ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl
+    ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl
+    ghc-lib/stage1/compiler/build/primop-strictness.hs-incl
+    ghc-lib/stage1/compiler/build/primop-tag.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl
+    includes/*.h
+    includes/CodeGen.Platform.hs
+    includes/rts/*.h
+    includes/rts/storage/*.h
+    includes/rts/prof/*.h
+    compiler/nativeGen/*.h
+    compiler/utils/*.h
+    compiler/*.h
+tested-with: GHC==8.6.3, GHC==8.4.3
+source-repository head
+    type: git
+    location: git@github.com:digital-asset/ghc-lib.git
+
+library
+    default-language:   Haskell2010
+    default-extensions: NoImplicitPrelude
+    include-dirs:
+        ghc-lib/generated
+        ghc-lib/stage1/compiler/build
+        compiler
+        compiler/utils
+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS
+    cc-options: -DTHREADED_RTS
+    cpp-options: -DSTAGE=2 -DTHREADED_RTS -DGHCI -DGHC_IN_GHCI
+    if !os(windows)
+        build-depends: unix
+    else
+        build-depends: Win32
+    build-depends:
+        ghc-prim > 0.2 && < 0.6,
+        base >= 4.11 && < 4.14,
+        containers >= 0.5 && < 0.7,
+        bytestring >= 0.9 && < 0.11,
+        binary == 0.8.*,
+        filepath >= 1 && < 1.5,
+        directory >= 1 && < 1.4,
+        array >= 0.1 && < 0.6,
+        deepseq >= 1.4 && < 1.5,
+        pretty == 1.1.*,
+        time >= 1.4 && < 1.10,
+        transformers == 0.5.*,
+        process >= 1 && < 1.7,
+        hpc == 0.6.*,
+        ghc-lib-parser
+    build-tools: alex >= 3.1, happy >= 1.19.4
+    other-extensions:
+        BangPatterns
+        CPP
+        DataKinds
+        DefaultSignatures
+        DeriveDataTypeable
+        DeriveFoldable
+        DeriveFunctor
+        DeriveGeneric
+        DeriveTraversable
+        DisambiguateRecordFields
+        ExistentialQuantification
+        ExplicitForAll
+        FlexibleContexts
+        FlexibleInstances
+        GADTs
+        GeneralizedNewtypeDeriving
+        InstanceSigs
+        MagicHash
+        MultiParamTypeClasses
+        NamedFieldPuns
+        NondecreasingIndentation
+        RankNTypes
+        RecordWildCards
+        RoleAnnotations
+        ScopedTypeVariables
+        StandaloneDeriving
+        Trustworthy
+        TupleSections
+        TypeFamilies
+        TypeSynonymInstances
+        UnboxedTuples
+        UndecidableInstances
+    hs-source-dirs:
+        compiler
+        compiler/backpack
+        compiler/cmm
+        compiler/codeGen
+        compiler/coreSyn
+        compiler/deSugar
+        compiler/ghci
+        compiler/hieFile
+        compiler/hsSyn
+        compiler/iface
+        compiler/llvmGen
+        compiler/main
+        compiler/nativeGen
+        compiler/prelude
+        compiler/profiling
+        compiler/rename
+        compiler/simplCore
+        compiler/simplStg
+        compiler/specialise
+        compiler/stgSyn
+        compiler/stranal
+        compiler/typecheck
+        compiler/utils
+        ghc-lib/stage1/compiler/build
+        libraries/ghc-boot
+        libraries/ghci
+        libraries/template-haskell
+    autogen-modules:
+        Paths_ghc_lib
+    reexported-modules:
+        Annotations,
+        ApiAnnotation,
+        Avail,
+        Bag,
+        BasicTypes,
+        BinFingerprint,
+        Binary,
+        BkpSyn,
+        BooleanFormula,
+        BufWrite,
+        ByteCodeTypes,
+        Class,
+        CmdLineParser,
+        CmmType,
+        CoAxiom,
+        Coercion,
+        ConLike,
+        Config,
+        Constants,
+        CoreArity,
+        CoreFVs,
+        CoreMap,
+        CoreMonad,
+        CoreOpt,
+        CoreSeq,
+        CoreStats,
+        CoreSubst,
+        CoreSyn,
+        CoreTidy,
+        CoreUnfold,
+        CoreUtils,
+        CostCentre,
+        CostCentreState,
+        Ctype,
+        DataCon,
+        Demand,
+        Digraph,
+        DriverPhases,
+        DynFlags,
+        Encoding,
+        EnumSet,
+        ErrUtils,
+        Exception,
+        FV,
+        FamInstEnv,
+        FastFunctions,
+        FastMutInt,
+        FastString,
+        FastStringEnv,
+        FieldLabel,
+        FileCleanup,
+        Fingerprint,
+        FiniteMap,
+        ForeignCall,
+        GHC.Exts.Heap,
+        GHC.Exts.Heap.ClosureTypes,
+        GHC.Exts.Heap.Closures,
+        GHC.Exts.Heap.Constants,
+        GHC.Exts.Heap.InfoTable,
+        GHC.Exts.Heap.InfoTable.Types,
+        GHC.Exts.Heap.InfoTableProf,
+        GHC.Exts.Heap.Utils,
+        GHC.ForeignSrcLang,
+        GHC.ForeignSrcLang.Type,
+        GHC.LanguageExtensions,
+        GHC.LanguageExtensions.Type,
+        GHC.Lexeme,
+        GHC.PackageDb,
+        GHC.Serialized,
+        GHCi.BreakArray,
+        GHCi.FFI,
+        GHCi.Message,
+        GHCi.RemoteTypes,
+        GHCi.TH.Binary,
+        GhcMonad,
+        GhcPrelude,
+        HaddockUtils,
+        Hooks,
+        HsBinds,
+        HsDecls,
+        HsDoc,
+        HsExpr,
+        HsExtension,
+        HsImpExp,
+        HsInstances,
+        HsLit,
+        HsPat,
+        HsSyn,
+        HsTypes,
+        HsUtils,
+        HscTypes,
+        IOEnv,
+        Id,
+        IdInfo,
+        IfaceSyn,
+        IfaceType,
+        InstEnv,
+        InteractiveEvalTypes,
+        Json,
+        Kind,
+        KnownUniques,
+        Language.Haskell.TH,
+        Language.Haskell.TH.LanguageExtensions,
+        Language.Haskell.TH.Lib,
+        Language.Haskell.TH.Lib.Internal,
+        Language.Haskell.TH.Lib.Map,
+        Language.Haskell.TH.Ppr,
+        Language.Haskell.TH.PprLib,
+        Language.Haskell.TH.Syntax,
+        Lexeme,
+        Lexer,
+        LinkerTypes,
+        ListSetOps,
+        Literal,
+        Maybes,
+        MkCore,
+        MkId,
+        Module,
+        MonadUtils,
+        Name,
+        NameCache,
+        NameEnv,
+        NameSet,
+        OccName,
+        OccurAnal,
+        OptCoercion,
+        OrdList,
+        Outputable,
+        PackageConfig,
+        Packages,
+        Pair,
+        Panic,
+        Parser,
+        PatSyn,
+        PipelineMonad,
+        PlaceHolder,
+        Platform,
+        PlatformConstants,
+        Plugins,
+        PmExpr,
+        PprColour,
+        PprCore,
+        PrelNames,
+        PrelRules,
+        Pretty,
+        PrimOp,
+        RdrHsSyn,
+        RdrName,
+        RepType,
+        Rules,
+        SizedSeq,
+        SrcLoc,
+        StringBuffer,
+        SysTools.BaseDir,
+        SysTools.Terminal,
+        TcEvidence,
+        TcRnTypes,
+        TcType,
+        ToIface,
+        TrieMap,
+        TyCoRep,
+        TyCon,
+        Type,
+        TysPrim,
+        TysWiredIn,
+        Unify,
+        UniqDFM,
+        UniqDSet,
+        UniqFM,
+        UniqSet,
+        UniqSupply,
+        Unique,
+        Util,
+        Var,
+        VarEnv,
+        VarSet
+    exposed-modules:
+        Paths_ghc_lib
+        Ar
+        AsmCodeGen
+        AsmUtils
+        BinIface
+        Bitmap
+        BlockId
+        BlockLayout
+        BuildTyCl
+        ByteCodeAsm
+        ByteCodeGen
+        ByteCodeInstr
+        ByteCodeItbls
+        ByteCodeLink
+        CFG
+        CLabel
+        CPrim
+        CSE
+        CallArity
+        CgUtils
+        Check
+        ClsInst
+        Cmm
+        CmmBuildInfoTables
+        CmmCallConv
+        CmmCommonBlockElim
+        CmmContFlowOpt
+        CmmExpr
+        CmmImplementSwitchPlans
+        CmmInfo
+        CmmLayoutStack
+        CmmLex
+        CmmLint
+        CmmLive
+        CmmMachOp
+        CmmMonad
+        CmmNode
+        CmmOpt
+        CmmParse
+        CmmPipeline
+        CmmProcPoint
+        CmmSink
+        CmmSwitch
+        CmmUtils
+        CodeGen.Platform
+        CodeGen.Platform.ARM
+        CodeGen.Platform.ARM64
+        CodeGen.Platform.NoRegs
+        CodeGen.Platform.PPC
+        CodeGen.Platform.SPARC
+        CodeGen.Platform.X86
+        CodeGen.Platform.X86_64
+        CodeOutput
+        Convert
+        CoreLint
+        CorePrep
+        CoreToStg
+        Coverage
+        Debug
+        Debugger
+        Desugar
+        DmdAnal
+        DriverBkp
+        DriverMkDepend
+        DriverPipeline
+        DsArrows
+        DsBinds
+        DsCCall
+        DsExpr
+        DsForeign
+        DsGRHSs
+        DsListComp
+        DsMeta
+        DsMonad
+        DsUsage
+        DsUtils
+        Dwarf
+        Dwarf.Constants
+        Dwarf.Types
+        DynamicLoading
+        Elf
+        Exitify
+        ExtractDocs
+        FamInst
+        Finder
+        FlagChecker
+        FloatIn
+        FloatOut
+        Format
+        FunDeps
+        GHC
+        GHC.HandleEncoding
+        GHCi
+        GHCi.BinaryArray
+        GHCi.CreateBCO
+        GHCi.InfoTable
+        GHCi.ObjLink
+        GHCi.ResolvedBCO
+        GHCi.Run
+        GHCi.Signals
+        GHCi.StaticPtrTable
+        GHCi.TH
+        GhcMake
+        GhcPlugins
+        GraphBase
+        GraphColor
+        GraphOps
+        GraphPpr
+        HeaderInfo
+        HieAst
+        HieBin
+        HieDebug
+        HieTypes
+        HieUtils
+        Hoopl.Block
+        Hoopl.Collections
+        Hoopl.Dataflow
+        Hoopl.Graph
+        Hoopl.Label
+        HsDumpAst
+        HscMain
+        HscStats
+        IfaceEnv
+        Inst
+        Instruction
+        InteractiveEval
+        Language.Haskell.TH.Quote
+        LiberateCase
+        Linker
+        ListT
+        Llvm
+        Llvm.AbsSyn
+        Llvm.MetaData
+        Llvm.PpLlvm
+        Llvm.Types
+        LlvmCodeGen
+        LlvmCodeGen.Base
+        LlvmCodeGen.CodeGen
+        LlvmCodeGen.Data
+        LlvmCodeGen.Ppr
+        LlvmCodeGen.Regs
+        LlvmMangler
+        LoadIface
+        Match
+        MatchCon
+        MatchLit
+        MkGraph
+        MkIface
+        NCGMonad
+        NameShape
+        PIC
+        PPC.CodeGen
+        PPC.Cond
+        PPC.Instr
+        PPC.Ppr
+        PPC.RegInfo
+        PPC.Regs
+        PprBase
+        PprC
+        PprCmm
+        PprCmmDecl
+        PprCmmExpr
+        PprTyThing
+        PrelInfo
+        ProfInit
+        Reg
+        RegAlloc.Graph.ArchBase
+        RegAlloc.Graph.ArchX86
+        RegAlloc.Graph.Coalesce
+        RegAlloc.Graph.Main
+        RegAlloc.Graph.Spill
+        RegAlloc.Graph.SpillClean
+        RegAlloc.Graph.SpillCost
+        RegAlloc.Graph.Stats
+        RegAlloc.Graph.TrivColorable
+        RegAlloc.Linear.Base
+        RegAlloc.Linear.FreeRegs
+        RegAlloc.Linear.JoinToTargets
+        RegAlloc.Linear.Main
+        RegAlloc.Linear.PPC.FreeRegs
+        RegAlloc.Linear.SPARC.FreeRegs
+        RegAlloc.Linear.StackMap
+        RegAlloc.Linear.State
+        RegAlloc.Linear.Stats
+        RegAlloc.Linear.X86.FreeRegs
+        RegAlloc.Linear.X86_64.FreeRegs
+        RegAlloc.Liveness
+        RegClass
+        RnBinds
+        RnEnv
+        RnExpr
+        RnFixity
+        RnHsDoc
+        RnModIface
+        RnNames
+        RnPat
+        RnSource
+        RnSplice
+        RnTypes
+        RnUnbound
+        RnUtils
+        RtClosureInspect
+        SAT
+        SMRep
+        SPARC.AddrMode
+        SPARC.Base
+        SPARC.CodeGen
+        SPARC.CodeGen.Amode
+        SPARC.CodeGen.Base
+        SPARC.CodeGen.CondCode
+        SPARC.CodeGen.Expand
+        SPARC.CodeGen.Gen32
+        SPARC.CodeGen.Gen64
+        SPARC.CodeGen.Sanity
+        SPARC.Cond
+        SPARC.Imm
+        SPARC.Instr
+        SPARC.Ppr
+        SPARC.Regs
+        SPARC.ShortcutJump
+        SPARC.Stack
+        SetLevels
+        SimplCore
+        SimplEnv
+        SimplMonad
+        SimplStg
+        SimplUtils
+        Simplify
+        SpecConstr
+        Specialise
+        State
+        StaticPtrTable
+        StgCmm
+        StgCmmArgRep
+        StgCmmBind
+        StgCmmClosure
+        StgCmmCon
+        StgCmmEnv
+        StgCmmExpr
+        StgCmmExtCode
+        StgCmmForeign
+        StgCmmHeap
+        StgCmmHpc
+        StgCmmLayout
+        StgCmmMonad
+        StgCmmPrim
+        StgCmmProf
+        StgCmmTicky
+        StgCmmUtils
+        StgCse
+        StgFVs
+        StgLiftLams
+        StgLiftLams.Analysis
+        StgLiftLams.LiftM
+        StgLiftLams.Transformation
+        StgLint
+        StgStats
+        StgSubst
+        StgSyn
+        Stream
+        SysTools
+        SysTools.ExtraObj
+        SysTools.Info
+        SysTools.Process
+        SysTools.Tasks
+        THNames
+        TargetReg
+        TcAnnotations
+        TcArrows
+        TcBackpack
+        TcBinds
+        TcCanonical
+        TcClassDcl
+        TcDefaults
+        TcDeriv
+        TcDerivInfer
+        TcDerivUtils
+        TcEnv
+        TcErrors
+        TcEvTerm
+        TcExpr
+        TcFlatten
+        TcForeign
+        TcGenDeriv
+        TcGenFunctor
+        TcGenGenerics
+        TcHoleErrors
+        TcHsSyn
+        TcHsType
+        TcIface
+        TcInstDcls
+        TcInteract
+        TcMType
+        TcMatches
+        TcPat
+        TcPatSyn
+        TcPluginM
+        TcRnDriver
+        TcRnExports
+        TcRnMonad
+        TcRules
+        TcSMonad
+        TcSigs
+        TcSimplify
+        TcSplice
+        TcTyClsDecls
+        TcTyDecls
+        TcTypeNats
+        TcTypeable
+        TcUnify
+        TcValidity
+        TidyPgm
+        TmOracle
+        UnVarGraph
+        UnariseStg
+        UniqMap
+        WorkWrap
+        WwLib
+        X86.CodeGen
+        X86.Cond
+        X86.Instr
+        X86.Ppr
+        X86.RegInfo
+        X86.Regs
+
+executable ghc-lib
+    default-language:   Haskell2010
+    if !os(windows)
+        build-depends: unix
+    else
+        build-depends: Win32
+    build-depends:
+        base == 4.*, array, bytestring, directory, process, filepath,
+        containers, deepseq, ghc-prim, haskeline, time, transformers,
+        ghc-lib
+    hs-source-dirs: ghc
+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS
+    cc-options: -DTHREADED_RTS
+    cpp-options: -DGHCI -DTHREADED_RTS -DGHC_LOADED_INTO_GHCI
+    other-modules:
+        GHCi.Leak
+        GHCi.UI
+        GHCi.UI.Info
+        GHCi.UI.Monad
+        GHCi.UI.Tags
+        GHCi.Util
+    other-extensions:
+        BangPatterns
+        CPP
+        FlexibleInstances
+        LambdaCase
+        MagicHash
+        MultiWayIf
+        NondecreasingIndentation
+        OverloadedStrings
+        RankNTypes
+        RecordWildCards
+        ScopedTypeVariables
+        TupleSections
+        UnboxedTuples
+        ViewPatterns
+    default-extensions: NoImplicitPrelude
+    main-is: Main.hs
diff --git a/ghc-lib/generated/DerivedConstants.h b/ghc-lib/generated/DerivedConstants.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/DerivedConstants.h
@@ -0,0 +1,554 @@
+/* This file is created automatically.  Do not edit by hand.*/
+
+#define CONTROL_GROUP_CONST_291 291
+#define STD_HDR_SIZE 1
+#define PROF_HDR_SIZE 2
+#define BLOCK_SIZE 4096
+#define MBLOCK_SIZE 1048576
+#define BLOCKS_PER_MBLOCK 252
+#define TICKY_BIN_COUNT 9
+#define OFFSET_StgRegTable_rR1 0
+#define OFFSET_StgRegTable_rR2 8
+#define OFFSET_StgRegTable_rR3 16
+#define OFFSET_StgRegTable_rR4 24
+#define OFFSET_StgRegTable_rR5 32
+#define OFFSET_StgRegTable_rR6 40
+#define OFFSET_StgRegTable_rR7 48
+#define OFFSET_StgRegTable_rR8 56
+#define OFFSET_StgRegTable_rR9 64
+#define OFFSET_StgRegTable_rR10 72
+#define OFFSET_StgRegTable_rF1 80
+#define OFFSET_StgRegTable_rF2 84
+#define OFFSET_StgRegTable_rF3 88
+#define OFFSET_StgRegTable_rF4 92
+#define OFFSET_StgRegTable_rF5 96
+#define OFFSET_StgRegTable_rF6 100
+#define OFFSET_StgRegTable_rD1 104
+#define OFFSET_StgRegTable_rD2 112
+#define OFFSET_StgRegTable_rD3 120
+#define OFFSET_StgRegTable_rD4 128
+#define OFFSET_StgRegTable_rD5 136
+#define OFFSET_StgRegTable_rD6 144
+#define OFFSET_StgRegTable_rXMM1 152
+#define OFFSET_StgRegTable_rXMM2 168
+#define OFFSET_StgRegTable_rXMM3 184
+#define OFFSET_StgRegTable_rXMM4 200
+#define OFFSET_StgRegTable_rXMM5 216
+#define OFFSET_StgRegTable_rXMM6 232
+#define OFFSET_StgRegTable_rYMM1 248
+#define OFFSET_StgRegTable_rYMM2 280
+#define OFFSET_StgRegTable_rYMM3 312
+#define OFFSET_StgRegTable_rYMM4 344
+#define OFFSET_StgRegTable_rYMM5 376
+#define OFFSET_StgRegTable_rYMM6 408
+#define OFFSET_StgRegTable_rZMM1 440
+#define OFFSET_StgRegTable_rZMM2 504
+#define OFFSET_StgRegTable_rZMM3 568
+#define OFFSET_StgRegTable_rZMM4 632
+#define OFFSET_StgRegTable_rZMM5 696
+#define OFFSET_StgRegTable_rZMM6 760
+#define OFFSET_StgRegTable_rL1 824
+#define OFFSET_StgRegTable_rSp 832
+#define OFFSET_StgRegTable_rSpLim 840
+#define OFFSET_StgRegTable_rHp 848
+#define OFFSET_StgRegTable_rHpLim 856
+#define OFFSET_StgRegTable_rCCCS 864
+#define OFFSET_StgRegTable_rCurrentTSO 872
+#define OFFSET_StgRegTable_rCurrentNursery 888
+#define OFFSET_StgRegTable_rHpAlloc 904
+#define OFFSET_StgRegTable_rRet 912
+#define REP_StgRegTable_rRet b64
+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]
+#define OFFSET_StgRegTable_rNursery 880
+#define REP_StgRegTable_rNursery b64
+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]
+#define OFFSET_stgEagerBlackholeInfo -24
+#define OFFSET_stgGCEnter1 -16
+#define OFFSET_stgGCFun -8
+#define OFFSET_Capability_r 24
+#define OFFSET_Capability_lock 1096
+#define OFFSET_Capability_no 944
+#define REP_Capability_no b32
+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]
+#define OFFSET_Capability_mut_lists 1016
+#define REP_Capability_mut_lists b64
+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]
+#define OFFSET_Capability_context_switch 1064
+#define REP_Capability_context_switch b32
+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]
+#define OFFSET_Capability_interrupt 1068
+#define REP_Capability_interrupt b32
+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]
+#define OFFSET_Capability_sparks 1200
+#define REP_Capability_sparks b64
+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]
+#define OFFSET_Capability_total_allocated 1072
+#define REP_Capability_total_allocated b64
+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]
+#define OFFSET_Capability_weak_ptr_list_hd 1048
+#define REP_Capability_weak_ptr_list_hd b64
+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]
+#define OFFSET_Capability_weak_ptr_list_tl 1056
+#define REP_Capability_weak_ptr_list_tl b64
+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]
+#define OFFSET_bdescr_start 0
+#define REP_bdescr_start b64
+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]
+#define OFFSET_bdescr_free 8
+#define REP_bdescr_free b64
+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]
+#define OFFSET_bdescr_blocks 48
+#define REP_bdescr_blocks b32
+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]
+#define OFFSET_bdescr_gen_no 40
+#define REP_bdescr_gen_no b16
+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]
+#define OFFSET_bdescr_link 16
+#define REP_bdescr_link b64
+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]
+#define OFFSET_bdescr_flags 46
+#define REP_bdescr_flags b16
+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]
+#define SIZEOF_generation 384
+#define OFFSET_generation_n_new_large_words 56
+#define REP_generation_n_new_large_words b64
+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]
+#define OFFSET_generation_weak_ptr_list 112
+#define REP_generation_weak_ptr_list b64
+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]
+#define SIZEOF_CostCentreStack 96
+#define OFFSET_CostCentreStack_ccsID 0
+#define REP_CostCentreStack_ccsID b64
+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]
+#define OFFSET_CostCentreStack_mem_alloc 72
+#define REP_CostCentreStack_mem_alloc b64
+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]
+#define OFFSET_CostCentreStack_scc_count 48
+#define REP_CostCentreStack_scc_count b64
+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]
+#define OFFSET_CostCentreStack_prevStack 16
+#define REP_CostCentreStack_prevStack b64
+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]
+#define OFFSET_CostCentre_ccID 0
+#define REP_CostCentre_ccID b64
+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]
+#define OFFSET_CostCentre_link 56
+#define REP_CostCentre_link b64
+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]
+#define OFFSET_StgHeader_info 0
+#define REP_StgHeader_info b64
+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]
+#define OFFSET_StgHeader_ccs 8
+#define REP_StgHeader_ccs b64
+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]
+#define OFFSET_StgHeader_ldvw 16
+#define REP_StgHeader_ldvw b64
+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]
+#define SIZEOF_StgSMPThunkHeader 8
+#define OFFSET_StgClosure_payload 0
+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]
+#define OFFSET_StgEntCounter_allocs 48
+#define REP_StgEntCounter_allocs b64
+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]
+#define OFFSET_StgEntCounter_allocd 16
+#define REP_StgEntCounter_allocd b64
+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]
+#define OFFSET_StgEntCounter_registeredp 0
+#define REP_StgEntCounter_registeredp b64
+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]
+#define OFFSET_StgEntCounter_link 56
+#define REP_StgEntCounter_link b64
+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]
+#define OFFSET_StgEntCounter_entry_count 40
+#define REP_StgEntCounter_entry_count b64
+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]
+#define SIZEOF_StgUpdateFrame_NoHdr 8
+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)
+#define SIZEOF_StgCatchFrame_NoHdr 16
+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)
+#define SIZEOF_StgStopFrame_NoHdr 0
+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)
+#define SIZEOF_StgMutArrPtrs_NoHdr 16
+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)
+#define OFFSET_StgMutArrPtrs_ptrs 0
+#define REP_StgMutArrPtrs_ptrs b64
+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]
+#define OFFSET_StgMutArrPtrs_size 8
+#define REP_StgMutArrPtrs_size b64
+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]
+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8
+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)
+#define OFFSET_StgSmallMutArrPtrs_ptrs 0
+#define REP_StgSmallMutArrPtrs_ptrs b64
+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]
+#define SIZEOF_StgArrBytes_NoHdr 8
+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)
+#define OFFSET_StgArrBytes_bytes 0
+#define REP_StgArrBytes_bytes b64
+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]
+#define OFFSET_StgArrBytes_payload 8
+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]
+#define OFFSET_StgTSO__link 0
+#define REP_StgTSO__link b64
+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]
+#define OFFSET_StgTSO_global_link 8
+#define REP_StgTSO_global_link b64
+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]
+#define OFFSET_StgTSO_what_next 24
+#define REP_StgTSO_what_next b16
+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]
+#define OFFSET_StgTSO_why_blocked 26
+#define REP_StgTSO_why_blocked b16
+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]
+#define OFFSET_StgTSO_block_info 32
+#define REP_StgTSO_block_info b64
+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]
+#define OFFSET_StgTSO_blocked_exceptions 80
+#define REP_StgTSO_blocked_exceptions b64
+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]
+#define OFFSET_StgTSO_id 40
+#define REP_StgTSO_id b32
+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]
+#define OFFSET_StgTSO_cap 64
+#define REP_StgTSO_cap b64
+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]
+#define OFFSET_StgTSO_saved_errno 44
+#define REP_StgTSO_saved_errno b32
+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]
+#define OFFSET_StgTSO_trec 72
+#define REP_StgTSO_trec b64
+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]
+#define OFFSET_StgTSO_flags 28
+#define REP_StgTSO_flags b32
+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]
+#define OFFSET_StgTSO_dirty 48
+#define REP_StgTSO_dirty b32
+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]
+#define OFFSET_StgTSO_bq 88
+#define REP_StgTSO_bq b64
+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]
+#define OFFSET_StgTSO_alloc_limit 96
+#define REP_StgTSO_alloc_limit b64
+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]
+#define OFFSET_StgTSO_cccs 112
+#define REP_StgTSO_cccs b64
+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]
+#define OFFSET_StgTSO_stackobj 16
+#define REP_StgTSO_stackobj b64
+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]
+#define OFFSET_StgStack_sp 8
+#define REP_StgStack_sp b64
+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]
+#define OFFSET_StgStack_stack 16
+#define OFFSET_StgStack_stack_size 0
+#define REP_StgStack_stack_size b32
+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]
+#define OFFSET_StgStack_dirty 4
+#define REP_StgStack_dirty b32
+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]
+#define SIZEOF_StgTSOProfInfo 8
+#define OFFSET_StgUpdateFrame_updatee 0
+#define REP_StgUpdateFrame_updatee b64
+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]
+#define OFFSET_StgCatchFrame_handler 8
+#define REP_StgCatchFrame_handler b64
+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]
+#define OFFSET_StgCatchFrame_exceptions_blocked 0
+#define REP_StgCatchFrame_exceptions_blocked b64
+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]
+#define SIZEOF_StgPAP_NoHdr 16
+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)
+#define OFFSET_StgPAP_n_args 4
+#define REP_StgPAP_n_args b32
+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]
+#define OFFSET_StgPAP_fun 8
+#define REP_StgPAP_fun gcptr
+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]
+#define OFFSET_StgPAP_arity 0
+#define REP_StgPAP_arity b32
+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]
+#define OFFSET_StgPAP_payload 16
+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]
+#define SIZEOF_StgAP_NoThunkHdr 16
+#define SIZEOF_StgAP_NoHdr 24
+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)
+#define OFFSET_StgAP_n_args 12
+#define REP_StgAP_n_args b32
+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]
+#define OFFSET_StgAP_fun 16
+#define REP_StgAP_fun gcptr
+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]
+#define OFFSET_StgAP_payload 24
+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]
+#define SIZEOF_StgAP_STACK_NoThunkHdr 16
+#define SIZEOF_StgAP_STACK_NoHdr 24
+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)
+#define OFFSET_StgAP_STACK_size 8
+#define REP_StgAP_STACK_size b64
+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]
+#define OFFSET_StgAP_STACK_fun 16
+#define REP_StgAP_STACK_fun gcptr
+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]
+#define OFFSET_StgAP_STACK_payload 24
+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]
+#define SIZEOF_StgSelector_NoThunkHdr 8
+#define SIZEOF_StgSelector_NoHdr 16
+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)
+#define OFFSET_StgInd_indirectee 0
+#define REP_StgInd_indirectee gcptr
+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]
+#define SIZEOF_StgMutVar_NoHdr 8
+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)
+#define OFFSET_StgMutVar_var 0
+#define REP_StgMutVar_var b64
+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]
+#define SIZEOF_StgAtomicallyFrame_NoHdr 16
+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)
+#define OFFSET_StgAtomicallyFrame_code 0
+#define REP_StgAtomicallyFrame_code b64
+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]
+#define OFFSET_StgAtomicallyFrame_result 8
+#define REP_StgAtomicallyFrame_result b64
+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]
+#define OFFSET_StgTRecHeader_enclosing_trec 0
+#define REP_StgTRecHeader_enclosing_trec b64
+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]
+#define SIZEOF_StgCatchSTMFrame_NoHdr 16
+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)
+#define OFFSET_StgCatchSTMFrame_handler 8
+#define REP_StgCatchSTMFrame_handler b64
+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]
+#define OFFSET_StgCatchSTMFrame_code 0
+#define REP_StgCatchSTMFrame_code b64
+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]
+#define SIZEOF_StgCatchRetryFrame_NoHdr 24
+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)
+#define OFFSET_StgCatchRetryFrame_running_alt_code 0
+#define REP_StgCatchRetryFrame_running_alt_code b64
+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]
+#define OFFSET_StgCatchRetryFrame_first_code 8
+#define REP_StgCatchRetryFrame_first_code b64
+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]
+#define OFFSET_StgCatchRetryFrame_alt_code 16
+#define REP_StgCatchRetryFrame_alt_code b64
+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]
+#define OFFSET_StgTVarWatchQueue_closure 0
+#define REP_StgTVarWatchQueue_closure b64
+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]
+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8
+#define REP_StgTVarWatchQueue_next_queue_entry b64
+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]
+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16
+#define REP_StgTVarWatchQueue_prev_queue_entry b64
+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]
+#define SIZEOF_StgTVar_NoHdr 24
+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)
+#define OFFSET_StgTVar_current_value 0
+#define REP_StgTVar_current_value b64
+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]
+#define OFFSET_StgTVar_first_watch_queue_entry 8
+#define REP_StgTVar_first_watch_queue_entry b64
+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]
+#define OFFSET_StgTVar_num_updates 16
+#define REP_StgTVar_num_updates b64
+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]
+#define SIZEOF_StgWeak_NoHdr 40
+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)
+#define OFFSET_StgWeak_link 32
+#define REP_StgWeak_link b64
+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]
+#define OFFSET_StgWeak_key 8
+#define REP_StgWeak_key b64
+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]
+#define OFFSET_StgWeak_value 16
+#define REP_StgWeak_value b64
+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]
+#define OFFSET_StgWeak_finalizer 24
+#define REP_StgWeak_finalizer b64
+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]
+#define OFFSET_StgWeak_cfinalizers 0
+#define REP_StgWeak_cfinalizers b64
+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]
+#define SIZEOF_StgCFinalizerList_NoHdr 40
+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)
+#define OFFSET_StgCFinalizerList_link 0
+#define REP_StgCFinalizerList_link b64
+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]
+#define OFFSET_StgCFinalizerList_fptr 8
+#define REP_StgCFinalizerList_fptr b64
+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]
+#define OFFSET_StgCFinalizerList_ptr 16
+#define REP_StgCFinalizerList_ptr b64
+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]
+#define OFFSET_StgCFinalizerList_eptr 24
+#define REP_StgCFinalizerList_eptr b64
+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]
+#define OFFSET_StgCFinalizerList_flag 32
+#define REP_StgCFinalizerList_flag b64
+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]
+#define SIZEOF_StgMVar_NoHdr 24
+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)
+#define OFFSET_StgMVar_head 0
+#define REP_StgMVar_head b64
+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]
+#define OFFSET_StgMVar_tail 8
+#define REP_StgMVar_tail b64
+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]
+#define OFFSET_StgMVar_value 16
+#define REP_StgMVar_value b64
+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]
+#define SIZEOF_StgMVarTSOQueue_NoHdr 16
+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)
+#define OFFSET_StgMVarTSOQueue_link 0
+#define REP_StgMVarTSOQueue_link b64
+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]
+#define OFFSET_StgMVarTSOQueue_tso 8
+#define REP_StgMVarTSOQueue_tso b64
+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]
+#define SIZEOF_StgBCO_NoHdr 32
+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)
+#define OFFSET_StgBCO_instrs 0
+#define REP_StgBCO_instrs b64
+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]
+#define OFFSET_StgBCO_literals 8
+#define REP_StgBCO_literals b64
+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]
+#define OFFSET_StgBCO_ptrs 16
+#define REP_StgBCO_ptrs b64
+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]
+#define OFFSET_StgBCO_arity 24
+#define REP_StgBCO_arity b32
+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]
+#define OFFSET_StgBCO_size 28
+#define REP_StgBCO_size b32
+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]
+#define OFFSET_StgBCO_bitmap 32
+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]
+#define SIZEOF_StgStableName_NoHdr 8
+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)
+#define OFFSET_StgStableName_sn 0
+#define REP_StgStableName_sn b64
+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]
+#define SIZEOF_StgBlockingQueue_NoHdr 32
+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)
+#define OFFSET_StgBlockingQueue_bh 8
+#define REP_StgBlockingQueue_bh b64
+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]
+#define OFFSET_StgBlockingQueue_owner 16
+#define REP_StgBlockingQueue_owner b64
+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]
+#define OFFSET_StgBlockingQueue_queue 24
+#define REP_StgBlockingQueue_queue b64
+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]
+#define OFFSET_StgBlockingQueue_link 0
+#define REP_StgBlockingQueue_link b64
+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]
+#define SIZEOF_MessageBlackHole_NoHdr 24
+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)
+#define OFFSET_MessageBlackHole_link 0
+#define REP_MessageBlackHole_link b64
+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]
+#define OFFSET_MessageBlackHole_tso 8
+#define REP_MessageBlackHole_tso b64
+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]
+#define OFFSET_MessageBlackHole_bh 16
+#define REP_MessageBlackHole_bh b64
+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]
+#define SIZEOF_StgCompactNFData_NoHdr 64
+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64)
+#define OFFSET_StgCompactNFData_totalW 0
+#define REP_StgCompactNFData_totalW b64
+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]
+#define OFFSET_StgCompactNFData_autoBlockW 8
+#define REP_StgCompactNFData_autoBlockW b64
+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]
+#define OFFSET_StgCompactNFData_nursery 32
+#define REP_StgCompactNFData_nursery b64
+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]
+#define OFFSET_StgCompactNFData_last 40
+#define REP_StgCompactNFData_last b64
+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]
+#define OFFSET_StgCompactNFData_hp 16
+#define REP_StgCompactNFData_hp b64
+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]
+#define OFFSET_StgCompactNFData_hpLim 24
+#define REP_StgCompactNFData_hpLim b64
+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]
+#define OFFSET_StgCompactNFData_hash 48
+#define REP_StgCompactNFData_hash b64
+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]
+#define OFFSET_StgCompactNFData_result 56
+#define REP_StgCompactNFData_result b64
+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]
+#define SIZEOF_StgCompactNFDataBlock 24
+#define OFFSET_StgCompactNFDataBlock_self 0
+#define REP_StgCompactNFDataBlock_self b64
+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]
+#define OFFSET_StgCompactNFDataBlock_owner 8
+#define REP_StgCompactNFDataBlock_owner b64
+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]
+#define OFFSET_StgCompactNFDataBlock_next 16
+#define REP_StgCompactNFDataBlock_next b64
+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]
+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 269
+#define REP_RtsFlags_ProfFlags_showCCSOnException b8
+#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]
+#define OFFSET_RtsFlags_DebugFlags_apply 210
+#define REP_RtsFlags_DebugFlags_apply b8
+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]
+#define OFFSET_RtsFlags_DebugFlags_sanity 206
+#define REP_RtsFlags_DebugFlags_sanity b8
+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]
+#define OFFSET_RtsFlags_DebugFlags_weak 202
+#define REP_RtsFlags_DebugFlags_weak b8
+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]
+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16
+#define REP_RtsFlags_GcFlags_initialStkSize b32
+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]
+#define OFFSET_RtsFlags_MiscFlags_tickInterval 176
+#define REP_RtsFlags_MiscFlags_tickInterval b64
+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]
+#define SIZEOF_StgFunInfoExtraFwd 32
+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24
+#define REP_StgFunInfoExtraFwd_slow_apply b64
+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]
+#define OFFSET_StgFunInfoExtraFwd_fun_type 0
+#define REP_StgFunInfoExtraFwd_fun_type b32
+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]
+#define OFFSET_StgFunInfoExtraFwd_arity 4
+#define REP_StgFunInfoExtraFwd_arity b32
+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]
+#define OFFSET_StgFunInfoExtraFwd_bitmap 16
+#define REP_StgFunInfoExtraFwd_bitmap b64
+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]
+#define SIZEOF_StgFunInfoExtraRev 24
+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0
+#define REP_StgFunInfoExtraRev_slow_apply_offset b32
+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]
+#define OFFSET_StgFunInfoExtraRev_fun_type 16
+#define REP_StgFunInfoExtraRev_fun_type b32
+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]
+#define OFFSET_StgFunInfoExtraRev_arity 20
+#define REP_StgFunInfoExtraRev_arity b32
+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]
+#define OFFSET_StgFunInfoExtraRev_bitmap 8
+#define REP_StgFunInfoExtraRev_bitmap b64
+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]
+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8
+#define REP_StgFunInfoExtraRev_bitmap_offset b32
+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]
+#define OFFSET_StgLargeBitmap_size 0
+#define REP_StgLargeBitmap_size b64
+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]
+#define OFFSET_StgLargeBitmap_bitmap 8
+#define SIZEOF_snEntry 24
+#define OFFSET_snEntry_sn_obj 16
+#define REP_snEntry_sn_obj b64
+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]
+#define OFFSET_snEntry_addr 0
+#define REP_snEntry_addr b64
+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]
+#define SIZEOF_spEntry 8
+#define OFFSET_spEntry_addr 0
+#define REP_spEntry_addr b64
+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
diff --git a/ghc-lib/generated/GHCConstantsHaskellExports.hs b/ghc-lib/generated/GHCConstantsHaskellExports.hs
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/GHCConstantsHaskellExports.hs
@@ -0,0 +1,125 @@
+    cONTROL_GROUP_CONST_291,
+    sTD_HDR_SIZE,
+    pROF_HDR_SIZE,
+    bLOCK_SIZE,
+    bLOCKS_PER_MBLOCK,
+    tICKY_BIN_COUNT,
+    oFFSET_StgRegTable_rR1,
+    oFFSET_StgRegTable_rR2,
+    oFFSET_StgRegTable_rR3,
+    oFFSET_StgRegTable_rR4,
+    oFFSET_StgRegTable_rR5,
+    oFFSET_StgRegTable_rR6,
+    oFFSET_StgRegTable_rR7,
+    oFFSET_StgRegTable_rR8,
+    oFFSET_StgRegTable_rR9,
+    oFFSET_StgRegTable_rR10,
+    oFFSET_StgRegTable_rF1,
+    oFFSET_StgRegTable_rF2,
+    oFFSET_StgRegTable_rF3,
+    oFFSET_StgRegTable_rF4,
+    oFFSET_StgRegTable_rF5,
+    oFFSET_StgRegTable_rF6,
+    oFFSET_StgRegTable_rD1,
+    oFFSET_StgRegTable_rD2,
+    oFFSET_StgRegTable_rD3,
+    oFFSET_StgRegTable_rD4,
+    oFFSET_StgRegTable_rD5,
+    oFFSET_StgRegTable_rD6,
+    oFFSET_StgRegTable_rXMM1,
+    oFFSET_StgRegTable_rXMM2,
+    oFFSET_StgRegTable_rXMM3,
+    oFFSET_StgRegTable_rXMM4,
+    oFFSET_StgRegTable_rXMM5,
+    oFFSET_StgRegTable_rXMM6,
+    oFFSET_StgRegTable_rYMM1,
+    oFFSET_StgRegTable_rYMM2,
+    oFFSET_StgRegTable_rYMM3,
+    oFFSET_StgRegTable_rYMM4,
+    oFFSET_StgRegTable_rYMM5,
+    oFFSET_StgRegTable_rYMM6,
+    oFFSET_StgRegTable_rZMM1,
+    oFFSET_StgRegTable_rZMM2,
+    oFFSET_StgRegTable_rZMM3,
+    oFFSET_StgRegTable_rZMM4,
+    oFFSET_StgRegTable_rZMM5,
+    oFFSET_StgRegTable_rZMM6,
+    oFFSET_StgRegTable_rL1,
+    oFFSET_StgRegTable_rSp,
+    oFFSET_StgRegTable_rSpLim,
+    oFFSET_StgRegTable_rHp,
+    oFFSET_StgRegTable_rHpLim,
+    oFFSET_StgRegTable_rCCCS,
+    oFFSET_StgRegTable_rCurrentTSO,
+    oFFSET_StgRegTable_rCurrentNursery,
+    oFFSET_StgRegTable_rHpAlloc,
+    oFFSET_stgEagerBlackholeInfo,
+    oFFSET_stgGCEnter1,
+    oFFSET_stgGCFun,
+    oFFSET_Capability_r,
+    oFFSET_bdescr_start,
+    oFFSET_bdescr_free,
+    oFFSET_bdescr_blocks,
+    oFFSET_bdescr_flags,
+    sIZEOF_CostCentreStack,
+    oFFSET_CostCentreStack_mem_alloc,
+    oFFSET_CostCentreStack_scc_count,
+    oFFSET_StgHeader_ccs,
+    oFFSET_StgHeader_ldvw,
+    sIZEOF_StgSMPThunkHeader,
+    oFFSET_StgEntCounter_allocs,
+    oFFSET_StgEntCounter_allocd,
+    oFFSET_StgEntCounter_registeredp,
+    oFFSET_StgEntCounter_link,
+    oFFSET_StgEntCounter_entry_count,
+    sIZEOF_StgUpdateFrame_NoHdr,
+    sIZEOF_StgMutArrPtrs_NoHdr,
+    oFFSET_StgMutArrPtrs_ptrs,
+    oFFSET_StgMutArrPtrs_size,
+    sIZEOF_StgSmallMutArrPtrs_NoHdr,
+    oFFSET_StgSmallMutArrPtrs_ptrs,
+    sIZEOF_StgArrBytes_NoHdr,
+    oFFSET_StgArrBytes_bytes,
+    oFFSET_StgTSO_alloc_limit,
+    oFFSET_StgTSO_cccs,
+    oFFSET_StgTSO_stackobj,
+    oFFSET_StgStack_sp,
+    oFFSET_StgStack_stack,
+    oFFSET_StgUpdateFrame_updatee,
+    oFFSET_StgFunInfoExtraFwd_arity,
+    sIZEOF_StgFunInfoExtraRev,
+    oFFSET_StgFunInfoExtraRev_arity,
+    mAX_SPEC_SELECTEE_SIZE,
+    mAX_SPEC_AP_SIZE,
+    mIN_PAYLOAD_SIZE,
+    mIN_INTLIKE,
+    mAX_INTLIKE,
+    mIN_CHARLIKE,
+    mAX_CHARLIKE,
+    mUT_ARR_PTRS_CARD_BITS,
+    mAX_Vanilla_REG,
+    mAX_Float_REG,
+    mAX_Double_REG,
+    mAX_Long_REG,
+    mAX_XMM_REG,
+    mAX_Real_Vanilla_REG,
+    mAX_Real_Float_REG,
+    mAX_Real_Double_REG,
+    mAX_Real_XMM_REG,
+    mAX_Real_Long_REG,
+    rESERVED_C_STACK_BYTES,
+    rESERVED_STACK_WORDS,
+    aP_STACK_SPLIM,
+    wORD_SIZE,
+    dOUBLE_SIZE,
+    cINT_SIZE,
+    cLONG_SIZE,
+    cLONG_LONG_SIZE,
+    bITMAP_BITS_SHIFT,
+    tAG_BITS,
+    wORDS_BIGENDIAN,
+    dYNAMIC_BY_DEFAULT,
+    lDV_SHIFT,
+    iLDV_CREATE_MASK,
+    iLDV_STATE_CREATE,
+    iLDV_STATE_USE,
diff --git a/ghc-lib/generated/GHCConstantsHaskellType.hs b/ghc-lib/generated/GHCConstantsHaskellType.hs
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/GHCConstantsHaskellType.hs
@@ -0,0 +1,134 @@
+data PlatformConstants = PlatformConstants {
+    pc_platformConstants :: ()
+    , pc_CONTROL_GROUP_CONST_291 :: Int
+    , pc_STD_HDR_SIZE :: Int
+    , pc_PROF_HDR_SIZE :: Int
+    , pc_BLOCK_SIZE :: Int
+    , pc_BLOCKS_PER_MBLOCK :: Int
+    , pc_TICKY_BIN_COUNT :: Int
+    , pc_OFFSET_StgRegTable_rR1 :: Int
+    , pc_OFFSET_StgRegTable_rR2 :: Int
+    , pc_OFFSET_StgRegTable_rR3 :: Int
+    , pc_OFFSET_StgRegTable_rR4 :: Int
+    , pc_OFFSET_StgRegTable_rR5 :: Int
+    , pc_OFFSET_StgRegTable_rR6 :: Int
+    , pc_OFFSET_StgRegTable_rR7 :: Int
+    , pc_OFFSET_StgRegTable_rR8 :: Int
+    , pc_OFFSET_StgRegTable_rR9 :: Int
+    , pc_OFFSET_StgRegTable_rR10 :: Int
+    , pc_OFFSET_StgRegTable_rF1 :: Int
+    , pc_OFFSET_StgRegTable_rF2 :: Int
+    , pc_OFFSET_StgRegTable_rF3 :: Int
+    , pc_OFFSET_StgRegTable_rF4 :: Int
+    , pc_OFFSET_StgRegTable_rF5 :: Int
+    , pc_OFFSET_StgRegTable_rF6 :: Int
+    , pc_OFFSET_StgRegTable_rD1 :: Int
+    , pc_OFFSET_StgRegTable_rD2 :: Int
+    , pc_OFFSET_StgRegTable_rD3 :: Int
+    , pc_OFFSET_StgRegTable_rD4 :: Int
+    , pc_OFFSET_StgRegTable_rD5 :: Int
+    , pc_OFFSET_StgRegTable_rD6 :: Int
+    , pc_OFFSET_StgRegTable_rXMM1 :: Int
+    , pc_OFFSET_StgRegTable_rXMM2 :: Int
+    , pc_OFFSET_StgRegTable_rXMM3 :: Int
+    , pc_OFFSET_StgRegTable_rXMM4 :: Int
+    , pc_OFFSET_StgRegTable_rXMM5 :: Int
+    , pc_OFFSET_StgRegTable_rXMM6 :: Int
+    , pc_OFFSET_StgRegTable_rYMM1 :: Int
+    , pc_OFFSET_StgRegTable_rYMM2 :: Int
+    , pc_OFFSET_StgRegTable_rYMM3 :: Int
+    , pc_OFFSET_StgRegTable_rYMM4 :: Int
+    , pc_OFFSET_StgRegTable_rYMM5 :: Int
+    , pc_OFFSET_StgRegTable_rYMM6 :: Int
+    , pc_OFFSET_StgRegTable_rZMM1 :: Int
+    , pc_OFFSET_StgRegTable_rZMM2 :: Int
+    , pc_OFFSET_StgRegTable_rZMM3 :: Int
+    , pc_OFFSET_StgRegTable_rZMM4 :: Int
+    , pc_OFFSET_StgRegTable_rZMM5 :: Int
+    , pc_OFFSET_StgRegTable_rZMM6 :: Int
+    , pc_OFFSET_StgRegTable_rL1 :: Int
+    , pc_OFFSET_StgRegTable_rSp :: Int
+    , pc_OFFSET_StgRegTable_rSpLim :: Int
+    , pc_OFFSET_StgRegTable_rHp :: Int
+    , pc_OFFSET_StgRegTable_rHpLim :: Int
+    , pc_OFFSET_StgRegTable_rCCCS :: Int
+    , pc_OFFSET_StgRegTable_rCurrentTSO :: Int
+    , pc_OFFSET_StgRegTable_rCurrentNursery :: Int
+    , pc_OFFSET_StgRegTable_rHpAlloc :: Int
+    , pc_OFFSET_stgEagerBlackholeInfo :: Int
+    , pc_OFFSET_stgGCEnter1 :: Int
+    , pc_OFFSET_stgGCFun :: Int
+    , pc_OFFSET_Capability_r :: Int
+    , pc_OFFSET_bdescr_start :: Int
+    , pc_OFFSET_bdescr_free :: Int
+    , pc_OFFSET_bdescr_blocks :: Int
+    , pc_OFFSET_bdescr_flags :: Int
+    , pc_SIZEOF_CostCentreStack :: Int
+    , pc_OFFSET_CostCentreStack_mem_alloc :: Int
+    , pc_REP_CostCentreStack_mem_alloc :: Int
+    , pc_OFFSET_CostCentreStack_scc_count :: Int
+    , pc_REP_CostCentreStack_scc_count :: Int
+    , pc_OFFSET_StgHeader_ccs :: Int
+    , pc_OFFSET_StgHeader_ldvw :: Int
+    , pc_SIZEOF_StgSMPThunkHeader :: Int
+    , pc_OFFSET_StgEntCounter_allocs :: Int
+    , pc_REP_StgEntCounter_allocs :: Int
+    , pc_OFFSET_StgEntCounter_allocd :: Int
+    , pc_REP_StgEntCounter_allocd :: Int
+    , pc_OFFSET_StgEntCounter_registeredp :: Int
+    , pc_OFFSET_StgEntCounter_link :: Int
+    , pc_OFFSET_StgEntCounter_entry_count :: Int
+    , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int
+    , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int
+    , pc_OFFSET_StgMutArrPtrs_ptrs :: Int
+    , pc_OFFSET_StgMutArrPtrs_size :: Int
+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int
+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int
+    , pc_SIZEOF_StgArrBytes_NoHdr :: Int
+    , pc_OFFSET_StgArrBytes_bytes :: Int
+    , pc_OFFSET_StgTSO_alloc_limit :: Int
+    , pc_OFFSET_StgTSO_cccs :: Int
+    , pc_OFFSET_StgTSO_stackobj :: Int
+    , pc_OFFSET_StgStack_sp :: Int
+    , pc_OFFSET_StgStack_stack :: Int
+    , pc_OFFSET_StgUpdateFrame_updatee :: Int
+    , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int
+    , pc_REP_StgFunInfoExtraFwd_arity :: Int
+    , pc_SIZEOF_StgFunInfoExtraRev :: Int
+    , pc_OFFSET_StgFunInfoExtraRev_arity :: Int
+    , pc_REP_StgFunInfoExtraRev_arity :: Int
+    , pc_MAX_SPEC_SELECTEE_SIZE :: Int
+    , pc_MAX_SPEC_AP_SIZE :: Int
+    , pc_MIN_PAYLOAD_SIZE :: Int
+    , pc_MIN_INTLIKE :: Int
+    , pc_MAX_INTLIKE :: Int
+    , pc_MIN_CHARLIKE :: Int
+    , pc_MAX_CHARLIKE :: Int
+    , pc_MUT_ARR_PTRS_CARD_BITS :: Int
+    , pc_MAX_Vanilla_REG :: Int
+    , pc_MAX_Float_REG :: Int
+    , pc_MAX_Double_REG :: Int
+    , pc_MAX_Long_REG :: Int
+    , pc_MAX_XMM_REG :: Int
+    , pc_MAX_Real_Vanilla_REG :: Int
+    , pc_MAX_Real_Float_REG :: Int
+    , pc_MAX_Real_Double_REG :: Int
+    , pc_MAX_Real_XMM_REG :: Int
+    , pc_MAX_Real_Long_REG :: Int
+    , pc_RESERVED_C_STACK_BYTES :: Int
+    , pc_RESERVED_STACK_WORDS :: Int
+    , pc_AP_STACK_SPLIM :: Int
+    , pc_WORD_SIZE :: Int
+    , pc_DOUBLE_SIZE :: Int
+    , pc_CINT_SIZE :: Int
+    , pc_CLONG_SIZE :: Int
+    , pc_CLONG_LONG_SIZE :: Int
+    , pc_BITMAP_BITS_SHIFT :: Int
+    , pc_TAG_BITS :: Int
+    , pc_WORDS_BIGENDIAN :: Bool
+    , pc_DYNAMIC_BY_DEFAULT :: Bool
+    , pc_LDV_SHIFT :: Int
+    , pc_ILDV_CREATE_MASK :: Integer
+    , pc_ILDV_STATE_CREATE :: Integer
+    , pc_ILDV_STATE_USE :: Integer
+  } deriving Read
diff --git a/ghc-lib/generated/GHCConstantsHaskellWrappers.hs b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs
@@ -0,0 +1,250 @@
+cONTROL_GROUP_CONST_291 :: DynFlags -> Int
+cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags))
+sTD_HDR_SIZE :: DynFlags -> Int
+sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags))
+pROF_HDR_SIZE :: DynFlags -> Int
+pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags))
+bLOCK_SIZE :: DynFlags -> Int
+bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags))
+bLOCKS_PER_MBLOCK :: DynFlags -> Int
+bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags))
+tICKY_BIN_COUNT :: DynFlags -> Int
+tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR1 :: DynFlags -> Int
+oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR2 :: DynFlags -> Int
+oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR3 :: DynFlags -> Int
+oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR4 :: DynFlags -> Int
+oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR5 :: DynFlags -> Int
+oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR6 :: DynFlags -> Int
+oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR7 :: DynFlags -> Int
+oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR8 :: DynFlags -> Int
+oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR9 :: DynFlags -> Int
+oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR10 :: DynFlags -> Int
+oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF1 :: DynFlags -> Int
+oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF2 :: DynFlags -> Int
+oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF3 :: DynFlags -> Int
+oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF4 :: DynFlags -> Int
+oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF5 :: DynFlags -> Int
+oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF6 :: DynFlags -> Int
+oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD1 :: DynFlags -> Int
+oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD2 :: DynFlags -> Int
+oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD3 :: DynFlags -> Int
+oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD4 :: DynFlags -> Int
+oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD5 :: DynFlags -> Int
+oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD6 :: DynFlags -> Int
+oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rL1 :: DynFlags -> Int
+oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rSp :: DynFlags -> Int
+oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rSpLim :: DynFlags -> Int
+oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rHp :: DynFlags -> Int
+oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rHpLim :: DynFlags -> Int
+oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rCCCS :: DynFlags -> Int
+oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int
+oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int
+oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int
+oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags))
+oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int
+oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags))
+oFFSET_stgGCEnter1 :: DynFlags -> Int
+oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags))
+oFFSET_stgGCFun :: DynFlags -> Int
+oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags))
+oFFSET_Capability_r :: DynFlags -> Int
+oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags))
+oFFSET_bdescr_start :: DynFlags -> Int
+oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags))
+oFFSET_bdescr_free :: DynFlags -> Int
+oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags))
+oFFSET_bdescr_blocks :: DynFlags -> Int
+oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags))
+oFFSET_bdescr_flags :: DynFlags -> Int
+oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags))
+sIZEOF_CostCentreStack :: DynFlags -> Int
+sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags))
+oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int
+oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags))
+oFFSET_CostCentreStack_scc_count :: DynFlags -> Int
+oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags))
+oFFSET_StgHeader_ccs :: DynFlags -> Int
+oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags))
+oFFSET_StgHeader_ldvw :: DynFlags -> Int
+oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags))
+sIZEOF_StgSMPThunkHeader :: DynFlags -> Int
+sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_allocs :: DynFlags -> Int
+oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_allocd :: DynFlags -> Int
+oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_registeredp :: DynFlags -> Int
+oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_link :: DynFlags -> Int
+oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_entry_count :: DynFlags -> Int
+oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags))
+sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int
+sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags))
+sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int
+sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))
+oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int
+oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags))
+oFFSET_StgMutArrPtrs_size :: DynFlags -> Int
+oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags))
+sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int
+sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))
+oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int
+oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags))
+sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int
+sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags))
+oFFSET_StgArrBytes_bytes :: DynFlags -> Int
+oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags))
+oFFSET_StgTSO_alloc_limit :: DynFlags -> Int
+oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags))
+oFFSET_StgTSO_cccs :: DynFlags -> Int
+oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags))
+oFFSET_StgTSO_stackobj :: DynFlags -> Int
+oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags))
+oFFSET_StgStack_sp :: DynFlags -> Int
+oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags))
+oFFSET_StgStack_stack :: DynFlags -> Int
+oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags))
+oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int
+oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags))
+oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int
+oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags))
+sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int
+sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags))
+oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int
+oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags))
+mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int
+mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags))
+mAX_SPEC_AP_SIZE :: DynFlags -> Int
+mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags))
+mIN_PAYLOAD_SIZE :: DynFlags -> Int
+mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags))
+mIN_INTLIKE :: DynFlags -> Int
+mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags))
+mAX_INTLIKE :: DynFlags -> Int
+mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags))
+mIN_CHARLIKE :: DynFlags -> Int
+mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags))
+mAX_CHARLIKE :: DynFlags -> Int
+mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags))
+mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int
+mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags))
+mAX_Vanilla_REG :: DynFlags -> Int
+mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags))
+mAX_Float_REG :: DynFlags -> Int
+mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags))
+mAX_Double_REG :: DynFlags -> Int
+mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags))
+mAX_Long_REG :: DynFlags -> Int
+mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags))
+mAX_XMM_REG :: DynFlags -> Int
+mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags))
+mAX_Real_Vanilla_REG :: DynFlags -> Int
+mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags))
+mAX_Real_Float_REG :: DynFlags -> Int
+mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags))
+mAX_Real_Double_REG :: DynFlags -> Int
+mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags))
+mAX_Real_XMM_REG :: DynFlags -> Int
+mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags))
+mAX_Real_Long_REG :: DynFlags -> Int
+mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags))
+rESERVED_C_STACK_BYTES :: DynFlags -> Int
+rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags))
+rESERVED_STACK_WORDS :: DynFlags -> Int
+rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags))
+aP_STACK_SPLIM :: DynFlags -> Int
+aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags))
+wORD_SIZE :: DynFlags -> Int
+wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))
+dOUBLE_SIZE :: DynFlags -> Int
+dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags))
+cINT_SIZE :: DynFlags -> Int
+cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags))
+cLONG_SIZE :: DynFlags -> Int
+cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags))
+cLONG_LONG_SIZE :: DynFlags -> Int
+cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags))
+bITMAP_BITS_SHIFT :: DynFlags -> Int
+bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags))
+tAG_BITS :: DynFlags -> Int
+tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags))
+wORDS_BIGENDIAN :: DynFlags -> Bool
+wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags))
+dYNAMIC_BY_DEFAULT :: DynFlags -> Bool
+dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags))
+lDV_SHIFT :: DynFlags -> Int
+lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags))
+iLDV_CREATE_MASK :: DynFlags -> Integer
+iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags))
+iLDV_STATE_CREATE :: DynFlags -> Integer
+iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags))
+iLDV_STATE_USE :: DynFlags -> Integer
+iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags))
diff --git a/ghc-lib/generated/ghcautoconf.h b/ghc-lib/generated/ghcautoconf.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/ghcautoconf.h
@@ -0,0 +1,542 @@
+#ifndef __GHCAUTOCONF_H__
+#define __GHCAUTOCONF_H__
+/* mk/config.h.  Generated from config.h.in by configure.  */
+/* mk/config.h.in.  Generated from configure.ac by autoheader.  */
+
+/* Define if building universal (internal helper macro) */
+/* #undef AC_APPLE_UNIVERSAL_BUILD */
+
+/* The alignment of a `char'. */
+#define ALIGNMENT_CHAR 1
+
+/* The alignment of a `double'. */
+#define ALIGNMENT_DOUBLE 8
+
+/* The alignment of a `float'. */
+#define ALIGNMENT_FLOAT 4
+
+/* The alignment of a `int'. */
+#define ALIGNMENT_INT 4
+
+/* The alignment of a `int16_t'. */
+#define ALIGNMENT_INT16_T 2
+
+/* The alignment of a `int32_t'. */
+#define ALIGNMENT_INT32_T 4
+
+/* The alignment of a `int64_t'. */
+#define ALIGNMENT_INT64_T 8
+
+/* The alignment of a `int8_t'. */
+#define ALIGNMENT_INT8_T 1
+
+/* The alignment of a `long'. */
+#define ALIGNMENT_LONG 8
+
+/* The alignment of a `long long'. */
+#define ALIGNMENT_LONG_LONG 8
+
+/* The alignment of a `short'. */
+#define ALIGNMENT_SHORT 2
+
+/* The alignment of a `uint16_t'. */
+#define ALIGNMENT_UINT16_T 2
+
+/* The alignment of a `uint32_t'. */
+#define ALIGNMENT_UINT32_T 4
+
+/* The alignment of a `uint64_t'. */
+#define ALIGNMENT_UINT64_T 8
+
+/* The alignment of a `uint8_t'. */
+#define ALIGNMENT_UINT8_T 1
+
+/* The alignment of a `unsigned char'. */
+#define ALIGNMENT_UNSIGNED_CHAR 1
+
+/* The alignment of a `unsigned int'. */
+#define ALIGNMENT_UNSIGNED_INT 4
+
+/* The alignment of a `unsigned long'. */
+#define ALIGNMENT_UNSIGNED_LONG 8
+
+/* The alignment of a `unsigned long long'. */
+#define ALIGNMENT_UNSIGNED_LONG_LONG 8
+
+/* The alignment of a `unsigned short'. */
+#define ALIGNMENT_UNSIGNED_SHORT 2
+
+/* The alignment of a `void *'. */
+#define ALIGNMENT_VOID_P 8
+
+/* Define to 1 if __thread is supported */
+#define CC_SUPPORTS_TLS 1
+
+/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
+   systems. This function is required for `alloca.c' support on those systems.
+   */
+/* #undef CRAY_STACKSEG_END */
+
+/* Define to 1 if using `alloca.c'. */
+/* #undef C_ALLOCA */
+
+/* Define to 1 if your processor stores words of floats with the most
+   significant byte first */
+/* #undef FLOAT_WORDS_BIGENDIAN */
+
+/* Has visibility hidden */
+#define HAS_VISIBILITY_HIDDEN 1
+
+/* Define to 1 if you have `alloca', as a function or macro. */
+#define HAVE_ALLOCA 1
+
+/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).
+   */
+#define HAVE_ALLOCA_H 1
+
+/* Define to 1 if you have the <bfd.h> header file. */
+/* #undef HAVE_BFD_H */
+
+/* Does GCC support __atomic primitives? */
+#define HAVE_C11_ATOMICS $CONF_GCC_SUPPORTS__ATOMICS
+
+/* Define to 1 if you have the `clock_gettime' function. */
+#define HAVE_CLOCK_GETTIME 1
+
+/* Define to 1 if you have the `ctime_r' function. */
+#define HAVE_CTIME_R 1
+
+/* Define to 1 if you have the <ctype.h> header file. */
+#define HAVE_CTYPE_H 1
+
+/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you
+   don't. */
+#define HAVE_DECL_CTIME_R 1
+
+/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you
+   don't. */
+/* #undef HAVE_DECL_MADV_DONTNEED */
+
+/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you
+   don't. */
+/* #undef HAVE_DECL_MADV_FREE */
+
+/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you
+   don't. */
+/* #undef HAVE_DECL_MAP_NORESERVE */
+
+/* Define to 1 if you have the <dirent.h> header file. */
+#define HAVE_DIRENT_H 1
+
+/* Define to 1 if you have the <dlfcn.h> header file. */
+#define HAVE_DLFCN_H 1
+
+/* Define to 1 if you have the <errno.h> header file. */
+#define HAVE_ERRNO_H 1
+
+/* Define to 1 if you have the `eventfd' function. */
+/* #undef HAVE_EVENTFD */
+
+/* Define to 1 if you have the <fcntl.h> header file. */
+#define HAVE_FCNTL_H 1
+
+/* Define to 1 if you have the <ffi.h> header file. */
+/* #undef HAVE_FFI_H */
+
+/* Define to 1 if you have the `fork' function. */
+#define HAVE_FORK 1
+
+/* Define to 1 if you have the `getclock' function. */
+/* #undef HAVE_GETCLOCK */
+
+/* Define to 1 if you have the `GetModuleFileName' function. */
+/* #undef HAVE_GETMODULEFILENAME */
+
+/* Define to 1 if you have the `getrusage' function. */
+#define HAVE_GETRUSAGE 1
+
+/* Define to 1 if you have the `gettimeofday' function. */
+#define HAVE_GETTIMEOFDAY 1
+
+/* Define to 1 if you have the <grp.h> header file. */
+#define HAVE_GRP_H 1
+
+/* Define to 1 if you have the <inttypes.h> header file. */
+#define HAVE_INTTYPES_H 1
+
+/* Define to 1 if you have the `bfd' library (-lbfd). */
+/* #undef HAVE_LIBBFD */
+
+/* Define to 1 if you have the `dl' library (-ldl). */
+#define HAVE_LIBDL 1
+
+/* Define to 1 if you have libffi. */
+/* #undef HAVE_LIBFFI */
+
+/* Define to 1 if you have the `iberty' library (-liberty). */
+/* #undef HAVE_LIBIBERTY */
+
+/* Define to 1 if you need to link with libm */
+#define HAVE_LIBM 1
+
+/* Define to 1 if you have libnuma */
+#define HAVE_LIBNUMA 0
+
+/* Define to 1 if you have the `pthread' library (-lpthread). */
+#define HAVE_LIBPTHREAD 1
+
+/* Define to 1 if you have the `rt' library (-lrt). */
+/* #undef HAVE_LIBRT */
+
+/* Define to 1 if you have the <limits.h> header file. */
+#define HAVE_LIMITS_H 1
+
+/* Define to 1 if you have the <locale.h> header file. */
+#define HAVE_LOCALE_H 1
+
+/* Define to 1 if the system has the type `long long'. */
+#define HAVE_LONG_LONG 1
+
+/* Define to 1 if you have the <memory.h> header file. */
+#define HAVE_MEMORY_H 1
+
+/* Define to 1 if you have the mingwex library. */
+/* #undef HAVE_MINGWEX */
+
+/* Define to 1 if you have the <nlist.h> header file. */
+#define HAVE_NLIST_H 1
+
+/* Define to 1 if you have the <numaif.h> header file. */
+/* #undef HAVE_NUMAIF_H */
+
+/* Define to 1 if you have the <numa.h> header file. */
+/* #undef HAVE_NUMA_H */
+
+/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */
+#define HAVE_PRINTF_LDBLSTUB 0
+
+/* Define to 1 if you have the <pthread.h> header file. */
+#define HAVE_PTHREAD_H 1
+
+/* Define to 1 if you have the glibc version of pthread_setname_np */
+/* #undef HAVE_PTHREAD_SETNAME_NP */
+
+/* Define to 1 if you have the <pwd.h> header file. */
+#define HAVE_PWD_H 1
+
+/* Define to 1 if you have the <sched.h> header file. */
+#define HAVE_SCHED_H 1
+
+/* Define to 1 if you have the `sched_setaffinity' function. */
+/* #undef HAVE_SCHED_SETAFFINITY */
+
+/* Define to 1 if you have the `setitimer' function. */
+#define HAVE_SETITIMER 1
+
+/* Define to 1 if you have the `setlocale' function. */
+#define HAVE_SETLOCALE 1
+
+/* Define to 1 if you have the `siginterrupt' function. */
+#define HAVE_SIGINTERRUPT 1
+
+/* Define to 1 if you have the <signal.h> header file. */
+#define HAVE_SIGNAL_H 1
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#define HAVE_STDINT_H 1
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#define HAVE_STDLIB_H 1
+
+/* Define to 1 if you have the <strings.h> header file. */
+#define HAVE_STRINGS_H 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if Apple-style dead-stripping is supported. */
+#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1
+
+/* Define to 1 if you have the `sysconf' function. */
+#define HAVE_SYSCONF 1
+
+/* Define to 1 if you have the <sys/cpuset.h> header file. */
+/* #undef HAVE_SYS_CPUSET_H */
+
+/* Define to 1 if you have the <sys/eventfd.h> header file. */
+/* #undef HAVE_SYS_EVENTFD_H */
+
+/* Define to 1 if you have the <sys/mman.h> header file. */
+#define HAVE_SYS_MMAN_H 1
+
+/* Define to 1 if you have the <sys/param.h> header file. */
+#define HAVE_SYS_PARAM_H 1
+
+/* Define to 1 if you have the <sys/resource.h> header file. */
+#define HAVE_SYS_RESOURCE_H 1
+
+/* Define to 1 if you have the <sys/select.h> header file. */
+#define HAVE_SYS_SELECT_H 1
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#define HAVE_SYS_STAT_H 1
+
+/* Define to 1 if you have the <sys/timeb.h> header file. */
+#define HAVE_SYS_TIMEB_H 1
+
+/* Define to 1 if you have the <sys/timerfd.h> header file. */
+/* #undef HAVE_SYS_TIMERFD_H */
+
+/* Define to 1 if you have the <sys/timers.h> header file. */
+/* #undef HAVE_SYS_TIMERS_H */
+
+/* Define to 1 if you have the <sys/times.h> header file. */
+#define HAVE_SYS_TIMES_H 1
+
+/* Define to 1 if you have the <sys/time.h> header file. */
+#define HAVE_SYS_TIME_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#define HAVE_SYS_TYPES_H 1
+
+/* Define to 1 if you have the <sys/utsname.h> header file. */
+#define HAVE_SYS_UTSNAME_H 1
+
+/* Define to 1 if you have the <sys/wait.h> header file. */
+#define HAVE_SYS_WAIT_H 1
+
+/* Define to 1 if you have the <termios.h> header file. */
+#define HAVE_TERMIOS_H 1
+
+/* Define to 1 if you have the `timer_settime' function. */
+/* #undef HAVE_TIMER_SETTIME */
+
+/* Define to 1 if you have the `times' function. */
+#define HAVE_TIMES 1
+
+/* Define to 1 if you have the <time.h> header file. */
+#define HAVE_TIME_H 1
+
+/* Define to 1 if you have the <unistd.h> header file. */
+#define HAVE_UNISTD_H 1
+
+/* Define to 1 if you have the <utime.h> header file. */
+#define HAVE_UTIME_H 1
+
+/* Define to 1 if you have the `vfork' function. */
+#define HAVE_VFORK 1
+
+/* Define to 1 if you have the <vfork.h> header file. */
+/* #undef HAVE_VFORK_H */
+
+/* Define to 1 if you have the <windows.h> header file. */
+/* #undef HAVE_WINDOWS_H */
+
+/* Define to 1 if you have the `WinExec' function. */
+/* #undef HAVE_WINEXEC */
+
+/* Define to 1 if you have the <winsock.h> header file. */
+/* #undef HAVE_WINSOCK_H */
+
+/* Define to 1 if `fork' works. */
+#define HAVE_WORKING_FORK 1
+
+/* Define to 1 if `vfork' works. */
+#define HAVE_WORKING_VFORK 1
+
+/* Define to 1 if C symbols have a leading underscore added by the compiler.
+   */
+#define LEADING_UNDERSCORE 1
+
+/* Define 1 if we need to link code using pthreads with -lpthread */
+#define NEED_PTHREAD_LIB 0
+
+/* Define to the address where bug reports for this package should be sent. */
+/* #undef PACKAGE_BUGREPORT */
+
+/* Define to the full name of this package. */
+/* #undef PACKAGE_NAME */
+
+/* Define to the full name and version of this package. */
+/* #undef PACKAGE_STRING */
+
+/* Define to the one symbol short name of this package. */
+/* #undef PACKAGE_TARNAME */
+
+/* Define to the home page for this package. */
+/* #undef PACKAGE_URL */
+
+/* Define to the version of this package. */
+/* #undef PACKAGE_VERSION */
+
+/* Use mmap in the runtime linker */
+#define RTS_LINKER_USE_MMAP 1
+
+/* The size of `char', as computed by sizeof. */
+#define SIZEOF_CHAR 1
+
+/* The size of `double', as computed by sizeof. */
+#define SIZEOF_DOUBLE 8
+
+/* The size of `float', as computed by sizeof. */
+#define SIZEOF_FLOAT 4
+
+/* The size of `int', as computed by sizeof. */
+#define SIZEOF_INT 4
+
+/* The size of `int16_t', as computed by sizeof. */
+#define SIZEOF_INT16_T 2
+
+/* The size of `int32_t', as computed by sizeof. */
+#define SIZEOF_INT32_T 4
+
+/* The size of `int64_t', as computed by sizeof. */
+#define SIZEOF_INT64_T 8
+
+/* The size of `int8_t', as computed by sizeof. */
+#define SIZEOF_INT8_T 1
+
+/* The size of `long', as computed by sizeof. */
+#define SIZEOF_LONG 8
+
+/* The size of `long long', as computed by sizeof. */
+#define SIZEOF_LONG_LONG 8
+
+/* The size of `short', as computed by sizeof. */
+#define SIZEOF_SHORT 2
+
+/* The size of `uint16_t', as computed by sizeof. */
+#define SIZEOF_UINT16_T 2
+
+/* The size of `uint32_t', as computed by sizeof. */
+#define SIZEOF_UINT32_T 4
+
+/* The size of `uint64_t', as computed by sizeof. */
+#define SIZEOF_UINT64_T 8
+
+/* The size of `uint8_t', as computed by sizeof. */
+#define SIZEOF_UINT8_T 1
+
+/* The size of `unsigned char', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_CHAR 1
+
+/* The size of `unsigned int', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_INT 4
+
+/* The size of `unsigned long', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_LONG 8
+
+/* The size of `unsigned long long', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_LONG_LONG 8
+
+/* The size of `unsigned short', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_SHORT 2
+
+/* The size of `void *', as computed by sizeof. */
+#define SIZEOF_VOID_P 8
+
+/* If using the C implementation of alloca, define if you know the
+   direction of stack growth for your system; otherwise it will be
+   automatically deduced at runtime.
+	STACK_DIRECTION > 0 => grows toward higher addresses
+	STACK_DIRECTION < 0 => grows toward lower addresses
+	STACK_DIRECTION = 0 => direction of growth unknown */
+/* #undef STACK_DIRECTION */
+
+/* Define to 1 if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
+#define TIME_WITH_SYS_TIME 1
+
+/* Enable single heap address space support */
+#define USE_LARGE_ADDRESS_SPACE 1
+
+/* Set to 1 to use libdw */
+#define USE_LIBDW 0
+
+/* Enable extensions on AIX 3, Interix.  */
+#ifndef _ALL_SOURCE
+# define _ALL_SOURCE 1
+#endif
+/* Enable GNU extensions on systems that have them.  */
+#ifndef _GNU_SOURCE
+# define _GNU_SOURCE 1
+#endif
+/* Enable threading extensions on Solaris.  */
+#ifndef _POSIX_PTHREAD_SEMANTICS
+# define _POSIX_PTHREAD_SEMANTICS 1
+#endif
+/* Enable extensions on HP NonStop.  */
+#ifndef _TANDEM_SOURCE
+# define _TANDEM_SOURCE 1
+#endif
+/* Enable general extensions on Solaris.  */
+#ifndef __EXTENSIONS__
+# define __EXTENSIONS__ 1
+#endif
+
+
+/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */
+/* #undef USE_TIMER_CREATE */
+
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+   significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+#  define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+/* #  undef WORDS_BIGENDIAN */
+# endif
+#endif
+
+/* Enable large inode numbers on Mac OS X 10.5.  */
+#ifndef _DARWIN_USE_64_BIT_INODE
+# define _DARWIN_USE_64_BIT_INODE 1
+#endif
+
+/* Number of bits in a file offset, on hosts where this is settable. */
+/* #undef _FILE_OFFSET_BITS */
+
+/* Define for large files, on AIX-style hosts. */
+/* #undef _LARGE_FILES */
+
+/* Define to 1 if on MINIX. */
+/* #undef _MINIX */
+
+/* Define to 2 if the system does not provide POSIX.1 features except with
+   this defined. */
+/* #undef _POSIX_1_SOURCE */
+
+/* Define to 1 if you need to in order for `stat' and other things to work. */
+/* #undef _POSIX_SOURCE */
+
+/* ARM pre v6 */
+/* #undef arm_HOST_ARCH_PRE_ARMv6 */
+
+/* ARM pre v7 */
+/* #undef arm_HOST_ARCH_PRE_ARMv7 */
+
+/* Define to empty if `const' does not conform to ANSI C. */
+/* #undef const */
+
+/* Define to `int' if <sys/types.h> does not define. */
+/* #undef pid_t */
+
+/* The supported LLVM version number */
+#define sUPPORTED_LLVM_VERSION (7,0)
+
+/* Define to `unsigned int' if <sys/types.h> does not define. */
+/* #undef size_t */
+
+/* Define as `fork' if `vfork' does not work. */
+/* #undef vfork */
+
+#define TABLES_NEXT_TO_CODE 1
+
+#define llvm_CC_FLAVOR 1
+
+#define clang_CC_FLAVOR 1
+#endif /* __GHCAUTOCONF_H__ */
diff --git a/ghc-lib/generated/ghcplatform.h b/ghc-lib/generated/ghcplatform.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/ghcplatform.h
@@ -0,0 +1,34 @@
+#ifndef __GHCPLATFORM_H__
+#define __GHCPLATFORM_H__
+
+#define BuildPlatform_TYPE  x86_64_apple_darwin
+#define HostPlatform_TYPE   x86_64_apple_darwin
+
+#define x86_64_apple_darwin_BUILD 1
+#define x86_64_apple_darwin_HOST 1
+
+#define x86_64_BUILD_ARCH 1
+#define x86_64_HOST_ARCH 1
+#define BUILD_ARCH "x86_64"
+#define HOST_ARCH "x86_64"
+
+#define darwin_BUILD_OS 1
+#define darwin_HOST_OS 1
+#define BUILD_OS "darwin"
+#define HOST_OS "darwin"
+
+#define apple_BUILD_VENDOR 1
+#define apple_HOST_VENDOR 1
+#define BUILD_VENDOR "apple"
+#define HOST_VENDOR "apple"
+
+/* These TARGET macros are for backwards compatibility... DO NOT USE! */
+#define TargetPlatform_TYPE x86_64_apple_darwin
+#define x86_64_apple_darwin_TARGET 1
+#define x86_64_TARGET_ARCH 1
+#define TARGET_ARCH "x86_64"
+#define darwin_TARGET_OS 1
+#define TARGET_OS "darwin"
+#define apple_TARGET_VENDOR 1
+
+#endif /* __GHCPLATFORM_H__ */
diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/ghcversion.h
@@ -0,0 +1,19 @@
+#ifndef __GHCVERSION_H__
+#define __GHCVERSION_H__
+
+#ifndef __GLASGOW_HASKELL__
+# define __GLASGOW_HASKELL__ 809
+#endif
+
+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0
+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190522
+
+#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\
+   ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \
+          && (pl1) <  __GLASGOW_HASKELL_PATCHLEVEL1__ || \
+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \
+          && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \
+          && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )
+
+#endif /* __GHCVERSION_H__ */
diff --git a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h
@@ -0,0 +1,33 @@
+#ifndef __PLATFORM_H__
+#define __PLATFORM_H__
+
+#define BuildPlatform_NAME  "x86_64-apple-darwin"
+#define HostPlatform_NAME   "x86_64-apple-darwin"
+
+#define x86_64_apple_darwin_BUILD 1
+#define x86_64_apple_darwin_HOST 1
+#define x86_64_apple_darwin_TARGET 1
+
+#define x86_64_BUILD_ARCH 1
+#define x86_64_HOST_ARCH 1
+#define x86_64_TARGET_ARCH 1
+#define BUILD_ARCH "x86_64"
+#define HOST_ARCH "x86_64"
+#define TARGET_ARCH "x86_64"
+#define LLVM_TARGET "x86_64-apple-darwin"
+
+#define darwin_BUILD_OS 1
+#define darwin_HOST_OS 1
+#define darwin_TARGET_OS 1
+#define BUILD_OS "darwin"
+#define HOST_OS "darwin"
+#define TARGET_OS "darwin"
+
+#define apple_BUILD_VENDOR 1
+#define apple_HOST_VENDOR 1
+#define apple_TARGET_VENDOR  1
+#define BUILD_VENDOR "apple"
+#define HOST_VENDOR "apple"
+#define TARGET_VENDOR "apple"
+
+#endif /* __PLATFORM_H__ */
diff --git a/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl
@@ -0,0 +1,231 @@
+primOpCanFail IntQuotOp = True
+primOpCanFail IntRemOp = True
+primOpCanFail IntQuotRemOp = True
+primOpCanFail Int8QuotOp = True
+primOpCanFail Int8RemOp = True
+primOpCanFail Int8QuotRemOp = True
+primOpCanFail Word8QuotOp = True
+primOpCanFail Word8RemOp = True
+primOpCanFail Word8QuotRemOp = True
+primOpCanFail Int16QuotOp = True
+primOpCanFail Int16RemOp = True
+primOpCanFail Int16QuotRemOp = True
+primOpCanFail Word16QuotOp = True
+primOpCanFail Word16RemOp = True
+primOpCanFail Word16QuotRemOp = True
+primOpCanFail WordQuotOp = True
+primOpCanFail WordRemOp = True
+primOpCanFail WordQuotRemOp = True
+primOpCanFail WordQuotRem2Op = True
+primOpCanFail DoubleDivOp = True
+primOpCanFail DoubleLogOp = True
+primOpCanFail DoubleAsinOp = True
+primOpCanFail DoubleAcosOp = True
+primOpCanFail FloatDivOp = True
+primOpCanFail FloatLogOp = True
+primOpCanFail FloatAsinOp = True
+primOpCanFail FloatAcosOp = True
+primOpCanFail ReadArrayOp = True
+primOpCanFail WriteArrayOp = True
+primOpCanFail IndexArrayOp = True
+primOpCanFail CopyArrayOp = True
+primOpCanFail CopyMutableArrayOp = True
+primOpCanFail CloneArrayOp = True
+primOpCanFail CloneMutableArrayOp = True
+primOpCanFail FreezeArrayOp = True
+primOpCanFail ThawArrayOp = True
+primOpCanFail ReadSmallArrayOp = True
+primOpCanFail WriteSmallArrayOp = True
+primOpCanFail IndexSmallArrayOp = True
+primOpCanFail CopySmallArrayOp = True
+primOpCanFail CopySmallMutableArrayOp = True
+primOpCanFail CloneSmallArrayOp = True
+primOpCanFail CloneSmallMutableArrayOp = True
+primOpCanFail FreezeSmallArrayOp = True
+primOpCanFail ThawSmallArrayOp = True
+primOpCanFail IndexByteArrayOp_Char = True
+primOpCanFail IndexByteArrayOp_WideChar = True
+primOpCanFail IndexByteArrayOp_Int = True
+primOpCanFail IndexByteArrayOp_Word = True
+primOpCanFail IndexByteArrayOp_Addr = True
+primOpCanFail IndexByteArrayOp_Float = True
+primOpCanFail IndexByteArrayOp_Double = True
+primOpCanFail IndexByteArrayOp_StablePtr = True
+primOpCanFail IndexByteArrayOp_Int8 = True
+primOpCanFail IndexByteArrayOp_Int16 = True
+primOpCanFail IndexByteArrayOp_Int32 = True
+primOpCanFail IndexByteArrayOp_Int64 = True
+primOpCanFail IndexByteArrayOp_Word8 = True
+primOpCanFail IndexByteArrayOp_Word16 = True
+primOpCanFail IndexByteArrayOp_Word32 = True
+primOpCanFail IndexByteArrayOp_Word64 = True
+primOpCanFail IndexByteArrayOp_Word8AsChar = True
+primOpCanFail IndexByteArrayOp_Word8AsWideChar = True
+primOpCanFail IndexByteArrayOp_Word8AsAddr = True
+primOpCanFail IndexByteArrayOp_Word8AsFloat = True
+primOpCanFail IndexByteArrayOp_Word8AsDouble = True
+primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True
+primOpCanFail IndexByteArrayOp_Word8AsInt16 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt32 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt64 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt = True
+primOpCanFail IndexByteArrayOp_Word8AsWord16 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord32 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord64 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord = True
+primOpCanFail ReadByteArrayOp_Char = True
+primOpCanFail ReadByteArrayOp_WideChar = True
+primOpCanFail ReadByteArrayOp_Int = True
+primOpCanFail ReadByteArrayOp_Word = True
+primOpCanFail ReadByteArrayOp_Addr = True
+primOpCanFail ReadByteArrayOp_Float = True
+primOpCanFail ReadByteArrayOp_Double = True
+primOpCanFail ReadByteArrayOp_StablePtr = True
+primOpCanFail ReadByteArrayOp_Int8 = True
+primOpCanFail ReadByteArrayOp_Int16 = True
+primOpCanFail ReadByteArrayOp_Int32 = True
+primOpCanFail ReadByteArrayOp_Int64 = True
+primOpCanFail ReadByteArrayOp_Word8 = True
+primOpCanFail ReadByteArrayOp_Word16 = True
+primOpCanFail ReadByteArrayOp_Word32 = True
+primOpCanFail ReadByteArrayOp_Word64 = True
+primOpCanFail ReadByteArrayOp_Word8AsChar = True
+primOpCanFail ReadByteArrayOp_Word8AsWideChar = True
+primOpCanFail ReadByteArrayOp_Word8AsAddr = True
+primOpCanFail ReadByteArrayOp_Word8AsFloat = True
+primOpCanFail ReadByteArrayOp_Word8AsDouble = True
+primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True
+primOpCanFail ReadByteArrayOp_Word8AsInt16 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt32 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt64 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt = True
+primOpCanFail ReadByteArrayOp_Word8AsWord16 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord32 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord64 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord = True
+primOpCanFail WriteByteArrayOp_Char = True
+primOpCanFail WriteByteArrayOp_WideChar = True
+primOpCanFail WriteByteArrayOp_Int = True
+primOpCanFail WriteByteArrayOp_Word = True
+primOpCanFail WriteByteArrayOp_Addr = True
+primOpCanFail WriteByteArrayOp_Float = True
+primOpCanFail WriteByteArrayOp_Double = True
+primOpCanFail WriteByteArrayOp_StablePtr = True
+primOpCanFail WriteByteArrayOp_Int8 = True
+primOpCanFail WriteByteArrayOp_Int16 = True
+primOpCanFail WriteByteArrayOp_Int32 = True
+primOpCanFail WriteByteArrayOp_Int64 = True
+primOpCanFail WriteByteArrayOp_Word8 = True
+primOpCanFail WriteByteArrayOp_Word16 = True
+primOpCanFail WriteByteArrayOp_Word32 = True
+primOpCanFail WriteByteArrayOp_Word64 = True
+primOpCanFail WriteByteArrayOp_Word8AsChar = True
+primOpCanFail WriteByteArrayOp_Word8AsWideChar = True
+primOpCanFail WriteByteArrayOp_Word8AsAddr = True
+primOpCanFail WriteByteArrayOp_Word8AsFloat = True
+primOpCanFail WriteByteArrayOp_Word8AsDouble = True
+primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True
+primOpCanFail WriteByteArrayOp_Word8AsInt16 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt32 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt64 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt = True
+primOpCanFail WriteByteArrayOp_Word8AsWord16 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord32 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord64 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord = True
+primOpCanFail CompareByteArraysOp = True
+primOpCanFail CopyByteArrayOp = True
+primOpCanFail CopyMutableByteArrayOp = True
+primOpCanFail CopyByteArrayToAddrOp = True
+primOpCanFail CopyMutableByteArrayToAddrOp = True
+primOpCanFail CopyAddrToByteArrayOp = True
+primOpCanFail SetByteArrayOp = True
+primOpCanFail AtomicReadByteArrayOp_Int = True
+primOpCanFail AtomicWriteByteArrayOp_Int = True
+primOpCanFail CasByteArrayOp_Int = True
+primOpCanFail FetchAddByteArrayOp_Int = True
+primOpCanFail FetchSubByteArrayOp_Int = True
+primOpCanFail FetchAndByteArrayOp_Int = True
+primOpCanFail FetchNandByteArrayOp_Int = True
+primOpCanFail FetchOrByteArrayOp_Int = True
+primOpCanFail FetchXorByteArrayOp_Int = True
+primOpCanFail IndexArrayArrayOp_ByteArray = True
+primOpCanFail IndexArrayArrayOp_ArrayArray = True
+primOpCanFail ReadArrayArrayOp_ByteArray = True
+primOpCanFail ReadArrayArrayOp_MutableByteArray = True
+primOpCanFail ReadArrayArrayOp_ArrayArray = True
+primOpCanFail ReadArrayArrayOp_MutableArrayArray = True
+primOpCanFail WriteArrayArrayOp_ByteArray = True
+primOpCanFail WriteArrayArrayOp_MutableByteArray = True
+primOpCanFail WriteArrayArrayOp_ArrayArray = True
+primOpCanFail WriteArrayArrayOp_MutableArrayArray = True
+primOpCanFail CopyArrayArrayOp = True
+primOpCanFail CopyMutableArrayArrayOp = True
+primOpCanFail IndexOffAddrOp_Char = True
+primOpCanFail IndexOffAddrOp_WideChar = True
+primOpCanFail IndexOffAddrOp_Int = True
+primOpCanFail IndexOffAddrOp_Word = True
+primOpCanFail IndexOffAddrOp_Addr = True
+primOpCanFail IndexOffAddrOp_Float = True
+primOpCanFail IndexOffAddrOp_Double = True
+primOpCanFail IndexOffAddrOp_StablePtr = True
+primOpCanFail IndexOffAddrOp_Int8 = True
+primOpCanFail IndexOffAddrOp_Int16 = True
+primOpCanFail IndexOffAddrOp_Int32 = True
+primOpCanFail IndexOffAddrOp_Int64 = True
+primOpCanFail IndexOffAddrOp_Word8 = True
+primOpCanFail IndexOffAddrOp_Word16 = True
+primOpCanFail IndexOffAddrOp_Word32 = True
+primOpCanFail IndexOffAddrOp_Word64 = True
+primOpCanFail ReadOffAddrOp_Char = True
+primOpCanFail ReadOffAddrOp_WideChar = True
+primOpCanFail ReadOffAddrOp_Int = True
+primOpCanFail ReadOffAddrOp_Word = True
+primOpCanFail ReadOffAddrOp_Addr = True
+primOpCanFail ReadOffAddrOp_Float = True
+primOpCanFail ReadOffAddrOp_Double = True
+primOpCanFail ReadOffAddrOp_StablePtr = True
+primOpCanFail ReadOffAddrOp_Int8 = True
+primOpCanFail ReadOffAddrOp_Int16 = True
+primOpCanFail ReadOffAddrOp_Int32 = True
+primOpCanFail ReadOffAddrOp_Int64 = True
+primOpCanFail ReadOffAddrOp_Word8 = True
+primOpCanFail ReadOffAddrOp_Word16 = True
+primOpCanFail ReadOffAddrOp_Word32 = True
+primOpCanFail ReadOffAddrOp_Word64 = True
+primOpCanFail WriteOffAddrOp_Char = True
+primOpCanFail WriteOffAddrOp_WideChar = True
+primOpCanFail WriteOffAddrOp_Int = True
+primOpCanFail WriteOffAddrOp_Word = True
+primOpCanFail WriteOffAddrOp_Addr = True
+primOpCanFail WriteOffAddrOp_Float = True
+primOpCanFail WriteOffAddrOp_Double = True
+primOpCanFail WriteOffAddrOp_StablePtr = True
+primOpCanFail WriteOffAddrOp_Int8 = True
+primOpCanFail WriteOffAddrOp_Int16 = True
+primOpCanFail WriteOffAddrOp_Int32 = True
+primOpCanFail WriteOffAddrOp_Int64 = True
+primOpCanFail WriteOffAddrOp_Word8 = True
+primOpCanFail WriteOffAddrOp_Word16 = True
+primOpCanFail WriteOffAddrOp_Word32 = True
+primOpCanFail WriteOffAddrOp_Word64 = True
+primOpCanFail AtomicModifyMutVar2Op = True
+primOpCanFail AtomicModifyMutVar_Op = True
+primOpCanFail ReallyUnsafePtrEqualityOp = True
+primOpCanFail (VecInsertOp _ _ _) = True
+primOpCanFail (VecDivOp _ _ _) = True
+primOpCanFail (VecQuotOp _ _ _) = True
+primOpCanFail (VecRemOp _ _ _) = True
+primOpCanFail (VecIndexByteArrayOp _ _ _) = True
+primOpCanFail (VecReadByteArrayOp _ _ _) = True
+primOpCanFail (VecWriteByteArrayOp _ _ _) = True
+primOpCanFail (VecIndexOffAddrOp _ _ _) = True
+primOpCanFail (VecReadOffAddrOp _ _ _) = True
+primOpCanFail (VecWriteOffAddrOp _ _ _) = True
+primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True
+primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True
+primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True
+primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True
+primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True
+primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True
+primOpCanFail _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl
@@ -0,0 +1,57 @@
+primOpCodeSize OrdOp = 0
+primOpCodeSize IntAddCOp = 2
+primOpCodeSize IntSubCOp = 2
+primOpCodeSize ChrOp = 0
+primOpCodeSize Int2WordOp = 0
+primOpCodeSize WordAddCOp = 2
+primOpCodeSize WordSubCOp = 2
+primOpCodeSize WordAdd2Op = 2
+primOpCodeSize Word2IntOp = 0
+primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAsinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAsinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall 
+primOpCodeSize WriteArrayOp = 2
+primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 
+primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 
+primOpCodeSize Addr2IntOp = 0
+primOpCodeSize Int2AddrOp = 0
+primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall 
+primOpCodeSize TouchOp =  0 
+primOpCodeSize ParOp =  primOpCodeSizeForeignCall 
+primOpCodeSize SparkOp =  primOpCodeSizeForeignCall 
+primOpCodeSize AddrToAnyOp = 0
+primOpCodeSize AnyToAddrOp = 0
+primOpCodeSize _ =  primOpCodeSizeDefault 
diff --git a/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl b/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl
@@ -0,0 +1,38 @@
+commutableOp CharEqOp = True
+commutableOp CharNeOp = True
+commutableOp IntAddOp = True
+commutableOp IntMulOp = True
+commutableOp IntMulMayOfloOp = True
+commutableOp AndIOp = True
+commutableOp OrIOp = True
+commutableOp XorIOp = True
+commutableOp IntAddCOp = True
+commutableOp IntEqOp = True
+commutableOp IntNeOp = True
+commutableOp Int8AddOp = True
+commutableOp Int8MulOp = True
+commutableOp Word8AddOp = True
+commutableOp Word8MulOp = True
+commutableOp Int16AddOp = True
+commutableOp Int16MulOp = True
+commutableOp Word16AddOp = True
+commutableOp Word16MulOp = True
+commutableOp WordAddOp = True
+commutableOp WordAddCOp = True
+commutableOp WordAdd2Op = True
+commutableOp WordMulOp = True
+commutableOp WordMul2Op = True
+commutableOp AndOp = True
+commutableOp OrOp = True
+commutableOp XorOp = True
+commutableOp DoubleEqOp = True
+commutableOp DoubleNeOp = True
+commutableOp DoubleAddOp = True
+commutableOp DoubleMulOp = True
+commutableOp FloatEqOp = True
+commutableOp FloatNeOp = True
+commutableOp FloatAddOp = True
+commutableOp FloatMulOp = True
+commutableOp (VecAddOp _ _ _) = True
+commutableOp (VecMulOp _ _ _) = True
+commutableOp _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl
@@ -0,0 +1,580 @@
+data PrimOp
+   = CharGtOp
+   | CharGeOp
+   | CharEqOp
+   | CharNeOp
+   | CharLtOp
+   | CharLeOp
+   | OrdOp
+   | IntAddOp
+   | IntSubOp
+   | IntMulOp
+   | IntMulMayOfloOp
+   | IntQuotOp
+   | IntRemOp
+   | IntQuotRemOp
+   | AndIOp
+   | OrIOp
+   | XorIOp
+   | NotIOp
+   | IntNegOp
+   | IntAddCOp
+   | IntSubCOp
+   | IntGtOp
+   | IntGeOp
+   | IntEqOp
+   | IntNeOp
+   | IntLtOp
+   | IntLeOp
+   | ChrOp
+   | Int2WordOp
+   | Int2FloatOp
+   | Int2DoubleOp
+   | Word2FloatOp
+   | Word2DoubleOp
+   | ISllOp
+   | ISraOp
+   | ISrlOp
+   | Int8Extend
+   | Int8Narrow
+   | Int8NegOp
+   | Int8AddOp
+   | Int8SubOp
+   | Int8MulOp
+   | Int8QuotOp
+   | Int8RemOp
+   | Int8QuotRemOp
+   | Int8EqOp
+   | Int8GeOp
+   | Int8GtOp
+   | Int8LeOp
+   | Int8LtOp
+   | Int8NeOp
+   | Word8Extend
+   | Word8Narrow
+   | Word8NotOp
+   | Word8AddOp
+   | Word8SubOp
+   | Word8MulOp
+   | Word8QuotOp
+   | Word8RemOp
+   | Word8QuotRemOp
+   | Word8EqOp
+   | Word8GeOp
+   | Word8GtOp
+   | Word8LeOp
+   | Word8LtOp
+   | Word8NeOp
+   | Int16Extend
+   | Int16Narrow
+   | Int16NegOp
+   | Int16AddOp
+   | Int16SubOp
+   | Int16MulOp
+   | Int16QuotOp
+   | Int16RemOp
+   | Int16QuotRemOp
+   | Int16EqOp
+   | Int16GeOp
+   | Int16GtOp
+   | Int16LeOp
+   | Int16LtOp
+   | Int16NeOp
+   | Word16Extend
+   | Word16Narrow
+   | Word16NotOp
+   | Word16AddOp
+   | Word16SubOp
+   | Word16MulOp
+   | Word16QuotOp
+   | Word16RemOp
+   | Word16QuotRemOp
+   | Word16EqOp
+   | Word16GeOp
+   | Word16GtOp
+   | Word16LeOp
+   | Word16LtOp
+   | Word16NeOp
+   | WordAddOp
+   | WordAddCOp
+   | WordSubCOp
+   | WordAdd2Op
+   | WordSubOp
+   | WordMulOp
+   | WordMul2Op
+   | WordQuotOp
+   | WordRemOp
+   | WordQuotRemOp
+   | WordQuotRem2Op
+   | AndOp
+   | OrOp
+   | XorOp
+   | NotOp
+   | SllOp
+   | SrlOp
+   | Word2IntOp
+   | WordGtOp
+   | WordGeOp
+   | WordEqOp
+   | WordNeOp
+   | WordLtOp
+   | WordLeOp
+   | PopCnt8Op
+   | PopCnt16Op
+   | PopCnt32Op
+   | PopCnt64Op
+   | PopCntOp
+   | Pdep8Op
+   | Pdep16Op
+   | Pdep32Op
+   | Pdep64Op
+   | PdepOp
+   | Pext8Op
+   | Pext16Op
+   | Pext32Op
+   | Pext64Op
+   | PextOp
+   | Clz8Op
+   | Clz16Op
+   | Clz32Op
+   | Clz64Op
+   | ClzOp
+   | Ctz8Op
+   | Ctz16Op
+   | Ctz32Op
+   | Ctz64Op
+   | CtzOp
+   | BSwap16Op
+   | BSwap32Op
+   | BSwap64Op
+   | BSwapOp
+   | BRev8Op
+   | BRev16Op
+   | BRev32Op
+   | BRev64Op
+   | BRevOp
+   | Narrow8IntOp
+   | Narrow16IntOp
+   | Narrow32IntOp
+   | Narrow8WordOp
+   | Narrow16WordOp
+   | Narrow32WordOp
+   | DoubleGtOp
+   | DoubleGeOp
+   | DoubleEqOp
+   | DoubleNeOp
+   | DoubleLtOp
+   | DoubleLeOp
+   | DoubleAddOp
+   | DoubleSubOp
+   | DoubleMulOp
+   | DoubleDivOp
+   | DoubleNegOp
+   | DoubleFabsOp
+   | Double2IntOp
+   | Double2FloatOp
+   | DoubleExpOp
+   | DoubleLogOp
+   | DoubleSqrtOp
+   | DoubleSinOp
+   | DoubleCosOp
+   | DoubleTanOp
+   | DoubleAsinOp
+   | DoubleAcosOp
+   | DoubleAtanOp
+   | DoubleSinhOp
+   | DoubleCoshOp
+   | DoubleTanhOp
+   | DoubleAsinhOp
+   | DoubleAcoshOp
+   | DoubleAtanhOp
+   | DoublePowerOp
+   | DoubleDecode_2IntOp
+   | DoubleDecode_Int64Op
+   | FloatGtOp
+   | FloatGeOp
+   | FloatEqOp
+   | FloatNeOp
+   | FloatLtOp
+   | FloatLeOp
+   | FloatAddOp
+   | FloatSubOp
+   | FloatMulOp
+   | FloatDivOp
+   | FloatNegOp
+   | FloatFabsOp
+   | Float2IntOp
+   | FloatExpOp
+   | FloatLogOp
+   | FloatSqrtOp
+   | FloatSinOp
+   | FloatCosOp
+   | FloatTanOp
+   | FloatAsinOp
+   | FloatAcosOp
+   | FloatAtanOp
+   | FloatSinhOp
+   | FloatCoshOp
+   | FloatTanhOp
+   | FloatAsinhOp
+   | FloatAcoshOp
+   | FloatAtanhOp
+   | FloatPowerOp
+   | Float2DoubleOp
+   | FloatDecode_IntOp
+   | NewArrayOp
+   | SameMutableArrayOp
+   | ReadArrayOp
+   | WriteArrayOp
+   | SizeofArrayOp
+   | SizeofMutableArrayOp
+   | IndexArrayOp
+   | UnsafeFreezeArrayOp
+   | UnsafeThawArrayOp
+   | CopyArrayOp
+   | CopyMutableArrayOp
+   | CloneArrayOp
+   | CloneMutableArrayOp
+   | FreezeArrayOp
+   | ThawArrayOp
+   | CasArrayOp
+   | NewSmallArrayOp
+   | SameSmallMutableArrayOp
+   | ReadSmallArrayOp
+   | WriteSmallArrayOp
+   | SizeofSmallArrayOp
+   | SizeofSmallMutableArrayOp
+   | IndexSmallArrayOp
+   | UnsafeFreezeSmallArrayOp
+   | UnsafeThawSmallArrayOp
+   | CopySmallArrayOp
+   | CopySmallMutableArrayOp
+   | CloneSmallArrayOp
+   | CloneSmallMutableArrayOp
+   | FreezeSmallArrayOp
+   | ThawSmallArrayOp
+   | CasSmallArrayOp
+   | NewByteArrayOp_Char
+   | NewPinnedByteArrayOp_Char
+   | NewAlignedPinnedByteArrayOp_Char
+   | MutableByteArrayIsPinnedOp
+   | ByteArrayIsPinnedOp
+   | ByteArrayContents_Char
+   | SameMutableByteArrayOp
+   | ShrinkMutableByteArrayOp_Char
+   | ResizeMutableByteArrayOp_Char
+   | UnsafeFreezeByteArrayOp
+   | SizeofByteArrayOp
+   | SizeofMutableByteArrayOp
+   | GetSizeofMutableByteArrayOp
+   | IndexByteArrayOp_Char
+   | IndexByteArrayOp_WideChar
+   | IndexByteArrayOp_Int
+   | IndexByteArrayOp_Word
+   | IndexByteArrayOp_Addr
+   | IndexByteArrayOp_Float
+   | IndexByteArrayOp_Double
+   | IndexByteArrayOp_StablePtr
+   | IndexByteArrayOp_Int8
+   | IndexByteArrayOp_Int16
+   | IndexByteArrayOp_Int32
+   | IndexByteArrayOp_Int64
+   | IndexByteArrayOp_Word8
+   | IndexByteArrayOp_Word16
+   | IndexByteArrayOp_Word32
+   | IndexByteArrayOp_Word64
+   | IndexByteArrayOp_Word8AsChar
+   | IndexByteArrayOp_Word8AsWideChar
+   | IndexByteArrayOp_Word8AsAddr
+   | IndexByteArrayOp_Word8AsFloat
+   | IndexByteArrayOp_Word8AsDouble
+   | IndexByteArrayOp_Word8AsStablePtr
+   | IndexByteArrayOp_Word8AsInt16
+   | IndexByteArrayOp_Word8AsInt32
+   | IndexByteArrayOp_Word8AsInt64
+   | IndexByteArrayOp_Word8AsInt
+   | IndexByteArrayOp_Word8AsWord16
+   | IndexByteArrayOp_Word8AsWord32
+   | IndexByteArrayOp_Word8AsWord64
+   | IndexByteArrayOp_Word8AsWord
+   | ReadByteArrayOp_Char
+   | ReadByteArrayOp_WideChar
+   | ReadByteArrayOp_Int
+   | ReadByteArrayOp_Word
+   | ReadByteArrayOp_Addr
+   | ReadByteArrayOp_Float
+   | ReadByteArrayOp_Double
+   | ReadByteArrayOp_StablePtr
+   | ReadByteArrayOp_Int8
+   | ReadByteArrayOp_Int16
+   | ReadByteArrayOp_Int32
+   | ReadByteArrayOp_Int64
+   | ReadByteArrayOp_Word8
+   | ReadByteArrayOp_Word16
+   | ReadByteArrayOp_Word32
+   | ReadByteArrayOp_Word64
+   | ReadByteArrayOp_Word8AsChar
+   | ReadByteArrayOp_Word8AsWideChar
+   | ReadByteArrayOp_Word8AsAddr
+   | ReadByteArrayOp_Word8AsFloat
+   | ReadByteArrayOp_Word8AsDouble
+   | ReadByteArrayOp_Word8AsStablePtr
+   | ReadByteArrayOp_Word8AsInt16
+   | ReadByteArrayOp_Word8AsInt32
+   | ReadByteArrayOp_Word8AsInt64
+   | ReadByteArrayOp_Word8AsInt
+   | ReadByteArrayOp_Word8AsWord16
+   | ReadByteArrayOp_Word8AsWord32
+   | ReadByteArrayOp_Word8AsWord64
+   | ReadByteArrayOp_Word8AsWord
+   | WriteByteArrayOp_Char
+   | WriteByteArrayOp_WideChar
+   | WriteByteArrayOp_Int
+   | WriteByteArrayOp_Word
+   | WriteByteArrayOp_Addr
+   | WriteByteArrayOp_Float
+   | WriteByteArrayOp_Double
+   | WriteByteArrayOp_StablePtr
+   | WriteByteArrayOp_Int8
+   | WriteByteArrayOp_Int16
+   | WriteByteArrayOp_Int32
+   | WriteByteArrayOp_Int64
+   | WriteByteArrayOp_Word8
+   | WriteByteArrayOp_Word16
+   | WriteByteArrayOp_Word32
+   | WriteByteArrayOp_Word64
+   | WriteByteArrayOp_Word8AsChar
+   | WriteByteArrayOp_Word8AsWideChar
+   | WriteByteArrayOp_Word8AsAddr
+   | WriteByteArrayOp_Word8AsFloat
+   | WriteByteArrayOp_Word8AsDouble
+   | WriteByteArrayOp_Word8AsStablePtr
+   | WriteByteArrayOp_Word8AsInt16
+   | WriteByteArrayOp_Word8AsInt32
+   | WriteByteArrayOp_Word8AsInt64
+   | WriteByteArrayOp_Word8AsInt
+   | WriteByteArrayOp_Word8AsWord16
+   | WriteByteArrayOp_Word8AsWord32
+   | WriteByteArrayOp_Word8AsWord64
+   | WriteByteArrayOp_Word8AsWord
+   | CompareByteArraysOp
+   | CopyByteArrayOp
+   | CopyMutableByteArrayOp
+   | CopyByteArrayToAddrOp
+   | CopyMutableByteArrayToAddrOp
+   | CopyAddrToByteArrayOp
+   | SetByteArrayOp
+   | AtomicReadByteArrayOp_Int
+   | AtomicWriteByteArrayOp_Int
+   | CasByteArrayOp_Int
+   | FetchAddByteArrayOp_Int
+   | FetchSubByteArrayOp_Int
+   | FetchAndByteArrayOp_Int
+   | FetchNandByteArrayOp_Int
+   | FetchOrByteArrayOp_Int
+   | FetchXorByteArrayOp_Int
+   | NewArrayArrayOp
+   | SameMutableArrayArrayOp
+   | UnsafeFreezeArrayArrayOp
+   | SizeofArrayArrayOp
+   | SizeofMutableArrayArrayOp
+   | IndexArrayArrayOp_ByteArray
+   | IndexArrayArrayOp_ArrayArray
+   | ReadArrayArrayOp_ByteArray
+   | ReadArrayArrayOp_MutableByteArray
+   | ReadArrayArrayOp_ArrayArray
+   | ReadArrayArrayOp_MutableArrayArray
+   | WriteArrayArrayOp_ByteArray
+   | WriteArrayArrayOp_MutableByteArray
+   | WriteArrayArrayOp_ArrayArray
+   | WriteArrayArrayOp_MutableArrayArray
+   | CopyArrayArrayOp
+   | CopyMutableArrayArrayOp
+   | AddrAddOp
+   | AddrSubOp
+   | AddrRemOp
+   | Addr2IntOp
+   | Int2AddrOp
+   | AddrGtOp
+   | AddrGeOp
+   | AddrEqOp
+   | AddrNeOp
+   | AddrLtOp
+   | AddrLeOp
+   | IndexOffAddrOp_Char
+   | IndexOffAddrOp_WideChar
+   | IndexOffAddrOp_Int
+   | IndexOffAddrOp_Word
+   | IndexOffAddrOp_Addr
+   | IndexOffAddrOp_Float
+   | IndexOffAddrOp_Double
+   | IndexOffAddrOp_StablePtr
+   | IndexOffAddrOp_Int8
+   | IndexOffAddrOp_Int16
+   | IndexOffAddrOp_Int32
+   | IndexOffAddrOp_Int64
+   | IndexOffAddrOp_Word8
+   | IndexOffAddrOp_Word16
+   | IndexOffAddrOp_Word32
+   | IndexOffAddrOp_Word64
+   | ReadOffAddrOp_Char
+   | ReadOffAddrOp_WideChar
+   | ReadOffAddrOp_Int
+   | ReadOffAddrOp_Word
+   | ReadOffAddrOp_Addr
+   | ReadOffAddrOp_Float
+   | ReadOffAddrOp_Double
+   | ReadOffAddrOp_StablePtr
+   | ReadOffAddrOp_Int8
+   | ReadOffAddrOp_Int16
+   | ReadOffAddrOp_Int32
+   | ReadOffAddrOp_Int64
+   | ReadOffAddrOp_Word8
+   | ReadOffAddrOp_Word16
+   | ReadOffAddrOp_Word32
+   | ReadOffAddrOp_Word64
+   | WriteOffAddrOp_Char
+   | WriteOffAddrOp_WideChar
+   | WriteOffAddrOp_Int
+   | WriteOffAddrOp_Word
+   | WriteOffAddrOp_Addr
+   | WriteOffAddrOp_Float
+   | WriteOffAddrOp_Double
+   | WriteOffAddrOp_StablePtr
+   | WriteOffAddrOp_Int8
+   | WriteOffAddrOp_Int16
+   | WriteOffAddrOp_Int32
+   | WriteOffAddrOp_Int64
+   | WriteOffAddrOp_Word8
+   | WriteOffAddrOp_Word16
+   | WriteOffAddrOp_Word32
+   | WriteOffAddrOp_Word64
+   | NewMutVarOp
+   | ReadMutVarOp
+   | WriteMutVarOp
+   | SameMutVarOp
+   | AtomicModifyMutVar2Op
+   | AtomicModifyMutVar_Op
+   | CasMutVarOp
+   | CatchOp
+   | RaiseOp
+   | RaiseIOOp
+   | MaskAsyncExceptionsOp
+   | MaskUninterruptibleOp
+   | UnmaskAsyncExceptionsOp
+   | MaskStatus
+   | AtomicallyOp
+   | RetryOp
+   | CatchRetryOp
+   | CatchSTMOp
+   | NewTVarOp
+   | ReadTVarOp
+   | ReadTVarIOOp
+   | WriteTVarOp
+   | SameTVarOp
+   | NewMVarOp
+   | TakeMVarOp
+   | TryTakeMVarOp
+   | PutMVarOp
+   | TryPutMVarOp
+   | ReadMVarOp
+   | TryReadMVarOp
+   | SameMVarOp
+   | IsEmptyMVarOp
+   | DelayOp
+   | WaitReadOp
+   | WaitWriteOp
+   | ForkOp
+   | ForkOnOp
+   | KillThreadOp
+   | YieldOp
+   | MyThreadIdOp
+   | LabelThreadOp
+   | IsCurrentThreadBoundOp
+   | NoDuplicateOp
+   | ThreadStatusOp
+   | MkWeakOp
+   | MkWeakNoFinalizerOp
+   | AddCFinalizerToWeakOp
+   | DeRefWeakOp
+   | FinalizeWeakOp
+   | TouchOp
+   | MakeStablePtrOp
+   | DeRefStablePtrOp
+   | EqStablePtrOp
+   | MakeStableNameOp
+   | EqStableNameOp
+   | StableNameToIntOp
+   | CompactNewOp
+   | CompactResizeOp
+   | CompactContainsOp
+   | CompactContainsAnyOp
+   | CompactGetFirstBlockOp
+   | CompactGetNextBlockOp
+   | CompactAllocateBlockOp
+   | CompactFixupPointersOp
+   | CompactAdd
+   | CompactAddWithSharing
+   | CompactSize
+   | ReallyUnsafePtrEqualityOp
+   | ParOp
+   | SparkOp
+   | SeqOp
+   | GetSparkOp
+   | NumSparks
+   | DataToTagOp
+   | TagToEnumOp
+   | AddrToAnyOp
+   | AnyToAddrOp
+   | MkApUpd0_Op
+   | NewBCOOp
+   | UnpackClosureOp
+   | ClosureSizeOp
+   | GetApStackValOp
+   | GetCCSOfOp
+   | GetCurrentCCSOp
+   | ClearCCSOp
+   | TraceEventOp
+   | TraceEventBinaryOp
+   | TraceMarkerOp
+   | GetThreadAllocationCounter
+   | SetThreadAllocationCounter
+   | VecBroadcastOp PrimOpVecCat Length Width
+   | VecPackOp PrimOpVecCat Length Width
+   | VecUnpackOp PrimOpVecCat Length Width
+   | VecInsertOp PrimOpVecCat Length Width
+   | VecAddOp PrimOpVecCat Length Width
+   | VecSubOp PrimOpVecCat Length Width
+   | VecMulOp PrimOpVecCat Length Width
+   | VecDivOp PrimOpVecCat Length Width
+   | VecQuotOp PrimOpVecCat Length Width
+   | VecRemOp PrimOpVecCat Length Width
+   | VecNegOp PrimOpVecCat Length Width
+   | VecIndexByteArrayOp PrimOpVecCat Length Width
+   | VecReadByteArrayOp PrimOpVecCat Length Width
+   | VecWriteByteArrayOp PrimOpVecCat Length Width
+   | VecIndexOffAddrOp PrimOpVecCat Length Width
+   | VecReadOffAddrOp PrimOpVecCat Length Width
+   | VecWriteOffAddrOp PrimOpVecCat Length Width
+   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width
+   | VecReadScalarByteArrayOp PrimOpVecCat Length Width
+   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width
+   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width
+   | VecReadScalarOffAddrOp PrimOpVecCat Length Width
+   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width
+   | PrefetchByteArrayOp3
+   | PrefetchMutableByteArrayOp3
+   | PrefetchAddrOp3
+   | PrefetchValueOp3
+   | PrefetchByteArrayOp2
+   | PrefetchMutableByteArrayOp2
+   | PrefetchAddrOp2
+   | PrefetchValueOp2
+   | PrefetchByteArrayOp1
+   | PrefetchMutableByteArrayOp1
+   | PrefetchAddrOp1
+   | PrefetchValueOp1
+   | PrefetchByteArrayOp0
+   | PrefetchMutableByteArrayOp0
+   | PrefetchAddrOp0
+   | PrefetchValueOp0
diff --git a/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl b/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl
@@ -0,0 +1,20 @@
+primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)
+primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)
+primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)
+primOpFixity _ = Nothing
diff --git a/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl
@@ -0,0 +1,242 @@
+primOpHasSideEffects NewArrayOp = True
+primOpHasSideEffects ReadArrayOp = True
+primOpHasSideEffects WriteArrayOp = True
+primOpHasSideEffects UnsafeFreezeArrayOp = True
+primOpHasSideEffects UnsafeThawArrayOp = True
+primOpHasSideEffects CopyArrayOp = True
+primOpHasSideEffects CopyMutableArrayOp = True
+primOpHasSideEffects CloneArrayOp = True
+primOpHasSideEffects CloneMutableArrayOp = True
+primOpHasSideEffects FreezeArrayOp = True
+primOpHasSideEffects ThawArrayOp = True
+primOpHasSideEffects CasArrayOp = True
+primOpHasSideEffects NewSmallArrayOp = True
+primOpHasSideEffects ReadSmallArrayOp = True
+primOpHasSideEffects WriteSmallArrayOp = True
+primOpHasSideEffects UnsafeFreezeSmallArrayOp = True
+primOpHasSideEffects UnsafeThawSmallArrayOp = True
+primOpHasSideEffects CopySmallArrayOp = True
+primOpHasSideEffects CopySmallMutableArrayOp = True
+primOpHasSideEffects CloneSmallArrayOp = True
+primOpHasSideEffects CloneSmallMutableArrayOp = True
+primOpHasSideEffects FreezeSmallArrayOp = True
+primOpHasSideEffects ThawSmallArrayOp = True
+primOpHasSideEffects CasSmallArrayOp = True
+primOpHasSideEffects NewByteArrayOp_Char = True
+primOpHasSideEffects NewPinnedByteArrayOp_Char = True
+primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True
+primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True
+primOpHasSideEffects ResizeMutableByteArrayOp_Char = True
+primOpHasSideEffects UnsafeFreezeByteArrayOp = True
+primOpHasSideEffects ReadByteArrayOp_Char = True
+primOpHasSideEffects ReadByteArrayOp_WideChar = True
+primOpHasSideEffects ReadByteArrayOp_Int = True
+primOpHasSideEffects ReadByteArrayOp_Word = True
+primOpHasSideEffects ReadByteArrayOp_Addr = True
+primOpHasSideEffects ReadByteArrayOp_Float = True
+primOpHasSideEffects ReadByteArrayOp_Double = True
+primOpHasSideEffects ReadByteArrayOp_StablePtr = True
+primOpHasSideEffects ReadByteArrayOp_Int8 = True
+primOpHasSideEffects ReadByteArrayOp_Int16 = True
+primOpHasSideEffects ReadByteArrayOp_Int32 = True
+primOpHasSideEffects ReadByteArrayOp_Int64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8 = True
+primOpHasSideEffects ReadByteArrayOp_Word16 = True
+primOpHasSideEffects ReadByteArrayOp_Word32 = True
+primOpHasSideEffects ReadByteArrayOp_Word64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True
+primOpHasSideEffects WriteByteArrayOp_Char = True
+primOpHasSideEffects WriteByteArrayOp_WideChar = True
+primOpHasSideEffects WriteByteArrayOp_Int = True
+primOpHasSideEffects WriteByteArrayOp_Word = True
+primOpHasSideEffects WriteByteArrayOp_Addr = True
+primOpHasSideEffects WriteByteArrayOp_Float = True
+primOpHasSideEffects WriteByteArrayOp_Double = True
+primOpHasSideEffects WriteByteArrayOp_StablePtr = True
+primOpHasSideEffects WriteByteArrayOp_Int8 = True
+primOpHasSideEffects WriteByteArrayOp_Int16 = True
+primOpHasSideEffects WriteByteArrayOp_Int32 = True
+primOpHasSideEffects WriteByteArrayOp_Int64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8 = True
+primOpHasSideEffects WriteByteArrayOp_Word16 = True
+primOpHasSideEffects WriteByteArrayOp_Word32 = True
+primOpHasSideEffects WriteByteArrayOp_Word64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True
+primOpHasSideEffects CopyByteArrayOp = True
+primOpHasSideEffects CopyMutableByteArrayOp = True
+primOpHasSideEffects CopyByteArrayToAddrOp = True
+primOpHasSideEffects CopyMutableByteArrayToAddrOp = True
+primOpHasSideEffects CopyAddrToByteArrayOp = True
+primOpHasSideEffects SetByteArrayOp = True
+primOpHasSideEffects AtomicReadByteArrayOp_Int = True
+primOpHasSideEffects AtomicWriteByteArrayOp_Int = True
+primOpHasSideEffects CasByteArrayOp_Int = True
+primOpHasSideEffects FetchAddByteArrayOp_Int = True
+primOpHasSideEffects FetchSubByteArrayOp_Int = True
+primOpHasSideEffects FetchAndByteArrayOp_Int = True
+primOpHasSideEffects FetchNandByteArrayOp_Int = True
+primOpHasSideEffects FetchOrByteArrayOp_Int = True
+primOpHasSideEffects FetchXorByteArrayOp_Int = True
+primOpHasSideEffects NewArrayArrayOp = True
+primOpHasSideEffects UnsafeFreezeArrayArrayOp = True
+primOpHasSideEffects ReadArrayArrayOp_ByteArray = True
+primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True
+primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True
+primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True
+primOpHasSideEffects WriteArrayArrayOp_ByteArray = True
+primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True
+primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True
+primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True
+primOpHasSideEffects CopyArrayArrayOp = True
+primOpHasSideEffects CopyMutableArrayArrayOp = True
+primOpHasSideEffects ReadOffAddrOp_Char = True
+primOpHasSideEffects ReadOffAddrOp_WideChar = True
+primOpHasSideEffects ReadOffAddrOp_Int = True
+primOpHasSideEffects ReadOffAddrOp_Word = True
+primOpHasSideEffects ReadOffAddrOp_Addr = True
+primOpHasSideEffects ReadOffAddrOp_Float = True
+primOpHasSideEffects ReadOffAddrOp_Double = True
+primOpHasSideEffects ReadOffAddrOp_StablePtr = True
+primOpHasSideEffects ReadOffAddrOp_Int8 = True
+primOpHasSideEffects ReadOffAddrOp_Int16 = True
+primOpHasSideEffects ReadOffAddrOp_Int32 = True
+primOpHasSideEffects ReadOffAddrOp_Int64 = True
+primOpHasSideEffects ReadOffAddrOp_Word8 = True
+primOpHasSideEffects ReadOffAddrOp_Word16 = True
+primOpHasSideEffects ReadOffAddrOp_Word32 = True
+primOpHasSideEffects ReadOffAddrOp_Word64 = True
+primOpHasSideEffects WriteOffAddrOp_Char = True
+primOpHasSideEffects WriteOffAddrOp_WideChar = True
+primOpHasSideEffects WriteOffAddrOp_Int = True
+primOpHasSideEffects WriteOffAddrOp_Word = True
+primOpHasSideEffects WriteOffAddrOp_Addr = True
+primOpHasSideEffects WriteOffAddrOp_Float = True
+primOpHasSideEffects WriteOffAddrOp_Double = True
+primOpHasSideEffects WriteOffAddrOp_StablePtr = True
+primOpHasSideEffects WriteOffAddrOp_Int8 = True
+primOpHasSideEffects WriteOffAddrOp_Int16 = True
+primOpHasSideEffects WriteOffAddrOp_Int32 = True
+primOpHasSideEffects WriteOffAddrOp_Int64 = True
+primOpHasSideEffects WriteOffAddrOp_Word8 = True
+primOpHasSideEffects WriteOffAddrOp_Word16 = True
+primOpHasSideEffects WriteOffAddrOp_Word32 = True
+primOpHasSideEffects WriteOffAddrOp_Word64 = True
+primOpHasSideEffects NewMutVarOp = True
+primOpHasSideEffects ReadMutVarOp = True
+primOpHasSideEffects WriteMutVarOp = True
+primOpHasSideEffects AtomicModifyMutVar2Op = True
+primOpHasSideEffects AtomicModifyMutVar_Op = True
+primOpHasSideEffects CasMutVarOp = True
+primOpHasSideEffects CatchOp = True
+primOpHasSideEffects RaiseOp = True
+primOpHasSideEffects RaiseIOOp = True
+primOpHasSideEffects MaskAsyncExceptionsOp = True
+primOpHasSideEffects MaskUninterruptibleOp = True
+primOpHasSideEffects UnmaskAsyncExceptionsOp = True
+primOpHasSideEffects MaskStatus = True
+primOpHasSideEffects AtomicallyOp = True
+primOpHasSideEffects RetryOp = True
+primOpHasSideEffects CatchRetryOp = True
+primOpHasSideEffects CatchSTMOp = True
+primOpHasSideEffects NewTVarOp = True
+primOpHasSideEffects ReadTVarOp = True
+primOpHasSideEffects ReadTVarIOOp = True
+primOpHasSideEffects WriteTVarOp = True
+primOpHasSideEffects NewMVarOp = True
+primOpHasSideEffects TakeMVarOp = True
+primOpHasSideEffects TryTakeMVarOp = True
+primOpHasSideEffects PutMVarOp = True
+primOpHasSideEffects TryPutMVarOp = True
+primOpHasSideEffects ReadMVarOp = True
+primOpHasSideEffects TryReadMVarOp = True
+primOpHasSideEffects IsEmptyMVarOp = True
+primOpHasSideEffects DelayOp = True
+primOpHasSideEffects WaitReadOp = True
+primOpHasSideEffects WaitWriteOp = True
+primOpHasSideEffects ForkOp = True
+primOpHasSideEffects ForkOnOp = True
+primOpHasSideEffects KillThreadOp = True
+primOpHasSideEffects YieldOp = True
+primOpHasSideEffects MyThreadIdOp = True
+primOpHasSideEffects LabelThreadOp = True
+primOpHasSideEffects IsCurrentThreadBoundOp = True
+primOpHasSideEffects NoDuplicateOp = True
+primOpHasSideEffects ThreadStatusOp = True
+primOpHasSideEffects MkWeakOp = True
+primOpHasSideEffects MkWeakNoFinalizerOp = True
+primOpHasSideEffects AddCFinalizerToWeakOp = True
+primOpHasSideEffects DeRefWeakOp = True
+primOpHasSideEffects FinalizeWeakOp = True
+primOpHasSideEffects TouchOp = True
+primOpHasSideEffects MakeStablePtrOp = True
+primOpHasSideEffects DeRefStablePtrOp = True
+primOpHasSideEffects EqStablePtrOp = True
+primOpHasSideEffects MakeStableNameOp = True
+primOpHasSideEffects CompactNewOp = True
+primOpHasSideEffects CompactResizeOp = True
+primOpHasSideEffects CompactAllocateBlockOp = True
+primOpHasSideEffects CompactFixupPointersOp = True
+primOpHasSideEffects CompactAdd = True
+primOpHasSideEffects CompactAddWithSharing = True
+primOpHasSideEffects CompactSize = True
+primOpHasSideEffects ParOp = True
+primOpHasSideEffects SparkOp = True
+primOpHasSideEffects GetSparkOp = True
+primOpHasSideEffects NumSparks = True
+primOpHasSideEffects NewBCOOp = True
+primOpHasSideEffects TraceEventOp = True
+primOpHasSideEffects TraceEventBinaryOp = True
+primOpHasSideEffects TraceMarkerOp = True
+primOpHasSideEffects GetThreadAllocationCounter = True
+primOpHasSideEffects SetThreadAllocationCounter = True
+primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True
+primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True
+primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True
+primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True
+primOpHasSideEffects PrefetchByteArrayOp3 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp3 = True
+primOpHasSideEffects PrefetchAddrOp3 = True
+primOpHasSideEffects PrefetchValueOp3 = True
+primOpHasSideEffects PrefetchByteArrayOp2 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp2 = True
+primOpHasSideEffects PrefetchAddrOp2 = True
+primOpHasSideEffects PrefetchValueOp2 = True
+primOpHasSideEffects PrefetchByteArrayOp1 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp1 = True
+primOpHasSideEffects PrefetchAddrOp1 = True
+primOpHasSideEffects PrefetchValueOp1 = True
+primOpHasSideEffects PrefetchByteArrayOp0 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp0 = True
+primOpHasSideEffects PrefetchAddrOp0 = True
+primOpHasSideEffects PrefetchValueOp0 = True
+primOpHasSideEffects _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-list.hs-incl b/ghc-lib/stage1/compiler/build/primop-list.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-list.hs-incl
@@ -0,0 +1,1199 @@
+   [CharGtOp
+   , CharGeOp
+   , CharEqOp
+   , CharNeOp
+   , CharLtOp
+   , CharLeOp
+   , OrdOp
+   , IntAddOp
+   , IntSubOp
+   , IntMulOp
+   , IntMulMayOfloOp
+   , IntQuotOp
+   , IntRemOp
+   , IntQuotRemOp
+   , AndIOp
+   , OrIOp
+   , XorIOp
+   , NotIOp
+   , IntNegOp
+   , IntAddCOp
+   , IntSubCOp
+   , IntGtOp
+   , IntGeOp
+   , IntEqOp
+   , IntNeOp
+   , IntLtOp
+   , IntLeOp
+   , ChrOp
+   , Int2WordOp
+   , Int2FloatOp
+   , Int2DoubleOp
+   , Word2FloatOp
+   , Word2DoubleOp
+   , ISllOp
+   , ISraOp
+   , ISrlOp
+   , Int8Extend
+   , Int8Narrow
+   , Int8NegOp
+   , Int8AddOp
+   , Int8SubOp
+   , Int8MulOp
+   , Int8QuotOp
+   , Int8RemOp
+   , Int8QuotRemOp
+   , Int8EqOp
+   , Int8GeOp
+   , Int8GtOp
+   , Int8LeOp
+   , Int8LtOp
+   , Int8NeOp
+   , Word8Extend
+   , Word8Narrow
+   , Word8NotOp
+   , Word8AddOp
+   , Word8SubOp
+   , Word8MulOp
+   , Word8QuotOp
+   , Word8RemOp
+   , Word8QuotRemOp
+   , Word8EqOp
+   , Word8GeOp
+   , Word8GtOp
+   , Word8LeOp
+   , Word8LtOp
+   , Word8NeOp
+   , Int16Extend
+   , Int16Narrow
+   , Int16NegOp
+   , Int16AddOp
+   , Int16SubOp
+   , Int16MulOp
+   , Int16QuotOp
+   , Int16RemOp
+   , Int16QuotRemOp
+   , Int16EqOp
+   , Int16GeOp
+   , Int16GtOp
+   , Int16LeOp
+   , Int16LtOp
+   , Int16NeOp
+   , Word16Extend
+   , Word16Narrow
+   , Word16NotOp
+   , Word16AddOp
+   , Word16SubOp
+   , Word16MulOp
+   , Word16QuotOp
+   , Word16RemOp
+   , Word16QuotRemOp
+   , Word16EqOp
+   , Word16GeOp
+   , Word16GtOp
+   , Word16LeOp
+   , Word16LtOp
+   , Word16NeOp
+   , WordAddOp
+   , WordAddCOp
+   , WordSubCOp
+   , WordAdd2Op
+   , WordSubOp
+   , WordMulOp
+   , WordMul2Op
+   , WordQuotOp
+   , WordRemOp
+   , WordQuotRemOp
+   , WordQuotRem2Op
+   , AndOp
+   , OrOp
+   , XorOp
+   , NotOp
+   , SllOp
+   , SrlOp
+   , Word2IntOp
+   , WordGtOp
+   , WordGeOp
+   , WordEqOp
+   , WordNeOp
+   , WordLtOp
+   , WordLeOp
+   , PopCnt8Op
+   , PopCnt16Op
+   , PopCnt32Op
+   , PopCnt64Op
+   , PopCntOp
+   , Pdep8Op
+   , Pdep16Op
+   , Pdep32Op
+   , Pdep64Op
+   , PdepOp
+   , Pext8Op
+   , Pext16Op
+   , Pext32Op
+   , Pext64Op
+   , PextOp
+   , Clz8Op
+   , Clz16Op
+   , Clz32Op
+   , Clz64Op
+   , ClzOp
+   , Ctz8Op
+   , Ctz16Op
+   , Ctz32Op
+   , Ctz64Op
+   , CtzOp
+   , BSwap16Op
+   , BSwap32Op
+   , BSwap64Op
+   , BSwapOp
+   , BRev8Op
+   , BRev16Op
+   , BRev32Op
+   , BRev64Op
+   , BRevOp
+   , Narrow8IntOp
+   , Narrow16IntOp
+   , Narrow32IntOp
+   , Narrow8WordOp
+   , Narrow16WordOp
+   , Narrow32WordOp
+   , DoubleGtOp
+   , DoubleGeOp
+   , DoubleEqOp
+   , DoubleNeOp
+   , DoubleLtOp
+   , DoubleLeOp
+   , DoubleAddOp
+   , DoubleSubOp
+   , DoubleMulOp
+   , DoubleDivOp
+   , DoubleNegOp
+   , DoubleFabsOp
+   , Double2IntOp
+   , Double2FloatOp
+   , DoubleExpOp
+   , DoubleLogOp
+   , DoubleSqrtOp
+   , DoubleSinOp
+   , DoubleCosOp
+   , DoubleTanOp
+   , DoubleAsinOp
+   , DoubleAcosOp
+   , DoubleAtanOp
+   , DoubleSinhOp
+   , DoubleCoshOp
+   , DoubleTanhOp
+   , DoubleAsinhOp
+   , DoubleAcoshOp
+   , DoubleAtanhOp
+   , DoublePowerOp
+   , DoubleDecode_2IntOp
+   , DoubleDecode_Int64Op
+   , FloatGtOp
+   , FloatGeOp
+   , FloatEqOp
+   , FloatNeOp
+   , FloatLtOp
+   , FloatLeOp
+   , FloatAddOp
+   , FloatSubOp
+   , FloatMulOp
+   , FloatDivOp
+   , FloatNegOp
+   , FloatFabsOp
+   , Float2IntOp
+   , FloatExpOp
+   , FloatLogOp
+   , FloatSqrtOp
+   , FloatSinOp
+   , FloatCosOp
+   , FloatTanOp
+   , FloatAsinOp
+   , FloatAcosOp
+   , FloatAtanOp
+   , FloatSinhOp
+   , FloatCoshOp
+   , FloatTanhOp
+   , FloatAsinhOp
+   , FloatAcoshOp
+   , FloatAtanhOp
+   , FloatPowerOp
+   , Float2DoubleOp
+   , FloatDecode_IntOp
+   , NewArrayOp
+   , SameMutableArrayOp
+   , ReadArrayOp
+   , WriteArrayOp
+   , SizeofArrayOp
+   , SizeofMutableArrayOp
+   , IndexArrayOp
+   , UnsafeFreezeArrayOp
+   , UnsafeThawArrayOp
+   , CopyArrayOp
+   , CopyMutableArrayOp
+   , CloneArrayOp
+   , CloneMutableArrayOp
+   , FreezeArrayOp
+   , ThawArrayOp
+   , CasArrayOp
+   , NewSmallArrayOp
+   , SameSmallMutableArrayOp
+   , ReadSmallArrayOp
+   , WriteSmallArrayOp
+   , SizeofSmallArrayOp
+   , SizeofSmallMutableArrayOp
+   , IndexSmallArrayOp
+   , UnsafeFreezeSmallArrayOp
+   , UnsafeThawSmallArrayOp
+   , CopySmallArrayOp
+   , CopySmallMutableArrayOp
+   , CloneSmallArrayOp
+   , CloneSmallMutableArrayOp
+   , FreezeSmallArrayOp
+   , ThawSmallArrayOp
+   , CasSmallArrayOp
+   , NewByteArrayOp_Char
+   , NewPinnedByteArrayOp_Char
+   , NewAlignedPinnedByteArrayOp_Char
+   , MutableByteArrayIsPinnedOp
+   , ByteArrayIsPinnedOp
+   , ByteArrayContents_Char
+   , SameMutableByteArrayOp
+   , ShrinkMutableByteArrayOp_Char
+   , ResizeMutableByteArrayOp_Char
+   , UnsafeFreezeByteArrayOp
+   , SizeofByteArrayOp
+   , SizeofMutableByteArrayOp
+   , GetSizeofMutableByteArrayOp
+   , IndexByteArrayOp_Char
+   , IndexByteArrayOp_WideChar
+   , IndexByteArrayOp_Int
+   , IndexByteArrayOp_Word
+   , IndexByteArrayOp_Addr
+   , IndexByteArrayOp_Float
+   , IndexByteArrayOp_Double
+   , IndexByteArrayOp_StablePtr
+   , IndexByteArrayOp_Int8
+   , IndexByteArrayOp_Int16
+   , IndexByteArrayOp_Int32
+   , IndexByteArrayOp_Int64
+   , IndexByteArrayOp_Word8
+   , IndexByteArrayOp_Word16
+   , IndexByteArrayOp_Word32
+   , IndexByteArrayOp_Word64
+   , IndexByteArrayOp_Word8AsChar
+   , IndexByteArrayOp_Word8AsWideChar
+   , IndexByteArrayOp_Word8AsAddr
+   , IndexByteArrayOp_Word8AsFloat
+   , IndexByteArrayOp_Word8AsDouble
+   , IndexByteArrayOp_Word8AsStablePtr
+   , IndexByteArrayOp_Word8AsInt16
+   , IndexByteArrayOp_Word8AsInt32
+   , IndexByteArrayOp_Word8AsInt64
+   , IndexByteArrayOp_Word8AsInt
+   , IndexByteArrayOp_Word8AsWord16
+   , IndexByteArrayOp_Word8AsWord32
+   , IndexByteArrayOp_Word8AsWord64
+   , IndexByteArrayOp_Word8AsWord
+   , ReadByteArrayOp_Char
+   , ReadByteArrayOp_WideChar
+   , ReadByteArrayOp_Int
+   , ReadByteArrayOp_Word
+   , ReadByteArrayOp_Addr
+   , ReadByteArrayOp_Float
+   , ReadByteArrayOp_Double
+   , ReadByteArrayOp_StablePtr
+   , ReadByteArrayOp_Int8
+   , ReadByteArrayOp_Int16
+   , ReadByteArrayOp_Int32
+   , ReadByteArrayOp_Int64
+   , ReadByteArrayOp_Word8
+   , ReadByteArrayOp_Word16
+   , ReadByteArrayOp_Word32
+   , ReadByteArrayOp_Word64
+   , ReadByteArrayOp_Word8AsChar
+   , ReadByteArrayOp_Word8AsWideChar
+   , ReadByteArrayOp_Word8AsAddr
+   , ReadByteArrayOp_Word8AsFloat
+   , ReadByteArrayOp_Word8AsDouble
+   , ReadByteArrayOp_Word8AsStablePtr
+   , ReadByteArrayOp_Word8AsInt16
+   , ReadByteArrayOp_Word8AsInt32
+   , ReadByteArrayOp_Word8AsInt64
+   , ReadByteArrayOp_Word8AsInt
+   , ReadByteArrayOp_Word8AsWord16
+   , ReadByteArrayOp_Word8AsWord32
+   , ReadByteArrayOp_Word8AsWord64
+   , ReadByteArrayOp_Word8AsWord
+   , WriteByteArrayOp_Char
+   , WriteByteArrayOp_WideChar
+   , WriteByteArrayOp_Int
+   , WriteByteArrayOp_Word
+   , WriteByteArrayOp_Addr
+   , WriteByteArrayOp_Float
+   , WriteByteArrayOp_Double
+   , WriteByteArrayOp_StablePtr
+   , WriteByteArrayOp_Int8
+   , WriteByteArrayOp_Int16
+   , WriteByteArrayOp_Int32
+   , WriteByteArrayOp_Int64
+   , WriteByteArrayOp_Word8
+   , WriteByteArrayOp_Word16
+   , WriteByteArrayOp_Word32
+   , WriteByteArrayOp_Word64
+   , WriteByteArrayOp_Word8AsChar
+   , WriteByteArrayOp_Word8AsWideChar
+   , WriteByteArrayOp_Word8AsAddr
+   , WriteByteArrayOp_Word8AsFloat
+   , WriteByteArrayOp_Word8AsDouble
+   , WriteByteArrayOp_Word8AsStablePtr
+   , WriteByteArrayOp_Word8AsInt16
+   , WriteByteArrayOp_Word8AsInt32
+   , WriteByteArrayOp_Word8AsInt64
+   , WriteByteArrayOp_Word8AsInt
+   , WriteByteArrayOp_Word8AsWord16
+   , WriteByteArrayOp_Word8AsWord32
+   , WriteByteArrayOp_Word8AsWord64
+   , WriteByteArrayOp_Word8AsWord
+   , CompareByteArraysOp
+   , CopyByteArrayOp
+   , CopyMutableByteArrayOp
+   , CopyByteArrayToAddrOp
+   , CopyMutableByteArrayToAddrOp
+   , CopyAddrToByteArrayOp
+   , SetByteArrayOp
+   , AtomicReadByteArrayOp_Int
+   , AtomicWriteByteArrayOp_Int
+   , CasByteArrayOp_Int
+   , FetchAddByteArrayOp_Int
+   , FetchSubByteArrayOp_Int
+   , FetchAndByteArrayOp_Int
+   , FetchNandByteArrayOp_Int
+   , FetchOrByteArrayOp_Int
+   , FetchXorByteArrayOp_Int
+   , NewArrayArrayOp
+   , SameMutableArrayArrayOp
+   , UnsafeFreezeArrayArrayOp
+   , SizeofArrayArrayOp
+   , SizeofMutableArrayArrayOp
+   , IndexArrayArrayOp_ByteArray
+   , IndexArrayArrayOp_ArrayArray
+   , ReadArrayArrayOp_ByteArray
+   , ReadArrayArrayOp_MutableByteArray
+   , ReadArrayArrayOp_ArrayArray
+   , ReadArrayArrayOp_MutableArrayArray
+   , WriteArrayArrayOp_ByteArray
+   , WriteArrayArrayOp_MutableByteArray
+   , WriteArrayArrayOp_ArrayArray
+   , WriteArrayArrayOp_MutableArrayArray
+   , CopyArrayArrayOp
+   , CopyMutableArrayArrayOp
+   , AddrAddOp
+   , AddrSubOp
+   , AddrRemOp
+   , Addr2IntOp
+   , Int2AddrOp
+   , AddrGtOp
+   , AddrGeOp
+   , AddrEqOp
+   , AddrNeOp
+   , AddrLtOp
+   , AddrLeOp
+   , IndexOffAddrOp_Char
+   , IndexOffAddrOp_WideChar
+   , IndexOffAddrOp_Int
+   , IndexOffAddrOp_Word
+   , IndexOffAddrOp_Addr
+   , IndexOffAddrOp_Float
+   , IndexOffAddrOp_Double
+   , IndexOffAddrOp_StablePtr
+   , IndexOffAddrOp_Int8
+   , IndexOffAddrOp_Int16
+   , IndexOffAddrOp_Int32
+   , IndexOffAddrOp_Int64
+   , IndexOffAddrOp_Word8
+   , IndexOffAddrOp_Word16
+   , IndexOffAddrOp_Word32
+   , IndexOffAddrOp_Word64
+   , ReadOffAddrOp_Char
+   , ReadOffAddrOp_WideChar
+   , ReadOffAddrOp_Int
+   , ReadOffAddrOp_Word
+   , ReadOffAddrOp_Addr
+   , ReadOffAddrOp_Float
+   , ReadOffAddrOp_Double
+   , ReadOffAddrOp_StablePtr
+   , ReadOffAddrOp_Int8
+   , ReadOffAddrOp_Int16
+   , ReadOffAddrOp_Int32
+   , ReadOffAddrOp_Int64
+   , ReadOffAddrOp_Word8
+   , ReadOffAddrOp_Word16
+   , ReadOffAddrOp_Word32
+   , ReadOffAddrOp_Word64
+   , WriteOffAddrOp_Char
+   , WriteOffAddrOp_WideChar
+   , WriteOffAddrOp_Int
+   , WriteOffAddrOp_Word
+   , WriteOffAddrOp_Addr
+   , WriteOffAddrOp_Float
+   , WriteOffAddrOp_Double
+   , WriteOffAddrOp_StablePtr
+   , WriteOffAddrOp_Int8
+   , WriteOffAddrOp_Int16
+   , WriteOffAddrOp_Int32
+   , WriteOffAddrOp_Int64
+   , WriteOffAddrOp_Word8
+   , WriteOffAddrOp_Word16
+   , WriteOffAddrOp_Word32
+   , WriteOffAddrOp_Word64
+   , NewMutVarOp
+   , ReadMutVarOp
+   , WriteMutVarOp
+   , SameMutVarOp
+   , AtomicModifyMutVar2Op
+   , AtomicModifyMutVar_Op
+   , CasMutVarOp
+   , CatchOp
+   , RaiseOp
+   , RaiseIOOp
+   , MaskAsyncExceptionsOp
+   , MaskUninterruptibleOp
+   , UnmaskAsyncExceptionsOp
+   , MaskStatus
+   , AtomicallyOp
+   , RetryOp
+   , CatchRetryOp
+   , CatchSTMOp
+   , NewTVarOp
+   , ReadTVarOp
+   , ReadTVarIOOp
+   , WriteTVarOp
+   , SameTVarOp
+   , NewMVarOp
+   , TakeMVarOp
+   , TryTakeMVarOp
+   , PutMVarOp
+   , TryPutMVarOp
+   , ReadMVarOp
+   , TryReadMVarOp
+   , SameMVarOp
+   , IsEmptyMVarOp
+   , DelayOp
+   , WaitReadOp
+   , WaitWriteOp
+   , ForkOp
+   , ForkOnOp
+   , KillThreadOp
+   , YieldOp
+   , MyThreadIdOp
+   , LabelThreadOp
+   , IsCurrentThreadBoundOp
+   , NoDuplicateOp
+   , ThreadStatusOp
+   , MkWeakOp
+   , MkWeakNoFinalizerOp
+   , AddCFinalizerToWeakOp
+   , DeRefWeakOp
+   , FinalizeWeakOp
+   , TouchOp
+   , MakeStablePtrOp
+   , DeRefStablePtrOp
+   , EqStablePtrOp
+   , MakeStableNameOp
+   , EqStableNameOp
+   , StableNameToIntOp
+   , CompactNewOp
+   , CompactResizeOp
+   , CompactContainsOp
+   , CompactContainsAnyOp
+   , CompactGetFirstBlockOp
+   , CompactGetNextBlockOp
+   , CompactAllocateBlockOp
+   , CompactFixupPointersOp
+   , CompactAdd
+   , CompactAddWithSharing
+   , CompactSize
+   , ReallyUnsafePtrEqualityOp
+   , ParOp
+   , SparkOp
+   , SeqOp
+   , GetSparkOp
+   , NumSparks
+   , DataToTagOp
+   , TagToEnumOp
+   , AddrToAnyOp
+   , AnyToAddrOp
+   , MkApUpd0_Op
+   , NewBCOOp
+   , UnpackClosureOp
+   , ClosureSizeOp
+   , GetApStackValOp
+   , GetCCSOfOp
+   , GetCurrentCCSOp
+   , ClearCCSOp
+   , TraceEventOp
+   , TraceEventBinaryOp
+   , TraceMarkerOp
+   , GetThreadAllocationCounter
+   , SetThreadAllocationCounter
+   , (VecBroadcastOp IntVec 16 W8)
+   , (VecBroadcastOp IntVec 8 W16)
+   , (VecBroadcastOp IntVec 4 W32)
+   , (VecBroadcastOp IntVec 2 W64)
+   , (VecBroadcastOp IntVec 32 W8)
+   , (VecBroadcastOp IntVec 16 W16)
+   , (VecBroadcastOp IntVec 8 W32)
+   , (VecBroadcastOp IntVec 4 W64)
+   , (VecBroadcastOp IntVec 64 W8)
+   , (VecBroadcastOp IntVec 32 W16)
+   , (VecBroadcastOp IntVec 16 W32)
+   , (VecBroadcastOp IntVec 8 W64)
+   , (VecBroadcastOp WordVec 16 W8)
+   , (VecBroadcastOp WordVec 8 W16)
+   , (VecBroadcastOp WordVec 4 W32)
+   , (VecBroadcastOp WordVec 2 W64)
+   , (VecBroadcastOp WordVec 32 W8)
+   , (VecBroadcastOp WordVec 16 W16)
+   , (VecBroadcastOp WordVec 8 W32)
+   , (VecBroadcastOp WordVec 4 W64)
+   , (VecBroadcastOp WordVec 64 W8)
+   , (VecBroadcastOp WordVec 32 W16)
+   , (VecBroadcastOp WordVec 16 W32)
+   , (VecBroadcastOp WordVec 8 W64)
+   , (VecBroadcastOp FloatVec 4 W32)
+   , (VecBroadcastOp FloatVec 2 W64)
+   , (VecBroadcastOp FloatVec 8 W32)
+   , (VecBroadcastOp FloatVec 4 W64)
+   , (VecBroadcastOp FloatVec 16 W32)
+   , (VecBroadcastOp FloatVec 8 W64)
+   , (VecPackOp IntVec 16 W8)
+   , (VecPackOp IntVec 8 W16)
+   , (VecPackOp IntVec 4 W32)
+   , (VecPackOp IntVec 2 W64)
+   , (VecPackOp IntVec 32 W8)
+   , (VecPackOp IntVec 16 W16)
+   , (VecPackOp IntVec 8 W32)
+   , (VecPackOp IntVec 4 W64)
+   , (VecPackOp IntVec 64 W8)
+   , (VecPackOp IntVec 32 W16)
+   , (VecPackOp IntVec 16 W32)
+   , (VecPackOp IntVec 8 W64)
+   , (VecPackOp WordVec 16 W8)
+   , (VecPackOp WordVec 8 W16)
+   , (VecPackOp WordVec 4 W32)
+   , (VecPackOp WordVec 2 W64)
+   , (VecPackOp WordVec 32 W8)
+   , (VecPackOp WordVec 16 W16)
+   , (VecPackOp WordVec 8 W32)
+   , (VecPackOp WordVec 4 W64)
+   , (VecPackOp WordVec 64 W8)
+   , (VecPackOp WordVec 32 W16)
+   , (VecPackOp WordVec 16 W32)
+   , (VecPackOp WordVec 8 W64)
+   , (VecPackOp FloatVec 4 W32)
+   , (VecPackOp FloatVec 2 W64)
+   , (VecPackOp FloatVec 8 W32)
+   , (VecPackOp FloatVec 4 W64)
+   , (VecPackOp FloatVec 16 W32)
+   , (VecPackOp FloatVec 8 W64)
+   , (VecUnpackOp IntVec 16 W8)
+   , (VecUnpackOp IntVec 8 W16)
+   , (VecUnpackOp IntVec 4 W32)
+   , (VecUnpackOp IntVec 2 W64)
+   , (VecUnpackOp IntVec 32 W8)
+   , (VecUnpackOp IntVec 16 W16)
+   , (VecUnpackOp IntVec 8 W32)
+   , (VecUnpackOp IntVec 4 W64)
+   , (VecUnpackOp IntVec 64 W8)
+   , (VecUnpackOp IntVec 32 W16)
+   , (VecUnpackOp IntVec 16 W32)
+   , (VecUnpackOp IntVec 8 W64)
+   , (VecUnpackOp WordVec 16 W8)
+   , (VecUnpackOp WordVec 8 W16)
+   , (VecUnpackOp WordVec 4 W32)
+   , (VecUnpackOp WordVec 2 W64)
+   , (VecUnpackOp WordVec 32 W8)
+   , (VecUnpackOp WordVec 16 W16)
+   , (VecUnpackOp WordVec 8 W32)
+   , (VecUnpackOp WordVec 4 W64)
+   , (VecUnpackOp WordVec 64 W8)
+   , (VecUnpackOp WordVec 32 W16)
+   , (VecUnpackOp WordVec 16 W32)
+   , (VecUnpackOp WordVec 8 W64)
+   , (VecUnpackOp FloatVec 4 W32)
+   , (VecUnpackOp FloatVec 2 W64)
+   , (VecUnpackOp FloatVec 8 W32)
+   , (VecUnpackOp FloatVec 4 W64)
+   , (VecUnpackOp FloatVec 16 W32)
+   , (VecUnpackOp FloatVec 8 W64)
+   , (VecInsertOp IntVec 16 W8)
+   , (VecInsertOp IntVec 8 W16)
+   , (VecInsertOp IntVec 4 W32)
+   , (VecInsertOp IntVec 2 W64)
+   , (VecInsertOp IntVec 32 W8)
+   , (VecInsertOp IntVec 16 W16)
+   , (VecInsertOp IntVec 8 W32)
+   , (VecInsertOp IntVec 4 W64)
+   , (VecInsertOp IntVec 64 W8)
+   , (VecInsertOp IntVec 32 W16)
+   , (VecInsertOp IntVec 16 W32)
+   , (VecInsertOp IntVec 8 W64)
+   , (VecInsertOp WordVec 16 W8)
+   , (VecInsertOp WordVec 8 W16)
+   , (VecInsertOp WordVec 4 W32)
+   , (VecInsertOp WordVec 2 W64)
+   , (VecInsertOp WordVec 32 W8)
+   , (VecInsertOp WordVec 16 W16)
+   , (VecInsertOp WordVec 8 W32)
+   , (VecInsertOp WordVec 4 W64)
+   , (VecInsertOp WordVec 64 W8)
+   , (VecInsertOp WordVec 32 W16)
+   , (VecInsertOp WordVec 16 W32)
+   , (VecInsertOp WordVec 8 W64)
+   , (VecInsertOp FloatVec 4 W32)
+   , (VecInsertOp FloatVec 2 W64)
+   , (VecInsertOp FloatVec 8 W32)
+   , (VecInsertOp FloatVec 4 W64)
+   , (VecInsertOp FloatVec 16 W32)
+   , (VecInsertOp FloatVec 8 W64)
+   , (VecAddOp IntVec 16 W8)
+   , (VecAddOp IntVec 8 W16)
+   , (VecAddOp IntVec 4 W32)
+   , (VecAddOp IntVec 2 W64)
+   , (VecAddOp IntVec 32 W8)
+   , (VecAddOp IntVec 16 W16)
+   , (VecAddOp IntVec 8 W32)
+   , (VecAddOp IntVec 4 W64)
+   , (VecAddOp IntVec 64 W8)
+   , (VecAddOp IntVec 32 W16)
+   , (VecAddOp IntVec 16 W32)
+   , (VecAddOp IntVec 8 W64)
+   , (VecAddOp WordVec 16 W8)
+   , (VecAddOp WordVec 8 W16)
+   , (VecAddOp WordVec 4 W32)
+   , (VecAddOp WordVec 2 W64)
+   , (VecAddOp WordVec 32 W8)
+   , (VecAddOp WordVec 16 W16)
+   , (VecAddOp WordVec 8 W32)
+   , (VecAddOp WordVec 4 W64)
+   , (VecAddOp WordVec 64 W8)
+   , (VecAddOp WordVec 32 W16)
+   , (VecAddOp WordVec 16 W32)
+   , (VecAddOp WordVec 8 W64)
+   , (VecAddOp FloatVec 4 W32)
+   , (VecAddOp FloatVec 2 W64)
+   , (VecAddOp FloatVec 8 W32)
+   , (VecAddOp FloatVec 4 W64)
+   , (VecAddOp FloatVec 16 W32)
+   , (VecAddOp FloatVec 8 W64)
+   , (VecSubOp IntVec 16 W8)
+   , (VecSubOp IntVec 8 W16)
+   , (VecSubOp IntVec 4 W32)
+   , (VecSubOp IntVec 2 W64)
+   , (VecSubOp IntVec 32 W8)
+   , (VecSubOp IntVec 16 W16)
+   , (VecSubOp IntVec 8 W32)
+   , (VecSubOp IntVec 4 W64)
+   , (VecSubOp IntVec 64 W8)
+   , (VecSubOp IntVec 32 W16)
+   , (VecSubOp IntVec 16 W32)
+   , (VecSubOp IntVec 8 W64)
+   , (VecSubOp WordVec 16 W8)
+   , (VecSubOp WordVec 8 W16)
+   , (VecSubOp WordVec 4 W32)
+   , (VecSubOp WordVec 2 W64)
+   , (VecSubOp WordVec 32 W8)
+   , (VecSubOp WordVec 16 W16)
+   , (VecSubOp WordVec 8 W32)
+   , (VecSubOp WordVec 4 W64)
+   , (VecSubOp WordVec 64 W8)
+   , (VecSubOp WordVec 32 W16)
+   , (VecSubOp WordVec 16 W32)
+   , (VecSubOp WordVec 8 W64)
+   , (VecSubOp FloatVec 4 W32)
+   , (VecSubOp FloatVec 2 W64)
+   , (VecSubOp FloatVec 8 W32)
+   , (VecSubOp FloatVec 4 W64)
+   , (VecSubOp FloatVec 16 W32)
+   , (VecSubOp FloatVec 8 W64)
+   , (VecMulOp IntVec 16 W8)
+   , (VecMulOp IntVec 8 W16)
+   , (VecMulOp IntVec 4 W32)
+   , (VecMulOp IntVec 2 W64)
+   , (VecMulOp IntVec 32 W8)
+   , (VecMulOp IntVec 16 W16)
+   , (VecMulOp IntVec 8 W32)
+   , (VecMulOp IntVec 4 W64)
+   , (VecMulOp IntVec 64 W8)
+   , (VecMulOp IntVec 32 W16)
+   , (VecMulOp IntVec 16 W32)
+   , (VecMulOp IntVec 8 W64)
+   , (VecMulOp WordVec 16 W8)
+   , (VecMulOp WordVec 8 W16)
+   , (VecMulOp WordVec 4 W32)
+   , (VecMulOp WordVec 2 W64)
+   , (VecMulOp WordVec 32 W8)
+   , (VecMulOp WordVec 16 W16)
+   , (VecMulOp WordVec 8 W32)
+   , (VecMulOp WordVec 4 W64)
+   , (VecMulOp WordVec 64 W8)
+   , (VecMulOp WordVec 32 W16)
+   , (VecMulOp WordVec 16 W32)
+   , (VecMulOp WordVec 8 W64)
+   , (VecMulOp FloatVec 4 W32)
+   , (VecMulOp FloatVec 2 W64)
+   , (VecMulOp FloatVec 8 W32)
+   , (VecMulOp FloatVec 4 W64)
+   , (VecMulOp FloatVec 16 W32)
+   , (VecMulOp FloatVec 8 W64)
+   , (VecDivOp FloatVec 4 W32)
+   , (VecDivOp FloatVec 2 W64)
+   , (VecDivOp FloatVec 8 W32)
+   , (VecDivOp FloatVec 4 W64)
+   , (VecDivOp FloatVec 16 W32)
+   , (VecDivOp FloatVec 8 W64)
+   , (VecQuotOp IntVec 16 W8)
+   , (VecQuotOp IntVec 8 W16)
+   , (VecQuotOp IntVec 4 W32)
+   , (VecQuotOp IntVec 2 W64)
+   , (VecQuotOp IntVec 32 W8)
+   , (VecQuotOp IntVec 16 W16)
+   , (VecQuotOp IntVec 8 W32)
+   , (VecQuotOp IntVec 4 W64)
+   , (VecQuotOp IntVec 64 W8)
+   , (VecQuotOp IntVec 32 W16)
+   , (VecQuotOp IntVec 16 W32)
+   , (VecQuotOp IntVec 8 W64)
+   , (VecQuotOp WordVec 16 W8)
+   , (VecQuotOp WordVec 8 W16)
+   , (VecQuotOp WordVec 4 W32)
+   , (VecQuotOp WordVec 2 W64)
+   , (VecQuotOp WordVec 32 W8)
+   , (VecQuotOp WordVec 16 W16)
+   , (VecQuotOp WordVec 8 W32)
+   , (VecQuotOp WordVec 4 W64)
+   , (VecQuotOp WordVec 64 W8)
+   , (VecQuotOp WordVec 32 W16)
+   , (VecQuotOp WordVec 16 W32)
+   , (VecQuotOp WordVec 8 W64)
+   , (VecRemOp IntVec 16 W8)
+   , (VecRemOp IntVec 8 W16)
+   , (VecRemOp IntVec 4 W32)
+   , (VecRemOp IntVec 2 W64)
+   , (VecRemOp IntVec 32 W8)
+   , (VecRemOp IntVec 16 W16)
+   , (VecRemOp IntVec 8 W32)
+   , (VecRemOp IntVec 4 W64)
+   , (VecRemOp IntVec 64 W8)
+   , (VecRemOp IntVec 32 W16)
+   , (VecRemOp IntVec 16 W32)
+   , (VecRemOp IntVec 8 W64)
+   , (VecRemOp WordVec 16 W8)
+   , (VecRemOp WordVec 8 W16)
+   , (VecRemOp WordVec 4 W32)
+   , (VecRemOp WordVec 2 W64)
+   , (VecRemOp WordVec 32 W8)
+   , (VecRemOp WordVec 16 W16)
+   , (VecRemOp WordVec 8 W32)
+   , (VecRemOp WordVec 4 W64)
+   , (VecRemOp WordVec 64 W8)
+   , (VecRemOp WordVec 32 W16)
+   , (VecRemOp WordVec 16 W32)
+   , (VecRemOp WordVec 8 W64)
+   , (VecNegOp IntVec 16 W8)
+   , (VecNegOp IntVec 8 W16)
+   , (VecNegOp IntVec 4 W32)
+   , (VecNegOp IntVec 2 W64)
+   , (VecNegOp IntVec 32 W8)
+   , (VecNegOp IntVec 16 W16)
+   , (VecNegOp IntVec 8 W32)
+   , (VecNegOp IntVec 4 W64)
+   , (VecNegOp IntVec 64 W8)
+   , (VecNegOp IntVec 32 W16)
+   , (VecNegOp IntVec 16 W32)
+   , (VecNegOp IntVec 8 W64)
+   , (VecNegOp FloatVec 4 W32)
+   , (VecNegOp FloatVec 2 W64)
+   , (VecNegOp FloatVec 8 W32)
+   , (VecNegOp FloatVec 4 W64)
+   , (VecNegOp FloatVec 16 W32)
+   , (VecNegOp FloatVec 8 W64)
+   , (VecIndexByteArrayOp IntVec 16 W8)
+   , (VecIndexByteArrayOp IntVec 8 W16)
+   , (VecIndexByteArrayOp IntVec 4 W32)
+   , (VecIndexByteArrayOp IntVec 2 W64)
+   , (VecIndexByteArrayOp IntVec 32 W8)
+   , (VecIndexByteArrayOp IntVec 16 W16)
+   , (VecIndexByteArrayOp IntVec 8 W32)
+   , (VecIndexByteArrayOp IntVec 4 W64)
+   , (VecIndexByteArrayOp IntVec 64 W8)
+   , (VecIndexByteArrayOp IntVec 32 W16)
+   , (VecIndexByteArrayOp IntVec 16 W32)
+   , (VecIndexByteArrayOp IntVec 8 W64)
+   , (VecIndexByteArrayOp WordVec 16 W8)
+   , (VecIndexByteArrayOp WordVec 8 W16)
+   , (VecIndexByteArrayOp WordVec 4 W32)
+   , (VecIndexByteArrayOp WordVec 2 W64)
+   , (VecIndexByteArrayOp WordVec 32 W8)
+   , (VecIndexByteArrayOp WordVec 16 W16)
+   , (VecIndexByteArrayOp WordVec 8 W32)
+   , (VecIndexByteArrayOp WordVec 4 W64)
+   , (VecIndexByteArrayOp WordVec 64 W8)
+   , (VecIndexByteArrayOp WordVec 32 W16)
+   , (VecIndexByteArrayOp WordVec 16 W32)
+   , (VecIndexByteArrayOp WordVec 8 W64)
+   , (VecIndexByteArrayOp FloatVec 4 W32)
+   , (VecIndexByteArrayOp FloatVec 2 W64)
+   , (VecIndexByteArrayOp FloatVec 8 W32)
+   , (VecIndexByteArrayOp FloatVec 4 W64)
+   , (VecIndexByteArrayOp FloatVec 16 W32)
+   , (VecIndexByteArrayOp FloatVec 8 W64)
+   , (VecReadByteArrayOp IntVec 16 W8)
+   , (VecReadByteArrayOp IntVec 8 W16)
+   , (VecReadByteArrayOp IntVec 4 W32)
+   , (VecReadByteArrayOp IntVec 2 W64)
+   , (VecReadByteArrayOp IntVec 32 W8)
+   , (VecReadByteArrayOp IntVec 16 W16)
+   , (VecReadByteArrayOp IntVec 8 W32)
+   , (VecReadByteArrayOp IntVec 4 W64)
+   , (VecReadByteArrayOp IntVec 64 W8)
+   , (VecReadByteArrayOp IntVec 32 W16)
+   , (VecReadByteArrayOp IntVec 16 W32)
+   , (VecReadByteArrayOp IntVec 8 W64)
+   , (VecReadByteArrayOp WordVec 16 W8)
+   , (VecReadByteArrayOp WordVec 8 W16)
+   , (VecReadByteArrayOp WordVec 4 W32)
+   , (VecReadByteArrayOp WordVec 2 W64)
+   , (VecReadByteArrayOp WordVec 32 W8)
+   , (VecReadByteArrayOp WordVec 16 W16)
+   , (VecReadByteArrayOp WordVec 8 W32)
+   , (VecReadByteArrayOp WordVec 4 W64)
+   , (VecReadByteArrayOp WordVec 64 W8)
+   , (VecReadByteArrayOp WordVec 32 W16)
+   , (VecReadByteArrayOp WordVec 16 W32)
+   , (VecReadByteArrayOp WordVec 8 W64)
+   , (VecReadByteArrayOp FloatVec 4 W32)
+   , (VecReadByteArrayOp FloatVec 2 W64)
+   , (VecReadByteArrayOp FloatVec 8 W32)
+   , (VecReadByteArrayOp FloatVec 4 W64)
+   , (VecReadByteArrayOp FloatVec 16 W32)
+   , (VecReadByteArrayOp FloatVec 8 W64)
+   , (VecWriteByteArrayOp IntVec 16 W8)
+   , (VecWriteByteArrayOp IntVec 8 W16)
+   , (VecWriteByteArrayOp IntVec 4 W32)
+   , (VecWriteByteArrayOp IntVec 2 W64)
+   , (VecWriteByteArrayOp IntVec 32 W8)
+   , (VecWriteByteArrayOp IntVec 16 W16)
+   , (VecWriteByteArrayOp IntVec 8 W32)
+   , (VecWriteByteArrayOp IntVec 4 W64)
+   , (VecWriteByteArrayOp IntVec 64 W8)
+   , (VecWriteByteArrayOp IntVec 32 W16)
+   , (VecWriteByteArrayOp IntVec 16 W32)
+   , (VecWriteByteArrayOp IntVec 8 W64)
+   , (VecWriteByteArrayOp WordVec 16 W8)
+   , (VecWriteByteArrayOp WordVec 8 W16)
+   , (VecWriteByteArrayOp WordVec 4 W32)
+   , (VecWriteByteArrayOp WordVec 2 W64)
+   , (VecWriteByteArrayOp WordVec 32 W8)
+   , (VecWriteByteArrayOp WordVec 16 W16)
+   , (VecWriteByteArrayOp WordVec 8 W32)
+   , (VecWriteByteArrayOp WordVec 4 W64)
+   , (VecWriteByteArrayOp WordVec 64 W8)
+   , (VecWriteByteArrayOp WordVec 32 W16)
+   , (VecWriteByteArrayOp WordVec 16 W32)
+   , (VecWriteByteArrayOp WordVec 8 W64)
+   , (VecWriteByteArrayOp FloatVec 4 W32)
+   , (VecWriteByteArrayOp FloatVec 2 W64)
+   , (VecWriteByteArrayOp FloatVec 8 W32)
+   , (VecWriteByteArrayOp FloatVec 4 W64)
+   , (VecWriteByteArrayOp FloatVec 16 W32)
+   , (VecWriteByteArrayOp FloatVec 8 W64)
+   , (VecIndexOffAddrOp IntVec 16 W8)
+   , (VecIndexOffAddrOp IntVec 8 W16)
+   , (VecIndexOffAddrOp IntVec 4 W32)
+   , (VecIndexOffAddrOp IntVec 2 W64)
+   , (VecIndexOffAddrOp IntVec 32 W8)
+   , (VecIndexOffAddrOp IntVec 16 W16)
+   , (VecIndexOffAddrOp IntVec 8 W32)
+   , (VecIndexOffAddrOp IntVec 4 W64)
+   , (VecIndexOffAddrOp IntVec 64 W8)
+   , (VecIndexOffAddrOp IntVec 32 W16)
+   , (VecIndexOffAddrOp IntVec 16 W32)
+   , (VecIndexOffAddrOp IntVec 8 W64)
+   , (VecIndexOffAddrOp WordVec 16 W8)
+   , (VecIndexOffAddrOp WordVec 8 W16)
+   , (VecIndexOffAddrOp WordVec 4 W32)
+   , (VecIndexOffAddrOp WordVec 2 W64)
+   , (VecIndexOffAddrOp WordVec 32 W8)
+   , (VecIndexOffAddrOp WordVec 16 W16)
+   , (VecIndexOffAddrOp WordVec 8 W32)
+   , (VecIndexOffAddrOp WordVec 4 W64)
+   , (VecIndexOffAddrOp WordVec 64 W8)
+   , (VecIndexOffAddrOp WordVec 32 W16)
+   , (VecIndexOffAddrOp WordVec 16 W32)
+   , (VecIndexOffAddrOp WordVec 8 W64)
+   , (VecIndexOffAddrOp FloatVec 4 W32)
+   , (VecIndexOffAddrOp FloatVec 2 W64)
+   , (VecIndexOffAddrOp FloatVec 8 W32)
+   , (VecIndexOffAddrOp FloatVec 4 W64)
+   , (VecIndexOffAddrOp FloatVec 16 W32)
+   , (VecIndexOffAddrOp FloatVec 8 W64)
+   , (VecReadOffAddrOp IntVec 16 W8)
+   , (VecReadOffAddrOp IntVec 8 W16)
+   , (VecReadOffAddrOp IntVec 4 W32)
+   , (VecReadOffAddrOp IntVec 2 W64)
+   , (VecReadOffAddrOp IntVec 32 W8)
+   , (VecReadOffAddrOp IntVec 16 W16)
+   , (VecReadOffAddrOp IntVec 8 W32)
+   , (VecReadOffAddrOp IntVec 4 W64)
+   , (VecReadOffAddrOp IntVec 64 W8)
+   , (VecReadOffAddrOp IntVec 32 W16)
+   , (VecReadOffAddrOp IntVec 16 W32)
+   , (VecReadOffAddrOp IntVec 8 W64)
+   , (VecReadOffAddrOp WordVec 16 W8)
+   , (VecReadOffAddrOp WordVec 8 W16)
+   , (VecReadOffAddrOp WordVec 4 W32)
+   , (VecReadOffAddrOp WordVec 2 W64)
+   , (VecReadOffAddrOp WordVec 32 W8)
+   , (VecReadOffAddrOp WordVec 16 W16)
+   , (VecReadOffAddrOp WordVec 8 W32)
+   , (VecReadOffAddrOp WordVec 4 W64)
+   , (VecReadOffAddrOp WordVec 64 W8)
+   , (VecReadOffAddrOp WordVec 32 W16)
+   , (VecReadOffAddrOp WordVec 16 W32)
+   , (VecReadOffAddrOp WordVec 8 W64)
+   , (VecReadOffAddrOp FloatVec 4 W32)
+   , (VecReadOffAddrOp FloatVec 2 W64)
+   , (VecReadOffAddrOp FloatVec 8 W32)
+   , (VecReadOffAddrOp FloatVec 4 W64)
+   , (VecReadOffAddrOp FloatVec 16 W32)
+   , (VecReadOffAddrOp FloatVec 8 W64)
+   , (VecWriteOffAddrOp IntVec 16 W8)
+   , (VecWriteOffAddrOp IntVec 8 W16)
+   , (VecWriteOffAddrOp IntVec 4 W32)
+   , (VecWriteOffAddrOp IntVec 2 W64)
+   , (VecWriteOffAddrOp IntVec 32 W8)
+   , (VecWriteOffAddrOp IntVec 16 W16)
+   , (VecWriteOffAddrOp IntVec 8 W32)
+   , (VecWriteOffAddrOp IntVec 4 W64)
+   , (VecWriteOffAddrOp IntVec 64 W8)
+   , (VecWriteOffAddrOp IntVec 32 W16)
+   , (VecWriteOffAddrOp IntVec 16 W32)
+   , (VecWriteOffAddrOp IntVec 8 W64)
+   , (VecWriteOffAddrOp WordVec 16 W8)
+   , (VecWriteOffAddrOp WordVec 8 W16)
+   , (VecWriteOffAddrOp WordVec 4 W32)
+   , (VecWriteOffAddrOp WordVec 2 W64)
+   , (VecWriteOffAddrOp WordVec 32 W8)
+   , (VecWriteOffAddrOp WordVec 16 W16)
+   , (VecWriteOffAddrOp WordVec 8 W32)
+   , (VecWriteOffAddrOp WordVec 4 W64)
+   , (VecWriteOffAddrOp WordVec 64 W8)
+   , (VecWriteOffAddrOp WordVec 32 W16)
+   , (VecWriteOffAddrOp WordVec 16 W32)
+   , (VecWriteOffAddrOp WordVec 8 W64)
+   , (VecWriteOffAddrOp FloatVec 4 W32)
+   , (VecWriteOffAddrOp FloatVec 2 W64)
+   , (VecWriteOffAddrOp FloatVec 8 W32)
+   , (VecWriteOffAddrOp FloatVec 4 W64)
+   , (VecWriteOffAddrOp FloatVec 16 W32)
+   , (VecWriteOffAddrOp FloatVec 8 W64)
+   , (VecIndexScalarByteArrayOp IntVec 16 W8)
+   , (VecIndexScalarByteArrayOp IntVec 8 W16)
+   , (VecIndexScalarByteArrayOp IntVec 4 W32)
+   , (VecIndexScalarByteArrayOp IntVec 2 W64)
+   , (VecIndexScalarByteArrayOp IntVec 32 W8)
+   , (VecIndexScalarByteArrayOp IntVec 16 W16)
+   , (VecIndexScalarByteArrayOp IntVec 8 W32)
+   , (VecIndexScalarByteArrayOp IntVec 4 W64)
+   , (VecIndexScalarByteArrayOp IntVec 64 W8)
+   , (VecIndexScalarByteArrayOp IntVec 32 W16)
+   , (VecIndexScalarByteArrayOp IntVec 16 W32)
+   , (VecIndexScalarByteArrayOp IntVec 8 W64)
+   , (VecIndexScalarByteArrayOp WordVec 16 W8)
+   , (VecIndexScalarByteArrayOp WordVec 8 W16)
+   , (VecIndexScalarByteArrayOp WordVec 4 W32)
+   , (VecIndexScalarByteArrayOp WordVec 2 W64)
+   , (VecIndexScalarByteArrayOp WordVec 32 W8)
+   , (VecIndexScalarByteArrayOp WordVec 16 W16)
+   , (VecIndexScalarByteArrayOp WordVec 8 W32)
+   , (VecIndexScalarByteArrayOp WordVec 4 W64)
+   , (VecIndexScalarByteArrayOp WordVec 64 W8)
+   , (VecIndexScalarByteArrayOp WordVec 32 W16)
+   , (VecIndexScalarByteArrayOp WordVec 16 W32)
+   , (VecIndexScalarByteArrayOp WordVec 8 W64)
+   , (VecIndexScalarByteArrayOp FloatVec 4 W32)
+   , (VecIndexScalarByteArrayOp FloatVec 2 W64)
+   , (VecIndexScalarByteArrayOp FloatVec 8 W32)
+   , (VecIndexScalarByteArrayOp FloatVec 4 W64)
+   , (VecIndexScalarByteArrayOp FloatVec 16 W32)
+   , (VecIndexScalarByteArrayOp FloatVec 8 W64)
+   , (VecReadScalarByteArrayOp IntVec 16 W8)
+   , (VecReadScalarByteArrayOp IntVec 8 W16)
+   , (VecReadScalarByteArrayOp IntVec 4 W32)
+   , (VecReadScalarByteArrayOp IntVec 2 W64)
+   , (VecReadScalarByteArrayOp IntVec 32 W8)
+   , (VecReadScalarByteArrayOp IntVec 16 W16)
+   , (VecReadScalarByteArrayOp IntVec 8 W32)
+   , (VecReadScalarByteArrayOp IntVec 4 W64)
+   , (VecReadScalarByteArrayOp IntVec 64 W8)
+   , (VecReadScalarByteArrayOp IntVec 32 W16)
+   , (VecReadScalarByteArrayOp IntVec 16 W32)
+   , (VecReadScalarByteArrayOp IntVec 8 W64)
+   , (VecReadScalarByteArrayOp WordVec 16 W8)
+   , (VecReadScalarByteArrayOp WordVec 8 W16)
+   , (VecReadScalarByteArrayOp WordVec 4 W32)
+   , (VecReadScalarByteArrayOp WordVec 2 W64)
+   , (VecReadScalarByteArrayOp WordVec 32 W8)
+   , (VecReadScalarByteArrayOp WordVec 16 W16)
+   , (VecReadScalarByteArrayOp WordVec 8 W32)
+   , (VecReadScalarByteArrayOp WordVec 4 W64)
+   , (VecReadScalarByteArrayOp WordVec 64 W8)
+   , (VecReadScalarByteArrayOp WordVec 32 W16)
+   , (VecReadScalarByteArrayOp WordVec 16 W32)
+   , (VecReadScalarByteArrayOp WordVec 8 W64)
+   , (VecReadScalarByteArrayOp FloatVec 4 W32)
+   , (VecReadScalarByteArrayOp FloatVec 2 W64)
+   , (VecReadScalarByteArrayOp FloatVec 8 W32)
+   , (VecReadScalarByteArrayOp FloatVec 4 W64)
+   , (VecReadScalarByteArrayOp FloatVec 16 W32)
+   , (VecReadScalarByteArrayOp FloatVec 8 W64)
+   , (VecWriteScalarByteArrayOp IntVec 16 W8)
+   , (VecWriteScalarByteArrayOp IntVec 8 W16)
+   , (VecWriteScalarByteArrayOp IntVec 4 W32)
+   , (VecWriteScalarByteArrayOp IntVec 2 W64)
+   , (VecWriteScalarByteArrayOp IntVec 32 W8)
+   , (VecWriteScalarByteArrayOp IntVec 16 W16)
+   , (VecWriteScalarByteArrayOp IntVec 8 W32)
+   , (VecWriteScalarByteArrayOp IntVec 4 W64)
+   , (VecWriteScalarByteArrayOp IntVec 64 W8)
+   , (VecWriteScalarByteArrayOp IntVec 32 W16)
+   , (VecWriteScalarByteArrayOp IntVec 16 W32)
+   , (VecWriteScalarByteArrayOp IntVec 8 W64)
+   , (VecWriteScalarByteArrayOp WordVec 16 W8)
+   , (VecWriteScalarByteArrayOp WordVec 8 W16)
+   , (VecWriteScalarByteArrayOp WordVec 4 W32)
+   , (VecWriteScalarByteArrayOp WordVec 2 W64)
+   , (VecWriteScalarByteArrayOp WordVec 32 W8)
+   , (VecWriteScalarByteArrayOp WordVec 16 W16)
+   , (VecWriteScalarByteArrayOp WordVec 8 W32)
+   , (VecWriteScalarByteArrayOp WordVec 4 W64)
+   , (VecWriteScalarByteArrayOp WordVec 64 W8)
+   , (VecWriteScalarByteArrayOp WordVec 32 W16)
+   , (VecWriteScalarByteArrayOp WordVec 16 W32)
+   , (VecWriteScalarByteArrayOp WordVec 8 W64)
+   , (VecWriteScalarByteArrayOp FloatVec 4 W32)
+   , (VecWriteScalarByteArrayOp FloatVec 2 W64)
+   , (VecWriteScalarByteArrayOp FloatVec 8 W32)
+   , (VecWriteScalarByteArrayOp FloatVec 4 W64)
+   , (VecWriteScalarByteArrayOp FloatVec 16 W32)
+   , (VecWriteScalarByteArrayOp FloatVec 8 W64)
+   , (VecIndexScalarOffAddrOp IntVec 16 W8)
+   , (VecIndexScalarOffAddrOp IntVec 8 W16)
+   , (VecIndexScalarOffAddrOp IntVec 4 W32)
+   , (VecIndexScalarOffAddrOp IntVec 2 W64)
+   , (VecIndexScalarOffAddrOp IntVec 32 W8)
+   , (VecIndexScalarOffAddrOp IntVec 16 W16)
+   , (VecIndexScalarOffAddrOp IntVec 8 W32)
+   , (VecIndexScalarOffAddrOp IntVec 4 W64)
+   , (VecIndexScalarOffAddrOp IntVec 64 W8)
+   , (VecIndexScalarOffAddrOp IntVec 32 W16)
+   , (VecIndexScalarOffAddrOp IntVec 16 W32)
+   , (VecIndexScalarOffAddrOp IntVec 8 W64)
+   , (VecIndexScalarOffAddrOp WordVec 16 W8)
+   , (VecIndexScalarOffAddrOp WordVec 8 W16)
+   , (VecIndexScalarOffAddrOp WordVec 4 W32)
+   , (VecIndexScalarOffAddrOp WordVec 2 W64)
+   , (VecIndexScalarOffAddrOp WordVec 32 W8)
+   , (VecIndexScalarOffAddrOp WordVec 16 W16)
+   , (VecIndexScalarOffAddrOp WordVec 8 W32)
+   , (VecIndexScalarOffAddrOp WordVec 4 W64)
+   , (VecIndexScalarOffAddrOp WordVec 64 W8)
+   , (VecIndexScalarOffAddrOp WordVec 32 W16)
+   , (VecIndexScalarOffAddrOp WordVec 16 W32)
+   , (VecIndexScalarOffAddrOp WordVec 8 W64)
+   , (VecIndexScalarOffAddrOp FloatVec 4 W32)
+   , (VecIndexScalarOffAddrOp FloatVec 2 W64)
+   , (VecIndexScalarOffAddrOp FloatVec 8 W32)
+   , (VecIndexScalarOffAddrOp FloatVec 4 W64)
+   , (VecIndexScalarOffAddrOp FloatVec 16 W32)
+   , (VecIndexScalarOffAddrOp FloatVec 8 W64)
+   , (VecReadScalarOffAddrOp IntVec 16 W8)
+   , (VecReadScalarOffAddrOp IntVec 8 W16)
+   , (VecReadScalarOffAddrOp IntVec 4 W32)
+   , (VecReadScalarOffAddrOp IntVec 2 W64)
+   , (VecReadScalarOffAddrOp IntVec 32 W8)
+   , (VecReadScalarOffAddrOp IntVec 16 W16)
+   , (VecReadScalarOffAddrOp IntVec 8 W32)
+   , (VecReadScalarOffAddrOp IntVec 4 W64)
+   , (VecReadScalarOffAddrOp IntVec 64 W8)
+   , (VecReadScalarOffAddrOp IntVec 32 W16)
+   , (VecReadScalarOffAddrOp IntVec 16 W32)
+   , (VecReadScalarOffAddrOp IntVec 8 W64)
+   , (VecReadScalarOffAddrOp WordVec 16 W8)
+   , (VecReadScalarOffAddrOp WordVec 8 W16)
+   , (VecReadScalarOffAddrOp WordVec 4 W32)
+   , (VecReadScalarOffAddrOp WordVec 2 W64)
+   , (VecReadScalarOffAddrOp WordVec 32 W8)
+   , (VecReadScalarOffAddrOp WordVec 16 W16)
+   , (VecReadScalarOffAddrOp WordVec 8 W32)
+   , (VecReadScalarOffAddrOp WordVec 4 W64)
+   , (VecReadScalarOffAddrOp WordVec 64 W8)
+   , (VecReadScalarOffAddrOp WordVec 32 W16)
+   , (VecReadScalarOffAddrOp WordVec 16 W32)
+   , (VecReadScalarOffAddrOp WordVec 8 W64)
+   , (VecReadScalarOffAddrOp FloatVec 4 W32)
+   , (VecReadScalarOffAddrOp FloatVec 2 W64)
+   , (VecReadScalarOffAddrOp FloatVec 8 W32)
+   , (VecReadScalarOffAddrOp FloatVec 4 W64)
+   , (VecReadScalarOffAddrOp FloatVec 16 W32)
+   , (VecReadScalarOffAddrOp FloatVec 8 W64)
+   , (VecWriteScalarOffAddrOp IntVec 16 W8)
+   , (VecWriteScalarOffAddrOp IntVec 8 W16)
+   , (VecWriteScalarOffAddrOp IntVec 4 W32)
+   , (VecWriteScalarOffAddrOp IntVec 2 W64)
+   , (VecWriteScalarOffAddrOp IntVec 32 W8)
+   , (VecWriteScalarOffAddrOp IntVec 16 W16)
+   , (VecWriteScalarOffAddrOp IntVec 8 W32)
+   , (VecWriteScalarOffAddrOp IntVec 4 W64)
+   , (VecWriteScalarOffAddrOp IntVec 64 W8)
+   , (VecWriteScalarOffAddrOp IntVec 32 W16)
+   , (VecWriteScalarOffAddrOp IntVec 16 W32)
+   , (VecWriteScalarOffAddrOp IntVec 8 W64)
+   , (VecWriteScalarOffAddrOp WordVec 16 W8)
+   , (VecWriteScalarOffAddrOp WordVec 8 W16)
+   , (VecWriteScalarOffAddrOp WordVec 4 W32)
+   , (VecWriteScalarOffAddrOp WordVec 2 W64)
+   , (VecWriteScalarOffAddrOp WordVec 32 W8)
+   , (VecWriteScalarOffAddrOp WordVec 16 W16)
+   , (VecWriteScalarOffAddrOp WordVec 8 W32)
+   , (VecWriteScalarOffAddrOp WordVec 4 W64)
+   , (VecWriteScalarOffAddrOp WordVec 64 W8)
+   , (VecWriteScalarOffAddrOp WordVec 32 W16)
+   , (VecWriteScalarOffAddrOp WordVec 16 W32)
+   , (VecWriteScalarOffAddrOp WordVec 8 W64)
+   , (VecWriteScalarOffAddrOp FloatVec 4 W32)
+   , (VecWriteScalarOffAddrOp FloatVec 2 W64)
+   , (VecWriteScalarOffAddrOp FloatVec 8 W32)
+   , (VecWriteScalarOffAddrOp FloatVec 4 W64)
+   , (VecWriteScalarOffAddrOp FloatVec 16 W32)
+   , (VecWriteScalarOffAddrOp FloatVec 8 W64)
+   , PrefetchByteArrayOp3
+   , PrefetchMutableByteArrayOp3
+   , PrefetchAddrOp3
+   , PrefetchValueOp3
+   , PrefetchByteArrayOp2
+   , PrefetchMutableByteArrayOp2
+   , PrefetchAddrOp2
+   , PrefetchValueOp2
+   , PrefetchByteArrayOp1
+   , PrefetchMutableByteArrayOp1
+   , PrefetchAddrOp1
+   , PrefetchValueOp1
+   , PrefetchByteArrayOp0
+   , PrefetchMutableByteArrayOp0
+   , PrefetchAddrOp0
+   , PrefetchValueOp0
+   ]
diff --git a/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl
@@ -0,0 +1,102 @@
+primOpOutOfLine DoubleDecode_2IntOp = True
+primOpOutOfLine DoubleDecode_Int64Op = True
+primOpOutOfLine FloatDecode_IntOp = True
+primOpOutOfLine NewArrayOp = True
+primOpOutOfLine UnsafeThawArrayOp = True
+primOpOutOfLine CopyArrayOp = True
+primOpOutOfLine CopyMutableArrayOp = True
+primOpOutOfLine CloneArrayOp = True
+primOpOutOfLine CloneMutableArrayOp = True
+primOpOutOfLine FreezeArrayOp = True
+primOpOutOfLine ThawArrayOp = True
+primOpOutOfLine CasArrayOp = True
+primOpOutOfLine NewSmallArrayOp = True
+primOpOutOfLine UnsafeThawSmallArrayOp = True
+primOpOutOfLine CopySmallArrayOp = True
+primOpOutOfLine CopySmallMutableArrayOp = True
+primOpOutOfLine CloneSmallArrayOp = True
+primOpOutOfLine CloneSmallMutableArrayOp = True
+primOpOutOfLine FreezeSmallArrayOp = True
+primOpOutOfLine ThawSmallArrayOp = True
+primOpOutOfLine CasSmallArrayOp = True
+primOpOutOfLine NewByteArrayOp_Char = True
+primOpOutOfLine NewPinnedByteArrayOp_Char = True
+primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True
+primOpOutOfLine MutableByteArrayIsPinnedOp = True
+primOpOutOfLine ByteArrayIsPinnedOp = True
+primOpOutOfLine ShrinkMutableByteArrayOp_Char = True
+primOpOutOfLine ResizeMutableByteArrayOp_Char = True
+primOpOutOfLine NewArrayArrayOp = True
+primOpOutOfLine CopyArrayArrayOp = True
+primOpOutOfLine CopyMutableArrayArrayOp = True
+primOpOutOfLine NewMutVarOp = True
+primOpOutOfLine AtomicModifyMutVar2Op = True
+primOpOutOfLine AtomicModifyMutVar_Op = True
+primOpOutOfLine CasMutVarOp = True
+primOpOutOfLine CatchOp = True
+primOpOutOfLine RaiseOp = True
+primOpOutOfLine RaiseIOOp = True
+primOpOutOfLine MaskAsyncExceptionsOp = True
+primOpOutOfLine MaskUninterruptibleOp = True
+primOpOutOfLine UnmaskAsyncExceptionsOp = True
+primOpOutOfLine MaskStatus = True
+primOpOutOfLine AtomicallyOp = True
+primOpOutOfLine RetryOp = True
+primOpOutOfLine CatchRetryOp = True
+primOpOutOfLine CatchSTMOp = True
+primOpOutOfLine NewTVarOp = True
+primOpOutOfLine ReadTVarOp = True
+primOpOutOfLine ReadTVarIOOp = True
+primOpOutOfLine WriteTVarOp = True
+primOpOutOfLine NewMVarOp = True
+primOpOutOfLine TakeMVarOp = True
+primOpOutOfLine TryTakeMVarOp = True
+primOpOutOfLine PutMVarOp = True
+primOpOutOfLine TryPutMVarOp = True
+primOpOutOfLine ReadMVarOp = True
+primOpOutOfLine TryReadMVarOp = True
+primOpOutOfLine IsEmptyMVarOp = True
+primOpOutOfLine DelayOp = True
+primOpOutOfLine WaitReadOp = True
+primOpOutOfLine WaitWriteOp = True
+primOpOutOfLine ForkOp = True
+primOpOutOfLine ForkOnOp = True
+primOpOutOfLine KillThreadOp = True
+primOpOutOfLine YieldOp = True
+primOpOutOfLine LabelThreadOp = True
+primOpOutOfLine IsCurrentThreadBoundOp = True
+primOpOutOfLine NoDuplicateOp = True
+primOpOutOfLine ThreadStatusOp = True
+primOpOutOfLine MkWeakOp = True
+primOpOutOfLine MkWeakNoFinalizerOp = True
+primOpOutOfLine AddCFinalizerToWeakOp = True
+primOpOutOfLine DeRefWeakOp = True
+primOpOutOfLine FinalizeWeakOp = True
+primOpOutOfLine MakeStablePtrOp = True
+primOpOutOfLine DeRefStablePtrOp = True
+primOpOutOfLine MakeStableNameOp = True
+primOpOutOfLine CompactNewOp = True
+primOpOutOfLine CompactResizeOp = True
+primOpOutOfLine CompactContainsOp = True
+primOpOutOfLine CompactContainsAnyOp = True
+primOpOutOfLine CompactGetFirstBlockOp = True
+primOpOutOfLine CompactGetNextBlockOp = True
+primOpOutOfLine CompactAllocateBlockOp = True
+primOpOutOfLine CompactFixupPointersOp = True
+primOpOutOfLine CompactAdd = True
+primOpOutOfLine CompactAddWithSharing = True
+primOpOutOfLine CompactSize = True
+primOpOutOfLine GetSparkOp = True
+primOpOutOfLine NumSparks = True
+primOpOutOfLine MkApUpd0_Op = True
+primOpOutOfLine NewBCOOp = True
+primOpOutOfLine UnpackClosureOp = True
+primOpOutOfLine ClosureSizeOp = True
+primOpOutOfLine GetApStackValOp = True
+primOpOutOfLine ClearCCSOp = True
+primOpOutOfLine TraceEventOp = True
+primOpOutOfLine TraceEventBinaryOp = True
+primOpOutOfLine TraceMarkerOp = True
+primOpOutOfLine GetThreadAllocationCounter = True
+primOpOutOfLine SetThreadAllocationCounter = True
+primOpOutOfLine _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl
@@ -0,0 +1,1198 @@
+primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy
+primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy
+primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy
+primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy
+primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy
+primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy
+primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)
+primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy
+primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy
+primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy
+primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy
+primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy
+primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy
+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy
+primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy
+primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy
+primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy
+primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy
+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy
+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy
+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy
+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy
+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy
+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy
+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)
+primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)
+primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)
+primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)
+primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)
+primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)
+primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#")  [] [int8PrimTy] (intPrimTy)
+primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#")  [] [intPrimTy] (int8PrimTy)
+primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy
+primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy
+primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy
+primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy
+primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy
+primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy
+primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#")  [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy]))
+primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy
+primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy
+primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy
+primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy
+primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy
+primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy
+primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#")  [] [word8PrimTy] (wordPrimTy)
+primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#")  [] [wordPrimTy] (word8PrimTy)
+primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy
+primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy
+primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy
+primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy
+primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy
+primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy
+primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#")  [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy]))
+primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy
+primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy
+primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy
+primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy
+primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy
+primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy
+primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#")  [] [int16PrimTy] (intPrimTy)
+primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#")  [] [intPrimTy] (int16PrimTy)
+primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy
+primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy
+primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy
+primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy
+primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy
+primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy
+primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#")  [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy]))
+primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy
+primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy
+primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy
+primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy
+primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy
+primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy
+primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#")  [] [word16PrimTy] (wordPrimTy)
+primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#")  [] [wordPrimTy] (word16PrimTy)
+primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy
+primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy
+primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy
+primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy
+primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy
+primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy
+primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#")  [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy]))
+primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy
+primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy
+primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy
+primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy
+primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy
+primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy
+primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy
+primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
+primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
+primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy
+primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy
+primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy
+primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy
+primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy
+primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy
+primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy
+primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy
+primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)
+primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy
+primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy
+primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy
+primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy
+primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy
+primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy
+primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy
+primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy
+primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy
+primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)
+primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy
+primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy
+primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy
+primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy
+primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
+primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy
+primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy
+primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy
+primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy
+primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
+primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy
+primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy
+primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy
+primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy
+primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)
+primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy
+primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy
+primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy
+primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy
+primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)
+primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy
+primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy
+primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy
+primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy
+primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy
+primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy
+primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy
+primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy
+primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy
+primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy
+primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy
+primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy
+primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy
+primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy
+primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy
+primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy
+primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy
+primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy
+primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy
+primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy
+primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy
+primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy
+primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy
+primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy
+primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy
+primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy
+primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy
+primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy
+primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)
+primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)
+primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy
+primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy
+primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy
+primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy
+primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy
+primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy
+primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy
+primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy
+primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy
+primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy
+primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy
+primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy
+primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy
+primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy
+primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy
+primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy
+primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))
+primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy
+primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy
+primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy
+primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy
+primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy
+primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy
+primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy
+primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy
+primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy
+primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy
+primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy
+primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy
+primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)
+primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy
+primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy
+primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy
+primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy
+primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy
+primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy
+primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy
+primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy
+primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy
+primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy
+primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy
+primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy
+primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy
+primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy
+primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy
+primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy
+primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)
+primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)
+primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))
+primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)
+primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))
+primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)
+primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))
+primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)
+primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))
+primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)
+primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)
+primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))
+primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)
+primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)
+primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)
+primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
+primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)
+primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
+primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
+primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
+primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))
+primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))
+primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)
+primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)
+primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)
+primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))
+primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))
+primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))
+primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)
+primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)
+primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)
+primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy
+primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy
+primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy
+primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy
+primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy
+primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy
+primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)
+primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)
+primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
+primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
+primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
+primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))
+primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))
+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))
+primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)
+primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))
+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))
+primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))
+primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
+primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
+primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
+primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))
+primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))
+primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))
+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))
+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)
+primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))
+primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)
+primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)
+primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))
+primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))
+primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))
+primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))
+primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))
+primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))
+primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)
+primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)
+primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)
+primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)
+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))
+primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))
+primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))
+primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVar] [alphaTy] (intPrimTy)
+primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))
+primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy)
+primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)
+primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [intPrimTy] (int32X4PrimTy)
+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)
+primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [intPrimTy] (int8X32PrimTy)
+primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [intPrimTy] (int16X16PrimTy)
+primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [intPrimTy] (int32X8PrimTy)
+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)
+primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [intPrimTy] (int8X64PrimTy)
+primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [intPrimTy] (int16X32PrimTy)
+primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [intPrimTy] (int32X16PrimTy)
+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)
+primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)
+primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)
+primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [wordPrimTy] (word32X4PrimTy)
+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)
+primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)
+primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)
+primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [wordPrimTy] (word32X8PrimTy)
+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)
+primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)
+primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)
+primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [wordPrimTy] (word32X16PrimTy)
+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)
+primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)
+primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)
+primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)
+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)
+primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)
+primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)
+primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)
+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)
+primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)
+primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)
+primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)
+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)
+primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)
+primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)
+primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy)
+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)
+primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)
+primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)
+primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy)
+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)
+primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)
+primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)
+primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy)
+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)
+primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)
+primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)
+primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)
+primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)
+primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)
+primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)
+primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))
+primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))
+primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))
+primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy
+primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy
+primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy
+primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy
+primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy
+primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy
+primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy
+primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy
+primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy
+primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy
+primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy
+primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy
+primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy
+primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy
+primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy
+primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy
+primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy
+primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy
+primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy
+primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy
+primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy
+primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy
+primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy
+primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy
+primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy
+primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy
+primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy
+primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy
+primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy
+primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy
+primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy
+primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy
+primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy
+primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy
+primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy
+primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy
+primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy
+primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy
+primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy
+primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy
+primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy
+primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy
+primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy
+primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy
+primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy
+primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy
+primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy
+primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy
+primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy
+primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy
+primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy
+primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy
+primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy
+primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy
+primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy
+primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy
+primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy
+primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy
+primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy
+primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy
+primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy
+primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy
+primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy
+primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy
+primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy
+primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy
+primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy
+primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy
+primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy
+primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy
+primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy
+primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy
+primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy
+primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy
+primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy
+primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy
+primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy
+primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy
+primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy
+primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy
+primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy
+primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy
+primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy
+primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy
+primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy
+primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy
+primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy
+primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy
+primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy
+primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy
+primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy
+primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy
+primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy
+primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy
+primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy
+primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy
+primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy
+primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy
+primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy
+primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy
+primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy
+primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy
+primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy
+primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy
+primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy
+primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy
+primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy
+primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy
+primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy
+primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy
+primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy
+primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy
+primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy
+primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy
+primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy
+primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy
+primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy
+primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy
+primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy
+primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy
+primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy
+primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy
+primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy
+primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy
+primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy
+primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy
+primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy
+primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy
+primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy
+primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy
+primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy
+primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy
+primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy
+primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy
+primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy
+primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy
+primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy
+primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy
+primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy
+primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy
+primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy
+primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy
+primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy
+primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy
+primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy
+primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy
+primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy
+primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy
+primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy
+primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy
+primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy
+primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy
+primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy
+primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy
+primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy
+primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy
+primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy
+primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy
+primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy
+primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy
+primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy
+primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy
+primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
diff --git a/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl
@@ -0,0 +1,22 @@
+primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , lazyApply2Dmd
+                                                 , topDmd] topRes 
+primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes 
+primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes 
+primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes 
+primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , lazyApply1Dmd
+                                                 , topDmd ] topRes 
+primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , lazyApply2Dmd
+                                                 , topDmd ] topRes 
+primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topRes 
+primOpStrictness PrefetchValueOp3 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness PrefetchValueOp2 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness PrefetchValueOp1 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness PrefetchValueOp0 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes 
diff --git a/ghc-lib/stage1/compiler/build/primop-tag.hs-incl b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl
@@ -0,0 +1,1201 @@
+maxPrimOpTag :: Int
+maxPrimOpTag = 1198
+primOpTag :: PrimOp -> Int
+primOpTag CharGtOp = 1
+primOpTag CharGeOp = 2
+primOpTag CharEqOp = 3
+primOpTag CharNeOp = 4
+primOpTag CharLtOp = 5
+primOpTag CharLeOp = 6
+primOpTag OrdOp = 7
+primOpTag IntAddOp = 8
+primOpTag IntSubOp = 9
+primOpTag IntMulOp = 10
+primOpTag IntMulMayOfloOp = 11
+primOpTag IntQuotOp = 12
+primOpTag IntRemOp = 13
+primOpTag IntQuotRemOp = 14
+primOpTag AndIOp = 15
+primOpTag OrIOp = 16
+primOpTag XorIOp = 17
+primOpTag NotIOp = 18
+primOpTag IntNegOp = 19
+primOpTag IntAddCOp = 20
+primOpTag IntSubCOp = 21
+primOpTag IntGtOp = 22
+primOpTag IntGeOp = 23
+primOpTag IntEqOp = 24
+primOpTag IntNeOp = 25
+primOpTag IntLtOp = 26
+primOpTag IntLeOp = 27
+primOpTag ChrOp = 28
+primOpTag Int2WordOp = 29
+primOpTag Int2FloatOp = 30
+primOpTag Int2DoubleOp = 31
+primOpTag Word2FloatOp = 32
+primOpTag Word2DoubleOp = 33
+primOpTag ISllOp = 34
+primOpTag ISraOp = 35
+primOpTag ISrlOp = 36
+primOpTag Int8Extend = 37
+primOpTag Int8Narrow = 38
+primOpTag Int8NegOp = 39
+primOpTag Int8AddOp = 40
+primOpTag Int8SubOp = 41
+primOpTag Int8MulOp = 42
+primOpTag Int8QuotOp = 43
+primOpTag Int8RemOp = 44
+primOpTag Int8QuotRemOp = 45
+primOpTag Int8EqOp = 46
+primOpTag Int8GeOp = 47
+primOpTag Int8GtOp = 48
+primOpTag Int8LeOp = 49
+primOpTag Int8LtOp = 50
+primOpTag Int8NeOp = 51
+primOpTag Word8Extend = 52
+primOpTag Word8Narrow = 53
+primOpTag Word8NotOp = 54
+primOpTag Word8AddOp = 55
+primOpTag Word8SubOp = 56
+primOpTag Word8MulOp = 57
+primOpTag Word8QuotOp = 58
+primOpTag Word8RemOp = 59
+primOpTag Word8QuotRemOp = 60
+primOpTag Word8EqOp = 61
+primOpTag Word8GeOp = 62
+primOpTag Word8GtOp = 63
+primOpTag Word8LeOp = 64
+primOpTag Word8LtOp = 65
+primOpTag Word8NeOp = 66
+primOpTag Int16Extend = 67
+primOpTag Int16Narrow = 68
+primOpTag Int16NegOp = 69
+primOpTag Int16AddOp = 70
+primOpTag Int16SubOp = 71
+primOpTag Int16MulOp = 72
+primOpTag Int16QuotOp = 73
+primOpTag Int16RemOp = 74
+primOpTag Int16QuotRemOp = 75
+primOpTag Int16EqOp = 76
+primOpTag Int16GeOp = 77
+primOpTag Int16GtOp = 78
+primOpTag Int16LeOp = 79
+primOpTag Int16LtOp = 80
+primOpTag Int16NeOp = 81
+primOpTag Word16Extend = 82
+primOpTag Word16Narrow = 83
+primOpTag Word16NotOp = 84
+primOpTag Word16AddOp = 85
+primOpTag Word16SubOp = 86
+primOpTag Word16MulOp = 87
+primOpTag Word16QuotOp = 88
+primOpTag Word16RemOp = 89
+primOpTag Word16QuotRemOp = 90
+primOpTag Word16EqOp = 91
+primOpTag Word16GeOp = 92
+primOpTag Word16GtOp = 93
+primOpTag Word16LeOp = 94
+primOpTag Word16LtOp = 95
+primOpTag Word16NeOp = 96
+primOpTag WordAddOp = 97
+primOpTag WordAddCOp = 98
+primOpTag WordSubCOp = 99
+primOpTag WordAdd2Op = 100
+primOpTag WordSubOp = 101
+primOpTag WordMulOp = 102
+primOpTag WordMul2Op = 103
+primOpTag WordQuotOp = 104
+primOpTag WordRemOp = 105
+primOpTag WordQuotRemOp = 106
+primOpTag WordQuotRem2Op = 107
+primOpTag AndOp = 108
+primOpTag OrOp = 109
+primOpTag XorOp = 110
+primOpTag NotOp = 111
+primOpTag SllOp = 112
+primOpTag SrlOp = 113
+primOpTag Word2IntOp = 114
+primOpTag WordGtOp = 115
+primOpTag WordGeOp = 116
+primOpTag WordEqOp = 117
+primOpTag WordNeOp = 118
+primOpTag WordLtOp = 119
+primOpTag WordLeOp = 120
+primOpTag PopCnt8Op = 121
+primOpTag PopCnt16Op = 122
+primOpTag PopCnt32Op = 123
+primOpTag PopCnt64Op = 124
+primOpTag PopCntOp = 125
+primOpTag Pdep8Op = 126
+primOpTag Pdep16Op = 127
+primOpTag Pdep32Op = 128
+primOpTag Pdep64Op = 129
+primOpTag PdepOp = 130
+primOpTag Pext8Op = 131
+primOpTag Pext16Op = 132
+primOpTag Pext32Op = 133
+primOpTag Pext64Op = 134
+primOpTag PextOp = 135
+primOpTag Clz8Op = 136
+primOpTag Clz16Op = 137
+primOpTag Clz32Op = 138
+primOpTag Clz64Op = 139
+primOpTag ClzOp = 140
+primOpTag Ctz8Op = 141
+primOpTag Ctz16Op = 142
+primOpTag Ctz32Op = 143
+primOpTag Ctz64Op = 144
+primOpTag CtzOp = 145
+primOpTag BSwap16Op = 146
+primOpTag BSwap32Op = 147
+primOpTag BSwap64Op = 148
+primOpTag BSwapOp = 149
+primOpTag BRev8Op = 150
+primOpTag BRev16Op = 151
+primOpTag BRev32Op = 152
+primOpTag BRev64Op = 153
+primOpTag BRevOp = 154
+primOpTag Narrow8IntOp = 155
+primOpTag Narrow16IntOp = 156
+primOpTag Narrow32IntOp = 157
+primOpTag Narrow8WordOp = 158
+primOpTag Narrow16WordOp = 159
+primOpTag Narrow32WordOp = 160
+primOpTag DoubleGtOp = 161
+primOpTag DoubleGeOp = 162
+primOpTag DoubleEqOp = 163
+primOpTag DoubleNeOp = 164
+primOpTag DoubleLtOp = 165
+primOpTag DoubleLeOp = 166
+primOpTag DoubleAddOp = 167
+primOpTag DoubleSubOp = 168
+primOpTag DoubleMulOp = 169
+primOpTag DoubleDivOp = 170
+primOpTag DoubleNegOp = 171
+primOpTag DoubleFabsOp = 172
+primOpTag Double2IntOp = 173
+primOpTag Double2FloatOp = 174
+primOpTag DoubleExpOp = 175
+primOpTag DoubleLogOp = 176
+primOpTag DoubleSqrtOp = 177
+primOpTag DoubleSinOp = 178
+primOpTag DoubleCosOp = 179
+primOpTag DoubleTanOp = 180
+primOpTag DoubleAsinOp = 181
+primOpTag DoubleAcosOp = 182
+primOpTag DoubleAtanOp = 183
+primOpTag DoubleSinhOp = 184
+primOpTag DoubleCoshOp = 185
+primOpTag DoubleTanhOp = 186
+primOpTag DoubleAsinhOp = 187
+primOpTag DoubleAcoshOp = 188
+primOpTag DoubleAtanhOp = 189
+primOpTag DoublePowerOp = 190
+primOpTag DoubleDecode_2IntOp = 191
+primOpTag DoubleDecode_Int64Op = 192
+primOpTag FloatGtOp = 193
+primOpTag FloatGeOp = 194
+primOpTag FloatEqOp = 195
+primOpTag FloatNeOp = 196
+primOpTag FloatLtOp = 197
+primOpTag FloatLeOp = 198
+primOpTag FloatAddOp = 199
+primOpTag FloatSubOp = 200
+primOpTag FloatMulOp = 201
+primOpTag FloatDivOp = 202
+primOpTag FloatNegOp = 203
+primOpTag FloatFabsOp = 204
+primOpTag Float2IntOp = 205
+primOpTag FloatExpOp = 206
+primOpTag FloatLogOp = 207
+primOpTag FloatSqrtOp = 208
+primOpTag FloatSinOp = 209
+primOpTag FloatCosOp = 210
+primOpTag FloatTanOp = 211
+primOpTag FloatAsinOp = 212
+primOpTag FloatAcosOp = 213
+primOpTag FloatAtanOp = 214
+primOpTag FloatSinhOp = 215
+primOpTag FloatCoshOp = 216
+primOpTag FloatTanhOp = 217
+primOpTag FloatAsinhOp = 218
+primOpTag FloatAcoshOp = 219
+primOpTag FloatAtanhOp = 220
+primOpTag FloatPowerOp = 221
+primOpTag Float2DoubleOp = 222
+primOpTag FloatDecode_IntOp = 223
+primOpTag NewArrayOp = 224
+primOpTag SameMutableArrayOp = 225
+primOpTag ReadArrayOp = 226
+primOpTag WriteArrayOp = 227
+primOpTag SizeofArrayOp = 228
+primOpTag SizeofMutableArrayOp = 229
+primOpTag IndexArrayOp = 230
+primOpTag UnsafeFreezeArrayOp = 231
+primOpTag UnsafeThawArrayOp = 232
+primOpTag CopyArrayOp = 233
+primOpTag CopyMutableArrayOp = 234
+primOpTag CloneArrayOp = 235
+primOpTag CloneMutableArrayOp = 236
+primOpTag FreezeArrayOp = 237
+primOpTag ThawArrayOp = 238
+primOpTag CasArrayOp = 239
+primOpTag NewSmallArrayOp = 240
+primOpTag SameSmallMutableArrayOp = 241
+primOpTag ReadSmallArrayOp = 242
+primOpTag WriteSmallArrayOp = 243
+primOpTag SizeofSmallArrayOp = 244
+primOpTag SizeofSmallMutableArrayOp = 245
+primOpTag IndexSmallArrayOp = 246
+primOpTag UnsafeFreezeSmallArrayOp = 247
+primOpTag UnsafeThawSmallArrayOp = 248
+primOpTag CopySmallArrayOp = 249
+primOpTag CopySmallMutableArrayOp = 250
+primOpTag CloneSmallArrayOp = 251
+primOpTag CloneSmallMutableArrayOp = 252
+primOpTag FreezeSmallArrayOp = 253
+primOpTag ThawSmallArrayOp = 254
+primOpTag CasSmallArrayOp = 255
+primOpTag NewByteArrayOp_Char = 256
+primOpTag NewPinnedByteArrayOp_Char = 257
+primOpTag NewAlignedPinnedByteArrayOp_Char = 258
+primOpTag MutableByteArrayIsPinnedOp = 259
+primOpTag ByteArrayIsPinnedOp = 260
+primOpTag ByteArrayContents_Char = 261
+primOpTag SameMutableByteArrayOp = 262
+primOpTag ShrinkMutableByteArrayOp_Char = 263
+primOpTag ResizeMutableByteArrayOp_Char = 264
+primOpTag UnsafeFreezeByteArrayOp = 265
+primOpTag SizeofByteArrayOp = 266
+primOpTag SizeofMutableByteArrayOp = 267
+primOpTag GetSizeofMutableByteArrayOp = 268
+primOpTag IndexByteArrayOp_Char = 269
+primOpTag IndexByteArrayOp_WideChar = 270
+primOpTag IndexByteArrayOp_Int = 271
+primOpTag IndexByteArrayOp_Word = 272
+primOpTag IndexByteArrayOp_Addr = 273
+primOpTag IndexByteArrayOp_Float = 274
+primOpTag IndexByteArrayOp_Double = 275
+primOpTag IndexByteArrayOp_StablePtr = 276
+primOpTag IndexByteArrayOp_Int8 = 277
+primOpTag IndexByteArrayOp_Int16 = 278
+primOpTag IndexByteArrayOp_Int32 = 279
+primOpTag IndexByteArrayOp_Int64 = 280
+primOpTag IndexByteArrayOp_Word8 = 281
+primOpTag IndexByteArrayOp_Word16 = 282
+primOpTag IndexByteArrayOp_Word32 = 283
+primOpTag IndexByteArrayOp_Word64 = 284
+primOpTag IndexByteArrayOp_Word8AsChar = 285
+primOpTag IndexByteArrayOp_Word8AsWideChar = 286
+primOpTag IndexByteArrayOp_Word8AsAddr = 287
+primOpTag IndexByteArrayOp_Word8AsFloat = 288
+primOpTag IndexByteArrayOp_Word8AsDouble = 289
+primOpTag IndexByteArrayOp_Word8AsStablePtr = 290
+primOpTag IndexByteArrayOp_Word8AsInt16 = 291
+primOpTag IndexByteArrayOp_Word8AsInt32 = 292
+primOpTag IndexByteArrayOp_Word8AsInt64 = 293
+primOpTag IndexByteArrayOp_Word8AsInt = 294
+primOpTag IndexByteArrayOp_Word8AsWord16 = 295
+primOpTag IndexByteArrayOp_Word8AsWord32 = 296
+primOpTag IndexByteArrayOp_Word8AsWord64 = 297
+primOpTag IndexByteArrayOp_Word8AsWord = 298
+primOpTag ReadByteArrayOp_Char = 299
+primOpTag ReadByteArrayOp_WideChar = 300
+primOpTag ReadByteArrayOp_Int = 301
+primOpTag ReadByteArrayOp_Word = 302
+primOpTag ReadByteArrayOp_Addr = 303
+primOpTag ReadByteArrayOp_Float = 304
+primOpTag ReadByteArrayOp_Double = 305
+primOpTag ReadByteArrayOp_StablePtr = 306
+primOpTag ReadByteArrayOp_Int8 = 307
+primOpTag ReadByteArrayOp_Int16 = 308
+primOpTag ReadByteArrayOp_Int32 = 309
+primOpTag ReadByteArrayOp_Int64 = 310
+primOpTag ReadByteArrayOp_Word8 = 311
+primOpTag ReadByteArrayOp_Word16 = 312
+primOpTag ReadByteArrayOp_Word32 = 313
+primOpTag ReadByteArrayOp_Word64 = 314
+primOpTag ReadByteArrayOp_Word8AsChar = 315
+primOpTag ReadByteArrayOp_Word8AsWideChar = 316
+primOpTag ReadByteArrayOp_Word8AsAddr = 317
+primOpTag ReadByteArrayOp_Word8AsFloat = 318
+primOpTag ReadByteArrayOp_Word8AsDouble = 319
+primOpTag ReadByteArrayOp_Word8AsStablePtr = 320
+primOpTag ReadByteArrayOp_Word8AsInt16 = 321
+primOpTag ReadByteArrayOp_Word8AsInt32 = 322
+primOpTag ReadByteArrayOp_Word8AsInt64 = 323
+primOpTag ReadByteArrayOp_Word8AsInt = 324
+primOpTag ReadByteArrayOp_Word8AsWord16 = 325
+primOpTag ReadByteArrayOp_Word8AsWord32 = 326
+primOpTag ReadByteArrayOp_Word8AsWord64 = 327
+primOpTag ReadByteArrayOp_Word8AsWord = 328
+primOpTag WriteByteArrayOp_Char = 329
+primOpTag WriteByteArrayOp_WideChar = 330
+primOpTag WriteByteArrayOp_Int = 331
+primOpTag WriteByteArrayOp_Word = 332
+primOpTag WriteByteArrayOp_Addr = 333
+primOpTag WriteByteArrayOp_Float = 334
+primOpTag WriteByteArrayOp_Double = 335
+primOpTag WriteByteArrayOp_StablePtr = 336
+primOpTag WriteByteArrayOp_Int8 = 337
+primOpTag WriteByteArrayOp_Int16 = 338
+primOpTag WriteByteArrayOp_Int32 = 339
+primOpTag WriteByteArrayOp_Int64 = 340
+primOpTag WriteByteArrayOp_Word8 = 341
+primOpTag WriteByteArrayOp_Word16 = 342
+primOpTag WriteByteArrayOp_Word32 = 343
+primOpTag WriteByteArrayOp_Word64 = 344
+primOpTag WriteByteArrayOp_Word8AsChar = 345
+primOpTag WriteByteArrayOp_Word8AsWideChar = 346
+primOpTag WriteByteArrayOp_Word8AsAddr = 347
+primOpTag WriteByteArrayOp_Word8AsFloat = 348
+primOpTag WriteByteArrayOp_Word8AsDouble = 349
+primOpTag WriteByteArrayOp_Word8AsStablePtr = 350
+primOpTag WriteByteArrayOp_Word8AsInt16 = 351
+primOpTag WriteByteArrayOp_Word8AsInt32 = 352
+primOpTag WriteByteArrayOp_Word8AsInt64 = 353
+primOpTag WriteByteArrayOp_Word8AsInt = 354
+primOpTag WriteByteArrayOp_Word8AsWord16 = 355
+primOpTag WriteByteArrayOp_Word8AsWord32 = 356
+primOpTag WriteByteArrayOp_Word8AsWord64 = 357
+primOpTag WriteByteArrayOp_Word8AsWord = 358
+primOpTag CompareByteArraysOp = 359
+primOpTag CopyByteArrayOp = 360
+primOpTag CopyMutableByteArrayOp = 361
+primOpTag CopyByteArrayToAddrOp = 362
+primOpTag CopyMutableByteArrayToAddrOp = 363
+primOpTag CopyAddrToByteArrayOp = 364
+primOpTag SetByteArrayOp = 365
+primOpTag AtomicReadByteArrayOp_Int = 366
+primOpTag AtomicWriteByteArrayOp_Int = 367
+primOpTag CasByteArrayOp_Int = 368
+primOpTag FetchAddByteArrayOp_Int = 369
+primOpTag FetchSubByteArrayOp_Int = 370
+primOpTag FetchAndByteArrayOp_Int = 371
+primOpTag FetchNandByteArrayOp_Int = 372
+primOpTag FetchOrByteArrayOp_Int = 373
+primOpTag FetchXorByteArrayOp_Int = 374
+primOpTag NewArrayArrayOp = 375
+primOpTag SameMutableArrayArrayOp = 376
+primOpTag UnsafeFreezeArrayArrayOp = 377
+primOpTag SizeofArrayArrayOp = 378
+primOpTag SizeofMutableArrayArrayOp = 379
+primOpTag IndexArrayArrayOp_ByteArray = 380
+primOpTag IndexArrayArrayOp_ArrayArray = 381
+primOpTag ReadArrayArrayOp_ByteArray = 382
+primOpTag ReadArrayArrayOp_MutableByteArray = 383
+primOpTag ReadArrayArrayOp_ArrayArray = 384
+primOpTag ReadArrayArrayOp_MutableArrayArray = 385
+primOpTag WriteArrayArrayOp_ByteArray = 386
+primOpTag WriteArrayArrayOp_MutableByteArray = 387
+primOpTag WriteArrayArrayOp_ArrayArray = 388
+primOpTag WriteArrayArrayOp_MutableArrayArray = 389
+primOpTag CopyArrayArrayOp = 390
+primOpTag CopyMutableArrayArrayOp = 391
+primOpTag AddrAddOp = 392
+primOpTag AddrSubOp = 393
+primOpTag AddrRemOp = 394
+primOpTag Addr2IntOp = 395
+primOpTag Int2AddrOp = 396
+primOpTag AddrGtOp = 397
+primOpTag AddrGeOp = 398
+primOpTag AddrEqOp = 399
+primOpTag AddrNeOp = 400
+primOpTag AddrLtOp = 401
+primOpTag AddrLeOp = 402
+primOpTag IndexOffAddrOp_Char = 403
+primOpTag IndexOffAddrOp_WideChar = 404
+primOpTag IndexOffAddrOp_Int = 405
+primOpTag IndexOffAddrOp_Word = 406
+primOpTag IndexOffAddrOp_Addr = 407
+primOpTag IndexOffAddrOp_Float = 408
+primOpTag IndexOffAddrOp_Double = 409
+primOpTag IndexOffAddrOp_StablePtr = 410
+primOpTag IndexOffAddrOp_Int8 = 411
+primOpTag IndexOffAddrOp_Int16 = 412
+primOpTag IndexOffAddrOp_Int32 = 413
+primOpTag IndexOffAddrOp_Int64 = 414
+primOpTag IndexOffAddrOp_Word8 = 415
+primOpTag IndexOffAddrOp_Word16 = 416
+primOpTag IndexOffAddrOp_Word32 = 417
+primOpTag IndexOffAddrOp_Word64 = 418
+primOpTag ReadOffAddrOp_Char = 419
+primOpTag ReadOffAddrOp_WideChar = 420
+primOpTag ReadOffAddrOp_Int = 421
+primOpTag ReadOffAddrOp_Word = 422
+primOpTag ReadOffAddrOp_Addr = 423
+primOpTag ReadOffAddrOp_Float = 424
+primOpTag ReadOffAddrOp_Double = 425
+primOpTag ReadOffAddrOp_StablePtr = 426
+primOpTag ReadOffAddrOp_Int8 = 427
+primOpTag ReadOffAddrOp_Int16 = 428
+primOpTag ReadOffAddrOp_Int32 = 429
+primOpTag ReadOffAddrOp_Int64 = 430
+primOpTag ReadOffAddrOp_Word8 = 431
+primOpTag ReadOffAddrOp_Word16 = 432
+primOpTag ReadOffAddrOp_Word32 = 433
+primOpTag ReadOffAddrOp_Word64 = 434
+primOpTag WriteOffAddrOp_Char = 435
+primOpTag WriteOffAddrOp_WideChar = 436
+primOpTag WriteOffAddrOp_Int = 437
+primOpTag WriteOffAddrOp_Word = 438
+primOpTag WriteOffAddrOp_Addr = 439
+primOpTag WriteOffAddrOp_Float = 440
+primOpTag WriteOffAddrOp_Double = 441
+primOpTag WriteOffAddrOp_StablePtr = 442
+primOpTag WriteOffAddrOp_Int8 = 443
+primOpTag WriteOffAddrOp_Int16 = 444
+primOpTag WriteOffAddrOp_Int32 = 445
+primOpTag WriteOffAddrOp_Int64 = 446
+primOpTag WriteOffAddrOp_Word8 = 447
+primOpTag WriteOffAddrOp_Word16 = 448
+primOpTag WriteOffAddrOp_Word32 = 449
+primOpTag WriteOffAddrOp_Word64 = 450
+primOpTag NewMutVarOp = 451
+primOpTag ReadMutVarOp = 452
+primOpTag WriteMutVarOp = 453
+primOpTag SameMutVarOp = 454
+primOpTag AtomicModifyMutVar2Op = 455
+primOpTag AtomicModifyMutVar_Op = 456
+primOpTag CasMutVarOp = 457
+primOpTag CatchOp = 458
+primOpTag RaiseOp = 459
+primOpTag RaiseIOOp = 460
+primOpTag MaskAsyncExceptionsOp = 461
+primOpTag MaskUninterruptibleOp = 462
+primOpTag UnmaskAsyncExceptionsOp = 463
+primOpTag MaskStatus = 464
+primOpTag AtomicallyOp = 465
+primOpTag RetryOp = 466
+primOpTag CatchRetryOp = 467
+primOpTag CatchSTMOp = 468
+primOpTag NewTVarOp = 469
+primOpTag ReadTVarOp = 470
+primOpTag ReadTVarIOOp = 471
+primOpTag WriteTVarOp = 472
+primOpTag SameTVarOp = 473
+primOpTag NewMVarOp = 474
+primOpTag TakeMVarOp = 475
+primOpTag TryTakeMVarOp = 476
+primOpTag PutMVarOp = 477
+primOpTag TryPutMVarOp = 478
+primOpTag ReadMVarOp = 479
+primOpTag TryReadMVarOp = 480
+primOpTag SameMVarOp = 481
+primOpTag IsEmptyMVarOp = 482
+primOpTag DelayOp = 483
+primOpTag WaitReadOp = 484
+primOpTag WaitWriteOp = 485
+primOpTag ForkOp = 486
+primOpTag ForkOnOp = 487
+primOpTag KillThreadOp = 488
+primOpTag YieldOp = 489
+primOpTag MyThreadIdOp = 490
+primOpTag LabelThreadOp = 491
+primOpTag IsCurrentThreadBoundOp = 492
+primOpTag NoDuplicateOp = 493
+primOpTag ThreadStatusOp = 494
+primOpTag MkWeakOp = 495
+primOpTag MkWeakNoFinalizerOp = 496
+primOpTag AddCFinalizerToWeakOp = 497
+primOpTag DeRefWeakOp = 498
+primOpTag FinalizeWeakOp = 499
+primOpTag TouchOp = 500
+primOpTag MakeStablePtrOp = 501
+primOpTag DeRefStablePtrOp = 502
+primOpTag EqStablePtrOp = 503
+primOpTag MakeStableNameOp = 504
+primOpTag EqStableNameOp = 505
+primOpTag StableNameToIntOp = 506
+primOpTag CompactNewOp = 507
+primOpTag CompactResizeOp = 508
+primOpTag CompactContainsOp = 509
+primOpTag CompactContainsAnyOp = 510
+primOpTag CompactGetFirstBlockOp = 511
+primOpTag CompactGetNextBlockOp = 512
+primOpTag CompactAllocateBlockOp = 513
+primOpTag CompactFixupPointersOp = 514
+primOpTag CompactAdd = 515
+primOpTag CompactAddWithSharing = 516
+primOpTag CompactSize = 517
+primOpTag ReallyUnsafePtrEqualityOp = 518
+primOpTag ParOp = 519
+primOpTag SparkOp = 520
+primOpTag SeqOp = 521
+primOpTag GetSparkOp = 522
+primOpTag NumSparks = 523
+primOpTag DataToTagOp = 524
+primOpTag TagToEnumOp = 525
+primOpTag AddrToAnyOp = 526
+primOpTag AnyToAddrOp = 527
+primOpTag MkApUpd0_Op = 528
+primOpTag NewBCOOp = 529
+primOpTag UnpackClosureOp = 530
+primOpTag ClosureSizeOp = 531
+primOpTag GetApStackValOp = 532
+primOpTag GetCCSOfOp = 533
+primOpTag GetCurrentCCSOp = 534
+primOpTag ClearCCSOp = 535
+primOpTag TraceEventOp = 536
+primOpTag TraceEventBinaryOp = 537
+primOpTag TraceMarkerOp = 538
+primOpTag GetThreadAllocationCounter = 539
+primOpTag SetThreadAllocationCounter = 540
+primOpTag (VecBroadcastOp IntVec 16 W8) = 541
+primOpTag (VecBroadcastOp IntVec 8 W16) = 542
+primOpTag (VecBroadcastOp IntVec 4 W32) = 543
+primOpTag (VecBroadcastOp IntVec 2 W64) = 544
+primOpTag (VecBroadcastOp IntVec 32 W8) = 545
+primOpTag (VecBroadcastOp IntVec 16 W16) = 546
+primOpTag (VecBroadcastOp IntVec 8 W32) = 547
+primOpTag (VecBroadcastOp IntVec 4 W64) = 548
+primOpTag (VecBroadcastOp IntVec 64 W8) = 549
+primOpTag (VecBroadcastOp IntVec 32 W16) = 550
+primOpTag (VecBroadcastOp IntVec 16 W32) = 551
+primOpTag (VecBroadcastOp IntVec 8 W64) = 552
+primOpTag (VecBroadcastOp WordVec 16 W8) = 553
+primOpTag (VecBroadcastOp WordVec 8 W16) = 554
+primOpTag (VecBroadcastOp WordVec 4 W32) = 555
+primOpTag (VecBroadcastOp WordVec 2 W64) = 556
+primOpTag (VecBroadcastOp WordVec 32 W8) = 557
+primOpTag (VecBroadcastOp WordVec 16 W16) = 558
+primOpTag (VecBroadcastOp WordVec 8 W32) = 559
+primOpTag (VecBroadcastOp WordVec 4 W64) = 560
+primOpTag (VecBroadcastOp WordVec 64 W8) = 561
+primOpTag (VecBroadcastOp WordVec 32 W16) = 562
+primOpTag (VecBroadcastOp WordVec 16 W32) = 563
+primOpTag (VecBroadcastOp WordVec 8 W64) = 564
+primOpTag (VecBroadcastOp FloatVec 4 W32) = 565
+primOpTag (VecBroadcastOp FloatVec 2 W64) = 566
+primOpTag (VecBroadcastOp FloatVec 8 W32) = 567
+primOpTag (VecBroadcastOp FloatVec 4 W64) = 568
+primOpTag (VecBroadcastOp FloatVec 16 W32) = 569
+primOpTag (VecBroadcastOp FloatVec 8 W64) = 570
+primOpTag (VecPackOp IntVec 16 W8) = 571
+primOpTag (VecPackOp IntVec 8 W16) = 572
+primOpTag (VecPackOp IntVec 4 W32) = 573
+primOpTag (VecPackOp IntVec 2 W64) = 574
+primOpTag (VecPackOp IntVec 32 W8) = 575
+primOpTag (VecPackOp IntVec 16 W16) = 576
+primOpTag (VecPackOp IntVec 8 W32) = 577
+primOpTag (VecPackOp IntVec 4 W64) = 578
+primOpTag (VecPackOp IntVec 64 W8) = 579
+primOpTag (VecPackOp IntVec 32 W16) = 580
+primOpTag (VecPackOp IntVec 16 W32) = 581
+primOpTag (VecPackOp IntVec 8 W64) = 582
+primOpTag (VecPackOp WordVec 16 W8) = 583
+primOpTag (VecPackOp WordVec 8 W16) = 584
+primOpTag (VecPackOp WordVec 4 W32) = 585
+primOpTag (VecPackOp WordVec 2 W64) = 586
+primOpTag (VecPackOp WordVec 32 W8) = 587
+primOpTag (VecPackOp WordVec 16 W16) = 588
+primOpTag (VecPackOp WordVec 8 W32) = 589
+primOpTag (VecPackOp WordVec 4 W64) = 590
+primOpTag (VecPackOp WordVec 64 W8) = 591
+primOpTag (VecPackOp WordVec 32 W16) = 592
+primOpTag (VecPackOp WordVec 16 W32) = 593
+primOpTag (VecPackOp WordVec 8 W64) = 594
+primOpTag (VecPackOp FloatVec 4 W32) = 595
+primOpTag (VecPackOp FloatVec 2 W64) = 596
+primOpTag (VecPackOp FloatVec 8 W32) = 597
+primOpTag (VecPackOp FloatVec 4 W64) = 598
+primOpTag (VecPackOp FloatVec 16 W32) = 599
+primOpTag (VecPackOp FloatVec 8 W64) = 600
+primOpTag (VecUnpackOp IntVec 16 W8) = 601
+primOpTag (VecUnpackOp IntVec 8 W16) = 602
+primOpTag (VecUnpackOp IntVec 4 W32) = 603
+primOpTag (VecUnpackOp IntVec 2 W64) = 604
+primOpTag (VecUnpackOp IntVec 32 W8) = 605
+primOpTag (VecUnpackOp IntVec 16 W16) = 606
+primOpTag (VecUnpackOp IntVec 8 W32) = 607
+primOpTag (VecUnpackOp IntVec 4 W64) = 608
+primOpTag (VecUnpackOp IntVec 64 W8) = 609
+primOpTag (VecUnpackOp IntVec 32 W16) = 610
+primOpTag (VecUnpackOp IntVec 16 W32) = 611
+primOpTag (VecUnpackOp IntVec 8 W64) = 612
+primOpTag (VecUnpackOp WordVec 16 W8) = 613
+primOpTag (VecUnpackOp WordVec 8 W16) = 614
+primOpTag (VecUnpackOp WordVec 4 W32) = 615
+primOpTag (VecUnpackOp WordVec 2 W64) = 616
+primOpTag (VecUnpackOp WordVec 32 W8) = 617
+primOpTag (VecUnpackOp WordVec 16 W16) = 618
+primOpTag (VecUnpackOp WordVec 8 W32) = 619
+primOpTag (VecUnpackOp WordVec 4 W64) = 620
+primOpTag (VecUnpackOp WordVec 64 W8) = 621
+primOpTag (VecUnpackOp WordVec 32 W16) = 622
+primOpTag (VecUnpackOp WordVec 16 W32) = 623
+primOpTag (VecUnpackOp WordVec 8 W64) = 624
+primOpTag (VecUnpackOp FloatVec 4 W32) = 625
+primOpTag (VecUnpackOp FloatVec 2 W64) = 626
+primOpTag (VecUnpackOp FloatVec 8 W32) = 627
+primOpTag (VecUnpackOp FloatVec 4 W64) = 628
+primOpTag (VecUnpackOp FloatVec 16 W32) = 629
+primOpTag (VecUnpackOp FloatVec 8 W64) = 630
+primOpTag (VecInsertOp IntVec 16 W8) = 631
+primOpTag (VecInsertOp IntVec 8 W16) = 632
+primOpTag (VecInsertOp IntVec 4 W32) = 633
+primOpTag (VecInsertOp IntVec 2 W64) = 634
+primOpTag (VecInsertOp IntVec 32 W8) = 635
+primOpTag (VecInsertOp IntVec 16 W16) = 636
+primOpTag (VecInsertOp IntVec 8 W32) = 637
+primOpTag (VecInsertOp IntVec 4 W64) = 638
+primOpTag (VecInsertOp IntVec 64 W8) = 639
+primOpTag (VecInsertOp IntVec 32 W16) = 640
+primOpTag (VecInsertOp IntVec 16 W32) = 641
+primOpTag (VecInsertOp IntVec 8 W64) = 642
+primOpTag (VecInsertOp WordVec 16 W8) = 643
+primOpTag (VecInsertOp WordVec 8 W16) = 644
+primOpTag (VecInsertOp WordVec 4 W32) = 645
+primOpTag (VecInsertOp WordVec 2 W64) = 646
+primOpTag (VecInsertOp WordVec 32 W8) = 647
+primOpTag (VecInsertOp WordVec 16 W16) = 648
+primOpTag (VecInsertOp WordVec 8 W32) = 649
+primOpTag (VecInsertOp WordVec 4 W64) = 650
+primOpTag (VecInsertOp WordVec 64 W8) = 651
+primOpTag (VecInsertOp WordVec 32 W16) = 652
+primOpTag (VecInsertOp WordVec 16 W32) = 653
+primOpTag (VecInsertOp WordVec 8 W64) = 654
+primOpTag (VecInsertOp FloatVec 4 W32) = 655
+primOpTag (VecInsertOp FloatVec 2 W64) = 656
+primOpTag (VecInsertOp FloatVec 8 W32) = 657
+primOpTag (VecInsertOp FloatVec 4 W64) = 658
+primOpTag (VecInsertOp FloatVec 16 W32) = 659
+primOpTag (VecInsertOp FloatVec 8 W64) = 660
+primOpTag (VecAddOp IntVec 16 W8) = 661
+primOpTag (VecAddOp IntVec 8 W16) = 662
+primOpTag (VecAddOp IntVec 4 W32) = 663
+primOpTag (VecAddOp IntVec 2 W64) = 664
+primOpTag (VecAddOp IntVec 32 W8) = 665
+primOpTag (VecAddOp IntVec 16 W16) = 666
+primOpTag (VecAddOp IntVec 8 W32) = 667
+primOpTag (VecAddOp IntVec 4 W64) = 668
+primOpTag (VecAddOp IntVec 64 W8) = 669
+primOpTag (VecAddOp IntVec 32 W16) = 670
+primOpTag (VecAddOp IntVec 16 W32) = 671
+primOpTag (VecAddOp IntVec 8 W64) = 672
+primOpTag (VecAddOp WordVec 16 W8) = 673
+primOpTag (VecAddOp WordVec 8 W16) = 674
+primOpTag (VecAddOp WordVec 4 W32) = 675
+primOpTag (VecAddOp WordVec 2 W64) = 676
+primOpTag (VecAddOp WordVec 32 W8) = 677
+primOpTag (VecAddOp WordVec 16 W16) = 678
+primOpTag (VecAddOp WordVec 8 W32) = 679
+primOpTag (VecAddOp WordVec 4 W64) = 680
+primOpTag (VecAddOp WordVec 64 W8) = 681
+primOpTag (VecAddOp WordVec 32 W16) = 682
+primOpTag (VecAddOp WordVec 16 W32) = 683
+primOpTag (VecAddOp WordVec 8 W64) = 684
+primOpTag (VecAddOp FloatVec 4 W32) = 685
+primOpTag (VecAddOp FloatVec 2 W64) = 686
+primOpTag (VecAddOp FloatVec 8 W32) = 687
+primOpTag (VecAddOp FloatVec 4 W64) = 688
+primOpTag (VecAddOp FloatVec 16 W32) = 689
+primOpTag (VecAddOp FloatVec 8 W64) = 690
+primOpTag (VecSubOp IntVec 16 W8) = 691
+primOpTag (VecSubOp IntVec 8 W16) = 692
+primOpTag (VecSubOp IntVec 4 W32) = 693
+primOpTag (VecSubOp IntVec 2 W64) = 694
+primOpTag (VecSubOp IntVec 32 W8) = 695
+primOpTag (VecSubOp IntVec 16 W16) = 696
+primOpTag (VecSubOp IntVec 8 W32) = 697
+primOpTag (VecSubOp IntVec 4 W64) = 698
+primOpTag (VecSubOp IntVec 64 W8) = 699
+primOpTag (VecSubOp IntVec 32 W16) = 700
+primOpTag (VecSubOp IntVec 16 W32) = 701
+primOpTag (VecSubOp IntVec 8 W64) = 702
+primOpTag (VecSubOp WordVec 16 W8) = 703
+primOpTag (VecSubOp WordVec 8 W16) = 704
+primOpTag (VecSubOp WordVec 4 W32) = 705
+primOpTag (VecSubOp WordVec 2 W64) = 706
+primOpTag (VecSubOp WordVec 32 W8) = 707
+primOpTag (VecSubOp WordVec 16 W16) = 708
+primOpTag (VecSubOp WordVec 8 W32) = 709
+primOpTag (VecSubOp WordVec 4 W64) = 710
+primOpTag (VecSubOp WordVec 64 W8) = 711
+primOpTag (VecSubOp WordVec 32 W16) = 712
+primOpTag (VecSubOp WordVec 16 W32) = 713
+primOpTag (VecSubOp WordVec 8 W64) = 714
+primOpTag (VecSubOp FloatVec 4 W32) = 715
+primOpTag (VecSubOp FloatVec 2 W64) = 716
+primOpTag (VecSubOp FloatVec 8 W32) = 717
+primOpTag (VecSubOp FloatVec 4 W64) = 718
+primOpTag (VecSubOp FloatVec 16 W32) = 719
+primOpTag (VecSubOp FloatVec 8 W64) = 720
+primOpTag (VecMulOp IntVec 16 W8) = 721
+primOpTag (VecMulOp IntVec 8 W16) = 722
+primOpTag (VecMulOp IntVec 4 W32) = 723
+primOpTag (VecMulOp IntVec 2 W64) = 724
+primOpTag (VecMulOp IntVec 32 W8) = 725
+primOpTag (VecMulOp IntVec 16 W16) = 726
+primOpTag (VecMulOp IntVec 8 W32) = 727
+primOpTag (VecMulOp IntVec 4 W64) = 728
+primOpTag (VecMulOp IntVec 64 W8) = 729
+primOpTag (VecMulOp IntVec 32 W16) = 730
+primOpTag (VecMulOp IntVec 16 W32) = 731
+primOpTag (VecMulOp IntVec 8 W64) = 732
+primOpTag (VecMulOp WordVec 16 W8) = 733
+primOpTag (VecMulOp WordVec 8 W16) = 734
+primOpTag (VecMulOp WordVec 4 W32) = 735
+primOpTag (VecMulOp WordVec 2 W64) = 736
+primOpTag (VecMulOp WordVec 32 W8) = 737
+primOpTag (VecMulOp WordVec 16 W16) = 738
+primOpTag (VecMulOp WordVec 8 W32) = 739
+primOpTag (VecMulOp WordVec 4 W64) = 740
+primOpTag (VecMulOp WordVec 64 W8) = 741
+primOpTag (VecMulOp WordVec 32 W16) = 742
+primOpTag (VecMulOp WordVec 16 W32) = 743
+primOpTag (VecMulOp WordVec 8 W64) = 744
+primOpTag (VecMulOp FloatVec 4 W32) = 745
+primOpTag (VecMulOp FloatVec 2 W64) = 746
+primOpTag (VecMulOp FloatVec 8 W32) = 747
+primOpTag (VecMulOp FloatVec 4 W64) = 748
+primOpTag (VecMulOp FloatVec 16 W32) = 749
+primOpTag (VecMulOp FloatVec 8 W64) = 750
+primOpTag (VecDivOp FloatVec 4 W32) = 751
+primOpTag (VecDivOp FloatVec 2 W64) = 752
+primOpTag (VecDivOp FloatVec 8 W32) = 753
+primOpTag (VecDivOp FloatVec 4 W64) = 754
+primOpTag (VecDivOp FloatVec 16 W32) = 755
+primOpTag (VecDivOp FloatVec 8 W64) = 756
+primOpTag (VecQuotOp IntVec 16 W8) = 757
+primOpTag (VecQuotOp IntVec 8 W16) = 758
+primOpTag (VecQuotOp IntVec 4 W32) = 759
+primOpTag (VecQuotOp IntVec 2 W64) = 760
+primOpTag (VecQuotOp IntVec 32 W8) = 761
+primOpTag (VecQuotOp IntVec 16 W16) = 762
+primOpTag (VecQuotOp IntVec 8 W32) = 763
+primOpTag (VecQuotOp IntVec 4 W64) = 764
+primOpTag (VecQuotOp IntVec 64 W8) = 765
+primOpTag (VecQuotOp IntVec 32 W16) = 766
+primOpTag (VecQuotOp IntVec 16 W32) = 767
+primOpTag (VecQuotOp IntVec 8 W64) = 768
+primOpTag (VecQuotOp WordVec 16 W8) = 769
+primOpTag (VecQuotOp WordVec 8 W16) = 770
+primOpTag (VecQuotOp WordVec 4 W32) = 771
+primOpTag (VecQuotOp WordVec 2 W64) = 772
+primOpTag (VecQuotOp WordVec 32 W8) = 773
+primOpTag (VecQuotOp WordVec 16 W16) = 774
+primOpTag (VecQuotOp WordVec 8 W32) = 775
+primOpTag (VecQuotOp WordVec 4 W64) = 776
+primOpTag (VecQuotOp WordVec 64 W8) = 777
+primOpTag (VecQuotOp WordVec 32 W16) = 778
+primOpTag (VecQuotOp WordVec 16 W32) = 779
+primOpTag (VecQuotOp WordVec 8 W64) = 780
+primOpTag (VecRemOp IntVec 16 W8) = 781
+primOpTag (VecRemOp IntVec 8 W16) = 782
+primOpTag (VecRemOp IntVec 4 W32) = 783
+primOpTag (VecRemOp IntVec 2 W64) = 784
+primOpTag (VecRemOp IntVec 32 W8) = 785
+primOpTag (VecRemOp IntVec 16 W16) = 786
+primOpTag (VecRemOp IntVec 8 W32) = 787
+primOpTag (VecRemOp IntVec 4 W64) = 788
+primOpTag (VecRemOp IntVec 64 W8) = 789
+primOpTag (VecRemOp IntVec 32 W16) = 790
+primOpTag (VecRemOp IntVec 16 W32) = 791
+primOpTag (VecRemOp IntVec 8 W64) = 792
+primOpTag (VecRemOp WordVec 16 W8) = 793
+primOpTag (VecRemOp WordVec 8 W16) = 794
+primOpTag (VecRemOp WordVec 4 W32) = 795
+primOpTag (VecRemOp WordVec 2 W64) = 796
+primOpTag (VecRemOp WordVec 32 W8) = 797
+primOpTag (VecRemOp WordVec 16 W16) = 798
+primOpTag (VecRemOp WordVec 8 W32) = 799
+primOpTag (VecRemOp WordVec 4 W64) = 800
+primOpTag (VecRemOp WordVec 64 W8) = 801
+primOpTag (VecRemOp WordVec 32 W16) = 802
+primOpTag (VecRemOp WordVec 16 W32) = 803
+primOpTag (VecRemOp WordVec 8 W64) = 804
+primOpTag (VecNegOp IntVec 16 W8) = 805
+primOpTag (VecNegOp IntVec 8 W16) = 806
+primOpTag (VecNegOp IntVec 4 W32) = 807
+primOpTag (VecNegOp IntVec 2 W64) = 808
+primOpTag (VecNegOp IntVec 32 W8) = 809
+primOpTag (VecNegOp IntVec 16 W16) = 810
+primOpTag (VecNegOp IntVec 8 W32) = 811
+primOpTag (VecNegOp IntVec 4 W64) = 812
+primOpTag (VecNegOp IntVec 64 W8) = 813
+primOpTag (VecNegOp IntVec 32 W16) = 814
+primOpTag (VecNegOp IntVec 16 W32) = 815
+primOpTag (VecNegOp IntVec 8 W64) = 816
+primOpTag (VecNegOp FloatVec 4 W32) = 817
+primOpTag (VecNegOp FloatVec 2 W64) = 818
+primOpTag (VecNegOp FloatVec 8 W32) = 819
+primOpTag (VecNegOp FloatVec 4 W64) = 820
+primOpTag (VecNegOp FloatVec 16 W32) = 821
+primOpTag (VecNegOp FloatVec 8 W64) = 822
+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 823
+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 824
+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 825
+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 826
+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 827
+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 828
+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 829
+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 830
+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 831
+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 832
+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 833
+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 834
+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 835
+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 836
+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 837
+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 838
+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 839
+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 840
+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 841
+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 842
+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 843
+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 844
+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 845
+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 846
+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 847
+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 848
+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 849
+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 850
+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 851
+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 852
+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 853
+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 854
+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 855
+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 856
+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 857
+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 858
+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 859
+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 860
+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 861
+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 862
+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 863
+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 864
+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 865
+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 866
+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 867
+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 868
+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 869
+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 870
+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 871
+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 872
+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 873
+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 874
+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 875
+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 876
+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 877
+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 878
+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 879
+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 880
+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 881
+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 882
+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 883
+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 884
+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 885
+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 886
+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 887
+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 888
+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 889
+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 890
+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 891
+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 892
+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 893
+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 894
+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 895
+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 896
+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 897
+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 898
+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 899
+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 900
+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 901
+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 902
+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 903
+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 904
+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 905
+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 906
+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 907
+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 908
+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 909
+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 910
+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 911
+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 912
+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 913
+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 914
+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 915
+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 916
+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 917
+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 918
+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 919
+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 920
+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 921
+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 922
+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 923
+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 924
+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 925
+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 926
+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 927
+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 928
+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 929
+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 930
+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 931
+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 932
+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 933
+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 934
+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 935
+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 936
+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 937
+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 938
+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 939
+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 940
+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 941
+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 942
+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 943
+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 944
+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 945
+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 946
+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 947
+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 948
+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 949
+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 950
+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 951
+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 952
+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 953
+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 954
+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 955
+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 956
+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 957
+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 958
+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 959
+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 960
+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 961
+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 962
+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 963
+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 964
+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 965
+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 966
+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 967
+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 968
+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 969
+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 970
+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 971
+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 972
+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 973
+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 974
+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 975
+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 976
+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 977
+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 978
+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 979
+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 980
+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 981
+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 982
+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 983
+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 984
+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 985
+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 986
+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 987
+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 988
+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 989
+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 990
+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 991
+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 992
+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 993
+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 994
+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 995
+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 996
+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 997
+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 998
+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 999
+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1000
+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1001
+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1002
+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1003
+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1004
+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1005
+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1006
+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1007
+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1008
+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1009
+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1010
+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1011
+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1012
+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1013
+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1014
+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1015
+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1016
+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1017
+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1018
+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1019
+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1020
+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1021
+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1022
+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1023
+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1024
+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1025
+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1026
+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1027
+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1028
+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1029
+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1030
+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1031
+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1032
+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1033
+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1034
+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1035
+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1036
+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1037
+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1038
+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1039
+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1040
+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1041
+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1042
+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1043
+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1044
+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1045
+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1046
+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1047
+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1048
+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1049
+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1050
+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1051
+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1052
+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1053
+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1054
+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1055
+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1056
+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1057
+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1058
+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1059
+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1060
+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1061
+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1062
+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1063
+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1064
+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1065
+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1066
+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1067
+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1068
+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1069
+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1070
+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1071
+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1072
+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1073
+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1074
+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1075
+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1076
+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1077
+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1078
+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1079
+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1080
+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1081
+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1082
+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1083
+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1084
+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1085
+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1086
+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1087
+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1088
+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1089
+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1090
+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1091
+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1092
+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1093
+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1094
+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1095
+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1096
+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1097
+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1098
+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1099
+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1100
+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1101
+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1102
+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1103
+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1104
+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1105
+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1106
+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1107
+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1108
+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1109
+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1110
+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1111
+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1112
+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1113
+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1114
+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1115
+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1116
+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1117
+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1118
+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1119
+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1120
+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1121
+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1122
+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1123
+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1124
+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1125
+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1126
+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1127
+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1128
+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1129
+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1130
+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1131
+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1132
+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1133
+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1134
+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1135
+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1136
+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1137
+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1138
+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1139
+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1140
+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1141
+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1142
+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1143
+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1144
+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1145
+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1146
+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1147
+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1148
+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1149
+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1150
+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1151
+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1152
+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1153
+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1154
+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1155
+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1156
+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1157
+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1158
+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1159
+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1160
+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1161
+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1162
+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1163
+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1164
+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1165
+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1166
+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1167
+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1168
+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1169
+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1170
+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1171
+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1172
+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1173
+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1174
+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1175
+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1176
+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1177
+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1178
+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1179
+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1180
+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1181
+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1182
+primOpTag PrefetchByteArrayOp3 = 1183
+primOpTag PrefetchMutableByteArrayOp3 = 1184
+primOpTag PrefetchAddrOp3 = 1185
+primOpTag PrefetchValueOp3 = 1186
+primOpTag PrefetchByteArrayOp2 = 1187
+primOpTag PrefetchMutableByteArrayOp2 = 1188
+primOpTag PrefetchAddrOp2 = 1189
+primOpTag PrefetchValueOp2 = 1190
+primOpTag PrefetchByteArrayOp1 = 1191
+primOpTag PrefetchMutableByteArrayOp1 = 1192
+primOpTag PrefetchAddrOp1 = 1193
+primOpTag PrefetchValueOp1 = 1194
+primOpTag PrefetchByteArrayOp0 = 1195
+primOpTag PrefetchMutableByteArrayOp0 = 1196
+primOpTag PrefetchAddrOp0 = 1197
+primOpTag PrefetchValueOp0 = 1198
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl
@@ -0,0 +1,30 @@
+    , int8X16PrimTyCon
+    , int16X8PrimTyCon
+    , int32X4PrimTyCon
+    , int64X2PrimTyCon
+    , int8X32PrimTyCon
+    , int16X16PrimTyCon
+    , int32X8PrimTyCon
+    , int64X4PrimTyCon
+    , int8X64PrimTyCon
+    , int16X32PrimTyCon
+    , int32X16PrimTyCon
+    , int64X8PrimTyCon
+    , word8X16PrimTyCon
+    , word16X8PrimTyCon
+    , word32X4PrimTyCon
+    , word64X2PrimTyCon
+    , word8X32PrimTyCon
+    , word16X16PrimTyCon
+    , word32X8PrimTyCon
+    , word64X4PrimTyCon
+    , word8X64PrimTyCon
+    , word16X32PrimTyCon
+    , word32X16PrimTyCon
+    , word64X8PrimTyCon
+    , floatX4PrimTyCon
+    , doubleX2PrimTyCon
+    , floatX8PrimTyCon
+    , doubleX4PrimTyCon
+    , floatX16PrimTyCon
+    , doubleX8PrimTyCon
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl
@@ -0,0 +1,30 @@
+        int8X16PrimTy, int8X16PrimTyCon,
+        int16X8PrimTy, int16X8PrimTyCon,
+        int32X4PrimTy, int32X4PrimTyCon,
+        int64X2PrimTy, int64X2PrimTyCon,
+        int8X32PrimTy, int8X32PrimTyCon,
+        int16X16PrimTy, int16X16PrimTyCon,
+        int32X8PrimTy, int32X8PrimTyCon,
+        int64X4PrimTy, int64X4PrimTyCon,
+        int8X64PrimTy, int8X64PrimTyCon,
+        int16X32PrimTy, int16X32PrimTyCon,
+        int32X16PrimTy, int32X16PrimTyCon,
+        int64X8PrimTy, int64X8PrimTyCon,
+        word8X16PrimTy, word8X16PrimTyCon,
+        word16X8PrimTy, word16X8PrimTyCon,
+        word32X4PrimTy, word32X4PrimTyCon,
+        word64X2PrimTy, word64X2PrimTyCon,
+        word8X32PrimTy, word8X32PrimTyCon,
+        word16X16PrimTy, word16X16PrimTyCon,
+        word32X8PrimTy, word32X8PrimTyCon,
+        word64X4PrimTy, word64X4PrimTyCon,
+        word8X64PrimTy, word8X64PrimTyCon,
+        word16X32PrimTy, word16X32PrimTyCon,
+        word32X16PrimTy, word32X16PrimTyCon,
+        word64X8PrimTy, word64X8PrimTyCon,
+        floatX4PrimTy, floatX4PrimTyCon,
+        doubleX2PrimTy, doubleX2PrimTyCon,
+        floatX8PrimTy, floatX8PrimTyCon,
+        doubleX4PrimTy, doubleX4PrimTyCon,
+        floatX16PrimTy, floatX16PrimTyCon,
+        doubleX8PrimTy, doubleX8PrimTyCon,
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl
@@ -0,0 +1,180 @@
+int8X16PrimTyConName :: Name
+int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon
+int8X16PrimTy :: Type
+int8X16PrimTy = mkTyConTy int8X16PrimTyCon
+int8X16PrimTyCon :: TyCon
+int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)
+int16X8PrimTyConName :: Name
+int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon
+int16X8PrimTy :: Type
+int16X8PrimTy = mkTyConTy int16X8PrimTyCon
+int16X8PrimTyCon :: TyCon
+int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)
+int32X4PrimTyConName :: Name
+int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon
+int32X4PrimTy :: Type
+int32X4PrimTy = mkTyConTy int32X4PrimTyCon
+int32X4PrimTyCon :: TyCon
+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)
+int64X2PrimTyConName :: Name
+int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon
+int64X2PrimTy :: Type
+int64X2PrimTy = mkTyConTy int64X2PrimTyCon
+int64X2PrimTyCon :: TyCon
+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)
+int8X32PrimTyConName :: Name
+int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon
+int8X32PrimTy :: Type
+int8X32PrimTy = mkTyConTy int8X32PrimTyCon
+int8X32PrimTyCon :: TyCon
+int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)
+int16X16PrimTyConName :: Name
+int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon
+int16X16PrimTy :: Type
+int16X16PrimTy = mkTyConTy int16X16PrimTyCon
+int16X16PrimTyCon :: TyCon
+int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)
+int32X8PrimTyConName :: Name
+int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon
+int32X8PrimTy :: Type
+int32X8PrimTy = mkTyConTy int32X8PrimTyCon
+int32X8PrimTyCon :: TyCon
+int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)
+int64X4PrimTyConName :: Name
+int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon
+int64X4PrimTy :: Type
+int64X4PrimTy = mkTyConTy int64X4PrimTyCon
+int64X4PrimTyCon :: TyCon
+int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)
+int8X64PrimTyConName :: Name
+int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon
+int8X64PrimTy :: Type
+int8X64PrimTy = mkTyConTy int8X64PrimTyCon
+int8X64PrimTyCon :: TyCon
+int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)
+int16X32PrimTyConName :: Name
+int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon
+int16X32PrimTy :: Type
+int16X32PrimTy = mkTyConTy int16X32PrimTyCon
+int16X32PrimTyCon :: TyCon
+int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)
+int32X16PrimTyConName :: Name
+int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon
+int32X16PrimTy :: Type
+int32X16PrimTy = mkTyConTy int32X16PrimTyCon
+int32X16PrimTyCon :: TyCon
+int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)
+int64X8PrimTyConName :: Name
+int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon
+int64X8PrimTy :: Type
+int64X8PrimTy = mkTyConTy int64X8PrimTyCon
+int64X8PrimTyCon :: TyCon
+int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)
+word8X16PrimTyConName :: Name
+word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon
+word8X16PrimTy :: Type
+word8X16PrimTy = mkTyConTy word8X16PrimTyCon
+word8X16PrimTyCon :: TyCon
+word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)
+word16X8PrimTyConName :: Name
+word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon
+word16X8PrimTy :: Type
+word16X8PrimTy = mkTyConTy word16X8PrimTyCon
+word16X8PrimTyCon :: TyCon
+word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)
+word32X4PrimTyConName :: Name
+word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon
+word32X4PrimTy :: Type
+word32X4PrimTy = mkTyConTy word32X4PrimTyCon
+word32X4PrimTyCon :: TyCon
+word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)
+word64X2PrimTyConName :: Name
+word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon
+word64X2PrimTy :: Type
+word64X2PrimTy = mkTyConTy word64X2PrimTyCon
+word64X2PrimTyCon :: TyCon
+word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)
+word8X32PrimTyConName :: Name
+word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon
+word8X32PrimTy :: Type
+word8X32PrimTy = mkTyConTy word8X32PrimTyCon
+word8X32PrimTyCon :: TyCon
+word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)
+word16X16PrimTyConName :: Name
+word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon
+word16X16PrimTy :: Type
+word16X16PrimTy = mkTyConTy word16X16PrimTyCon
+word16X16PrimTyCon :: TyCon
+word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)
+word32X8PrimTyConName :: Name
+word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon
+word32X8PrimTy :: Type
+word32X8PrimTy = mkTyConTy word32X8PrimTyCon
+word32X8PrimTyCon :: TyCon
+word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)
+word64X4PrimTyConName :: Name
+word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon
+word64X4PrimTy :: Type
+word64X4PrimTy = mkTyConTy word64X4PrimTyCon
+word64X4PrimTyCon :: TyCon
+word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)
+word8X64PrimTyConName :: Name
+word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon
+word8X64PrimTy :: Type
+word8X64PrimTy = mkTyConTy word8X64PrimTyCon
+word8X64PrimTyCon :: TyCon
+word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)
+word16X32PrimTyConName :: Name
+word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon
+word16X32PrimTy :: Type
+word16X32PrimTy = mkTyConTy word16X32PrimTyCon
+word16X32PrimTyCon :: TyCon
+word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)
+word32X16PrimTyConName :: Name
+word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon
+word32X16PrimTy :: Type
+word32X16PrimTy = mkTyConTy word32X16PrimTyCon
+word32X16PrimTyCon :: TyCon
+word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)
+word64X8PrimTyConName :: Name
+word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon
+word64X8PrimTy :: Type
+word64X8PrimTy = mkTyConTy word64X8PrimTyCon
+word64X8PrimTyCon :: TyCon
+word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)
+floatX4PrimTyConName :: Name
+floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon
+floatX4PrimTy :: Type
+floatX4PrimTy = mkTyConTy floatX4PrimTyCon
+floatX4PrimTyCon :: TyCon
+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)
+doubleX2PrimTyConName :: Name
+doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon
+doubleX2PrimTy :: Type
+doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon
+doubleX2PrimTyCon :: TyCon
+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)
+floatX8PrimTyConName :: Name
+floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon
+floatX8PrimTy :: Type
+floatX8PrimTy = mkTyConTy floatX8PrimTyCon
+floatX8PrimTyCon :: TyCon
+floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)
+doubleX4PrimTyConName :: Name
+doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon
+doubleX4PrimTy :: Type
+doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon
+doubleX4PrimTyCon :: TyCon
+doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)
+floatX16PrimTyConName :: Name
+floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon
+floatX16PrimTy :: Type
+floatX16PrimTy = mkTyConTy floatX16PrimTyCon
+floatX16PrimTyCon :: TyCon
+floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)
+doubleX8PrimTyConName :: Name
+doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon
+doubleX8PrimTy :: Type
+doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon
+doubleX8PrimTyCon :: TyCon
+doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl
@@ -0,0 +1,60 @@
+int8X16PrimTyConKey :: Unique
+int8X16PrimTyConKey = mkPreludeTyConUnique 300
+int16X8PrimTyConKey :: Unique
+int16X8PrimTyConKey = mkPreludeTyConUnique 301
+int32X4PrimTyConKey :: Unique
+int32X4PrimTyConKey = mkPreludeTyConUnique 302
+int64X2PrimTyConKey :: Unique
+int64X2PrimTyConKey = mkPreludeTyConUnique 303
+int8X32PrimTyConKey :: Unique
+int8X32PrimTyConKey = mkPreludeTyConUnique 304
+int16X16PrimTyConKey :: Unique
+int16X16PrimTyConKey = mkPreludeTyConUnique 305
+int32X8PrimTyConKey :: Unique
+int32X8PrimTyConKey = mkPreludeTyConUnique 306
+int64X4PrimTyConKey :: Unique
+int64X4PrimTyConKey = mkPreludeTyConUnique 307
+int8X64PrimTyConKey :: Unique
+int8X64PrimTyConKey = mkPreludeTyConUnique 308
+int16X32PrimTyConKey :: Unique
+int16X32PrimTyConKey = mkPreludeTyConUnique 309
+int32X16PrimTyConKey :: Unique
+int32X16PrimTyConKey = mkPreludeTyConUnique 310
+int64X8PrimTyConKey :: Unique
+int64X8PrimTyConKey = mkPreludeTyConUnique 311
+word8X16PrimTyConKey :: Unique
+word8X16PrimTyConKey = mkPreludeTyConUnique 312
+word16X8PrimTyConKey :: Unique
+word16X8PrimTyConKey = mkPreludeTyConUnique 313
+word32X4PrimTyConKey :: Unique
+word32X4PrimTyConKey = mkPreludeTyConUnique 314
+word64X2PrimTyConKey :: Unique
+word64X2PrimTyConKey = mkPreludeTyConUnique 315
+word8X32PrimTyConKey :: Unique
+word8X32PrimTyConKey = mkPreludeTyConUnique 316
+word16X16PrimTyConKey :: Unique
+word16X16PrimTyConKey = mkPreludeTyConUnique 317
+word32X8PrimTyConKey :: Unique
+word32X8PrimTyConKey = mkPreludeTyConUnique 318
+word64X4PrimTyConKey :: Unique
+word64X4PrimTyConKey = mkPreludeTyConUnique 319
+word8X64PrimTyConKey :: Unique
+word8X64PrimTyConKey = mkPreludeTyConUnique 320
+word16X32PrimTyConKey :: Unique
+word16X32PrimTyConKey = mkPreludeTyConUnique 321
+word32X16PrimTyConKey :: Unique
+word32X16PrimTyConKey = mkPreludeTyConUnique 322
+word64X8PrimTyConKey :: Unique
+word64X8PrimTyConKey = mkPreludeTyConUnique 323
+floatX4PrimTyConKey :: Unique
+floatX4PrimTyConKey = mkPreludeTyConUnique 324
+doubleX2PrimTyConKey :: Unique
+doubleX2PrimTyConKey = mkPreludeTyConUnique 325
+floatX8PrimTyConKey :: Unique
+floatX8PrimTyConKey = mkPreludeTyConUnique 326
+doubleX4PrimTyConKey :: Unique
+doubleX4PrimTyConKey = mkPreludeTyConUnique 327
+floatX16PrimTyConKey :: Unique
+floatX16PrimTyConKey = mkPreludeTyConUnique 328
+doubleX8PrimTyConKey :: Unique
+doubleX8PrimTyConKey = mkPreludeTyConUnique 329
diff --git a/ghc-lib/stage1/lib/llvm-passes b/ghc-lib/stage1/lib/llvm-passes
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/llvm-passes
@@ -0,0 +1,5 @@
+[
+(0, "-mem2reg -globalopt"),
+(1, "-O1 -globalopt"),
+(2, "-O2")
+]
diff --git a/ghc-lib/stage1/lib/llvm-targets b/ghc-lib/stage1/lib/llvm-targets
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/llvm-targets
@@ -0,0 +1,31 @@
+[("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))
+,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))
+,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))
+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
+,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
+,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))
+,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))
+,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))
+,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))
+,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))
+,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("i386-apple-ios", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))
+,("x86_64-apple-ios", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))
+,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))
+]
diff --git a/ghc-lib/stage1/lib/platformConstants b/ghc-lib/stage1/lib/platformConstants
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/platformConstants
@@ -0,0 +1,134 @@
+PlatformConstants {
+    pc_platformConstants = ()
+    , pc_CONTROL_GROUP_CONST_291 = 291
+    , pc_STD_HDR_SIZE = 1
+    , pc_PROF_HDR_SIZE = 2
+    , pc_BLOCK_SIZE = 4096
+    , pc_BLOCKS_PER_MBLOCK = 252
+    , pc_TICKY_BIN_COUNT = 9
+    , pc_OFFSET_StgRegTable_rR1 = 0
+    , pc_OFFSET_StgRegTable_rR2 = 8
+    , pc_OFFSET_StgRegTable_rR3 = 16
+    , pc_OFFSET_StgRegTable_rR4 = 24
+    , pc_OFFSET_StgRegTable_rR5 = 32
+    , pc_OFFSET_StgRegTable_rR6 = 40
+    , pc_OFFSET_StgRegTable_rR7 = 48
+    , pc_OFFSET_StgRegTable_rR8 = 56
+    , pc_OFFSET_StgRegTable_rR9 = 64
+    , pc_OFFSET_StgRegTable_rR10 = 72
+    , pc_OFFSET_StgRegTable_rF1 = 80
+    , pc_OFFSET_StgRegTable_rF2 = 84
+    , pc_OFFSET_StgRegTable_rF3 = 88
+    , pc_OFFSET_StgRegTable_rF4 = 92
+    , pc_OFFSET_StgRegTable_rF5 = 96
+    , pc_OFFSET_StgRegTable_rF6 = 100
+    , pc_OFFSET_StgRegTable_rD1 = 104
+    , pc_OFFSET_StgRegTable_rD2 = 112
+    , pc_OFFSET_StgRegTable_rD3 = 120
+    , pc_OFFSET_StgRegTable_rD4 = 128
+    , pc_OFFSET_StgRegTable_rD5 = 136
+    , pc_OFFSET_StgRegTable_rD6 = 144
+    , pc_OFFSET_StgRegTable_rXMM1 = 152
+    , pc_OFFSET_StgRegTable_rXMM2 = 168
+    , pc_OFFSET_StgRegTable_rXMM3 = 184
+    , pc_OFFSET_StgRegTable_rXMM4 = 200
+    , pc_OFFSET_StgRegTable_rXMM5 = 216
+    , pc_OFFSET_StgRegTable_rXMM6 = 232
+    , pc_OFFSET_StgRegTable_rYMM1 = 248
+    , pc_OFFSET_StgRegTable_rYMM2 = 280
+    , pc_OFFSET_StgRegTable_rYMM3 = 312
+    , pc_OFFSET_StgRegTable_rYMM4 = 344
+    , pc_OFFSET_StgRegTable_rYMM5 = 376
+    , pc_OFFSET_StgRegTable_rYMM6 = 408
+    , pc_OFFSET_StgRegTable_rZMM1 = 440
+    , pc_OFFSET_StgRegTable_rZMM2 = 504
+    , pc_OFFSET_StgRegTable_rZMM3 = 568
+    , pc_OFFSET_StgRegTable_rZMM4 = 632
+    , pc_OFFSET_StgRegTable_rZMM5 = 696
+    , pc_OFFSET_StgRegTable_rZMM6 = 760
+    , pc_OFFSET_StgRegTable_rL1 = 824
+    , pc_OFFSET_StgRegTable_rSp = 832
+    , pc_OFFSET_StgRegTable_rSpLim = 840
+    , pc_OFFSET_StgRegTable_rHp = 848
+    , pc_OFFSET_StgRegTable_rHpLim = 856
+    , pc_OFFSET_StgRegTable_rCCCS = 864
+    , pc_OFFSET_StgRegTable_rCurrentTSO = 872
+    , pc_OFFSET_StgRegTable_rCurrentNursery = 888
+    , pc_OFFSET_StgRegTable_rHpAlloc = 904
+    , pc_OFFSET_stgEagerBlackholeInfo = -24
+    , pc_OFFSET_stgGCEnter1 = -16
+    , pc_OFFSET_stgGCFun = -8
+    , pc_OFFSET_Capability_r = 24
+    , pc_OFFSET_bdescr_start = 0
+    , pc_OFFSET_bdescr_free = 8
+    , pc_OFFSET_bdescr_blocks = 48
+    , pc_OFFSET_bdescr_flags = 46
+    , pc_SIZEOF_CostCentreStack = 96
+    , pc_OFFSET_CostCentreStack_mem_alloc = 72
+    , pc_REP_CostCentreStack_mem_alloc = 8
+    , pc_OFFSET_CostCentreStack_scc_count = 48
+    , pc_REP_CostCentreStack_scc_count = 8
+    , pc_OFFSET_StgHeader_ccs = 8
+    , pc_OFFSET_StgHeader_ldvw = 16
+    , pc_SIZEOF_StgSMPThunkHeader = 8
+    , pc_OFFSET_StgEntCounter_allocs = 48
+    , pc_REP_StgEntCounter_allocs = 8
+    , pc_OFFSET_StgEntCounter_allocd = 16
+    , pc_REP_StgEntCounter_allocd = 8
+    , pc_OFFSET_StgEntCounter_registeredp = 0
+    , pc_OFFSET_StgEntCounter_link = 56
+    , pc_OFFSET_StgEntCounter_entry_count = 40
+    , pc_SIZEOF_StgUpdateFrame_NoHdr = 8
+    , pc_SIZEOF_StgMutArrPtrs_NoHdr = 16
+    , pc_OFFSET_StgMutArrPtrs_ptrs = 0
+    , pc_OFFSET_StgMutArrPtrs_size = 8
+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8
+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
+    , pc_SIZEOF_StgArrBytes_NoHdr = 8
+    , pc_OFFSET_StgArrBytes_bytes = 0
+    , pc_OFFSET_StgTSO_alloc_limit = 96
+    , pc_OFFSET_StgTSO_cccs = 112
+    , pc_OFFSET_StgTSO_stackobj = 16
+    , pc_OFFSET_StgStack_sp = 8
+    , pc_OFFSET_StgStack_stack = 16
+    , pc_OFFSET_StgUpdateFrame_updatee = 0
+    , pc_OFFSET_StgFunInfoExtraFwd_arity = 4
+    , pc_REP_StgFunInfoExtraFwd_arity = 4
+    , pc_SIZEOF_StgFunInfoExtraRev = 24
+    , pc_OFFSET_StgFunInfoExtraRev_arity = 20
+    , pc_REP_StgFunInfoExtraRev_arity = 4
+    , pc_MAX_SPEC_SELECTEE_SIZE = 15
+    , pc_MAX_SPEC_AP_SIZE = 7
+    , pc_MIN_PAYLOAD_SIZE = 1
+    , pc_MIN_INTLIKE = -16
+    , pc_MAX_INTLIKE = 16
+    , pc_MIN_CHARLIKE = 0
+    , pc_MAX_CHARLIKE = 255
+    , pc_MUT_ARR_PTRS_CARD_BITS = 7
+    , pc_MAX_Vanilla_REG = 10
+    , pc_MAX_Float_REG = 6
+    , pc_MAX_Double_REG = 6
+    , pc_MAX_Long_REG = 1
+    , pc_MAX_XMM_REG = 6
+    , pc_MAX_Real_Vanilla_REG = 6
+    , pc_MAX_Real_Float_REG = 6
+    , pc_MAX_Real_Double_REG = 6
+    , pc_MAX_Real_XMM_REG = 6
+    , pc_MAX_Real_Long_REG = 0
+    , pc_RESERVED_C_STACK_BYTES = 16384
+    , pc_RESERVED_STACK_WORDS = 21
+    , pc_AP_STACK_SPLIM = 1024
+    , pc_WORD_SIZE = 8
+    , pc_DOUBLE_SIZE = 8
+    , pc_CINT_SIZE = 4
+    , pc_CLONG_SIZE = 8
+    , pc_CLONG_LONG_SIZE = 8
+    , pc_BITMAP_BITS_SHIFT = 6
+    , pc_TAG_BITS = 3
+    , pc_WORDS_BIGENDIAN = False
+    , pc_DYNAMIC_BY_DEFAULT = False
+    , pc_LDV_SHIFT = 30
+    , pc_ILDV_CREATE_MASK = 1152921503533105152
+    , pc_ILDV_STATE_CREATE = 0
+    , pc_ILDV_STATE_USE = 1152921504606846976
+  }
diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/settings
@@ -0,0 +1,47 @@
+[("GCC extra via C opts", "-fwrapv -fno-builtin")
+,("C compiler command", "gcc")
+,("C compiler flags", "")
+,("C compiler link flags", "")
+,("C compiler supports -no-pie", "NO")
+,("Haskell CPP command", "gcc")
+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")
+,("ld command", "ld")
+,("ld flags", "")
+,("ld supports compact unwind", "YES")
+,("ld supports build-id", "NO")
+,("ld supports filelist", "YES")
+,("ld is GNU ld", "NO")
+,("ar command", "ar")
+,("ar flags", "qcls")
+,("ar supports at file", "NO")
+,("ranlib command", "ranlib")
+,("touch command", "touch")
+,("dllwrap command", "/bin/false")
+,("windres command", "/bin/false")
+,("libtool command", "libtool")
+,("unlit command", "$topdir/bin/ghc-lib/stage0/lib/bin/unlit")
+,("cross compiling", "NO")
+,("target platform string", "x86_64-apple-darwin")
+,("target os", "OSDarwin")
+,("target arch", "ArchX86_64")
+,("target word size", "8")
+,("target has GNU nonexec stack", "False")
+,("target has .ident directive", "True")
+,("target has subsections via symbols", "True")
+,("target has RTS linker", "YES")
+,("Unregisterised", "NO")
+,("LLVM llc command", "llc")
+,("LLVM opt command", "opt")
+,("LLVM clang command", "clang")
+,("integer library", "integer-simple")
+,("Use interpreter", "YES")
+,("Use native code generator", "YES")
+,("Support SMP", "YES")
+,("RTS ways", "YES")
+,("Tables next to code", "YES")
+,("Leading underscore", "NO")
+,("Use LibFFI", "NO")
+,("Use Threads", "YES")
+,("Use Debugging", "NO")
+,("RTS expects libdw", "NO")
+]
diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/Leak.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
+module GHCi.Leak
+  ( LeakIndicators
+  , getLeakIndicators
+  , checkLeakIndicators
+  ) where
+
+import Control.Monad
+import Data.Bits
+import DynFlags ( sTargetPlatform )
+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
+import GHC
+import GHC.Ptr (Ptr (..))
+import GHCi.Util
+import HscTypes
+import Outputable
+import Platform (target32Bit)
+import Prelude
+import System.Mem
+import System.Mem.Weak
+import UniqDFM
+
+-- Checking for space leaks in GHCi. See #15111, and the
+-- -fghci-leak-check flag.
+
+data LeakIndicators = LeakIndicators [LeakModIndicators]
+
+data LeakModIndicators = LeakModIndicators
+  { leakMod :: Weak HomeModInfo
+  , leakIface :: Weak ModIface
+  , leakDetails :: Weak ModDetails
+  , leakLinkable :: Maybe (Weak Linkable)
+  }
+
+-- | Grab weak references to some of the data structures representing
+-- the currently loaded modules.
+getLeakIndicators :: HscEnv -> IO LeakIndicators
+getLeakIndicators HscEnv{..} =
+  fmap LeakIndicators $
+    forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do
+      leakMod <- mkWeakPtr hmi Nothing
+      leakIface <- mkWeakPtr hm_iface Nothing
+      leakDetails <- mkWeakPtr hm_details Nothing
+      leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable
+      return $ LeakModIndicators{..}
+
+-- | Look at the LeakIndicators collected by an earlier call to
+-- `getLeakIndicators`, and print messasges if any of them are still
+-- alive.
+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()
+checkLeakIndicators dflags (LeakIndicators leakmods)  = do
+  performGC
+  forM_ leakmods $ \LeakModIndicators{..} -> do
+    deRefWeak leakMod >>= \case
+      Nothing -> return ()
+      Just hmi ->
+        report ("HomeModInfo for " ++
+          showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
+    deRefWeak leakIface >>= report "ModIface"
+    deRefWeak leakDetails >>= report "ModDetails"
+    forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
+ where
+  report :: String -> Maybe a -> IO ()
+  report _ Nothing = return ()
+  report msg (Just a) = do
+    addr <- anyToPtr a
+    putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++
+              show (maskTagBits addr))
+
+  tagBits
+    | target32Bit (sTargetPlatform (settings dflags)) = 2
+    | otherwise = 3
+
+  maskTagBits :: Ptr a -> Ptr a
+  maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI.hs
@@ -0,0 +1,4055 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- GHC Interactive User Interface
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+module GHCi.UI (
+        interactiveUI,
+        GhciSettings(..),
+        defaultGhciSettings,
+        ghciCommands,
+        ghciWelcomeMsg
+    ) where
+
+#include "HsVersions.h"
+
+-- GHCi
+import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
+import GHCi.UI.Monad hiding ( args, runStmt )
+import GHCi.UI.Tags
+import GHCi.UI.Info
+import Debugger
+
+-- The GHC interface
+import GHCi
+import GHCi.RemoteTypes
+import GHCi.BreakArray
+import DynFlags
+import ErrUtils hiding (traceCmd)
+import Finder
+import GhcMonad ( modifySession )
+import qualified GHC
+import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
+             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
+             GetDocsFailure(..),
+             getModuleGraph, handleSourceError )
+import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)
+import HsImpExp
+import HsSyn
+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
+                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,
+                  hsc_dynLinker )
+import Module
+import Name
+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
+                  listVisibleModuleNames, pprFlag )
+import IfaceSyn ( showToHeader )
+import PprTyThing
+import PrelNames
+import RdrName ( getGRE_NameQualifier_maybes, getRdrName )
+import SrcLoc
+import qualified Lexer
+
+import StringBuffer
+import Outputable hiding ( printForUser, printForUserPartWay )
+
+import DynamicLoading ( initializePlugins )
+
+-- Other random utilities
+import BasicTypes hiding ( isTopLevel )
+import Config
+import Digraph
+import Encoding
+import FastString
+import Linker
+import Maybes ( orElse, expectJust )
+import NameSet
+import Panic hiding ( showException )
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import Bag (unitBag)
+
+-- Haskell Libraries
+import System.Console.Haskeline as Haskeline
+
+import Control.Applicative hiding (empty)
+import Control.DeepSeq (deepseq)
+import Control.Monad as Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+
+import Data.Array
+import qualified Data.ByteString.Char8 as BS
+import Data.Char
+import Data.Function
+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
+                   partition, sort, sortBy, (\\) )
+import qualified Data.Set as S
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Time.LocalTime ( getZonedTime )
+import Data.Time.Format ( formatTime, defaultTimeLocale )
+import Data.Version ( showVersion )
+import Prelude hiding ((<>))
+
+import Exception hiding (catch)
+import Foreign hiding (void)
+import GHC.Stack hiding (SrcLoc(..))
+
+import System.Directory
+import System.Environment
+import System.Exit ( exitWith, ExitCode(..) )
+import System.FilePath
+import System.Info
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Process
+import Text.Printf
+import Text.Read ( readMaybe )
+import Text.Read.Lex (isSymbolChar)
+
+import Unsafe.Coerce
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix hiding ( getEnv )
+#else
+import qualified System.Win32
+#endif
+
+import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
+import GHC.IO.Handle ( hFlushAll )
+import GHC.TopHandler ( topHandler )
+
+import GHCi.Leak
+
+-----------------------------------------------------------------------------
+
+data GhciSettings = GhciSettings {
+        availableCommands :: [Command],
+        shortHelpText     :: String,
+        fullHelpText      :: String,
+        defPrompt         :: PromptFunction,
+        defPromptCont     :: PromptFunction
+    }
+
+defaultGhciSettings :: GhciSettings
+defaultGhciSettings =
+    GhciSettings {
+        availableCommands = ghciCommands,
+        shortHelpText     = defShortHelpText,
+        defPrompt         = default_prompt,
+        defPromptCont     = default_prompt_cont,
+        fullHelpText      = defFullHelpText
+    }
+
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+                 ": https://www.haskell.org/ghc/  :? for help"
+
+ghciCommands :: [Command]
+ghciCommands = map mkCmd [
+  -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+  ("?",         keepGoing help,                 noCompletion),
+  ("add",       keepGoingPaths addModule,       completeFilename),
+  ("abandon",   keepGoing abandonCmd,           noCompletion),
+  ("break",     keepGoing breakCmd,             completeIdentifier),
+  ("back",      keepGoing backCmd,              noCompletion),
+  ("browse",    keepGoing' (browseCmd False),   completeModule),
+  ("browse!",   keepGoing' (browseCmd True),    completeModule),
+  ("cd",        keepGoing' changeDirectory,     completeFilename),
+  ("check",     keepGoing' checkModule,         completeHomeModule),
+  ("continue",  keepGoing continueCmd,          noCompletion),
+  ("cmd",       keepGoing cmdCmd,               completeExpression),
+  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
+  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
+  ("def",       keepGoing (defineMacro False),  completeExpression),
+  ("def!",      keepGoing (defineMacro True),   completeExpression),
+  ("delete",    keepGoing deleteCmd,            noCompletion),
+  ("doc",       keepGoing' docCmd,              completeIdentifier),
+  ("edit",      keepGoing' editFile,            completeFilename),
+  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
+  ("force",     keepGoing forceCmd,             completeExpression),
+  ("forward",   keepGoing forwardCmd,           noCompletion),
+  ("help",      keepGoing help,                 noCompletion),
+  ("history",   keepGoing historyCmd,           noCompletion),
+  ("info",      keepGoing' (info False),        completeIdentifier),
+  ("info!",     keepGoing' (info True),         completeIdentifier),
+  ("issafe",    keepGoing' isSafeCmd,           completeModule),
+  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
+  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
+  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
+  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
+  ("list",      keepGoing' listCmd,             noCompletion),
+  ("module",    keepGoing moduleCmd,            completeSetModule),
+  ("main",      keepGoing runMain,              completeFilename),
+  ("print",     keepGoing printCmd,             completeExpression),
+  ("quit",      quit,                           noCompletion),
+  ("reload",    keepGoing' reloadModule,        noCompletion),
+  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),
+  ("run",       keepGoing runRun,               completeFilename),
+  ("script",    keepGoing' scriptCmd,           completeFilename),
+  ("set",       keepGoing setCmd,               completeSetOptions),
+  ("seti",      keepGoing setiCmd,              completeSeti),
+  ("show",      keepGoing showCmd,              completeShowOptions),
+  ("showi",     keepGoing showiCmd,             completeShowiOptions),
+  ("sprint",    keepGoing sprintCmd,            completeExpression),
+  ("step",      keepGoing stepCmd,              completeIdentifier),
+  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
+  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
+  ("type",      keepGoing' typeOfExpr,          completeExpression),
+  ("trace",     keepGoing traceCmd,             completeExpression),
+  ("unadd",     keepGoingPaths unAddModule,     completeFilename),
+  ("undef",     keepGoing undefineMacro,        completeMacro),
+  ("unset",     keepGoing unsetOptions,         completeSetOptions),
+  ("where",     keepGoing whereCmd,             noCompletion)
+  ] ++ map mkCmdHidden [ -- hidden commands
+  ("all-types", keepGoing' allTypesCmd),
+  ("complete",  keepGoing completeCmd),
+  ("loc-at",    keepGoing' locAtCmd),
+  ("type-at",   keepGoing' typeAtCmd),
+  ("uses",      keepGoing' usesCmd)
+  ]
+ where
+  mkCmd (n,a,c) = Command { cmdName = n
+                          , cmdAction = a
+                          , cmdHidden = False
+                          , cmdCompletionFunc = c
+                          }
+
+  mkCmdHidden (n,a) = Command { cmdName = n
+                              , cmdAction = a
+                              , cmdHidden = True
+                              , cmdCompletionFunc = noCompletion
+                              }
+
+-- We initialize readline (in the interactiveUI function) to use
+-- word_break_chars as the default set of completion word break characters.
+-- This can be overridden for a particular command (for example, filename
+-- expansion shouldn't consider '/' to be a word break) by setting the third
+-- entry in the Command tuple above.
+--
+-- NOTE: in order for us to override the default correctly, any custom entry
+-- must be a SUBSET of word_break_chars.
+word_break_chars :: String
+word_break_chars = spaces ++ specials ++ symbols
+
+symbols, specials, spaces :: String
+symbols = "!#$%&*+/<=>?@\\^|-~"
+specials = "(),;[]`{}"
+spaces = " \t\n"
+
+flagWordBreakChars :: String
+flagWordBreakChars = " \t\n"
+
+
+keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
+keepGoing a str = keepGoing' (lift . a) str
+
+keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
+keepGoing' a str = a str >> return False
+
+keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
+keepGoingPaths a str
+ = do case toArgs str of
+          Left err -> liftIO $ hPutStrLn stderr err
+          Right args -> a args
+      return False
+
+defShortHelpText :: String
+defShortHelpText = "use :? for help.\n"
+
+defFullHelpText :: String
+defFullHelpText =
+  " Commands available from the prompt:\n" ++
+  "\n" ++
+  "   <statement>                 evaluate/run <statement>\n" ++
+  "   :                           repeat last command\n" ++
+  "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
+  "   :add [*]<module> ...        add module(s) to the current target set\n" ++
+  "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
+  "                               (!: more details; *: all top-level names)\n" ++
+  "   :cd <dir>                   change directory to <dir>\n" ++
+  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
+  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
+  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" ++
+  "                               (!: use regex instead of line number)\n" ++
+  "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" ++
+  "                               precedence, ::<cmd> is always a builtin command)\n" ++
+  "   :doc <name>                 display docs for the given name (experimental)\n" ++
+  "   :edit <file>                edit file\n" ++
+  "   :edit                       edit last module\n" ++
+  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" ++
+  "   :help, :?                   display this list of commands\n" ++
+  "   :info[!] [<name> ...]       display information about the given names\n" ++
+  "                               (!: do not filter instances)\n" ++
+  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
+  "   :kind[!] <type>             show the kind of <type>\n" ++
+  "                               (!: also print the normalised type)\n" ++
+  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
+  "                               (!: defer type errors)\n" ++
+  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
+  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
+  "   :quit                       exit GHCi\n" ++
+  "   :reload[!]                  reload the current module set\n" ++
+  "                               (!: defer type errors)\n" ++
+  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
+  "   :script <file>              run the script <file>\n" ++
+  "   :type <expr>                show the type of <expr>\n" ++
+  "   :type +d <expr>             show the type of <expr>, defaulting type variables\n" ++
+  "   :type +v <expr>             show the type of <expr>, with its specified tyvars\n" ++
+  "   :unadd <module> ...         remove module(s) from the current target set\n" ++
+  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
+  "   :!<command>                 run the shell command <command>\n" ++
+  "\n" ++
+  " -- Commands for debugging:\n" ++
+  "\n" ++
+  "   :abandon                    at a breakpoint, abandon current computation\n" ++
+  "   :back [<n>]                 go back in the history N steps (after :trace)\n" ++
+  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
+  "   :break <name>               set a breakpoint on the specified function\n" ++
+  "   :continue                   resume after a breakpoint\n" ++
+  "   :delete <number>            delete the specified breakpoint\n" ++
+  "   :delete *                   delete all breakpoints\n" ++
+  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
+  "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
+  "   :history [<n>]              after :trace, show the execution history\n" ++
+  "   :list                       show the source code around current breakpoint\n" ++
+  "   :list <identifier>          show the source code for <identifier>\n" ++
+  "   :list [<module>] <line>     show the source code around line number <line>\n" ++
+  "   :print [<name> ...]         show a value without forcing its computation\n" ++
+  "   :sprint [<name> ...]        simplified version of :print\n" ++
+  "   :step                       single-step after stopping at a breakpoint\n"++
+  "   :step <expr>                single-step into <expr>\n"++
+  "   :steplocal                  single-step within the current top-level binding\n"++
+  "   :stepmodule                 single-step restricted to the current module\n"++
+  "   :trace                      trace after stopping at a breakpoint\n"++
+  "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++
+
+  "\n" ++
+  " -- Commands for changing settings:\n" ++
+  "\n" ++
+  "   :set <option> ...           set options\n" ++
+  "   :seti <option> ...          set options for interactive evaluation only\n" ++
+  "   :set local-config { source | ignore }\n" ++
+  "                               set whether to source .ghci in current dir\n" ++
+  "                               (loading untrusted config is a security issue)\n" ++
+  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
+  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
+  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
+  "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" ++
+  "   :set prompt-function <expr> set the function to handle the prompt\n" ++
+  "   :set prompt-cont-function <expr>\n" ++
+  "                               set the function to handle the continuation prompt\n" ++
+  "   :set editor <cmd>           set the command used for :edit\n" ++
+  "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++
+  "   :unset <option> ...         unset options\n" ++
+  "\n" ++
+  "  Options for ':set' and ':unset':\n" ++
+  "\n" ++
+  "    +m            allow multiline commands\n" ++
+  "    +r            revert top-level expressions after each evaluation\n" ++
+  "    +s            print timing/memory stats after each evaluation\n" ++
+  "    +t            print type after evaluation\n" ++
+  "    +c            collect type/location info after loading modules\n" ++
+  "    -<flags>      most GHC command line flags can also be set here\n" ++
+  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
+  "                    for GHCi-specific flags, see User's Guide,\n"++
+  "                    Flag reference, Interactive-mode options\n" ++
+  "\n" ++
+  " -- Commands for displaying information:\n" ++
+  "\n" ++
+  "   :show bindings              show the current bindings made at the prompt\n" ++
+  "   :show breaks                show the active breakpoints\n" ++
+  "   :show context               show the breakpoint context\n" ++
+  "   :show imports               show the current imports\n" ++
+  "   :show linker                show current linker state\n" ++
+  "   :show modules               show the currently loaded modules\n" ++
+  "   :show packages              show the currently active package flags\n" ++
+  "   :show paths                 show the currently active search paths\n" ++
+  "   :show language              show the currently active language flags\n" ++
+  "   :show targets               show the current set of targets\n" ++
+  "   :show <setting>             show value of <setting>, which is one of\n" ++
+  "                                  [args, prog, editor, stop]\n" ++
+  "   :showi language             show language flags for interactive evaluation\n" ++
+  "\n"
+
+findEditor :: IO String
+findEditor = do
+  getEnv "EDITOR"
+    `catchIO` \_ -> do
+#if defined(mingw32_HOST_OS)
+        win <- System.Win32.getWindowsDirectory
+        return (win </> "notepad.exe")
+#else
+        return ""
+#endif
+
+default_progname, default_stop :: String
+default_progname = "<interactive>"
+default_stop = ""
+
+default_prompt, default_prompt_cont :: PromptFunction
+default_prompt = generatePromptFunctionFromString "%s> "
+default_prompt_cont = generatePromptFunctionFromString "%s| "
+
+default_args :: [String]
+default_args = []
+
+interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
+              -> Ghc ()
+interactiveUI config srcs maybe_exprs = do
+   -- HACK! If we happen to get into an infinite loop (eg the user
+   -- types 'let x=x in x' at the prompt), then the thread will block
+   -- on a blackhole, and become unreachable during GC.  The GC will
+   -- detect that it is unreachable and send it the NonTermination
+   -- exception.  However, since the thread is unreachable, everything
+   -- it refers to might be finalized, including the standard Handles.
+   -- This sounds like a bug, but we don't have a good solution right
+   -- now.
+   _ <- liftIO $ newStablePtr stdin
+   _ <- liftIO $ newStablePtr stdout
+   _ <- liftIO $ newStablePtr stderr
+
+    -- Initialise buffering for the *interpreted* I/O system
+   (nobuffering, flush) <- initInterpBuffering
+
+   -- The initial set of DynFlags used for interactive evaluation is the same
+   -- as the global DynFlags, plus -XExtendedDefaultRules and
+   -- -XNoMonomorphismRestriction.
+   -- See note [Changing language extensions for interactive evaluation] #10857
+   dflags <- getDynFlags
+   let dflags' = (xopt_set_unlessExplSpec
+                      LangExt.ExtendedDefaultRules xopt_set)
+               . (xopt_set_unlessExplSpec
+                      LangExt.MonomorphismRestriction xopt_unset)
+               $ dflags
+   GHC.setInteractiveDynFlags dflags'
+
+   lastErrLocationsRef <- liftIO $ newIORef []
+   progDynFlags <- GHC.getProgramDynFlags
+   _ <- GHC.setProgramDynFlags $
+      -- Ensure we don't override the user's log action lest we break
+      -- -ddump-json (#14078)
+      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)
+                                                lastErrLocationsRef }
+
+   when (isNothing maybe_exprs) $ do
+        -- Only for GHCi (not runghc and ghc -e):
+
+        -- Turn buffering off for the compiled program's stdout/stderr
+        turnOffBuffering_ nobuffering
+        -- Turn buffering off for GHCi's stdout
+        liftIO $ hFlush stdout
+        liftIO $ hSetBuffering stdout NoBuffering
+        -- We don't want the cmd line to buffer any input that might be
+        -- intended for the program, so unbuffer stdin.
+        liftIO $ hSetBuffering stdin NoBuffering
+        liftIO $ hSetBuffering stderr NoBuffering
+#if defined(mingw32_HOST_OS)
+        -- On Unix, stdin will use the locale encoding.  The IO library
+        -- doesn't do this on Windows (yet), so for now we use UTF-8,
+        -- for consistency with GHC 6.10 and to make the tests work.
+        liftIO $ hSetEncoding stdin utf8
+#endif
+
+   default_editor <- liftIO $ findEditor
+   eval_wrapper <- mkEvalWrapper default_progname default_args
+   let prelude_import = simpleImportDecl preludeModuleName
+   startGHCi (runGHCi srcs maybe_exprs)
+        GHCiState{ progname           = default_progname,
+                   args               = default_args,
+                   evalWrapper        = eval_wrapper,
+                   prompt             = defPrompt config,
+                   prompt_cont        = defPromptCont config,
+                   stop               = default_stop,
+                   editor             = default_editor,
+                   options            = [],
+                   localConfig        = SourceLocalConfig,
+                   -- We initialize line number as 0, not 1, because we use
+                   -- current line number while reporting errors which is
+                   -- incremented after reading a line.
+                   line_number        = 0,
+                   break_ctr          = 0,
+                   breaks             = [],
+                   tickarrays         = emptyModuleEnv,
+                   ghci_commands      = availableCommands config,
+                   ghci_macros        = [],
+                   last_command       = Nothing,
+                   cmd_wrapper        = (cmdSuccess =<<),
+                   cmdqueue           = [],
+                   remembered_ctx     = [],
+                   transient_ctx      = [],
+                   extra_imports      = [],
+                   prelude_imports    = [prelude_import],
+                   ghc_e              = isJust maybe_exprs,
+                   short_help         = shortHelpText config,
+                   long_help          = fullHelpText config,
+                   lastErrorLocations = lastErrLocationsRef,
+                   mod_infos          = M.empty,
+                   flushStdHandles    = flush,
+                   noBuffering        = nobuffering
+                 }
+
+   return ()
+
+{-
+Note [Changing language extensions for interactive evaluation]
+--------------------------------------------------------------
+GHCi maintains two sets of options:
+
+- The "loading options" apply when loading modules
+- The "interactive options" apply when evaluating expressions and commands
+    typed at the GHCi prompt.
+
+The loading options are mostly created in ghc/Main.hs:main' from the command
+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options
+are copied to the interactive options.
+
+These interactive options (but not the loading options!) are supplemented
+unconditionally by setting ExtendedDefaultRules ON and
+MonomorphismRestriction OFF. The unconditional setting of these options
+eventually overwrite settings already specified at the command line.
+
+Therefore instead of unconditionally setting ExtendedDefaultRules and
+NoMonomorphismRestriction for the interactive options, we use the function
+'xopt_set_unlessExplSpec' to first check whether the extension has already
+specified at the command line.
+
+The ghci config file has not yet been processed.
+-}
+
+resetLastErrorLocations :: GhciMonad m => m ()
+resetLastErrorLocations = do
+    st <- getGHCiState
+    liftIO $ writeIORef (lastErrorLocations st) []
+
+ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction
+ghciLogAction old_log_action lastErrLocations
+              dflags flag severity srcSpan style msg = do
+    old_log_action dflags flag severity srcSpan style msg
+    case severity of
+        SevError -> case srcSpan of
+            RealSrcSpan rsp -> modifyIORef lastErrLocations
+                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
+            _ -> return ()
+        _ -> return ()
+
+withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
+withGhcAppData right left = do
+    either_dir <- tryIO (getAppUserDataDirectory "ghc")
+    case either_dir of
+        Right dir ->
+            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
+               right dir
+        _ -> left
+
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
+runGHCi paths maybe_exprs = do
+  dflags <- getDynFlags
+  let
+   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
+
+   app_user_dir = liftIO $ withGhcAppData
+                    (\dir -> return (Just (dir </> "ghci.conf")))
+                    (return Nothing)
+
+   home_dir = do
+    either_dir <- liftIO $ tryIO (getEnv "HOME")
+    case either_dir of
+      Right home -> return (Just (home </> ".ghci"))
+      _ -> return Nothing
+
+   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
+   canonicalizePath' fp = liftM Just (canonicalizePath fp)
+                `catchIO` \_ -> return Nothing
+
+   sourceConfigFile :: FilePath -> GHCi ()
+   sourceConfigFile file = do
+     exists <- liftIO $ doesFileExist file
+     when exists $ do
+       either_hdl <- liftIO $ tryIO (openFile file ReadMode)
+       case either_hdl of
+         Left _e   -> return ()
+         -- NOTE: this assumes that runInputT won't affect the terminal;
+         -- can we assume this will always be the case?
+         -- This would be a good place for runFileInputT.
+         Right hdl ->
+             do runInputTWithPrefs defaultPrefs defaultSettings $
+                          runCommands $ fileLoop hdl
+                liftIO (hClose hdl `catchIO` \_ -> return ())
+                -- Don't print a message if this is really ghc -e (#11478).
+                -- Also, let the user silence the message with -v0
+                -- (the default verbosity in GHCi is 1).
+                when (isNothing maybe_exprs && verbosity dflags > 0) $
+                  liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
+
+  --
+
+  setGHCContextFromGHCiState
+
+  processedCfgs <- if ignore_dot_ghci
+    then pure []
+    else do
+      userCfgs <- do
+        paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]
+        checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths
+        liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths
+
+      localCfg <- do
+        let path = ".ghci"
+        ok <- liftIO $ checkFileAndDirPerms path
+        if ok then liftIO $ canonicalizePath' path else pure Nothing
+
+      mapM_ sourceConfigFile userCfgs
+        -- Process the global and user .ghci
+        -- (but not $CWD/.ghci or CLI args, yet)
+
+      behaviour <- localConfig <$> getGHCiState
+
+      processedLocalCfg <- case localCfg of
+        Just path | path `notElem` userCfgs ->
+          -- don't read .ghci twice if CWD is $HOME
+          case behaviour of
+            SourceLocalConfig -> localCfg <$ sourceConfigFile path
+            IgnoreLocalConfig -> pure Nothing
+        _ -> pure Nothing
+
+      pure $ maybe id (:) processedLocalCfg userCfgs
+
+  let arg_cfgs = reverse $ ghciScripts dflags
+    -- -ghci-script are collected in reverse order
+    -- We don't require that a script explicitly added by -ghci-script
+    -- is owned by the current user. (#6017)
+
+  mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs
+    -- Dedup, and remove any configs we already processed.
+    -- Importantly, if $PWD/.ghci was ignored due to configuration,
+    -- explicitly specifying it does cause it to be processed.
+
+  -- Perform a :load for files given on the GHCi command line
+  -- When in -e mode, if the load fails then we want to stop
+  -- immediately rather than going on to evaluate the expression.
+  when (not (null paths)) $ do
+     ok <- ghciHandle (\e -> do showException e; return Failed) $
+                -- TODO: this is a hack.
+                runInputTWithPrefs defaultPrefs defaultSettings $
+                    loadModule paths
+     when (isJust maybe_exprs && failed ok) $
+        liftIO (exitWith (ExitFailure 1))
+
+  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
+
+  -- if verbosity is greater than 0, or we are connected to a
+  -- terminal, display the prompt in the interactive loop.
+  is_tty <- liftIO (hIsTerminalDevice stdin)
+  let show_prompt = verbosity dflags > 0 || is_tty
+
+  -- reset line number
+  modifyGHCiState $ \st -> st{line_number=0}
+
+  case maybe_exprs of
+        Nothing ->
+          do
+            -- enter the interactive loop
+            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
+        Just exprs -> do
+            -- just evaluate the expression we were given
+            enqueueCommands exprs
+            let hdle e = do st <- getGHCiState
+                            -- flush the interpreter's stdout/stderr on exit (#3890)
+                            flushInterpBuffers
+                            -- Jump through some hoops to get the
+                            -- current progname in the exception text:
+                            -- <progname>: <exception>
+                            liftIO $ withProgName (progname st)
+                                   $ topHandler e
+                                   -- this used to be topHandlerFastExit, see #2228
+            runInputTWithPrefs defaultPrefs defaultSettings $ do
+                -- make `ghc -e` exit nonzero on invalid input, see #7962
+                _ <- runCommands' hdle
+                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
+                     (return Nothing)
+                return ()
+
+  -- and finally, exit
+  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+
+runGHCiInput :: InputT GHCi a -> GHCi a
+runGHCiInput f = do
+    dflags <- getDynFlags
+    let ghciHistory = gopt Opt_GhciHistory dflags
+    let localGhciHistory = gopt Opt_LocalGhciHistory dflags
+    currentDirectory <- liftIO $ getCurrentDirectory
+
+    histFile <- case (ghciHistory, localGhciHistory) of
+      (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
+      (True, _) -> liftIO $ withGhcAppData
+        (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)
+      _ -> return Nothing
+
+    runInputT
+        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
+        f
+
+-- | How to get the next input line from the user
+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
+nextInputLine show_prompt is_tty
+  | is_tty = do
+    prmpt <- if show_prompt then lift mkPrompt else return ""
+    r <- getInputLine prmpt
+    incrementLineNo
+    return r
+  | otherwise = do
+    when show_prompt $ lift mkPrompt >>= liftIO . putStr
+    fileLoop stdin
+
+-- NOTE: We only read .ghci files if they are owned by the current user,
+-- and aren't world writable (files owned by root are ok, see #9324).
+-- Otherwise, we could be accidentally running code planted by
+-- a malicious third party.
+
+-- Furthermore, We only read ./.ghci if . is owned by the current user
+-- and isn't writable by anyone else.  I think this is sufficient: we
+-- don't need to check .. and ../.. etc. because "."  always refers to
+-- the same directory while a process is running.
+
+checkFileAndDirPerms :: FilePath -> IO Bool
+checkFileAndDirPerms file = do
+  file_ok <- checkPerms file
+  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will
+  -- print some confusing and useless warnings in some cases (e.g. in
+  -- travis). Note that we can't add a test for this, as all ghci tests should
+  -- run with -ignore-dot-ghci, which means we never get here.
+  if file_ok then checkPerms (getDirectory file) else return False
+  where
+  getDirectory f = case takeDirectory f of
+    "" -> "."
+    d -> d
+
+checkPerms :: FilePath -> IO Bool
+#if defined(mingw32_HOST_OS)
+checkPerms _ = return True
+#else
+checkPerms file =
+  handleIO (\_ -> return False) $ do
+    st <- getFileStatus file
+    me <- getRealUserID
+    let mode = System.Posix.fileMode st
+        ok = (fileOwner st == me || fileOwner st == 0) &&
+             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
+             otherWriteMode /= mode `intersectFileModes` otherWriteMode
+    unless ok $
+      -- #8248: Improving warning to include a possible fix.
+      putStrLn $ "*** WARNING: " ++ file ++
+                 " is writable by someone else, IGNORING!" ++
+                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
+    return ok
+#endif
+
+incrementLineNo :: GhciMonad m => m ()
+incrementLineNo = modifyGHCiState incLineNo
+  where
+    incLineNo st = st { line_number = line_number st + 1 }
+
+fileLoop :: GhciMonad m => Handle -> m (Maybe String)
+fileLoop hdl = do
+   l <- liftIO $ tryIO $ hGetLine hdl
+   case l of
+        Left e | isEOFError e              -> return Nothing
+               | -- as we share stdin with the program, the program
+                 -- might have already closed it, so we might get a
+                 -- handle-closed exception. We therefore catch that
+                 -- too.
+                 isIllegalOperation e      -> return Nothing
+               | InvalidArgument <- etype  -> return Nothing
+               | otherwise                 -> liftIO $ ioError e
+                where etype = ioeGetErrorType e
+                -- treat InvalidArgument in the same way as EOF:
+                -- this can happen if the user closed stdin, or
+                -- perhaps did getContents which closes stdin at
+                -- EOF.
+        Right l' -> do
+           incrementLineNo
+           return (Just l')
+
+formatCurrentTime :: String -> IO String
+formatCurrentTime format =
+  getZonedTime >>= return . (formatTime defaultTimeLocale format)
+
+getUserName :: IO String
+getUserName = do
+#if defined(mingw32_HOST_OS)
+  getEnv "USERNAME"
+    `catchIO` \e -> do
+      putStrLn $ show e
+      return ""
+#else
+  getLoginName
+#endif
+
+getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
+getInfoForPrompt = do
+  st <- getGHCiState
+  imports <- GHC.getContext
+  resumes <- GHC.getResumeContext
+
+  context_bit <-
+        case resumes of
+            [] -> return empty
+            r:_ -> do
+                let ix = GHC.resumeHistoryIx r
+                if ix == 0
+                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)
+                   else do
+                        let hist = GHC.resumeHistory r !! (ix-1)
+                        pan <- GHC.getHistorySpan hist
+                        return (brackets (ppr (negate ix) <> char ':'
+                                          <+> ppr pan) <> space)
+
+  let
+        dots | _:rs <- resumes, not (null rs) = text "... "
+             | otherwise = empty
+
+        rev_imports = reverse imports -- rightmost are the most recent
+
+        myIdeclName d | Just m <- ideclAs d = unLoc m
+                      | otherwise           = unLoc (ideclName d)
+
+        modules_names =
+             ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
+             [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
+        line = 1 + line_number st
+
+  return (dots <> context_bit, modules_names, line)
+
+parseCallEscape :: String -> (String, String)
+parseCallEscape s
+  | not (all isSpace beforeOpen) = ("", "")
+  | null sinceOpen               = ("", "")
+  | null sinceClosed             = ("", "")
+  | null cmd                     = ("", "")
+  | otherwise                    = (cmd, tail sinceClosed)
+  where
+    (beforeOpen, sinceOpen) = span (/='(') s
+    (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
+
+checkPromptStringForErrors :: String -> Maybe String
+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
+  case parseCallEscape xs of
+    ("", "") -> Just ("Incorrect %call syntax. " ++
+                      "Should be %call(a command and arguments).")
+    (_, afterClosed) -> checkPromptStringForErrors afterClosed
+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
+checkPromptStringForErrors "" = Nothing
+
+generatePromptFunctionFromString :: String -> PromptFunction
+generatePromptFunctionFromString promptS modules_names line =
+        processString promptS
+  where
+        processString :: String -> GHCi SDoc
+        processString ('%':'s':xs) =
+            liftM2 (<>) (return modules_list) (processString xs)
+            where
+              modules_list = hsep $ map text modules_names
+        processString ('%':'l':xs) =
+            liftM2 (<>) (return $ ppr line) (processString xs)
+        processString ('%':'d':xs) =
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%a %b %d"
+        processString ('%':'t':xs) =
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"
+        processString ('%':'T':xs) = do
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"
+        processString ('%':'@':xs) = do
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%I:%M %P"
+        processString ('%':'A':xs) = do
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%H:%M"
+        processString ('%':'u':xs) =
+            liftM2 (<>) (liftM text user_name) (processString xs)
+            where
+              user_name = liftIO $ getUserName
+        processString ('%':'w':xs) =
+            liftM2 (<>) (liftM text current_directory) (processString xs)
+            where
+              current_directory = liftIO $ getCurrentDirectory
+        processString ('%':'o':xs) =
+            liftM ((text os) <>) (processString xs)
+        processString ('%':'a':xs) =
+            liftM ((text arch) <>) (processString xs)
+        processString ('%':'N':xs) =
+            liftM ((text compilerName) <>) (processString xs)
+        processString ('%':'V':xs) =
+            liftM ((text $ showVersion compilerVersion) <>) (processString xs)
+        processString ('%':'c':'a':'l':'l':xs) = do
+            respond <- liftIO $ do
+                (code, out, err) <-
+                    readProcessWithExitCode
+                    (head list_words) (tail list_words) ""
+                    `catchIO` \e -> return (ExitFailure 1, "", show e)
+                case code of
+                    ExitSuccess -> return out
+                    _ -> do
+                        hPutStrLn stderr err
+                        return ""
+            liftM ((text respond) <>) (processString afterClosed)
+            where
+              (cmd, afterClosed) = parseCallEscape xs
+              list_words = words cmd
+        processString ('%':'%':xs) =
+            liftM ((char '%') <>) (processString xs)
+        processString (x:xs) =
+            liftM (char x <>) (processString xs)
+        processString "" =
+            return empty
+
+mkPrompt :: GHCi String
+mkPrompt = do
+  st <- getGHCiState
+  dflags <- getDynFlags
+  (context, modules_names, line) <- getInfoForPrompt
+
+  prompt_string <- (prompt st) modules_names line
+  let prompt_doc = context <> prompt_string
+
+  return (showSDoc dflags prompt_doc)
+
+queryQueue :: GhciMonad m => m (Maybe String)
+queryQueue = do
+  st <- getGHCiState
+  case cmdqueue st of
+    []   -> return Nothing
+    c:cs -> do setGHCiState st{ cmdqueue = cs }
+               return (Just c)
+
+-- Reconfigurable pretty-printing Ticket #5461
+installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()
+installInteractivePrint Nothing _  = return ()
+installInteractivePrint (Just ipFun) exprmode = do
+  ok <- trySuccess $ do
+                names <- GHC.parseName ipFun
+                let name = case names of
+                             name':_ -> name'
+                             [] -> panic "installInteractivePrint"
+                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
+                                      in he{hsc_IC = new_ic})
+                return Succeeded
+
+  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
+
+-- | The main read-eval-print loop
+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
+
+runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
+             -> Maybe (GHCi ()) -- ^ Source error handler
+             -> InputT GHCi (Maybe String)
+             -> InputT GHCi (Maybe Bool)
+         -- We want to return () here, but have to return (Maybe Bool)
+         -- because gmask is not polymorphic enough: we want to use
+         -- unmask at two different types.
+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do
+    b <- ghandle (\e -> case fromException e of
+                          Just UserInterrupt -> return $ Just False
+                          _ -> case fromException e of
+                                 Just ghce ->
+                                   do liftIO (print (ghce :: GhcException))
+                                      return Nothing
+                                 _other ->
+                                   liftIO (Exception.throwIO e))
+            (unmask $ runOneCommand eh gCmd)
+    case b of
+      Nothing -> return Nothing
+      Just success -> do
+        unless success $ maybe (return ()) lift sourceErrorHandler
+        unmask $ runCommands' eh sourceErrorHandler gCmd
+
+-- | Evaluate a single line of user input (either :<command> or Haskell code).
+-- A result of Nothing means there was no more input to process.
+-- Otherwise the result is Just b where b is True if the command succeeded;
+-- this is relevant only to ghc -e, which will exit with status 1
+-- if the command was unsuccessful. GHCi will continue in either case.
+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
+            -> InputT GHCi (Maybe Bool)
+runOneCommand eh gCmd = do
+  -- run a previously queued command if there is one, otherwise get new
+  -- input from user
+  mb_cmd0 <- noSpace (lift queryQueue)
+  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
+  case mb_cmd1 of
+    Nothing -> return Nothing
+    Just c  -> do
+      st <- getGHCiState
+      ghciHandle (\e -> lift $ eh e >>= return . Just) $
+        handleSourceError printErrorAndFail $
+          cmd_wrapper st $ doCommand c
+               -- source error's are handled by runStmt
+               -- is the handler necessary here?
+  where
+    printErrorAndFail err = do
+        GHC.printException err
+        return $ Just False     -- Exit ghc -e, but not GHCi
+
+    noSpace q = q >>= maybe (return Nothing)
+                            (\c -> case removeSpaces c of
+                                     ""   -> noSpace q
+                                     ":{" -> multiLineCmd q
+                                     _    -> return (Just c) )
+    multiLineCmd q = do
+      st <- getGHCiState
+      let p = prompt st
+      setGHCiState st{ prompt = prompt_cont st }
+      mb_cmd <- collectCommand q "" `GHC.gfinally`
+                modifyGHCiState (\st' -> st' { prompt = p })
+      return mb_cmd
+    -- we can't use removeSpaces for the sublines here, so
+    -- multiline commands are somewhat more brittle against
+    -- fileformat errors (such as \r in dos input on unix),
+    -- we get rid of any extra spaces for the ":}" test;
+    -- we also avoid silent failure if ":}" is not found;
+    -- and since there is no (?) valid occurrence of \r (as
+    -- opposed to its String representation, "\r") inside a
+    -- ghci command, we replace any such with ' ' (argh:-(
+    collectCommand q c = q >>=
+      maybe (liftIO (ioError collectError))
+            (\l->if removeSpaces l == ":}"
+                 then return (Just c)
+                 else collectCommand q (c ++ "\n" ++ map normSpace l))
+      where normSpace '\r' = ' '
+            normSpace   x  = x
+    -- SDM (2007-11-07): is userError the one to use here?
+    collectError = userError "unterminated multiline command :{ .. :}"
+
+    -- | Handle a line of input
+    doCommand :: String -> InputT GHCi CommandResult
+
+    -- command
+    doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do
+      (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd
+      let processResult True = Nothing
+          processResult False = Just True
+      return $ CommandComplete stmt' (processResult <$> result) stats
+
+    -- haskell
+    doCommand stmt = do
+      -- if 'stmt' was entered via ':{' it will contain '\n's
+      let stmt_nl_cnt = length [ () | '\n' <- stmt ]
+      ml <- lift $ isOptionSet Multiline
+      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
+        then do
+          fst_line_num <- line_number <$> getGHCiState
+          mb_stmt <- checkInputForLayout stmt gCmd
+          case mb_stmt of
+            Nothing -> return CommandIncomplete
+            Just ml_stmt -> do
+              -- temporarily compensate line-number for multi-line input
+              (stats, result) <- runAndPrintStats runAllocs $ lift $
+                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
+              return $
+                CommandComplete ml_stmt (Just . runSuccess <$> result) stats
+        else do -- single line input and :{ - multiline input
+          last_line_num <- line_number <$> getGHCiState
+          -- reconstruct first line num from last line num and stmt
+          let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
+                           | otherwise = last_line_num -- single line input
+              stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
+              stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
+          -- temporarily compensate line-number for multi-line input
+          (stats, result) <- runAndPrintStats runAllocs $ lift $
+            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
+          return $ CommandComplete stmt' (Just . runSuccess <$> result) stats
+
+    -- runStmt wrapper for temporarily overridden line-number
+    runStmtWithLineNum :: Int -> String -> SingleStep
+                       -> GHCi (Maybe GHC.ExecResult)
+    runStmtWithLineNum lnum stmt step = do
+        st0 <- getGHCiState
+        setGHCiState st0 { line_number = lnum }
+        result <- runStmt stmt step
+        -- restore original line_number
+        getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
+        return result
+
+    -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
+    dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
+                            , all isSpace l0 = dropLeadingWhiteLines r
+                            | otherwise = s
+
+
+-- #4316
+-- lex the input.  If there is an unclosed layout context, request input
+checkInputForLayout
+  :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)
+checkInputForLayout stmt getStmt = do
+   dflags' <- getDynFlags
+   let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule
+   st0 <- getGHCiState
+   let buf'   =  stringToStringBuffer stmt
+       loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
+       pstate = Lexer.mkPState dflags buf' loc
+   case Lexer.unP goToEnd pstate of
+     (Lexer.POk _ False) -> return $ Just stmt
+     _other              -> do
+       st1 <- getGHCiState
+       let p = prompt st1
+       setGHCiState st1{ prompt = prompt_cont st1 }
+       mb_stmt <- ghciHandle (\ex -> case fromException ex of
+                            Just UserInterrupt -> return Nothing
+                            _ -> case fromException ex of
+                                 Just ghce ->
+                                   do liftIO (print (ghce :: GhcException))
+                                      return Nothing
+                                 _other -> liftIO (Exception.throwIO ex))
+                     getStmt
+       modifyGHCiState (\st' -> st' { prompt = p })
+       -- the recursive call does not recycle parser state
+       -- as we use a new string buffer
+       case mb_stmt of
+         Nothing  -> return Nothing
+         Just str -> if str == ""
+           then return $ Just stmt
+           else do
+             checkInputForLayout (stmt++"\n"++str) getStmt
+     where goToEnd = do
+             eof <- Lexer.nextIsEOF
+             if eof
+               then Lexer.activeContext
+               else Lexer.lexer False return >> goToEnd
+
+enqueueCommands :: GhciMonad m => [String] -> m ()
+enqueueCommands cmds = do
+  -- make sure we force any exceptions in the commands while we're
+  -- still inside the exception handler, otherwise bad things will
+  -- happen (see #10501)
+  cmds `deepseq` return ()
+  modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }
+
+-- | Entry point to execute some haskell code from user.
+-- The return value True indicates success, as in `runOneCommand`.
+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
+runStmt input step = do
+  dflags <- GHC.getInteractiveDynFlags
+  -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
+  -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
+  -- declarations and statements are not affected.
+  -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs
+  st <- getGHCiState
+  let source = progname st
+  let line = line_number st
+
+  if | GHC.isStmt dflags input -> do
+         hsc_env <- GHC.getSession
+         mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))
+         case mb_stmt of
+           Nothing ->
+             -- empty statement / comment
+             return (Just exec_complete)
+           Just stmt ->
+             run_stmt stmt
+
+     | GHC.isImport dflags input -> run_import
+
+     -- Every import declaration should be handled by `run_import`. As GHCi
+     -- in general only accepts one command at a time, we simply throw an
+     -- exception when the input contains multiple commands of which at least
+     -- one is an import command (see #10663).
+     | GHC.hasImport dflags input -> throwGhcException
+       (CmdLineError "error: expecting a single import declaration")
+
+     -- Otherwise assume a declaration (or a list of declarations)
+     -- Note: `GHC.isDecl` returns False on input like
+     -- `data Infix a b = a :@: b; infixl 4 :@:`
+     -- and should therefore not be used here.
+     | otherwise -> do
+         hsc_env <- GHC.getSession
+         decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)
+         run_decls decls
+  where
+    exec_complete = GHC.ExecComplete (Right []) 0
+
+    run_import = do
+      addImportToContext input
+      return (Just exec_complete)
+
+    run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)
+    run_stmt stmt = do
+           m_result <- GhciMonad.runStmt stmt input step
+           case m_result of
+               Nothing     -> return Nothing
+               Just result -> Just <$> afterRunStmt (const True) result
+
+    -- `x = y` (a declaration) should be treated as `let x = y` (a statement).
+    -- The reason is because GHCi wasn't designed to support `x = y`, but then
+    -- b98ff3 (#7253) added support for it, except it did not do a good job and
+    -- caused problems like:
+    --
+    --  - not adding the binders defined this way in the necessary places caused
+    --    `x = y` to not work in some cases (#12091).
+    --  - some GHCi command crashed after `x = y` (#15721)
+    --  - warning generation did not work for `x = y` (#11606)
+    --  - because `x = y` is a declaration (instead of a statement) differences
+    --    in generated code caused confusion (#16089)
+    --
+    -- Instead of dealing with all these problems individually here we fix this
+    -- mess by just treating `x = y` as `let x = y`.
+    run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)
+    -- Only turn `FunBind` and `VarBind` into statements, other bindings
+    -- (e.g. `PatBind`) need to stay as decls.
+    run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)
+    run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)
+    -- Note that any `x = y` declarations below will be run as declarations
+    -- instead of statements (e.g. `...; x = y; ...`)
+    run_decls decls = do
+      -- In the new IO library, read handles buffer data even if the Handle
+      -- is set to NoBuffering.  This causes problems for GHCi where there
+      -- are really two stdin Handles.  So we flush any bufferred data in
+      -- GHCi's stdin Handle here (only relevant if stdin is attached to
+      -- a file, otherwise the read buffer can't be flushed).
+      _ <- liftIO $ tryIO $ hFlushAll stdin
+      m_result <- GhciMonad.runDecls' decls
+      forM m_result $ \result ->
+        afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)
+
+    mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
+    mk_stmt loc bind =
+      let l = L loc
+      in l (LetStmt noExt (l (HsValBinds noExt (ValBinds noExt (unitBag (l bind)) []))))
+
+-- | Clean up the GHCi environment after a statement has run
+afterRunStmt :: GhciMonad m
+             => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
+afterRunStmt step_here run_result = do
+  resumes <- GHC.getResumeContext
+  case run_result of
+     GHC.ExecComplete{..} ->
+       case execResult of
+          Left ex -> liftIO $ Exception.throwIO ex
+          Right names -> do
+            show_types <- isOptionSet ShowType
+            when show_types $ printTypeOfNames names
+     GHC.ExecBreak names mb_info
+         | isNothing  mb_info ||
+           step_here (GHC.resumeSpan $ head resumes) -> do
+               mb_id_loc <- toBreakIdAndLocation mb_info
+               let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+               if (null bCmd)
+                 then printStoppedAtBreakInfo (head resumes) names
+                 else enqueueCommands [bCmd]
+               -- run the command set with ":set stop <cmd>"
+               st <- getGHCiState
+               enqueueCommands [stop st]
+               return ()
+         | otherwise -> resume step_here GHC.SingleStep >>=
+                        afterRunStmt step_here >> return ()
+
+  flushInterpBuffers
+  withSignalHandlers $ do
+     b <- isOptionSet RevertCAFs
+     when b revertCAFs
+
+  return run_result
+
+runSuccess :: Maybe GHC.ExecResult -> Bool
+runSuccess run_result
+  | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True
+  | otherwise = False
+
+runAllocs :: Maybe GHC.ExecResult -> Maybe Integer
+runAllocs m = do
+  res <- m
+  case res of
+    GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
+    _ -> Nothing
+
+toBreakIdAndLocation :: GhciMonad m
+                     => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))
+toBreakIdAndLocation Nothing = return Nothing
+toBreakIdAndLocation (Just inf) = do
+  let md = GHC.breakInfo_module inf
+      nm = GHC.breakInfo_number inf
+  st <- getGHCiState
+  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
+                                  breakModule loc == md,
+                                  breakTick loc == nm ]
+
+printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
+printStoppedAtBreakInfo res names = do
+  printForUser $ pprStopped res
+  --  printTypeOfNames session names
+  let namesSorted = sortBy compareNames names
+  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
+  docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
+  printForUserPartWay $ vcat docs
+
+printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()
+printTypeOfNames names
+ = mapM_ (printTypeOfName ) $ sortBy compareNames names
+
+compareNames :: Name -> Name -> Ordering
+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
+    where compareWith n = (getOccString n, getSrcSpan n)
+
+printTypeOfName :: GHC.GhcMonad m => Name -> m ()
+printTypeOfName n
+   = do maybe_tything <- GHC.lookupName n
+        case maybe_tything of
+            Nothing    -> return ()
+            Just thing -> printTyThing thing
+
+
+data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
+
+-- | Entry point for execution a ':<command>' input from user
+specialCommand :: String -> InputT GHCi Bool
+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
+specialCommand str = do
+  let (cmd,rest) = break isSpace str
+  maybe_cmd <- lookupCommand cmd
+  htxt <- short_help <$> getGHCiState
+  case maybe_cmd of
+    GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)
+    BadCommand ->
+      do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
+                           ++ htxt)
+         return False
+    NoLastCommand ->
+      do liftIO $ hPutStr stdout ("there is no last command to perform\n"
+                           ++ htxt)
+         return False
+
+shellEscape :: MonadIO m => String -> m Bool
+shellEscape str = liftIO (system str >> return False)
+
+lookupCommand :: GhciMonad m => String -> m (MaybeCommand)
+lookupCommand "" = do
+  st <- getGHCiState
+  case last_command st of
+      Just c -> return $ GotCommand c
+      Nothing -> return NoLastCommand
+lookupCommand str = do
+  mc <- lookupCommand' str
+  modifyGHCiState (\st -> st { last_command = mc })
+  return $ case mc of
+           Just c -> GotCommand c
+           Nothing -> BadCommand
+
+lookupCommand' :: GhciMonad m => String -> m (Maybe Command)
+lookupCommand' ":" = return Nothing
+lookupCommand' str' = do
+  macros    <- ghci_macros <$> getGHCiState
+  ghci_cmds <- ghci_commands <$> getGHCiState
+
+  let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds
+
+  let (str, xcmds) = case str' of
+          ':' : rest -> (rest, [])     -- "::" selects a builtin command
+          _          -> (str', macros) -- otherwise include macros in lookup
+
+      lookupExact  s = find $ (s ==)           . cmdName
+      lookupPrefix s = find $ (s `isPrefixOf`) . cmdName
+
+      -- hidden commands can only be matched exact
+      builtinPfxMatch = lookupPrefix str ghci_cmds_nohide
+
+  -- first, look for exact match (while preferring macros); then, look
+  -- for first prefix match (preferring builtins), *unless* a macro
+  -- overrides the builtin; see #8305 for motivation
+  return $ lookupExact str xcmds <|>
+           lookupExact str ghci_cmds <|>
+           (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>
+           builtinPfxMatch <|>
+           lookupPrefix str xcmds
+
+getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)
+getCurrentBreakSpan = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+        let ix = GHC.resumeHistoryIx r
+        if ix == 0
+           then return (Just (GHC.resumeSpan r))
+           else do
+                let hist = GHC.resumeHistory r !! (ix-1)
+                pan <- GHC.getHistorySpan hist
+                return (Just pan)
+
+getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])
+getCallStackAtCurrentBreakpoint = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+       hsc_env <- GHC.getSession
+       Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))
+
+getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
+getCurrentBreakModule = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+        let ix = GHC.resumeHistoryIx r
+        if ix == 0
+           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
+           else do
+                let hist = GHC.resumeHistory r !! (ix-1)
+                return $ Just $ GHC.getHistoryModule  hist
+
+-----------------------------------------------------------------------------
+--
+-- Commands
+--
+-----------------------------------------------------------------------------
+
+noArgs :: MonadIO m => m () -> String -> m ()
+noArgs m "" = m
+noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"
+
+withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()
+withSandboxOnly cmd this = do
+   dflags <- getDynFlags
+   if not (gopt Opt_GhciSandbox dflags)
+      then printForUser (text cmd <+>
+                         ptext (sLit "is not supported with -fno-ghci-sandbox"))
+      else this
+
+-----------------------------------------------------------------------------
+-- :help
+
+help :: GhciMonad m => String -> m ()
+help _ = do
+    txt <- long_help `fmap` getGHCiState
+    liftIO $ putStr txt
+
+-----------------------------------------------------------------------------
+-- :info
+
+info :: GHC.GhcMonad m => Bool -> String -> m ()
+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info allInfo s  = handleSourceError GHC.printException $ do
+    unqual <- GHC.getPrintUnqual
+    dflags <- getDynFlags
+    sdocs  <- mapM (infoThing allInfo) (words s)
+    mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs
+
+infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
+infoThing allInfo str = do
+    names     <- GHC.parseName str
+    mb_stuffs <- mapM (GHC.getInfo allInfo) names
+    let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
+                                     (catMaybes mb_stuffs)
+    return $ vcat (intersperse (text "") $ map pprInfo filtered)
+
+  -- Filter out names whose parent is also there Good
+  -- example is '[]', which is both a type and data
+  -- constructor in the same type
+filterOutChildren :: (a -> TyThing) -> [a] -> [a]
+filterOutChildren get_thing xs
+  = filterOut has_parent xs
+  where
+    all_names = mkNameSet (map (getName . get_thing) xs)
+    has_parent x = case tyThingParent_maybe (get_thing x) of
+                     Just p  -> getName p `elemNameSet` all_names
+                     Nothing -> False
+
+pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
+pprInfo (thing, fixity, cls_insts, fam_insts, docs)
+  =  docs
+  $$ pprTyThingInContextLoc thing
+  $$ show_fixity
+  $$ vcat (map GHC.pprInstance cls_insts)
+  $$ vcat (map GHC.pprFamInst  fam_insts)
+  where
+    show_fixity
+        | fixity == GHC.defaultFixity = empty
+        | otherwise                   = ppr fixity <+> pprInfixName (GHC.getName thing)
+
+-----------------------------------------------------------------------------
+-- :main
+
+runMain :: GhciMonad m => String -> m ()
+runMain s = case toArgs s of
+            Left err   -> liftIO (hPutStrLn stderr err)
+            Right args ->
+                do dflags <- getDynFlags
+                   let main = fromMaybe "main" (mainFunIs dflags)
+                   -- Wrap the main function in 'void' to discard its value instead
+                   -- of printing it (#9086). See Haskell 2010 report Chapter 5.
+                   doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"
+
+-----------------------------------------------------------------------------
+-- :run
+
+runRun :: GhciMonad m => String -> m ()
+runRun s = case toCmdArgs s of
+           Left err          -> liftIO (hPutStrLn stderr err)
+           Right (cmd, args) -> doWithArgs args cmd
+
+doWithArgs :: GhciMonad m => [String] -> String -> m ()
+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
+                                       show args ++ " (" ++ cmd ++ ")"]
+
+-----------------------------------------------------------------------------
+-- :cd
+
+changeDirectory :: GhciMonad m => String -> m ()
+changeDirectory "" = do
+  -- :cd on its own changes to the user's home directory
+  either_dir <- liftIO $ tryIO getHomeDirectory
+  case either_dir of
+     Left _e -> return ()
+     Right dir -> changeDirectory dir
+changeDirectory dir = do
+  graph <- GHC.getModuleGraph
+  when (not (null $ GHC.mgModSummaries graph)) $
+        liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
+  GHC.setTargets []
+  _ <- GHC.load LoadAllTargets
+  setContextAfterLoad False []
+  GHC.workingDirectoryChanged
+  dir' <- expandPath dir
+  liftIO $ setCurrentDirectory dir'
+  dflags <- getDynFlags
+  -- With -fexternal-interpreter, we have to change the directory of the subprocess too.
+  -- (this gives consistent behaviour with and without -fexternal-interpreter)
+  when (gopt Opt_ExternalInterpreter dflags) $ do
+    hsc_env <- GHC.getSession
+    fhv <- compileGHCiExpr $
+      "System.Directory.setCurrentDirectory " ++ show dir'
+    liftIO $ evalIO hsc_env fhv
+
+trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
+trySuccess act =
+    handleSourceError (\e -> do GHC.printException e
+                                return Failed) $ do
+      act
+
+-----------------------------------------------------------------------------
+-- :edit
+
+editFile :: GhciMonad m => String -> m ()
+editFile str =
+  do file <- if null str then chooseEditFile else expandPath str
+     st <- getGHCiState
+     errs <- liftIO $ readIORef $ lastErrorLocations st
+     let cmd = editor st
+     when (null cmd)
+       $ throwGhcException (CmdLineError "editor not set, use :set editor")
+     lineOpt <- liftIO $ do
+         let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)
+              `catchIO` (\_ -> return False)
+
+         curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs
+         return $ case curFileErrs of
+             (_, line):_ -> " +" ++ show line
+             _ -> ""
+     let cmdArgs = ' ':(file ++ lineOpt)
+     code <- liftIO $ system (cmd ++ cmdArgs)
+
+     when (code == ExitSuccess)
+       $ reloadModule ""
+
+-- The user didn't specify a file so we pick one for them.
+-- Our strategy is to pick the first module that failed to load,
+-- or otherwise the first target.
+--
+-- XXX: Can we figure out what happened if the depndecy analysis fails
+--      (e.g., because the porgrammeer mistyped the name of a module)?
+-- XXX: Can we figure out the location of an error to pass to the editor?
+-- XXX: if we could figure out the list of errors that occured during the
+-- last load/reaload, then we could start the editor focused on the first
+-- of those.
+chooseEditFile :: GHC.GhcMonad m => m String
+chooseEditFile =
+  do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
+
+     graph <- GHC.getModuleGraph
+     failed_graph <-
+       GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)
+     let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
+         pick xs  = case xs of
+                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)
+                      _     -> Nothing
+
+     case pick (order failed_graph) of
+       Just file -> return file
+       Nothing   ->
+         do targets <- GHC.getTargets
+            case msum (map fromTarget targets) of
+              Just file -> return file
+              Nothing   -> throwGhcException (CmdLineError "No files to edit.")
+
+  where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
+        fromTarget _ = Nothing -- when would we get a module target?
+
+
+-----------------------------------------------------------------------------
+-- :def
+
+defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
+defineMacro _ (':':_) = liftIO $ putStrLn
+                          "macro name cannot start with a colon"
+defineMacro _ ('!':_) = liftIO $ putStrLn
+                          "macro name cannot start with an exclamation mark"
+                          -- little code duplication allows to grep error msg
+defineMacro overwrite s = do
+  let (macro_name, definition) = break isSpace s
+  macros <- ghci_macros <$> getGHCiState
+  let defined = map cmdName macros
+  if null macro_name
+        then if null defined
+                then liftIO $ putStrLn "no macros defined"
+                else liftIO $ putStr ("the following macros are defined:\n" ++
+                                      unlines defined)
+  else do
+    isCommand <- isJust <$> lookupCommand' macro_name
+    let check_newname
+          | macro_name `elem` defined = throwGhcException (CmdLineError
+            ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))
+          | isCommand = throwGhcException (CmdLineError
+            ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))
+          | otherwise = return ()
+        hint = " Use ':def!' to overwrite."
+
+    unless overwrite check_newname
+    -- compile the expression
+    handleSourceError GHC.printException $ do
+      step <- getGhciStepIO
+      expr <- GHC.parseExpr definition
+      -- > ghciStepIO . definition :: String -> IO String
+      let stringTy = nlHsTyVar stringTy_RDR
+          ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+          body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
+                                     `mkHsApp` (nlHsPar expr)
+          tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
+          new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig
+      hv <- GHC.compileParsedExprRemote new_expr
+
+      let newCmd = Command { cmdName = macro_name
+                           , cmdAction = lift . runMacro hv
+                           , cmdHidden = False
+                           , cmdCompletionFunc = noCompletion
+                           }
+
+      -- later defined macros have precedence
+      modifyGHCiState $ \s ->
+        let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+        in s { ghci_macros = newCmd : filtered }
+
+runMacro
+  :: GhciMonad m
+  => GHC.ForeignHValue  -- String -> IO String
+  -> String
+  -> m Bool
+runMacro fun s = do
+  hsc_env <- GHC.getSession
+  str <- liftIO $ evalStringToIOString hsc_env fun s
+  enqueueCommands (lines str)
+  return False
+
+
+-----------------------------------------------------------------------------
+-- :undef
+
+undefineMacro :: GhciMonad m => String -> m ()
+undefineMacro str = mapM_ undef (words str)
+ where undef macro_name = do
+        cmds <- ghci_macros <$> getGHCiState
+        if (macro_name `notElem` map cmdName cmds)
+           then throwGhcException (CmdLineError
+                ("macro '" ++ macro_name ++ "' is not defined"))
+           else do
+            -- This is a tad racy but really, it's a shell
+            modifyGHCiState $ \s ->
+                s { ghci_macros = filter ((/= macro_name) . cmdName)
+                                         (ghci_macros s) }
+
+
+-----------------------------------------------------------------------------
+-- :cmd
+
+cmdCmd :: GhciMonad m => String -> m ()
+cmdCmd str = handleSourceError GHC.printException $ do
+    step <- getGhciStepIO
+    expr <- GHC.parseExpr str
+    -- > ghciStepIO str :: IO String
+    let new_expr = step `mkHsApp` expr
+    hv <- GHC.compileParsedExprRemote new_expr
+
+    hsc_env <- GHC.getSession
+    cmds <- liftIO $ evalString hsc_env hv
+    enqueueCommands (lines cmds)
+
+-- | Generate a typed ghciStepIO expression
+-- @ghciStepIO :: Ty String -> IO String@.
+getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)
+getGhciStepIO = do
+  ghciTyConName <- GHC.getGHCiMonad
+  let stringTy = nlHsTyVar stringTy_RDR
+      ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
+      ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+      body = nlHsVar (getRdrName ghciStepIoMName)
+      tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)
+  return $ noLoc $ ExprWithTySig noExt body tySig
+
+-----------------------------------------------------------------------------
+-- :check
+
+checkModule :: GhciMonad m => String -> m ()
+checkModule m = do
+  let modl = GHC.mkModuleName m
+  ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
+          r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
+          dflags <- getDynFlags
+          liftIO $ putStrLn $ showSDoc dflags $
+           case GHC.moduleInfo r of
+             cm | Just scope <- GHC.modInfoTopLevelScope cm ->
+                let
+                    (loc, glob) = ASSERT( all isExternalName scope )
+                                  partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
+                in
+                        (text "global names: " <+> ppr glob) $$
+                        (text "local  names: " <+> ppr loc)
+             _ -> empty
+          return True
+  afterLoad (successIf ok) False
+
+-----------------------------------------------------------------------------
+-- :doc
+
+docCmd :: GHC.GhcMonad m => String -> m ()
+docCmd "" =
+  throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")
+docCmd s  = do
+  -- TODO: Maybe also get module headers for module names
+  names <- GHC.parseName s
+  e_docss <- mapM GHC.getDocs names
+  sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss
+  let sdocs' = vcat (intersperse (text "") sdocs)
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'
+
+-- TODO: also print arg docs.
+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
+pprDocs (mb_decl_docs, _arg_docs) =
+  maybe
+    (text "<has no documentation>")
+    (text . unpackHDS)
+    mb_decl_docs
+
+handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc
+handleGetDocsFailure no_docs = do
+  dflags <- getDynFlags
+  let msg = showPpr dflags no_docs
+  throwGhcException $ case no_docs of
+    NameHasNoModule {} -> Sorry msg
+    NoDocsInIface {} -> InstallationError msg
+    InteractiveName -> ProgramError msg
+
+-----------------------------------------------------------------------------
+-- :load, :add, :reload
+
+-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
+-- '-fdefer-type-errors' again if it has not been set before.
+wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a
+wrapDeferTypeErrors load =
+  gbracket
+    (do
+      -- Force originalFlags to avoid leaking the associated HscEnv
+      !originalFlags <- getDynFlags
+      void $ GHC.setProgramDynFlags $
+         setGeneralFlag' Opt_DeferTypeErrors originalFlags
+      return originalFlags)
+    (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
+    (\_ -> load)
+
+loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
+loadModule fs = do
+  (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)
+  either (liftIO . Exception.throwIO) return result
+
+-- | @:load@ command
+loadModule_ :: GhciMonad m => [FilePath] -> m ()
+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))
+
+loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
+loadModuleDefer = wrapDeferTypeErrors . loadModule_
+
+loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
+loadModule' files = do
+  let (filenames, phases) = unzip files
+  exp_filenames <- mapM expandPath filenames
+  let files' = zip exp_filenames phases
+  targets <- mapM (uncurry GHC.guessTarget) files'
+
+  -- NOTE: we used to do the dependency anal first, so that if it
+  -- fails we didn't throw away the current set of modules.  This would
+  -- require some re-working of the GHC interface, so we'll leave it
+  -- as a ToDo for now.
+
+  hsc_env <- GHC.getSession
+
+  -- Grab references to the currently loaded modules so that we can
+  -- see if they leak.
+  let !dflags = hsc_dflags hsc_env
+  leak_indicators <- if gopt Opt_GhciLeakCheck dflags
+    then liftIO $ getLeakIndicators hsc_env
+    else return (panic "no leak indicators")
+
+  -- unload first
+  _ <- GHC.abandonAll
+  discardActiveBreakPoints
+  GHC.setTargets []
+  _ <- GHC.load LoadAllTargets
+
+  GHC.setTargets targets
+  success <- doLoadAndCollectInfo False LoadAllTargets
+  when (gopt Opt_GhciLeakCheck dflags) $
+    liftIO $ checkLeakIndicators dflags leak_indicators
+  return success
+
+-- | @:add@ command
+addModule :: GhciMonad m => [FilePath] -> m ()
+addModule files = do
+  revertCAFs -- always revert CAFs on load/add.
+  files' <- mapM expandPath files
+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
+  targets' <- filterM checkTarget targets
+  -- remove old targets with the same id; e.g. for :add *M
+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]
+  mapM_ GHC.addTarget targets'
+  _ <- doLoadAndCollectInfo False LoadAllTargets
+  return ()
+  where
+    checkTarget :: GHC.GhcMonad m => Target -> m Bool
+    checkTarget (Target (TargetModule m) _ _) = checkTargetModule m
+    checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f
+
+    checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool
+    checkTargetModule m = do
+      hsc_env <- GHC.getSession
+      result <- liftIO $
+        Finder.findImportedModule hsc_env m (Just (fsLit "this"))
+      case result of
+        Found _ _ -> return True
+        _ -> (liftIO $ putStrLn $
+          "Module " ++ moduleNameString m ++ " not found") >> return False
+
+    checkTargetFile :: String -> IO Bool
+    checkTargetFile f = do
+      exists <- (doesFileExist f) :: IO Bool
+      unless exists $ putStrLn $ "File " ++ f ++ " not found"
+      return exists
+
+-- | @:unadd@ command
+unAddModule :: GhciMonad m => [FilePath] -> m ()
+unAddModule files = do
+  files' <- mapM expandPath files
+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
+  _ <- doLoadAndCollectInfo False LoadAllTargets
+  return ()
+
+-- | @:reload@ command
+reloadModule :: GhciMonad m => String -> m ()
+reloadModule m = void $ doLoadAndCollectInfo True loadTargets
+  where
+    loadTargets | null m    = LoadAllTargets
+                | otherwise = LoadUpTo (GHC.mkModuleName m)
+
+reloadModuleDefer :: GhciMonad m => String -> m ()
+reloadModuleDefer = wrapDeferTypeErrors . reloadModule
+
+-- | Load/compile targets and (optionally) collect module-info
+--
+-- This collects the necessary SrcSpan annotated type information (via
+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
+-- and @:uses@ commands.
+--
+-- Meta-info collection is not enabled by default and needs to be
+-- enabled explicitly via @:set +c@.  The reason is that collecting
+-- the type-information for all sub-spans can be quite expensive, and
+-- since those commands are designed to be used by editors and
+-- tooling, it's useless to collect this data for normal GHCi
+-- sessions.
+doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
+doLoadAndCollectInfo retain_context howmuch = do
+  doCollectInfo <- isOptionSet CollectInfo
+
+  doLoad retain_context howmuch >>= \case
+    Succeeded | doCollectInfo -> do
+      mod_summaries <- GHC.mgModSummaries <$> getModuleGraph
+      loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries
+      v <- mod_infos <$> getGHCiState
+      !newInfos <- collectInfo v loaded
+      modifyGHCiState (\st -> st { mod_infos = newInfos })
+      return Succeeded
+    flag -> return flag
+
+doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
+doLoad retain_context howmuch = do
+  -- turn off breakpoints before we load: we can't turn them off later, because
+  -- the ModBreaks will have gone away.
+  discardActiveBreakPoints
+
+  resetLastErrorLocations
+  -- Enable buffering stdout and stderr as we're compiling. Keeping these
+  -- handles unbuffered will just slow the compilation down, especially when
+  -- compiling in parallel.
+  gbracket (liftIO $ do hSetBuffering stdout LineBuffering
+                        hSetBuffering stderr LineBuffering)
+           (\_ ->
+            liftIO $ do hSetBuffering stdout NoBuffering
+                        hSetBuffering stderr NoBuffering) $ \_ -> do
+      ok <- trySuccess $ GHC.load howmuch
+      afterLoad ok retain_context
+      return ok
+
+
+afterLoad
+  :: GhciMonad m
+  => SuccessFlag
+  -> Bool   -- keep the remembered_ctx, as far as possible (:reload)
+  -> m ()
+afterLoad ok retain_context = do
+  revertCAFs  -- always revert CAFs on load.
+  discardTickArrays
+  loaded_mods <- getLoadedModules
+  modulesLoadedMsg ok loaded_mods
+  setContextAfterLoad retain_context loaded_mods
+
+setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()
+setContextAfterLoad keep_ctxt [] = do
+  setContextKeepingPackageModules keep_ctxt []
+setContextAfterLoad keep_ctxt ms = do
+  -- load a target if one is available, otherwise load the topmost module.
+  targets <- GHC.getTargets
+  case [ m | Just m <- map (findTarget ms) targets ] of
+        []    ->
+          let graph = GHC.mkModuleGraph ms
+              graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)
+          in load_this (last graph')
+        (m:_) ->
+          load_this m
+ where
+   findTarget mds t
+    = case filter (`matches` t) mds of
+        []    -> Nothing
+        (m:_) -> Just m
+
+   summary `matches` Target (TargetModule m) _ _
+        = GHC.ms_mod_name summary == m
+   summary `matches` Target (TargetFile f _) _ _
+        | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
+   _ `matches` _
+        = False
+
+   load_this summary | m <- GHC.ms_mod summary = do
+        is_interp <- GHC.moduleIsInterpreted m
+        dflags <- getDynFlags
+        let star_ok = is_interp && not (safeLanguageOn dflags)
+              -- We import the module with a * iff
+              --   - it is interpreted, and
+              --   - -XSafe is off (it doesn't allow *-imports)
+        let new_ctx | star_ok   = [mkIIModule (GHC.moduleName m)]
+                    | otherwise = [mkIIDecl   (GHC.moduleName m)]
+        setContextKeepingPackageModules keep_ctxt new_ctx
+
+
+-- | Keep any package modules (except Prelude) when changing the context.
+setContextKeepingPackageModules
+  :: GhciMonad m
+  => Bool                 -- True  <=> keep all of remembered_ctx
+                          -- False <=> just keep package imports
+  -> [InteractiveImport]  -- new context
+  -> m ()
+setContextKeepingPackageModules keep_ctx trans_ctx = do
+
+  st <- getGHCiState
+  let rem_ctx = remembered_ctx st
+  new_rem_ctx <- if keep_ctx then return rem_ctx
+                             else keepPackageImports rem_ctx
+  setGHCiState st{ remembered_ctx = new_rem_ctx,
+                   transient_ctx  = filterSubsumed new_rem_ctx trans_ctx }
+  setGHCContextFromGHCiState
+
+-- | Filters a list of 'InteractiveImport', clearing out any home package
+-- imports so only imports from external packages are preserved.  ('IIModule'
+-- counts as a home package import, because we are only able to bring a
+-- full top-level into scope when the source is available.)
+keepPackageImports
+  :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]
+keepPackageImports = filterM is_pkg_import
+  where
+     is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool
+     is_pkg_import (IIModule _) = return False
+     is_pkg_import (IIDecl d)
+         = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
+              case e :: Either SomeException Module of
+                Left _  -> return False
+                Right m -> return (not (isHomeModule m))
+        where
+          mod_name = unLoc (ideclName d)
+
+
+modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
+modulesLoadedMsg ok mods = do
+  dflags <- getDynFlags
+  unqual <- GHC.getPrintUnqual
+
+  msg <- if gopt Opt_ShowLoadedModules dflags
+         then do
+               mod_names <- mapM mod_name mods
+               let mod_commas
+                     | null mods = text "none."
+                     | otherwise = hsep (punctuate comma mod_names) <> text "."
+               return $ status <> text ", modules loaded:" <+> mod_commas
+         else do
+               return $ status <> text ","
+                    <+> speakNOf (length mods) (text "module") <+> "loaded."
+
+  when (verbosity dflags > 0) $
+     liftIO $ putStrLn $ showSDocForUser dflags unqual msg
+  where
+    status = case ok of
+                  Failed    -> text "Failed"
+                  Succeeded -> text "Ok"
+
+    mod_name mod = do
+        is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod
+        return $ if is_interpreted
+                 then ppr (GHC.ms_mod mod)
+                 else ppr (GHC.ms_mod mod)
+                      <+> parens (text $ normalise $ msObjFilePath mod)
+                      -- Fix #9887
+
+-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
+-- and printing 'throwE' strings to 'stderr'
+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
+runExceptGhcMonad act = handleSourceError GHC.printException $
+                        either handleErr pure =<<
+                        runExceptT act
+  where
+    handleErr sdoc = do
+        dflags <- getDynFlags
+        liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc
+
+-- | Inverse of 'runExceptT' for \"pure\" computations
+-- (c.f. 'except' for 'Except')
+exceptT :: Applicative m => Either e a -> ExceptT e m a
+exceptT = ExceptT . pure
+
+-----------------------------------------------------------------------------
+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
+
+typeOfExpr :: GHC.GhcMonad m => String -> m ()
+typeOfExpr str = handleSourceError GHC.printException $ do
+    let (mode, expr_str) = case break isSpace str of
+          ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)
+          ("+v", rest) -> (GHC.TM_NoInst,  dropWhile isSpace rest)
+          _            -> (GHC.TM_Inst,    str)
+    ty <- GHC.exprType mode expr_str
+    printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]
+
+-----------------------------------------------------------------------------
+-- | @:type-at@ command
+
+typeAtCmd :: GhciMonad m => String -> m ()
+typeAtCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos      <- lift $ mod_infos <$> getGHCiState
+    (info, ty) <- findType infos span' sample
+    lift $ printForUserModInfo (modinfoInfo info)
+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])
+
+-----------------------------------------------------------------------------
+-- | @:uses@ command
+
+usesCmd :: GhciMonad m => String -> m ()
+usesCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos  <- lift $ mod_infos <$> getGHCiState
+    uses   <- findNameUses infos span' sample
+    forM_ uses (liftIO . putStrLn . showSrcSpan)
+
+-----------------------------------------------------------------------------
+-- | @:loc-at@ command
+
+locAtCmd :: GhciMonad m => String -> m ()
+locAtCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos    <- lift $ mod_infos <$> getGHCiState
+    (_,_,sp) <- findLoc infos span' sample
+    liftIO . putStrLn . showSrcSpan $ sp
+
+-----------------------------------------------------------------------------
+-- | @:all-types@ command
+
+allTypesCmd :: GhciMonad m => String -> m ()
+allTypesCmd _ = runExceptGhcMonad $ do
+    infos <- lift $ mod_infos <$> getGHCiState
+    forM_ (M.elems infos) $ \mi ->
+        forM_ (modinfoSpans mi) (lift . printSpan)
+  where
+    printSpan span'
+      | Just ty <- spaninfoType span' = do
+        df <- getDynFlags
+        let tyInfo = unwords . words $
+                     showSDocForUser df alwaysQualify (pprTypeForUser ty)
+        liftIO . putStrLn $
+            showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
+      | otherwise = return ()
+
+-----------------------------------------------------------------------------
+-- Helpers for locAtCmd/typeAtCmd/usesCmd
+
+-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
+parseSpanArg s = do
+    (fp,s0) <- readAsString (skipWs s)
+    s0'     <- skipWs1 s0
+    (sl,s1) <- readAsInt s0'
+    s1'     <- skipWs1 s1
+    (sc,s2) <- readAsInt s1'
+    s2'     <- skipWs1 s2
+    (el,s3) <- readAsInt s2'
+    s3'     <- skipWs1 s3
+    (ec,s4) <- readAsInt s3'
+
+    trailer <- case s4 of
+        [] -> Right ""
+        _  -> skipWs1 s4
+
+    let fs    = mkFastString fp
+        span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
+                              -- End column of RealSrcSpan is the column
+                              -- after the end of the span.
+                              (mkRealSrcLoc fs el (ec + 1))
+
+    return (span',trailer)
+  where
+    readAsInt :: String -> Either SDoc (Int,String)
+    readAsInt "" = Left "Premature end of string while expecting Int"
+    readAsInt s0 = case reads s0 of
+        [s_rest] -> Right s_rest
+        _        -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
+
+    readAsString :: String -> Either SDoc (String,String)
+    readAsString s0
+      | '"':_ <- s0 = case reads s0 of
+          [s_rest] -> Right s_rest
+          _        -> leftRes
+      | s_rest@(_:_,_) <- breakWs s0 = Right s_rest
+      | otherwise = leftRes
+      where
+        leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
+
+    skipWs1 :: String -> Either SDoc String
+    skipWs1 (c:cs) | isWs c = Right (skipWs cs)
+    skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
+
+    isWs    = (`elem` [' ','\t'])
+    skipWs  = dropWhile isWs
+    breakWs = break isWs
+
+
+-- | Pretty-print \"real\" 'SrcSpan's as
+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
+-- while simply unpacking 'UnhelpfulSpan's
+showSrcSpan :: SrcSpan -> String
+showSrcSpan (UnhelpfulSpan s)  = unpackFS s
+showSrcSpan (RealSrcSpan spn)  = showRealSrcSpan spn
+
+-- | Variant of 'showSrcSpan' for 'RealSrcSpan's
+showRealSrcSpan :: RealSrcSpan -> String
+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
+                             , ")-(", show el, ",", show ec, ")"
+                             ]
+  where
+    fp = unpackFS (srcSpanFile spn)
+    sl = srcSpanStartLine spn
+    sc = srcSpanStartCol  spn
+    el = srcSpanEndLine   spn
+    -- The end column is the column after the end of the span see the
+    -- RealSrcSpan module
+    ec = let ec' = srcSpanEndCol    spn in if ec' == 0 then 0 else ec' - 1
+
+-----------------------------------------------------------------------------
+-- | @:kind@ command
+
+kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()
+kindOfType norm str = handleSourceError GHC.printException $ do
+    (ty, kind) <- GHC.typeKind norm str
+    printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
+                        , ppWhen norm $ equals <+> pprTypeForUser ty ]
+
+-----------------------------------------------------------------------------
+-- :quit
+
+quit :: Monad m => String -> m Bool
+quit _ = return True
+
+
+-----------------------------------------------------------------------------
+-- :script
+
+-- running a script file #1363
+
+scriptCmd :: String -> InputT GHCi ()
+scriptCmd ws = do
+  case words ws of
+    [s]    -> runScript s
+    _      -> throwGhcException (CmdLineError "syntax:  :script <filename>")
+
+runScript :: String    -- ^ filename
+           -> InputT GHCi ()
+runScript filename = do
+  filename' <- expandPath filename
+  either_script <- liftIO $ tryIO (openFile filename' ReadMode)
+  case either_script of
+    Left _err    -> throwGhcException (CmdLineError $ "IO error:  \""++filename++"\" "
+                      ++(ioeGetErrorString _err))
+    Right script -> do
+      st <- getGHCiState
+      let prog = progname st
+          line = line_number st
+      setGHCiState st{progname=filename',line_number=0}
+      scriptLoop script
+      liftIO $ hClose script
+      new_st <- getGHCiState
+      setGHCiState new_st{progname=prog,line_number=line}
+  where scriptLoop script = do
+          res <- runOneCommand handler $ fileLoop script
+          case res of
+            Nothing -> return ()
+            Just s  -> if s
+              then scriptLoop script
+              else return ()
+
+-----------------------------------------------------------------------------
+-- :issafe
+
+-- Displaying Safe Haskell properties of a module
+
+isSafeCmd :: GHC.GhcMonad m => String -> m ()
+isSafeCmd m =
+    case words m of
+        [s] | looksLikeModuleName s -> do
+            md <- lookupModule s
+            isSafeModule md
+        [] -> do md <- guessCurrentModule "issafe"
+                 isSafeModule md
+        _ -> throwGhcException (CmdLineError "syntax:  :issafe <module>")
+
+isSafeModule :: GHC.GhcMonad m => Module -> m ()
+isSafeModule m = do
+    mb_mod_info <- GHC.getModuleInfo m
+    when (isNothing mb_mod_info)
+         (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
+
+    dflags <- getDynFlags
+    let iface = GHC.modInfoIface $ fromJust mb_mod_info
+    when (isNothing iface)
+         (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
+                                    (GHC.moduleNameString $ GHC.moduleName m))
+
+    (msafe, pkgs) <- GHC.moduleTrustReqs m
+    let trust  = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
+        pkg    = if packageTrusted dflags m then "trusted" else "untrusted"
+        (good, bad) = tallyPkgs dflags pkgs
+
+    -- print info to user...
+    liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
+    liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
+    when (not $ S.null good)
+         (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
+                        (intercalate ", " $ map (showPpr dflags) (S.toList good)))
+    case msafe && S.null bad of
+        True -> liftIO $ putStrLn $ mname ++ " is trusted!"
+        False -> do
+            when (not $ null bad)
+                 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
+                            ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))
+            liftIO $ putStrLn $ mname ++ " is NOT trusted!"
+
+  where
+    mname = GHC.moduleNameString $ GHC.moduleName m
+
+    packageTrusted dflags md
+        | thisPackage dflags == moduleUnitId md = True
+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)
+
+    tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
+                          | otherwise = S.partition part deps
+        where part pkg = trusted $ getInstalledPackageDetails dflags pkg
+
+-----------------------------------------------------------------------------
+-- :browse
+
+-- Browsing a module's contents
+
+browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()
+browseCmd bang m =
+  case words m of
+    ['*':s] | looksLikeModuleName s -> do
+        md <- wantInterpretedModule s
+        browseModule bang md False
+    [s] | looksLikeModuleName s -> do
+        md <- lookupModule s
+        browseModule bang md True
+    [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
+             browseModule bang md True
+    _ -> throwGhcException (CmdLineError "syntax:  :browse <module>")
+
+guessCurrentModule :: GHC.GhcMonad m => String -> m Module
+-- Guess which module the user wants to browse.  Pick
+-- modules that are interpreted first.  The most
+-- recently-added module occurs last, it seems.
+guessCurrentModule cmd
+  = do imports <- GHC.getContext
+       when (null imports) $ throwGhcException $
+          CmdLineError (':' : cmd ++ ": no current module")
+       case (head imports) of
+          IIModule m -> GHC.findModule m Nothing
+          IIDecl d   -> GHC.findModule (unLoc (ideclName d))
+                                       (fmap sl_fs $ ideclPkgQual d)
+
+-- without bang, show items in context of their parents and omit children
+-- with bang, show class methods and data constructors separately, and
+--            indicate import modules, to aid qualifying unqualified names
+-- with sorted, sort items alphabetically
+browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()
+browseModule bang modl exports_only = do
+  -- :browse reports qualifiers wrt current context
+  unqual <- GHC.getPrintUnqual
+
+  mb_mod_info <- GHC.getModuleInfo modl
+  case mb_mod_info of
+    Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
+                                GHC.moduleNameString (GHC.moduleName modl)))
+    Just mod_info -> do
+        dflags <- getDynFlags
+        let names
+               | exports_only = GHC.modInfoExports mod_info
+               | otherwise    = GHC.modInfoTopLevelScope mod_info
+                                `orElse` []
+
+                -- sort alphabetically name, but putting locally-defined
+                -- identifiers first. We would like to improve this; see #1799.
+            sorted_names = loc_sort local ++ occ_sort external
+                where
+                (local,external) = ASSERT( all isExternalName names )
+                                   partition ((==modl) . nameModule) names
+                occ_sort = sortBy (compare `on` nameOccName)
+                -- try to sort by src location. If the first name in our list
+                -- has a good source location, then they all should.
+                loc_sort ns
+                      | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
+                      = sortBy (compare `on` nameSrcSpan) ns
+                      | otherwise
+                      = occ_sort ns
+
+        mb_things <- mapM GHC.lookupName sorted_names
+        let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
+
+        rdr_env <- GHC.getGRE
+
+        let things | bang      = catMaybes mb_things
+                   | otherwise = filtered_things
+            pretty | bang      = pprTyThing showToHeader
+                   | otherwise = pprTyThingInContext showToHeader
+
+            labels  [] = text "-- not currently imported"
+            labels  l  = text $ intercalate "\n" $ map qualifier l
+
+            qualifier :: Maybe [ModuleName] -> String
+            qualifier  = maybe "-- defined locally"
+                             (("-- imported via "++) . intercalate ", "
+                               . map GHC.moduleNameString)
+            importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
+
+            modNames :: [[Maybe [ModuleName]]]
+            modNames   = map (importInfo . GHC.getName) things
+
+            -- annotate groups of imports with their import modules
+            -- the default ordering is somewhat arbitrary, so we group
+            -- by header and sort groups; the names themselves should
+            -- really come in order of source appearance.. (trac #1799)
+            annotate mts = concatMap (\(m,ts)->labels m:ts)
+                         $ sortBy cmpQualifiers $ grp mts
+              where cmpQualifiers =
+                      compare `on` (map (fmap (map moduleNameFS)) . fst)
+            grp []            = []
+            grp mts@((m,_):_) = (m,map snd g) : grp ng
+              where (g,ng) = partition ((==m).fst) mts
+
+        let prettyThings, prettyThings' :: [SDoc]
+            prettyThings = map pretty things
+            prettyThings' | bang      = annotate $ zip modNames prettyThings
+                          | otherwise = prettyThings
+        liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
+        -- ToDo: modInfoInstances currently throws an exception for
+        -- package modules.  When it works, we can do this:
+        --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+
+
+-----------------------------------------------------------------------------
+-- :module
+
+-- Setting the module context.  For details on context handling see
+-- "remembered_ctx" and "transient_ctx" in GhciMonad.
+
+moduleCmd :: GhciMonad m => String -> m ()
+moduleCmd str
+  | all sensible strs = cmd
+  | otherwise = throwGhcException (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
+  where
+    (cmd, strs) =
+        case str of
+          '+':stuff -> rest addModulesToContext   stuff
+          '-':stuff -> rest remModulesFromContext stuff
+          stuff     -> rest setContext            stuff
+
+    rest op stuff = (op as bs, stuffs)
+       where (as,bs) = partitionWith starred stuffs
+             stuffs  = words stuff
+
+    sensible ('*':m) = looksLikeModuleName m
+    sensible m       = looksLikeModuleName m
+
+    starred ('*':m) = Left  (GHC.mkModuleName m)
+    starred m       = Right (GHC.mkModuleName m)
+
+
+-- -----------------------------------------------------------------------------
+-- Four ways to manipulate the context:
+--   (a) :module +<stuff>:     addModulesToContext
+--   (b) :module -<stuff>:     remModulesFromContext
+--   (c) :module <stuff>:      setContext
+--   (d) import <module>...:   addImportToContext
+
+addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
+addModulesToContext starred unstarred = restoreContextOnFailure $ do
+   addModulesToContext_ starred unstarred
+
+addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
+addModulesToContext_ starred unstarred = do
+   mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
+   setGHCContextFromGHCiState
+
+remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
+remModulesFromContext  starred unstarred = do
+   -- we do *not* call restoreContextOnFailure here.  If the user
+   -- is trying to fix up a context that contains errors by removing
+   -- modules, we don't want GHC to silently put them back in again.
+   mapM_ rm (starred ++ unstarred)
+   setGHCContextFromGHCiState
+ where
+   rm :: GhciMonad m => ModuleName -> m ()
+   rm str = do
+     m <- moduleName <$> lookupModuleName str
+     let filt = filter ((/=) m . iiModuleName)
+     modifyGHCiState $ \st ->
+        st { remembered_ctx = filt (remembered_ctx st)
+           , transient_ctx  = filt (transient_ctx st) }
+
+setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
+setContext starred unstarred = restoreContextOnFailure $ do
+  modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
+                                -- delete the transient context
+  addModulesToContext_ starred unstarred
+
+addImportToContext :: GhciMonad m => String -> m ()
+addImportToContext str = restoreContextOnFailure $ do
+  idecl <- GHC.parseImportDecl str
+  addII (IIDecl idecl)   -- #5836
+  setGHCContextFromGHCiState
+
+-- Util used by addImportToContext and addModulesToContext
+addII :: GhciMonad m => InteractiveImport -> m ()
+addII iidecl = do
+  checkAdd iidecl
+  modifyGHCiState $ \st ->
+     st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
+        , transient_ctx = filter (not . (iidecl `iiSubsumes`))
+                                 (transient_ctx st)
+        }
+
+-- Sometimes we can't tell whether an import is valid or not until
+-- we finally call 'GHC.setContext'.  e.g.
+--
+--   import System.IO (foo)
+--
+-- will fail because System.IO does not export foo.  In this case we
+-- don't want to store the import in the context permanently, so we
+-- catch the failure from 'setGHCContextFromGHCiState' and set the
+-- context back to what it was.
+--
+-- See #6007
+--
+restoreContextOnFailure :: GhciMonad m => m a -> m a
+restoreContextOnFailure do_this = do
+  st <- getGHCiState
+  let rc = remembered_ctx st; tc = transient_ctx st
+  do_this `gonException` (modifyGHCiState $ \st' ->
+     st' { remembered_ctx = rc, transient_ctx = tc })
+
+-- -----------------------------------------------------------------------------
+-- Validate a module that we want to add to the context
+
+checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()
+checkAdd ii = do
+  dflags <- getDynFlags
+  let safe = safeLanguageOn dflags
+  case ii of
+    IIModule modname
+       | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
+       | otherwise -> wantInterpretedModuleName modname >> return ()
+
+    IIDecl d -> do
+       let modname = unLoc (ideclName d)
+           pkgqual = ideclPkgQual d
+       m <- GHC.lookupModule modname (fmap sl_fs pkgqual)
+       when safe $ do
+           t <- GHC.isModuleTrusted m
+           when (not t) $ throwGhcException $ ProgramError $ ""
+
+-- -----------------------------------------------------------------------------
+-- Update the GHC API's view of the context
+
+-- | Sets the GHC context from the GHCi state.  The GHC context is
+-- always set this way, we never modify it incrementally.
+--
+-- We ignore any imports for which the ModuleName does not currently
+-- exist.  This is so that the remembered_ctx can contain imports for
+-- modules that are not currently loaded, perhaps because we just did
+-- a :reload and encountered errors.
+--
+-- Prelude is added if not already present in the list.  Therefore to
+-- override the implicit Prelude import you can say 'import Prelude ()'
+-- at the prompt, just as in Haskell source.
+--
+setGHCContextFromGHCiState :: GhciMonad m => m ()
+setGHCContextFromGHCiState = do
+  st <- getGHCiState
+      -- re-use checkAdd to check whether the module is valid.  If the
+      -- module does not exist, we do *not* want to print an error
+      -- here, we just want to silently keep the module in the context
+      -- until such time as the module reappears again.  So we ignore
+      -- the actual exception thrown by checkAdd, using tryBool to
+      -- turn it into a Bool.
+  iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
+
+  prel_iidecls <- getImplicitPreludeImports iidecls
+  valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls
+
+  extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))
+
+  GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls
+
+
+getImplicitPreludeImports :: GhciMonad m
+                          => [InteractiveImport] -> m [InteractiveImport]
+getImplicitPreludeImports iidecls = do
+  dflags <- GHC.getInteractiveDynFlags
+     -- allow :seti to override -XNoImplicitPrelude
+  st <- getGHCiState
+
+  -- We add the prelude imports if there are no *-imports, and we also
+  -- allow each prelude import to be subsumed by another explicit import
+  -- of the same module.  This means that you can override the prelude import
+  -- with "import Prelude hiding (map)", for example.
+  let prel_iidecls =
+         if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)
+            then [ IIDecl imp
+                 | imp <- prelude_imports st
+                 , not (any (sameImpModule imp) iidecls) ]
+            else []
+
+  return prel_iidecls
+
+-- -----------------------------------------------------------------------------
+-- Utils on InteractiveImport
+
+mkIIModule :: ModuleName -> InteractiveImport
+mkIIModule = IIModule
+
+mkIIDecl :: ModuleName -> InteractiveImport
+mkIIDecl = IIDecl . simpleImportDecl
+
+iiModules :: [InteractiveImport] -> [ModuleName]
+iiModules is = [m | IIModule m <- is]
+
+isIIModule :: InteractiveImport -> Bool
+isIIModule (IIModule _) = True
+isIIModule _ = False
+
+iiModuleName :: InteractiveImport -> ModuleName
+iiModuleName (IIModule m) = m
+iiModuleName (IIDecl d)   = unLoc (ideclName d)
+
+preludeModuleName :: ModuleName
+preludeModuleName = GHC.mkModuleName "Prelude"
+
+sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool
+sameImpModule _ (IIModule _) = False -- we only care about imports here
+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)
+
+addNotSubsumed :: InteractiveImport
+               -> [InteractiveImport] -> [InteractiveImport]
+addNotSubsumed i is
+  | any (`iiSubsumes` i) is = is
+  | otherwise               = i : filter (not . (i `iiSubsumes`)) is
+
+-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
+-- by any of @is@.
+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
+               -> [InteractiveImport]
+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
+
+-- | Returns True if the left import subsumes the right one.  Doesn't
+-- need to be 100% accurate, conservatively returning False is fine.
+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
+-- plusProv will ensue (#5904))
+--
+-- Note that an IIModule does not necessarily subsume an IIDecl,
+-- because e.g. a module might export a name that is only available
+-- qualified within the module itself.
+--
+-- Note that 'import M' does not necessarily subsume 'import M(foo)',
+-- because M might not export foo and we want an error to be produced
+-- in that case.
+--
+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
+iiSubsumes (IIDecl d1) (IIDecl d2)      -- A bit crude
+  =  unLoc (ideclName d1) == unLoc (ideclName d2)
+     && ideclAs d1 == ideclAs d2
+     && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))
+     && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
+  where
+     _                    `hidingSubsumes` Just (False,L _ []) = True
+     Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
+                                                           = all (`elem` xs) ys
+     h1                   `hidingSubsumes` h2              = h1 == h2
+iiSubsumes _ _ = False
+
+
+----------------------------------------------------------------------------
+-- :set
+
+-- set options in the interpreter.  Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected.  ToDo:
+-- figure out which ones & disallow them.
+
+setCmd :: GhciMonad m => String -> m ()
+setCmd ""   = showOptions False
+setCmd "-a" = showOptions True
+setCmd str
+  = case getCmd str of
+    Right ("args",    rest) ->
+        case toArgs rest of
+            Left err -> liftIO (hPutStrLn stderr err)
+            Right args -> setArgs args
+    Right ("prog",    rest) ->
+        case toArgs rest of
+            Right [prog] -> setProg prog
+            _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
+
+    Right ("prompt",           rest) ->
+        setPromptString setPrompt (dropWhile isSpace rest)
+                        "syntax: set prompt <string>"
+    Right ("prompt-function",  rest) ->
+        setPromptFunc setPrompt $ dropWhile isSpace rest
+    Right ("prompt-cont",          rest) ->
+        setPromptString setPromptCont (dropWhile isSpace rest)
+                        "syntax: :set prompt-cont <string>"
+    Right ("prompt-cont-function", rest) ->
+        setPromptFunc setPromptCont $ dropWhile isSpace rest
+
+    Right ("editor",  rest) -> setEditor  $ dropWhile isSpace rest
+    Right ("stop",    rest) -> setStop    $ dropWhile isSpace rest
+    Right ("local-config", rest) ->
+        setLocalConfigBehaviour $ dropWhile isSpace rest
+    _ -> case toArgs str of
+         Left err -> liftIO (hPutStrLn stderr err)
+         Right wds -> setOptions wds
+
+setiCmd :: GhciMonad m => String -> m ()
+setiCmd ""   = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
+setiCmd str  =
+  case toArgs str of
+    Left err -> liftIO (hPutStrLn stderr err)
+    Right wds -> newDynFlags True wds
+
+showOptions :: GhciMonad m => Bool -> m ()
+showOptions show_all
+  = do st <- getGHCiState
+       dflags <- getDynFlags
+       let opts = options st
+       liftIO $ putStrLn (showSDoc dflags (
+              text "options currently set: " <>
+              if null opts
+                   then text "none."
+                   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
+           ))
+       getDynFlags >>= liftIO . showDynFlags show_all
+
+
+showDynFlags :: Bool -> DynFlags -> IO ()
+showDynFlags show_all dflags = do
+  showLanguages' show_all dflags
+  putStrLn $ showSDoc dflags $
+     text "GHCi-specific dynamic flag settings:" $$
+         nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))
+  putStrLn $ showSDoc dflags $
+     text "other dynamic, non-language, flag settings:" $$
+         nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))
+  putStrLn $ showSDoc dflags $
+     text "warning settings:" $$
+         nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))
+  where
+        setting prefix noPrefix test flag
+          | quiet     = empty
+          | is_on     = text prefix <> text name
+          | otherwise = text noPrefix <> text name
+          where name = flagSpecName flag
+                f = flagSpecFlag flag
+                is_on = test f dflags
+                quiet = not show_all && test f default_dflags == is_on
+
+        llvmConfig = (llvmTargets dflags, llvmPasses dflags)
+
+        default_dflags = defaultDynFlags (settings dflags) llvmConfig
+
+        (ghciFlags,others)  = partition (\f -> flagSpecFlag f `elem` flgs)
+                                        DynFlags.fFlags
+        flgs = [ Opt_PrintExplicitForalls
+               , Opt_PrintExplicitKinds
+               , Opt_PrintUnicodeSyntax
+               , Opt_PrintBindResult
+               , Opt_BreakOnException
+               , Opt_BreakOnError
+               , Opt_PrintEvldWithShow
+               ]
+
+setArgs, setOptions :: GhciMonad m => [String] -> m ()
+setProg, setEditor, setStop :: GhciMonad m => String -> m ()
+setLocalConfigBehaviour :: GhciMonad m => String -> m ()
+
+setArgs args = do
+  st <- getGHCiState
+  wrapper <- mkEvalWrapper (progname st) args
+  setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }
+
+setProg prog = do
+  st <- getGHCiState
+  wrapper <- mkEvalWrapper prog (GhciMonad.args st)
+  setGHCiState st { progname = prog, evalWrapper = wrapper }
+
+setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
+
+setLocalConfigBehaviour s
+  | s == "source" =
+      modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })
+  | s == "ignore" =
+      modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })
+  | otherwise = throwGhcException
+      (CmdLineError "syntax:  :set local-config { source | ignore }")
+
+setStop str@(c:_) | isDigit c
+  = do let (nm_str,rest) = break (not.isDigit) str
+           nm = read nm_str
+       st <- getGHCiState
+       let old_breaks = breaks st
+       if all ((/= nm) . fst) old_breaks
+              then printForUser (text "Breakpoint" <+> ppr nm <+>
+                                 text "does not exist")
+              else do
+       let new_breaks = map fn old_breaks
+           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
+                      | otherwise = (i,loc)
+       setGHCiState st{ breaks = new_breaks }
+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
+
+setPrompt :: GhciMonad m => PromptFunction -> m ()
+setPrompt v = modifyGHCiState (\st -> st {prompt = v})
+
+setPromptCont :: GhciMonad m => PromptFunction -> m ()
+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})
+
+setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()
+setPromptFunc fSetPrompt s = do
+    -- We explicitly annotate the type of the expression to ensure
+    -- that unsafeCoerce# is passed the exact type necessary rather
+    -- than a more general one
+    let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"
+    (HValue funValue) <- GHC.compileExpr exprStr
+    fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)
+    where
+      convertToPromptFunction :: ([String] -> Int -> IO String)
+                              -> PromptFunction
+      convertToPromptFunction func = (\mods line -> liftIO $
+                                       liftM text (func mods line))
+
+setPromptString :: MonadIO m
+                => (PromptFunction -> m ()) -> String -> String -> m ()
+setPromptString fSetPrompt value err = do
+  if null value
+    then liftIO $ hPutStrLn stderr $ err
+    else case value of
+           ('\"':_) ->
+             case reads value of
+               [(value', xs)] | all isSpace xs ->
+                 setParsedPromptString fSetPrompt value'
+               _ -> liftIO $ hPutStrLn stderr
+                             "Can't parse prompt string. Use Haskell syntax."
+           _ ->
+             setParsedPromptString fSetPrompt value
+
+setParsedPromptString :: MonadIO m
+                      => (PromptFunction -> m ()) ->  String -> m ()
+setParsedPromptString fSetPrompt s = do
+  case (checkPromptStringForErrors s) of
+    Just err ->
+      liftIO $ hPutStrLn stderr err
+    Nothing ->
+      fSetPrompt $ generatePromptFunctionFromString s
+
+setOptions wds =
+   do -- first, deal with the GHCi opts (+s, +t, etc.)
+      let (plus_opts, minus_opts)  = partitionWith isPlus wds
+      mapM_ setOpt plus_opts
+      -- then, dynamic flags
+      when (not (null minus_opts)) $ newDynFlags False minus_opts
+
+newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
+newDynFlags interactive_only minus_opts = do
+      let lopts = map noLoc minus_opts
+
+      idflags0 <- GHC.getInteractiveDynFlags
+      (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
+
+      liftIO $ handleFlagWarnings idflags1 warns
+      when (not $ null leftovers)
+           (throwGhcException . CmdLineError
+            $ "Some flags have not been recognized: "
+            ++ (concat . intersperse ", " $ map unLoc leftovers))
+
+      when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
+          liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
+      -- Load any new plugins
+      hsc_env0 <- GHC.getSession
+      idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)
+      GHC.setInteractiveDynFlags idflags2
+      installInteractivePrint (interactivePrint idflags1) False
+
+      dflags0 <- getDynFlags
+
+      when (not interactive_only) $ do
+        (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
+        new_pkgs <- GHC.setProgramDynFlags dflags1
+
+        -- if the package flags changed, reset the context and link
+        -- the new packages.
+        hsc_env <- GHC.getSession
+        let dflags2 = hsc_dflags hsc_env
+        when (packageFlagsChanged dflags2 dflags0) $ do
+          when (verbosity dflags2 > 0) $
+            liftIO . putStrLn $
+              "package flags have changed, resetting and loading new packages..."
+          GHC.setTargets []
+          _ <- GHC.load LoadAllTargets
+          liftIO $ linkPackages hsc_env new_pkgs
+          -- package flags changed, we can't re-use any of the old context
+          setContextAfterLoad False []
+          -- and copy the package state to the interactive DynFlags
+          idflags <- GHC.getInteractiveDynFlags
+          GHC.setInteractiveDynFlags
+              idflags{ pkgState = pkgState dflags2
+                     , pkgDatabase = pkgDatabase dflags2
+                     , packageFlags = packageFlags dflags2 }
+
+        let ld0length   = length $ ldInputs dflags0
+            fmrk0length = length $ cmdlineFrameworks dflags0
+
+            newLdInputs     = drop ld0length (ldInputs dflags2)
+            newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
+
+            hsc_env' = hsc_env { hsc_dflags =
+                         dflags2 { ldInputs = newLdInputs
+                                 , cmdlineFrameworks = newCLFrameworks } }
+
+        when (not (null newLdInputs && null newCLFrameworks)) $
+          liftIO $ linkCmdLineLibs hsc_env'
+
+      return ()
+
+
+unsetOptions :: GhciMonad m => String -> m ()
+unsetOptions str
+  =   -- first, deal with the GHCi opts (+s, +t, etc.)
+     let opts = words str
+         (minus_opts, rest1) = partition isMinus opts
+         (plus_opts, rest2)  = partitionWith isPlus rest1
+         (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
+
+         defaulters =
+           [ ("args"   , setArgs default_args)
+           , ("prog"   , setProg default_progname)
+           , ("prompt"     , setPrompt default_prompt)
+           , ("prompt-cont", setPromptCont default_prompt_cont)
+           , ("editor" , liftIO findEditor >>= setEditor)
+           , ("stop"   , setStop default_stop)
+           ]
+
+         no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+         no_flag ('-':'X':rest) = return ("-XNo" ++ rest)
+         no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
+
+     in if (not (null rest3))
+           then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
+           else do
+             mapM_ (fromJust.flip lookup defaulters) other_opts
+
+             mapM_ unsetOpt plus_opts
+
+             no_flags <- mapM no_flag minus_opts
+             when (not (null no_flags)) $ newDynFlags False no_flags
+
+isMinus :: String -> Bool
+isMinus ('-':_) = True
+isMinus _ = False
+
+isPlus :: String -> Either String String
+isPlus ('+':opt) = Left opt
+isPlus other     = Right other
+
+setOpt, unsetOpt :: GhciMonad m => String -> m ()
+
+setOpt str
+  = case strToGHCiOpt str of
+        Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
+        Just o  -> setOption o
+
+unsetOpt str
+  = case strToGHCiOpt str of
+        Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
+        Just o  -> unsetOption o
+
+strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "m" = Just Multiline
+strToGHCiOpt "s" = Just ShowTiming
+strToGHCiOpt "t" = Just ShowType
+strToGHCiOpt "r" = Just RevertCAFs
+strToGHCiOpt "c" = Just CollectInfo
+strToGHCiOpt _   = Nothing
+
+optToStr :: GHCiOption -> String
+optToStr Multiline  = "m"
+optToStr ShowTiming = "s"
+optToStr ShowType   = "t"
+optToStr RevertCAFs = "r"
+optToStr CollectInfo = "c"
+
+
+-- ---------------------------------------------------------------------------
+-- :show
+
+showCmd :: forall m. GhciMonad m => String -> m ()
+showCmd ""   = showOptions False
+showCmd "-a" = showOptions True
+showCmd str = do
+    st <- getGHCiState
+    dflags <- getDynFlags
+    hsc_env <- GHC.getSession
+
+    let lookupCmd :: String -> Maybe (m ())
+        lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
+
+        -- (show in help?, command name, action)
+        action :: String -> m () -> (Bool, String, m ())
+        action name m = (True, name, m)
+
+        hidden :: String -> m () -> (Bool, String, m ())
+        hidden name m = (False, name, m)
+
+        cmds =
+            [ action "args"       $ liftIO $ putStrLn (show (GhciMonad.args st))
+            , action "prog"       $ liftIO $ putStrLn (show (progname st))
+            , action "editor"     $ liftIO $ putStrLn (show (editor st))
+            , action "stop"       $ liftIO $ putStrLn (show (stop st))
+            , action "imports"    $ showImports
+            , action "modules"    $ showModules
+            , action "bindings"   $ showBindings
+            , action "linker"     $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env))
+            , action "breaks"     $ showBkptTable
+            , action "context"    $ showContext
+            , action "packages"   $ showPackages
+            , action "paths"      $ showPaths
+            , action "language"   $ showLanguages
+            , hidden "languages"  $ showLanguages -- backwards compat
+            , hidden "lang"       $ showLanguages -- useful abbreviation
+            , action "targets"    $ showTargets
+            ]
+
+    case words str of
+      [w] | Just action <- lookupCmd w -> action
+
+      _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
+           in throwGhcException $ CmdLineError $ showSDoc dflags
+              $ hang (text "syntax:") 4
+              $ hang (text ":show") 6
+              $ brackets (fsep $ punctuate (text " |") helpCmds)
+
+showiCmd :: GHC.GhcMonad m => String -> m ()
+showiCmd str = do
+  case words str of
+        ["languages"]  -> showiLanguages -- backwards compat
+        ["language"]   -> showiLanguages
+        ["lang"]       -> showiLanguages -- useful abbreviation
+        _ -> throwGhcException (CmdLineError ("syntax:  :showi language"))
+
+showImports :: GhciMonad m => m ()
+showImports = do
+  st <- getGHCiState
+  dflags <- getDynFlags
+  let rem_ctx   = reverse (remembered_ctx st)
+      trans_ctx = transient_ctx st
+
+      show_one (IIModule star_m)
+          = ":module +*" ++ moduleNameString star_m
+      show_one (IIDecl imp) = showPpr dflags imp
+
+  prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
+
+  let show_prel p = show_one p ++ " -- implicit"
+      show_extra p = show_one (IIDecl p) ++ " -- fixed"
+
+      trans_comment s = s ++ " -- added automatically" :: String
+  --
+  liftIO $ mapM_ putStrLn (map show_one rem_ctx ++
+                           map (trans_comment . show_one) trans_ctx ++
+                           map show_prel prel_iidecls ++
+                           map show_extra (extra_imports st))
+
+showModules :: GHC.GhcMonad m => m ()
+showModules = do
+  loaded_mods <- getLoadedModules
+        -- we want *loaded* modules only, see #1734
+  let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
+  mapM_ show_one loaded_mods
+
+getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
+getLoadedModules = do
+  graph <- GHC.getModuleGraph
+  filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)
+
+showBindings :: GHC.GhcMonad m => m ()
+showBindings = do
+    bindings <- GHC.getBindings
+    (insts, finsts) <- GHC.getInsts
+    let idocs  = map GHC.pprInstanceHdr insts
+        fidocs = map GHC.pprFamInst finsts
+        binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525
+        -- See Note [Filter bindings]
+    docs <- mapM makeDoc (reverse binds)
+                  -- reverse so the new ones come last
+    mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
+  where
+    makeDoc (AnId i) = pprTypeAndContents i
+    makeDoc tt = do
+        mb_stuff <- GHC.getInfo False (getName tt)
+        return $ maybe (text "") pprTT mb_stuff
+
+    pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
+    pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)
+      = pprTyThing showToHeader thing
+        $$ show_fixity
+      where
+        show_fixity
+            | fixity == GHC.defaultFixity  = empty
+            | otherwise                    = ppr fixity <+> ppr (GHC.getName thing)
+
+
+printTyThing :: GHC.GhcMonad m => TyThing -> m ()
+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)
+
+{-
+Note [Filter bindings]
+~~~~~~~~~~~~~~~~~~~~~~
+
+If we don't filter the bindings returned by the function GHC.getBindings,
+then the :show bindings command will also show unwanted bound names,
+internally generated by GHC, eg:
+    $tcFoo :: GHC.Types.TyCon = _
+    $trModule :: GHC.Types.Module = _ .
+
+The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this
+ticket contains an analysis of the situation and suggests the solution
+implemented above.
+
+The same filter was also implemented to fix #11051 [3]. See the
+Note [What to show to users] in compiler/main/InteractiveEval.hs
+
+[1] https://gitlab.haskell.org/ghc/ghc/issues/12525
+[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489
+[3] https://gitlab.haskell.org/ghc/ghc/issues/11051
+-}
+
+
+showBkptTable :: GhciMonad m => m ()
+showBkptTable = do
+  st <- getGHCiState
+  printForUser $ prettyLocations (breaks st)
+
+showContext :: GHC.GhcMonad m => m ()
+showContext = do
+   resumes <- GHC.getResumeContext
+   printForUser $ vcat (map pp_resume (reverse resumes))
+  where
+   pp_resume res =
+        ptext (sLit "--> ") <> text (GHC.resumeStmt res)
+        $$ nest 2 (pprStopped res)
+
+pprStopped :: GHC.Resume -> SDoc
+pprStopped res =
+  ptext (sLit "Stopped in")
+    <+> ((case mb_mod_name of
+           Nothing -> empty
+           Just mod_name -> text (moduleNameString mod_name) <> char '.')
+         <> text (GHC.resumeDecl res))
+    <> char ',' <+> ppr (GHC.resumeSpan res)
+ where
+  mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
+
+showPackages :: GHC.GhcMonad m => m ()
+showPackages = do
+  dflags <- getDynFlags
+  let pkg_flags = packageFlags dflags
+  liftIO $ putStrLn $ showSDoc dflags $
+    text ("active package flags:"++if null pkg_flags then " none" else "") $$
+      nest 2 (vcat (map pprFlag pkg_flags))
+
+showPaths :: GHC.GhcMonad m => m ()
+showPaths = do
+  dflags <- getDynFlags
+  liftIO $ do
+    cwd <- getCurrentDirectory
+    putStrLn $ showSDoc dflags $
+      text "current working directory: " $$
+        nest 2 (text cwd)
+    let ipaths = importPaths dflags
+    putStrLn $ showSDoc dflags $
+      text ("module import search paths:"++if null ipaths then " none" else "") $$
+        nest 2 (vcat (map text ipaths))
+
+showLanguages :: GHC.GhcMonad m => m ()
+showLanguages = getDynFlags >>= liftIO . showLanguages' False
+
+showiLanguages :: GHC.GhcMonad m => m ()
+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
+
+showLanguages' :: Bool -> DynFlags -> IO ()
+showLanguages' show_all dflags =
+  putStrLn $ showSDoc dflags $ vcat
+     [ text "base language is: " <>
+         case language dflags of
+           Nothing          -> text "Haskell2010"
+           Just Haskell98   -> text "Haskell98"
+           Just Haskell2010 -> text "Haskell2010"
+     , (if show_all then text "all active language options:"
+                    else text "with the following modifiers:") $$
+          nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
+     ]
+  where
+   setting test flag
+          | quiet     = empty
+          | is_on     = text "-X" <> text name
+          | otherwise = text "-XNo" <> text name
+          where name = flagSpecName flag
+                f = flagSpecFlag flag
+                is_on = test f dflags
+                quiet = not show_all && test f default_dflags == is_on
+
+   llvmConfig = (llvmTargets dflags, llvmPasses dflags)
+
+   default_dflags =
+       defaultDynFlags (settings dflags) llvmConfig `lang_set`
+         case language dflags of
+           Nothing -> Just Haskell2010
+           other   -> other
+
+showTargets :: GHC.GhcMonad m => m ()
+showTargets = mapM_ showTarget =<< GHC.getTargets
+  where
+    showTarget :: GHC.GhcMonad m => Target -> m ()
+    showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)
+    showTarget (Target (TargetModule m) _ _) =
+      liftIO (putStrLn $ moduleNameString m)
+
+-- -----------------------------------------------------------------------------
+-- Completion
+
+completeCmd :: String -> GHCi ()
+completeCmd argLine0 = case parseLine argLine0 of
+    Just ("repl", resultRange, left) -> do
+        (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
+        let compls' = takeRange resultRange compls
+        liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
+        forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
+            liftIO $ print r
+    _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
+  where
+    parseLine argLine
+        | null argLine = Nothing
+        | null rest1   = Nothing
+        | otherwise    = (,,) dom <$> resRange <*> s
+      where
+        (dom, rest1) = breakSpace argLine
+        (rng, rest2) = breakSpace rest1
+        resRange | head rest1 == '"' = parseRange ""
+                 | otherwise         = parseRange rng
+        s | head rest1 == '"' = readMaybe rest1 :: Maybe String
+          | otherwise         = readMaybe rest2
+        breakSpace = fmap (dropWhile isSpace) . break isSpace
+
+    takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
+
+    -- syntax: [n-][m] with semantics "drop (n-1) . take m"
+    parseRange :: String -> Maybe (Maybe Int,Maybe Int)
+    parseRange s = case span isDigit s of
+                   (_, "") ->
+                       -- upper limit only
+                       Just (Nothing, bndRead s)
+                   (s1, '-' : s2)
+                    | all isDigit s2 ->
+                       Just (bndRead s1, bndRead s2)
+                   _ ->
+                       Nothing
+      where
+        bndRead x = if null x then Nothing else Just (read x)
+
+
+
+completeGhciCommand, completeMacro, completeIdentifier, completeModule,
+    completeSetModule, completeSeti, completeShowiOptions,
+    completeHomeModule, completeSetOptions, completeShowOptions,
+    completeHomeModuleOrFile, completeExpression
+    :: GhciMonad m => CompletionFunc m
+
+-- | Provide completions for last word in a given string.
+--
+-- Takes a tuple of two strings.  First string is a reversed line to be
+-- completed.  Second string is likely unused, 'completeCmd' always passes an
+-- empty string as second item in tuple.
+ghciCompleteWord :: CompletionFunc GHCi
+ghciCompleteWord line@(left,_) = case firstWord of
+    -- If given string starts with `:` colon, and there is only one following
+    -- word then provide REPL command completions.  If there is more than one
+    -- word complete either filename or builtin ghci commands or macros.
+    ':':cmd     | null rest     -> completeGhciCommand line
+                | otherwise     -> do
+                        completion <- lookupCompletion cmd
+                        completion line
+    -- If given string starts with `import` keyword provide module name
+    -- completions
+    "import"    -> completeModule line
+    -- otherwise provide identifier completions
+    _           -> completeExpression line
+  where
+    (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
+    lookupCompletion ('!':_) = return completeFilename
+    lookupCompletion c = do
+        maybe_cmd <- lookupCommand' c
+        case maybe_cmd of
+            Just cmd -> return (cmdCompletionFunc cmd)
+            Nothing  -> return completeFilename
+
+completeGhciCommand = wrapCompleter " " $ \w -> do
+  macros <- ghci_macros <$> getGHCiState
+  cmds   <- ghci_commands `fmap` getGHCiState
+  let macro_names = map (':':) . map cmdName $ macros
+  let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds
+  let{ candidates = case w of
+      ':' : ':' : _ -> map (':':) command_names
+      _ -> nub $ macro_names ++ command_names }
+  return $ filter (w `isPrefixOf`) candidates
+
+completeMacro = wrapIdentCompleter $ \w -> do
+  cmds <- ghci_macros <$> getGHCiState
+  return (filter (w `isPrefixOf`) (map cmdName cmds))
+
+completeIdentifier line@(left, _) =
+  -- Note: `left` is a reversed input
+  case left of
+    (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line
+    _                      -> wrapIdentCompleter complete line
+  where
+    complete w = do
+      rdrs <- GHC.getRdrNamesInScope
+      dflags <- GHC.getSessionDynFlags
+      return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
+
+completeModule = wrapIdentCompleter $ \w -> do
+  dflags <- GHC.getSessionDynFlags
+  let pkg_mods = allVisibleModules dflags
+  loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+  return $ filter (w `isPrefixOf`)
+        $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
+
+completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
+  dflags <- GHC.getSessionDynFlags
+  modules <- case m of
+    Just '-' -> do
+      imports <- GHC.getContext
+      return $ map iiModuleName imports
+    _ -> do
+      let pkg_mods = allVisibleModules dflags
+      loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+      return $ loaded_mods ++ pkg_mods
+  return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
+
+completeHomeModule = wrapIdentCompleter listHomeModules
+
+listHomeModules :: GHC.GhcMonad m => String -> m [String]
+listHomeModules w = do
+    g <- GHC.getModuleGraph
+    let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)
+    dflags <- getDynFlags
+    return $ sort $ filter (w `isPrefixOf`)
+            $ map (showPpr dflags) home_mods
+
+completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) opts)
+    where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":
+                 "prompt-cont-function":"editor":"stop":flagList
+          flagList = map head $ group $ sort allNonDeprecatedFlags
+
+completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) flagList)
+    where flagList = map head $ group $ sort allNonDeprecatedFlags
+
+completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) opts)
+    where opts = ["args", "prog", "editor", "stop",
+                     "modules", "bindings", "linker", "breaks",
+                     "context", "packages", "paths", "language", "imports"]
+
+completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) ["language"])
+
+completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
+                $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
+                            listFiles
+
+unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
+unionComplete f1 f2 line = do
+  cs1 <- f1 line
+  cs2 <- f2 line
+  return (cs1 ++ cs2)
+
+wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m
+wrapCompleter breakChars fun = completeWord Nothing breakChars
+    $ fmap (map simpleCompletion . nubSort) . fun
+
+wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m
+wrapIdentCompleter = wrapCompleter word_break_chars
+
+wrapIdentCompleterWithModifier
+  :: Monad m
+  => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
+    $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
+ where
+  getModifier = find (`elem` modifChars)
+
+-- | Return a list of visible module names for autocompletion.
+-- (NB: exposed != visible)
+allVisibleModules :: DynFlags -> [ModuleName]
+allVisibleModules dflags = listVisibleModuleNames dflags
+
+completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
+                        completeIdentifier
+
+
+-- -----------------------------------------------------------------------------
+-- commands for debugger
+
+sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()
+sprintCmd = pprintClosureCommand False False
+printCmd  = pprintClosureCommand True False
+forceCmd  = pprintClosureCommand False True
+
+stepCmd :: GhciMonad m => String -> m ()
+stepCmd arg = withSandboxOnly ":step" $ step arg
+  where
+  step []         = doContinue (const True) GHC.SingleStep
+  step expression = runStmt expression GHC.SingleStep >> return ()
+
+stepLocalCmd :: GhciMonad m => String -> m ()
+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
+  where
+  step expr
+   | not (null expr) = stepCmd expr
+   | otherwise = do
+      mb_span <- getCurrentBreakSpan
+      case mb_span of
+        Nothing  -> stepCmd []
+        Just loc -> do
+           md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
+           current_toplevel_decl <- enclosingTickSpan md loc
+           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
+
+stepModuleCmd :: GhciMonad m => String -> m ()
+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
+  where
+  step expr
+   | not (null expr) = stepCmd expr
+   | otherwise = do
+      mb_span <- getCurrentBreakSpan
+      case mb_span of
+        Nothing  -> stepCmd []
+        Just pan -> do
+           let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
+           doContinue f GHC.SingleStep
+
+-- | Returns the span of the largest tick containing the srcspan given
+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan
+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+enclosingTickSpan md (RealSrcSpan src) = do
+  ticks <- getTickArray md
+  let line = srcSpanStartLine src
+  ASSERT(inRange (bounds ticks) line) do
+  let enclosing_spans = [ pan | (_,pan) <- ticks ! line
+                               , realSrcSpanEnd pan >= realSrcSpanEnd src]
+  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+ where
+
+leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
+leftmostLargestRealSrcSpan a b =
+  (realSrcSpanStart a `compare` realSrcSpanStart b)
+     `thenCmp`
+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)
+
+traceCmd :: GhciMonad m => String -> m ()
+traceCmd arg
+  = withSandboxOnly ":trace" $ tr arg
+  where
+  tr []         = doContinue (const True) GHC.RunAndLogSteps
+  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
+
+continueCmd :: GhciMonad m => String -> m ()
+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
+
+doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()
+doContinue pre step = do
+  runResult <- resume pre step
+  _ <- afterRunStmt pre runResult
+  return ()
+
+abandonCmd :: GhciMonad m => String -> m ()
+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
+  b <- GHC.abandon -- the prompt will change to indicate the new context
+  when (not b) $ liftIO $ putStrLn "There is no computation running."
+
+deleteCmd :: GhciMonad m => String -> m ()
+deleteCmd argLine = withSandboxOnly ":delete" $ do
+   deleteSwitch $ words argLine
+   where
+   deleteSwitch :: GhciMonad m => [String] -> m ()
+   deleteSwitch [] =
+      liftIO $ putStrLn "The delete command requires at least one argument."
+   -- delete all break points
+   deleteSwitch ("*":_rest) = discardActiveBreakPoints
+   deleteSwitch idents = do
+      mapM_ deleteOneBreak idents
+      where
+      deleteOneBreak :: GhciMonad m => String -> m ()
+      deleteOneBreak str
+         | all isDigit str = deleteBreak (read str)
+         | otherwise = return ()
+
+historyCmd :: GHC.GhcMonad m => String -> m ()
+historyCmd arg
+  | null arg        = history 20
+  | all isDigit arg = history (read arg)
+  | otherwise       = liftIO $ putStrLn "Syntax:  :history [num]"
+  where
+  history num = do
+    resumes <- GHC.getResumeContext
+    case resumes of
+      [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
+      (r:_) -> do
+        let hist = GHC.resumeHistory r
+            (took,rest) = splitAt num hist
+        case hist of
+          [] -> liftIO $ putStrLn $
+                   "Empty history. Perhaps you forgot to use :trace?"
+          _  -> do
+                 pans <- mapM GHC.getHistorySpan took
+                 let nums  = map (printf "-%-3d:") [(1::Int)..]
+                     names = map GHC.historyEnclosingDecls took
+                 printForUser (vcat(zipWith3
+                                 (\x y z -> x <+> y <+> z)
+                                 (map text nums)
+                                 (map (bold . hcat . punctuate colon . map text) names)
+                                 (map (parens . ppr) pans)))
+                 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
+
+bold :: SDoc -> SDoc
+bold c | do_bold   = text start_bold <> c <> text end_bold
+       | otherwise = c
+
+backCmd :: GhciMonad m => String -> m ()
+backCmd arg
+  | null arg        = back 1
+  | all isDigit arg = back (read arg)
+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"
+  where
+  back num = withSandboxOnly ":back" $ do
+      (names, _, pan, _) <- GHC.back num
+      printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
+      printTypeOfNames names
+       -- run the command set with ":set stop <cmd>"
+      st <- getGHCiState
+      enqueueCommands [stop st]
+
+forwardCmd :: GhciMonad m => String -> m ()
+forwardCmd arg
+  | null arg        = forward 1
+  | all isDigit arg = forward (read arg)
+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"
+  where
+  forward num = withSandboxOnly ":forward" $ do
+      (names, ix, pan, _) <- GHC.forward num
+      printForUser $ (if (ix == 0)
+                        then ptext (sLit "Stopped at")
+                        else ptext (sLit "Logged breakpoint at")) <+> ppr pan
+      printTypeOfNames names
+       -- run the command set with ":set stop <cmd>"
+      st <- getGHCiState
+      enqueueCommands [stop st]
+
+-- handle the "break" command
+breakCmd :: GhciMonad m => String -> m ()
+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
+
+breakSwitch :: GhciMonad m => [String] -> m ()
+breakSwitch [] = do
+   liftIO $ putStrLn "The break command requires at least one argument."
+breakSwitch (arg1:rest)
+   | looksLikeModuleName arg1 && not (null rest) = do
+        md <- wantInterpretedModule arg1
+        breakByModule md rest
+   | all isDigit arg1 = do
+        imports <- GHC.getContext
+        case iiModules imports of
+           (mn : _) -> do
+              md <- lookupModuleName mn
+              breakByModuleLine md (read arg1) rest
+           [] -> do
+              liftIO $ putStrLn "No modules are loaded with debugging support."
+   | otherwise = do -- try parsing it as an identifier
+        wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+        maybe_info <- GHC.getModuleInfo (GHC.nameModule name)
+        case maybe_info of
+          Nothing -> noCanDo name (ptext (sLit "cannot get module info"))
+          Just minf ->
+               ASSERT( isExternalName name )
+                    findBreakAndSet (GHC.nameModule name) $
+                       findBreakForBind name (GHC.modInfoModBreaks minf)
+       where
+          noCanDo n why = printForUser $
+                text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+
+breakByModule :: GhciMonad m => Module -> [String] -> m ()
+breakByModule md (arg1:rest)
+   | all isDigit arg1 = do  -- looks like a line number
+        breakByModuleLine md (read arg1) rest
+breakByModule _ _
+   = breakSyntax
+
+breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()
+breakByModuleLine md line args
+   | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
+   | [col] <- args, all isDigit col =
+        findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
+   | otherwise = breakSyntax
+
+breakSyntax :: a
+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
+
+findBreakAndSet :: GhciMonad m
+                => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
+findBreakAndSet md lookupTickTree = do
+   tickArray <- getTickArray md
+   (breakArray, _) <- getModBreak md
+   case lookupTickTree tickArray of
+      []  -> liftIO $ putStrLn $ "No breakpoints found at that location."
+      some -> mapM_ (breakAt breakArray) some
+ where
+   breakAt breakArray (tick, pan) = do
+         setBreakFlag True breakArray tick
+         (alreadySet, nm) <-
+               recordBreak $ BreakLocation
+                       { breakModule = md
+                       , breakLoc = RealSrcSpan pan
+                       , breakTick = tick
+                       , onBreakCmd = ""
+                       }
+         printForUser $
+            text "Breakpoint " <> ppr nm <>
+            if alreadySet
+               then text " was already set at " <> ppr pan
+               else text " activated at " <> ppr pan
+
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+--    - the leftmost complete subexpression on the specified line, or
+--    - the leftmost subexpression starting on the specified line, or
+--    - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
+findBreakByLine line arr
+  | not (inRange (bounds arr) line) = Nothing
+  | otherwise =
+    listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd)  comp)   `mplus`
+    listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
+    listToMaybe (sortBy (flip compare `on` snd) ticks)
+  where
+        ticks = arr ! line
+
+        starts_here = [ (ix,pan) | (ix, pan) <- ticks,
+                        GHC.srcSpanStartLine pan == line ]
+
+        (comp, incomp) = partition ends_here starts_here
+            where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
+
+-- The aim is to find the breakpoints for all the RHSs of the
+-- equations corresponding to a binding.  So we find all breakpoints
+-- for
+--   (a) this binder only (not a nested declaration)
+--   (b) that do not have an enclosing breakpoint
+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray
+                 -> [(BreakIndex,RealSrcSpan)]
+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks
+  where
+    ticks = [ (index, span)
+            | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),
+              n == occNameString (nameOccName name),
+              RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]
+    enclosed (_,sp0) = any subspan ticks
+      where subspan (_,sp) = sp /= sp0 &&
+                         realSrcSpanStart sp <= realSrcSpanStart sp0 &&
+                         realSrcSpanEnd sp0 <= realSrcSpanEnd sp
+
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+                 -> Maybe (BreakIndex,RealSrcSpan)
+findBreakByCoord mb_file (line, col) arr
+  | not (inRange (bounds arr) line) = Nothing
+  | otherwise =
+    listToMaybe (sortBy (flip compare `on` snd) contains ++
+                 sortBy (compare `on` snd) after_here)
+  where
+        ticks = arr ! line
+
+        -- the ticks that span this coordinate
+        contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),
+                            is_correct_file pan ]
+
+        is_correct_file pan
+                 | Just f <- mb_file = GHC.srcSpanFile pan == f
+                 | otherwise         = True
+
+        after_here = [ tick | tick@(_,pan) <- ticks,
+                              GHC.srcSpanStartLine pan == line,
+                              GHC.srcSpanStartCol pan >= col ]
+
+-- For now, use ANSI bold on terminals that we know support it.
+-- Otherwise, we add a line of carets under the active expression instead.
+-- In particular, on Windows and when running the testsuite (which sets
+-- TERM to vt100 for other reasons) we get carets.
+-- We really ought to use a proper termcap/terminfo library.
+do_bold :: Bool
+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
+    where mTerm = System.Environment.getEnv "TERM"
+                  `catchIO` \_ -> return "TERM not set"
+
+start_bold :: String
+start_bold = "\ESC[1m"
+end_bold :: String
+end_bold   = "\ESC[0m"
+
+-----------------------------------------------------------------------------
+-- :where
+
+whereCmd :: GHC.GhcMonad m => String -> m ()
+whereCmd = noArgs $ do
+  mstrs <- getCallStackAtCurrentBreakpoint
+  case mstrs of
+    Nothing -> return ()
+    Just strs -> liftIO $ putStrLn (renderStack strs)
+
+-----------------------------------------------------------------------------
+-- :list
+
+listCmd :: GhciMonad m => String -> m ()
+listCmd "" = do
+   mb_span <- getCurrentBreakSpan
+   case mb_span of
+      Nothing ->
+          printForUser $ text "Not stopped at a breakpoint; nothing to list"
+      Just (RealSrcSpan pan) ->
+          listAround pan True
+      Just pan@(UnhelpfulSpan _) ->
+          do resumes <- GHC.getResumeContext
+             case resumes of
+                 [] -> panic "No resumes"
+                 (r:_) ->
+                     do let traceIt = case GHC.resumeHistory r of
+                                      [] -> text "rerunning with :trace,"
+                                      _ -> empty
+                            doWhat = traceIt <+> text ":back then :list"
+                        printForUser (text "Unable to list source for" <+>
+                                      ppr pan
+                                   $$ text "Try" <+> doWhat)
+listCmd str = list2 (words str)
+
+list2 :: GhciMonad m => [String] -> m ()
+list2 [arg] | all isDigit arg = do
+    imports <- GHC.getContext
+    case iiModules imports of
+        [] -> liftIO $ putStrLn "No module to list"
+        (mn : _) -> do
+          md <- lookupModuleName mn
+          listModuleLine md (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+        md <- wantInterpretedModule arg1
+        listModuleLine md (read arg2)
+list2 [arg] = do
+        wantNameFromInterpretedModule noCanDo arg $ \name -> do
+        let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+        case loc of
+            RealSrcLoc l ->
+               do tickArray <- ASSERT( isExternalName name )
+                               getTickArray (GHC.nameModule name)
+                  let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+                                        (GHC.srcLocLine l, GHC.srcLocCol l)
+                                        tickArray
+                  case mb_span of
+                    Nothing       -> listAround (realSrcLocSpan l) False
+                    Just (_, pan) -> listAround pan False
+            UnhelpfulLoc _ ->
+                  noCanDo name $ text "can't find its location: " <>
+                                 ppr loc
+    where
+        noCanDo n why = printForUser $
+            text "cannot list source code for " <> ppr n <> text ": " <> why
+list2  _other =
+        liftIO $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
+
+listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()
+listModuleLine modl line = do
+   graph <- GHC.getModuleGraph
+   let this = GHC.mgLookupModule graph modl
+   case this of
+     Nothing -> panic "listModuleLine"
+     Just summ -> do
+           let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
+               loc = mkRealSrcLoc (mkFastString (filename)) line 0
+           listAround (realSrcLocSpan loc) False
+
+-- | list a section of a source file around a particular SrcSpan.
+-- If the highlight flag is True, also highlight the span using
+-- start_bold\/end_bold.
+
+-- GHC files are UTF-8, so we can implement this by:
+-- 1) read the file in as a BS and syntax highlight it as before
+-- 2) convert the BS to String using utf-string, and write it out.
+-- It would be better if we could convert directly between UTF-8 and the
+-- console encoding, of course.
+listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()
+listAround pan do_highlight = do
+      contents <- liftIO $ BS.readFile (unpackFS file)
+      -- Drop carriage returns to avoid duplicates, see #9367.
+      let ls  = BS.split '\n' $ BS.filter (/= '\r') contents
+          ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
+                        drop (line1 - 1 - pad_before) $ ls
+          fst_line = max 1 (line1 - pad_before)
+          line_nos = [ fst_line .. ]
+
+          highlighted | do_highlight = zipWith highlight line_nos ls'
+                      | otherwise    = [\p -> BS.concat[p,l] | l <- ls']
+
+          bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
+          prefixed = zipWith ($) highlighted bs_line_nos
+          output   = BS.intercalate (BS.pack "\n") prefixed
+
+      let utf8Decoded = utf8DecodeByteString output
+      liftIO $ putStrLn utf8Decoded
+  where
+        file  = GHC.srcSpanFile pan
+        line1 = GHC.srcSpanStartLine pan
+        col1  = GHC.srcSpanStartCol pan - 1
+        line2 = GHC.srcSpanEndLine pan
+        col2  = GHC.srcSpanEndCol pan - 1
+
+        pad_before | line1 == 1 = 0
+                   | otherwise  = 1
+        pad_after = 1
+
+        highlight | do_bold   = highlight_bold
+                  | otherwise = highlight_carets
+
+        highlight_bold no line prefix
+          | no == line1 && no == line2
+          = let (a,r) = BS.splitAt col1 line
+                (b,c) = BS.splitAt (col2-col1) r
+            in
+            BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
+          | no == line1
+          = let (a,b) = BS.splitAt col1 line in
+            BS.concat [prefix, a, BS.pack start_bold, b]
+          | no == line2
+          = let (a,b) = BS.splitAt col2 line in
+            BS.concat [prefix, a, BS.pack end_bold, b]
+          | otherwise   = BS.concat [prefix, line]
+
+        highlight_carets no line prefix
+          | no == line1 && no == line2
+          = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
+                                         BS.replicate (col2-col1) '^']
+          | no == line1
+          = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
+                                         prefix, line]
+          | no == line2
+          = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
+                                         BS.pack "^^"]
+          | otherwise   = BS.concat [prefix, line]
+         where
+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
+           nl = BS.singleton '\n'
+
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: GhciMonad m => Module -> m TickArray
+getTickArray modl = do
+   st <- getGHCiState
+   let arrmap = tickarrays st
+   case lookupModuleEnv arrmap modl of
+      Just arr -> return arr
+      Nothing  -> do
+        (_breakArray, ticks) <- getModBreak modl
+        let arr = mkTickArray (assocs ticks)
+        setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+        return arr
+
+discardTickArrays :: GhciMonad m => m ()
+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+  = accumArray (flip (:)) [] (1, max_line)
+        [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]
+    where
+        max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]
+        srcSpanLines pan = [ GHC.srcSpanStartLine pan ..  GHC.srcSpanEndLine pan ]
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GhciMonad m => m ()
+discardActiveBreakPoints = do
+   st <- getGHCiState
+   mapM_ (turnOffBreak.snd) (breaks st)
+   setGHCiState $ st { breaks = [] }
+
+deleteBreak :: GhciMonad m => Int -> m ()
+deleteBreak identity = do
+   st <- getGHCiState
+   let oldLocations    = breaks st
+       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
+   if null this
+      then printForUser (text "Breakpoint" <+> ppr identity <+>
+                         text "does not exist")
+      else do
+           mapM_ (turnOffBreak.snd) this
+           setGHCiState $ st { breaks = rest }
+
+turnOffBreak :: GHC.GhcMonad m => BreakLocation -> m ()
+turnOffBreak loc = do
+  (arr, _) <- getModBreak (breakModule loc)
+  hsc_env <- GHC.getSession
+  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
+
+getModBreak :: GHC.GhcMonad m
+            => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
+getModBreak m = do
+   mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
+   let modBreaks  = GHC.modInfoModBreaks mod_info
+   let arr        = GHC.modBreaks_flags modBreaks
+   let ticks      = GHC.modBreaks_locs  modBreaks
+   return (arr, ticks)
+
+setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()
+setBreakFlag toggle arr i = do
+  hsc_env <- GHC.getSession
+  liftIO $ enableBreakpoint hsc_env arr i toggle
+
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions;
+-- it normally just prints out the exception.  The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception.  We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: GhciMonad m => SomeException -> m Bool
+handler exception = do
+  flushInterpBuffers
+  withSignalHandlers $
+     ghciHandle handler (showException exception >> return False)
+
+showException :: MonadIO m => SomeException -> m ()
+showException se =
+  liftIO $ case fromException se of
+           -- omit the location for CmdLineError:
+           Just (CmdLineError s)    -> putException s
+           -- ditto:
+           Just other_ghc_ex        -> putException (show other_ghc_ex)
+           Nothing                  ->
+               case fromException se of
+               Just UserInterrupt -> putException "Interrupted."
+               _                  -> putException ("*** Exception: " ++ show se)
+  where
+    putException = hPutStrLn stderr
+
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered.  Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
+ghciHandle h m = gmask $ \restore -> do
+                 -- Force dflags to avoid leaking the associated HscEnv
+                 !dflags <- getDynFlags
+                 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
+
+ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
+ghciTry m = fmap Right m `gcatch` \e -> return $ Left e
+
+tryBool :: ExceptionMonad m => m a -> m Bool
+tryBool m = do
+    r <- ghciTry m
+    case r of
+      Left _  -> return False
+      Right _ -> return True
+
+-- ----------------------------------------------------------------------------
+-- Utils
+
+lookupModule :: GHC.GhcMonad m => String -> m Module
+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
+
+lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
+lookupModuleName mName = GHC.lookupModule mName Nothing
+
+isHomeModule :: Module -> Bool
+isHomeModule m = GHC.moduleUnitId m == mainUnitId
+
+-- TODO: won't work if home dir is encoded.
+-- (changeDirectory may not work either in that case.)
+expandPath :: MonadIO m => String -> m String
+expandPath = liftIO . expandPathIO
+
+expandPathIO :: String -> IO String
+expandPathIO p =
+  case dropWhile isSpace p of
+   ('~':d) -> do
+        tilde <- getHomeDirectory -- will fail if HOME not defined
+        return (tilde ++ '/':d)
+   other ->
+        return other
+
+wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
+
+wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
+wantInterpretedModuleName modname = do
+   modl <- lookupModuleName modname
+   let str = moduleNameString modname
+   dflags <- getDynFlags
+   when (GHC.moduleUnitId modl /= thisPackage dflags) $
+      throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
+   is_interpreted <- GHC.moduleIsInterpreted modl
+   when (not is_interpreted) $
+       throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
+   return modl
+
+wantNameFromInterpretedModule :: GHC.GhcMonad m
+                              => (Name -> SDoc -> m ())
+                              -> String
+                              -> (Name -> m ())
+                              -> m ()
+wantNameFromInterpretedModule noCanDo str and_then =
+  handleSourceError GHC.printException $ do
+   names <- GHC.parseName str
+   case names of
+      []    -> return ()
+      (n:_) -> do
+            let modl = ASSERT( isExternalName n ) GHC.nameModule n
+            if not (GHC.isExternalName n)
+               then noCanDo n $ ppr n <>
+                                text " is not defined in an interpreted module"
+               else do
+            is_interpreted <- GHC.moduleIsInterpreted modl
+            if not is_interpreted
+               then noCanDo n $ text "module " <> ppr modl <>
+                                text " is not interpreted"
+               else and_then n
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI/Info.hs
@@ -0,0 +1,382 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
+
+-- | Get information on modules, expressions, and identifiers
+module GHCi.UI.Info
+    ( ModInfo(..)
+    , SpanInfo(..)
+    , spanInfoFromRealSrcSpan
+    , collectInfo
+    , findLoc
+    , findNameUses
+    , findType
+    , getModInfo
+    ) where
+
+import           Control.Exception
+import           Control.Monad
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Maybe
+import           Data.Data
+import           Data.Function
+import           Data.List
+import           Data.Map.Strict   (Map)
+import qualified Data.Map.Strict   as M
+import           Data.Maybe
+import           Data.Time
+import           Prelude           hiding (mod,(<>))
+import           System.Directory
+
+import qualified CoreUtils
+import           Desugar
+import           DynFlags (HasDynFlags(..))
+import           FastString
+import           GHC
+import           GhcMonad
+import           Name
+import           NameSet
+import           Outputable
+import           SrcLoc
+import           TcHsSyn
+import           Var
+
+-- | Info about a module. This information is generated every time a
+-- module is loaded.
+data ModInfo = ModInfo
+    { modinfoSummary    :: !ModSummary
+      -- ^ Summary generated by GHC. Can be used to access more
+      -- information about the module.
+    , modinfoSpans      :: [SpanInfo]
+      -- ^ Generated set of information about all spans in the
+      -- module that correspond to some kind of identifier for
+      -- which there will be type info and/or location info.
+    , modinfoInfo       :: !ModuleInfo
+      -- ^ Again, useful from GHC for accessing information
+      -- (exports, instances, scope) from a module.
+    , modinfoLastUpdate :: !UTCTime
+      -- ^ The timestamp of the file used to generate this record.
+    }
+
+-- | Type of some span of source code. Most of these fields are
+-- unboxed but Haddock doesn't show that.
+data SpanInfo = SpanInfo
+    { spaninfoSrcSpan   :: {-# UNPACK #-} !RealSrcSpan
+      -- ^ The span we associate information with
+    , spaninfoType      :: !(Maybe Type)
+      -- ^ The 'Type' associated with the span
+    , spaninfoVar       :: !(Maybe Id)
+      -- ^ The actual 'Var' associated with the span, if
+      -- any. This can be useful for accessing a variety of
+      -- information about the identifier such as module,
+      -- locality, definition location, etc.
+    }
+
+instance Outputable SpanInfo where
+  ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i
+
+-- | Test whether second span is contained in (or equal to) first span.
+-- This is basically 'containsSpan' for 'SpanInfo'
+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
+containsSpanInfo = containsSpan `on` spaninfoSrcSpan
+
+-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
+
+-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
+-- respectively)
+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
+spanInfoFromRealSrcSpan spn mty mvar =
+    SpanInfo spn mty mvar
+
+-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
+-- only a 'RealSrcSpan'
+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
+
+-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
+srcSpanFilePath :: RealSrcSpan -> FilePath
+srcSpanFilePath = unpackFS . srcSpanFile
+
+-- | Try to find the location of the given identifier at the given
+-- position in the module.
+findLoc :: GhcMonad m
+        => Map ModuleName ModInfo
+        -> RealSrcSpan
+        -> String
+        -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
+findLoc infos span0 string = do
+    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
+             guessModule infos (srcSpanFilePath span0)
+
+    info  <- maybeToExceptT "No module info for current file! Try loading it?" $
+             MaybeT $ pure $ M.lookup name infos
+
+    name' <- findName infos span0 info string
+
+    case getSrcSpan name' of
+        UnhelpfulSpan{} -> do
+            throwE ("Found a name, but no location information." <+>
+                    "The module is:" <+>
+                    maybe "<unknown>" (ppr . moduleName)
+                          (nameModule_maybe name'))
+
+        span' -> return (info,name',span')
+
+-- | Find any uses of the given identifier in the codebase.
+findNameUses :: (GhcMonad m)
+             => Map ModuleName ModInfo
+             -> RealSrcSpan
+             -> String
+             -> ExceptT SDoc m [SrcSpan]
+findNameUses infos span0 string =
+    locToSpans <$> findLoc infos span0 string
+  where
+    locToSpans (modinfo,name',span') =
+        stripSurrounding (span' : map toSrcSpan spans)
+      where
+        toSrcSpan = RealSrcSpan . spaninfoSrcSpan
+        spans = filter ((== Just name') . fmap getName . spaninfoVar)
+                       (modinfoSpans modinfo)
+
+-- | Filter out redundant spans which surround/contain other spans.
+stripSurrounding :: [SrcSpan] -> [SrcSpan]
+stripSurrounding xs = filter (not . isRedundant) xs
+  where
+    isRedundant x = any (x `strictlyContains`) xs
+
+    (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
+         = s1 /= s2 && s1 `containsSpan` s2
+    _                `strictlyContains` _ = False
+
+-- | Try to resolve the name located at the given position, or
+-- otherwise resolve based on the current module's scope.
+findName :: GhcMonad m
+         => Map ModuleName ModInfo
+         -> RealSrcSpan
+         -> ModInfo
+         -> String
+         -> ExceptT SDoc m Name
+findName infos span0 mi string =
+    case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
+      Nothing -> tryExternalModuleResolution
+      Just name ->
+        case getSrcSpan name of
+          UnhelpfulSpan {} -> tryExternalModuleResolution
+          RealSrcSpan   {} -> return (getName name)
+  where
+    tryExternalModuleResolution =
+      case find (matchName $ mkFastString string)
+                (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
+        Nothing -> throwE "Couldn't resolve to any modules."
+        Just imported -> resolveNameFromModule infos imported
+
+    matchName :: FastString -> Name -> Bool
+    matchName str name =
+      str ==
+      occNameFS (getOccName name)
+
+-- | Try to resolve the name from another (loaded) module's exports.
+resolveNameFromModule :: GhcMonad m
+                      => Map ModuleName ModInfo
+                      -> Name
+                      -> ExceptT SDoc m Name
+resolveNameFromModule infos name = do
+     modL <- maybe (throwE $ "No module for" <+> ppr name) return $
+             nameModule_maybe name
+
+     info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
+                            ppr modL)) return $
+             M.lookup (moduleName modL) infos
+
+     maybe (throwE "No matching export in any local modules.") return $
+         find (matchName name) (modInfoExports (modinfoInfo info))
+  where
+    matchName :: Name -> Name -> Bool
+    matchName x y = occNameFS (getOccName x) ==
+                    occNameFS (getOccName y)
+
+-- | Try to resolve the type display from the given span.
+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
+                        reverse spans' `spaninfosWithin` si
+
+-- | Try to find the type of the given span.
+findType :: GhcMonad m
+         => Map ModuleName ModInfo
+         -> RealSrcSpan
+         -> String
+         -> ExceptT SDoc m (ModInfo, Type)
+findType infos span0 string = do
+    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
+             guessModule infos (srcSpanFilePath span0)
+
+    info  <- maybeToExceptT "No module info for current file! Try loading it?" $
+             MaybeT $ pure $ M.lookup name infos
+
+    case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
+        Nothing -> (,) info <$> lift (exprType TM_Inst string)
+        Just ty -> return (info, ty)
+  where
+    -- | Try to resolve the type display from the given span.
+    resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
+    resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
+                            reverse spans' `spaninfosWithin` si
+
+-- | Guess a module name from a file path.
+guessModule :: GhcMonad m
+            => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
+guessModule infos fp = do
+    target <- lift $ guessTarget fp Nothing
+    case targetId target of
+        TargetModule mn  -> return mn
+        TargetFile fp' _ -> guessModule' fp'
+  where
+    guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
+    guessModule' fp' = case findModByFp fp' of
+        Just mn -> return mn
+        Nothing -> do
+            fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
+
+            target' <- lift $ guessTarget fp'' Nothing
+            case targetId target' of
+                TargetModule mn -> return mn
+                _               -> MaybeT . pure $ findModByFp fp''
+
+    findModByFp :: FilePath -> Maybe ModuleName
+    findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
+      where
+        mifp :: (ModuleName, ModInfo) -> Maybe FilePath
+        mifp = ml_hs_file . ms_location . modinfoSummary . snd
+
+
+-- | Collect type info data for the loaded modules.
+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
+               -> m (Map ModuleName ModInfo)
+collectInfo ms loaded = do
+    df <- getDynFlags
+    liftIO (filterM cacheInvalid loaded) >>= \case
+        [] -> return ms
+        invalidated -> do
+            liftIO (putStrLn ("Collecting type info for " ++
+                              show (length invalidated) ++
+                              " module(s) ... "))
+
+            foldM (go df) ms invalidated
+  where
+    go df m name = do { info <- getModInfo name; return (M.insert name info m) }
+                   `gcatch`
+                   (\(e :: SomeException) -> do
+                         liftIO $ putStrLn
+                                $ showSDocForUser df alwaysQualify
+                                $ "Error while getting type info from" <+>
+                                  ppr name <> ":" <+> text (show e)
+                         return m)
+
+    cacheInvalid name = case M.lookup name ms of
+        Nothing -> return True
+        Just mi -> do
+            let fp = srcFilePath (modinfoSummary mi)
+                last' = modinfoLastUpdate mi
+            current <- getModificationTime fp
+            exists <- doesFileExist fp
+            if exists
+                then return $ current /= last'
+                else return True
+
+-- | Get the source file path from a ModSummary.
+-- If the .hs file is missing, and the .o file exists,
+-- we return the .o file path.
+srcFilePath :: ModSummary -> FilePath
+srcFilePath modSum = fromMaybe obj_fp src_fp
+    where
+        src_fp = ml_hs_file ms_loc
+        obj_fp = ml_obj_file ms_loc
+        ms_loc = ms_location modSum
+
+-- | Get info about the module: summary, types, etc.
+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
+getModInfo name = do
+    m <- getModSummary name
+    p <- parseModule m
+    typechecked <- typecheckModule p
+    allTypes <- processAllTypeCheckedModule typechecked
+    let i = tm_checked_module_info typechecked
+    ts <- liftIO $ getModificationTime $ srcFilePath m
+    return (ModInfo m allTypes i ts)
+
+-- | Get ALL source spans in the module.
+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
+                            -> m [SpanInfo]
+processAllTypeCheckedModule tcm = do
+    bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
+    ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
+    pts <- mapM getTypeLPat    $ listifyAllSpans tcs
+    return $ mapMaybe toSpanInfo
+           $ sortBy cmpSpan
+           $ catMaybes (bts ++ ets ++ pts)
+  where
+    tcs = tm_typechecked_source tcm
+
+    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
+    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+    getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
+        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
+    getTypeLHsBind _ = pure Nothing
+
+    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
+    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+    getTypeLHsExpr e = do
+        hs_env  <- getSession
+        (_,mbe) <- liftIO $ deSugarExpr hs_env e
+        return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
+      where
+        mid :: Maybe Id
+        mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i
+            | otherwise                                  = Nothing
+
+        unwrapVar (HsWrap _ _ var) = var
+        unwrapVar e'               = e'
+
+    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
+    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+    getTypeLPat (dL->L spn pat) =
+        pure (Just (getMaybeId pat,spn,hsPatType pat))
+      where
+        getMaybeId (VarPat _ (dL->L _ vid)) = Just vid
+        getMaybeId _                        = Nothing
+
+    -- | Get ALL source spans in the source.
+    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
+    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
+      where
+        p (dL->L spn _) = isGoodSrcSpan spn
+
+    -- | Variant of @syb@'s @everything@ (which summarises all nodes
+    -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
+    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+    everythingAllSpans k z f x
+      | (False `mkQ` (const True :: NameSet -> Bool)) x = z
+      | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
+
+    cmpSpan (_,a,_) (_,b,_)
+      | a `isSubspanOf` b = LT
+      | b `isSubspanOf` a = GT
+      | otherwise         = EQ
+
+    -- | Pretty print the types into a 'SpanInfo'.
+    toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
+    toSpanInfo (n,RealSrcSpan spn,typ)
+        = Just $ spanInfoFromRealSrcSpan spn (Just typ) n
+    toSpanInfo _ = Nothing
+
+-- helper stolen from @syb@ package
+type GenericQ r = forall a. Data a => a -> r
+
+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+(r `mkQ` br) a = maybe r br (cast a)
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI/Monad.hs
@@ -0,0 +1,536 @@
+{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+module GHCi.UI.Monad (
+        GHCi(..), startGHCi,
+        GHCiState(..), GhciMonad(..),
+        GHCiOption(..), isOptionSet, setOption, unsetOption,
+        Command(..), CommandResult(..), cmdSuccess,
+        LocalConfigBehaviour(..),
+        PromptFunction,
+        BreakLocation(..),
+        TickArray,
+        getDynFlags,
+
+        runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
+        ActionStats(..), runAndPrintStats, runWithStats, printStats,
+
+        printForUserNeverQualify, printForUserModInfo,
+        printForUser, printForUserPartWay, prettyLocations,
+
+        compileGHCiExpr,
+        initInterpBuffering,
+        turnOffBuffering, turnOffBuffering_,
+        flushInterpBuffers,
+        mkEvalWrapper
+    ) where
+
+#include "HsVersions.h"
+
+import GHCi.UI.Info (ModInfo)
+import qualified GHC
+import GhcMonad         hiding (liftIO)
+import Outputable       hiding (printForUser, printForUserPartWay)
+import qualified Outputable
+import DynFlags
+import FastString
+import HscTypes
+import SrcLoc
+import Module
+import GHCi
+import GHCi.RemoteTypes
+import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
+import Util
+
+import Exception
+import Numeric
+import Data.Array
+import Data.IORef
+import Data.Time
+import System.Environment
+import System.IO
+import Control.Monad
+import Prelude hiding ((<>))
+
+import System.Console.Haskeline (CompletionFunc, InputT)
+import qualified System.Console.Haskeline as Haskeline
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+import Data.Map.Strict (Map)
+import qualified GHC.LanguageExtensions as LangExt
+
+-----------------------------------------------------------------------------
+-- GHCi monad
+
+data GHCiState = GHCiState
+     {
+        progname       :: String,
+        args           :: [String],
+        evalWrapper    :: ForeignHValue, -- ^ of type @IO a -> IO a@
+        prompt         :: PromptFunction,
+        prompt_cont    :: PromptFunction,
+        editor         :: String,
+        stop           :: String,
+        localConfig    :: LocalConfigBehaviour,
+        options        :: [GHCiOption],
+        line_number    :: !Int,         -- ^ input line
+        break_ctr      :: !Int,
+        breaks         :: ![(Int, BreakLocation)],
+        tickarrays     :: ModuleEnv TickArray,
+            -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
+            -- so that we don't rebuild it each time the user sets
+            -- a breakpoint.
+        ghci_commands  :: [Command],
+            -- ^ available ghci commands
+        ghci_macros    :: [Command],
+            -- ^ user-defined macros
+        last_command   :: Maybe Command,
+            -- ^ @:@ at the GHCi prompt repeats the last command, so we
+            -- remember it here
+        cmd_wrapper    :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),
+            -- ^ The command wrapper is run for each command or statement.
+            -- The 'Bool' value denotes whether the command is successful and
+            -- 'Nothing' means to exit GHCi.
+        cmdqueue       :: [String],
+
+        remembered_ctx :: [InteractiveImport],
+            -- ^ The imports that the user has asked for, via import
+            -- declarations and :module commands.  This list is
+            -- persistent over :reloads (but any imports for modules
+            -- that are not loaded are temporarily ignored).  After a
+            -- :load, all the home-package imports are stripped from
+            -- this list.
+            --
+            -- See bugs #2049, #1873, #1360
+
+        transient_ctx  :: [InteractiveImport],
+            -- ^ An import added automatically after a :load, usually of
+            -- the most recently compiled module.  May be empty if
+            -- there are no modules loaded.  This list is replaced by
+            -- :load, :reload, and :add.  In between it may be modified
+            -- by :module.
+
+        extra_imports  :: [ImportDecl GhcPs],
+            -- ^ These are "always-on" imports, added to the
+            -- context regardless of what other imports we have.
+            -- This is useful for adding imports that are required
+            -- by setGHCiMonad.  Be careful adding things here:
+            -- you can create ambiguities if these imports overlap
+            -- with other things in scope.
+            --
+            -- NB. although this is not currently used by GHCi itself,
+            -- it was added to support other front-ends that are based
+            -- on the GHCi code.  Potentially we could also expose
+            -- this functionality via GHCi commands.
+
+        prelude_imports :: [ImportDecl GhcPs],
+            -- ^ These imports are added to the context when
+            -- -XImplicitPrelude is on and we don't have a *-module
+            -- in the context.  They can also be overridden by another
+            -- import for the same module, e.g.
+            -- "import Prelude hiding (map)"
+
+        ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)
+
+        short_help :: String,
+            -- ^ help text to display to a user
+        long_help  :: String,
+        lastErrorLocations :: IORef [(FastString, Int)],
+
+        mod_infos  :: !(Map ModuleName ModInfo),
+
+        flushStdHandles :: ForeignHValue,
+            -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
+        noBuffering :: ForeignHValue
+            -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
+     }
+
+type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
+
+-- | A GHCi command
+data Command
+   = Command
+   { cmdName           :: String
+     -- ^ Name of GHCi command (e.g. "exit")
+   , cmdAction         :: String -> InputT GHCi Bool
+     -- ^ The 'Bool' value denotes whether to exit GHCi
+   , cmdHidden         :: Bool
+     -- ^ Commands which are excluded from default completion
+     -- and @:help@ summary. This is usually set for commands not
+     -- useful for interactive use but rather for IDEs.
+   , cmdCompletionFunc :: CompletionFunc GHCi
+     -- ^ 'CompletionFunc' for arguments
+   }
+
+data CommandResult
+   = CommandComplete
+   { cmdInput :: String
+   , cmdResult :: Either SomeException (Maybe Bool)
+   , cmdStats :: ActionStats
+   }
+   | CommandIncomplete
+     -- ^ Unterminated multiline command
+   deriving Show
+
+cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)
+cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e
+cmdSuccess CommandComplete{ cmdResult = Right r } = return r
+cmdSuccess CommandIncomplete = return $ Just True
+
+type PromptFunction = [String]
+                   -> Int
+                   -> GHCi SDoc
+
+data GHCiOption
+        = ShowTiming            -- show time/allocs after evaluation
+        | ShowType              -- show the type of expressions
+        | RevertCAFs            -- revert CAFs after every evaluation
+        | Multiline             -- use multiline commands
+        | CollectInfo           -- collect and cache information about
+                                -- modules after load
+        deriving Eq
+
+-- | Treatment of ./.ghci files.  For now we either load or
+-- ignore.  But later we could implement a "safe mode" where
+-- only safe operations are performed.
+--
+data LocalConfigBehaviour
+  = SourceLocalConfig
+  | IgnoreLocalConfig
+  deriving (Eq)
+
+data BreakLocation
+   = BreakLocation
+   { breakModule :: !GHC.Module
+   , breakLoc    :: !SrcSpan
+   , breakTick   :: {-# UNPACK #-} !Int
+   , onBreakCmd  :: String
+   }
+
+instance Eq BreakLocation where
+  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
+                 breakTick loc1   == breakTick loc2
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations []   = text "No active breakpoints."
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
+                if null (onBreakCmd loc)
+                   then Outputable.empty
+                   else doubleQuotes (text (onBreakCmd loc))
+
+recordBreak
+  :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+   -- don't store the same break point twice
+   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
+     (nm:_) -> return (True, nm)
+     [] -> do
+      let oldCounter = break_ctr st
+          newCounter = oldCounter + 1
+      setGHCiState $ st { break_ctr = newCounter,
+                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
+                        }
+      return (False, oldCounter)
+
+newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
+
+reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
+
+startGHCi :: GHCi a -> GHCiState -> Ghc a
+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
+
+instance Functor GHCi where
+    fmap = liftM
+
+instance Applicative GHCi where
+    pure a = GHCi $ \_ -> pure a
+    (<*>) = ap
+
+instance Monad GHCi where
+  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
+
+class GhcMonad m => GhciMonad m where
+  getGHCiState    :: m GHCiState
+  setGHCiState    :: GHCiState -> m ()
+  modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
+  reifyGHCi       :: ((Session, IORef GHCiState) -> IO a) -> m a
+
+instance GhciMonad GHCi where
+  getGHCiState      = GHCi $ \r -> liftIO $ readIORef r
+  setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s
+  modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
+  reifyGHCi f       = GHCi $ \r -> reifyGhc $ \s -> f (s, r)
+
+instance GhciMonad (InputT GHCi) where
+  getGHCiState    = lift getGHCiState
+  setGHCiState    = lift . setGHCiState
+  modifyGHCiState = lift . modifyGHCiState
+  reifyGHCi       = lift . reifyGHCi
+
+liftGhc :: Ghc a -> GHCi a
+liftGhc m = GHCi $ \_ -> m
+
+instance MonadIO GHCi where
+  liftIO = liftGhc . liftIO
+
+instance HasDynFlags GHCi where
+  getDynFlags = getSessionDynFlags
+
+instance GhcMonad GHCi where
+  setSession s' = liftGhc $ setSession s'
+  getSession    = liftGhc $ getSession
+
+instance HasDynFlags (InputT GHCi) where
+  getDynFlags = lift getDynFlags
+
+instance GhcMonad (InputT GHCi) where
+  setSession = lift . setSession
+  getSession = lift getSession
+
+instance ExceptionMonad GHCi where
+  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
+  gmask f =
+      GHCi $ \s -> gmask $ \io_restore ->
+                             let
+                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
+                             in
+                                unGHCi (f g_restore) s
+
+instance Haskeline.MonadException Ghc where
+  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
+                    in fmap (flip unGhc s) $ f run'
+
+instance Haskeline.MonadException GHCi where
+  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
+                    in fmap (flip unGHCi s) $ f run'
+
+instance ExceptionMonad (InputT GHCi) where
+  gcatch = Haskeline.catch
+  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
+
+isOptionSet :: GhciMonad m => GHCiOption -> m Bool
+isOptionSet opt
+ = do st <- getGHCiState
+      return (opt `elem` options st)
+
+setOption :: GhciMonad m => GHCiOption -> m ()
+setOption opt
+ = do st <- getGHCiState
+      setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+
+unsetOption :: GhciMonad m => GHCiOption -> m ()
+unsetOption opt
+ = do st <- getGHCiState
+      setGHCiState (st{ options = filter (/= opt) (options st) })
+
+printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
+printForUserNeverQualify doc = do
+  dflags <- getDynFlags
+  liftIO $ Outputable.printForUser dflags stdout neverQualify doc
+
+printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
+printForUserModInfo info doc = do
+  dflags <- getDynFlags
+  mUnqual <- GHC.mkPrintUnqualifiedForModule info
+  unqual <- maybe GHC.getPrintUnqual return mUnqual
+  liftIO $ Outputable.printForUser dflags stdout unqual doc
+
+printForUser :: GhcMonad m => SDoc -> m ()
+printForUser doc = do
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  liftIO $ Outputable.printForUser dflags stdout unqual doc
+
+printForUserPartWay :: GhcMonad m => SDoc -> m ()
+printForUserPartWay doc = do
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
+
+-- | Run a single Haskell expression
+runStmt
+  :: GhciMonad m
+  => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)
+runStmt stmt stmt_text step = do
+  st <- getGHCiState
+  GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
+    let opts = GHC.execOptions
+                  { GHC.execSourceFile = progname st
+                  , GHC.execLineNumber = line_number st
+                  , GHC.execSingleStep = step
+                  , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
+                                                   (EvalThis fhv) }
+    Just <$> GHC.execStmt' stmt stmt_text opts
+
+runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])
+runDecls decls = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+      reflectGHCi x $ do
+        GHC.handleSourceError (\e -> do GHC.printException e;
+                                        return Nothing) $ do
+          r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
+          return (Just r)
+
+runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])
+runDecls' decls = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+    reflectGHCi x $
+      GHC.handleSourceError
+        (\e -> do GHC.printException e;
+                  return Nothing)
+        (Just <$> GHC.runParsedDecls decls)
+
+resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult
+resume canLogSpan step = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+      reflectGHCi x $ do
+        GHC.resumeExec canLogSpan step
+
+-- --------------------------------------------------------------------------
+-- timing & statistics
+
+data ActionStats = ActionStats
+  { actionAllocs :: Maybe Integer
+  , actionElapsedTime :: Double
+  } deriving Show
+
+runAndPrintStats
+  :: GhciMonad m
+  => (a -> Maybe Integer)
+  -> m a
+  -> m (ActionStats, Either SomeException a)
+runAndPrintStats getAllocs action = do
+  result <- runWithStats getAllocs action
+  case result of
+    (stats, Right{}) -> do
+      showTiming <- isOptionSet ShowTiming
+      when showTiming $ do
+        dflags  <- getDynFlags
+        liftIO $ printStats dflags stats
+    _ -> return ()
+  return result
+
+runWithStats
+  :: ExceptionMonad m
+  => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
+runWithStats getAllocs action = do
+  t0 <- liftIO getCurrentTime
+  result <- gtry action
+  let allocs = either (const Nothing) getAllocs result
+  t1 <- liftIO getCurrentTime
+  let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
+  return (ActionStats allocs elapsedTime, result)
+
+printStats :: DynFlags -> ActionStats -> IO ()
+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
+   = do let secs_str = showFFloat (Just 2) secs
+        putStrLn (showSDoc dflags (
+                 parens (text (secs_str "") <+> text "secs" <> comma <+>
+                         case mallocs of
+                           Nothing -> empty
+                           Just allocs ->
+                             text (separateThousands allocs) <+> text "bytes")))
+  where
+    separateThousands n = reverse . sep . reverse . show $ n
+      where sep n'
+              | n' `lengthAtMost` 3 = n'
+              | otherwise           = take 3 n' ++ "," ++ sep (drop 3 n')
+
+-----------------------------------------------------------------------------
+-- reverting CAFs
+
+revertCAFs :: GhciMonad m => m ()
+revertCAFs = do
+  hsc_env <- GHC.getSession
+  liftIO $ iservCmd hsc_env RtsRevertCAFs
+  s <- getGHCiState
+  when (not (ghc_e s)) turnOffBuffering
+     -- Have to turn off buffering again, because we just
+     -- reverted stdout, stderr & stdin to their defaults.
+
+
+-----------------------------------------------------------------------------
+-- To flush buffers for the *interpreted* computation we need
+-- to refer to *its* stdout/stderr handles
+
+-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
+initInterpBuffering = do
+  nobuf <- compileGHCiExpr $
+   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
+       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
+       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
+  flush <- compileGHCiExpr $
+   "do { System.IO.hFlush System.IO.stdout; " ++
+       " System.IO.hFlush System.IO.stderr }"
+  return (nobuf, flush)
+
+-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
+flushInterpBuffers :: GhciMonad m => m ()
+flushInterpBuffers = do
+  st <- getGHCiState
+  hsc_env <- GHC.getSession
+  liftIO $ evalIO hsc_env (flushStdHandles st)
+
+-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
+turnOffBuffering :: GhciMonad m => m ()
+turnOffBuffering = do
+  st <- getGHCiState
+  turnOffBuffering_ (noBuffering st)
+
+turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
+turnOffBuffering_ fhv = do
+  hsc_env <- getSession
+  liftIO $ evalIO hsc_env fhv
+
+mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue
+mkEvalWrapper progname args =
+  compileGHCiExpr $
+    "\\m -> System.Environment.withProgName " ++ show progname ++
+    "(System.Environment.withArgs " ++ show args ++ " m)"
+
+compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
+compileGHCiExpr expr =
+  withTempSession mkTempSession $ GHC.compileExprRemote expr
+  where
+    mkTempSession hsc_env = hsc_env
+      { hsc_dflags = (hsc_dflags hsc_env) {
+        -- Running GHCi's internal expression is incompatible with -XSafe.
+          -- We temporarily disable any Safe Haskell settings while running
+          -- GHCi internal expressions. (see #12509)
+        safeHaskell = Sf_None
+      }
+        -- RebindableSyntax can wreak havoc with GHCi in several ways
+          -- (see #13385 and #14342 for examples), so we temporarily
+          -- disable it too.
+          `xopt_unset` LangExt.RebindableSyntax
+          -- We heavily depend on -fimplicit-import-qualified to compile expr
+          -- with fully qualified names without imports.
+          `gopt_set` Opt_ImplicitImportQualified
+      }
diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI/Tags.hs
@@ -0,0 +1,216 @@
+-----------------------------------------------------------------------------
+--
+-- GHCi's :ctags and :etags commands
+--
+-- (c) The GHC Team 2005-2007
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module GHCi.UI.Tags (
+  createCTagsWithLineNumbersCmd,
+  createCTagsWithRegExesCmd,
+  createETagsFileCmd
+) where
+
+import Exception
+import GHC
+import GHCi.UI.Monad
+import Outputable
+
+-- ToDo: figure out whether we need these, and put something appropriate
+-- into the GHC API instead
+import Name (nameOccName)
+import OccName (pprOccName)
+import ConLike
+import MonadUtils
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Ord
+import DriverPhases
+import Panic
+import Prelude
+import System.Directory
+import System.IO
+import System.IO.Error
+
+-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
+  createETagsFileCmd :: String -> GHCi ()
+
+createCTagsWithLineNumbersCmd ""   =
+  ghciCreateTagsFile CTagsWithLineNumbers "tags"
+createCTagsWithLineNumbersCmd file =
+  ghciCreateTagsFile CTagsWithLineNumbers file
+
+createCTagsWithRegExesCmd ""   =
+  ghciCreateTagsFile CTagsWithRegExes "tags"
+createCTagsWithRegExesCmd file =
+  ghciCreateTagsFile CTagsWithRegExes file
+
+createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
+createETagsFileCmd file  = ghciCreateTagsFile ETags file
+
+data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+  createTagsFile kind file
+
+-- ToDo:
+--      - remove restriction that all modules must be interpreted
+--        (problem: we don't know source locations for entities unless
+--        we compiled the module.
+--
+--      - extract createTagsFile so it can be used from the command-line
+--        (probably need to fix first problem before this is useful).
+--
+createTagsFile :: TagsKind -> FilePath -> GHCi ()
+createTagsFile tagskind tagsFile = do
+  graph <- GHC.getModuleGraph
+  mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)
+  either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
+  case either_res of
+    Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
+    Right _ -> return ()
+
+
+listModuleTags :: GHC.Module -> GHCi [TagInfo]
+listModuleTags m = do
+  is_interpreted <- GHC.moduleIsInterpreted m
+  -- should we just skip these?
+  when (not is_interpreted) $
+    let mName = GHC.moduleNameString (GHC.moduleName m) in
+    throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
+  mbModInfo <- GHC.getModuleInfo m
+  case mbModInfo of
+    Nothing -> return []
+    Just mInfo -> do
+       dflags <- getDynFlags
+       mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
+       let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
+       let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
+       let localNames = filter ((m==) . nameModule) names
+       mbTyThings <- mapM GHC.lookupName localNames
+       return $! [ tagInfo dflags unqual exported kind name realLoc
+                     | tyThing <- catMaybes mbTyThings
+                     , let name = getName tyThing
+                     , let exported = GHC.modInfoIsExportedName mInfo name
+                     , let kind = tyThing2TagKind tyThing
+                     , let loc = srcSpanStart (nameSrcSpan name)
+                     , RealSrcLoc realLoc <- [loc]
+                     ]
+
+  where
+    tyThing2TagKind (AnId _)                 = 'v'
+    tyThing2TagKind (AConLike RealDataCon{}) = 'd'
+    tyThing2TagKind (AConLike PatSynCon{})   = 'p'
+    tyThing2TagKind (ATyCon _)               = 't'
+    tyThing2TagKind (ACoAxiom _)             = 'x'
+
+
+data TagInfo = TagInfo
+  { tagExported :: Bool -- is tag exported
+  , tagKind :: Char   -- tag kind
+  , tagName :: String -- tag name
+  , tagFile :: String -- file name
+  , tagLine :: Int    -- line number
+  , tagCol :: Int     -- column number
+  , tagSrcInfo :: Maybe (String,Integer)  -- source code line and char offset
+  }
+
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
+        -> TagInfo
+tagInfo dflags unqual exported kind name loc
+    = TagInfo exported kind
+        (showSDocForUser dflags unqual $ pprOccName (nameOccName name))
+        (showSDocForUser dflags unqual $ ftext (srcLocFile loc))
+        (srcLocLine loc) (srcLocCol loc) Nothing
+
+-- throw an exception when someone tries to overwrite existing source file (fix for #10989)
+writeTagsSafely :: FilePath -> String -> IO ()
+writeTagsSafely file str = do
+    dfe <- doesFileExist file
+    if dfe && isSourceFilename file
+        then throwGhcException (CmdLineError (file ++ " is existing source file. " ++
+             "Please specify another file name to store tags data"))
+        else writeFile file str
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+-- ctags style with the Ex expression being just the line number, Vim et al
+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
+  let tags = unlines $ sort $ map showCTag tagInfos
+  tryIO (writeTagsSafely file tags)
+
+-- ctags style with the Ex expression being a regex searching the line, Vim et al
+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
+  tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
+  let tags = unlines $ sort $ map showCTag $concat tagInfoGroups
+  tryIO (writeTagsSafely file tags)
+
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+  tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
+  let tagGroups = map processGroup tagInfoGroups
+  tryIO (writeTagsSafely file $ concat tagGroups)
+
+  where
+    processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
+    processGroup group@(tagInfo:_) =
+      let tags = unlines $ map showETag group in
+      "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
+
+
+makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
+makeTagGroupsWithSrcInfo tagInfos = do
+  let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
+  mapM addTagSrcInfo groups
+
+  where
+    addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
+    addTagSrcInfo group@(tagInfo:_) = do
+      file <- readFile $tagFile tagInfo
+      let sortedGroup = sortBy (comparing tagLine) group
+      return $ perFile sortedGroup 1 0 $ lines file
+
+    perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
+     | tagLine tag > cnt =
+         perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
+     | tagLine tag == cnt =
+         tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
+    perFile _ _ _ _ = []
+
+
+-- ctags format, for Vim et al
+showCTag :: TagInfo -> String
+showCTag ti =
+  tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
+    tagKind ti : ( if tagExported ti then "" else "\tfile:" )
+
+  where
+    tagCmd =
+      case tagSrcInfo ti of
+        Nothing -> show $tagLine ti
+        Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
+
+      where
+        escapeSlashes '/' r = '\\' : '/' : r
+        escapeSlashes '\\' r = '\\' : '\\' : r
+        escapeSlashes c r = c : r
+
+
+-- etags format, for Emacs/XEmacs
+showETag :: TagInfo -> String
+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
+                  tagSrcInfo = Just (srcLine,charPos) }
+    =  take (colNo - 1) srcLine ++ tag
+    ++ "\x7f" ++ tag
+    ++ "\x01" ++ show lineNo
+    ++ "," ++ show charPos
+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
diff --git a/ghc/GHCi/Util.hs b/ghc/GHCi/Util.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/Util.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- | Utilities for GHCi.
+module GHCi.Util where
+
+-- NOTE: Avoid importing GHC modules here, because the primary purpose
+-- of this module is to not use UnboxedTuples in a module that imports
+-- lots of other modules.  See issue#13101 for more info.
+
+import GHC.Exts
+import GHC.Types
+
+anyToPtr :: a -> IO (Ptr ())
+anyToPtr x =
+  IO (\s -> case anyToAddr# x s of
+              (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
diff --git a/ghc/Main.hs b/ghc/Main.hs
new file mode 100644
--- /dev/null
+++ b/ghc/Main.hs
@@ -0,0 +1,963 @@
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHC Driver program
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+-- The official GHC API
+import qualified GHC
+import GHC              ( -- DynFlags(..), HscTarget(..),
+                          -- GhcMode(..), GhcLink(..),
+                          Ghc, GhcMonad(..),
+                          LoadHowMuch(..) )
+import CmdLineParser
+
+-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
+import LoadIface        ( showIface )
+import HscMain          ( newHscEnv )
+import DriverPipeline   ( oneShot, compileFile )
+import DriverMkDepend   ( doMkDependHS )
+import DriverBkp   ( doBackpack )
+#if defined(GHCI)
+import GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
+#endif
+
+-- Frontend plugins
+#if defined(GHCI)
+import DynamicLoading   ( loadFrontendPlugin, initializePlugins  )
+import Plugins
+#else
+import DynamicLoading   ( pluginError )
+#endif
+import Module           ( ModuleName )
+
+
+-- Various other random stuff that we need
+import GHC.HandleEncoding
+import Config
+import Constants
+import HscTypes
+import Packages         ( pprPackages, pprPackagesSimple )
+import DriverPhases
+import BasicTypes       ( failed )
+import DynFlags hiding (WarnReason(..))
+import ErrUtils
+import FastString
+import Outputable
+import SrcLoc
+import Util
+import Panic
+import UniqSupply
+import MonadUtils       ( liftIO )
+
+-- Imports for --abi-hash
+import LoadIface           ( loadUserInterface )
+import Module              ( mkModuleName )
+import Finder              ( findImportedModule, cannotFindModule )
+import TcRnMonad           ( initIfaceCheck )
+import Binary              ( openBinMem, put_ )
+import BinFingerprint      ( fingerprintBinMem )
+
+-- Standard Haskell libraries
+import System.IO
+import System.Environment
+import System.Exit
+import System.FilePath
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import Prelude
+
+-----------------------------------------------------------------------------
+-- ToDo:
+
+-- time commands when run with -v
+-- user ways
+-- Win32 support: proper signal handling
+-- reading the package configuration file is too slow
+-- -K<size>
+
+-----------------------------------------------------------------------------
+-- GHC's command-line interface
+
+main :: IO ()
+main = do
+   initGCStatistics -- See Note [-Bsymbolic and hooks]
+   hSetBuffering stdout LineBuffering
+   hSetBuffering stderr LineBuffering
+
+   configureHandleEncoding
+   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+    -- 1. extract the -B flag from the args
+    argv0 <- getArgs
+
+    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
+        mbMinusB | null minusB_args = Nothing
+                 | otherwise = Just (drop 2 (last minusB_args))
+
+    let argv2 = map (mkGeneralLocated "on the commandline") argv1
+
+    -- 2. Parse the "mode" flags (--make, --interactive etc.)
+    (mode, argv3, flagWarnings) <- parseModeFlags argv2
+
+    -- If all we want to do is something like showing the version number
+    -- then do it now, before we start a GHC session etc. This makes
+    -- getting basic information much more resilient.
+
+    -- In particular, if we wait until later before giving the version
+    -- number then bootstrapping gets confused, as it tries to find out
+    -- what version of GHC it's using before package.conf exists, so
+    -- starting the session fails.
+    case mode of
+        Left preStartupMode ->
+            do case preStartupMode of
+                   ShowSupportedExtensions   -> showSupportedExtensions
+                   ShowVersion               -> showVersion
+                   ShowNumVersion            -> putStrLn cProjectVersion
+                   ShowOptions isInteractive -> showOptions isInteractive
+        Right postStartupMode ->
+            -- start our GHC session
+            GHC.runGhc mbMinusB $ do
+
+            dflags <- GHC.getSessionDynFlags
+
+            case postStartupMode of
+                Left preLoadMode ->
+                    liftIO $ do
+                        case preLoadMode of
+                            ShowInfo               -> showInfo dflags
+                            ShowGhcUsage           -> showGhcUsage  dflags
+                            ShowGhciUsage          -> showGhciUsage dflags
+                            PrintWithDynFlags f    -> putStrLn (f dflags)
+                Right postLoadMode ->
+                    main' postLoadMode dflags argv3 flagWarnings
+
+main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
+      -> Ghc ()
+main' postLoadMode dflags0 args flagWarnings = do
+  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
+  -- can be further adjusted on a module by module basis, using only
+  -- the -fvia-C and -fasm flags.  If the default HscTarget is not
+  -- HscC or HscAsm, -fvia-C and -fasm have no effect.
+  let dflt_target = hscTarget dflags0
+      (mode, lang, link)
+         = case postLoadMode of
+               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
+               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
+               DoMake          -> (CompManager, dflt_target,    LinkBinary)
+               DoBackpack      -> (CompManager, dflt_target,    LinkBinary)
+               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
+               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
+               _               -> (OneShot,     dflt_target,    LinkBinary)
+
+  let dflags1 = dflags0{ ghcMode   = mode,
+                         hscTarget = lang,
+                         ghcLink   = link,
+                         verbosity = case postLoadMode of
+                                         DoEval _ -> 0
+                                         _other   -> 1
+                        }
+
+      -- turn on -fimplicit-import-qualified for GHCi now, so that it
+      -- can be overriden from the command-line
+      -- XXX: this should really be in the interactive DynFlags, but
+      -- we don't set that until later in interactiveUI
+      -- We also set -fignore-optim-changes and -fignore-hpc-changes,
+      -- which are program-level options. Again, this doesn't really
+      -- feel like the right place to handle this, but we don't have
+      -- a great story for the moment.
+      dflags2  | DoInteractive <- postLoadMode = def_ghci_flags
+               | DoEval _      <- postLoadMode = def_ghci_flags
+               | otherwise                     = dflags1
+        where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified
+                                       `gopt_set` Opt_IgnoreOptimChanges
+                                       `gopt_set` Opt_IgnoreHpcChanges
+
+        -- The rest of the arguments are "dynamic"
+        -- Leftover ones are presumably files
+  (dflags3, fileish_args, dynamicFlagWarnings) <-
+      GHC.parseDynamicFlags dflags2 args
+
+  let dflags4 = case lang of
+                HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
+                    let platform = targetPlatform dflags3
+                        dflags3a = updateWays $ dflags3 { ways = interpWays }
+                        dflags3b = foldl gopt_set dflags3a
+                                 $ concatMap (wayGeneralFlags platform)
+                                             interpWays
+                        dflags3c = foldl gopt_unset dflags3b
+                                 $ concatMap (wayUnsetGeneralFlags platform)
+                                             interpWays
+                    in dflags3c
+                _ ->
+                    dflags3
+
+  GHC.prettyPrintGhcErrors dflags4 $ do
+
+  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
+
+  handleSourceError (\e -> do
+       GHC.printException e
+       liftIO $ exitWith (ExitFailure 1)) $ do
+         liftIO $ handleFlagWarnings dflags4 flagWarnings'
+
+  liftIO $ showBanner postLoadMode dflags4
+
+  let
+     -- To simplify the handling of filepaths, we normalise all filepaths right
+     -- away. Note the asymmetry of FilePath.normalise:
+     --    Linux:   p/q -> p/q; p\q -> p\q
+     --    Windows: p/q -> p\q; p\q -> p\q
+     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
+     -- to -foo.hs. We have to re-prepend the current directory.
+    normalise_hyp fp
+        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
+        | otherwise                           = nfp
+        where
+#if defined(mingw32_HOST_OS)
+          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
+#else
+          strt_dot_sl = "./" `isPrefixOf` fp
+#endif
+          cur_dir = '.' : [pathSeparator]
+          nfp = normalise fp
+    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
+    (srcs, objs)         = partition_args normal_fileish_paths [] []
+
+    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
+                                   ++ ldInputs dflags4 }
+
+  -- we've finished manipulating the DynFlags, update the session
+  _ <- GHC.setSessionDynFlags dflags5
+  dflags6 <- GHC.getSessionDynFlags
+  hsc_env <- GHC.getSession
+
+        ---------------- Display configuration -----------
+  case verbosity dflags6 of
+    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6
+      | v >= 5 -> liftIO $ dumpPackages dflags6
+      | otherwise -> return ()
+
+  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
+        ---------------- Final sanity checking -----------
+  liftIO $ checkOptions postLoadMode dflags6 srcs objs
+
+  ---------------- Do the business -----------
+  handleSourceError (\e -> do
+       GHC.printException e
+       liftIO $ exitWith (ExitFailure 1)) $ do
+    case postLoadMode of
+       ShowInterface f        -> liftIO $ doShowIface dflags6 f
+       DoMake                 -> doMake srcs
+       DoMkDependHS           -> doMkDependHS (map fst srcs)
+       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
+       DoInteractive          -> ghciUI hsc_env dflags6 srcs Nothing
+       DoEval exprs           -> ghciUI hsc_env dflags6 srcs $ Just $
+                                   reverse exprs
+       DoAbiHash              -> abiHash (map fst srcs)
+       ShowPackages           -> liftIO $ showPackages dflags6
+       DoFrontend f           -> doFrontend f srcs
+       DoBackpack             -> doBackpack (map fst srcs)
+
+  liftIO $ dumpFinalStats dflags6
+
+ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
+       -> Ghc ()
+#if !defined(GHCI)
+ghciUI _ _ _ _ =
+  throwGhcException (CmdLineError "not built for interactive use")
+#else
+ghciUI hsc_env dflags0 srcs maybe_expr = do
+  dflags1 <- liftIO (initializePlugins hsc_env dflags0)
+  _ <- GHC.setSessionDynFlags dflags1
+  interactiveUI defaultGhciSettings srcs maybe_expr
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Splitting arguments into source files and object files.  This is where we
+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
+-- file indicating the phase specified by the -x option in force, if any.
+
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff      = partition_args args srcs objs
+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
+        where phase = startPhase suff
+              (slurp,rest) = break (== "-x") args
+              these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+    {-
+      We split out the object files (.o, .dll) and add them
+      to ldInputs for use by the linker.
+
+      The following things should be considered compilation manager inputs:
+
+       - haskell source files (strings ending in .hs, .lhs or other
+         haskellish extension),
+
+       - module names (not forgetting hierarchical module names),
+
+       - things beginning with '-' are flags that were not recognised by
+         the flag parser, and we want them to generate errors later in
+         checkOptions, so we class them as source files (#5921)
+
+       - and finally we consider everything without an extension to be
+         a comp manager input, as shorthand for a .hs or .lhs filename.
+
+      Everything else is considered to be a linker object, and passed
+      straight through to the linker.
+    -}
+looks_like_an_input :: String -> Bool
+looks_like_an_input m =  isSourceFilename m
+                      || looksLikeModuleName m
+                      || "-" `isPrefixOf` m
+                      || not (hasExtension m)
+
+-- -----------------------------------------------------------------------------
+-- Option sanity checks
+
+-- | Ensure sanity of options.
+--
+-- Throws 'UsageError' or 'CmdLineError' if not.
+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
+     -- Final sanity checking before kicking off a compilation (pipeline).
+checkOptions mode dflags srcs objs = do
+     -- Complain about any unknown flags
+   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
+   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
+
+   when (notNull (filter wayRTSOnly (ways dflags))
+         && isInterpretiveMode mode) $
+        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
+
+        -- -prof and --interactive are not a good combination
+   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
+         && isInterpretiveMode mode
+         && not (gopt Opt_ExternalInterpreter dflags)) $
+      do throwGhcException (UsageError
+              "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
+        -- -ohi sanity check
+   if (isJust (outputHi dflags) &&
+      (isCompManagerMode mode || srcs `lengthExceeds` 1))
+        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
+        else do
+
+        -- -o sanity checking
+   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
+         && not (isLinkMode mode))
+        then throwGhcException (UsageError "can't apply -o to multiple source files")
+        else do
+
+   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
+
+   when (not_linking && not (null objs)) $
+        hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
+
+        -- Check that there are some input files
+        -- (except in the interactive case)
+   if null srcs && (null objs || not_linking) && needsInputsMode mode
+        then throwGhcException (UsageError "no input files")
+        else do
+
+   case mode of
+      StopBefore HCc | hscTarget dflags /= HscC
+        -> throwGhcException $ UsageError $
+           "the option -C is only available with an unregisterised GHC"
+      _ -> return ()
+
+     -- Verify that output files point somewhere sensible.
+   verifyOutputFiles dflags
+
+-- Compiler output options
+
+-- Called to verify that the output files point somewhere valid.
+--
+-- The assumption is that the directory portion of these output
+-- options will have to exist by the time 'verifyOutputFiles'
+-- is invoked.
+--
+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
+-- they don't exist, so don't check for those here (#2278).
+verifyOutputFiles :: DynFlags -> IO ()
+verifyOutputFiles dflags = do
+  let ofile = outputFile dflags
+  when (isJust ofile) $ do
+     let fn = fromJust ofile
+     flg <- doesDirNameExist fn
+     when (not flg) (nonExistentDir "-o" fn)
+  let ohi = outputHi dflags
+  when (isJust ohi) $ do
+     let hi = fromJust ohi
+     flg <- doesDirNameExist hi
+     when (not flg) (nonExistentDir "-ohi" hi)
+ where
+   nonExistentDir flg dir =
+     throwGhcException (CmdLineError ("error: directory portion of " ++
+                             show dir ++ " does not exist (used with " ++
+                             show flg ++ " option.)"))
+
+-----------------------------------------------------------------------------
+-- GHC modes of operation
+
+type Mode = Either PreStartupMode PostStartupMode
+type PostStartupMode = Either PreLoadMode PostLoadMode
+
+data PreStartupMode
+  = ShowVersion                          -- ghc -V/--version
+  | ShowNumVersion                       -- ghc --numeric-version
+  | ShowSupportedExtensions              -- ghc --supported-extensions
+  | ShowOptions Bool {- isInteractive -} -- ghc --show-options
+
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
+showVersionMode             = mkPreStartupMode ShowVersion
+showNumVersionMode          = mkPreStartupMode ShowNumVersion
+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
+showOptionsMode             = mkPreStartupMode (ShowOptions False)
+
+mkPreStartupMode :: PreStartupMode -> Mode
+mkPreStartupMode = Left
+
+isShowVersionMode :: Mode -> Bool
+isShowVersionMode (Left ShowVersion) = True
+isShowVersionMode _ = False
+
+isShowNumVersionMode :: Mode -> Bool
+isShowNumVersionMode (Left ShowNumVersion) = True
+isShowNumVersionMode _ = False
+
+data PreLoadMode
+  = ShowGhcUsage                           -- ghc -?
+  | ShowGhciUsage                          -- ghci -?
+  | ShowInfo                               -- ghc --info
+  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
+
+showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
+showGhcUsageMode = mkPreLoadMode ShowGhcUsage
+showGhciUsageMode = mkPreLoadMode ShowGhciUsage
+showInfoMode = mkPreLoadMode ShowInfo
+
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+                   $ lookup k (compilerInfo dflags)
+
+mkPreLoadMode :: PreLoadMode -> Mode
+mkPreLoadMode = Right . Left
+
+isShowGhcUsageMode :: Mode -> Bool
+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
+isShowGhcUsageMode _ = False
+
+isShowGhciUsageMode :: Mode -> Bool
+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
+isShowGhciUsageMode _ = False
+
+data PostLoadMode
+  = ShowInterface FilePath  -- ghc --show-iface
+  | DoMkDependHS            -- ghc -M
+  | StopBefore Phase        -- ghc -E | -C | -S
+                            -- StopBefore StopLn is the default
+  | DoMake                  -- ghc --make
+  | DoBackpack              -- ghc --backpack foo.bkp
+  | DoInteractive           -- ghc --interactive
+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+  | DoAbiHash               -- ghc --abi-hash
+  | ShowPackages            -- ghc --show-packages
+  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
+
+doMkDependHSMode, doMakeMode, doInteractiveMode,
+  doAbiHashMode, showPackagesMode :: Mode
+doMkDependHSMode = mkPostLoadMode DoMkDependHS
+doMakeMode = mkPostLoadMode DoMake
+doInteractiveMode = mkPostLoadMode DoInteractive
+doAbiHashMode = mkPostLoadMode DoAbiHash
+showPackagesMode = mkPostLoadMode ShowPackages
+
+showInterfaceMode :: FilePath -> Mode
+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+
+stopBeforeMode :: Phase -> Mode
+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
+
+doEvalMode :: String -> Mode
+doEvalMode str = mkPostLoadMode (DoEval [str])
+
+doFrontendMode :: String -> Mode
+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
+
+doBackpackMode :: Mode
+doBackpackMode = mkPostLoadMode DoBackpack
+
+mkPostLoadMode :: PostLoadMode -> Mode
+mkPostLoadMode = Right . Right
+
+isDoInteractiveMode :: Mode -> Bool
+isDoInteractiveMode (Right (Right DoInteractive)) = True
+isDoInteractiveMode _ = False
+
+isStopLnMode :: Mode -> Bool
+isStopLnMode (Right (Right (StopBefore StopLn))) = True
+isStopLnMode _ = False
+
+isDoMakeMode :: Mode -> Bool
+isDoMakeMode (Right (Right DoMake)) = True
+isDoMakeMode _ = False
+
+isDoEvalMode :: Mode -> Bool
+isDoEvalMode (Right (Right (DoEval _))) = True
+isDoEvalMode _ = False
+
+#if defined(GHCI)
+isInteractiveMode :: PostLoadMode -> Bool
+isInteractiveMode DoInteractive = True
+isInteractiveMode _             = False
+#endif
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: PostLoadMode -> Bool
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _)    = True
+isInterpretiveMode _             = False
+
+needsInputsMode :: PostLoadMode -> Bool
+needsInputsMode DoMkDependHS    = True
+needsInputsMode (StopBefore _)  = True
+needsInputsMode DoMake          = True
+needsInputsMode _               = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: PostLoadMode -> Bool
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake              = True
+isLinkMode DoInteractive       = True
+isLinkMode (DoEval _)          = True
+isLinkMode _                   = False
+
+isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoMake        = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _)    = True
+isCompManagerMode _             = False
+
+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [Located String]
+               -> IO (Mode,
+                      [Located String],
+                      [Warn])
+parseModeFlags args = do
+  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
+          runCmdLine (processArgs mode_flags args)
+                     (Nothing, [], [])
+      mode = case mModeFlag of
+             Nothing     -> doMakeMode
+             Just (m, _) -> m
+
+  -- See Note [Handling errors when parsing commandline flags]
+  unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
+      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
+
+  return (mode, flags' ++ leftover, warns)
+
+type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+  -- so we collect the new ones and return them.
+
+mode_flags :: [Flag ModeM]
+mode_flags =
+  [  ------- help / version ----------------------------------------------
+    defFlag "?"                     (PassFlag (setMode showGhcUsageMode))
+  , defFlag "-help"                 (PassFlag (setMode showGhcUsageMode))
+  , defFlag "V"                     (PassFlag (setMode showVersionMode))
+  , defFlag "-version"              (PassFlag (setMode showVersionMode))
+  , defFlag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
+  , defFlag "-info"                 (PassFlag (setMode showInfoMode))
+  , defFlag "-show-options"         (PassFlag (setMode showOptionsMode))
+  , defFlag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
+  , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+  , defFlag "-show-packages"        (PassFlag (setMode showPackagesMode))
+  ] ++
+  [ defFlag k'                      (PassFlag (setMode (printSetting k)))
+  | k <- ["Project version",
+          "Project Git commit id",
+          "Booter version",
+          "Stage",
+          "Build platform",
+          "Host platform",
+          "Target platform",
+          "Have interpreter",
+          "Object splitting supported",
+          "Have native code generator",
+          "Support SMP",
+          "Unregisterised",
+          "Tables next to code",
+          "RTS ways",
+          "Leading underscore",
+          "Debug on",
+          "LibDir",
+          "Global Package DB",
+          "C compiler flags",
+          "C compiler link flags",
+          "ld flags"],
+    let k' = "-print-" ++ map (replaceSpace . toLower) k
+        replaceSpace ' ' = '-'
+        replaceSpace c   = c
+  ] ++
+      ------- interfaces ----------------------------------------------------
+  [ defFlag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
+                                               "--show-iface"))
+
+      ------- primary modes ------------------------------------------------
+  , defFlag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
+                                               addFlag "-no-link" f))
+  , defFlag "M"            (PassFlag (setMode doMkDependHSMode))
+  , defFlag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
+  , defFlag "C"            (PassFlag (setMode (stopBeforeMode HCc)))
+  , defFlag "S"            (PassFlag (setMode (stopBeforeMode (As False))))
+  , defFlag "-make"        (PassFlag (setMode doMakeMode))
+  , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))
+  , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
+  , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
+  , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
+  , defFlag "-frontend"    (SepArg   (\s -> setMode (doFrontendMode s) "-frontend"))
+  ]
+
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
+    (mModeFlag, errs, flags') <- getCmdLineState
+    let (modeFlag', errs') =
+            case mModeFlag of
+            Nothing -> ((newMode, newFlag), errs)
+            Just (oldMode, oldFlag) ->
+                case (oldMode, newMode) of
+                    -- -c/--make are allowed together, and mean --make -no-link
+                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
+                      || isStopLnMode newMode && isDoMakeMode oldMode ->
+                      ((doMakeMode, "--make"), [])
+
+                    -- If we have both --help and --interactive then we
+                    -- want showGhciUsage
+                    _ | isShowGhcUsageMode oldMode &&
+                        isDoInteractiveMode newMode ->
+                            ((showGhciUsageMode, oldFlag), [])
+                      | isShowGhcUsageMode newMode &&
+                        isDoInteractiveMode oldMode ->
+                            ((showGhciUsageMode, newFlag), [])
+
+                    -- If we have both -e and --interactive then -e always wins
+                    _ | isDoEvalMode oldMode &&
+                        isDoInteractiveMode newMode ->
+                            ((oldMode, oldFlag), [])
+                      | isDoEvalMode newMode &&
+                        isDoInteractiveMode oldMode ->
+                            ((newMode, newFlag), [])
+
+                    -- Otherwise, --help/--version/--numeric-version always win
+                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
+                      | isDominantFlag newMode -> ((newMode, newFlag), [])
+                    -- We need to accumulate eval flags like "-e foo -e bar"
+                    (Right (Right (DoEval esOld)),
+                     Right (Right (DoEval [eNew]))) ->
+                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
+                         errs)
+                    -- Saying e.g. --interactive --interactive is OK
+                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
+
+                    -- --interactive and --show-options are used together
+                    (Right (Right DoInteractive), Left (ShowOptions _)) ->
+                      ((Left (ShowOptions True),
+                        "--interactive --show-options"), errs)
+                    (Left (ShowOptions _), (Right (Right DoInteractive))) ->
+                      ((Left (ShowOptions True),
+                        "--show-options --interactive"), errs)
+                    -- Otherwise, complain
+                    _ -> let err = flagMismatchErr oldFlag newFlag
+                         in ((oldMode, oldFlag), err : errs)
+    putCmdLineState (Just modeFlag', errs', flags')
+  where isDominantFlag f = isShowGhcUsageMode   f ||
+                           isShowGhciUsageMode  f ||
+                           isShowVersionMode    f ||
+                           isShowNumVersionMode f
+
+flagMismatchErr :: String -> String -> String
+flagMismatchErr oldFlag newFlag
+    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"
+
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
+  (m, e, flags') <- getCmdLineState
+  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
+    where loc = "addFlag by " ++ flag ++ " on the commandline"
+
+-- ----------------------------------------------------------------------------
+-- Run --make mode
+
+doMake :: [(String,Maybe Phase)] -> Ghc ()
+doMake srcs  = do
+    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
+
+    hsc_env <- GHC.getSession
+
+    -- if we have no haskell sources from which to do a dependency
+    -- analysis, then just do one-shot compilation and/or linking.
+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+    -- we expect.
+    if (null hs_srcs)
+       then liftIO (oneShot hsc_env StopLn srcs)
+       else do
+
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+                 non_hs_srcs
+    dflags <- GHC.getSessionDynFlags
+    let dflags' = dflags { ldInputs = map (FileOption "") o_files
+                                      ++ ldInputs dflags }
+    _ <- GHC.setSessionDynFlags dflags'
+
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets targets
+    ok_flag <- GHC.load LoadAllTargets
+
+    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+    return ()
+
+
+-- ---------------------------------------------------------------------------
+-- --show-iface mode
+
+doShowIface :: DynFlags -> FilePath -> IO ()
+doShowIface dflags file = do
+  hsc_env <- newHscEnv dflags
+  showIface hsc_env file
+
+-- ---------------------------------------------------------------------------
+-- Various banners and verbosity output.
+
+showBanner :: PostLoadMode -> DynFlags -> IO ()
+showBanner _postLoadMode dflags = do
+   let verb = verbosity dflags
+
+#if defined(GHCI)
+   -- Show the GHCi banner
+   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
+#endif
+
+   -- Display details of the configuration in verbose mode
+   when (verb >= 2) $
+    do hPutStr stderr "Glasgow Haskell Compiler, Version "
+       hPutStr stderr cProjectVersion
+       hPutStr stderr ", stage "
+       hPutStr stderr cStage
+       hPutStr stderr " booted by GHC version "
+       hPutStrLn stderr cBooterVersion
+
+-- We print out a Read-friendly string, but a prettier one than the
+-- Show instance gives us
+showInfo :: DynFlags -> IO ()
+showInfo dflags = do
+        let sq x = " [" ++ x ++ "\n ]"
+        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
+
+showSupportedExtensions :: IO ()
+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
+
+showVersion :: IO ()
+showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
+
+showOptions :: Bool -> IO ()
+showOptions isInteractive = putStr (unlines availableOptions)
+    where
+      availableOptions = concat [
+        flagsForCompletion isInteractive,
+        map ('-':) (getFlagNames mode_flags)
+        ]
+      getFlagNames opts         = map flagName opts
+
+showGhcUsage :: DynFlags -> IO ()
+showGhcUsage = showUsage False
+
+showGhciUsage :: DynFlags -> IO ()
+showGhciUsage = showUsage True
+
+showUsage :: Bool -> DynFlags -> IO ()
+showUsage ghci dflags = do
+  let usage_path = if ghci then ghciUsagePath dflags
+                           else ghcUsagePath dflags
+  usage <- readFile usage_path
+  dump usage
+  where
+     dump ""          = return ()
+     dump ('$':'$':s) = putStr progName >> dump s
+     dump (c:s)       = putChar c >> dump s
+
+dumpFinalStats :: DynFlags -> IO ()
+dumpFinalStats dflags =
+  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+
+dumpFastStringStats :: DynFlags -> IO ()
+dumpFastStringStats dflags = do
+  segments <- getFastStringTable
+  let buckets = concat segments
+      bucketsPerSegment = map length segments
+      entriesPerBucket = map length buckets
+      entries = sum entriesPerBucket
+      hasZ = sum $ map (length . filter hasZEncoding) buckets
+      msg = text "FastString stats:" $$ nest 4 (vcat
+        [ text "segments:         " <+> int (length segments)
+        , text "buckets:          " <+> int (sum bucketsPerSegment)
+        , text "entries:          " <+> int entries
+        , text "largest segment:  " <+> int (maximum bucketsPerSegment)
+        , text "smallest segment: " <+> int (minimum bucketsPerSegment)
+        , text "longest bucket:   " <+> int (maximum entriesPerBucket)
+        , text "has z-encoding:   " <+> (hasZ `pcntOf` entries)
+        ])
+        -- we usually get more "has z-encoding" than "z-encoded", because
+        -- when we z-encode a string it might hash to the exact same string,
+        -- which is not counted as "z-encoded".  Only strings whose
+        -- Z-encoding is different from the original string are counted in
+        -- the "z-encoded" total.
+  putMsg dflags msg
+  where
+   x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
+
+showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
+showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))
+dumpPackages       dflags = putMsg dflags (pprPackages dflags)
+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
+
+-- -----------------------------------------------------------------------------
+-- Frontend plugin support
+
+doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
+#if !defined(GHCI)
+doFrontend modname _ = pluginError [modname]
+#else
+doFrontend modname srcs = do
+    hsc_env <- getSession
+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
+    frontend frontend_plugin
+      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
+#endif
+
+-- -----------------------------------------------------------------------------
+-- ABI hash support
+
+{-
+        ghc --abi-hash Data.Foo System.Bar
+
+Generates a combined hash of the ABI for modules Data.Foo and
+System.Bar.  The modules must already be compiled, and appropriate -i
+options may be necessary in order to find the .hi files.
+
+This is used by Cabal for generating the ComponentId for a
+package.  The ComponentId must change when the visible ABI of
+the package chagnes, so during registration Cabal calls ghc --abi-hash
+to get a hash of the package's ABI.
+-}
+
+-- | Print ABI hash of input modules.
+--
+-- The resulting hash is the MD5 of the GHC version used (#5328,
+-- see 'hiVersion') and of the existing ABI hash from each module (see
+-- 'mi_mod_hash').
+abiHash :: [String] -- ^ List of module names
+        -> Ghc ()
+abiHash strs = do
+  hsc_env <- getSession
+  let dflags = hsc_dflags hsc_env
+
+  liftIO $ do
+
+  let find_it str = do
+         let modname = mkModuleName str
+         r <- findImportedModule hsc_env modname Nothing
+         case r of
+           Found _ m -> return m
+           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
+                          cannotFindModule dflags modname r
+
+  mods <- mapM find_it strs
+
+  let get_iface modl = loadUserInterface False (text "abiHash") modl
+  ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods
+
+  bh <- openBinMem (3*1024) -- just less than a block
+  put_ bh hiVersion
+    -- package hashes change when the compiler version changes (for now)
+    -- see #5328
+  mapM_ (put_ bh . mi_mod_hash) ifaces
+  f <- fingerprintBinMem bh
+
+  putStrLn (showPpr dflags f)
+
+-- -----------------------------------------------------------------------------
+-- Util
+
+unknownFlagsErr :: [String] -> a
+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
+  where
+    oneError f =
+        "unrecognised flag: " ++ f ++ "\n" ++
+        (case match f (nubSort allNonDeprecatedFlags) of
+            [] -> ""
+            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))
+    -- fixes #11789
+    -- If the flag contains '=',
+    -- this uses both the whole and the left side of '=' for comparing.
+    match f allFlags
+        | elem '=' f =
+              let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags
+                  fName = takeWhile (/= '=') f
+              in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)
+        | otherwise = fuzzyMatch f allFlags
+
+{- Note [-Bsymbolic and hooks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Bsymbolic is a flag that prevents the binding of references to global
+symbols to symbols outside the shared library being compiled (see `man
+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
+package: that is because we want hooks to be overridden by the user,
+we don't want to constrain them to the RTS package.
+
+Unfortunately this seems to have broken somehow on OS X: as a result,
+defaultHooks (in hschooks.c) is not called, which does not initialize
+the GC stats. As a result, this breaks things like `:set +s` in GHCi
+(#8754). As a hacky workaround, we instead call 'defaultHooks'
+directly to initalize the flags in the RTS.
+
+A byproduct of this, I believe, is that hooks are likely broken on OS
+X when dynamically linking. But this probably doesn't affect most
+people since we're linking GHC dynamically, but most things themselves
+link statically.
+-}
+
+-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then
+-- running it causes an error like this:
+--
+-- Loading temp shared object failed:
+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics
+--
+-- Skipping the foreign call fixes this problem, and the outer GHCi
+-- should have already made this call anyway.
+#if defined(GHC_LOADED_INTO_GHCI)
+initGCStatistics :: IO ()
+initGCStatistics = return ()
+#else
+foreign import ccall safe "initGCStatistics"
+  initGCStatistics :: IO ()
+#endif
diff --git a/includes/Cmm.h b/includes/Cmm.h
new file mode 100644
--- /dev/null
+++ b/includes/Cmm.h
@@ -0,0 +1,936 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2004-2013
+ *
+ * This file is included at the top of all .cmm source files (and
+ * *only* .cmm files).  It defines a collection of useful macros for
+ * making .cmm code a bit less error-prone to write, and a bit easier
+ * on the eye for the reader.
+ *
+ * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * Accessing fields of structures defined in the RTS header files is
+ * done via automatically-generated macros in DerivedConstants.h.  For
+ * example, where previously we used
+ *
+ *          CurrentTSO->what_next = x
+ *
+ * in C-- we now use
+ *
+ *          StgTSO_what_next(CurrentTSO) = x
+ *
+ * where the StgTSO_what_next() macro is automatically generated by
+ * mkDerivedConstants.c.  If you need to access a field that doesn't
+ * already have a macro, edit that file (it's pretty self-explanatory).
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * In files that are included into both C and C-- (and perhaps
+ * Haskell) sources, we sometimes need to conditionally compile bits
+ * depending on the language.  CMINUSMINUS==1 in .cmm sources:
+ */
+#define CMINUSMINUS 1
+
+#include "ghcconfig.h"
+
+/* -----------------------------------------------------------------------------
+   Types
+
+   The following synonyms for C-- types are declared here:
+
+     I8, I16, I32, I64    MachRep-style names for convenience
+
+     W_                   is shorthand for the word type (== StgWord)
+     F_                   shorthand for float  (F_ == StgFloat == C's float)
+     D_                   shorthand for double (D_ == StgDouble == C's double)
+
+     CInt                 has the same size as an int in C on this platform
+     CLong                has the same size as a long in C on this platform
+     CBool                has the same size as a bool in C on this platform
+
+  --------------------------------------------------------------------------- */
+
+#define I8  bits8
+#define I16 bits16
+#define I32 bits32
+#define I64 bits64
+#define P_  gcptr
+
+#if SIZEOF_VOID_P == 4
+#define W_ bits32
+/* Maybe it's better to include MachDeps.h */
+#define TAG_BITS                2
+#elif SIZEOF_VOID_P == 8
+#define W_ bits64
+/* Maybe it's better to include MachDeps.h */
+#define TAG_BITS                3
+#else
+#error Unknown word size
+#endif
+
+/*
+ * The RTS must sometimes UNTAG a pointer before dereferencing it.
+ * See the wiki page commentary/rts/haskell-execution/pointer-tagging
+ */
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+#define UNTAG(p) (p & ~TAG_MASK)
+#define GETTAG(p) (p & TAG_MASK)
+
+#if SIZEOF_INT == 4
+#define CInt bits32
+#elif SIZEOF_INT == 8
+#define CInt bits64
+#else
+#error Unknown int size
+#endif
+
+#if SIZEOF_LONG == 4
+#define CLong bits32
+#elif SIZEOF_LONG == 8
+#define CLong bits64
+#else
+#error Unknown long size
+#endif
+
+#define CBool bits8
+
+#define F_   float32
+#define D_   float64
+#define L_   bits64
+#define V16_ bits128
+#define V32_ bits256
+#define V64_ bits512
+
+#define SIZEOF_StgDouble 8
+#define SIZEOF_StgWord64 8
+
+/* -----------------------------------------------------------------------------
+   Misc useful stuff
+   -------------------------------------------------------------------------- */
+
+#define ccall foreign "C"
+
+#define NULL (0::W_)
+
+#define STRING(name,str)                        \
+  section "rodata" {                            \
+        name : bits8[] str;                     \
+  }                                             \
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define RET_LBL(f) f##_info
+#else
+#define RET_LBL(f) f##_ret
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define ENTRY_LBL(f) f##_info
+#else
+#define ENTRY_LBL(f) f##_entry
+#endif
+
+/* -----------------------------------------------------------------------------
+   Byte/word macros
+
+   Everything in C-- is in byte offsets (well, most things).  We use
+   some macros to allow us to express offsets in words and to try to
+   avoid byte/word confusion.
+   -------------------------------------------------------------------------- */
+
+#define SIZEOF_W  SIZEOF_VOID_P
+#define W_MASK    (SIZEOF_W-1)
+
+#if SIZEOF_W == 4
+#define W_SHIFT 2
+#elif SIZEOF_W == 8
+#define W_SHIFT 3
+#endif
+
+/* Converting quantities of words to bytes */
+#define WDS(n) ((n)*SIZEOF_W)
+
+/*
+ * Converting quantities of bytes to words
+ * NB. these work on *unsigned* values only
+ */
+#define BYTES_TO_WDS(n) ((n) / SIZEOF_W)
+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W)
+
+/*
+ * TO_W_(n) and TO_ZXW_(n) convert n to W_ type from a smaller type,
+ * with and without sign extension respectively
+ */
+#if SIZEOF_W == 4
+#define TO_I64(x) %sx64(x)
+#define TO_W_(x) %sx32(x)
+#define TO_ZXW_(x) %zx32(x)
+#define HALF_W_(x) %lobits16(x)
+#elif SIZEOF_W == 8
+#define TO_I64(x) (x)
+#define TO_W_(x) %sx64(x)
+#define TO_ZXW_(x) %zx64(x)
+#define HALF_W_(x) %lobits32(x)
+#endif
+
+#if SIZEOF_INT == 4 && SIZEOF_W == 8
+#define W_TO_INT(x) %lobits32(x)
+#elif SIZEOF_INT == SIZEOF_W
+#define W_TO_INT(x) (x)
+#endif
+
+#if SIZEOF_LONG == 4 && SIZEOF_W == 8
+#define W_TO_LONG(x) %lobits32(x)
+#elif SIZEOF_LONG == SIZEOF_W
+#define W_TO_LONG(x) (x)
+#endif
+
+/* -----------------------------------------------------------------------------
+   Atomic memory operations.
+   -------------------------------------------------------------------------- */
+
+#if SIZEOF_W == 4
+#define cmpxchgW cmpxchg32
+#elif SIZEOF_W == 8
+#define cmpxchgW cmpxchg64
+#endif
+
+/* -----------------------------------------------------------------------------
+   Heap/stack access, and adjusting the heap/stack pointers.
+   -------------------------------------------------------------------------- */
+
+#define Sp(n)  W_[Sp + WDS(n)]
+#define Hp(n)  W_[Hp + WDS(n)]
+
+#define Sp_adj(n) Sp = Sp + WDS(n)  /* pronounced "spadge" */
+#define Hp_adj(n) Hp = Hp + WDS(n)
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+   -------------------------------------------------------------------------- */
+
+#if defined(DEBUG)
+#define ASSERT(predicate)                       \
+        if (predicate) {                        \
+            /*null*/;                           \
+        } else {                                \
+            foreign "C" _assertFail(__FILE__, __LINE__) never returns; \
+        }
+#else
+#define ASSERT(p) /* nothing */
+#endif
+
+#if defined(DEBUG)
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) /* nothing */
+#endif
+
+/*
+ * The IF_DEBUG macro is useful for debug messages that depend on one
+ * of the RTS debug options.  For example:
+ *
+ *   IF_DEBUG(RtsFlags_DebugFlags_apply,
+ *      foreign "C" fprintf(stderr, stg_ap_0_ret_str));
+ *
+ * Note the syntax is slightly different to the C version of this macro.
+ */
+#if defined(DEBUG)
+#define IF_DEBUG(c,s)  if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; }
+#else
+#define IF_DEBUG(c,s)  /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+   Entering
+
+   It isn't safe to "enter" every closure.  Functions in particular
+   have no entry code as such; their entry point contains the code to
+   apply the function.
+
+   ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,
+   but switch doesn't allow us to use exprs there yet.
+
+   If R1 points to a tagged object it points either to
+   * A constructor.
+   * A function with arity <= TAG_MASK.
+   In both cases the right thing to do is to return.
+   Note: it is rather lucky that we can use the tag bits to do this
+         for both objects. Maybe it points to a brittle design?
+
+   Indirections can contain tagged pointers, so their tag is checked.
+   -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+
+// When profiling, we cannot shortcut ENTER() by checking the tag,
+// because LDV profiling relies on entering closures to mark them as
+// "used".
+
+#define LOAD_INFO(ret,x)                        \
+    info = %INFO_PTR(UNTAG(x));
+
+#define UNTAG_IF_PROF(x) UNTAG(x)
+
+#else
+
+#define LOAD_INFO(ret,x)                        \
+  if (GETTAG(x) != 0) {                         \
+      ret(x);                                   \
+  }                                             \
+  info = %INFO_PTR(x);
+
+#define UNTAG_IF_PROF(x) (x) /* already untagged */
+
+#endif
+
+// We need two versions of ENTER():
+//  - ENTER(x) takes the closure as an argument and uses return(),
+//    for use in civilized code where the stack is handled by GHC
+//
+//  - ENTER_NOSTACK() where the closure is in R1, and returns are
+//    explicit jumps, for use when we are doing the stack management
+//    ourselves.
+
+#if defined(PROFILING)
+// See Note [Evaluating functions with profiling] in rts/Apply.cmm
+#define ENTER(x) jump stg_ap_0_fast(x);
+#else
+#define ENTER(x) ENTER_(return,x)
+#endif
+
+#define ENTER_R1() ENTER_(RET_R1,R1)
+
+#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1]
+
+#define ENTER_(ret,x)                                   \
+ again:                                                 \
+  W_ info;                                              \
+  LOAD_INFO(ret,x)                                       \
+  switch [INVALID_OBJECT .. N_CLOSURE_TYPES]            \
+         (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {       \
+  case                                                  \
+    IND,                                                \
+    IND_STATIC:                                         \
+   {                                                    \
+      x = StgInd_indirectee(x);                         \
+      goto again;                                       \
+   }                                                    \
+  case                                                  \
+    FUN,                                                \
+    FUN_1_0,                                            \
+    FUN_0_1,                                            \
+    FUN_2_0,                                            \
+    FUN_1_1,                                            \
+    FUN_0_2,                                            \
+    FUN_STATIC,                                         \
+    BCO,                                                \
+    PAP:                                                \
+   {                                                    \
+       ret(x);                                          \
+   }                                                    \
+  default:                                              \
+   {                                                    \
+       x = UNTAG_IF_PROF(x);                            \
+       jump %ENTRY_CODE(info) (x);                      \
+   }                                                    \
+  }
+
+// The FUN cases almost never happen: a pointer to a non-static FUN
+// should always be tagged.  This unfortunately isn't true for the
+// interpreter right now, which leaves untagged FUNs on the stack.
+
+/* -----------------------------------------------------------------------------
+   Constants.
+   -------------------------------------------------------------------------- */
+
+#include "rts/Constants.h"
+#include "DerivedConstants.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/FunTypes.h"
+#include "rts/OSThreads.h"
+
+/*
+ * Need MachRegs, because some of the RTS code is conditionally
+ * compiled based on REG_R1, REG_R2, etc.
+ */
+#include "stg/RtsMachRegs.h"
+
+#include "rts/prof/LDV.h"
+
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#include "rts/storage/Block.h"  /* For Bdescr() */
+
+
+#define MyCapability()  (BaseReg - OFFSET_Capability_r)
+
+/* -------------------------------------------------------------------------
+   Info tables
+   ------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define PROF_HDR_FIELDS(w_,hdr1,hdr2)          \
+  w_ hdr1,                                     \
+  w_ hdr2,
+#else
+#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */
+#endif
+
+/* -------------------------------------------------------------------------
+   Allocation and garbage collection
+   ------------------------------------------------------------------------- */
+
+/*
+ * ALLOC_PRIM is for allocating memory on the heap for a primitive
+ * object.  It is used all over PrimOps.cmm.
+ *
+ * We make the simplifying assumption that the "admin" part of a
+ * primitive closure is just the header when calculating sizes for
+ * ticky-ticky.  It's not clear whether eg. the size field of an array
+ * should be counted as "admin", or the various fields of a BCO.
+ */
+#define ALLOC_PRIM(bytes)                                       \
+   HP_CHK_GEN_TICKY(bytes);                                     \
+   TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0);  \
+   CCCS_ALLOC(bytes);
+
+#define HEAP_CHECK(bytes,failure)                       \
+    TICK_BUMP(HEAP_CHK_ctr);                            \
+    Hp = Hp + (bytes);                                  \
+    if (Hp > HpLim) { HpAlloc = (bytes); failure; }     \
+    TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure)           \
+    HEAP_CHECK(bytes,failure)                                   \
+    TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
+    CCCS_ALLOC(bytes);
+
+#define ALLOC_PRIM_(bytes,fun)                                  \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun));
+
+#define ALLOC_PRIM_P(bytes,fun,arg)                             \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));
+
+#define ALLOC_PRIM_N(bytes,fun,arg)                             \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg));
+
+/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */
+#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS)
+
+#define HP_CHK_GEN_TICKY(bytes)                 \
+   HP_CHK_GEN(bytes);                           \
+   TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define HP_CHK_P(bytes, fun, arg)               \
+   HEAP_CHECK(bytes, GC_PRIM_P(fun,arg))
+
+// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed?
+//         -NSF March 2013
+#define ALLOC_P_TICKY(bytes, fun, arg)          \
+   HP_CHK_P(bytes);                             \
+   TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define CHECK_GC()                                                      \
+  (bdescr_link(CurrentNursery) == NULL ||                               \
+   generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))
+
+// allocate() allocates from the nursery, so we check to see
+// whether the nursery is nearly empty in any function that uses
+// allocate() - this includes many of the primops.
+//
+// HACK alert: the __L__ stuff is here to coax the common-block
+// eliminator into commoning up the call stg_gc_noregs() with the same
+// code that gets generated by a STK_CHK_GEN() in the same proc.  We
+// also need an if (0) { goto __L__; } so that the __L__ label isn't
+// optimised away by the control-flow optimiser prior to common-block
+// elimination (it will be optimised away later).
+//
+// This saves some code in gmp-wrappers.cmm where we have lots of
+// MAYBE_GC() in the same proc as STK_CHK_GEN().
+//
+#define MAYBE_GC(retry)                         \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        goto __L__;                             \
+  __L__:                                        \
+        call stg_gc_noregs();                   \
+        goto retry;                             \
+   }                                            \
+   if (0) { goto __L__; }
+
+#define GC_PRIM(fun)                            \
+        jump stg_gc_prim(fun);
+
+// Version of GC_PRIM for use in low-level Cmm.  We can call
+// stg_gc_prim, because it takes one argument and therefore has a
+// platform-independent calling convention (Note [Syntax of .cmm
+// files] in CmmParse.y).
+#define GC_PRIM_LL(fun)                         \
+        R1 = fun;                               \
+        jump stg_gc_prim [R1];
+
+// We pass the fun as the second argument, because the arg is
+// usually already in the first argument position (R1), so this
+// avoids moving it to a different register / stack slot.
+#define GC_PRIM_N(fun,arg)                      \
+        jump stg_gc_prim_n(arg,fun);
+
+#define GC_PRIM_P(fun,arg)                      \
+        jump stg_gc_prim_p(arg,fun);
+
+#define GC_PRIM_P_LL(fun,arg)                   \
+        R1 = arg;                               \
+        R2 = fun;                               \
+        jump stg_gc_prim_p_ll [R1,R2];
+
+#define GC_PRIM_PP(fun,arg1,arg2)               \
+        jump stg_gc_prim_pp(arg1,arg2,fun);
+
+#define MAYBE_GC_(fun)                          \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM(fun)                            \
+   }
+
+#define MAYBE_GC_N(fun,arg)                     \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_N(fun,arg)                      \
+   }
+
+#define MAYBE_GC_P(fun,arg)                     \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_P(fun,arg)                      \
+   }
+
+#define MAYBE_GC_PP(fun,arg1,arg2)              \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_PP(fun,arg1,arg2)               \
+   }
+
+#define STK_CHK_LL(n, fun)                      \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        GC_PRIM_LL(fun)                         \
+    }
+
+#define STK_CHK_P_LL(n, fun, arg)               \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        GC_PRIM_P_LL(fun,arg)                   \
+    }
+
+#define STK_CHK_PP(n, fun, arg1, arg2)          \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        GC_PRIM_PP(fun,arg1,arg2)               \
+    }
+
+#define STK_CHK_ENTER(n, closure)               \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        jump __stg_gc_enter_1(closure);         \
+    }
+
+// A funky heap check used by AutoApply.cmm
+
+#define HP_CHK_NP_ASSIGN_SP0(size,f)                    \
+    HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];)
+
+/* -----------------------------------------------------------------------------
+   Closure headers
+   -------------------------------------------------------------------------- */
+
+/*
+ * This is really ugly, since we don't do the rest of StgHeader this
+ * way.  The problem is that values from DerivedConstants.h cannot be
+ * dependent on the way (SMP, PROF etc.).  For SIZEOF_StgHeader we get
+ * the value from GHC, but it seems like too much trouble to do that
+ * for StgThunkHeader.
+ */
+#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader
+
+#define StgThunk_payload(__ptr__,__ix__) \
+    W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)]
+
+/* -----------------------------------------------------------------------------
+   Closures
+   -------------------------------------------------------------------------- */
+
+/* The offset of the payload of an array */
+#define BYTE_ARR_CTS(arr)  ((arr) + SIZEOF_StgArrBytes)
+
+/* The number of words allocated in an array payload */
+#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr))
+
+/* Getting/setting the info pointer of a closure */
+#define SET_INFO(p,info) StgHeader_info(p) = info
+#define GET_INFO(p) StgHeader_info(p)
+
+/* Determine the size of an ordinary closure from its info table */
+#define sizeW_fromITBL(itbl) \
+  SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl))
+
+/* NB. duplicated from InfoTables.h! */
+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
+
+/* Debugging macros */
+#define LOOKS_LIKE_INFO_PTR(p)                                  \
+   ((p) != NULL &&                                              \
+    LOOKS_LIKE_INFO_PTR_NOT_NULL(p))
+
+#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p)                         \
+   ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) &&     \
+     (TO_W_(%INFO_TYPE(%STD_INFO(p))) <  N_CLOSURE_TYPES))
+
+#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p))))
+
+/*
+ * The layout of the StgFunInfoExtra part of an info table changes
+ * depending on TABLES_NEXT_TO_CODE.  So we define field access
+ * macros which use the appropriate version here:
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+/*
+ * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset
+ * instead of the normal pointer.
+ */
+
+#define StgFunInfoExtra_slow_apply(fun_info)    \
+        (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info))    \
+               + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable)
+
+#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraRev_fun_type(i)
+#define StgFunInfoExtra_arity(i)      StgFunInfoExtraRev_arity(i)
+#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraRev_bitmap(i)
+#else
+#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i)
+#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraFwd_fun_type(i)
+#define StgFunInfoExtra_arity(i)      StgFunInfoExtraFwd_arity(i)
+#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)
+#endif
+
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
+
+#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
+#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size)
+#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
+#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n)
+#else
+#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */
+#define OVERWRITING_CLOSURE(c) /* nothing */
+#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
+#endif
+
+#if defined(THREADED_RTS)
+#define prim_write_barrier prim %write_barrier()
+#else
+#define prim_write_barrier /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+   Ticky macros
+   -------------------------------------------------------------------------- */
+
+#if defined(TICKY_TICKY)
+#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n
+#else
+#define TICK_BUMP_BY(ctr,n) /* nothing */
+#endif
+
+#define TICK_BUMP(ctr)      TICK_BUMP_BY(ctr,1)
+
+#define TICK_ENT_DYN_IND()              TICK_BUMP(ENT_DYN_IND_ctr)
+#define TICK_ENT_DYN_THK()              TICK_BUMP(ENT_DYN_THK_ctr)
+#define TICK_ENT_VIA_NODE()             TICK_BUMP(ENT_VIA_NODE_ctr)
+#define TICK_ENT_STATIC_IND()           TICK_BUMP(ENT_STATIC_IND_ctr)
+#define TICK_ENT_PERM_IND()             TICK_BUMP(ENT_PERM_IND_ctr)
+#define TICK_ENT_PAP()                  TICK_BUMP(ENT_PAP_ctr)
+#define TICK_ENT_AP()                   TICK_BUMP(ENT_AP_ctr)
+#define TICK_ENT_AP_STACK()             TICK_BUMP(ENT_AP_STACK_ctr)
+#define TICK_ENT_BH()                   TICK_BUMP(ENT_BH_ctr)
+#define TICK_ENT_LNE()                  TICK_BUMP(ENT_LNE_ctr)
+#define TICK_UNKNOWN_CALL()             TICK_BUMP(UNKNOWN_CALL_ctr)
+#define TICK_UPDF_PUSHED()              TICK_BUMP(UPDF_PUSHED_ctr)
+#define TICK_CATCHF_PUSHED()            TICK_BUMP(CATCHF_PUSHED_ctr)
+#define TICK_UPDF_OMITTED()             TICK_BUMP(UPDF_OMITTED_ctr)
+#define TICK_UPD_NEW_IND()              TICK_BUMP(UPD_NEW_IND_ctr)
+#define TICK_UPD_NEW_PERM_IND()         TICK_BUMP(UPD_NEW_PERM_IND_ctr)
+#define TICK_UPD_OLD_IND()              TICK_BUMP(UPD_OLD_IND_ctr)
+#define TICK_UPD_OLD_PERM_IND()         TICK_BUMP(UPD_OLD_PERM_IND_ctr)
+
+#define TICK_SLOW_CALL_FUN_TOO_FEW()    TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr)
+#define TICK_SLOW_CALL_FUN_CORRECT()    TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr)
+#define TICK_SLOW_CALL_FUN_TOO_MANY()   TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr)
+#define TICK_SLOW_CALL_PAP_TOO_FEW()    TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr)
+#define TICK_SLOW_CALL_PAP_CORRECT()    TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr)
+#define TICK_SLOW_CALL_PAP_TOO_MANY()   TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr)
+
+#define TICK_SLOW_CALL_fast_v16()       TICK_BUMP(SLOW_CALL_fast_v16_ctr)
+#define TICK_SLOW_CALL_fast_v()         TICK_BUMP(SLOW_CALL_fast_v_ctr)
+#define TICK_SLOW_CALL_fast_p()         TICK_BUMP(SLOW_CALL_fast_p_ctr)
+#define TICK_SLOW_CALL_fast_pv()        TICK_BUMP(SLOW_CALL_fast_pv_ctr)
+#define TICK_SLOW_CALL_fast_pp()        TICK_BUMP(SLOW_CALL_fast_pp_ctr)
+#define TICK_SLOW_CALL_fast_ppv()       TICK_BUMP(SLOW_CALL_fast_ppv_ctr)
+#define TICK_SLOW_CALL_fast_ppp()       TICK_BUMP(SLOW_CALL_fast_ppp_ctr)
+#define TICK_SLOW_CALL_fast_pppv()      TICK_BUMP(SLOW_CALL_fast_pppv_ctr)
+#define TICK_SLOW_CALL_fast_pppp()      TICK_BUMP(SLOW_CALL_fast_pppp_ctr)
+#define TICK_SLOW_CALL_fast_ppppp()     TICK_BUMP(SLOW_CALL_fast_ppppp_ctr)
+#define TICK_SLOW_CALL_fast_pppppp()    TICK_BUMP(SLOW_CALL_fast_pppppp_ctr)
+#define TICK_VERY_SLOW_CALL()           TICK_BUMP(VERY_SLOW_CALL_ctr)
+
+/* NOTE: TICK_HISTO_BY and TICK_HISTO
+   currently have no effect.
+   The old code for it didn't typecheck and I
+   just commented it out to get ticky to work.
+   - krc 1/2007 */
+
+#define TICK_HISTO_BY(histo,n,i) /* nothing */
+
+#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)
+
+/* An unboxed tuple with n components. */
+#define TICK_RET_UNBOXED_TUP(n)                 \
+  TICK_BUMP(RET_UNBOXED_TUP_ctr++);             \
+  TICK_HISTO(RET_UNBOXED_TUP,n)
+
+/*
+ * A slow call with n arguments.  In the unevald case, this call has
+ * already been counted once, so don't count it again.
+ */
+#define TICK_SLOW_CALL(n)                       \
+  TICK_BUMP(SLOW_CALL_ctr);                     \
+  TICK_HISTO(SLOW_CALL,n)
+
+/*
+ * This slow call was found to be to an unevaluated function; undo the
+ * ticks we did in TICK_SLOW_CALL.
+ */
+#define TICK_SLOW_CALL_UNEVALD(n)               \
+  TICK_BUMP(SLOW_CALL_UNEVALD_ctr);             \
+  TICK_BUMP_BY(SLOW_CALL_ctr,-1);               \
+  TICK_HISTO_BY(SLOW_CALL,n,-1);
+
+/* Updating a closure with a new CON */
+#define TICK_UPD_CON_IN_NEW(n)                  \
+  TICK_BUMP(UPD_CON_IN_NEW_ctr);                \
+  TICK_HISTO(UPD_CON_IN_NEW,n)
+
+#define TICK_ALLOC_HEAP_NOCTR(bytes)            \
+    TICK_BUMP(ALLOC_RTS_ctr);                   \
+    TICK_BUMP_BY(ALLOC_RTS_tot,bytes)
+
+/* -----------------------------------------------------------------------------
+   Saving and restoring STG registers
+
+   STG registers must be saved around a C call, just in case the STG
+   register is mapped to a caller-saves machine register.  Normally we
+   don't need to worry about this the code generator has already
+   loaded any live STG registers into variables for us, but in
+   hand-written low-level Cmm code where we don't know which registers
+   are live, we might have to save them all.
+   -------------------------------------------------------------------------- */
+
+#define SAVE_STGREGS                            \
+    W_ r1, r2, r3,  r4,  r5,  r6,  r7,  r8;     \
+    F_ f1, f2, f3, f4, f5, f6;                  \
+    D_ d1, d2, d3, d4, d5, d6;                  \
+    L_ l1;                                      \
+                                                \
+    r1 = R1;                                    \
+    r2 = R2;                                    \
+    r3 = R3;                                    \
+    r4 = R4;                                    \
+    r5 = R5;                                    \
+    r6 = R6;                                    \
+    r7 = R7;                                    \
+    r8 = R8;                                    \
+                                                \
+    f1 = F1;                                    \
+    f2 = F2;                                    \
+    f3 = F3;                                    \
+    f4 = F4;                                    \
+    f5 = F5;                                    \
+    f6 = F6;                                    \
+                                                \
+    d1 = D1;                                    \
+    d2 = D2;                                    \
+    d3 = D3;                                    \
+    d4 = D4;                                    \
+    d5 = D5;                                    \
+    d6 = D6;                                    \
+                                                \
+    l1 = L1;
+
+
+#define RESTORE_STGREGS                         \
+    R1 = r1;                                    \
+    R2 = r2;                                    \
+    R3 = r3;                                    \
+    R4 = r4;                                    \
+    R5 = r5;                                    \
+    R6 = r6;                                    \
+    R7 = r7;                                    \
+    R8 = r8;                                    \
+                                                \
+    F1 = f1;                                    \
+    F2 = f2;                                    \
+    F3 = f3;                                    \
+    F4 = f4;                                    \
+    F5 = f5;                                    \
+    F6 = f6;                                    \
+                                                \
+    D1 = d1;                                    \
+    D2 = d2;                                    \
+    D3 = d3;                                    \
+    D4 = d4;                                    \
+    D5 = d5;                                    \
+    D6 = d6;                                    \
+                                                \
+    L1 = l1;
+
+/* -----------------------------------------------------------------------------
+   Misc junk
+   -------------------------------------------------------------------------- */
+
+#define NO_TREC                   stg_NO_TREC_closure
+#define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure
+#define STM_AWOKEN                stg_STM_AWOKEN_closure
+
+#define recordMutableCap(p, gen)                                        \
+  W_ __bd;                                                              \
+  W_ mut_list;                                                          \
+  mut_list = Capability_mut_lists(MyCapability()) + WDS(gen);           \
+ __bd = W_[mut_list];                                                   \
+  if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) {           \
+      W_ __new_bd;                                                      \
+      ("ptr" __new_bd) = foreign "C" allocBlock_lock();                 \
+      bdescr_link(__new_bd) = __bd;                                     \
+      __bd = __new_bd;                                                  \
+      W_[mut_list] = __bd;                                              \
+  }                                                                     \
+  W_ free;                                                              \
+  free = bdescr_free(__bd);                                             \
+  W_[free] = p;                                                         \
+  bdescr_free(__bd) = free + WDS(1);
+
+#define recordMutable(p)                                        \
+      P_ __p;                                                   \
+      W_ __bd;                                                  \
+      W_ __gen;                                                 \
+      __p = p;                                                  \
+      __bd = Bdescr(__p);                                       \
+      __gen = TO_W_(bdescr_gen_no(__bd));                       \
+      if (__gen > 0) { recordMutableCap(__p, __gen); }
+
+/* -----------------------------------------------------------------------------
+   Arrays
+   -------------------------------------------------------------------------- */
+
+/* Complete function body for the clone family of (mutable) array ops.
+   Defined as a macro to avoid function call overhead or code
+   duplication. */
+#define cloneArray(info, src, offset, n)                       \
+    W_ words, size;                                            \
+    gcptr dst, dst_p, src_p;                                   \
+                                                               \
+    again: MAYBE_GC(again);                                    \
+                                                               \
+    size = n + mutArrPtrsCardWords(n);                         \
+    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;         \
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);       \
+                                                               \
+    SET_HDR(dst, info, CCCS);                                  \
+    StgMutArrPtrs_ptrs(dst) = n;                               \
+    StgMutArrPtrs_size(dst) = size;                            \
+                                                               \
+    dst_p = dst + SIZEOF_StgMutArrPtrs;                        \
+    src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset);          \
+    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \
+                                                               \
+    return (dst);
+
+#define copyArray(src, src_off, dst, dst_off, n)                  \
+  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \
+                                                                  \
+    if ((n) != 0) {                                               \
+        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \
+                                                                  \
+        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \
+        dst_p = dst_elems_p + WDS(dst_off);                       \
+        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \
+        bytes = WDS(n);                                           \
+                                                                  \
+        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);              \
+                                                                  \
+        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \
+        setCards(dst_cards_p, dst_off, n);                        \
+    }                                                             \
+                                                                  \
+    return ();
+
+#define copyMutableArray(src, src_off, dst, dst_off, n)           \
+  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \
+                                                                  \
+    if ((n) != 0) {                                               \
+        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \
+                                                                  \
+        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \
+        dst_p = dst_elems_p + WDS(dst_off);                       \
+        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \
+        bytes = WDS(n);                                           \
+                                                                  \
+        if ((src) == (dst)) {                                     \
+            prim %memmove(dst_p, src_p, bytes, SIZEOF_W);         \
+        } else {                                                  \
+            prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);          \
+        }                                                         \
+                                                                  \
+        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \
+        setCards(dst_cards_p, dst_off, n);                        \
+    }                                                             \
+                                                                  \
+    return ();
+
+/*
+ * Set the cards in the cards table pointed to by dst_cards_p for an
+ * update to n elements, starting at element dst_off.
+ */
+#define setCards(dst_cards_p, dst_off, n)                      \
+    W_ __start_card, __end_card, __cards;                      \
+    __start_card = mutArrPtrCardDown(dst_off);                 \
+    __end_card = mutArrPtrCardDown((dst_off) + (n) - 1);       \
+    __cards = __end_card - __start_card + 1;                   \
+    prim %memset((dst_cards_p) + __start_card, 1, __cards, 1);
+
+/* Complete function body for the clone family of small (mutable)
+   array ops. Defined as a macro to avoid function call overhead or
+   code duplication. */
+#define cloneSmallArray(info, src, offset, n)                  \
+    W_ words, size;                                            \
+    gcptr dst, dst_p, src_p;                                   \
+                                                               \
+    again: MAYBE_GC(again);                                    \
+                                                               \
+    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;       \
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);     \
+                                                               \
+    SET_HDR(dst, info, CCCS);                                  \
+    StgSmallMutArrPtrs_ptrs(dst) = n;                          \
+                                                               \
+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs;                   \
+    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset);     \
+    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \
+                                                               \
+    return (dst);
diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs
new file mode 100644
--- /dev/null
+++ b/includes/CodeGen.Platform.hs
@@ -0,0 +1,1063 @@
+
+import CmmExpr
+#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
+    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))
+import Panic
+#endif
+import Reg
+
+#include "ghcautoconf.h"
+#include "stg/MachRegs.h"
+
+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
+
+# if defined(MACHREGS_i386)
+#  define eax 0
+#  define ebx 1
+#  define ecx 2
+#  define edx 3
+#  define esi 4
+#  define edi 5
+#  define ebp 6
+#  define esp 7
+# endif
+
+# if defined(MACHREGS_x86_64)
+#  define rax   0
+#  define rbx   1
+#  define rcx   2
+#  define rdx   3
+#  define rsi   4
+#  define rdi   5
+#  define rbp   6
+#  define rsp   7
+#  define r8    8
+#  define r9    9
+#  define r10   10
+#  define r11   11
+#  define r12   12
+#  define r13   13
+#  define r14   14
+#  define r15   15
+# endif
+
+
+-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence
+-- being assigned the same RegNos.
+# define xmm0  16
+# define xmm1  17
+# define xmm2  18
+# define xmm3  19
+# define xmm4  20
+# define xmm5  21
+# define xmm6  22
+# define xmm7  23
+# define xmm8  24
+# define xmm9  25
+# define xmm10 26
+# define xmm11 27
+# define xmm12 28
+# define xmm13 29
+# define xmm14 30
+# define xmm15 31
+
+# define ymm0  16
+# define ymm1  17
+# define ymm2  18
+# define ymm3  19
+# define ymm4  20
+# define ymm5  21
+# define ymm6  22
+# define ymm7  23
+# define ymm8  24
+# define ymm9  25
+# define ymm10 26
+# define ymm11 27
+# define ymm12 28
+# define ymm13 29
+# define ymm14 30
+# define ymm15 31
+
+# define zmm0  16
+# define zmm1  17
+# define zmm2  18
+# define zmm3  19
+# define zmm4  20
+# define zmm5  21
+# define zmm6  22
+# define zmm7  23
+# define zmm8  24
+# define zmm9  25
+# define zmm10 26
+# define zmm11 27
+# define zmm12 28
+# define zmm13 29
+# define zmm14 30
+# define zmm15 31
+
+-- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs.
+-- Since it's only used to check 'isJust', the actual values don't matter, thus
+-- I'm not sure if these are the correct numberings.
+-- Normally, the register names are just stringified as part of the REG() macro
+
+#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \
+    || defined(MACHREGS_aarch64)
+
+# define r0 0
+# define r1 1
+# define r2 2
+# define r3 3
+# define r4 4
+# define r5 5
+# define r6 6
+# define r7 7
+# define r8 8
+# define r9 9
+# define r10 10
+# define r11 11
+# define r12 12
+# define r13 13
+# define r14 14
+# define r15 15
+# define r16 16
+# define r17 17
+# define r18 18
+# define r19 19
+# define r20 20
+# define r21 21
+# define r22 22
+# define r23 23
+# define r24 24
+# define r25 25
+# define r26 26
+# define r27 27
+# define r28 28
+# define r29 29
+# define r30 30
+# define r31 31
+
+-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe
+-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG.
+#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm)
+# define s0 32
+# define s1 33
+# define s2 34
+# define s3 35
+# define s4 36
+# define s5 37
+# define s6 38
+# define s7 39
+# define s8 40
+# define s9 41
+# define s10 42
+# define s11 43
+# define s12 44
+# define s13 45
+# define s14 46
+# define s15 47
+# define s16 48
+# define s17 49
+# define s18 50
+# define s19 51
+# define s20 52
+# define s21 53
+# define s22 54
+# define s23 55
+# define s24 56
+# define s25 57
+# define s26 58
+# define s27 59
+# define s28 60
+# define s29 61
+# define s30 62
+# define s31 63
+
+# define d0 32
+# define d1 33
+# define d2 34
+# define d3 35
+# define d4 36
+# define d5 37
+# define d6 38
+# define d7 39
+# define d8 40
+# define d9 41
+# define d10 42
+# define d11 43
+# define d12 44
+# define d13 45
+# define d14 46
+# define d15 47
+# define d16 48
+# define d17 49
+# define d18 50
+# define d19 51
+# define d20 52
+# define d21 53
+# define d22 54
+# define d23 55
+# define d24 56
+# define d25 57
+# define d26 58
+# define d27 59
+# define d28 60
+# define d29 61
+# define d30 62
+# define d31 63
+#endif
+
+# if defined(MACHREGS_darwin)
+#  define f0  32
+#  define f1  33
+#  define f2  34
+#  define f3  35
+#  define f4  36
+#  define f5  37
+#  define f6  38
+#  define f7  39
+#  define f8  40
+#  define f9  41
+#  define f10 42
+#  define f11 43
+#  define f12 44
+#  define f13 45
+#  define f14 46
+#  define f15 47
+#  define f16 48
+#  define f17 49
+#  define f18 50
+#  define f19 51
+#  define f20 52
+#  define f21 53
+#  define f22 54
+#  define f23 55
+#  define f24 56
+#  define f25 57
+#  define f26 58
+#  define f27 59
+#  define f28 60
+#  define f29 61
+#  define f30 62
+#  define f31 63
+# else
+#  define fr0  32
+#  define fr1  33
+#  define fr2  34
+#  define fr3  35
+#  define fr4  36
+#  define fr5  37
+#  define fr6  38
+#  define fr7  39
+#  define fr8  40
+#  define fr9  41
+#  define fr10 42
+#  define fr11 43
+#  define fr12 44
+#  define fr13 45
+#  define fr14 46
+#  define fr15 47
+#  define fr16 48
+#  define fr17 49
+#  define fr18 50
+#  define fr19 51
+#  define fr20 52
+#  define fr21 53
+#  define fr22 54
+#  define fr23 55
+#  define fr24 56
+#  define fr25 57
+#  define fr26 58
+#  define fr27 59
+#  define fr28 60
+#  define fr29 61
+#  define fr30 62
+#  define fr31 63
+# endif
+
+#elif defined(MACHREGS_sparc)
+
+# define g0  0
+# define g1  1
+# define g2  2
+# define g3  3
+# define g4  4
+# define g5  5
+# define g6  6
+# define g7  7
+
+# define o0  8
+# define o1  9
+# define o2  10
+# define o3  11
+# define o4  12
+# define o5  13
+# define o6  14
+# define o7  15
+
+# define l0  16
+# define l1  17
+# define l2  18
+# define l3  19
+# define l4  20
+# define l5  21
+# define l6  22
+# define l7  23
+
+# define i0  24
+# define i1  25
+# define i2  26
+# define i3  27
+# define i4  28
+# define i5  29
+# define i6  30
+# define i7  31
+
+# define f0  32
+# define f1  33
+# define f2  34
+# define f3  35
+# define f4  36
+# define f5  37
+# define f6  38
+# define f7  39
+# define f8  40
+# define f9  41
+# define f10 42
+# define f11 43
+# define f12 44
+# define f13 45
+# define f14 46
+# define f15 47
+# define f16 48
+# define f17 49
+# define f18 50
+# define f19 51
+# define f20 52
+# define f21 53
+# define f22 54
+# define f23 55
+# define f24 56
+# define f25 57
+# define f26 58
+# define f27 59
+# define f28 60
+# define f29 61
+# define f30 62
+# define f31 63
+
+#endif
+
+callerSaves :: GlobalReg -> Bool
+#if defined(CALLER_SAVES_Base)
+callerSaves BaseReg           = True
+#endif
+#if defined(CALLER_SAVES_R1)
+callerSaves (VanillaReg 1 _)  = True
+#endif
+#if defined(CALLER_SAVES_R2)
+callerSaves (VanillaReg 2 _)  = True
+#endif
+#if defined(CALLER_SAVES_R3)
+callerSaves (VanillaReg 3 _)  = True
+#endif
+#if defined(CALLER_SAVES_R4)
+callerSaves (VanillaReg 4 _)  = True
+#endif
+#if defined(CALLER_SAVES_R5)
+callerSaves (VanillaReg 5 _)  = True
+#endif
+#if defined(CALLER_SAVES_R6)
+callerSaves (VanillaReg 6 _)  = True
+#endif
+#if defined(CALLER_SAVES_R7)
+callerSaves (VanillaReg 7 _)  = True
+#endif
+#if defined(CALLER_SAVES_R8)
+callerSaves (VanillaReg 8 _)  = True
+#endif
+#if defined(CALLER_SAVES_R9)
+callerSaves (VanillaReg 9 _)  = True
+#endif
+#if defined(CALLER_SAVES_R10)
+callerSaves (VanillaReg 10 _) = True
+#endif
+#if defined(CALLER_SAVES_F1)
+callerSaves (FloatReg 1)      = True
+#endif
+#if defined(CALLER_SAVES_F2)
+callerSaves (FloatReg 2)      = True
+#endif
+#if defined(CALLER_SAVES_F3)
+callerSaves (FloatReg 3)      = True
+#endif
+#if defined(CALLER_SAVES_F4)
+callerSaves (FloatReg 4)      = True
+#endif
+#if defined(CALLER_SAVES_F5)
+callerSaves (FloatReg 5)      = True
+#endif
+#if defined(CALLER_SAVES_F6)
+callerSaves (FloatReg 6)      = True
+#endif
+#if defined(CALLER_SAVES_D1)
+callerSaves (DoubleReg 1)     = True
+#endif
+#if defined(CALLER_SAVES_D2)
+callerSaves (DoubleReg 2)     = True
+#endif
+#if defined(CALLER_SAVES_D3)
+callerSaves (DoubleReg 3)     = True
+#endif
+#if defined(CALLER_SAVES_D4)
+callerSaves (DoubleReg 4)     = True
+#endif
+#if defined(CALLER_SAVES_D5)
+callerSaves (DoubleReg 5)     = True
+#endif
+#if defined(CALLER_SAVES_D6)
+callerSaves (DoubleReg 6)     = True
+#endif
+#if defined(CALLER_SAVES_L1)
+callerSaves (LongReg 1)       = True
+#endif
+#if defined(CALLER_SAVES_Sp)
+callerSaves Sp                = True
+#endif
+#if defined(CALLER_SAVES_SpLim)
+callerSaves SpLim             = True
+#endif
+#if defined(CALLER_SAVES_Hp)
+callerSaves Hp                = True
+#endif
+#if defined(CALLER_SAVES_HpLim)
+callerSaves HpLim             = True
+#endif
+#if defined(CALLER_SAVES_CCCS)
+callerSaves CCCS              = True
+#endif
+#if defined(CALLER_SAVES_CurrentTSO)
+callerSaves CurrentTSO        = True
+#endif
+#if defined(CALLER_SAVES_CurrentNursery)
+callerSaves CurrentNursery    = True
+#endif
+callerSaves _                 = False
+
+activeStgRegs :: [GlobalReg]
+activeStgRegs = [
+#if defined(REG_Base)
+    BaseReg
+#endif
+#if defined(REG_Sp)
+    ,Sp
+#endif
+#if defined(REG_Hp)
+    ,Hp
+#endif
+#if defined(REG_R1)
+    ,VanillaReg 1 VGcPtr
+#endif
+#if defined(REG_R2)
+    ,VanillaReg 2 VGcPtr
+#endif
+#if defined(REG_R3)
+    ,VanillaReg 3 VGcPtr
+#endif
+#if defined(REG_R4)
+    ,VanillaReg 4 VGcPtr
+#endif
+#if defined(REG_R5)
+    ,VanillaReg 5 VGcPtr
+#endif
+#if defined(REG_R6)
+    ,VanillaReg 6 VGcPtr
+#endif
+#if defined(REG_R7)
+    ,VanillaReg 7 VGcPtr
+#endif
+#if defined(REG_R8)
+    ,VanillaReg 8 VGcPtr
+#endif
+#if defined(REG_R9)
+    ,VanillaReg 9 VGcPtr
+#endif
+#if defined(REG_R10)
+    ,VanillaReg 10 VGcPtr
+#endif
+#if defined(REG_SpLim)
+    ,SpLim
+#endif
+#if MAX_REAL_XMM_REG != 0
+#if defined(REG_F1)
+    ,FloatReg 1
+#endif
+#if defined(REG_D1)
+    ,DoubleReg 1
+#endif
+#if defined(REG_XMM1)
+    ,XmmReg 1
+#endif
+#if defined(REG_YMM1)
+    ,YmmReg 1
+#endif
+#if defined(REG_ZMM1)
+    ,ZmmReg 1
+#endif
+#if defined(REG_F2)
+    ,FloatReg 2
+#endif
+#if defined(REG_D2)
+    ,DoubleReg 2
+#endif
+#if defined(REG_XMM2)
+    ,XmmReg 2
+#endif
+#if defined(REG_YMM2)
+    ,YmmReg 2
+#endif
+#if defined(REG_ZMM2)
+    ,ZmmReg 2
+#endif
+#if defined(REG_F3)
+    ,FloatReg 3
+#endif
+#if defined(REG_D3)
+    ,DoubleReg 3
+#endif
+#if defined(REG_XMM3)
+    ,XmmReg 3
+#endif
+#if defined(REG_YMM3)
+    ,YmmReg 3
+#endif
+#if defined(REG_ZMM3)
+    ,ZmmReg 3
+#endif
+#if defined(REG_F4)
+    ,FloatReg 4
+#endif
+#if defined(REG_D4)
+    ,DoubleReg 4
+#endif
+#if defined(REG_XMM4)
+    ,XmmReg 4
+#endif
+#if defined(REG_YMM4)
+    ,YmmReg 4
+#endif
+#if defined(REG_ZMM4)
+    ,ZmmReg 4
+#endif
+#if defined(REG_F5)
+    ,FloatReg 5
+#endif
+#if defined(REG_D5)
+    ,DoubleReg 5
+#endif
+#if defined(REG_XMM5)
+    ,XmmReg 5
+#endif
+#if defined(REG_YMM5)
+    ,YmmReg 5
+#endif
+#if defined(REG_ZMM5)
+    ,ZmmReg 5
+#endif
+#if defined(REG_F6)
+    ,FloatReg 6
+#endif
+#if defined(REG_D6)
+    ,DoubleReg 6
+#endif
+#if defined(REG_XMM6)
+    ,XmmReg 6
+#endif
+#if defined(REG_YMM6)
+    ,YmmReg 6
+#endif
+#if defined(REG_ZMM6)
+    ,ZmmReg 6
+#endif
+#else /* MAX_REAL_XMM_REG == 0 */
+#if defined(REG_F1)
+    ,FloatReg 1
+#endif
+#if defined(REG_F2)
+    ,FloatReg 2
+#endif
+#if defined(REG_F3)
+    ,FloatReg 3
+#endif
+#if defined(REG_F4)
+    ,FloatReg 4
+#endif
+#if defined(REG_F5)
+    ,FloatReg 5
+#endif
+#if defined(REG_F6)
+    ,FloatReg 6
+#endif
+#if defined(REG_D1)
+    ,DoubleReg 1
+#endif
+#if defined(REG_D2)
+    ,DoubleReg 2
+#endif
+#if defined(REG_D3)
+    ,DoubleReg 3
+#endif
+#if defined(REG_D4)
+    ,DoubleReg 4
+#endif
+#if defined(REG_D5)
+    ,DoubleReg 5
+#endif
+#if defined(REG_D6)
+    ,DoubleReg 6
+#endif
+#endif /* MAX_REAL_XMM_REG == 0 */
+    ]
+
+haveRegBase :: Bool
+#if defined(REG_Base)
+haveRegBase = True
+#else
+haveRegBase = False
+#endif
+
+--  | Returns 'Nothing' if this global register is not stored
+-- in a real machine register, otherwise returns @'Just' reg@, where
+-- reg is the machine register it is stored in.
+globalRegMaybe :: GlobalReg -> Maybe RealReg
+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
+    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \
+    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64)
+# if defined(REG_Base)
+globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)
+# endif
+# if defined(REG_R1)
+globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)
+# endif
+# if defined(REG_R2)
+globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)
+# endif
+# if defined(REG_R3)
+globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)
+# endif
+# if defined(REG_R4)
+globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)
+# endif
+# if defined(REG_R5)
+globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)
+# endif
+# if defined(REG_R6)
+globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)
+# endif
+# if defined(REG_R7)
+globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)
+# endif
+# if defined(REG_R8)
+globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)
+# endif
+# if defined(REG_R9)
+globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)
+# endif
+# if defined(REG_R10)
+globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)
+# endif
+# if defined(REG_F1)
+globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)
+# endif
+# if defined(REG_F2)
+globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)
+# endif
+# if defined(REG_F3)
+globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)
+# endif
+# if defined(REG_F4)
+globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)
+# endif
+# if defined(REG_F5)
+globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)
+# endif
+# if defined(REG_F6)
+globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)
+# endif
+# if defined(REG_D1)
+globalRegMaybe (DoubleReg 1)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D1 (REG_D1 + 1))
+#  else
+                                          Just (RealRegSingle REG_D1)
+#  endif
+# endif
+# if defined(REG_D2)
+globalRegMaybe (DoubleReg 2)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D2 (REG_D2 + 1))
+#  else
+                                          Just (RealRegSingle REG_D2)
+#  endif
+# endif
+# if defined(REG_D3)
+globalRegMaybe (DoubleReg 3)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D3 (REG_D3 + 1))
+#  else
+                                          Just (RealRegSingle REG_D3)
+#  endif
+# endif
+# if defined(REG_D4)
+globalRegMaybe (DoubleReg 4)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D4 (REG_D4 + 1))
+#  else
+                                          Just (RealRegSingle REG_D4)
+#  endif
+# endif
+# if defined(REG_D5)
+globalRegMaybe (DoubleReg 5)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D5 (REG_D5 + 1))
+#  else
+                                          Just (RealRegSingle REG_D5)
+#  endif
+# endif
+# if defined(REG_D6)
+globalRegMaybe (DoubleReg 6)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D6 (REG_D6 + 1))
+#  else
+                                          Just (RealRegSingle REG_D6)
+#  endif
+# endif
+# if MAX_REAL_XMM_REG != 0
+#  if defined(REG_XMM1)
+globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)
+#  endif
+#  if defined(REG_XMM2)
+globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)
+#  endif
+#  if defined(REG_XMM3)
+globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)
+#  endif
+#  if defined(REG_XMM4)
+globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)
+#  endif
+#  if defined(REG_XMM5)
+globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)
+#  endif
+#  if defined(REG_XMM6)
+globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)
+#  endif
+# endif
+# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0
+#  if defined(REG_YMM1)
+globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)
+#  endif
+#  if defined(REG_YMM2)
+globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)
+#  endif
+#  if defined(REG_YMM3)
+globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)
+#  endif
+#  if defined(REG_YMM4)
+globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)
+#  endif
+#  if defined(REG_YMM5)
+globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)
+#  endif
+#  if defined(REG_YMM6)
+globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)
+#  endif
+# endif
+# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0
+#  if defined(REG_ZMM1)
+globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)
+#  endif
+#  if defined(REG_ZMM2)
+globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)
+#  endif
+#  if defined(REG_ZMM3)
+globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)
+#  endif
+#  if defined(REG_ZMM4)
+globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)
+#  endif
+#  if defined(REG_ZMM5)
+globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)
+#  endif
+#  if defined(REG_ZMM6)
+globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)
+#  endif
+# endif
+# if defined(REG_Sp)
+globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)
+# endif
+# if defined(REG_Lng1)
+globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)
+# endif
+# if defined(REG_Lng2)
+globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)
+# endif
+# if defined(REG_SpLim)
+globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)
+# endif
+# if defined(REG_Hp)
+globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)
+# endif
+# if defined(REG_HpLim)
+globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)
+# endif
+# if defined(REG_CurrentTSO)
+globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)
+# endif
+# if defined(REG_CurrentNursery)
+globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)
+# endif
+# if defined(REG_MachSp)
+globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)
+# endif
+globalRegMaybe _                        = Nothing
+#elif defined(MACHREGS_NO_REGS)
+globalRegMaybe _ = Nothing
+#else
+globalRegMaybe = panic "globalRegMaybe not defined for this platform"
+#endif
+
+freeReg :: RegNo -> Bool
+
+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
+
+# if defined(MACHREGS_i386)
+freeReg esp = False -- %esp is the C stack pointer
+freeReg esi = False -- Note [esi/edi/ebp not allocatable]
+freeReg edi = False
+freeReg ebp = False
+# endif
+# if defined(MACHREGS_x86_64)
+freeReg rsp = False  --        %rsp is the C stack pointer
+# endif
+
+{-
+Note [esi/edi/ebp not allocatable]
+
+%esi is mapped to R1, so %esi would normally be allocatable while it
+is not being used for R1.  However, %esi has no 8-bit version on x86,
+and the linear register allocator is not sophisticated enough to
+handle this irregularity (we need more RegClasses).  The
+graph-colouring allocator also cannot handle this - it was designed
+with more flexibility in mind, but the current implementation is
+restricted to the same set of classes as the linear allocator.
+
+Hence, on x86 esi, edi and ebp are treated as not allocatable.
+-}
+
+-- split patterns in two functions to prevent overlaps
+freeReg r         = freeRegBase r
+
+freeRegBase :: RegNo -> Bool
+# if defined(REG_Base)
+freeRegBase REG_Base  = False
+# endif
+# if defined(REG_Sp)
+freeRegBase REG_Sp    = False
+# endif
+# if defined(REG_SpLim)
+freeRegBase REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeRegBase REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeRegBase REG_HpLim = False
+# endif
+-- All other regs are considered to be "free", because we can track
+-- their liveness accurately.
+freeRegBase _ = True
+
+#elif defined(MACHREGS_powerpc)
+
+freeReg 0 = False -- Used by code setting the back chain pointer
+                  -- in stack reallocations on Linux.
+                  -- Moreover r0 is not usable in all insns.
+freeReg 1 = False -- The Stack Pointer
+-- most ELF PowerPC OSes use r2 as a TOC pointer
+freeReg 2 = False
+freeReg 13 = False -- reserved for system thread ID on 64 bit
+-- at least linux in -fPIC relies on r30 in PLT stubs
+freeReg 30 = False
+{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.
+   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register
+   in stack handling code. See compiler/nativeGen/PPC/Instr.hs.
+
+   Later we might want to reserve r13 and r30 only where it is required.
+   Then use r12 as temporary register, which is also what the C ABI does.
+-}
+
+# if defined(REG_Base)
+freeReg REG_Base  = False
+# endif
+# if defined(REG_Sp)
+freeReg REG_Sp    = False
+# endif
+# if defined(REG_SpLim)
+freeReg REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeReg REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeReg REG_HpLim = False
+# endif
+freeReg _ = True
+
+#elif defined(MACHREGS_sparc)
+
+-- SPARC regs used by the OS / ABI
+-- %g0(r0) is always zero
+freeReg g0  = False
+
+-- %g5(r5) - %g7(r7)
+--  are reserved for the OS
+freeReg g5  = False
+freeReg g6  = False
+freeReg g7  = False
+
+-- %o6(r14)
+--  is the C stack pointer
+freeReg o6  = False
+
+-- %o7(r15)
+--  holds the C return address
+freeReg o7  = False
+
+-- %i6(r30)
+--  is the C frame pointer
+freeReg i6  = False
+
+-- %i7(r31)
+--  is used for C return addresses
+freeReg i7  = False
+
+-- %f0(r32) - %f1(r32)
+--  are C floating point return regs
+freeReg f0  = False
+freeReg f1  = False
+
+{-
+freeReg regNo
+    -- don't release high half of double regs
+    | regNo >= f0
+    , regNo <  NCG_FirstFloatReg
+    , regNo `mod` 2 /= 0
+    = False
+-}
+
+# if defined(REG_Base)
+freeReg REG_Base  = False
+# endif
+# if defined(REG_R1)
+freeReg REG_R1    = False
+# endif
+# if defined(REG_R2)
+freeReg REG_R2    = False
+# endif
+# if defined(REG_R3)
+freeReg REG_R3    = False
+# endif
+# if defined(REG_R4)
+freeReg REG_R4    = False
+# endif
+# if defined(REG_R5)
+freeReg REG_R5    = False
+# endif
+# if defined(REG_R6)
+freeReg REG_R6    = False
+# endif
+# if defined(REG_R7)
+freeReg REG_R7    = False
+# endif
+# if defined(REG_R8)
+freeReg REG_R8    = False
+# endif
+# if defined(REG_R9)
+freeReg REG_R9    = False
+# endif
+# if defined(REG_R10)
+freeReg REG_R10   = False
+# endif
+# if defined(REG_F1)
+freeReg REG_F1    = False
+# endif
+# if defined(REG_F2)
+freeReg REG_F2    = False
+# endif
+# if defined(REG_F3)
+freeReg REG_F3    = False
+# endif
+# if defined(REG_F4)
+freeReg REG_F4    = False
+# endif
+# if defined(REG_F5)
+freeReg REG_F5    = False
+# endif
+# if defined(REG_F6)
+freeReg REG_F6    = False
+# endif
+# if defined(REG_D1)
+freeReg REG_D1    = False
+# endif
+# if defined(REG_D1_2)
+freeReg REG_D1_2  = False
+# endif
+# if defined(REG_D2)
+freeReg REG_D2    = False
+# endif
+# if defined(REG_D2_2)
+freeReg REG_D2_2  = False
+# endif
+# if defined(REG_D3)
+freeReg REG_D3    = False
+# endif
+# if defined(REG_D3_2)
+freeReg REG_D3_2  = False
+# endif
+# if defined(REG_D4)
+freeReg REG_D4    = False
+# endif
+# if defined(REG_D4_2)
+freeReg REG_D4_2  = False
+# endif
+# if defined(REG_D5)
+freeReg REG_D5    = False
+# endif
+# if defined(REG_D5_2)
+freeReg REG_D5_2  = False
+# endif
+# if defined(REG_D6)
+freeReg REG_D6    = False
+# endif
+# if defined(REG_D6_2)
+freeReg REG_D6_2  = False
+# endif
+# if defined(REG_Sp)
+freeReg REG_Sp    = False
+# endif
+# if defined(REG_SpLim)
+freeReg REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeReg REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeReg REG_HpLim = False
+# endif
+freeReg _ = True
+
+#else
+
+freeReg = panic "freeReg not defined for this platform"
+
+#endif
+
diff --git a/includes/HsFFI.h b/includes/HsFFI.h
new file mode 100644
--- /dev/null
+++ b/includes/HsFFI.h
@@ -0,0 +1,141 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2000
+ *
+ * A mapping for Haskell types to C types, including the corresponding bounds.
+ * Intended to be used in conjuction with the FFI.
+ *
+ * WARNING: Keep this file and StgTypes.h in synch!
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+/* get types from GHC's runtime system */
+#include "ghcconfig.h"
+#include "stg/Types.h"
+
+/* get limits for floating point types */
+#include <float.h>
+
+typedef StgChar                 HsChar;
+typedef StgInt                  HsInt;
+typedef StgInt8                 HsInt8;
+typedef StgInt16                HsInt16;
+typedef StgInt32                HsInt32;
+typedef StgInt64                HsInt64;
+typedef StgWord                 HsWord;
+typedef StgWord8                HsWord8;
+typedef StgWord16               HsWord16;
+typedef StgWord32               HsWord32;
+typedef StgWord64               HsWord64;
+typedef StgFloat                HsFloat;
+typedef StgDouble               HsDouble;
+typedef StgInt                  HsBool;
+typedef void*                   HsPtr;          /* this should better match StgAddr */
+typedef void                    (*HsFunPtr)(void); /* this should better match StgAddr */
+typedef void*                   HsStablePtr;
+
+/* this should correspond to the type of StgChar in StgTypes.h */
+#define HS_CHAR_MIN             0
+#define HS_CHAR_MAX             0x10FFFF
+
+/* is it true or not?  */
+#define HS_BOOL_FALSE           0
+#define HS_BOOL_TRUE            1
+
+#define HS_BOOL_MIN             HS_BOOL_FALSE
+#define HS_BOOL_MAX             HS_BOOL_TRUE
+
+
+#define HS_INT_MIN              STG_INT_MIN
+#define HS_INT_MAX              STG_INT_MAX
+#define HS_WORD_MAX             STG_WORD_MAX
+
+#define HS_INT8_MIN             STG_INT8_MIN
+#define HS_INT8_MAX             STG_INT8_MAX
+#define HS_INT16_MIN            STG_INT16_MIN
+#define HS_INT16_MAX            STG_INT16_MAX
+#define HS_INT32_MIN            STG_INT32_MIN
+#define HS_INT32_MAX            STG_INT32_MAX
+#define HS_INT64_MIN            STG_INT64_MIN
+#define HS_INT64_MAX            STG_INT64_MAX
+#define HS_WORD8_MAX            STG_WORD8_MAX
+#define HS_WORD16_MAX           STG_WORD16_MAX
+#define HS_WORD32_MAX           STG_WORD32_MAX
+#define HS_WORD64_MAX           STG_WORD64_MAX
+
+#define HS_FLOAT_RADIX          FLT_RADIX
+#define HS_FLOAT_ROUNDS         FLT_ROUNDS
+#define HS_FLOAT_EPSILON        FLT_EPSILON
+#define HS_FLOAT_DIG            FLT_DIG
+#define HS_FLOAT_MANT_DIG       FLT_MANT_DIG
+#define HS_FLOAT_MIN            FLT_MIN
+#define HS_FLOAT_MIN_EXP        FLT_MIN_EXP
+#define HS_FLOAT_MIN_10_EXP     FLT_MIN_10_EXP
+#define HS_FLOAT_MAX            FLT_MAX
+#define HS_FLOAT_MAX_EXP        FLT_MAX_EXP
+#define HS_FLOAT_MAX_10_EXP     FLT_MAX_10_EXP
+
+#define HS_DOUBLE_RADIX         DBL_RADIX
+#define HS_DOUBLE_ROUNDS        DBL_ROUNDS
+#define HS_DOUBLE_EPSILON       DBL_EPSILON
+#define HS_DOUBLE_DIG           DBL_DIG
+#define HS_DOUBLE_MANT_DIG      DBL_MANT_DIG
+#define HS_DOUBLE_MIN           DBL_MIN
+#define HS_DOUBLE_MIN_EXP       DBL_MIN_EXP
+#define HS_DOUBLE_MIN_10_EXP    DBL_MIN_10_EXP
+#define HS_DOUBLE_MAX           DBL_MAX
+#define HS_DOUBLE_MAX_EXP       DBL_MAX_EXP
+#define HS_DOUBLE_MAX_10_EXP    DBL_MAX_10_EXP
+
+extern void hs_init     (int *argc, char **argv[]);
+extern void hs_exit     (void);
+extern void hs_exit_nowait(void);
+extern void hs_set_argv (int argc, char *argv[]);
+extern void hs_thread_done (void);
+
+extern void hs_perform_gc (void);
+
+// Lock the stable pointer table. The table must be unlocked
+// again before calling any Haskell functions, even if those
+// functions do not manipulate stable pointers. The Haskell
+// garbage collector will not be able to run until this lock
+// is released! It is also forbidden to call hs_free_fun_ptr
+// or any stable pointer-related FFI functions other than
+// hs_free_stable_ptr_unsafe while the table is locked.
+extern void hs_lock_stable_ptr_table (void);
+
+// A deprecated synonym.
+extern void hs_lock_stable_tables (void);
+
+// Unlock the stable pointer table.
+extern void hs_unlock_stable_ptr_table (void);
+
+// A deprecated synonym.
+extern void hs_unlock_stable_tables (void);
+
+// Free a stable pointer assuming that the stable pointer
+// table is already locked.
+extern void hs_free_stable_ptr_unsafe (HsStablePtr sp);
+
+extern void hs_free_stable_ptr (HsStablePtr sp);
+extern void hs_free_fun_ptr    (HsFunPtr fp);
+
+extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2);
+extern int hs_spt_keys(StgPtr keys[], int szKeys);
+extern int hs_spt_key_count (void);
+
+extern void hs_try_putmvar (int capability, HsStablePtr sp);
+
+/* -------------------------------------------------------------------------- */
+
+
+
+#if defined(__cplusplus)
+}
+#endif
diff --git a/includes/MachDeps.h b/includes/MachDeps.h
new file mode 100644
--- /dev/null
+++ b/includes/MachDeps.h
@@ -0,0 +1,123 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002
+ *
+ * Definitions that characterise machine specific properties of basic
+ * types (C & Haskell) of a target platform.
+ *
+ * NB: Keep in sync with HsFFI.h and StgTypes.h.
+ * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Don't allow stage1 (cross-)compiler embed assumptions about target
+ * platform. When ghc-stage1 is being built by ghc-stage0 is should not
+ * refer to target defines. A few past examples:
+ *  - https://gitlab.haskell.org/ghc/ghc/issues/13491
+ *  - https://phabricator.haskell.org/D3122
+ *  - https://phabricator.haskell.org/D3405
+ *
+ * In those cases code change assumed target defines like SIZEOF_HSINT
+ * are applied to host platform, not target platform.
+ *
+ * So what should be used instead in STAGE=1?
+ *
+ * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:
+ *    Data.Bits.finiteBitSize (0 :: Int)
+ *
+ * To get target's values it is preferred to use runtime target
+ * configuration from 'targetPlatform :: DynFlags -> Platform'
+ * record. A few wrappers are already defined and used throughout GHC:
+ *    wORD_SIZE :: DynFlags -> Int
+ *    wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))
+ *
+ * Hence we hide these macros from -DSTAGE=1
+ */
+#if !defined(STAGE) || STAGE >= 2
+
+/* Sizes of C types come from here... */
+#include "ghcautoconf.h"
+
+/* Sizes of Haskell types follow.  These sizes correspond to:
+ *   - the number of bytes in the primitive type (eg. Int#)
+ *   - the number of bytes in the external representation (eg. HsInt)
+ *   - the scale offset used by writeFooOffAddr#
+ *
+ * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1,
+ * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap.
+ */
+
+#define SIZEOF_HSCHAR           SIZEOF_WORD32
+#define ALIGNMENT_HSCHAR        ALIGNMENT_WORD32
+
+#define SIZEOF_HSINT            SIZEOF_VOID_P
+#define ALIGNMENT_HSINT         ALIGNMENT_VOID_P
+
+#define SIZEOF_HSWORD           SIZEOF_VOID_P
+#define ALIGNMENT_HSWORD        ALIGNMENT_VOID_P
+
+#define SIZEOF_HSDOUBLE         SIZEOF_DOUBLE
+#define ALIGNMENT_HSDOUBLE      ALIGNMENT_DOUBLE
+
+#define SIZEOF_HSFLOAT          SIZEOF_FLOAT
+#define ALIGNMENT_HSFLOAT       ALIGNMENT_FLOAT
+
+#define SIZEOF_HSPTR            SIZEOF_VOID_P
+#define ALIGNMENT_HSPTR         ALIGNMENT_VOID_P
+
+#define SIZEOF_HSFUNPTR         SIZEOF_VOID_P
+#define ALIGNMENT_HSFUNPTR      ALIGNMENT_VOID_P
+
+#define SIZEOF_HSSTABLEPTR      SIZEOF_VOID_P
+#define ALIGNMENT_HSSTABLEPTR   ALIGNMENT_VOID_P
+
+#define SIZEOF_INT8             SIZEOF_INT8_T
+#define ALIGNMENT_INT8          ALIGNMENT_INT8_T
+
+#define SIZEOF_WORD8            SIZEOF_UINT8_T
+#define ALIGNMENT_WORD8         ALIGNMENT_UINT8_T
+
+#define SIZEOF_INT16            SIZEOF_INT16_T
+#define ALIGNMENT_INT16         ALIGNMENT_INT16_T
+
+#define SIZEOF_WORD16           SIZEOF_UINT16_T
+#define ALIGNMENT_WORD16        ALIGNMENT_UINT16_T
+
+#define SIZEOF_INT32            SIZEOF_INT32_T
+#define ALIGNMENT_INT32         ALIGNMENT_INT32_T
+
+#define SIZEOF_WORD32           SIZEOF_UINT32_T
+#define ALIGNMENT_WORD32        ALIGNMENT_UINT32_T
+
+#define SIZEOF_INT64            SIZEOF_INT64_T
+#define ALIGNMENT_INT64         ALIGNMENT_INT64_T
+
+#define SIZEOF_WORD64           SIZEOF_UINT64_T
+#define ALIGNMENT_WORD64        ALIGNMENT_UINT64_T
+
+#if !defined(WORD_SIZE_IN_BITS)
+#if SIZEOF_HSWORD == 4
+#define WORD_SIZE_IN_BITS       32
+#define WORD_SIZE_IN_BITS_FLOAT 32.0
+#else
+#define WORD_SIZE_IN_BITS       64
+#define WORD_SIZE_IN_BITS_FLOAT 64.0
+#endif
+#endif
+
+#if !defined(TAG_BITS)
+#if SIZEOF_HSWORD == 4
+#define TAG_BITS                2
+#else
+#define TAG_BITS                3
+#endif
+#endif
+
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+
+#endif /* !defined(STAGE) || STAGE >= 2 */
diff --git a/includes/Rts.h b/includes/Rts.h
new file mode 100644
--- /dev/null
+++ b/includes/Rts.h
@@ -0,0 +1,317 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS external APIs.  This file declares everything that the GHC RTS
+ * exposes externally.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+/* We include windows.h very early, as on Win64 the CONTEXT type has
+   fields "R8", "R9" and "R10", which goes bad if we've already
+   #define'd those names for our own purposes (in stg/Regs.h) */
+#if defined(HAVE_WINDOWS_H)
+#include <windows.h>
+#endif
+
+#if !defined(IN_STG_CODE)
+#define IN_STG_CODE 0
+#endif
+#include "Stg.h"
+
+#include "HsFFI.h"
+#include "RtsAPI.h"
+
+// Turn off inlining when debugging - it obfuscates things
+#if defined(DEBUG)
+# undef  STATIC_INLINE
+# define STATIC_INLINE static
+#endif
+
+#include "rts/Types.h"
+#include "rts/Time.h"
+
+#if __GNUC__ >= 3
+#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n)))
+#else
+#define ATTRIBUTE_ALIGNED(n) /*nothing*/
+#endif
+
+// Symbols that are extern, but private to the RTS, are declared
+// with visibility "hidden" to hide them outside the RTS shared
+// library.
+#if defined(HAS_VISIBILITY_HIDDEN)
+#define RTS_PRIVATE  GNUC3_ATTRIBUTE(visibility("hidden"))
+#else
+#define RTS_PRIVATE  /* disabled: RTS_PRIVATE */
+#endif
+
+#if __GNUC__ >= 4
+#define RTS_UNLIKELY(p) __builtin_expect((p),0)
+#else
+#define RTS_UNLIKELY(p) (p)
+#endif
+
+#if __GNUC__ >= 4
+#define RTS_LIKELY(p) __builtin_expect(!!(p), 1)
+#else
+#define RTS_LIKELY(p) (p)
+#endif
+
+/* __builtin_unreachable is supported since GNU C 4.5 */
+#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5)
+#define RTS_UNREACHABLE __builtin_unreachable()
+#else
+#define RTS_UNREACHABLE abort()
+#endif
+
+/* Fix for mingw stat problem (done here so it's early enough) */
+#if defined(mingw32_HOST_OS)
+#define __MSVCRT__ 1
+#endif
+
+/* Needed to get the macro version of errno on some OSs, and also to
+   get prototypes for the _r versions of C library functions. */
+#if !defined(_REENTRANT)
+#define _REENTRANT 1
+#endif
+
+/*
+ * We often want to know the size of something in units of an
+ * StgWord... (rounded up, of course!)
+ */
+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_))
+
+#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t))
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+
+   CHECK(p)   evaluates p and terminates with an error if p is false
+   ASSERT(p)  like CHECK(p) if DEBUG is on, otherwise a no-op
+   -------------------------------------------------------------------------- */
+
+void _assertFail(const char *filename, unsigned int linenum)
+   GNUC3_ATTRIBUTE(__noreturn__);
+
+#define CHECK(predicate)                        \
+        if (predicate)                          \
+            /*null*/;                           \
+        else                                    \
+            _assertFail(__FILE__, __LINE__)
+
+#define CHECKM(predicate, msg, ...)             \
+        if (predicate)                          \
+            /*null*/;                           \
+        else                                    \
+            barf(msg, ##__VA_ARGS__)
+
+#if !defined(DEBUG)
+#define ASSERT(predicate) /* nothing */
+#define ASSERTM(predicate,msg,...) /* nothing */
+#else
+#define ASSERT(predicate) CHECK(predicate)
+#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__)
+#endif /* DEBUG */
+
+/*
+ * Use this on the RHS of macros which expand to nothing
+ * to make sure that the macro can be used in a context which
+ * demands a non-empty statement.
+ */
+
+#define doNothing() do { } while (0)
+
+#if defined(DEBUG)
+#define USED_IF_DEBUG
+#define USED_IF_NOT_DEBUG STG_UNUSED
+#else
+#define USED_IF_DEBUG STG_UNUSED
+#define USED_IF_NOT_DEBUG
+#endif
+
+#if defined(THREADED_RTS)
+#define USED_IF_THREADS
+#define USED_IF_NOT_THREADS STG_UNUSED
+#else
+#define USED_IF_THREADS STG_UNUSED
+#define USED_IF_NOT_THREADS
+#endif
+
+#define FMT_SizeT    "zu"
+#define FMT_HexSizeT "zx"
+
+/* -----------------------------------------------------------------------------
+   Include everything STG-ish
+   -------------------------------------------------------------------------- */
+
+/* System headers: stdlib.h is needed so that we can use NULL.  It must
+ * come after MachRegs.h, because stdlib.h might define some inline
+ * functions which may only be defined after register variables have
+ * been declared.
+ */
+#include <stdlib.h>
+
+#include "rts/Config.h"
+
+/* Global constraints */
+#include "rts/Constants.h"
+
+/* Profiling information */
+#include "rts/prof/CCS.h"
+#include "rts/prof/LDV.h"
+
+/* Parallel information */
+#include "rts/OSThreads.h"
+#include "rts/SpinLock.h"
+
+#include "rts/Messages.h"
+#include "rts/Threads.h"
+
+/* Storage format definitions */
+#include "rts/storage/FunTypes.h"
+#include "rts/storage/InfoTables.h"
+#include "rts/storage/Closures.h"
+#include "rts/storage/Heap.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/TSO.h"
+#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */
+#include "rts/storage/Block.h"
+#include "rts/storage/ClosureMacros.h"
+#include "rts/storage/MBlock.h"
+#include "rts/storage/GC.h"
+
+/* Other RTS external APIs */
+#include "rts/Parallel.h"
+#include "rts/Signals.h"
+#include "rts/BlockSignals.h"
+#include "rts/Hpc.h"
+#include "rts/Flags.h"
+#include "rts/Adjustor.h"
+#include "rts/FileLock.h"
+#include "rts/GetTime.h"
+#include "rts/Globals.h"
+#include "rts/IOManager.h"
+#include "rts/Linker.h"
+#include "rts/Ticky.h"
+#include "rts/Timer.h"
+#include "rts/StablePtr.h"
+#include "rts/StableName.h"
+#include "rts/TTY.h"
+#include "rts/Utils.h"
+#include "rts/PrimFloat.h"
+#include "rts/Main.h"
+#include "rts/Profiling.h"
+#include "rts/StaticPtrTable.h"
+#include "rts/Libdw.h"
+#include "rts/LibdwPool.h"
+
+/* Misc stuff without a home */
+DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
+DLL_IMPORT_RTS extern int    prog_argc;
+DLL_IMPORT_RTS extern char  *prog_name;
+
+void reportStackOverflow(StgTSO* tso);
+void reportHeapOverflow(void);
+
+void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
+
+#if !defined(mingw32_HOST_OS)
+int stg_sig_install (int, int, void *);
+#endif
+
+/* -----------------------------------------------------------------------------
+   Ways
+   -------------------------------------------------------------------------- */
+
+// Returns non-zero if the RTS is a profiling version
+int rts_isProfiled(void);
+
+// Returns non-zero if the RTS is a dynamically-linked version
+int rts_isDynamic(void);
+
+/* -----------------------------------------------------------------------------
+   RTS Exit codes
+   -------------------------------------------------------------------------- */
+
+/* 255 is allegedly used by dynamic linkers to report linking failure */
+#define EXIT_INTERNAL_ERROR 254
+#define EXIT_DEADLOCK       253
+#define EXIT_INTERRUPTED    252
+#define EXIT_HEAPOVERFLOW   251
+#define EXIT_KILLED         250
+
+/* -----------------------------------------------------------------------------
+   Miscellaneous garbage
+   -------------------------------------------------------------------------- */
+
+#if defined(DEBUG)
+#define TICK_VAR(arity) \
+  extern StgInt SLOW_CALLS_##arity; \
+  extern StgInt RIGHT_ARITY_##arity; \
+  extern StgInt TAGGED_PTR_##arity;
+
+extern StgInt TOTAL_CALLS;
+
+TICK_VAR(1)
+TICK_VAR(2)
+#endif
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+   -------------------------------------------------------------------------- */
+
+#define IF_RTSFLAGS(c,s)  if (RtsFlags.c) { s; } doNothing()
+
+#if defined(DEBUG)
+#if IN_STG_CODE
+#define IF_DEBUG(c,s)  if (RtsFlags[0].DebugFlags.c) { s; } doNothing()
+#else
+#define IF_DEBUG(c,s)  if (RtsFlags.DebugFlags.c) { s; } doNothing()
+#endif
+#else
+#define IF_DEBUG(c,s)  doNothing()
+#endif
+
+#if defined(DEBUG)
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) doNothing()
+#endif
+
+#if defined(DEBUG)
+#define DEBUG_IS_ON   1
+#else
+#define DEBUG_IS_ON   0
+#endif
+
+/* -----------------------------------------------------------------------------
+   Useful macros and inline functions
+   -------------------------------------------------------------------------- */
+
+#if defined(__GNUC__)
+#define SUPPORTS_TYPEOF
+#endif
+
+#if defined(SUPPORTS_TYPEOF)
+#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })
+#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })
+#else
+#define stg_min(a,b) ((a) <= (b) ? (a) : (b))
+#define stg_max(a,b) ((a) <= (b) ? (b) : (a))
+#endif
+
+/* -------------------------------------------------------------------------- */
+
+#if defined(__cplusplus)
+}
+#endif
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
new file mode 100644
--- /dev/null
+++ b/includes/RtsAPI.h
@@ -0,0 +1,487 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * API for invoking Haskell functions via the RTS
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+#include "HsFFI.h"
+#include "rts/Time.h"
+#include "rts/EventLogWriter.h"
+
+/*
+ * Running the scheduler
+ */
+typedef enum {
+    NoStatus,    /* not finished yet */
+    Success,     /* completed successfully */
+    Killed,      /* uncaught exception */
+    Interrupted, /* stopped in response to a call to interruptStgRts */
+    HeapExhausted /* out of memory */
+} SchedulerStatus;
+
+typedef struct StgClosure_ *HaskellObj;
+
+/*
+ * An abstract type representing the token returned by rts_lock() and
+ * used when allocating objects and threads in the RTS.
+ */
+typedef struct Capability_ Capability;
+
+/*
+ * The public view of a Capability: we can be sure it starts with
+ * these two components (but it may have more private fields).
+ */
+typedef struct CapabilityPublic_ {
+    StgFunTable f;
+    StgRegTable r;
+} CapabilityPublic;
+
+/* ----------------------------------------------------------------------------
+   RTS configuration settings, for passing to hs_init_ghc()
+   ------------------------------------------------------------------------- */
+
+typedef enum {
+    RtsOptsNone,         // +RTS causes an error
+    RtsOptsIgnore,       // Ignore command line arguments
+    RtsOptsIgnoreAll,    // Ignore command line and Environment arguments
+    RtsOptsSafeOnly,     // safe RTS options allowed; others cause an error
+    RtsOptsAll           // all RTS options allowed
+  } RtsOptsEnabledEnum;
+
+struct GCDetails_;
+
+// The RtsConfig struct is passed (by value) to hs_init_ghc().  The
+// reason for using a struct is extensibility: we can add more
+// fields to this later without breaking existing client code.
+typedef struct {
+
+    // Whether to interpret +RTS options on the command line
+    RtsOptsEnabledEnum rts_opts_enabled;
+
+    // Whether to give RTS flag suggestions
+    HsBool rts_opts_suggestions;
+
+    // additional RTS options
+    const char *rts_opts;
+
+    // True if GHC was not passed -no-hs-main
+    HsBool rts_hs_main;
+
+    // Whether to retain CAFs (default: false)
+    HsBool keep_cafs;
+
+    // Writer a for eventlog.
+    const EventLogWriter *eventlog_writer;
+
+    // Called before processing command-line flags, so that default
+    // settings for RtsFlags can be provided.
+    void (* defaultsHook) (void);
+
+    // Called just before exiting
+    void (* onExitHook) (void);
+
+    // Called on a stack overflow, before exiting
+    void (* stackOverflowHook) (W_ stack_size);
+
+    // Called on heap overflow, before exiting
+    void (* outOfHeapHook) (W_ request_size, W_ heap_size);
+
+    // Called when malloc() fails, before exiting
+    void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg);
+
+    // Called for every GC
+    void (* gcDoneHook) (const struct GCDetails_ *stats);
+
+    // Called when GC sync takes too long (+RTS --long-gc-sync=<time>)
+    void (* longGCSync) (uint32_t this_cap, Time time_ns);
+    void (* longGCSyncEnd) (Time time_ns);
+} RtsConfig;
+
+// Clients should start with defaultRtsConfig and then customise it.
+// Bah, I really wanted this to be a const struct value, but it seems
+// you can't do that in C (it generates code).
+extern const RtsConfig defaultRtsConfig;
+
+/* -----------------------------------------------------------------------------
+   Statistics
+   -------------------------------------------------------------------------- */
+
+//
+// Stats about a single GC
+//
+typedef struct GCDetails_ {
+    // The generation number of this GC
+  uint32_t gen;
+    // Number of threads used in this GC
+  uint32_t threads;
+    // Number of bytes allocated since the previous GC
+  uint64_t allocated_bytes;
+    // Total amount of live data in the heap (incliudes large + compact data).
+    // Updated after every GC. Data in uncollected generations (in minor GCs)
+    // are considered live.
+  uint64_t live_bytes;
+    // Total amount of live data in large objects
+  uint64_t large_objects_bytes;
+    // Total amount of live data in compact regions
+  uint64_t compact_bytes;
+    // Total amount of slop (wasted memory)
+  uint64_t slop_bytes;
+    // Total amount of memory in use by the RTS
+  uint64_t mem_in_use_bytes;
+    // Total amount of data copied during this GC
+  uint64_t copied_bytes;
+    // In parallel GC, the max amount of data copied by any one thread
+  uint64_t par_max_copied_bytes;
+  // In parallel GC, the amount of balanced data copied by all threads
+  uint64_t par_balanced_copied_bytes;
+    // The time elapsed during synchronisation before GC
+  Time sync_elapsed_ns;
+    // The CPU time used during GC itself
+  Time cpu_ns;
+    // The time elapsed during GC itself
+  Time elapsed_ns;
+} GCDetails;
+
+//
+// Stats about the RTS currently, and since the start of execution
+//
+typedef struct _RTSStats {
+
+  // -----------------------------------
+  // Cumulative stats about memory use
+
+    // Total number of GCs
+  uint32_t gcs;
+    // Total number of major (oldest generation) GCs
+  uint32_t major_gcs;
+    // Total bytes allocated
+  uint64_t allocated_bytes;
+    // Maximum live data (including large objects + compact regions) in the
+    // heap. Updated after a major GC.
+  uint64_t max_live_bytes;
+    // Maximum live data in large objects
+  uint64_t max_large_objects_bytes;
+    // Maximum live data in compact regions
+  uint64_t max_compact_bytes;
+    // Maximum slop
+  uint64_t max_slop_bytes;
+    // Maximum memory in use by the RTS
+  uint64_t max_mem_in_use_bytes;
+    // Sum of live bytes across all major GCs.  Divided by major_gcs
+    // gives the average live data over the lifetime of the program.
+  uint64_t cumulative_live_bytes;
+    // Sum of copied_bytes across all GCs
+  uint64_t copied_bytes;
+    // Sum of copied_bytes across all parallel GCs
+  uint64_t par_copied_bytes;
+    // Sum of par_max_copied_bytes across all parallel GCs
+  uint64_t cumulative_par_max_copied_bytes;
+    // Sum of par_balanced_copied_byes across all parallel GCs.
+  uint64_t cumulative_par_balanced_copied_bytes;
+
+  // -----------------------------------
+  // Cumulative stats about time use
+  // (we use signed values here because due to inaccuracies in timers
+  // the values can occasionally go slightly negative)
+
+    // Total CPU time used by the init phase
+  Time init_cpu_ns;
+    // Total elapsed time used by the init phase
+  Time init_elapsed_ns;
+    // Total CPU time used by the mutator
+  Time mutator_cpu_ns;
+    // Total elapsed time used by the mutator
+  Time mutator_elapsed_ns;
+    // Total CPU time used by the GC
+  Time gc_cpu_ns;
+    // Total elapsed time used by the GC
+  Time gc_elapsed_ns;
+    // Total CPU time (at the previous GC)
+  Time cpu_ns;
+    // Total elapsed time (at the previous GC)
+  Time elapsed_ns;
+
+  // -----------------------------------
+  // Stats about the most recent GC
+
+  GCDetails gc;
+
+  // -----------------------------------
+  // Internal Counters
+
+    // The number of times a GC thread spun on its 'gc_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t gc_spin_spin;
+    // The number of times a GC thread yielded on its 'gc_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t gc_spin_yield;
+    // The number of times a GC thread spun on its 'mut_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t mut_spin_spin;
+    // The number of times a GC thread yielded on its 'mut_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t mut_spin_yield;
+    // The number of times a GC thread has checked for work across all parallel
+    // GCs
+  uint64_t any_work;
+    // The number of times a GC thread has checked for work and found none
+    // across all parallel GCs
+  uint64_t no_work;
+    // The number of times a GC thread has iterated it's outer loop across all
+    // parallel GCs
+  uint64_t scav_find_work;
+} RTSStats;
+
+void getRTSStats (RTSStats *s);
+int getRTSStatsEnabled (void);
+
+// Returns the total number of bytes allocated since the start of the program.
+// TODO: can we remove this?
+uint64_t getAllocations (void);
+
+/* ----------------------------------------------------------------------------
+   Starting up and shutting down the Haskell RTS.
+   ------------------------------------------------------------------------- */
+
+/* DEPRECATED, use hs_init() or hs_init_ghc() instead  */
+extern void startupHaskell         ( int argc, char *argv[],
+                                     void (*init_root)(void) );
+
+/* DEPRECATED, use hs_exit() instead  */
+extern void shutdownHaskell        ( void );
+
+/* Like hs_init(), but allows rtsopts. For more complicated usage,
+ * use hs_init_ghc. */
+extern void hs_init_with_rtsopts (int *argc, char **argv[]);
+
+/*
+ * GHC-specific version of hs_init() that allows specifying whether
+ * +RTS ... -RTS options are allowed or not (default: only "safe"
+ * options are allowed), and allows passing an option string that is
+ * to be interpreted by the RTS only, not passed to the program.
+ */
+extern void hs_init_ghc (int *argc, char **argv[],   // program arguments
+                         RtsConfig rts_config);      // RTS configuration
+
+extern void shutdownHaskellAndExit (int exitCode, int fastExit)
+    GNUC3_ATTRIBUTE(__noreturn__);
+
+#if !defined(mingw32_HOST_OS)
+extern void shutdownHaskellAndSignal (int sig, int fastExit)
+     GNUC3_ATTRIBUTE(__noreturn__);
+#endif
+
+extern void getProgArgv            ( int *argc, char **argv[] );
+extern void setProgArgv            ( int argc, char *argv[] );
+extern void getFullProgArgv        ( int *argc, char **argv[] );
+extern void setFullProgArgv        ( int argc, char *argv[] );
+extern void freeFullProgArgv       ( void ) ;
+
+/* exit() override */
+extern void (*exitFn)(int);
+
+/* ----------------------------------------------------------------------------
+   Locking.
+
+   You have to surround all access to the RtsAPI with these calls.
+   ------------------------------------------------------------------------- */
+
+// acquires a token which may be used to create new objects and
+// evaluate them.
+Capability *rts_lock (void);
+
+// releases the token acquired with rts_lock().
+void rts_unlock (Capability *token);
+
+// If you are in a context where you know you have a current capability but
+// do not know what it is, then use this to get it. Basically this only
+// applies to "unsafe" foreign calls (as unsafe foreign calls are made with
+// the capability held).
+//
+// WARNING: There is *no* guarantee this returns anything sensible (eg NULL)
+// when there is no current capability.
+Capability *rts_unsafeGetMyCapability (void);
+
+/* ----------------------------------------------------------------------------
+   Which cpu should the OS thread and Haskell thread run on?
+
+   1. Run the current thread on the given capability:
+     rts_setInCallCapability(cap, 0);
+
+   2. Run the current thread on the given capability and set the cpu affinity
+      for this thread:
+     rts_setInCallCapability(cap, 1);
+
+   3. Run the current thread on the given numa node:
+     rts_pinThreadToNumaNode(node);
+
+   4. Run the current thread on the given capability and on the given numa node:
+     rts_setInCallCapability(cap, 0);
+     rts_pinThreadToNumaNode(cap);
+   ------------------------------------------------------------------------- */
+
+// Specify the Capability that the current OS thread should run on when it calls
+// into Haskell.  The actual capability will be calculated as the supplied
+// value modulo the number of enabled Capabilities.
+//
+// Note that the thread may still be migrated by the RTS scheduler, but that
+// will only happen if there are multiple threads running on one Capability and
+// another Capability is free.
+//
+// If affinity is non-zero, the current thread will be bound to
+// specific CPUs according to the prevailing affinity policy for the
+// specified capability, set by either +RTS -qa or +RTS --numa.
+void rts_setInCallCapability (int preferred_capability, int affinity);
+
+// Specify the CPU Node that the current OS thread should run on when it calls
+// into Haskell. The argument can be either a node number or capability number.
+// The actual node will be calculated as the supplied value modulo the number
+// of numa nodes.
+void rts_pinThreadToNumaNode (int node);
+
+/* ----------------------------------------------------------------------------
+   Building Haskell objects from C datatypes.
+   ------------------------------------------------------------------------- */
+HaskellObj   rts_mkChar       ( Capability *, HsChar   c );
+HaskellObj   rts_mkInt        ( Capability *, HsInt    i );
+HaskellObj   rts_mkInt8       ( Capability *, HsInt8   i );
+HaskellObj   rts_mkInt16      ( Capability *, HsInt16  i );
+HaskellObj   rts_mkInt32      ( Capability *, HsInt32  i );
+HaskellObj   rts_mkInt64      ( Capability *, HsInt64  i );
+HaskellObj   rts_mkWord       ( Capability *, HsWord   w );
+HaskellObj   rts_mkWord8      ( Capability *, HsWord8  w );
+HaskellObj   rts_mkWord16     ( Capability *, HsWord16 w );
+HaskellObj   rts_mkWord32     ( Capability *, HsWord32 w );
+HaskellObj   rts_mkWord64     ( Capability *, HsWord64 w );
+HaskellObj   rts_mkPtr        ( Capability *, HsPtr    a );
+HaskellObj   rts_mkFunPtr     ( Capability *, HsFunPtr a );
+HaskellObj   rts_mkFloat      ( Capability *, HsFloat  f );
+HaskellObj   rts_mkDouble     ( Capability *, HsDouble f );
+HaskellObj   rts_mkStablePtr  ( Capability *, HsStablePtr s );
+HaskellObj   rts_mkBool       ( Capability *, HsBool   b );
+HaskellObj   rts_mkString     ( Capability *, char    *s );
+
+HaskellObj   rts_apply        ( Capability *, HaskellObj, HaskellObj );
+
+/* ----------------------------------------------------------------------------
+   Deconstructing Haskell objects
+   ------------------------------------------------------------------------- */
+HsChar       rts_getChar      ( HaskellObj );
+HsInt        rts_getInt       ( HaskellObj );
+HsInt8       rts_getInt8      ( HaskellObj );
+HsInt16      rts_getInt16     ( HaskellObj );
+HsInt32      rts_getInt32     ( HaskellObj );
+HsInt64      rts_getInt64     ( HaskellObj );
+HsWord       rts_getWord      ( HaskellObj );
+HsWord8      rts_getWord8     ( HaskellObj );
+HsWord16     rts_getWord16    ( HaskellObj );
+HsWord32     rts_getWord32    ( HaskellObj );
+HsWord64     rts_getWord64    ( HaskellObj );
+HsPtr        rts_getPtr       ( HaskellObj );
+HsFunPtr     rts_getFunPtr    ( HaskellObj );
+HsFloat      rts_getFloat     ( HaskellObj );
+HsDouble     rts_getDouble    ( HaskellObj );
+HsStablePtr  rts_getStablePtr ( HaskellObj );
+HsBool       rts_getBool      ( HaskellObj );
+
+/* ----------------------------------------------------------------------------
+   Evaluating Haskell expressions
+
+   The versions ending in '_' allow you to specify an initial stack size.
+   Note that these calls may cause Garbage Collection, so all HaskellObj
+   references are rendered invalid by these calls.
+
+   All of these functions take a (Capability **) - there is a
+   Capability pointer both input and output.  We use an inout
+   parameter because this is less error-prone for the client than a
+   return value - the client could easily forget to use the return
+   value, whereas incorrectly using an inout parameter will usually
+   result in a type error.
+   ------------------------------------------------------------------------- */
+
+void rts_eval (/* inout */ Capability **,
+               /* in    */ HaskellObj p,
+               /* out */   HaskellObj *ret);
+
+void rts_eval_ (/* inout */ Capability **,
+                /* in    */ HaskellObj p,
+                /* in    */ unsigned int stack_size,
+                /* out   */ HaskellObj *ret);
+
+void rts_evalIO (/* inout */ Capability **,
+                 /* in    */ HaskellObj p,
+                 /* out */   HaskellObj *ret);
+
+void rts_evalStableIOMain (/* inout */ Capability **,
+                           /* in    */ HsStablePtr s,
+                           /* out */   HsStablePtr *ret);
+
+void rts_evalStableIO (/* inout */ Capability **,
+                       /* in    */ HsStablePtr s,
+                       /* out */   HsStablePtr *ret);
+
+void rts_evalLazyIO (/* inout */ Capability **,
+                     /* in    */ HaskellObj p,
+                     /* out */   HaskellObj *ret);
+
+void rts_evalLazyIO_ (/* inout */ Capability **,
+                      /* in    */ HaskellObj p,
+                      /* in    */ unsigned int stack_size,
+                      /* out   */ HaskellObj *ret);
+
+void rts_checkSchedStatus (char* site, Capability *);
+
+SchedulerStatus rts_getSchedStatus (Capability *cap);
+
+/*
+ * The RTS allocates some thread-local data when you make a call into
+ * Haskell using one of the rts_eval() functions.  This data is not
+ * normally freed until hs_exit().  If you want to free it earlier
+ * than this, perhaps because the thread is about to exit, then call
+ * rts_done() from the thread.
+ *
+ * It is safe to make more rts_eval() calls after calling rts_done(),
+ * but the next one will cause allocation of the thread-local memory
+ * again.
+ */
+void rts_done (void);
+
+/* --------------------------------------------------------------------------
+   Wrapper closures
+
+   These are used by foreign export and foreign import "wrapper" stubs.
+   ----------------------------------------------------------------------- */
+
+// When producing Windows DLLs the we need to know which symbols are in the
+//      local package/DLL vs external ones.
+//
+//      Note that RtsAPI.h is also included by foreign export stubs in
+//      the base package itself.
+//
+#if defined(COMPILING_WINDOWS_DLL) && !defined(COMPILING_BASE_PACKAGE)
+__declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[];
+__declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[];
+#else
+extern StgWord base_GHCziTopHandler_runIO_closure[];
+extern StgWord base_GHCziTopHandler_runNonIO_closure[];
+#endif
+
+#define runIO_closure     base_GHCziTopHandler_runIO_closure
+#define runNonIO_closure  base_GHCziTopHandler_runNonIO_closure
+
+/* ------------------------------------------------------------------------ */
+
+#if defined(__cplusplus)
+}
+#endif
diff --git a/includes/Stg.h b/includes/Stg.h
new file mode 100644
--- /dev/null
+++ b/includes/Stg.h
@@ -0,0 +1,599 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Top-level include file for everything required when compiling .hc
+ * code.  NOTE: in .hc files, Stg.h must be included *before* any
+ * other headers, because we define some register variables which must
+ * be done before any inline functions are defined (some system
+ * headers have been known to define the odd inline function).
+ *
+ * We generally try to keep as little visible as possible when
+ * compiling .hc files.  So for example the definitions of the
+ * InfoTable structs, closure structs and other RTS types are not
+ * visible here.  The compiler knows enough about the representations
+ * of these types to generate code which manipulates them directly
+ * with pointer arithmetic.
+ *
+ * In ordinary C code, do not #include this file directly: #include
+ * "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if !(__STDC_VERSION__ >= 199901L) && !(__cplusplus >= 201103L)
+# error __STDC_VERSION__ does not advertise C99, C++11 or later
+#endif
+
+/*
+ * If we are compiling a .hc file, then we want all the register
+ * variables.  This is the what happens if you #include "Stg.h" first:
+ * we assume this is a .hc file, and set IN_STG_CODE==1, which later
+ * causes the register variables to be enabled in stg/Regs.h.
+ *
+ * If instead "Rts.h" is included first, then we are compiling a
+ * vanilla C file.  Everything from Stg.h is provided, except that
+ * IN_STG_CODE is not defined, and the register variables will not be
+ * active.
+ */
+#if !defined(IN_STG_CODE)
+# define IN_STG_CODE 1
+
+// Turn on C99 for .hc code.  This gives us the INFINITY and NAN
+// constants from math.h, which we occasionally need to use in .hc (#1861)
+# define _ISOC99_SOURCE
+
+// We need _BSD_SOURCE so that math.h defines things like gamma
+// on Linux
+# define _BSD_SOURCE
+
+// On AIX we need _BSD defined, otherwise <math.h> includes <stdlib.h>
+# if defined(_AIX)
+#  define _BSD 1
+# endif
+
+// '_BSD_SOURCE' is deprecated since glibc-2.20
+// in favour of '_DEFAULT_SOURCE'
+# define _DEFAULT_SOURCE
+#endif
+
+#if IN_STG_CODE == 0 || defined(llvm_CC_FLAVOR)
+// C compilers that use an LLVM back end (clang or llvm-gcc) do not
+// correctly support global register variables so we make sure that
+// we do not declare them for these compilers.
+# define NO_GLOBAL_REG_DECLS    /* don't define fixed registers */
+#endif
+
+/* Configuration */
+#include "ghcconfig.h"
+
+/* The code generator calls the math functions directly in .hc code.
+   NB. after configuration stuff above, because this sets #defines
+   that depend on config info, such as __USE_FILE_OFFSET64 */
+#include <math.h>
+
+// On Solaris, we don't get the INFINITY and NAN constants unless we
+// #define _STDC_C99, and we can't do that unless we also use -std=c99,
+// because _STDC_C99 causes the headers to use C99 syntax (e.g. restrict).
+// We aren't ready for -std=c99 yet, so define INFINITY/NAN by hand using
+// the gcc builtins.
+#if !defined(INFINITY)
+#if defined(__GNUC__)
+#define INFINITY __builtin_inf()
+#else
+#error No definition for INFINITY
+#endif
+#endif
+
+#if !defined(NAN)
+#if defined(__GNUC__)
+#define NAN __builtin_nan("")
+#else
+#error No definition for NAN
+#endif
+#endif
+
+/* -----------------------------------------------------------------------------
+   Useful definitions
+   -------------------------------------------------------------------------- */
+
+/*
+ * The C backend likes to refer to labels by just mentioning their
+ * names.  However, when a symbol is declared as a variable in C, the
+ * C compiler will implicitly dereference it when it occurs in source.
+ * So we must subvert this behaviour for .hc files by declaring
+ * variables as arrays, which eliminates the implicit dereference.
+ */
+#if IN_STG_CODE
+#define RTS_VAR(x) (x)[]
+#define RTS_DEREF(x) (*(x))
+#else
+#define RTS_VAR(x) x
+#define RTS_DEREF(x) x
+#endif
+
+/* bit macros
+ */
+#define BITS_PER_BYTE 8
+#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))
+
+/* Compute offsets of struct fields
+ */
+#define STG_FIELD_OFFSET(s_type, field) ((StgWord)&(((s_type*)0)->field))
+
+/*
+ * 'Portable' inlining:
+ * INLINE_HEADER is for inline functions in header files (macros)
+ * STATIC_INLINE is for inline functions in source files
+ * EXTERN_INLINE is for functions that we want to inline sometimes
+ * (we also compile a static version of the function; see Inlines.c)
+ */
+
+// We generally assume C99 semantics albeit these two definitions work fine even
+// when gnu90 semantics are active (i.e. when __GNUC_GNU_INLINE__ is defined or
+// when a GCC older than 4.2 is used)
+//
+// The problem, however, is with 'extern inline' whose semantics significantly
+// differs between gnu90 and C99
+#define INLINE_HEADER static inline
+#define STATIC_INLINE static inline
+
+// Figure out whether `__attributes__((gnu_inline))` is needed
+// to force gnu90-style 'external inline' semantics.
+#if defined(FORCE_GNU_INLINE)
+// disable auto-detection since HAVE_GNU_INLINE has been defined externally
+#elif defined(__GNUC_GNU_INLINE__) && __GNUC__ == 4 && __GNUC_MINOR__ == 2
+// GCC 4.2.x didn't properly support C99 inline semantics (GCC 4.3 was the first
+// release to properly support C99 inline semantics), and therefore warned when
+// using 'extern inline' while in C99 mode unless `__attributes__((gnu_inline))`
+// was explicitly set.
+# define FORCE_GNU_INLINE 1
+#endif
+
+#if defined(FORCE_GNU_INLINE)
+// Force compiler into gnu90 semantics
+# if defined(KEEP_INLINES)
+#  define EXTERN_INLINE inline __attribute__((gnu_inline))
+# else
+#  define EXTERN_INLINE extern inline __attribute__((gnu_inline))
+# endif
+#elif defined(__GNUC_GNU_INLINE__)
+// we're currently in gnu90 inline mode by default and
+// __attribute__((gnu_inline)) may not be supported, so better leave it off
+# if defined(KEEP_INLINES)
+#  define EXTERN_INLINE inline
+# else
+#  define EXTERN_INLINE extern inline
+# endif
+#else
+// Assume C99 semantics (yes, this curiously results in swapped definitions!)
+// This is the preferred branch, and at some point we may drop support for
+// compilers not supporting C99 semantics altogether.
+# if defined(KEEP_INLINES)
+#  define EXTERN_INLINE extern inline
+# else
+#  define EXTERN_INLINE inline
+# endif
+#endif
+
+
+/*
+ * GCC attributes
+ */
+#if defined(__GNUC__)
+#define GNU_ATTRIBUTE(at) __attribute__((at))
+#else
+#define GNU_ATTRIBUTE(at)
+#endif
+
+#if __GNUC__ >= 3
+#define GNUC3_ATTRIBUTE(at) __attribute__((at))
+#else
+#define GNUC3_ATTRIBUTE(at)
+#endif
+
+/* Used to mark a switch case that falls-through */
+#if (defined(__GNUC__) && __GNUC__ >= 7)
+// N.B. Don't enable fallthrough annotations when compiling with Clang.
+// Apparently clang doesn't enable implicitly fallthrough warnings by default
+// http://llvm.org/viewvc/llvm-project?revision=167655&view=revision
+// when compiling C and the attribute cause warnings of their own (#16019).
+#define FALLTHROUGH GNU_ATTRIBUTE(fallthrough)
+#else
+#define FALLTHROUGH ((void)0)
+#endif /* __GNUC__ >= 7 */
+
+#if !defined(DEBUG) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))
+#define GNUC_ATTR_HOT __attribute__((hot))
+#else
+#define GNUC_ATTR_HOT /* nothing */
+#endif
+
+#define STG_UNUSED    GNUC3_ATTRIBUTE(__unused__)
+
+/* Prevent functions from being optimized.
+   See Note [Windows Stack allocations] */
+#if defined(__clang__)
+#define STG_NO_OPTIMIZE __attribute__((optnone))
+#elif defined(__GNUC__) || defined(__GNUG__)
+#define STG_NO_OPTIMIZE __attribute__((optimize("O0")))
+#else
+#define STG_NO_OPTIMIZE /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+   Global type definitions
+   -------------------------------------------------------------------------- */
+
+#include "MachDeps.h"
+#include "stg/Types.h"
+
+/* -----------------------------------------------------------------------------
+   Shorthand forms
+   -------------------------------------------------------------------------- */
+
+typedef StgChar      C_;
+typedef StgWord      W_;
+typedef StgWord*  P_;
+typedef StgInt    I_;
+typedef StgWord StgWordArray[];
+typedef StgFunPtr       F_;
+
+/* byte arrays (and strings): */
+#define EB_(X)    extern const char X[]
+#define IB_(X)    static const char X[]
+/* static (non-heap) closures (requires alignment for pointer tagging): */
+#define EC_(X)    extern       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+#define IC_(X)    static       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+/* writable data (does not require alignment): */
+#define ERW_(X)   extern       StgWordArray (X)
+#define IRW_(X)   static       StgWordArray (X)
+/* read-only data (does not require alignment): */
+#define ERO_(X)   extern const StgWordArray (X)
+#define IRO_(X)   static const StgWordArray (X)
+/* stg-native functions: */
+#define IF_(f)    static StgFunPtr GNUC3_ATTRIBUTE(used) f(void)
+#define FN_(f)           StgFunPtr f(void)
+#define EF_(f)           StgFunPtr f(void) /* External Cmm functions */
+/* foreign functions: */
+#define EFF_(f)   void f() /* See Note [External function prototypes] */
+
+/* Note [External function prototypes]  See #8965, #11395
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In generated C code we need to distinct between two types
+of external symbols:
+1.  Cmm functions declared by 'EF_' macro (External Functions)
+2.    C functions declared by 'EFF_' macro (External Foreign Functions)
+
+Cmm functions are simple as they are internal to GHC.
+
+C functions are trickier:
+
+The external-function macro EFF_(F) used to be defined as
+    extern StgFunPtr f(void)
+i.e a function of zero arguments.  On most platforms this doesn't
+matter very much: calls to these functions put the parameters in the
+usual places anyway, and (with the exception of varargs) things just
+work.
+
+However, the ELFv2 ABI on ppc64 optimises stack allocation
+(http://gcc.gnu.org/ml/gcc-patches/2013-11/msg01149.html): a call to a
+function that has a prototype, is not varargs, and receives all parameters
+in registers rather than on the stack does not require the caller to
+allocate an argument save area.  The incorrect prototypes cause GCC to
+believe that all functions declared this way can be called without an
+argument save area, but if the callee has sufficiently many arguments then
+it will expect that area to be present, and will thus corrupt the caller's
+stack.  This happens in particular with calls to runInteractiveProcess in
+libraries/process/cbits/runProcess.c, and led to #8965.
+
+The simplest fix appears to be to declare these external functions with an
+unspecified argument list rather than a void argument list.  This is no
+worse for platforms that don't care either way, and allows a successful
+bootstrap of GHC 7.8 on little-endian Linux ppc64 (which uses the ELFv2
+ABI).
+
+Another case is m68k ABI where 'void*' return type is returned by 'a0'
+register while 'long' return type is returned by 'd0'. Thus we trick
+external prototype return neither of these types to workaround #11395.
+*/
+
+
+/* -----------------------------------------------------------------------------
+   Tail calls
+   -------------------------------------------------------------------------- */
+
+#define JMP_(cont) return((StgFunPtr)(cont))
+
+/* -----------------------------------------------------------------------------
+   Other Stg stuff...
+   -------------------------------------------------------------------------- */
+
+#include "stg/DLL.h"
+#include "stg/RtsMachRegs.h"
+#include "stg/Regs.h"
+#include "stg/Ticky.h"
+
+#if IN_STG_CODE
+/*
+ * This is included later for RTS sources, after definitions of
+ * StgInfoTable, StgClosure and so on.
+ */
+#include "stg/MiscClosures.h"
+#endif
+
+#include "stg/Prim.h" /* ghc-prim fallbacks */
+#include "stg/SMP.h" // write_barrier() inline is required
+
+/* -----------------------------------------------------------------------------
+   Moving Floats and Doubles
+
+   ASSIGN_FLT is for assigning a float to memory (usually the
+              stack/heap).  The memory address is guaranteed to be
+         StgWord aligned (currently == sizeof(void *)).
+
+   PK_FLT     is for pulling a float out of memory.  The memory is
+              guaranteed to be StgWord aligned.
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER void     ASSIGN_FLT (W_ [], StgFloat);
+INLINE_HEADER StgFloat    PK_FLT     (W_ []);
+
+#if ALIGNMENT_FLOAT <= ALIGNMENT_VOID_P
+
+INLINE_HEADER void     ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
+INLINE_HEADER StgFloat PK_FLT    (W_ p_src[])                { return *(StgFloat *)p_src; }
+
+#else  /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */
+
+INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)
+{
+    float_thing y;
+    y.f = src;
+    *p_dest = y.fu;
+}
+
+INLINE_HEADER StgFloat PK_FLT(W_ p_src[])
+{
+    float_thing y;
+    y.fu = *p_src;
+    return(y.f);
+}
+
+#endif /* ALIGNMENT_FLOAT > ALIGNMENT_VOID_P */
+
+#if ALIGNMENT_DOUBLE <= ALIGNMENT_VOID_P
+
+INLINE_HEADER void     ASSIGN_DBL (W_ [], StgDouble);
+INLINE_HEADER StgDouble   PK_DBL     (W_ []);
+
+INLINE_HEADER void      ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
+INLINE_HEADER StgDouble PK_DBL    (W_ p_src[])                 { return *(StgDouble *)p_src; }
+
+#else /* ALIGNMENT_DOUBLE > ALIGNMENT_VOID_P */
+
+/* Sparc uses two floating point registers to hold a double.  We can
+ * write ASSIGN_DBL and PK_DBL by directly accessing the registers
+ * independently - unfortunately this code isn't writable in C, we
+ * have to use inline assembler.
+ */
+#if defined(sparc_HOST_ARCH)
+
+#define ASSIGN_DBL(dst0,src) \
+    { StgPtr dst = (StgPtr)(dst0); \
+      __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
+   "=m" (((P_)(dst))[1]) : "f" (src)); \
+    }
+
+#define PK_DBL(src0) \
+    ( { StgPtr src = (StgPtr)(src0); \
+        register double d; \
+      __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
+   "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
+    } )
+
+#else /* ! sparc_HOST_ARCH */
+
+INLINE_HEADER void     ASSIGN_DBL (W_ [], StgDouble);
+INLINE_HEADER StgDouble   PK_DBL     (W_ []);
+
+typedef struct
+  { StgWord dhi;
+    StgWord dlo;
+  } unpacked_double;
+
+typedef union
+  { StgDouble d;
+    unpacked_double du;
+  } double_thing;
+
+INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)
+{
+    double_thing y;
+    y.d = src;
+    p_dest[0] = y.du.dhi;
+    p_dest[1] = y.du.dlo;
+}
+
+/* GCC also works with this version, but it generates
+   the same code as the previous one, and is not ANSI
+
+#define ASSIGN_DBL( p_dest, src ) \
+   *p_dest = ((double_thing) src).du.dhi; \
+   *(p_dest+1) = ((double_thing) src).du.dlo \
+*/
+
+INLINE_HEADER StgDouble PK_DBL(W_ p_src[])
+{
+    double_thing y;
+    y.du.dhi = p_src[0];
+    y.du.dlo = p_src[1];
+    return(y.d);
+}
+
+#endif /* ! sparc_HOST_ARCH */
+
+#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */
+
+
+/* -----------------------------------------------------------------------------
+   Moving 64-bit quantities around
+
+   ASSIGN_Word64      assign an StgWord64/StgInt64 to a memory location
+   PK_Word64          load an StgWord64/StgInt64 from a amemory location
+
+   In both cases the memory location might not be 64-bit aligned.
+   -------------------------------------------------------------------------- */
+
+#if SIZEOF_HSWORD == 4
+
+typedef struct
+  { StgWord dhi;
+    StgWord dlo;
+  } unpacked_double_word;
+
+typedef union
+  { StgInt64 i;
+    unpacked_double_word iu;
+  } int64_thing;
+
+typedef union
+  { StgWord64 w;
+    unpacked_double_word wu;
+  } word64_thing;
+
+INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+    word64_thing y;
+    y.w = src;
+    p_dest[0] = y.wu.dhi;
+    p_dest[1] = y.wu.dlo;
+}
+
+INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
+{
+    word64_thing y;
+    y.wu.dhi = p_src[0];
+    y.wu.dlo = p_src[1];
+    return(y.w);
+}
+
+INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+    int64_thing y;
+    y.i = src;
+    p_dest[0] = y.iu.dhi;
+    p_dest[1] = y.iu.dlo;
+}
+
+INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
+{
+    int64_thing y;
+    y.iu.dhi = p_src[0];
+    y.iu.dlo = p_src[1];
+    return(y.i);
+}
+
+#elif SIZEOF_VOID_P == 8
+
+INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+   p_dest[0] = src;
+}
+
+INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
+{
+    return p_src[0];
+}
+
+INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+    p_dest[0] = src;
+}
+
+INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
+{
+    return p_src[0];
+}
+
+#endif /* SIZEOF_HSWORD == 4 */
+
+/* -----------------------------------------------------------------------------
+   Integer multiply with overflow
+   -------------------------------------------------------------------------- */
+
+/* Multiply with overflow checking.
+ *
+ * This is tricky - the usual sign rules for add/subtract don't apply.
+ *
+ * On 32-bit machines we use gcc's 'long long' types, finding
+ * overflow with some careful bit-twiddling.
+ *
+ * On 64-bit machines where gcc's 'long long' type is also 64-bits,
+ * we use a crude approximation, testing whether either operand is
+ * larger than 32-bits; if neither is, then we go ahead with the
+ * multiplication.
+ *
+ * Return non-zero if there is any possibility that the signed multiply
+ * of a and b might overflow.  Return zero only if you are absolutely sure
+ * that it won't overflow.  If in doubt, return non-zero.
+ */
+
+#if SIZEOF_VOID_P == 4
+
+#if defined(WORDS_BIGENDIAN)
+#define RTS_CARRY_IDX__ 0
+#define RTS_REM_IDX__  1
+#else
+#define RTS_CARRY_IDX__ 1
+#define RTS_REM_IDX__ 0
+#endif
+
+typedef union {
+    StgInt64 l;
+    StgInt32 i[2];
+} long_long_u ;
+
+#define mulIntMayOflo(a,b)       \
+({                                              \
+  StgInt32 r, c;           \
+  long_long_u z;           \
+  z.l = (StgInt64)a * (StgInt64)b;     \
+  r = z.i[RTS_REM_IDX__];        \
+  c = z.i[RTS_CARRY_IDX__];         \
+  if (c == 0 || c == -1) {       \
+    c = ((StgWord)((a^b) ^ r))         \
+      >> (BITS_IN (I_) - 1);        \
+  }                  \
+  c;                                            \
+})
+
+/* Careful: the carry calculation above is extremely delicate.  Make sure
+ * you test it thoroughly after changing it.
+ */
+
+#else
+
+/* Approximate version when we don't have long arithmetic (on 64-bit archs) */
+
+/* If we have n-bit words then we have n-1 bits after accounting for the
+ * sign bit, so we can fit the result of multiplying 2 (n-1)/2-bit numbers */
+#define HALF_POS_INT  (((I_)1) << ((BITS_IN (I_) - 1) / 2))
+#define HALF_NEG_INT  (-HALF_POS_INT)
+
+#define mulIntMayOflo(a,b)       \
+({                                              \
+  I_ c;              \
+  if ((I_)a <= HALF_NEG_INT || a >= HALF_POS_INT    \
+      || (I_)b <= HALF_NEG_INT || b >= HALF_POS_INT) {\
+    c = 1;              \
+  } else {              \
+    c = 0;              \
+  }                  \
+  c;                                            \
+})
+#endif
diff --git a/includes/ghcconfig.h b/includes/ghcconfig.h
new file mode 100644
--- /dev/null
+++ b/includes/ghcconfig.h
@@ -0,0 +1,4 @@
+#pragma once
+
+#include "ghcautoconf.h"
+#include "ghcplatform.h"
diff --git a/includes/rts/Adjustor.h b/includes/rts/Adjustor.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Adjustor.h
@@ -0,0 +1,22 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Adjustor API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* Creating and destroying an adjustor thunk */
+void* createAdjustor (int cconv, 
+                      StgStablePtr hptr,
+                      StgFunPtr wptr,
+                      char *typeString);
+
+void freeHaskellFunctionPtr (void* ptr);
diff --git a/includes/rts/BlockSignals.h b/includes/rts/BlockSignals.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/BlockSignals.h
@@ -0,0 +1,34 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS signal handling 
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Used by runProcess() in the process package
+ */
+
+/*
+ * Function: blockUserSignals()
+ *
+ * Temporarily block the delivery of further console events. Needed to
+ * avoid race conditions when GCing the queue of outstanding handlers or
+ * when emptying the queue by running the handlers.
+ * 
+ */
+void blockUserSignals(void);
+
+/*
+ * Function: unblockUserSignals()
+ *
+ * The inverse of blockUserSignals(); re-enable the deliver of console events.
+ */
+void unblockUserSignals(void);
diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Bytecodes.h
@@ -0,0 +1,106 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Bytecode definitions.
+ *
+ * ---------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Instructions
+ *
+ * Notes:
+ * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"
+ *   pattern which fails.  If we don't see too many of these, we could
+ *   optimise out the redundant test.
+ * ------------------------------------------------------------------------*/
+
+/* NOTE:
+
+   THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/ghci/ByteCodeAsm.hs).
+   DO NOT PUT C-SPECIFIC STUFF IN HERE!
+
+   I hope that's clear :-)
+*/
+
+#define bci_STKCHECK  			1
+#define bci_PUSH_L    			2
+#define bci_PUSH_LL   			3
+#define bci_PUSH_LLL  			4
+#define bci_PUSH8                       5
+#define bci_PUSH16                      6
+#define bci_PUSH32                      7
+#define bci_PUSH8_W                     8
+#define bci_PUSH16_W                    9
+#define bci_PUSH32_W                    10
+#define bci_PUSH_G    			11
+#define bci_PUSH_ALTS  			12
+#define bci_PUSH_ALTS_P			13
+#define bci_PUSH_ALTS_N			14
+#define bci_PUSH_ALTS_F			15
+#define bci_PUSH_ALTS_D			16
+#define bci_PUSH_ALTS_L			17
+#define bci_PUSH_ALTS_V			18
+#define bci_PUSH_PAD8                   19
+#define bci_PUSH_PAD16                  20
+#define bci_PUSH_PAD32                  21
+#define bci_PUSH_UBX8                   22
+#define bci_PUSH_UBX16                  23
+#define bci_PUSH_UBX32                  24
+#define bci_PUSH_UBX  			25
+#define bci_PUSH_APPLY_N		26
+#define bci_PUSH_APPLY_F		27
+#define bci_PUSH_APPLY_D		28
+#define bci_PUSH_APPLY_L		29
+#define bci_PUSH_APPLY_V		30
+#define bci_PUSH_APPLY_P		31
+#define bci_PUSH_APPLY_PP		32
+#define bci_PUSH_APPLY_PPP		33
+#define bci_PUSH_APPLY_PPPP		34
+#define bci_PUSH_APPLY_PPPPP		35
+#define bci_PUSH_APPLY_PPPPPP		36
+/* #define bci_PUSH_APPLY_PPPPPPP		37 */
+#define bci_SLIDE     			38
+#define bci_ALLOC_AP   			39
+#define bci_ALLOC_AP_NOUPD		40
+#define bci_ALLOC_PAP  			41
+#define bci_MKAP      			42
+#define bci_MKPAP      			43
+#define bci_UNPACK    			44
+#define bci_PACK      			45
+#define bci_TESTLT_I   			46
+#define bci_TESTEQ_I  			47
+#define bci_TESTLT_F  			48
+#define bci_TESTEQ_F  			49
+#define bci_TESTLT_D  			50
+#define bci_TESTEQ_D  			51
+#define bci_TESTLT_P  			52
+#define bci_TESTEQ_P  			53
+#define bci_CASEFAIL  			54
+#define bci_JMP       			55
+#define bci_CCALL     			56
+#define bci_SWIZZLE   			57
+#define bci_ENTER     			58
+#define bci_RETURN    			59
+#define bci_RETURN_P 			60
+#define bci_RETURN_N 			61
+#define bci_RETURN_F 			62
+#define bci_RETURN_D 			63
+#define bci_RETURN_L 			64
+#define bci_RETURN_V 			65
+#define bci_BRK_FUN			66
+#define bci_TESTLT_W   			67
+#define bci_TESTEQ_W  			68
+/* If you need to go past 255 then you will run into the flags */
+
+/* If you need to go below 0x0100 then you will run into the instructions */
+#define bci_FLAG_LARGE_ARGS     0x8000
+
+/* If a BCO definitely requires less than this many words of stack,
+   don't include an explicit STKCHECK insn in it.  The interpreter
+   will check for this many words of stack before running each BCO,
+   rendering an explicit check unnecessary in the majority of
+   cases. */
+#define INTERP_STACK_CHECK_THRESH  50
+
+/*-------------------------------------------------------------------------*/
diff --git a/includes/rts/Config.h b/includes/rts/Config.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Config.h
@@ -0,0 +1,48 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Rts settings.
+ *
+ * NOTE: assumes #include "ghcconfig.h"
+ * 
+ * NB: THIS FILE IS INCLUDED IN NON-C CODE AND DATA!  #defines only please.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(TICKY_TICKY) && defined(THREADED_RTS)
+#error TICKY_TICKY is incompatible with THREADED_RTS
+#endif
+
+/*
+ * Whether the runtime system will use libbfd for debugging purposes.
+ */
+#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32)
+#define USING_LIBBFD 1
+#endif
+
+/* DEBUG implies TRACING and TICKY_TICKY  */
+#if defined(DEBUG)
+#if !defined(TRACING)
+#define TRACING
+#endif
+#if !defined(TICKY_TICKY)
+#define TICKY_TICKY
+#endif
+#endif
+
+
+/* -----------------------------------------------------------------------------
+   Signals - supported on non-PAR versions of the runtime.  See RtsSignals.h.
+   -------------------------------------------------------------------------- */
+
+#define RTS_USER_SIGNALS 1
+
+/* Profile spin locks */
+
+#define PROF_SPIN
diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Constants.h
@@ -0,0 +1,332 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Constants
+ *
+ * NOTE: this information is used by both the compiler and the RTS.
+ * Some of it is tweakable, and some of it must be kept up to date
+ * with various other parts of the system.
+ *
+ * Constants which are derived automatically from other definitions in
+ * the system (eg. structure sizes) are generated into the file
+ * DerivedConstants.h by a C program (mkDerivedConstantsHdr).
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   Minimum closure sizes
+
+   This is the minimum number of words in the payload of a
+   heap-allocated closure, so that the closure has enough room to be
+   overwritten with a forwarding pointer during garbage collection.
+   -------------------------------------------------------------------------- */
+
+#define MIN_PAYLOAD_SIZE 1
+
+/* -----------------------------------------------------------------------------
+   Constants to do with specialised closure types.
+   -------------------------------------------------------------------------- */
+
+/* We have some pre-compiled selector thunks defined in rts/StgStdThunks.hc.
+ * This constant defines the highest selectee index that we can replace with a
+ * reference to the pre-compiled code.
+ */
+
+#define MAX_SPEC_SELECTEE_SIZE 15
+
+/* Vector-apply thunks.  These thunks just push their free variables
+ * on the stack and enter the first one.  They're a bit like PAPs, but
+ * don't have a dynamic size.  We've pre-compiled a few to save
+ * space.
+ */
+
+#define MAX_SPEC_AP_SIZE       7
+
+/* Specialised FUN/THUNK/CONSTR closure types */
+
+#define MAX_SPEC_THUNK_SIZE    2
+#define MAX_SPEC_FUN_SIZE      2
+#define MAX_SPEC_CONSTR_SIZE   2
+
+/* Range of built-in table of static small int-like and char-like closures.
+ *
+ *   NB. This corresponds with the number of actual INTLIKE/CHARLIKE
+ *   closures defined in rts/StgMiscClosures.cmm.
+ */
+#define MAX_INTLIKE             16
+#define MIN_INTLIKE             (-16)
+
+#define MAX_CHARLIKE            255
+#define MIN_CHARLIKE            0
+
+/* Each byte in the card table for an StgMutaArrPtrs covers
+ * (1<<MUT_ARR_PTRS_CARD_BITS) elements in the array.  To find a good
+ * value for this, I used the benchmarks nofib/gc/hash,
+ * nofib/gc/graph, and nofib/gc/gc_bench.
+ */
+#define MUT_ARR_PTRS_CARD_BITS 7
+
+/* -----------------------------------------------------------------------------
+   STG Registers.
+
+   Note that in MachRegs.h we define how many of these registers are
+   *real* machine registers, and not just offsets in the Register Table.
+   -------------------------------------------------------------------------- */
+
+#define MAX_VANILLA_REG 10
+#define MAX_FLOAT_REG   6
+#define MAX_DOUBLE_REG  6
+#define MAX_LONG_REG    1
+#define MAX_XMM_REG     6
+
+/* -----------------------------------------------------------------------------
+   Semi-Tagging constants
+
+   Old Comments about this stuff:
+
+   Tags for indirection nodes and ``other'' (probably unevaluated) nodes;
+   normal-form values of algebraic data types will have tags 0, 1, ...
+
+   @INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count
+   how often we bang into indirection nodes; that's all.  (WDP 95/11)
+
+   ToDo: find out if we need any of this.
+   -------------------------------------------------------------------------- */
+
+#define INFO_OTHER_TAG          (-1)
+#define INFO_IND_TAG            (-2)
+#define INFO_FIRST_TAG          0
+
+/* -----------------------------------------------------------------------------
+   How much C stack to reserve for local temporaries when in the STG
+   world.  Used in StgCRun.c.
+   -------------------------------------------------------------------------- */
+
+#define RESERVED_C_STACK_BYTES (2048 * SIZEOF_LONG)
+
+/* -----------------------------------------------------------------------------
+   How large is the stack frame saved by StgRun?
+   world.  Used in StgCRun.c.
+
+   The size has to be enough to save the registers (see StgCRun)
+   plus padding if the result is not 16 byte aligned.
+   See the Note [Stack Alignment on X86] in StgCRun.c for details.
+
+   -------------------------------------------------------------------------- */
+#if defined(x86_64_HOST_ARCH)
+#  if defined(mingw32_HOST_OS)
+#    define STG_RUN_STACK_FRAME_SIZE 144
+#  else
+#    define STG_RUN_STACK_FRAME_SIZE 48
+#  endif
+#endif
+
+/* -----------------------------------------------------------------------------
+   StgRun related labels shared between StgCRun.c and StgStartup.cmm.
+   -------------------------------------------------------------------------- */
+
+#if defined(LEADING_UNDERSCORE)
+#define STG_RUN "_StgRun"
+#define STG_RUN_JMP _StgRunJmp
+#define STG_RETURN "_StgReturn"
+#else
+#define STG_RUN "StgRun"
+#define STG_RUN_JMP StgRunJmp
+#define STG_RETURN "StgReturn"
+#endif
+
+/* -----------------------------------------------------------------------------
+   How much Haskell stack space to reserve for the saving of registers
+   etc. in the case of a stack/heap overflow.
+
+   This must be large enough to accommodate the largest stack frame
+   pushed in one of the heap check fragments in HeapStackCheck.hc
+   (ie. currently the generic heap checks - 3 words for StgRetDyn,
+   18 words for the saved registers, see StgMacros.h).
+   -------------------------------------------------------------------------- */
+
+#define RESERVED_STACK_WORDS 21
+
+/* -----------------------------------------------------------------------------
+   The limit on the size of the stack check performed when we enter an
+   AP_STACK, in words.  See raiseAsync() and bug #1466.
+   -------------------------------------------------------------------------- */
+
+#define AP_STACK_SPLIM 1024
+
+/* -----------------------------------------------------------------------------
+   Storage manager constants
+   -------------------------------------------------------------------------- */
+
+/* The size of a block (2^BLOCK_SHIFT bytes) */
+#define BLOCK_SHIFT  12
+
+/* The size of a megablock (2^MBLOCK_SHIFT bytes) */
+#define MBLOCK_SHIFT   20
+
+/* -----------------------------------------------------------------------------
+   Bitmap/size fields (used in info tables)
+   -------------------------------------------------------------------------- */
+
+/* In a 32-bit bitmap field, we use 5 bits for the size, and 27 bits
+ * for the bitmap.  If the bitmap requires more than 27 bits, then we
+ * store it in a separate array, and leave a pointer in the bitmap
+ * field.  On a 64-bit machine, the sizes are extended accordingly.
+ */
+#if SIZEOF_VOID_P == 4
+#define BITMAP_SIZE_MASK     0x1f
+#define BITMAP_BITS_SHIFT    5
+#elif SIZEOF_VOID_P == 8
+#define BITMAP_SIZE_MASK     0x3f
+#define BITMAP_BITS_SHIFT    6
+#else
+#error unknown SIZEOF_VOID_P
+#endif
+
+/* -----------------------------------------------------------------------------
+   Lag/Drag/Void constants
+   -------------------------------------------------------------------------- */
+
+/*
+  An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation
+  time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK).
+ */
+#if SIZEOF_VOID_P == 8
+#define LDV_SHIFT               30
+#define LDV_STATE_MASK          0x1000000000000000
+#define LDV_CREATE_MASK         0x0FFFFFFFC0000000
+#define LDV_LAST_MASK           0x000000003FFFFFFF
+#define LDV_STATE_CREATE        0x0000000000000000
+#define LDV_STATE_USE           0x1000000000000000
+#else
+#define LDV_SHIFT               15
+#define LDV_STATE_MASK          0x40000000
+#define LDV_CREATE_MASK         0x3FFF8000
+#define LDV_LAST_MASK           0x00007FFF
+#define LDV_STATE_CREATE        0x00000000
+#define LDV_STATE_USE           0x40000000
+#endif /* SIZEOF_VOID_P */
+
+/* -----------------------------------------------------------------------------
+   TSO related constants
+   -------------------------------------------------------------------------- */
+
+/*
+ * Constants for the what_next field of a TSO, which indicates how it
+ * is to be run.
+ */
+#define ThreadRunGHC    1       /* return to address on top of stack */
+#define ThreadInterpret 2       /* interpret this thread */
+#define ThreadKilled    3       /* thread has died, don't run it */
+#define ThreadComplete  4       /* thread has finished */
+
+/*
+ * Constants for the why_blocked field of a TSO
+ * NB. keep these in sync with GHC/Conc/Sync.hs: threadStatus
+ */
+#define NotBlocked          0
+#define BlockedOnMVar       1
+#define BlockedOnMVarRead   14 /* TODO: renumber me, see #9003 */
+#define BlockedOnBlackHole  2
+#define BlockedOnRead       3
+#define BlockedOnWrite      4
+#define BlockedOnDelay      5
+#define BlockedOnSTM        6
+
+/* Win32 only: */
+#define BlockedOnDoProc     7
+
+/* Only relevant for THREADED_RTS: */
+#define BlockedOnCCall      10
+#define BlockedOnCCall_Interruptible 11
+   /* same as above but permit killing the worker thread */
+
+/* Involved in a message sent to tso->msg_cap */
+#define BlockedOnMsgThrowTo 12
+
+/* The thread is not on any run queues, but can be woken up
+   by tryWakeupThread() */
+#define ThreadMigrating     13
+
+/* WARNING WARNING top number is BlockedOnMVarRead 14, not 13!! */
+
+/*
+ * These constants are returned to the scheduler by a thread that has
+ * stopped for one reason or another.  See typedef StgThreadReturnCode
+ * in TSO.h.
+ */
+#define HeapOverflow   1                /* might also be StackOverflow */
+#define StackOverflow  2
+#define ThreadYielding 3
+#define ThreadBlocked  4
+#define ThreadFinished 5
+
+/*
+ * Flags for the tso->flags field.
+ */
+
+/*
+ * TSO_LOCKED is set when a TSO is locked to a particular Capability.
+ */
+#define TSO_LOCKED  2
+
+/*
+ * TSO_BLOCKEX: the TSO is blocking exceptions
+ *
+ * TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks
+ * interruptibly (eg. with BlockedOnMVar).
+ *
+ * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint
+ */
+#define TSO_BLOCKEX       4
+#define TSO_INTERRUPTIBLE 8
+#define TSO_STOPPED_ON_BREAKPOINT 16
+
+/*
+ * Used by the sanity checker to check whether TSOs are on the correct
+ * mutable list.
+ */
+#define TSO_MARKED 64
+
+/*
+ * Used to communicate between stackSqueeze() and
+ * threadStackOverflow() that a thread's stack was squeezed and the
+ * stack may not need to be expanded.
+ */
+#define TSO_SQUEEZED 128
+
+/*
+ * Enables the AllocationLimitExceeded exception when the thread's
+ * allocation limit goes negative.
+ */
+#define TSO_ALLOC_LIMIT 256
+
+/*
+ * The number of times we spin in a spin lock before yielding (see
+ * #3758).  To tune this value, use the benchmark in #3758: run the
+ * server with -N2 and the client both on a dual-core.  Also make sure
+ * that the chosen value doesn't slow down any of the parallel
+ * benchmarks in nofib/parallel.
+ */
+#define SPIN_COUNT 1000
+
+/* -----------------------------------------------------------------------------
+   Spare workers per Capability in the threaded RTS
+
+   No more than MAX_SPARE_WORKERS will be kept in the thread pool
+   associated with each Capability.
+   -------------------------------------------------------------------------- */
+
+#define MAX_SPARE_WORKERS 6
+
+/*
+ * The maximum number of NUMA nodes we support.  This is a fixed limit so that
+ * we can have static arrays of this size in the RTS for speed.
+ */
+#define MAX_NUMA_NODES 16
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/EventLogFormat.h
@@ -0,0 +1,264 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Event log format
+ *
+ * The log format is designed to be extensible: old tools should be
+ * able to parse (but not necessarily understand all of) new versions
+ * of the format, and new tools will be able to understand old log
+ * files.
+ *
+ * Each event has a specific format.  If you add new events, give them
+ * new numbers: we never re-use old event numbers.
+ *
+ * - The format is endian-independent: all values are represented in
+ *    bigendian order.
+ *
+ * - The format is extensible:
+ *
+ *    - The header describes each event type and its length.  Tools
+ *      that don't recognise a particular event type can skip those events.
+ *
+ *    - There is room for extra information in the event type
+ *      specification, which can be ignored by older tools.
+ *
+ *    - Events can have extra information added, but existing fields
+ *      cannot be changed.  Tools should ignore extra fields at the
+ *      end of the event record.
+ *
+ *    - Old event type ids are never re-used; just take a new identifier.
+ *
+ *
+ * The format
+ * ----------
+ *
+ * log : EVENT_HEADER_BEGIN
+ *       EventType*
+ *       EVENT_HEADER_END
+ *       EVENT_DATA_BEGIN
+ *       Event*
+ *       EVENT_DATA_END
+ *
+ * EventType :
+ *       EVENT_ET_BEGIN
+ *       Word16         -- unique identifier for this event
+ *       Int16          -- >=0  size of the event in bytes (minus the header)
+ *                      -- -1   variable size
+ *       Word32         -- length of the next field in bytes
+ *       Word8*         -- string describing the event
+ *       Word32         -- length of the next field in bytes
+ *       Word8*         -- extra info (for future extensions)
+ *       EVENT_ET_END
+ *
+ * Event :
+ *       Word16         -- event_type
+ *       Word64         -- time (nanosecs)
+ *       [Word16]       -- length of the rest (for variable-sized events only)
+ *       ... extra event-specific info ...
+ *
+ *
+ * To add a new event
+ * ------------------
+ *
+ *  - In this file:
+ *    - give it a new number, add a new #define EVENT_XXX below
+ *  - In EventLog.c
+ *    - add it to the EventDesc array
+ *    - emit the event type in initEventLogging()
+ *    - emit the new event in postEvent_()
+ *    - generate the event itself by calling postEvent() somewhere
+ *  - In the Haskell code to parse the event log file:
+ *    - add types and code to read the new event
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * Markers for begin/end of the Header.
+ */
+#define EVENT_HEADER_BEGIN    0x68647262 /* 'h' 'd' 'r' 'b' */
+#define EVENT_HEADER_END      0x68647265 /* 'h' 'd' 'r' 'e' */
+
+#define EVENT_DATA_BEGIN      0x64617462 /* 'd' 'a' 't' 'b' */
+#define EVENT_DATA_END        0xffff
+
+/*
+ * Markers for begin/end of the list of Event Types in the Header.
+ * Header, Event Type, Begin = hetb
+ * Header, Event Type, End = hete
+ */
+#define EVENT_HET_BEGIN       0x68657462 /* 'h' 'e' 't' 'b' */
+#define EVENT_HET_END         0x68657465 /* 'h' 'e' 't' 'e' */
+
+#define EVENT_ET_BEGIN        0x65746200 /* 'e' 't' 'b' 0 */
+#define EVENT_ET_END          0x65746500 /* 'e' 't' 'e' 0 */
+
+/*
+ * Types of event
+ */
+#define EVENT_CREATE_THREAD        0 /* (thread)               */
+#define EVENT_RUN_THREAD           1 /* (thread)               */
+#define EVENT_STOP_THREAD          2 /* (thread, status, blockinfo) */
+#define EVENT_THREAD_RUNNABLE      3 /* (thread)               */
+#define EVENT_MIGRATE_THREAD       4 /* (thread, new_cap)      */
+/* 5, 6, 7 deprecated */
+#define EVENT_THREAD_WAKEUP        8 /* (thread, other_cap)    */
+#define EVENT_GC_START             9 /* ()                     */
+#define EVENT_GC_END              10 /* ()                     */
+#define EVENT_REQUEST_SEQ_GC      11 /* ()                     */
+#define EVENT_REQUEST_PAR_GC      12 /* ()                     */
+/* 13, 14 deprecated */
+#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread)         */
+#define EVENT_LOG_MSG             16 /* (message ...)          */
+/* 17 deprecated */
+#define EVENT_BLOCK_MARKER        18 /* (size, end_time, capability) */
+#define EVENT_USER_MSG            19 /* (message ...)          */
+#define EVENT_GC_IDLE             20 /* () */
+#define EVENT_GC_WORK             21 /* () */
+#define EVENT_GC_DONE             22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE       25 /* (capset, capset_type)  */
+#define EVENT_CAPSET_DELETE       26 /* (capset)               */
+#define EVENT_CAPSET_ASSIGN_CAP   27 /* (capset, cap)          */
+#define EVENT_CAPSET_REMOVE_CAP   28 /* (capset, cap)          */
+/* the RTS identifier is in the form of "GHC-version rts_way"  */
+#define EVENT_RTS_IDENTIFIER      29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings             */
+#define EVENT_PROGRAM_ARGS        30 /* (capset, commandline_vector)  */
+#define EVENT_PROGRAM_ENV         31 /* (capset, environment_vector)  */
+#define EVENT_OSPROCESS_PID       32 /* (capset, pid)          */
+#define EVENT_OSPROCESS_PPID      33 /* (capset, parent_pid)   */
+#define EVENT_SPARK_COUNTERS      34 /* (crt,dud,ovf,cnv,gcd,fiz,rem) */
+#define EVENT_SPARK_CREATE        35 /* ()                     */
+#define EVENT_SPARK_DUD           36 /* ()                     */
+#define EVENT_SPARK_OVERFLOW      37 /* ()                     */
+#define EVENT_SPARK_RUN           38 /* ()                     */
+#define EVENT_SPARK_STEAL         39 /* (victim_cap)           */
+#define EVENT_SPARK_FIZZLE        40 /* ()                     */
+#define EVENT_SPARK_GC            41 /* ()                     */
+#define EVENT_INTERN_STRING       42 /* (string, id) {not used by ghc} */
+#define EVENT_WALL_CLOCK_TIME     43 /* (capset, unix_epoch_seconds, nanoseconds) */
+#define EVENT_THREAD_LABEL        44 /* (thread, name_string)  */
+#define EVENT_CAP_CREATE          45 /* (cap)                  */
+#define EVENT_CAP_DELETE          46 /* (cap)                  */
+#define EVENT_CAP_DISABLE         47 /* (cap)                  */
+#define EVENT_CAP_ENABLE          48 /* (cap)                  */
+#define EVENT_HEAP_ALLOCATED      49 /* (heap_capset, alloc_bytes) */
+#define EVENT_HEAP_SIZE           50 /* (heap_capset, size_bytes) */
+#define EVENT_HEAP_LIVE           51 /* (heap_capset, live_bytes) */
+#define EVENT_HEAP_INFO_GHC       52 /* (heap_capset, n_generations,
+                                         max_heap_size, alloc_area_size,
+                                         mblock_size, block_size) */
+#define EVENT_GC_STATS_GHC        53 /* (heap_capset, generation,
+                                         copied_bytes, slop_bytes, frag_bytes,
+                                         par_n_threads,
+                                         par_max_copied,
+                                         par_tot_copied, par_balanced_copied) */
+#define EVENT_GC_GLOBAL_SYNC      54 /* ()                     */
+#define EVENT_TASK_CREATE         55 /* (taskID, cap, tid)       */
+#define EVENT_TASK_MIGRATE        56 /* (taskID, cap, new_cap)   */
+#define EVENT_TASK_DELETE         57 /* (taskID)                 */
+#define EVENT_USER_MARKER         58 /* (marker_name) */
+#define EVENT_HACK_BUG_T9003      59 /* Hack: see trac #9003 */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/* Range 100 - 139 is reserved for Mercury. */
+
+/* Range 140 - 159 is reserved for Perf events. */
+
+/* Range 160 - 180 is reserved for cost-centre heap profiling events. */
+
+#define EVENT_HEAP_PROF_BEGIN              160
+#define EVENT_HEAP_PROF_COST_CENTRE        161
+#define EVENT_HEAP_PROF_SAMPLE_BEGIN       162
+#define EVENT_HEAP_PROF_SAMPLE_COST_CENTRE 163
+#define EVENT_HEAP_PROF_SAMPLE_STRING      164
+
+#define EVENT_USER_BINARY_MSG              181
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_GHC_EVENT_TAGS        182
+
+#if 0  /* DEPRECATED EVENTS: */
+/* we don't actually need to record the thread, it's implicit */
+#define EVENT_RUN_SPARK            5 /* (thread)               */
+#define EVENT_STEAL_SPARK          6 /* (thread, victim_cap)   */
+/* shutdown replaced by EVENT_CAP_DELETE */
+#define EVENT_SHUTDOWN             7 /* ()                     */
+/* ghc changed how it handles sparks so these are no longer applicable */
+#define EVENT_CREATE_SPARK        13 /* (cap, thread) */
+#define EVENT_SPARK_TO_THREAD     14 /* (cap, thread, spark_thread) */
+#define EVENT_STARTUP             17 /* (num_capabilities)     */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION             23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION  24 /* (commandline_string) */
+#endif
+
+/*
+ * Status values for EVENT_STOP_THREAD
+ *
+ * 1-5 are the StgRun return values (from includes/Constants.h):
+ *
+ * #define HeapOverflow   1
+ * #define StackOverflow  2
+ * #define ThreadYielding 3
+ * #define ThreadBlocked  4
+ * #define ThreadFinished 5
+ * #define ForeignCall                  6
+ * #define BlockedOnMVar                7
+ * #define BlockedOnBlackHole           8
+ * #define BlockedOnRead                9
+ * #define BlockedOnWrite               10
+ * #define BlockedOnDelay               11
+ * #define BlockedOnSTM                 12
+ * #define BlockedOnDoProc              13
+ * #define BlockedOnCCall               -- not used (see ForeignCall)
+ * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)
+ * #define BlockedOnMsgThrowTo          16
+ */
+#define THREAD_SUSPENDED_FOREIGN_CALL 6
+
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM      1  /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS   2  /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3  /* caps share a local clock/time      */
+
+/*
+ * Heap profile breakdown types. See EVENT_HEAP_PROF_BEGIN.
+ */
+typedef enum {
+    HEAP_PROF_BREAKDOWN_COST_CENTRE = 0x1,
+    HEAP_PROF_BREAKDOWN_MODULE,
+    HEAP_PROF_BREAKDOWN_CLOSURE_DESCR,
+    HEAP_PROF_BREAKDOWN_TYPE_DESCR,
+    HEAP_PROF_BREAKDOWN_RETAINER,
+    HEAP_PROF_BREAKDOWN_BIOGRAPHY,
+    HEAP_PROF_BREAKDOWN_CLOSURE_TYPE
+} HeapProfBreakdown;
+
+#if !defined(EVENTLOG_CONSTANTS_ONLY)
+
+typedef StgWord16 EventTypeNum;
+typedef StgWord64 EventTimestamp; /* in nanoseconds */
+typedef StgWord32 EventThreadID;
+typedef StgWord16 EventCapNo;
+typedef StgWord16 EventPayloadSize; /* variable-size events */
+typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */
+typedef StgWord64 EventTaskId;         /* for EVENT_TASK_* */
+typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */
+
+#define EVENT_PAYLOAD_SIZE_MAX STG_WORD16_MAX
+#endif
diff --git a/includes/rts/EventLogWriter.h b/includes/rts/EventLogWriter.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/EventLogWriter.h
@@ -0,0 +1,40 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2017
+ *
+ * Support for fast binary event logging.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stddef.h>
+#include <stdbool.h>
+
+/*
+ *  Abstraction for writing eventlog data.
+ */
+typedef struct {
+    // Initialize an EventLogWriter (may be NULL)
+    void (* initEventLogWriter) (void);
+
+    // Write a series of events
+    bool (* writeEventLog) (void *eventlog, size_t eventlog_size);
+
+    // Flush possibly existing buffers (may be NULL)
+    void (* flushEventLog) (void);
+
+    // Close an initialized EventLogOutput (may be NULL)
+    void (* stopEventLogWriter) (void);
+} EventLogWriter;
+
+/*
+ * An EventLogWriter which writes eventlogs to
+ * a file `program.eventlog`.
+ */
+extern const EventLogWriter FileEventLogWriter;
diff --git a/includes/rts/FileLock.h b/includes/rts/FileLock.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/FileLock.h
@@ -0,0 +1,19 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2007-2009
+ *
+ * File locking support as required by Haskell
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "Stg.h"
+
+int  lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing);
+int  unlockFile(int fd);
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Flags.h
@@ -0,0 +1,301 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Datatypes that holds the command-line flag settings.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stdio.h>
+#include <stdint.h>
+#include <stdbool.h>
+#include "stg/Types.h"
+#include "Time.h"
+
+/* For defaults, see the @initRtsFlagsDefaults@ routine. */
+
+/* Note [Synchronization of flags and base APIs]
+ *
+ * We provide accessors to RTS flags in base. (GHC.RTS module)
+ * The API should be updated whenever RTS flags are modified.
+ */
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _GC_FLAGS {
+    FILE   *statsFile;
+    uint32_t  giveStats;
+#define NO_GC_STATS	 0
+#define COLLECT_GC_STATS 1
+#define ONELINE_GC_STATS 2
+#define SUMMARY_GC_STATS 3
+#define VERBOSE_GC_STATS 4
+
+    uint32_t     maxStkSize;         /* in *words* */
+    uint32_t     initialStkSize;     /* in *words* */
+    uint32_t     stkChunkSize;       /* in *words* */
+    uint32_t     stkChunkBufferSize; /* in *words* */
+
+    uint32_t     maxHeapSize;        /* in *blocks* */
+    uint32_t     minAllocAreaSize;   /* in *blocks* */
+    uint32_t     largeAllocLim;      /* in *blocks* */
+    uint32_t     nurseryChunkSize;   /* in *blocks* */
+    uint32_t     minOldGenSize;      /* in *blocks* */
+    uint32_t     heapSizeSuggestion; /* in *blocks* */
+    bool heapSizeSuggestionAuto;
+    double  oldGenFactor;
+    double  pcFreeHeap;
+
+    uint32_t     generations;
+    bool squeezeUpdFrames;
+
+    bool compact;		/* True <=> "compact all the time" */
+    double  compactThreshold;
+
+    bool sweep;		/* use "mostly mark-sweep" instead of copying
+                                 * for the oldest generation */
+    bool ringBell;
+
+    Time    idleGCDelayTime;    /* units: TIME_RESOLUTION */
+    bool doIdleGC;
+
+    Time    longGCSync;         /* units: TIME_RESOLUTION */
+
+    StgWord heapBase;           /* address to ask the OS for memory */
+
+    StgWord allocLimitGrace;    /* units: *blocks*
+                                 * After an AllocationLimitExceeded
+                                 * exception has been raised, how much
+                                 * extra space is given to the thread
+                                 * to handle the exception before we
+                                 * raise it again.
+                                 */
+    StgWord heapLimitGrace;     /* units: *blocks*
+                                 * After a HeapOverflow exception has
+                                 * been raised, how much extra space is
+                                 * given to the thread to handle the
+                                 * exception before we raise it again.
+                                 */
+
+    bool numa;                   /* Use NUMA */
+    StgWord numaMask;
+} GC_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _DEBUG_FLAGS {
+    /* flags to control debugging output & extra checking in various subsystems */
+    bool scheduler;      /* 's' */
+    bool interpreter;    /* 'i' */
+    bool weak;           /* 'w' */
+    bool gccafs;         /* 'G' */
+    bool gc;             /* 'g' */
+    bool block_alloc;    /* 'b' */
+    bool sanity;         /* 'S'   warning: might be expensive! */
+    bool stable;         /* 't' */
+    bool prof;           /* 'p' */
+    bool linker;         /* 'l'   the object linker */
+    bool apply;          /* 'a' */
+    bool stm;            /* 'm' */
+    bool squeeze;        /* 'z'  stack squeezing & lazy blackholing */
+    bool hpc;            /* 'c' coverage */
+    bool sparks;         /* 'r' */
+    bool numa;           /* '--debug-numa' */
+    bool compact;        /* 'C' */
+} DEBUG_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _COST_CENTRE_FLAGS {
+    uint32_t    doCostCentres;
+# define COST_CENTRES_NONE      0
+# define COST_CENTRES_SUMMARY	1
+# define COST_CENTRES_VERBOSE	2 /* incl. serial time profile */
+# define COST_CENTRES_ALL	3
+# define COST_CENTRES_JSON      4
+
+    int	    profilerTicks;   /* derived */
+    int	    msecsPerTick;    /* derived */
+    char const *outputFileNameStem;
+} COST_CENTRE_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _PROFILING_FLAGS {
+    uint32_t doHeapProfile;
+# define NO_HEAP_PROFILING	0	/* N.B. Used as indexes into arrays */
+# define HEAP_BY_CCS		1
+# define HEAP_BY_MOD		2
+# define HEAP_BY_DESCR		4
+# define HEAP_BY_TYPE		5
+# define HEAP_BY_RETAINER       6
+# define HEAP_BY_LDV            7
+
+# define HEAP_BY_CLOSURE_TYPE   8
+
+    Time        heapProfileInterval; /* time between samples */
+    uint32_t    heapProfileIntervalTicks; /* ticks between samples (derived) */
+    bool        includeTSOs;
+
+
+    bool		showCCSOnException;
+
+    uint32_t    maxRetainerSetSize;
+
+    uint32_t    ccsLength;
+
+    const char*         modSelector;
+    const char*         descrSelector;
+    const char*         typeSelector;
+    const char*         ccSelector;
+    const char*         ccsSelector;
+    const char*         retainerSelector;
+    const char*         bioSelector;
+
+} PROFILING_FLAGS;
+
+#define TRACE_NONE      0
+#define TRACE_EVENTLOG  1
+#define TRACE_STDERR    2
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _TRACE_FLAGS {
+    int tracing;
+    bool timestamp;      /* show timestamp in stderr output */
+    bool scheduler;      /* trace scheduler events */
+    bool gc;             /* trace GC events */
+    bool sparks_sampled; /* trace spark events by a sampled method */
+    bool sparks_full;    /* trace spark events 100% accurately */
+    bool user;           /* trace user events (emitted from Haskell code) */
+    char *trace_output;  /* output filename for eventlog */
+} TRACE_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _CONCURRENT_FLAGS {
+    Time ctxtSwitchTime;         /* units: TIME_RESOLUTION */
+    int ctxtSwitchTicks;         /* derived */
+} CONCURRENT_FLAGS;
+
+/*
+ * The tickInterval is the time interval between "ticks", ie.
+ * timer signals (see Timer.{c,h}).  It is the frequency at
+ * which we sample CCCS for profiling.
+ *
+ * It is changed by the +RTS -V<secs> flag.
+ */
+#define DEFAULT_TICK_INTERVAL USToTime(10000)
+
+/*
+ * When linkerAlwaysPic is true, the runtime linker assume that all object
+ * files were compiled with -fPIC -fexternal-dynamic-refs and load them
+ * anywhere in the address space.
+ */
+#if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)
+#define DEFAULT_LINKER_ALWAYS_PIC true
+#else
+#define DEFAULT_LINKER_ALWAYS_PIC false
+#endif
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _MISC_FLAGS {
+    Time    tickInterval;        /* units: TIME_RESOLUTION */
+    bool install_signal_handlers;
+    bool install_seh_handlers;
+    bool generate_dump_file;
+    bool generate_stack_trace;
+    bool machineReadable;
+    bool internalCounters;       /* See Note [Internal Counter Stats] */
+    bool linkerAlwaysPic;        /* Assume the object code is always PIC */
+    StgWord linkerMemBase;       /* address to ask the OS for memory
+                                  * for the linker, NULL ==> off */
+} MISC_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _PAR_FLAGS {
+  uint32_t       nCapabilities;  /* number of threads to run simultaneously */
+  bool           migrate;        /* migrate threads between capabilities */
+  uint32_t       maxLocalSparks;
+  bool           parGcEnabled;   /* enable parallel GC */
+  uint32_t       parGcGen;       /* do parallel GC in this generation
+                                  * and higher only */
+  bool           parGcLoadBalancingEnabled;
+                                 /* enable load-balancing in the
+                                  * parallel GC */
+  uint32_t       parGcLoadBalancingGen;
+                                 /* do load-balancing in this
+                                  * generation and higher only */
+
+  uint32_t       parGcNoSyncWithIdle;
+                                 /* if a Capability has been idle for
+                                  * this many GCs, do not try to wake
+                                  * it up when doing a
+                                  * non-load-balancing parallel GC.
+                                  * (zero disables) */
+
+  uint32_t       parGcThreads;
+                                 /* Use this many threads for parallel
+                                  * GC (default: use all nNodes). */
+
+  bool           setAffinity;    /* force thread affinity with CPUs */
+} PAR_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _TICKY_FLAGS {
+    bool showTickyStats;
+    FILE   *tickyFile;
+} TICKY_FLAGS;
+
+/* Put them together: */
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _RTS_FLAGS {
+    /* The first portion of RTS_FLAGS is invariant. */
+    GC_FLAGS	      GcFlags;
+    CONCURRENT_FLAGS  ConcFlags;
+    MISC_FLAGS        MiscFlags;
+    DEBUG_FLAGS	      DebugFlags;
+    COST_CENTRE_FLAGS CcFlags;
+    PROFILING_FLAGS   ProfFlags;
+    TRACE_FLAGS       TraceFlags;
+    TICKY_FLAGS	      TickyFlags;
+    PAR_FLAGS	      ParFlags;
+} RTS_FLAGS;
+
+#if defined(COMPILING_RTS_MAIN)
+extern DLLIMPORT RTS_FLAGS RtsFlags;
+#elif IN_STG_CODE
+/* Hack because the C code generator can't generate '&label'. */
+extern RTS_FLAGS RtsFlags[];
+#else
+extern RTS_FLAGS RtsFlags;
+#endif
+
+/*
+ * The printf formats are here, so we are less likely to make
+ * overly-long filenames (with disastrous results).  No more than 128
+ * chars, please!
+ */
+
+#define STATS_FILENAME_MAXLEN	128
+
+#define GR_FILENAME_FMT		"%0.124s.gr"
+#define HP_FILENAME_FMT		"%0.124s.hp"
+#define LIFE_FILENAME_FMT	"%0.122s.life"
+#define PROF_FILENAME_FMT	"%0.122s.prof"
+#define PROF_FILENAME_FMT_GUM	"%0.118s.%03d.prof"
+#define QP_FILENAME_FMT		"%0.124s.qp"
+#define STAT_FILENAME_FMT	"%0.122s.stat"
+#define TICKY_FILENAME_FMT	"%0.121s.ticky"
+#define TIME_FILENAME_FMT	"%0.122s.time"
+#define TIME_FILENAME_FMT_GUM	"%0.118s.%03d.time"
+
+/* an "int" so as to match normal "argc" */
+/* Now defined in Stg.h (lib/std/cbits need these too.)
+extern int     prog_argc;
+extern char  **prog_argv;
+*/
+extern int      rts_argc;  /* ditto */
+extern char   **rts_argv;
diff --git a/includes/rts/GetTime.h b/includes/rts/GetTime.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/GetTime.h
@@ -0,0 +1,16 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1995-2009
+ *
+ * Interface to the RTS time
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+StgWord64 getMonotonicNSec (void);
diff --git a/includes/rts/Globals.h b/includes/rts/Globals.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Globals.h
@@ -0,0 +1,36 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2006-2009
+ *
+ * The RTS stores some "global" values on behalf of libraries, so that
+ * some libraries can ensure that certain top-level things are shared
+ * even when multiple versions of the library are loaded.  e.g. see
+ * Data.Typeable and GHC.Conc.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#define mkStoreAccessorPrototype(name)                                  \
+    StgStablePtr                                                        \
+    getOrSet##name(StgStablePtr ptr);
+
+mkStoreAccessorPrototype(GHCConcSignalSignalHandlerStore)
+mkStoreAccessorPrototype(GHCConcWindowsPendingDelaysStore)
+mkStoreAccessorPrototype(GHCConcWindowsIOManagerThreadStore)
+mkStoreAccessorPrototype(GHCConcWindowsProddingStore)
+mkStoreAccessorPrototype(SystemEventThreadEventManagerStore)
+mkStoreAccessorPrototype(SystemEventThreadIOManagerThreadStore)
+mkStoreAccessorPrototype(SystemTimerThreadEventManagerStore)
+mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore)
+mkStoreAccessorPrototype(LibHSghcFastStringTable)
+mkStoreAccessorPrototype(LibHSghcPersistentLinkerState)
+mkStoreAccessorPrototype(LibHSghcInitLinkerDone)
+mkStoreAccessorPrototype(LibHSghcGlobalDynFlags)
+mkStoreAccessorPrototype(LibHSghcStaticOptions)
+mkStoreAccessorPrototype(LibHSghcStaticOptionsReady)
diff --git a/includes/rts/Hpc.h b/includes/rts/Hpc.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Hpc.h
@@ -0,0 +1,34 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Haskell Program Coverage
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+// Simple linked list of modules
+typedef struct _HpcModuleInfo {
+  char *modName;                // name of module
+  StgWord32 tickCount;          // number of ticks
+  StgWord32 hashNo;             // Hash number for this module's mix info
+  StgWord64 *tixArr;            // tix Array; local for this module
+  bool from_file;               // data was read from the .tix file
+  struct _HpcModuleInfo *next;
+} HpcModuleInfo;
+
+void hs_hpc_module (char *modName,
+                    StgWord32 modCount,
+                    StgWord32 modHashNo,
+                    StgWord64 *tixArr);
+
+HpcModuleInfo * hs_hpc_rootModule (void);
+
+void startupHpc(void);
+void exitHpc(void);
diff --git a/includes/rts/IOManager.h b/includes/rts/IOManager.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/IOManager.h
@@ -0,0 +1,43 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * IO Manager functionality in the RTS
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+#if defined(mingw32_HOST_OS)
+
+int  rts_InstallConsoleEvent ( int action, StgStablePtr *handler );
+void rts_ConsoleHandlerDone  ( int ev );
+extern StgInt console_handler;
+
+void *   getIOManagerEvent  (void);
+HsWord32 readIOManagerEvent (void);
+void     sendIOManagerEvent (HsWord32 event);
+
+#else
+
+void     setIOManagerControlFd   (uint32_t cap_no, int fd);
+void     setTimerManagerControlFd(int fd);
+void     setIOManagerWakeupFd   (int fd);
+
+#endif
+
+//
+// Communicating with the IO manager thread (see GHC.Conc).
+// Posix implementation in posix/Signals.c
+// Win32 implementation in win32/ThrIOManager.c
+//
+void ioManagerWakeup (void);
+#if defined(THREADED_RTS)
+void ioManagerDie (void);
+void ioManagerStart (void);
+#endif
diff --git a/includes/rts/Libdw.h b/includes/rts/Libdw.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Libdw.h
@@ -0,0 +1,97 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2014-2015
+ *
+ * Producing DWARF-based stacktraces with libdw.
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+// for FILE
+#include <stdio.h>
+
+// Chunk capacity
+// This is rather arbitrary
+#define BACKTRACE_CHUNK_SZ 256
+
+/*
+ * Note [Chunked stack representation]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ *
+ * Consider the stack,
+ *     main                   calls                        (bottom of stack)
+ *       func1                which in turn calls
+ *         func2              which calls
+ *          func3             which calls
+ *            func4           which calls
+ *              func5         which calls
+ *                func6       which calls
+ *                  func7     which requests a backtrace   (top of stack)
+ *
+ * This would produce the Backtrace (using a smaller chunk size of three for
+ * illustrative purposes),
+ *
+ * Backtrace     /----> Chunk         /----> Chunk         /----> Chunk
+ * last --------/       next --------/       next --------/       next
+ * n_frames=8           n_frames=2           n_frames=3           n_frames=3
+ *                      ~~~~~~~~~~           ~~~~~~~~~~           ~~~~~~~~~~
+ *                      func1                func4                func7
+ *                      main                 func3                func6
+ *                                           func2                func5
+ *
+ */
+
+/* A chunk of code addresses from an execution stack
+ *
+ * The first address in this list corresponds to the stack frame
+ * nearest to the "top" of the stack.
+ */
+typedef struct BacktraceChunk_ {
+    StgWord n_frames;                      // number of frames in this chunk
+    struct BacktraceChunk_ *next;          // the chunk following this one
+    StgPtr frames[BACKTRACE_CHUNK_SZ];     // the code addresses from the
+                                           // frames
+} __attribute__((packed)) BacktraceChunk;
+
+/* A chunked list of code addresses from an execution stack
+ *
+ * This structure is optimized for append operations since we append O(stack
+ * depth) times yet typically only traverse the stack trace once. Consequently,
+ * the "top" stack frame (that is, the one where we started unwinding) can be
+ * found in the last chunk. Yes, this is a bit inconsistent with the ordering
+ * within a chunk. See Note [Chunked stack representation] for a depiction.
+ */
+typedef struct Backtrace_ {
+    StgWord n_frames;        // Total number of frames in the backtrace
+    BacktraceChunk *last;    // The first chunk of frames (corresponding to the
+                             // bottom of the stack)
+} Backtrace;
+
+/* Various information describing the location of an address */
+typedef struct Location_ {
+    const char *object_file;
+    const char *function;
+
+    // lineno and colno are only valid if source_file /= NULL
+    const char *source_file;
+    StgWord32 lineno;
+    StgWord32 colno;
+} __attribute__((packed)) Location;
+
+struct LibdwSession_;
+typedef struct LibdwSession_ LibdwSession;
+
+/* Free a backtrace */
+void backtraceFree(Backtrace *bt);
+
+/* Request a backtrace of the current stack state.
+ * May return NULL if a backtrace can't be acquired. */
+Backtrace *libdwGetBacktrace(LibdwSession *session);
+
+/* Lookup Location information for the given address.
+ * Returns 0 if successful, 1 if address could not be found. */
+int libdwLookupLocation(LibdwSession *session, Location *loc, StgPtr pc);
+
+/* Pretty-print a backtrace to the given FILE */
+void libdwPrintBacktrace(LibdwSession *session, FILE *file, Backtrace *bt);
diff --git a/includes/rts/LibdwPool.h b/includes/rts/LibdwPool.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/LibdwPool.h
@@ -0,0 +1,19 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2015-2016
+ *
+ * A pool of libdw sessions
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Claim a session from the pool */
+LibdwSession *libdwPoolTake(void);
+
+/* Return a session to the pool */
+void libdwPoolRelease(LibdwSession *sess);
+
+/* Free any sessions in the pool forcing a reload of any loaded debug
+ * information */
+void libdwPoolClear(void);
diff --git a/includes/rts/Linker.h b/includes/rts/Linker.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Linker.h
@@ -0,0 +1,101 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009
+ *
+ * RTS Object Linker
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(mingw32_HOST_OS)
+typedef wchar_t pathchar;
+#define PATH_FMT "ls"
+#else
+typedef char    pathchar;
+#define PATH_FMT "s"
+#endif
+
+/* Initialize the object linker. Equivalent to initLinker_(1). */
+void initLinker (void);
+
+/* Initialize the object linker.
+ * The retain_cafs argument is:
+ *
+ *   non-zero => Retain CAFs unconditionally in linked Haskell code.
+ *               Note that this prevents any code from being unloaded.
+ *               It should not be necessary unless you are GHCi or
+ *               hs-plugins, which needs to be able call any function
+ *               in the compiled code.
+ *
+ *   zero     => Do not retain CAFs.  Everything reachable from foreign
+ *               exports will be retained, due to the StablePtrs
+ *               created by the module initialisation code.  unloadObj
+ *               frees these StablePtrs, which will allow the CAFs to
+ *               be GC'd and the code to be removed.
+ */
+void initLinker_ (int retain_cafs);
+
+/* insert a symbol in the hash table */
+HsInt insertSymbol(pathchar* obj_name, char* key, void* data);
+
+/* lookup a symbol in the hash table */
+void *lookupSymbol( char *lbl );
+
+/* See Linker.c Note [runtime-linker-phases] */
+typedef enum {
+    OBJECT_LOADED,
+    OBJECT_NEEDED,
+    OBJECT_RESOLVED,
+    OBJECT_UNLOADED,
+    OBJECT_DONT_RESOLVE,
+    OBJECT_NOT_LOADED     /* The object was either never loaded or has been
+                             fully unloaded */
+} OStatus;
+
+/* check object load status */
+OStatus getObjectLoadStatus( pathchar *path );
+
+/* delete an object from the pool */
+HsInt unloadObj( pathchar *path );
+
+/* purge an object's symbols from the symbol table, but don't unload it */
+HsInt purgeObj( pathchar *path );
+
+/* add an obj (populate the global symbol table, but don't resolve yet) */
+HsInt loadObj( pathchar *path );
+
+/* add an arch (populate the global symbol table, but don't resolve yet) */
+HsInt loadArchive( pathchar *path );
+
+/* resolve all the currently unlinked objects in memory */
+HsInt resolveObjs( void );
+
+/* load a dynamic library */
+const char *addDLL( pathchar* dll_name );
+
+/* add a path to the library search path */
+HsPtr addLibrarySearchPath(pathchar* dll_path);
+
+/* removes a directory from the search path,
+   path must have been added using addLibrarySearchPath */
+HsBool removeLibrarySearchPath(HsPtr dll_path_index);
+
+/* give a warning about missing Windows patches that would make
+   the linker work better */
+void warnMissingKBLibraryPaths( void );
+
+/* -----------------------------------------------------------------------------
+* Searches the system directories to determine if there is a system DLL that
+* satisfies the given name. This prevent GHCi from linking against a static
+* library if a DLL is available.
+*/
+pathchar* findSystemLibrary(pathchar* dll_name);
+
+/* called by the initialization code for a module, not a user API */
+StgStablePtr foreignExportStablePtr (StgPtr p);
diff --git a/includes/rts/Main.h b/includes/rts/Main.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Main.h
@@ -0,0 +1,18 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009
+ *
+ * Entry point for standalone Haskell programs.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+ * The entry point for Haskell programs that use a Haskell main function
+ * -------------------------------------------------------------------------- */
+
+int hs_main (int argc, char *argv[],     // program args
+             StgClosure *main_closure,   // closure for Main.main
+             RtsConfig rts_config)       // RTS configuration
+   GNUC3_ATTRIBUTE(__noreturn__);
diff --git a/includes/rts/Messages.h b/includes/rts/Messages.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Messages.h
@@ -0,0 +1,104 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Message API for use inside the RTS.  All messages generated by the
+ * RTS should go through one of the functions declared here, and we
+ * also provide hooks so that messages from the RTS can be redirected
+ * as appropriate.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stdarg.h>
+
+#if defined(mingw32_HOST_OS)
+/* On Win64, if we say "printf" then gcc thinks we are going to use
+   MS format specifiers like %I64d rather than %llu */
+#define PRINTF gnu_printf
+#else
+/* However, on OS X, "gnu_printf" isn't recognised */
+#define PRINTF printf
+#endif
+
+/* -----------------------------------------------------------------------------
+ * Message generation
+ * -------------------------------------------------------------------------- */
+
+/*
+ * A fatal internal error: this is for errors that probably indicate
+ * bugs in the RTS or compiler.  We normally output bug reporting
+ * instructions along with the error message.
+ *
+ * barf() invokes (*fatalInternalErrorFn)().  This function is not
+ * expected to return.
+ */
+void barf(const char *s, ...)
+   GNUC3_ATTRIBUTE(__noreturn__)
+   GNUC3_ATTRIBUTE(format(PRINTF, 1, 2));
+
+void vbarf(const char *s, va_list ap)
+   GNUC3_ATTRIBUTE(__noreturn__);
+
+// declared in Rts.h:
+// extern void _assertFail(const char *filename, unsigned int linenum)
+//    GNUC3_ATTRIBUTE(__noreturn__);
+
+/*
+ * An error condition which is caused by and/or can be corrected by
+ * the user.
+ *
+ * errorBelch() invokes (*errorMsgFn)().
+ */
+void errorBelch(const char *s, ...)
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
+
+void verrorBelch(const char *s, va_list ap);
+
+/*
+ * An error condition which is caused by and/or can be corrected by
+ * the user, and which has an associated error condition reported
+ * by the system (in errno on Unix, and GetLastError() on Windows).
+ * The system error message is appended to the message generated
+ * from the supplied format string.
+ *
+ * sysErrorBelch() invokes (*sysErrorMsgFn)().
+ */
+void sysErrorBelch(const char *s, ...)
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
+
+void vsysErrorBelch(const char *s, va_list ap);
+
+/*
+ * A debugging message.  Debugging messages are generated either as a
+ * virtue of having DEBUG turned on, or by being explicitly selected
+ * via RTS options (eg. +RTS -Ds).
+ *
+ * debugBelch() invokes (*debugMsgFn)().
+ */
+void debugBelch(const char *s, ...)
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
+
+void vdebugBelch(const char *s, va_list ap);
+
+
+/* Hooks for redirecting message generation: */
+
+typedef void RtsMsgFunction(const char *, va_list);
+
+extern RtsMsgFunction *fatalInternalErrorFn;
+extern RtsMsgFunction *debugMsgFn;
+extern RtsMsgFunction *errorMsgFn;
+
+/* Default stdio implementation of the message hooks: */
+
+extern RtsMsgFunction rtsFatalInternalErrorFn;
+extern RtsMsgFunction rtsDebugMsgFn;
+extern RtsMsgFunction rtsErrorMsgFn;
+extern RtsMsgFunction rtsSysErrorMsgFn;
diff --git a/includes/rts/OSThreads.h b/includes/rts/OSThreads.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/OSThreads.h
@@ -0,0 +1,258 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001-2009
+ *
+ * Accessing OS threads functionality in a (mostly) OS-independent
+ * manner.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS)
+
+#if defined(CMINUSMINUS)
+
+#define OS_ACQUIRE_LOCK(mutex) foreign "C" pthread_mutex_lock(mutex)
+#define OS_RELEASE_LOCK(mutex) foreign "C" pthread_mutex_unlock(mutex)
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#else
+
+#include <pthread.h>
+#include <errno.h>
+
+typedef pthread_cond_t  Condition;
+typedef pthread_mutex_t Mutex;
+typedef pthread_t       OSThreadId;
+typedef pthread_key_t   ThreadLocalKey;
+
+#define OSThreadProcAttr /* nothing */
+
+#define INIT_COND_VAR       PTHREAD_COND_INITIALIZER
+
+#if defined(LOCK_DEBUG)
+#define LOCK_DEBUG_BELCH(what, mutex) \
+  debugBelch("%s(0x%p) %s %d\n", what, mutex, __FILE__, __LINE__)
+#else
+#define LOCK_DEBUG_BELCH(what, mutex) /* nothing */
+#endif
+
+/* Always check the result of lock and unlock. */
+#define OS_ACQUIRE_LOCK(mutex) \
+  LOCK_DEBUG_BELCH("ACQUIRE_LOCK", mutex); \
+  if (pthread_mutex_lock(mutex) == EDEADLK) { \
+    barf("multiple ACQUIRE_LOCK: %s %d", __FILE__,__LINE__); \
+  }
+
+// Returns zero if the lock was acquired.
+EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex);
+EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex)
+{
+    LOCK_DEBUG_BELCH("TRY_ACQUIRE_LOCK", mutex);
+    return pthread_mutex_trylock(mutex);
+}
+
+#define OS_RELEASE_LOCK(mutex) \
+  LOCK_DEBUG_BELCH("RELEASE_LOCK", mutex); \
+  if (pthread_mutex_unlock(mutex) != 0) { \
+    barf("RELEASE_LOCK: I do not own this lock: %s %d", __FILE__,__LINE__); \
+  }
+
+// Note: this assertion calls pthread_mutex_lock() on a mutex that
+// is already held by the calling thread.  The mutex should therefore
+// have been created with PTHREAD_MUTEX_ERRORCHECK, otherwise this
+// assertion will hang.  We always initialise mutexes with
+// PTHREAD_MUTEX_ERRORCHECK when DEBUG is on (see rts/posix/OSThreads.h).
+#define OS_ASSERT_LOCK_HELD(mutex) ASSERT(pthread_mutex_lock(mutex) == EDEADLK)
+
+#endif // CMINUSMINUS
+
+# elif defined(HAVE_WINDOWS_H)
+
+#if defined(CMINUSMINUS)
+
+/* We jump through a hoop here to get a CCall EnterCriticalSection
+   and LeaveCriticalSection, as that's what C-- wants. */
+
+#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" EnterCriticalSection(mutex)
+#define OS_RELEASE_LOCK(mutex) foreign "stdcall" LeaveCriticalSection(mutex)
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#else
+
+#include <windows.h>
+
+typedef HANDLE Condition;
+typedef DWORD OSThreadId;
+// don't be tempted to use HANDLE as the OSThreadId: there can be
+// many HANDLES to a given thread, so comparison would not work.
+typedef DWORD ThreadLocalKey;
+
+#define OSThreadProcAttr __stdcall
+
+#define INIT_COND_VAR  0
+
+// We have a choice for implementing Mutexes on Windows.  Standard
+// Mutexes are kernel objects that require kernel calls to
+// acquire/release, whereas CriticalSections are spin-locks that block
+// in the kernel after spinning for a configurable number of times.
+// CriticalSections are *much* faster, so we use those.  The Mutex
+// implementation is left here for posterity.
+#define USE_CRITICAL_SECTIONS 1
+
+#if USE_CRITICAL_SECTIONS
+
+typedef CRITICAL_SECTION Mutex;
+
+#if defined(LOCK_DEBUG)
+
+#define OS_ACQUIRE_LOCK(mutex) \
+  debugBelch("ACQUIRE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \
+  EnterCriticalSection(mutex)
+#define OS_RELEASE_LOCK(mutex) \
+  debugBelch("RELEASE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \
+  LeaveCriticalSection(mutex)
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#else
+
+#define OS_ACQUIRE_LOCK(mutex)      EnterCriticalSection(mutex)
+#define TRY_ACQUIRE_LOCK(mutex)  (TryEnterCriticalSection(mutex) == 0)
+#define OS_RELEASE_LOCK(mutex)      LeaveCriticalSection(mutex)
+
+// I don't know how to do this.  TryEnterCriticalSection() doesn't do
+// the right thing.
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#endif
+
+#else
+
+typedef HANDLE Mutex;
+
+// casting to (Mutex *) here required due to use in .cmm files where
+// the argument has (void *) type.
+#define OS_ACQUIRE_LOCK(mutex)                                     \
+    if (WaitForSingleObject(*((Mutex *)mutex),INFINITE) == WAIT_FAILED) { \
+        barf("WaitForSingleObject: %d", GetLastError());        \
+    }
+
+#define OS_RELEASE_LOCK(mutex)                             \
+    if (ReleaseMutex(*((Mutex *)mutex)) == 0) {         \
+        barf("ReleaseMutex: %d", GetLastError());       \
+    }
+
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+#endif
+
+#endif // CMINUSMINUS
+
+# elif defined(THREADED_RTS)
+#  error "Threads not supported"
+# endif
+
+
+#if !defined(CMINUSMINUS)
+//
+// General thread operations
+//
+extern OSThreadId osThreadId      ( void );
+extern void shutdownThread        ( void )   GNUC3_ATTRIBUTE(__noreturn__);
+extern void yieldThread           ( void );
+
+typedef void* OSThreadProcAttr OSThreadProc(void *);
+
+extern int  createOSThread        ( OSThreadId* tid, char *name,
+                                    OSThreadProc *startProc, void *param);
+extern bool osThreadIsAlive       ( OSThreadId id );
+extern void interruptOSThread     (OSThreadId id);
+
+//
+// Condition Variables
+//
+extern void initCondition         ( Condition* pCond );
+extern void closeCondition        ( Condition* pCond );
+extern bool broadcastCondition    ( Condition* pCond );
+extern bool signalCondition       ( Condition* pCond );
+extern bool waitCondition         ( Condition* pCond, Mutex* pMut );
+
+//
+// Mutexes
+//
+extern void initMutex             ( Mutex* pMut );
+extern void closeMutex            ( Mutex* pMut );
+
+//
+// Thread-local storage
+//
+void  newThreadLocalKey (ThreadLocalKey *key);
+void *getThreadLocalVar (ThreadLocalKey *key);
+void  setThreadLocalVar (ThreadLocalKey *key, void *value);
+void  freeThreadLocalKey (ThreadLocalKey *key);
+
+// Processors and affinity
+void setThreadAffinity (uint32_t n, uint32_t m);
+void setThreadNode (uint32_t node);
+void releaseThreadNode (void);
+#endif // !CMINUSMINUS
+
+#if defined(THREADED_RTS)
+
+#define ACQUIRE_LOCK(l) OS_ACQUIRE_LOCK(l)
+#define RELEASE_LOCK(l) OS_RELEASE_LOCK(l)
+#define ASSERT_LOCK_HELD(l) OS_ASSERT_LOCK_HELD(l)
+
+#else
+
+#define ACQUIRE_LOCK(l)
+#define RELEASE_LOCK(l)
+#define ASSERT_LOCK_HELD(l)
+
+#endif /* defined(THREADED_RTS) */
+
+#if !defined(CMINUSMINUS)
+//
+// Support for forkOS (defined regardless of THREADED_RTS, but does
+// nothing when !THREADED_RTS).
+//
+int forkOS_createThread ( HsStablePtr entry );
+
+//
+// Free any global resources created in OSThreads.
+//
+void freeThreadingResources(void);
+
+//
+// Returns the number of processor cores in the machine
+//
+uint32_t getNumberOfProcessors (void);
+
+//
+// Support for getting at the kernel thread Id for tracing/profiling.
+//
+// This stuff is optional and only used for tracing/profiling purposes, to
+// match up thread ids recorded by other tools. For example, on Linux and OSX
+// the pthread_t type is not the same as the kernel thread id, and system
+// profiling tools like Linux perf, and OSX's DTrace use the kernel thread Id.
+// So if we want to match up RTS tasks with kernel threads recorded by these
+// tools then we need to know the kernel thread Id, and this must be a separate
+// type from the OSThreadId.
+//
+// If the feature cannot be supported on an OS, it is OK to always return 0.
+// In particular it would almost certaily be meaningless on systems not using
+// a 1:1 threading model.
+
+// We use a common serialisable representation on all OSs
+// This is ok for Windows, OSX and Linux.
+typedef StgWord64 KernelThreadId;
+
+// Get the current kernel thread id
+KernelThreadId kernelThreadId (void);
+
+#endif /* CMINUSMINUS */
diff --git a/includes/rts/Parallel.h b/includes/rts/Parallel.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Parallel.h
@@ -0,0 +1,16 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Parallelism-related functionality
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+StgInt newSpark (StgRegTable *reg, StgClosure *p);
diff --git a/includes/rts/PrimFloat.h b/includes/rts/PrimFloat.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/PrimFloat.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Primitive floating-point operations
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+StgDouble __int_encodeDouble (I_ j, I_ e);
+StgFloat  __int_encodeFloat (I_ j, I_ e);
+StgDouble __word_encodeDouble (W_ j, I_ e);
+StgFloat  __word_encodeFloat (W_ j, I_ e);
diff --git a/includes/rts/Profiling.h b/includes/rts/Profiling.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Profiling.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2017-2018
+ *
+ * Cost-centre profiling API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+void registerCcList(CostCentre **cc_list);
+void registerCcsList(CostCentreStack **cc_list);
diff --git a/includes/rts/Signals.h b/includes/rts/Signals.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Signals.h
@@ -0,0 +1,23 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS signal handling 
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* NB. #included in Haskell code, no prototypes in here. */
+
+/* arguments to stg_sig_install() */
+#define STG_SIG_DFL   (-1)
+#define STG_SIG_IGN   (-2)
+#define STG_SIG_ERR   (-3)
+#define STG_SIG_HAN   (-4)
+#define STG_SIG_RST   (-5)
diff --git a/includes/rts/SpinLock.h b/includes/rts/SpinLock.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/SpinLock.h
@@ -0,0 +1,116 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2006-2009
+ *
+ * Spin locks
+ *
+ * These are simple spin-only locks as opposed to Mutexes which
+ * probably spin for a while before blocking in the kernel.  We use
+ * these when we are sure that all our threads are actively running on
+ * a CPU, eg. in the GC.
+ *
+ * TODO: measure whether we really need these, or whether Mutexes
+ * would do (and be a bit safer if a CPU becomes loaded).
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+#if defined(THREADED_RTS)
+
+#if defined(PROF_SPIN)
+typedef struct SpinLock_
+{
+    StgWord   lock;
+    StgWord64 spin;  // incremented every time we spin in ACQUIRE_SPIN_LOCK
+    StgWord64 yield; // incremented every time we yield in ACQUIRE_SPIN_LOCK
+} SpinLock;
+#else
+typedef StgWord SpinLock;
+#endif
+
+#if defined(PROF_SPIN)
+
+// PROF_SPIN enables counting the number of times we spin on a lock
+
+// acquire spin lock
+INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)
+{
+    StgWord32 r = 0;
+    uint32_t i;
+    do {
+        for (i = 0; i < SPIN_COUNT; i++) {
+            r = cas((StgVolatilePtr)&(p->lock), 1, 0);
+            if (r != 0) return;
+            p->spin++;
+            busy_wait_nop();
+        }
+        p->yield++;
+        yieldThread();
+    } while (1);
+}
+
+// release spin lock
+INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)
+{
+    write_barrier();
+    p->lock = 1;
+}
+
+// initialise spin lock
+INLINE_HEADER void initSpinLock(SpinLock * p)
+{
+    write_barrier();
+    p->lock = 1;
+    p->spin = 0;
+    p->yield = 0;
+}
+
+#else
+
+// acquire spin lock
+INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)
+{
+    StgWord32 r = 0;
+    uint32_t i;
+    do {
+        for (i = 0; i < SPIN_COUNT; i++) {
+            r = cas((StgVolatilePtr)p, 1, 0);
+            if (r != 0) return;
+            busy_wait_nop();
+        }
+        yieldThread();
+    } while (1);
+}
+
+// release spin lock
+INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)
+{
+    write_barrier();
+    (*p) = 1;
+}
+
+// init spin lock
+INLINE_HEADER void initSpinLock(SpinLock * p)
+{
+    write_barrier();
+    (*p) = 1;
+}
+
+#endif /* PROF_SPIN */
+
+#else /* !THREADED_RTS */
+
+// Using macros here means we don't have to ensure the argument is in scope
+#define ACQUIRE_SPIN_LOCK(p) /* nothing */
+#define RELEASE_SPIN_LOCK(p) /* nothing */
+
+INLINE_HEADER void initSpinLock(void * p STG_UNUSED)
+{ /* nothing */ }
+
+#endif /* THREADED_RTS */
diff --git a/includes/rts/StableName.h b/includes/rts/StableName.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/StableName.h
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Stable Names
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   PRIVATE from here.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgPtr  addr;        // Haskell object when entry is in use, next free
+                         // entry (NULL when this is the last free entry)
+                         // otherwise. May be NULL temporarily during GC (when
+                         // pointee dies).
+
+    StgPtr  old;         // Old Haskell object, used during GC
+
+    StgClosure *sn_obj;  // The StableName object, or NULL when the entry is
+                         // free
+} snEntry;
+
+extern DLL_IMPORT_RTS snEntry *stable_name_table;
diff --git a/includes/rts/StablePtr.h b/includes/rts/StablePtr.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/StablePtr.h
@@ -0,0 +1,35 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Stable Pointers
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+EXTERN_INLINE StgPtr deRefStablePtr (StgStablePtr stable_ptr);
+StgStablePtr getStablePtr  (StgPtr p);
+
+/* -----------------------------------------------------------------------------
+   PRIVATE from here.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgPtr addr;         // Haskell object when entry is in use, next free
+                         // entry (NULL when this is the last free entry)
+                         // otherwise.
+} spEntry;
+
+extern DLL_IMPORT_RTS spEntry *stable_ptr_table;
+
+EXTERN_INLINE
+StgPtr deRefStablePtr(StgStablePtr sp)
+{
+    return stable_ptr_table[(StgWord)sp].addr;
+}
diff --git a/includes/rts/StaticPtrTable.h b/includes/rts/StaticPtrTable.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/StaticPtrTable.h
@@ -0,0 +1,44 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Initialization of the Static Pointer Table
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/** Inserts an entry in the Static Pointer Table.
+ *
+ * The key is a fingerprint computed from the static pointer and the spe_closure
+ * is a pointer to the closure defining the table entry.
+ *
+ * A stable pointer to the closure is made to prevent it from being garbage
+ * collected while the entry exists on the table.
+ *
+ * This function is called from the code generated by
+ * compiler/deSugar/StaticPtrTable.sptInitCode
+ *
+ * */
+void hs_spt_insert (StgWord64 key[2],void* spe_closure);
+
+/** Inserts an entry for a StgTablePtr in the Static Pointer Table.
+ *
+ * This function is called from the GHCi interpreter to insert
+ * SPT entries for bytecode objects.
+ *
+ * */
+void hs_spt_insert_stableptr(StgWord64 key[2], StgStablePtr *entry);
+
+/** Removes an entry from the Static Pointer Table.
+ *
+ * This function is called from the code generated by
+ * compiler/deSugar/StaticPtrTable.sptInitCode
+ *
+ * */
+void hs_spt_remove (StgWord64 key[2]);
diff --git a/includes/rts/TTY.h b/includes/rts/TTY.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/TTY.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009
+ *
+ * POSIX TTY-related functionality
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+void* __hscore_get_saved_termios(int fd);
+void  __hscore_set_saved_termios(int fd, void* ts);
diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Threads.h
@@ -0,0 +1,74 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 1998-2009
+ *
+ * External API for the scheduler.  For most uses, the functions in
+ * RtsAPI.h should be enough.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(HAVE_SYS_TYPES_H)
+#include <sys/types.h>
+#endif
+
+//
+// Creating threads
+//
+StgTSO *createThread (Capability *cap, W_ stack_size);
+
+void scheduleWaitThread (/* in    */ StgTSO *tso,
+                         /* out   */ HaskellObj* ret,
+                         /* inout */ Capability **cap);
+
+StgTSO *createGenThread       (Capability *cap, W_ stack_size,
+                               StgClosure *closure);
+StgTSO *createIOThread        (Capability *cap, W_ stack_size,
+                               StgClosure *closure);
+StgTSO *createStrictIOThread  (Capability *cap, W_ stack_size,
+                               StgClosure *closure);
+
+// Suspending/resuming threads around foreign calls
+void *        suspendThread (StgRegTable *, bool interruptible);
+StgRegTable * resumeThread  (void *);
+
+//
+// Thread operations from Threads.c
+//
+int     cmp_thread                       (StgPtr tso1, StgPtr tso2);
+int     rts_getThreadId                  (StgPtr tso);
+void    rts_enableThreadAllocationLimit  (StgPtr tso);
+void    rts_disableThreadAllocationLimit (StgPtr tso);
+
+#if !defined(mingw32_HOST_OS)
+pid_t  forkProcess     (HsStablePtr *entry);
+#else
+pid_t  forkProcess     (HsStablePtr *entry)
+    GNU_ATTRIBUTE(__noreturn__);
+#endif
+
+HsBool rtsSupportsBoundThreads (void);
+
+// The number of Capabilities.
+// ToDo: I would like this to be private to the RTS and instead expose a
+// function getNumCapabilities(), but it is used in compiler/cbits/genSym.c
+extern unsigned int n_capabilities;
+
+// The number of Capabilities that are not disabled
+extern uint32_t enabled_capabilities;
+
+#if !IN_STG_CODE
+extern Capability MainCapability;
+#endif
+
+//
+// Change the number of capabilities (only supports increasing the
+// current value at the moment).
+//
+extern void setNumCapabilities (uint32_t new_);
diff --git a/includes/rts/Ticky.h b/includes/rts/Ticky.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Ticky.h
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * TICKY_TICKY types
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   The StgEntCounter type - needed regardless of TICKY_TICKY
+   -------------------------------------------------------------------------- */
+
+typedef struct _StgEntCounter {
+  /* Using StgWord for everything, because both the C and asm code
+     generators make trouble if you try to pack things tighter */
+    StgWord     registeredp;    /* 0 == no, 1 == yes */
+    StgInt      arity;          /* arity (static info) */
+    StgInt      allocd;         /* # allocation of this closure */
+                                /* (rest of args are in registers) */
+    char        *str;           /* name of the thing */
+    char        *arg_kinds;     /* info about the args types */
+    StgInt      entry_count;    /* Trips to fast entry code */
+    StgInt      allocs;         /* number of allocations by this fun */
+    struct _StgEntCounter *link;/* link to chain them all together */
+} StgEntCounter;
diff --git a/includes/rts/Time.h b/includes/rts/Time.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Time.h
@@ -0,0 +1,44 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Time values in the RTS
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+// For most time values in the RTS we use a fixed resolution of nanoseconds,
+// normalising the time we get from platform-dependent APIs to this
+// resolution.
+#define TIME_RESOLUTION 1000000000
+typedef int64_t Time;
+
+#define TIME_MAX HS_INT64_MAX
+
+#if TIME_RESOLUTION == 1000000000
+// I'm being lazy, but it's awkward to define fully general versions of these
+#define TimeToMS(t)      ((t) / 1000000)
+#define TimeToUS(t)      ((t) / 1000)
+#define TimeToNS(t)      (t)
+#define MSToTime(t)      ((Time)(t) * 1000000)
+#define USToTime(t)      ((Time)(t) * 1000)
+#define NSToTime(t)      ((Time)(t))
+#else
+#error Fix TimeToNS(), TimeToUS() etc.
+#endif
+
+#define SecondsToTime(t) ((Time)(t) * TIME_RESOLUTION)
+#define TimeToSeconds(t) ((t) / TIME_RESOLUTION)
+
+// Use instead of SecondsToTime() when we have a floating-point
+// seconds value, to avoid truncating it.
+INLINE_HEADER Time fsecondsToTime (double t)
+{
+    return (Time)(t * TIME_RESOLUTION);
+}
+
+Time getProcessElapsedTime (void);
diff --git a/includes/rts/Timer.h b/includes/rts/Timer.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Timer.h
@@ -0,0 +1,18 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1995-2009
+ *
+ * Interface to the RTS timer signal (uses OS-dependent Ticker.h underneath)
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+void startTimer (void);
+void stopTimer  (void);
+int rtsTimerSignal (void);
diff --git a/includes/rts/Types.h b/includes/rts/Types.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Types.h
@@ -0,0 +1,31 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS-specific types.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stddef.h>
+#include <stdbool.h>
+
+// Deprecated, use uint32_t instead.
+typedef unsigned int nat __attribute__((deprecated));  /* uint32_t */
+
+/* ullong (64|128-bit) type: only include if needed (not ANSI) */
+#if defined(__GNUC__)
+#define LL(x) (x##LL)
+#else
+#define LL(x) (x##L)
+#endif
+
+typedef struct StgClosure_   StgClosure;
+typedef struct StgInfoTable_ StgInfoTable;
+typedef struct StgTSO_       StgTSO;
diff --git a/includes/rts/Utils.h b/includes/rts/Utils.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Utils.h
@@ -0,0 +1,16 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS external APIs.  This file declares everything that the GHC RTS
+ * exposes externally.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Alternate to raise(3) for threaded rts, for BSD-based OSes */
+int genericRaise(int sig);
diff --git a/includes/rts/prof/CCS.h b/includes/rts/prof/CCS.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/prof/CCS.h
@@ -0,0 +1,226 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009-2012
+ *
+ * Macros for profiling operations in STG code
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+ * Data Structures
+ * ---------------------------------------------------------------------------*/
+/*
+ * Note [struct alignment]
+ * NB. be careful to avoid unwanted padding between fields, by
+ * putting the 8-byte fields on an 8-byte boundary.  Padding can
+ * vary between C compilers, and we don't take into account any
+ * possible padding when generating CCS and CC decls in the code
+ * generator (compiler/codeGen/StgCmmProf.hs).
+ */
+
+typedef struct CostCentre_ {
+    StgInt ccID;              // Unique Id, allocated by the RTS
+
+    char * label;
+    char * module;
+    char * srcloc;
+
+    // used for accumulating costs at the end of the run...
+    StgWord64 mem_alloc;      // align 8 (Note [struct alignment])
+    StgWord   time_ticks;
+
+    StgBool is_caf;           // true <=> CAF cost centre
+
+    struct CostCentre_ *link;
+} CostCentre;
+
+typedef struct CostCentreStack_ {
+    StgInt ccsID;               // unique ID, allocated by the RTS
+
+    CostCentre *cc;             // Cost centre at the top of the stack
+
+    struct CostCentreStack_ *prevStack;   // parent
+    struct IndexTable_      *indexTable;  // children
+    struct CostCentreStack_ *root;        // root of stack
+    StgWord    depth;           // number of items in the stack
+
+    StgWord64  scc_count;       // Count of times this CCS is entered
+                                // align 8 (Note [struct alignment])
+
+    StgWord    selected;        // is this CCS shown in the heap
+                                // profile? (zero if excluded via -hc
+                                // -hm etc.)
+
+    StgWord    time_ticks;      // number of time ticks accumulated by
+                                // this CCS
+
+    StgWord64  mem_alloc;       // mem allocated by this CCS
+                                // align 8 (Note [struct alignment])
+
+    StgWord64  inherited_alloc; // sum of mem_alloc over all children
+                                // (calculated at the end)
+                                // align 8 (Note [struct alignment])
+
+    StgWord    inherited_ticks; // sum of time_ticks over all children
+                                // (calculated at the end)
+} CostCentreStack;
+
+
+/* -----------------------------------------------------------------------------
+ * Start and stop the profiling timer.  These can be called from
+ * Haskell to restrict the profile to portion(s) of the execution.
+ * See the module GHC.Profiling.
+ * ---------------------------------------------------------------------------*/
+
+void stopProfTimer      ( void );
+void startProfTimer     ( void );
+
+/* -----------------------------------------------------------------------------
+ * The rest is PROFILING only...
+ * ---------------------------------------------------------------------------*/
+
+#if defined(PROFILING)
+
+/* -----------------------------------------------------------------------------
+ * Constants
+ * ---------------------------------------------------------------------------*/
+
+#define EMPTY_STACK NULL
+#define EMPTY_TABLE NULL
+
+/* Constants used to set is_caf flag on CostCentres */
+#define CC_IS_CAF      true
+#define CC_NOT_CAF     false
+/* -----------------------------------------------------------------------------
+ * Data Structures
+ * ---------------------------------------------------------------------------*/
+
+// IndexTable is the list of children of a CCS. (Alternatively it is a
+// cache of the results of pushing onto a CCS, so that the second and
+// subsequent times we push a certain CC on a CCS we get the same
+// result).
+
+typedef struct IndexTable_ {
+    // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of
+    // pushing `cc` to the owner of the index table (another CostCentreStack).
+    CostCentre *cc;
+    CostCentreStack *ccs;
+    struct IndexTable_ *next;
+    // back_edge is true when `cc` is already in the stack, so pushing it
+    // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in
+    // Profiling.c).
+    bool back_edge;
+} IndexTable;
+
+
+/* -----------------------------------------------------------------------------
+   Pre-defined cost centres and cost centre stacks
+   -------------------------------------------------------------------------- */
+
+#if IN_STG_CODE
+
+extern StgWord CC_MAIN[];
+extern StgWord CCS_MAIN[];      // Top CCS
+
+extern StgWord CC_SYSTEM[];
+extern StgWord CCS_SYSTEM[];    // RTS costs
+
+extern StgWord CC_GC[];
+extern StgWord CCS_GC[];         // Garbage collector costs
+
+extern StgWord CC_OVERHEAD[];
+extern StgWord CCS_OVERHEAD[];   // Profiling overhead
+
+extern StgWord CC_DONT_CARE[];
+extern StgWord CCS_DONT_CARE[];  // CCS attached to static constructors
+
+#else
+
+extern CostCentre      CC_MAIN[];
+extern CostCentreStack CCS_MAIN[];      // Top CCS
+
+extern CostCentre      CC_SYSTEM[];
+extern CostCentreStack CCS_SYSTEM[];    // RTS costs
+
+extern CostCentre      CC_GC[];
+extern CostCentreStack CCS_GC[];         // Garbage collector costs
+
+extern CostCentre      CC_OVERHEAD[];
+extern CostCentreStack CCS_OVERHEAD[];   // Profiling overhead
+
+extern CostCentre      CC_DONT_CARE[];
+extern CostCentreStack CCS_DONT_CARE[];  // shouldn't ever get set
+
+extern CostCentre      CC_PINNED[];
+extern CostCentreStack CCS_PINNED[];     // pinned memory
+
+extern CostCentre      CC_IDLE[];
+extern CostCentreStack CCS_IDLE[];       // capability is idle
+
+#endif /* IN_STG_CODE */
+
+extern unsigned int RTS_VAR(era);
+
+/* -----------------------------------------------------------------------------
+ * Functions
+ * ---------------------------------------------------------------------------*/
+
+CostCentreStack * pushCostCentre (CostCentreStack *, CostCentre *);
+void              enterFunCCS    (StgRegTable *reg, CostCentreStack *);
+CostCentre *mkCostCentre (char *label, char *module, char *srcloc);
+
+extern CostCentre * RTS_VAR(CC_LIST);               // registered CC list
+
+/* -----------------------------------------------------------------------------
+ * Declaring Cost Centres & Cost Centre Stacks.
+ * -------------------------------------------------------------------------- */
+
+# define CC_DECLARE(cc_ident,name,mod,loc,caf,is_local)  \
+     is_local CostCentre cc_ident[1]                     \
+       = {{ .ccID       = 0,                             \
+            .label      = name,                          \
+            .module     = mod,                           \
+            .srcloc     = loc,                           \
+            .time_ticks = 0,                             \
+            .mem_alloc  = 0,                             \
+            .link       = 0,                             \
+            .is_caf     = caf                            \
+         }};
+
+# define CCS_DECLARE(ccs_ident,cc_ident,is_local)        \
+     is_local CostCentreStack ccs_ident[1]               \
+       = {{ .ccsID               = 0,                    \
+            .cc                  = cc_ident,             \
+            .prevStack           = NULL,                 \
+            .indexTable          = NULL,                 \
+            .root                = NULL,                 \
+            .depth               = 0,                    \
+            .selected            = 0,                    \
+            .scc_count           = 0,                    \
+            .time_ticks          = 0,                    \
+            .mem_alloc           = 0,                    \
+            .inherited_ticks     = 0,                    \
+            .inherited_alloc     = 0                     \
+       }};
+
+/* -----------------------------------------------------------------------------
+ * Time / Allocation Macros
+ * ---------------------------------------------------------------------------*/
+
+/* eliminate profiling overhead from allocation costs */
+#define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))
+#define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs
+
+#else /* !PROFILING */
+
+#define CCS_ALLOC(ccs, amount) doNothing()
+#define ENTER_CCS_THUNK(cap,p) doNothing()
+
+#endif /* PROFILING */
diff --git a/includes/rts/prof/LDV.h b/includes/rts/prof/LDV.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/prof/LDV.h
@@ -0,0 +1,44 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow, 2009
+ *
+ * Lag/Drag/Void profiling.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(PROFILING)
+
+/* retrieves the LDV word from closure c */
+#define LDVW(c)                 (((StgClosure *)(c))->header.prof.hp.ldvw)
+
+/*
+ * Stores the creation time for closure c.
+ * This macro is called at the very moment of closure creation.
+ *
+ * NOTE: this initializes LDVW(c) to zero, which ensures that there
+ * is no conflict between retainer profiling and LDV profiling,
+ * because retainer profiling also expects LDVW(c) to be initialised
+ * to zero.
+ */
+
+#if defined(CMINUSMINUS)
+
+#else
+
+#define LDV_RECORD_CREATE(c)   \
+  LDVW((c)) = ((StgWord)RTS_DEREF(era) << LDV_SHIFT) | LDV_STATE_CREATE
+
+#endif
+
+#else  /* !PROFILING */
+
+#define LDV_RECORD_CREATE(c)   /* nothing */
+
+#endif /* PROFILING */
diff --git a/includes/rts/storage/Block.h b/includes/rts/storage/Block.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/Block.h
@@ -0,0 +1,341 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-1999
+ *
+ * Block structure for the storage manager
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "ghcconfig.h"
+
+/* The actual block and megablock-size constants are defined in
+ * includes/Constants.h, all constants here are derived from these.
+ */
+
+/* Block related constants (BLOCK_SHIFT is defined in Constants.h) */
+
+#if SIZEOF_LONG == SIZEOF_VOID_P
+#define UNIT 1UL
+#elif SIZEOF_LONG_LONG == SIZEOF_VOID_P
+#define UNIT 1ULL
+#else
+#error "Size of pointer is suspicious."
+#endif
+
+#if defined(CMINUSMINUS)
+#define BLOCK_SIZE   (1<<BLOCK_SHIFT)
+#else
+#define BLOCK_SIZE   (UNIT<<BLOCK_SHIFT)
+// Note [integer overflow]
+#endif
+
+#define BLOCK_SIZE_W (BLOCK_SIZE/sizeof(W_))
+#define BLOCK_MASK   (BLOCK_SIZE-1)
+
+#define BLOCK_ROUND_UP(p)   (((W_)(p)+BLOCK_SIZE-1) & ~BLOCK_MASK)
+#define BLOCK_ROUND_DOWN(p) ((void *) ((W_)(p) & ~BLOCK_MASK))
+
+/* Megablock related constants (MBLOCK_SHIFT is defined in Constants.h) */
+
+#if defined(CMINUSMINUS)
+#define MBLOCK_SIZE    (1<<MBLOCK_SHIFT)
+#else
+#define MBLOCK_SIZE    (UNIT<<MBLOCK_SHIFT)
+// Note [integer overflow]
+#endif
+
+#define MBLOCK_SIZE_W  (MBLOCK_SIZE/sizeof(W_))
+#define MBLOCK_MASK    (MBLOCK_SIZE-1)
+
+#define MBLOCK_ROUND_UP(p)   ((void *)(((W_)(p)+MBLOCK_SIZE-1) & ~MBLOCK_MASK))
+#define MBLOCK_ROUND_DOWN(p) ((void *)((W_)(p) & ~MBLOCK_MASK ))
+
+/* The largest size an object can be before we give it a block of its
+ * own and treat it as an immovable object during GC, expressed as a
+ * fraction of BLOCK_SIZE.
+ */
+#define LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))
+
+/*
+ * Note [integer overflow]
+ *
+ * The UL suffix in BLOCK_SIZE and MBLOCK_SIZE promotes the expression
+ * to an unsigned long, which means that expressions involving these
+ * will be promoted to unsigned long, which makes integer overflow
+ * less likely.  Historically, integer overflow in expressions like
+ *    (n * BLOCK_SIZE)
+ * where n is int or unsigned int, have caused obscure segfaults in
+ * programs that use large amounts of memory (e.g. #7762, #5086).
+ */
+
+/* -----------------------------------------------------------------------------
+ * Block descriptor.  This structure *must* be the right length, so we
+ * can do pointer arithmetic on pointers to it.
+ */
+
+/* The block descriptor is 64 bytes on a 64-bit machine, and 32-bytes
+ * on a 32-bit machine.
+ */
+
+// Note: fields marked with [READ ONLY] must not be modified by the
+// client of the block allocator API.  All other fields can be
+// freely modified.
+
+#if !defined(CMINUSMINUS)
+typedef struct bdescr_ {
+
+    StgPtr start;              // [READ ONLY] start addr of memory
+
+    StgPtr free;               // First free byte of memory.
+                               // allocGroup() sets this to the value of start.
+                               // NB. during use this value should lie
+                               // between start and start + blocks *
+                               // BLOCK_SIZE.  Values outside this
+                               // range are reserved for use by the
+                               // block allocator.  In particular, the
+                               // value (StgPtr)(-1) is used to
+                               // indicate that a block is unallocated.
+
+    struct bdescr_ *link;      // used for chaining blocks together
+
+    union {
+        struct bdescr_ *back;  // used (occasionally) for doubly-linked lists
+        StgWord *bitmap;       // bitmap for marking GC
+        StgPtr  scan;          // scan pointer for copying GC
+    } u;
+
+    struct generation_ *gen;   // generation
+
+    StgWord16 gen_no;          // gen->no, cached
+    StgWord16 dest_no;         // number of destination generation
+    StgWord16 node;            // which memory node does this block live on?
+
+    StgWord16 flags;           // block flags, see below
+
+    StgWord32 blocks;          // [READ ONLY] no. of blocks in a group
+                               // (if group head, 0 otherwise)
+
+#if SIZEOF_VOID_P == 8
+    StgWord32 _padding[3];
+#else
+    StgWord32 _padding[0];
+#endif
+} bdescr;
+#endif
+
+#if SIZEOF_VOID_P == 8
+#define BDESCR_SIZE  0x40
+#define BDESCR_MASK  0x3f
+#define BDESCR_SHIFT 6
+#else
+#define BDESCR_SIZE  0x20
+#define BDESCR_MASK  0x1f
+#define BDESCR_SHIFT 5
+#endif
+
+/* Block contains objects evacuated during this GC */
+#define BF_EVACUATED 1
+/* Block is a large object */
+#define BF_LARGE     2
+/* Block is pinned */
+#define BF_PINNED    4
+/* Block is to be marked, not copied */
+#define BF_MARKED    8
+/* Block is executable */
+#define BF_EXEC      32
+/* Block contains only a small amount of live data */
+#define BF_FRAGMENTED 64
+/* we know about this block (for finding leaks) */
+#define BF_KNOWN     128
+/* Block was swept in the last generation */
+#define BF_SWEPT     256
+/* Block is part of a Compact */
+#define BF_COMPACT   512
+/* Maximum flag value (do not define anything higher than this!) */
+#define BF_FLAG_MAX  (1 << 15)
+
+/* Finding the block descriptor for a given block -------------------------- */
+
+#if defined(CMINUSMINUS)
+
+#define Bdescr(p) \
+    ((((p) &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT)) \
+     | ((p) & ~MBLOCK_MASK))
+
+#else
+
+EXTERN_INLINE bdescr *Bdescr(StgPtr p);
+EXTERN_INLINE bdescr *Bdescr(StgPtr p)
+{
+  return (bdescr *)
+    ((((W_)p &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT))
+     | ((W_)p & ~MBLOCK_MASK)
+     );
+}
+
+#endif
+
+/* Useful Macros ------------------------------------------------------------ */
+
+/* Offset of first real data block in a megablock */
+
+#define FIRST_BLOCK_OFF \
+   ((W_)BLOCK_ROUND_UP(BDESCR_SIZE * (MBLOCK_SIZE / BLOCK_SIZE)))
+
+/* First data block in a given megablock */
+
+#define FIRST_BLOCK(m) ((void *)(FIRST_BLOCK_OFF + (W_)(m)))
+
+/* Last data block in a given megablock */
+
+#define LAST_BLOCK(m)  ((void *)(MBLOCK_SIZE-BLOCK_SIZE + (W_)(m)))
+
+/* First real block descriptor in a megablock */
+
+#define FIRST_BDESCR(m) \
+   ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
+
+/* Last real block descriptor in a megablock */
+
+#define LAST_BDESCR(m) \
+  ((bdescr *)(((MBLOCK_SIZE-BLOCK_SIZE)>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
+
+/* Number of usable blocks in a megablock */
+
+#if !defined(CMINUSMINUS) // already defined in DerivedConstants.h
+#define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)
+#endif
+
+/* How many blocks in this megablock group */
+
+#define MBLOCK_GROUP_BLOCKS(n) \
+   (BLOCKS_PER_MBLOCK + (n-1) * (MBLOCK_SIZE / BLOCK_SIZE))
+
+/* Compute the required size of a megablock group */
+
+#define BLOCKS_TO_MBLOCKS(n) \
+   (1 + (W_)MBLOCK_ROUND_UP((n-BLOCKS_PER_MBLOCK) * BLOCK_SIZE) / MBLOCK_SIZE)
+
+
+#if !defined(CMINUSMINUS)
+/* to the end... */
+
+/* Double-linked block lists: --------------------------------------------- */
+
+INLINE_HEADER void
+dbl_link_onto(bdescr *bd, bdescr **list)
+{
+  bd->link = *list;
+  bd->u.back = NULL;
+  if (*list) {
+    (*list)->u.back = bd; /* double-link the list */
+  }
+  *list = bd;
+}
+
+INLINE_HEADER void
+dbl_link_remove(bdescr *bd, bdescr **list)
+{
+    if (bd->u.back) {
+        bd->u.back->link = bd->link;
+    } else {
+        *list = bd->link;
+    }
+    if (bd->link) {
+        bd->link->u.back = bd->u.back;
+    }
+}
+
+INLINE_HEADER void
+dbl_link_insert_after(bdescr *bd, bdescr *after)
+{
+    bd->link = after->link;
+    bd->u.back = after;
+    if (after->link) {
+        after->link->u.back = bd;
+    }
+    after->link = bd;
+}
+
+INLINE_HEADER void
+dbl_link_replace(bdescr *new_, bdescr *old, bdescr **list)
+{
+    new_->link = old->link;
+    new_->u.back = old->u.back;
+    if (old->link) {
+        old->link->u.back = new_;
+    }
+    if (old->u.back) {
+        old->u.back->link = new_;
+    } else {
+        *list = new_;
+    }
+}
+
+/* Initialisation ---------------------------------------------------------- */
+
+extern void initBlockAllocator(void);
+
+/* Allocation -------------------------------------------------------------- */
+
+bdescr *allocGroup(W_ n);
+
+EXTERN_INLINE bdescr* allocBlock(void);
+EXTERN_INLINE bdescr* allocBlock(void)
+{
+    return allocGroup(1);
+}
+
+bdescr *allocGroupOnNode(uint32_t node, W_ n);
+
+EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node);
+EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node)
+{
+    return allocGroupOnNode(node,1);
+}
+
+// versions that take the storage manager lock for you:
+bdescr *allocGroup_lock(W_ n);
+bdescr *allocBlock_lock(void);
+
+bdescr *allocGroupOnNode_lock(uint32_t node, W_ n);
+bdescr *allocBlockOnNode_lock(uint32_t node);
+
+/* De-Allocation ----------------------------------------------------------- */
+
+void freeGroup(bdescr *p);
+void freeChain(bdescr *p);
+
+// versions that take the storage manager lock for you:
+void freeGroup_lock(bdescr *p);
+void freeChain_lock(bdescr *p);
+
+bdescr * splitBlockGroup (bdescr *bd, uint32_t blocks);
+
+/* Round a value to megablocks --------------------------------------------- */
+
+// We want to allocate an object around a given size, round it up or
+// down to the nearest size that will fit in an mblock group.
+INLINE_HEADER StgWord
+round_to_mblocks(StgWord words)
+{
+    if (words > BLOCKS_PER_MBLOCK * BLOCK_SIZE_W) {
+        // first, ignore the gap at the beginning of the first mblock by
+        // adding it to the total words.  Then we can pretend we're
+        // dealing in a uniform unit of megablocks.
+        words += FIRST_BLOCK_OFF/sizeof(W_);
+
+        if ((words % MBLOCK_SIZE_W) < (MBLOCK_SIZE_W / 2)) {
+            words = (words / MBLOCK_SIZE_W) * MBLOCK_SIZE_W;
+        } else {
+            words = ((words / MBLOCK_SIZE_W) + 1) * MBLOCK_SIZE_W;
+        }
+
+        words -= FIRST_BLOCK_OFF/sizeof(W_);
+    }
+    return words;
+}
+
+#endif /* !CMINUSMINUS */
diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/ClosureMacros.h
@@ -0,0 +1,587 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2012
+ *
+ * Macros for building and manipulating closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   Info tables are slammed up against the entry code, and the label
+   for the info table is at the *end* of the table itself.  This
+   inline function adjusts an info pointer to point to the beginning
+   of the table, so we can use standard C structure indexing on it.
+
+   Note: this works for SRT info tables as long as you don't want to
+   access the SRT, since they are laid out the same with the SRT
+   pointer as the first word in the table.
+
+   NOTES ABOUT MANGLED C VS. MINI-INTERPRETER:
+
+   A couple of definitions:
+
+       "info pointer"    The first word of the closure.  Might point
+                         to either the end or the beginning of the
+                         info table, depending on whether we're using
+                         the mini interpreter or not.  GET_INFO(c)
+                         retrieves the info pointer of a closure.
+
+       "info table"      The info table structure associated with a
+                         closure.  This is always a pointer to the
+                         beginning of the structure, so we can
+                         use standard C structure indexing to pull out
+                         the fields.  get_itbl(c) returns a pointer to
+                         the info table for closure c.
+
+   An address of the form xxxx_info points to the end of the info
+   table or the beginning of the info table depending on whether we're
+   mangling or not respectively.  So,
+
+         c->header.info = xxx_info
+
+   makes absolute sense, whether mangling or not.
+
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER void SET_INFO(StgClosure *c, const StgInfoTable *info) {
+    c->header.info = info;
+}
+INLINE_HEADER const StgInfoTable *GET_INFO(StgClosure *c) {
+    return c->header.info;
+}
+
+#define GET_ENTRY(c)  (ENTRY_CODE(GET_INFO(c)))
+
+#if defined(TABLES_NEXT_TO_CODE)
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info - 1;}
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info - 1;}
+INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info - 1;}
+INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info - 1;}
+INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info - 1;}
+INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)(i + 1) - 1;}
+INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)(i + 1) - 1;}
+INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)(i + 1) - 1;}
+INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)(i + 1) - 1;}
+#else
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info;}
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info;}
+INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info;}
+INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info;}
+INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info;}
+INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)i;}
+INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)i;}
+INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)i;}
+INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)i;}
+#endif
+
+EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c);
+EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c)
+{
+   return INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c);
+EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c)
+{
+   return RET_INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+INLINE_HEADER const StgFunInfoTable *get_fun_itbl(const StgClosure *c)
+{
+   return FUN_INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+INLINE_HEADER const StgThunkInfoTable *get_thunk_itbl(const StgClosure *c)
+{
+   return THUNK_INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)
+{
+   return CON_INFO_PTR_TO_STRUCT((c)->header.info);
+}
+
+INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)
+{
+    return get_itbl(con)->srt;
+}
+
+/* -----------------------------------------------------------------------------
+   Macros for building closures
+   -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#if defined(DEBUG_RETAINER)
+/*
+  For the sake of debugging, we take the safest way for the moment. Actually, this
+  is useful to check the sanity of heap before beginning retainer profiling.
+  flip is defined in RetainerProfile.c, and declared as extern in RetainerProfile.h.
+  Note: change those functions building Haskell objects from C datatypes, i.e.,
+  all rts_mk???() functions in RtsAPI.c, as well.
+ */
+#define SET_PROF_HDR(c,ccs_)            \
+        ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = (retainerSet *)((StgWord)NULL | flip))
+#else
+/*
+  For retainer profiling only: we do not have to set (c)->header.prof.hp.rs to
+  NULL | flip (flip is defined in RetainerProfile.c) because even when flip
+  is 1, rs is invalid and will be initialized to NULL | flip later when
+  the closure *c is visited.
+ */
+/*
+#define SET_PROF_HDR(c,ccs_)            \
+        ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = NULL)
+ */
+/*
+  The following macro works for both retainer profiling and LDV profiling:
+  for retainer profiling, ldvTime remains 0, so rs fields are initialized to 0.
+  See the invariants on ldvTime.
+ */
+#define SET_PROF_HDR(c,ccs_)            \
+        ((c)->header.prof.ccs = ccs_,   \
+        LDV_RECORD_CREATE((c)))
+#endif /* DEBUG_RETAINER */
+#else
+#define SET_PROF_HDR(c,ccs)
+#endif
+
+#define SET_HDR(c,_info,ccs)                            \
+   {                                                    \
+        (c)->header.info = _info;                       \
+        SET_PROF_HDR((StgClosure *)(c),ccs);            \
+   }
+
+#define SET_ARR_HDR(c,info,costCentreStack,n_bytes)     \
+   SET_HDR(c,info,costCentreStack);                     \
+   (c)->bytes = n_bytes;
+
+// Use when changing a closure from one kind to another
+#define OVERWRITE_INFO(c, new_info)                             \
+    OVERWRITING_CLOSURE((StgClosure *)(c));                     \
+    SET_INFO((StgClosure *)(c), (new_info));                    \
+    LDV_RECORD_CREATE(c);
+
+/* -----------------------------------------------------------------------------
+   How to get hold of the static link field for a static closure.
+   -------------------------------------------------------------------------- */
+
+/* These are hard-coded. */
+#define THUNK_STATIC_LINK(p) (&(p)->payload[1])
+#define IND_STATIC_LINK(p)   (&(p)->payload[1])
+
+INLINE_HEADER StgClosure **
+STATIC_LINK(const StgInfoTable *info, StgClosure *p)
+{
+    switch (info->type) {
+    case THUNK_STATIC:
+        return THUNK_STATIC_LINK(p);
+    case IND_STATIC:
+        return IND_STATIC_LINK(p);
+    default:
+        return &p->payload[info->layout.payload.ptrs +
+                           info->layout.payload.nptrs];
+    }
+}
+
+/* -----------------------------------------------------------------------------
+   INTLIKE and CHARLIKE closures.
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER P_ CHARLIKE_CLOSURE(int n) {
+    return (P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE];
+}
+INLINE_HEADER P_ INTLIKE_CLOSURE(int n) {
+    return (P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE];
+}
+
+/* ----------------------------------------------------------------------------
+   Macros for untagging and retagging closure pointers
+   For more information look at the comments in Cmm.h
+   ------------------------------------------------------------------------- */
+
+static inline StgWord
+GET_CLOSURE_TAG(const StgClosure * p)
+{
+    return (StgWord)p & TAG_MASK;
+}
+
+static inline StgClosure *
+UNTAG_CLOSURE(StgClosure * p)
+{
+    return (StgClosure*)((StgWord)p & ~TAG_MASK);
+}
+
+static inline const StgClosure *
+UNTAG_CONST_CLOSURE(const StgClosure * p)
+{
+    return (const StgClosure*)((StgWord)p & ~TAG_MASK);
+}
+
+static inline StgClosure *
+TAG_CLOSURE(StgWord tag,StgClosure * p)
+{
+    return (StgClosure*)((StgWord)p | tag);
+}
+
+/* -----------------------------------------------------------------------------
+   Forwarding pointers
+   -------------------------------------------------------------------------- */
+
+#define IS_FORWARDING_PTR(p) ((((StgWord)p) & 1) != 0)
+#define MK_FORWARDING_PTR(p) (((StgWord)p) | 1)
+#define UN_FORWARDING_PTR(p) (((StgWord)p) - 1)
+
+/* -----------------------------------------------------------------------------
+   DEBUGGING predicates for pointers
+
+   LOOKS_LIKE_INFO_PTR(p)    returns False if p is definitely not an info ptr
+   LOOKS_LIKE_CLOSURE_PTR(p) returns False if p is definitely not a closure ptr
+
+   These macros are complete but not sound.  That is, they might
+   return false positives.  Do not rely on them to distinguish info
+   pointers from closure pointers, for example.
+
+   We don't use address-space predicates these days, for portability
+   reasons, and the fact that code/data can be scattered about the
+   address space in a dynamically-linked environment.  Our best option
+   is to look at the alleged info table and see whether it seems to
+   make sense...
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p)
+{
+    StgInfoTable *info = INFO_PTR_TO_STRUCT((StgInfoTable *)p);
+    return info->type != INVALID_OBJECT && info->type < N_CLOSURE_TYPES;
+}
+
+INLINE_HEADER bool LOOKS_LIKE_INFO_PTR (StgWord p)
+{
+    return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p));
+}
+
+INLINE_HEADER bool LOOKS_LIKE_CLOSURE_PTR (const void *p)
+{
+    return LOOKS_LIKE_INFO_PTR((StgWord)
+            (UNTAG_CONST_CLOSURE((const StgClosure *)(p)))->header.info);
+}
+
+/* -----------------------------------------------------------------------------
+   Macros for calculating the size of a closure
+   -------------------------------------------------------------------------- */
+
+EXTERN_INLINE StgOffset PAP_sizeW   ( uint32_t n_args );
+EXTERN_INLINE StgOffset PAP_sizeW   ( uint32_t n_args )
+{ return sizeofW(StgPAP) + n_args; }
+
+EXTERN_INLINE StgOffset AP_sizeW   ( uint32_t n_args );
+EXTERN_INLINE StgOffset AP_sizeW   ( uint32_t n_args )
+{ return sizeofW(StgAP) + n_args; }
+
+EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size );
+EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size )
+{ return sizeofW(StgAP_STACK) + size; }
+
+EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np );
+EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np )
+{ return sizeofW(StgHeader) + p + np; }
+
+EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void );
+EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void )
+{ return sizeofW(StgSelector); }
+
+EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void );
+EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void )
+{ return sizeofW(StgInd); } // a BLACKHOLE is a kind of indirection
+
+/* --------------------------------------------------------------------------
+   Sizes of closures
+   ------------------------------------------------------------------------*/
+
+EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl );
+EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
+{ return sizeofW(StgClosure)
+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs
+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
+EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl );
+EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl )
+{ return sizeofW(StgThunk)
+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs
+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
+EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x );
+EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x )
+{ return AP_STACK_sizeW(x->size); }
+
+EXTERN_INLINE StgOffset ap_sizeW( StgAP* x );
+EXTERN_INLINE StgOffset ap_sizeW( StgAP* x )
+{ return AP_sizeW(x->n_args); }
+
+EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x );
+EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x )
+{ return PAP_sizeW(x->n_args); }
+
+EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x);
+EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x)
+{ return ROUNDUP_BYTES_TO_WDS(x->bytes); }
+
+EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x );
+EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x )
+{ return sizeofW(StgArrBytes) + arr_words_words(x); }
+
+EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x );
+EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
+{ return sizeofW(StgMutArrPtrs) + x->size; }
+
+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x );
+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x )
+{ return sizeofW(StgSmallMutArrPtrs) + x->ptrs; }
+
+EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack );
+EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack )
+{ return sizeofW(StgStack) + stack->stack_size; }
+
+EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco );
+EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco )
+{ return bco->size; }
+
+EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str );
+EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str )
+{ return str->totalW; }
+
+/*
+ * TODO: Consider to switch return type from 'uint32_t' to 'StgWord' #8742
+ *
+ * (Also for 'closure_sizeW' below)
+ */
+EXTERN_INLINE uint32_t
+closure_sizeW_ (const StgClosure *p, const StgInfoTable *info);
+EXTERN_INLINE uint32_t
+closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)
+{
+    switch (info->type) {
+    case THUNK_0_1:
+    case THUNK_1_0:
+        return sizeofW(StgThunk) + 1;
+    case FUN_0_1:
+    case CONSTR_0_1:
+    case FUN_1_0:
+    case CONSTR_1_0:
+        return sizeofW(StgHeader) + 1;
+    case THUNK_0_2:
+    case THUNK_1_1:
+    case THUNK_2_0:
+        return sizeofW(StgThunk) + 2;
+    case FUN_0_2:
+    case CONSTR_0_2:
+    case FUN_1_1:
+    case CONSTR_1_1:
+    case FUN_2_0:
+    case CONSTR_2_0:
+        return sizeofW(StgHeader) + 2;
+    case THUNK:
+        return thunk_sizeW_fromITBL(info);
+    case THUNK_SELECTOR:
+        return THUNK_SELECTOR_sizeW();
+    case AP_STACK:
+        return ap_stack_sizeW((StgAP_STACK *)p);
+    case AP:
+        return ap_sizeW((StgAP *)p);
+    case PAP:
+        return pap_sizeW((StgPAP *)p);
+    case IND:
+        return sizeofW(StgInd);
+    case ARR_WORDS:
+        return arr_words_sizeW((StgArrBytes *)p);
+    case MUT_ARR_PTRS_CLEAN:
+    case MUT_ARR_PTRS_DIRTY:
+    case MUT_ARR_PTRS_FROZEN_CLEAN:
+    case MUT_ARR_PTRS_FROZEN_DIRTY:
+        return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+        return small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+    case TSO:
+        return sizeofW(StgTSO);
+    case STACK:
+        return stack_sizeW((StgStack*)p);
+    case BCO:
+        return bco_sizeW((StgBCO *)p);
+    case TREC_CHUNK:
+        return sizeofW(StgTRecChunk);
+    default:
+        return sizeW_fromITBL(info);
+    }
+}
+
+// The definitive way to find the size, in words, of a heap-allocated closure
+EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p);
+EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p)
+{
+    return closure_sizeW_(p, get_itbl(p));
+}
+
+/* -----------------------------------------------------------------------------
+   Sizes of stack frames
+   -------------------------------------------------------------------------- */
+
+EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame );
+EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame )
+{
+    const StgRetInfoTable *info;
+
+    info = get_ret_itbl(frame);
+    switch (info->i.type) {
+
+    case RET_FUN:
+        return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;
+
+    case RET_BIG:
+        return 1 + GET_LARGE_BITMAP(&info->i)->size;
+
+    case RET_BCO:
+        return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);
+
+    default:
+        return 1 + BITMAP_SIZE(info->i.layout.bitmap);
+    }
+}
+
+/* -----------------------------------------------------------------------------
+   StgMutArrPtrs macros
+
+   An StgMutArrPtrs has a card table to indicate which elements are
+   dirty for the generational GC.  The card table is an array of
+   bytes, where each byte covers (1 << MUT_ARR_PTRS_CARD_BITS)
+   elements.  The card table is directly after the array data itself.
+   -------------------------------------------------------------------------- */
+
+// The number of card bytes needed
+INLINE_HEADER W_ mutArrPtrsCards (W_ elems)
+{
+    return (W_)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+                           >> MUT_ARR_PTRS_CARD_BITS);
+}
+
+// The number of words in the card table
+INLINE_HEADER W_ mutArrPtrsCardTableSize (W_ elems)
+{
+    return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems));
+}
+
+// The address of the card for a particular card number
+INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
+{
+    return ((StgWord8 *)&(a->payload[a->ptrs]) + n);
+}
+
+/* -----------------------------------------------------------------------------
+   Replacing a closure with a different one.  We must call
+   OVERWRITING_CLOSURE(p) on the old closure that is about to be
+   overwritten.
+
+   Note [zeroing slop]
+
+   In some scenarios we write zero words into "slop"; memory that is
+   left unoccupied after we overwrite a closure in the heap with a
+   smaller closure.
+
+   Zeroing slop is required for:
+
+    - full-heap sanity checks (DEBUG, and +RTS -DS)
+    - LDV profiling (PROFILING, and +RTS -hb)
+
+   Zeroing slop must be disabled for:
+
+    - THREADED_RTS with +RTS -N2 and greater, because we cannot
+      overwrite slop when another thread might be reading it.
+
+   Hence, slop is zeroed when either:
+
+    - PROFILING && era <= 0 (LDV is on)
+    - !THREADED_RTS && DEBUG
+
+   And additionally:
+
+    - LDV profiling and +RTS -N2 are incompatible
+    - full-heap sanity checks are disabled for THREADED_RTS
+
+   -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define ZERO_SLOP_FOR_LDV_PROF 1
+#else
+#define ZERO_SLOP_FOR_LDV_PROF 0
+#endif
+
+#if defined(DEBUG) && !defined(THREADED_RTS)
+#define ZERO_SLOP_FOR_SANITY_CHECK 1
+#else
+#define ZERO_SLOP_FOR_SANITY_CHECK 0
+#endif
+
+#if ZERO_SLOP_FOR_LDV_PROF || ZERO_SLOP_FOR_SANITY_CHECK
+#define OVERWRITING_CLOSURE(c) overwritingClosure(c)
+#define OVERWRITING_CLOSURE_OFS(c,n) overwritingClosureOfs(c,n)
+#else
+#define OVERWRITING_CLOSURE(c) /* nothing */
+#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
+#endif
+
+#if defined(PROFILING)
+void LDV_recordDead (const StgClosure *c, uint32_t size);
+#endif
+
+EXTERN_INLINE void overwritingClosure_ (StgClosure *p,
+                                        uint32_t offset /* in words */,
+                                        uint32_t size /* closure size, in words */);
+EXTERN_INLINE void overwritingClosure_ (StgClosure *p, uint32_t offset, uint32_t size)
+{
+#if ZERO_SLOP_FOR_LDV_PROF && !ZERO_SLOP_FOR_SANITY_CHECK
+    // see Note [zeroing slop], also #8402
+    if (era <= 0) return;
+#endif
+
+    // For LDV profiling, we need to record the closure as dead
+#if defined(PROFILING)
+    LDV_recordDead(p, size);
+#endif
+
+    for (uint32_t i = offset; i < size; i++) {
+        ((StgWord *)p)[i] = 0;
+    }
+}
+
+EXTERN_INLINE void overwritingClosure (StgClosure *p);
+EXTERN_INLINE void overwritingClosure (StgClosure *p)
+{
+    overwritingClosure_(p, sizeofW(StgThunkHeader), closure_sizeW(p));
+}
+
+// Version of 'overwritingClosure' which overwrites only a suffix of a
+// closure.  The offset is expressed in words relative to 'p' and shall
+// be less than or equal to closure_sizeW(p), and usually at least as
+// large as the respective thunk header.
+//
+// Note: As this calls LDV_recordDead() you have to call LDV_RECORD()
+//       on the final state of the closure at the call-site
+EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset);
+EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset)
+{
+    overwritingClosure_(p, offset, closure_sizeW(p));
+}
+
+// Version of 'overwritingClosure' which takes closure size as argument.
+EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size /* in words */);
+EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size)
+{
+    overwritingClosure_(p, sizeofW(StgThunkHeader), size);
+}
diff --git a/includes/rts/storage/ClosureTypes.h b/includes/rts/storage/ClosureTypes.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/ClosureTypes.h
@@ -0,0 +1,86 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2005
+ *
+ * Closure Type Constants: out here because the native code generator
+ * needs to get at them.
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * WARNING WARNING WARNING
+ *
+ * If you add or delete any closure types, don't forget to update the following,
+ *   - the closure flags table in rts/ClosureFlags.c
+ *   - isRetainer in rts/RetainerProfile.c
+ *   - the closure_type_names list in rts/Printer.c
+ */
+
+/* Object tag 0 raises an internal error */
+#define INVALID_OBJECT                0
+#define CONSTR                        1
+#define CONSTR_1_0                    2
+#define CONSTR_0_1                    3
+#define CONSTR_2_0                    4
+#define CONSTR_1_1                    5
+#define CONSTR_0_2                    6
+#define CONSTR_NOCAF                  7
+#define FUN                           8
+#define FUN_1_0                       9
+#define FUN_0_1                       10
+#define FUN_2_0                       11
+#define FUN_1_1                       12
+#define FUN_0_2                       13
+#define FUN_STATIC                    14
+#define THUNK                         15
+#define THUNK_1_0                     16
+#define THUNK_0_1                     17
+#define THUNK_2_0                     18
+#define THUNK_1_1                     19
+#define THUNK_0_2                     20
+#define THUNK_STATIC                  21
+#define THUNK_SELECTOR                22
+#define BCO                           23
+#define AP                            24
+#define PAP                           25
+#define AP_STACK                      26
+#define IND                           27
+#define IND_STATIC                    28
+#define RET_BCO                       29
+#define RET_SMALL                     30
+#define RET_BIG                       31
+#define RET_FUN                       32
+#define UPDATE_FRAME                  33
+#define CATCH_FRAME                   34
+#define UNDERFLOW_FRAME               35
+#define STOP_FRAME                    36
+#define BLOCKING_QUEUE                37
+#define BLACKHOLE                     38
+#define MVAR_CLEAN                    39
+#define MVAR_DIRTY                    40
+#define TVAR                          41
+#define ARR_WORDS                     42
+#define MUT_ARR_PTRS_CLEAN            43
+#define MUT_ARR_PTRS_DIRTY            44
+#define MUT_ARR_PTRS_FROZEN_DIRTY     45
+#define MUT_ARR_PTRS_FROZEN_CLEAN     46
+#define MUT_VAR_CLEAN                 47
+#define MUT_VAR_DIRTY                 48
+#define WEAK                          49
+#define PRIM                          50
+#define MUT_PRIM                      51
+#define TSO                           52
+#define STACK                         53
+#define TREC_CHUNK                    54
+#define ATOMICALLY_FRAME              55
+#define CATCH_RETRY_FRAME             56
+#define CATCH_STM_FRAME               57
+#define WHITEHOLE                     58
+#define SMALL_MUT_ARR_PTRS_CLEAN      59
+#define SMALL_MUT_ARR_PTRS_DIRTY      60
+#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61
+#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62
+#define COMPACT_NFDATA                63
+#define N_CLOSURE_TYPES               64
diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/Closures.h
@@ -0,0 +1,470 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * The Layout of a closure header depends on which kind of system we're
+ * compiling for: profiling, parallel, ticky, etc.
+ */
+
+/* -----------------------------------------------------------------------------
+   The profiling header
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+  CostCentreStack *ccs;
+  union {
+    struct _RetainerSet *rs;  /* Retainer Set */
+    StgWord ldvw;             /* Lag/Drag/Void Word */
+  } hp;
+} StgProfHeader;
+
+/* -----------------------------------------------------------------------------
+   The SMP header
+
+   A thunk has a padding word to take the updated value.  This is so
+   that the update doesn't overwrite the payload, so we can avoid
+   needing to lock the thunk during entry and update.
+
+   Note: this doesn't apply to THUNK_STATICs, which have no payload.
+
+   Note: we leave this padding word in all ways, rather than just SMP,
+   so that we don't have to recompile all our libraries for SMP.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgWord pad;
+} StgSMPThunkHeader;
+
+/* -----------------------------------------------------------------------------
+   The full fixed-size closure header
+
+   The size of the fixed header is the sum of the optional parts plus a single
+   word for the entry code pointer.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    const StgInfoTable* info;
+#if defined(PROFILING)
+    StgProfHeader         prof;
+#endif
+} StgHeader;
+
+typedef struct {
+    const StgInfoTable* info;
+#if defined(PROFILING)
+    StgProfHeader         prof;
+#endif
+    StgSMPThunkHeader     smp;
+} StgThunkHeader;
+
+#define THUNK_EXTRA_HEADER_W (sizeofW(StgThunkHeader)-sizeofW(StgHeader))
+
+/* -----------------------------------------------------------------------------
+   Closure Types
+
+   For any given closure type (defined in InfoTables.h), there is a
+   corresponding structure defined below.  The name of the structure
+   is obtained by concatenating the closure type with '_closure'
+   -------------------------------------------------------------------------- */
+
+/* All closures follow the generic format */
+
+typedef struct StgClosure_ {
+    StgHeader   header;
+    struct StgClosure_ *payload[];
+} *StgClosurePtr; // StgClosure defined in rts/Types.h
+
+typedef struct {
+    StgThunkHeader  header;
+    struct StgClosure_ *payload[];
+} StgThunk;
+
+typedef struct {
+    StgThunkHeader   header;
+    StgClosure *selectee;
+} StgSelector;
+
+typedef struct {
+    StgHeader   header;
+    StgHalfWord arity;          /* zero if it is an AP */
+    StgHalfWord n_args;
+    StgClosure *fun;            /* really points to a fun */
+    StgClosure *payload[];
+} StgPAP;
+
+typedef struct {
+    StgThunkHeader   header;
+    StgHalfWord arity;          /* zero if it is an AP */
+    StgHalfWord n_args;
+    StgClosure *fun;            /* really points to a fun */
+    StgClosure *payload[];
+} StgAP;
+
+typedef struct {
+    StgThunkHeader   header;
+    StgWord     size;                    /* number of words in payload */
+    StgClosure *fun;
+    StgClosure *payload[]; /* contains a chunk of *stack* */
+} StgAP_STACK;
+
+typedef struct {
+    StgHeader   header;
+    StgClosure *indirectee;
+} StgInd;
+
+typedef struct {
+    StgHeader     header;
+    StgClosure   *indirectee;
+    StgClosure   *static_link; // See Note [CAF lists]
+    const StgInfoTable *saved_info;
+        // `saved_info` also used for the link field for `debug_caf_list`,
+        // see `newCAF` and Note [CAF lists] in rts/sm/Storage.h.
+} StgIndStatic;
+
+typedef struct StgBlockingQueue_ {
+    StgHeader   header;
+    struct StgBlockingQueue_ *link;
+        // here so it looks like an IND, to be able to skip the queue without
+        // deleting it (done in wakeBlockingQueue())
+    StgClosure *bh;  // the BLACKHOLE
+    StgTSO     *owner;
+    struct MessageBlackHole_ *queue;
+        // holds TSOs blocked on `bh`
+} StgBlockingQueue;
+
+typedef struct {
+    StgHeader  header;
+    StgWord    bytes;
+    StgWord    payload[];
+} StgArrBytes;
+
+typedef struct {
+    StgHeader   header;
+    StgWord     ptrs;
+    StgWord     size; // ptrs plus card table
+    StgClosure *payload[];
+    // see also: StgMutArrPtrs macros in ClosureMacros.h
+} StgMutArrPtrs;
+
+typedef struct {
+    StgHeader   header;
+    StgWord     ptrs;
+    StgClosure *payload[];
+} StgSmallMutArrPtrs;
+
+typedef struct {
+    StgHeader   header;
+    StgClosure *var;
+} StgMutVar;
+
+typedef struct _StgUpdateFrame {
+    StgHeader  header;
+    StgClosure *updatee;
+} StgUpdateFrame;
+
+typedef struct {
+    StgHeader  header;
+    StgWord    exceptions_blocked;
+    StgClosure *handler;
+} StgCatchFrame;
+
+typedef struct {
+    const StgInfoTable* info;
+    struct StgStack_ *next_chunk;
+} StgUnderflowFrame;
+
+typedef struct {
+    StgHeader  header;
+} StgStopFrame;
+
+typedef struct {
+  StgHeader header;
+  StgWord data;
+} StgIntCharlikeClosure;
+
+/* statically allocated */
+typedef struct {
+  StgHeader  header;
+} StgRetry;
+
+typedef struct _StgStableName {
+  StgHeader      header;
+  StgWord        sn;
+} StgStableName;
+
+typedef struct _StgWeak {       /* Weak v */
+  StgHeader header;
+  StgClosure *cfinalizers;
+  StgClosure *key;
+  StgClosure *value;            /* v */
+  StgClosure *finalizer;
+  struct _StgWeak *link;
+} StgWeak;
+
+typedef struct _StgCFinalizerList {
+  StgHeader header;
+  StgClosure *link;
+  void (*fptr)(void);
+  void *ptr;
+  void *eptr;
+  StgWord flag; /* has environment (0 or 1) */
+} StgCFinalizerList;
+
+/* Byte code objects.  These are fixed size objects with pointers to
+ * four arrays, designed so that a BCO can be easily "re-linked" to
+ * other BCOs, to facilitate GHC's intelligent recompilation.  The
+ * array of instructions is static and not re-generated when the BCO
+ * is re-linked, but the other 3 arrays will be regenerated.
+ *
+ * A BCO represents either a function or a stack frame.  In each case,
+ * it needs a bitmap to describe to the garbage collector the
+ * pointerhood of its arguments/free variables respectively, and in
+ * the case of a function it also needs an arity.  These are stored
+ * directly in the BCO, rather than in the instrs array, for two
+ * reasons:
+ * (a) speed: we need to get at the bitmap info quickly when
+ *     the GC is examining APs and PAPs that point to this BCO
+ * (b) a subtle interaction with the compacting GC.  In compacting
+ *     GC, the info that describes the size/layout of a closure
+ *     cannot be in an object more than one level of indirection
+ *     away from the current object, because of the order in
+ *     which pointers are updated to point to their new locations.
+ */
+
+typedef struct {
+    StgHeader      header;
+    StgArrBytes   *instrs;      /* a pointer to an ArrWords */
+    StgArrBytes   *literals;    /* a pointer to an ArrWords */
+    StgMutArrPtrs *ptrs;        /* a pointer to a  MutArrPtrs */
+    StgHalfWord   arity;        /* arity of this BCO */
+    StgHalfWord   size;         /* size of this BCO (in words) */
+    StgWord       bitmap[];  /* an StgLargeBitmap */
+} StgBCO;
+
+#define BCO_BITMAP(bco)      ((StgLargeBitmap *)((StgBCO *)(bco))->bitmap)
+#define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size)
+#define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap)
+#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \
+                                / BITS_IN(StgWord))
+
+/* A function return stack frame: used when saving the state for a
+ * garbage collection at a function entry point.  The function
+ * arguments are on the stack, and we also save the function (its
+ * info table describes the pointerhood of the arguments).
+ *
+ * The stack frame size is also cached in the frame for convenience.
+ *
+ * The only RET_FUN is stg_gc_fun, which is created by __stg_gc_fun,
+ * both in HeapStackCheck.cmm.
+ */
+typedef struct {
+    const StgInfoTable* info;
+    StgWord        size;
+    StgClosure *   fun;
+    StgClosure *   payload[];
+} StgRetFun;
+
+/* Concurrent communication objects */
+
+typedef struct StgMVarTSOQueue_ {
+    StgHeader                header;
+    struct StgMVarTSOQueue_ *link;
+    struct StgTSO_          *tso;
+} StgMVarTSOQueue;
+
+typedef struct {
+    StgHeader                header;
+    struct StgMVarTSOQueue_ *head;
+    struct StgMVarTSOQueue_ *tail;
+    StgClosure*              value;
+} StgMVar;
+
+
+/* STM data structures
+ *
+ *  StgTVar defines the only type that can be updated through the STM
+ *  interface.
+ *
+ *  Note that various optimisations may be possible in order to use less
+ *  space for these data structures at the cost of more complexity in the
+ *  implementation:
+ *
+ *   - In StgTVar, current_value and first_watch_queue_entry could be held in
+ *     the same field: if any thread is waiting then its expected_value for
+ *     the tvar is the current value.
+ *
+ *   - In StgTRecHeader, it might be worthwhile having separate chunks
+ *     of read-only and read-write locations.  This would save a
+ *     new_value field in the read-only locations.
+ *
+ *   - In StgAtomicallyFrame, we could combine the waiting bit into
+ *     the header (maybe a different info tbl for a waiting transaction).
+ *     This means we can specialise the code for the atomically frame
+ *     (it immediately switches on frame->waiting anyway).
+ */
+
+typedef struct StgTRecHeader_ StgTRecHeader;
+
+typedef struct StgTVarWatchQueue_ {
+  StgHeader                  header;
+  StgClosure                *closure; // StgTSO
+  struct StgTVarWatchQueue_ *next_queue_entry;
+  struct StgTVarWatchQueue_ *prev_queue_entry;
+} StgTVarWatchQueue;
+
+typedef struct {
+  StgHeader                  header;
+  StgClosure                *volatile current_value;
+  StgTVarWatchQueue         *volatile first_watch_queue_entry;
+  StgInt                     volatile num_updates;
+} StgTVar;
+
+/* new_value == expected_value for read-only accesses */
+/* new_value is a StgTVarWatchQueue entry when trec in state TREC_WAITING */
+typedef struct {
+  StgTVar                   *tvar;
+  StgClosure                *expected_value;
+  StgClosure                *new_value;
+#if defined(THREADED_RTS)
+  StgInt                     num_updates;
+#endif
+} TRecEntry;
+
+#define TREC_CHUNK_NUM_ENTRIES 16
+
+typedef struct StgTRecChunk_ {
+  StgHeader                  header;
+  struct StgTRecChunk_      *prev_chunk;
+  StgWord                    next_entry_idx;
+  TRecEntry                  entries[TREC_CHUNK_NUM_ENTRIES];
+} StgTRecChunk;
+
+typedef enum {
+  TREC_ACTIVE,        /* Transaction in progress, outcome undecided */
+  TREC_CONDEMNED,     /* Transaction in progress, inconsistent / out of date reads */
+  TREC_COMMITTED,     /* Transaction has committed, now updating tvars */
+  TREC_ABORTED,       /* Transaction has aborted, now reverting tvars */
+  TREC_WAITING,       /* Transaction currently waiting */
+} TRecState;
+
+struct StgTRecHeader_ {
+  StgHeader                  header;
+  struct StgTRecHeader_     *enclosing_trec;
+  StgTRecChunk              *current_chunk;
+  TRecState                  state;
+};
+
+typedef struct {
+  StgHeader   header;
+  StgClosure *code;
+  StgClosure *result;
+} StgAtomicallyFrame;
+
+typedef struct {
+  StgHeader   header;
+  StgClosure *code;
+  StgClosure *handler;
+} StgCatchSTMFrame;
+
+typedef struct {
+  StgHeader      header;
+  StgWord        running_alt_code;
+  StgClosure    *first_code;
+  StgClosure    *alt_code;
+} StgCatchRetryFrame;
+
+/* ----------------------------------------------------------------------------
+   Messages
+   ------------------------------------------------------------------------- */
+
+typedef struct Message_ {
+    StgHeader        header;
+    struct Message_ *link;
+} Message;
+
+typedef struct MessageWakeup_ {
+    StgHeader header;
+    Message  *link;
+    StgTSO   *tso;
+} MessageWakeup;
+
+typedef struct MessageThrowTo_ {
+    StgHeader   header;
+    struct MessageThrowTo_ *link;
+    StgTSO     *source;
+    StgTSO     *target;
+    StgClosure *exception;
+} MessageThrowTo;
+
+typedef struct MessageBlackHole_ {
+    StgHeader   header;
+    struct MessageBlackHole_ *link;
+        // here so it looks like an IND, to be able to skip the message without
+        // deleting it (done in throwToMsg())
+    StgTSO     *tso;
+    StgClosure *bh;
+} MessageBlackHole;
+
+/* ----------------------------------------------------------------------------
+   Compact Regions
+   ------------------------------------------------------------------------- */
+
+//
+// A compact region is a list of blocks.  Each block starts with an
+// StgCompactNFDataBlock structure, and the list is chained through the next
+// field of these structs.  (the link field of the bdescr is used to chain
+// together multiple compact region on the compact_objects field of a
+// generation).
+//
+// See Note [Compact Normal Forms] for details
+//
+typedef struct StgCompactNFDataBlock_ {
+    struct StgCompactNFDataBlock_ *self;
+       // the address of this block this is copied over to the
+       // receiving end when serializing a compact, so the receiving
+       // end can allocate the block at best as it can, and then
+       // verify if pointer adjustment is needed or not by comparing
+       // self with the actual address; the same data is sent over as
+       // SerializedCompact metadata, but having it here simplifies
+       // the fixup implementation.
+    struct StgCompactNFData_ *owner;
+       // the closure who owns this block (used in objectGetCompact)
+    struct StgCompactNFDataBlock_ *next;
+       // chain of blocks used for serialization and freeing
+} StgCompactNFDataBlock;
+
+//
+// This is the Compact# primitive object.
+//
+typedef struct StgCompactNFData_ {
+    StgHeader header;
+      // for sanity and other checks in practice, nothing should ever
+      // need the compact info pointer (we don't even need fwding
+      // pointers because it's a large object)
+    StgWord totalW;
+      // Total number of words in all blocks in the compact
+    StgWord autoBlockW;
+      // size of automatically appended blocks
+    StgPtr hp, hpLim;
+      // the beginning and end of the free area in the nursery block.  This is
+      // just a convenience so that we can avoid multiple indirections through
+      // the nursery pointer below during compaction.
+    StgCompactNFDataBlock *nursery;
+      // where to (try to) allocate from when appending
+    StgCompactNFDataBlock *last;
+      // the last block of the chain (to know where to append new
+      // blocks for resize)
+    struct hashtable *hash;
+      // the hash table for the current compaction, or NULL if
+      // there's no (sharing-preserved) compaction in progress.
+    StgClosure *result;
+      // Used temporarily to store the result of compaction.  Doesn't need to be
+      // a GC root.
+} StgCompactNFData;
diff --git a/includes/rts/storage/FunTypes.h b/includes/rts/storage/FunTypes.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/FunTypes.h
@@ -0,0 +1,54 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2002
+ *
+ * Things for functions.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* generic - function comes with a small bitmap */
+#define ARG_GEN      0   
+
+/* generic - function comes with a large bitmap */
+#define ARG_GEN_BIG  1
+
+/* BCO - function is really a BCO */
+#define ARG_BCO      2
+
+/*
+ * Specialised function types: bitmaps and calling sequences
+ * for these functions are pre-generated: see ghc/utils/genapply and
+ * generated code in ghc/rts/AutoApply.cmm.
+ *
+ *  NOTE: other places to change if you change this table:
+ *       - utils/genapply/Main.hs: stackApplyTypes
+ *       - compiler/codeGen/StgCmmLayout.hs: stdPattern
+ */
+#define ARG_NONE     3 
+#define ARG_N        4  
+#define ARG_P        5 
+#define ARG_F        6 
+#define ARG_D        7 
+#define ARG_L        8 
+#define ARG_V16      9 
+#define ARG_V32      10
+#define ARG_V64      11
+#define ARG_NN       12 
+#define ARG_NP       13
+#define ARG_PN       14
+#define ARG_PP       15
+#define ARG_NNN      16
+#define ARG_NNP      17
+#define ARG_NPN      18
+#define ARG_NPP      19
+#define ARG_PNN      20
+#define ARG_PNP      21
+#define ARG_PPN      22
+#define ARG_PPP      23
+#define ARG_PPPP     24
+#define ARG_PPPPP    25
+#define ARG_PPPPPP   26
+#define ARG_PPPPPPP  27
+#define ARG_PPPPPPPP 28
diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/GC.h
@@ -0,0 +1,248 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * External Storage Manger Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stddef.h>
+#include "rts/OSThreads.h"
+
+/* -----------------------------------------------------------------------------
+ * Generational GC
+ *
+ * We support an arbitrary number of generations.  Notes (in no particular
+ * order):
+ *
+ *       - Objects "age" in the nursery for one GC cycle before being promoted
+ *         to the next generation.  There is no aging in other generations.
+ *
+ *       - generation 0 is the allocation area.  It is given
+ *         a fixed set of blocks during initialisation, and these blocks
+ *         normally stay in G0S0.  In parallel execution, each
+ *         Capability has its own nursery.
+ *
+ *       - during garbage collection, each generation which is an
+ *         evacuation destination (i.e. all generations except G0) is
+ *         allocated a to-space.  evacuated objects are allocated into
+ *         the generation's to-space until GC is finished, when the
+ *         original generations's contents may be freed and replaced
+ *         by the to-space.
+ *
+ *       - the mutable-list is per-generation.  G0 doesn't have one
+ *         (since every garbage collection collects at least G0).
+ *
+ *       - block descriptors contain a pointer to the generation that
+ *         the block belongs to, for convenience.
+ *
+ *       - static objects are stored in per-generation lists.  See GC.c for
+ *         details of how we collect CAFs in the generational scheme.
+ *
+ *       - large objects are per-generation, and are promoted in the
+ *         same way as small objects.
+ *
+ * ------------------------------------------------------------------------- */
+
+// A count of blocks needs to store anything up to the size of memory
+// divided by the block size.  The safest thing is therefore to use a
+// type that can store the full range of memory addresses,
+// ie. StgWord.  Note that we have had some tricky int overflows in a
+// couple of cases caused by using ints rather than longs (e.g. #5086)
+
+typedef StgWord memcount;
+
+typedef struct nursery_ {
+    bdescr *       blocks;
+    memcount       n_blocks;
+} nursery;
+
+// Nursery invariants:
+//
+//  - cap->r.rNursery points to the nursery for this capability
+//
+//  - cap->r.rCurrentNursery points to the block in the nursery that we are
+//    currently allocating into.  While in Haskell the current heap pointer is
+//    in Hp, outside Haskell it is stored in cap->r.rCurrentNursery->free.
+//
+//  - the blocks *after* cap->rCurrentNursery in the chain are empty
+//    (although their bd->free pointers have not been updated to
+//    reflect that)
+//
+//  - the blocks *before* cap->rCurrentNursery have been used.  Except
+//    for rCurrentAlloc.
+//
+//  - cap->r.rCurrentAlloc is either NULL, or it points to a block in
+//    the nursery *before* cap->r.rCurrentNursery.
+//
+// See also Note [allocation accounting] to understand how total
+// memory allocation is tracked.
+
+typedef struct generation_ {
+    uint32_t       no;                  // generation number
+
+    bdescr *       blocks;              // blocks in this gen
+    memcount       n_blocks;            // number of blocks
+    memcount       n_words;             // number of used words
+
+    bdescr *       large_objects;       // large objects (doubly linked)
+    memcount       n_large_blocks;      // no. of blocks used by large objs
+    memcount       n_large_words;       // no. of words used by large objs
+    memcount       n_new_large_words;   // words of new large objects
+                                        // (for doYouWantToGC())
+
+    bdescr *       compact_objects;     // compact objects chain
+                                        // the second block in each compact is
+                                        // linked from the closure object, while
+                                        // the second compact object in the
+                                        // chain is linked from bd->link (like
+                                        // large objects)
+    memcount       n_compact_blocks;    // no. of blocks used by all compacts
+    bdescr *       compact_blocks_in_import; // compact objects being imported
+                                             // (not known to the GC because
+                                             // potentially invalid, but we
+                                             // need to keep track of them
+                                             // to avoid assertions in Sanity)
+                                             // this is a list shaped like compact_objects
+    memcount       n_compact_blocks_in_import; // no. of blocks used by compacts
+                                               // being imported
+
+    // Max blocks to allocate in this generation before collecting it. Collect
+    // this generation when
+    //
+    //     n_blocks + n_large_blocks + n_compact_blocks > max_blocks
+    //
+    memcount       max_blocks;
+
+    StgTSO *       threads;             // threads in this gen
+                                        // linked via global_link
+    StgWeak *      weak_ptr_list;       // weak pointers in this gen
+
+    struct generation_ *to;             // destination gen for live objects
+
+    // stats information
+    uint32_t collections;
+    uint32_t par_collections;
+    uint32_t failed_promotions;         // Currently unused
+
+    // ------------------------------------
+    // Fields below are used during GC only
+
+#if defined(THREADED_RTS)
+    char pad[128];                      // make sure the following is
+                                        // on a separate cache line.
+    SpinLock     sync;                  // lock for large_objects
+                                        //    and scavenged_large_objects
+#endif
+
+    int          mark;                  // mark (not copy)? (old gen only)
+    int          compact;               // compact (not sweep)? (old gen only)
+
+    // During GC, if we are collecting this gen, blocks and n_blocks
+    // are copied into the following two fields.  After GC, these blocks
+    // are freed.
+    bdescr *     old_blocks;            // bdescr of first from-space block
+    memcount     n_old_blocks;         // number of blocks in from-space
+    memcount     live_estimate;         // for sweeping: estimate of live data
+
+    bdescr *     scavenged_large_objects;  // live large objs after GC (d-link)
+    memcount     n_scavenged_large_blocks; // size (not count) of above
+
+    bdescr *     live_compact_objects;  // live compact objs after GC (d-link)
+    memcount     n_live_compact_blocks; // size (not count) of above
+
+    bdescr *     bitmap;                // bitmap for compacting collection
+
+    StgTSO *     old_threads;
+    StgWeak *    old_weak_ptr_list;
+} generation;
+
+extern generation * generations;
+extern generation * g0;
+extern generation * oldest_gen;
+
+/* -----------------------------------------------------------------------------
+   Generic allocation
+
+   StgPtr allocate(Capability *cap, W_ n)
+                                Allocates memory from the nursery in
+                                the current Capability.
+
+   StgPtr allocatePinned(Capability *cap, W_ n)
+                                Allocates a chunk of contiguous store
+                                n words long, which is at a fixed
+                                address (won't be moved by GC).
+                                Returns a pointer to the first word.
+                                Always succeeds.
+
+                                NOTE: the GC can't in general handle
+                                pinned objects, so allocatePinned()
+                                can only be used for ByteArrays at the
+                                moment.
+
+                                Don't forget to TICK_ALLOC_XXX(...)
+                                after calling allocate or
+                                allocatePinned, for the
+                                benefit of the ticky-ticky profiler.
+
+   -------------------------------------------------------------------------- */
+
+StgPtr  allocate          ( Capability *cap, W_ n );
+StgPtr  allocateMightFail ( Capability *cap, W_ n );
+StgPtr  allocatePinned    ( Capability *cap, W_ n );
+
+/* memory allocator for executable memory */
+typedef void* AdjustorWritable;
+typedef void* AdjustorExecutable;
+
+AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr);
+void flushExec(W_ len, AdjustorExecutable exec_addr);
+#if defined(ios_HOST_OS)
+AdjustorWritable execToWritable(AdjustorExecutable exec);
+#endif
+void             freeExec (AdjustorExecutable p);
+
+// Used by GC checks in external .cmm code:
+extern W_ large_alloc_lim;
+
+/* -----------------------------------------------------------------------------
+   Performing Garbage Collection
+   -------------------------------------------------------------------------- */
+
+void performGC(void);
+void performMajorGC(void);
+
+/* -----------------------------------------------------------------------------
+   The CAF table - used to let us revert CAFs in GHCi
+   -------------------------------------------------------------------------- */
+
+StgInd *newCAF         (StgRegTable *reg, StgIndStatic *caf);
+StgInd *newRetainedCAF (StgRegTable *reg, StgIndStatic *caf);
+StgInd *newGCdCAF      (StgRegTable *reg, StgIndStatic *caf);
+void revertCAFs (void);
+
+// Request that all CAFs are retained indefinitely.
+// (preferably use RtsConfig.keep_cafs instead)
+void setKeepCAFs (void);
+
+/* -----------------------------------------------------------------------------
+   This is the write barrier for MUT_VARs, a.k.a. IORefs.  A
+   MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
+   is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
+   and is put on the mutable list.
+   -------------------------------------------------------------------------- */
+
+void dirty_MUT_VAR(StgRegTable *reg, StgClosure *p);
+
+/* set to disable CAF garbage collection in GHCi. */
+/* (needed when dynamic libraries are used). */
+extern bool keepCAFs;
+
+INLINE_HEADER void initBdescr(bdescr *bd, generation *gen, generation *dest)
+{
+    bd->gen     = gen;
+    bd->gen_no  = gen->no;
+    bd->dest_no = dest->no;
+}
diff --git a/includes/rts/storage/Heap.h b/includes/rts/storage/Heap.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/Heap.h
@@ -0,0 +1,18 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2006-2017
+ *
+ * Introspection into GHC's heap representation
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "rts/storage/Closures.h"
+
+StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);
+
+void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
+                        , StgClosure *fun, StgClosure **payload, StgWord size);
+
+StgWord heap_view_closureSize(StgClosure *closure);
diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/InfoTables.h
@@ -0,0 +1,405 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2002
+ *
+ * Info Tables
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* ----------------------------------------------------------------------------
+   Relative pointers
+
+   Several pointer fields in info tables are expressed as offsets
+   relative to the info pointer, so that we can generate
+   position-independent code.
+
+   Note [x86-64-relative]
+   There is a complication on the x86_64 platform, where pointers are
+   64 bits, but the tools don't support 64-bit relative relocations.
+   However, the default memory model (small) ensures that all symbols
+   have values in the lower 2Gb of the address space, so offsets all
+   fit in 32 bits.  Hence we can use 32-bit offset fields.
+
+   Somewhere between binutils-2.16.1 and binutils-2.16.91.0.6,
+   support for 64-bit PC-relative relocations was added, so maybe this
+   hackery can go away sometime.
+   ------------------------------------------------------------------------- */
+
+#if defined(x86_64_TARGET_ARCH)
+#define OFFSET_FIELD(n) StgHalfInt n; StgHalfWord __pad_##n
+#else
+#define OFFSET_FIELD(n) StgInt n
+#endif
+
+/* -----------------------------------------------------------------------------
+   Profiling info
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+#if !defined(TABLES_NEXT_TO_CODE)
+    char *closure_type;
+    char *closure_desc;
+#else
+    OFFSET_FIELD(closure_type_off);
+    OFFSET_FIELD(closure_desc_off);
+#endif
+} StgProfInfo;
+
+/* -----------------------------------------------------------------------------
+   Closure flags
+   -------------------------------------------------------------------------- */
+
+/* The type flags provide quick access to certain properties of a closure. */
+
+#define _HNF (1<<0)  /* head normal form?    */
+#define _BTM (1<<1)  /* uses info->layout.bitmap */
+#define _NS  (1<<2)  /* non-sparkable        */
+#define _THU (1<<3)  /* thunk?               */
+#define _MUT (1<<4)  /* mutable?             */
+#define _UPT (1<<5)  /* unpointed?           */
+#define _SRT (1<<6)  /* has an SRT?          */
+#define _IND (1<<7)  /* is an indirection?   */
+
+#define isMUTABLE(flags)   ((flags) &_MUT)
+#define isBITMAP(flags)    ((flags) &_BTM)
+#define isTHUNK(flags)     ((flags) &_THU)
+#define isUNPOINTED(flags) ((flags) &_UPT)
+#define hasSRT(flags)      ((flags) &_SRT)
+
+extern StgWord16 closure_flags[];
+
+#define closureFlags(c)         (closure_flags[get_itbl \
+                                    (UNTAG_CONST_CLOSURE(c))->type])
+
+#define closure_HNF(c)          (  closureFlags(c) & _HNF)
+#define closure_BITMAP(c)       (  closureFlags(c) & _BTM)
+#define closure_NON_SPARK(c)    ( (closureFlags(c) & _NS))
+#define closure_SHOULD_SPARK(c) (!(closureFlags(c) & _NS))
+#define closure_THUNK(c)        (  closureFlags(c) & _THU)
+#define closure_MUTABLE(c)      (  closureFlags(c) & _MUT)
+#define closure_UNPOINTED(c)    (  closureFlags(c) & _UPT)
+#define closure_SRT(c)          (  closureFlags(c) & _SRT)
+#define closure_IND(c)          (  closureFlags(c) & _IND)
+
+/* same as above but for info-ptr rather than closure */
+#define ipFlags(ip)             (closure_flags[ip->type])
+
+#define ip_HNF(ip)               (  ipFlags(ip) & _HNF)
+#define ip_BITMAP(ip)            (  ipFlags(ip) & _BTM)
+#define ip_SHOULD_SPARK(ip)      (!(ipFlags(ip) & _NS))
+#define ip_THUNK(ip)             (  ipFlags(ip) & _THU)
+#define ip_MUTABLE(ip)           (  ipFlags(ip) & _MUT)
+#define ip_UNPOINTED(ip)         (  ipFlags(ip) & _UPT)
+#define ip_SRT(ip)               (  ipFlags(ip) & _SRT)
+#define ip_IND(ip)               (  ipFlags(ip) & _IND)
+
+/* -----------------------------------------------------------------------------
+   Bitmaps
+
+   These are used to describe the pointerhood of a sequence of words
+   (usually on the stack) to the garbage collector.  The two primary
+   uses are for stack frames, and functions (where we need to describe
+   the layout of a PAP to the GC).
+
+   In these bitmaps: 0 == ptr, 1 == non-ptr.
+   -------------------------------------------------------------------------- */
+
+/*
+ * Small bitmaps:  for a small bitmap, we store the size and bitmap in
+ * the same word, using the following macros.  If the bitmap doesn't
+ * fit in a single word, we use a pointer to an StgLargeBitmap below.
+ */
+#define MK_SMALL_BITMAP(size,bits) (((bits)<<BITMAP_BITS_SHIFT) | (size))
+
+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
+
+/*
+ * A large bitmap.
+ */
+typedef struct {
+  StgWord size;
+  StgWord bitmap[];
+} StgLargeBitmap;
+
+/* ----------------------------------------------------------------------------
+   Info Tables
+   ------------------------------------------------------------------------- */
+
+/*
+ * Stuff describing the closure layout.  Well, actually, it might
+ * contain the selector index for a THUNK_SELECTOR.  This union is one
+ * word long.
+ */
+typedef union {
+    struct {                    /* Heap closure payload layout: */
+        StgHalfWord ptrs;       /* number of pointers */
+        StgHalfWord nptrs;      /* number of non-pointers */
+    } payload;
+
+    StgWord bitmap;               /* word-sized bit pattern describing */
+                                  /*  a stack frame: see below */
+
+#if !defined(TABLES_NEXT_TO_CODE)
+    StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */
+#else
+    OFFSET_FIELD(large_bitmap_offset);  /* offset from info table to large bitmap structure */
+#endif
+
+    StgWord selector_offset;      /* used in THUNK_SELECTORs */
+
+} StgClosureInfo;
+
+
+#if defined(x86_64_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)
+// On x86_64 we can fit a pointer offset in half a word, so put the SRT offset
+// in the info->srt field directly.
+//
+// See the section "Referring to an SRT from the info table" in
+// Note [SRTs] in CmmBuildInfoTables.hs
+#define USE_INLINE_SRT_FIELD
+#endif
+
+#if defined(USE_INLINE_SRT_FIELD)
+// offset to the SRT / closure, or zero if there's no SRT
+typedef StgHalfInt StgSRTField;
+#else
+// non-zero if there is an SRT, the offset is in the optional srt field.
+typedef StgHalfWord StgSRTField;
+#endif
+
+
+/*
+ * The "standard" part of an info table.  Every info table has this bit.
+ */
+typedef struct StgInfoTable_ {
+
+#if !defined(TABLES_NEXT_TO_CODE)
+    StgFunPtr       entry;      /* pointer to the entry code */
+#endif
+
+#if defined(PROFILING)
+    StgProfInfo     prof;
+#endif
+
+    StgClosureInfo  layout;     /* closure layout info (one word) */
+
+    StgHalfWord     type;       /* closure type */
+    StgSRTField     srt;
+       /* In a CONSTR:
+            - the zero-based constructor tag
+          In a FUN/THUNK
+            - if USE_INLINE_SRT_FIELD
+              - offset to the SRT (or zero if no SRT)
+            - otherwise
+              - non-zero if there is an SRT, offset is in srt_offset
+       */
+
+#if defined(TABLES_NEXT_TO_CODE)
+    StgCode         code[];
+#endif
+} *StgInfoTablePtr; // StgInfoTable defined in rts/Types.h
+
+
+/* -----------------------------------------------------------------------------
+   Function info tables
+
+   This is the general form of function info tables.  The compiler
+   will omit some of the fields in common cases:
+
+   -  If fun_type is not ARG_GEN or ARG_GEN_BIG, then the slow_apply
+      and bitmap fields may be left out (they are at the end, so omitting
+      them doesn't affect the layout).
+
+   -  If has_srt (in the std info table part) is zero, then the srt
+      field needn't be set.  This only applies if the slow_apply and
+      bitmap fields have also been omitted.
+   -------------------------------------------------------------------------- */
+
+/*
+   Note [Encoding static reference tables]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+   As static reference tables appear frequently in code, we use a special
+   compact encoding for the common case of a module defining only a few CAFs: We
+   produce one table containing a list of CAFs in the module and then include a
+   bitmap in each info table describing which entries of this table the closure
+   references.
+ */
+
+typedef struct StgFunInfoExtraRev_ {
+    OFFSET_FIELD(slow_apply_offset); /* apply to args on the stack */
+    union {
+        StgWord bitmap;
+        OFFSET_FIELD(bitmap_offset);    /* arg ptr/nonptr bitmap */
+    } b;
+#if !defined(USE_INLINE_SRT_FIELD)
+    OFFSET_FIELD(srt_offset);   /* pointer to the SRT closure */
+#endif
+    StgHalfWord    fun_type;    /* function type */
+    StgHalfWord    arity;       /* function arity */
+} StgFunInfoExtraRev;
+
+typedef struct StgFunInfoExtraFwd_ {
+    StgHalfWord    fun_type;    /* function type */
+    StgHalfWord    arity;       /* function arity */
+    StgClosure    *srt;         /* pointer to the SRT closure */
+    union { /* union for compat. with TABLES_NEXT_TO_CODE version */
+        StgWord        bitmap;  /* arg ptr/nonptr bitmap */
+    } b;
+    StgFun         *slow_apply; /* apply to args on the stack */
+} StgFunInfoExtraFwd;
+
+typedef struct {
+#if defined(TABLES_NEXT_TO_CODE)
+    StgFunInfoExtraRev f;
+    StgInfoTable i;
+#else
+    StgInfoTable i;
+    StgFunInfoExtraFwd f;
+#endif
+} StgFunInfoTable;
+
+// canned bitmap for each arg type, indexed by constants in FunTypes.h
+extern const StgWord stg_arg_bitmaps[];
+
+/* -----------------------------------------------------------------------------
+   Return info tables
+   -------------------------------------------------------------------------- */
+
+/*
+ * When info tables are laid out backwards, we can omit the SRT
+ * pointer iff has_srt is zero.
+ */
+
+typedef struct {
+#if defined(TABLES_NEXT_TO_CODE)
+#if !defined(USE_INLINE_SRT_FIELD)
+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */
+#endif
+    StgInfoTable i;
+#else
+    StgInfoTable i;
+    StgClosure  *srt;           /* pointer to the SRT closure */
+#endif
+} StgRetInfoTable;
+
+/* -----------------------------------------------------------------------------
+   Thunk info tables
+   -------------------------------------------------------------------------- */
+
+/*
+ * When info tables are laid out backwards, we can omit the SRT
+ * pointer iff has_srt is zero.
+ */
+
+typedef struct StgThunkInfoTable_ {
+#if defined(TABLES_NEXT_TO_CODE)
+#if !defined(USE_INLINE_SRT_FIELD)
+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */
+#endif
+    StgInfoTable i;
+#else
+    StgInfoTable i;
+    StgClosure  *srt;           /* pointer to the SRT closure */
+#endif
+} StgThunkInfoTable;
+
+/* -----------------------------------------------------------------------------
+   Constructor info tables
+   -------------------------------------------------------------------------- */
+
+typedef struct StgConInfoTable_ {
+#if !defined(TABLES_NEXT_TO_CODE)
+    StgInfoTable i;
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+    OFFSET_FIELD(con_desc); // the name of the data constructor
+                            // as: Package:Module.Name
+#else
+    char *con_desc;
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+    StgInfoTable i;
+#endif
+} StgConInfoTable;
+
+
+/* -----------------------------------------------------------------------------
+   Accessor macros for fields that might be offsets (C version)
+   -------------------------------------------------------------------------- */
+
+/*
+ * GET_SRT(info)
+ * info must be a Stg[Ret|Thunk]InfoTable* (an info table that has a SRT)
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#if defined(x86_64_TARGET_ARCH)
+#define GET_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))
+#else
+#define GET_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->srt_offset))
+#endif
+#else // !TABLES_NEXT_TO_CODE
+#define GET_SRT(info) ((info)->srt)
+#endif
+
+/*
+ * GET_CON_DESC(info)
+ * info must be a StgConInfoTable*.
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_CON_DESC(info) \
+            ((const char *)((StgWord)((info)+1) + (info->con_desc)))
+#else
+#define GET_CON_DESC(info) ((const char *)(info)->con_desc)
+#endif
+
+/*
+ * GET_FUN_SRT(info)
+ * info must be a StgFunInfoTable*
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#if defined(x86_64_TARGET_ARCH)
+#define GET_FUN_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))
+#else
+#define GET_FUN_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))
+#endif
+#else
+#define GET_FUN_SRT(info) ((info)->f.srt)
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+                                        + (info)->layout.large_bitmap_offset))
+#else
+#define GET_LARGE_BITMAP(info) ((info)->layout.large_bitmap)
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+                                        + (info)->f.b.bitmap_offset))
+#else
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) ((info)->f.b.bitmap))
+#endif
+
+/*
+ * GET_PROF_TYPE, GET_PROF_DESC
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_PROF_TYPE(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_type_off)))
+#else
+#define GET_PROF_TYPE(info) ((info)->prof.closure_type)
+#endif
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_PROF_DESC(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_desc_off)))
+#else
+#define GET_PROF_DESC(info) ((info)->prof.closure_desc)
+#endif
diff --git a/includes/rts/storage/MBlock.h b/includes/rts/storage/MBlock.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/MBlock.h
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2008
+ *
+ * MegaBlock Allocator interface.
+ *
+ * See wiki commentary at
+ *  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/heap-alloced
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+extern W_ peak_mblocks_allocated;
+extern W_ mblocks_allocated;
+
+extern void initMBlocks(void);
+extern void * getMBlock(void);
+extern void * getMBlocks(uint32_t n);
+extern void * getMBlockOnNode(uint32_t node);
+extern void * getMBlocksOnNode(uint32_t node, uint32_t n);
+extern void freeMBlocks(void *addr, uint32_t n);
+extern void releaseFreeMemory(void);
+extern void freeAllMBlocks(void);
+
+extern void *getFirstMBlock(void **state);
+extern void *getNextMBlock(void **state, void *mblock);
+
+#if defined(THREADED_RTS)
+// needed for HEAP_ALLOCED below
+extern SpinLock gc_alloc_block_sync;
+#endif
diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/TSO.h
@@ -0,0 +1,261 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * The definitions for Thread State Objects.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/*
+ * PROFILING info in a TSO
+ */
+typedef struct {
+  CostCentreStack *cccs;       /* thread's current CCS */
+} StgTSOProfInfo;
+
+/*
+ * There is no TICKY info in a TSO at this time.
+ */
+
+/*
+ * Thread IDs are 32 bits.
+ */
+typedef StgWord32 StgThreadID;
+
+#define tsoLocked(tso) ((tso)->flags & TSO_LOCKED)
+
+/*
+ * Type returned after running a thread.  Values of this type
+ * include HeapOverflow, StackOverflow etc.  See Constants.h for the
+ * full list.
+ */
+typedef unsigned int StgThreadReturnCode;
+
+#if defined(mingw32_HOST_OS)
+/* results from an async I/O request + its request ID. */
+typedef struct {
+  unsigned int reqID;
+  int          len;
+  int          errCode;
+} StgAsyncIOResult;
+#endif
+
+/* Reason for thread being blocked. See comment above struct StgTso_. */
+typedef union {
+  StgClosure *closure;
+  StgTSO *prev; // a back-link when the TSO is on the run queue (NotBlocked)
+  struct MessageBlackHole_ *bh;
+  struct MessageThrowTo_ *throwto;
+  struct MessageWakeup_  *wakeup;
+  StgInt fd;    /* StgInt instead of int, so that it's the same size as the ptrs */
+#if defined(mingw32_HOST_OS)
+  StgAsyncIOResult *async_result;
+#endif
+#if !defined(THREADED_RTS)
+  StgWord target;
+    // Only for the non-threaded RTS: the target time for a thread
+    // blocked in threadDelay, in units of 1ms.  This is a
+    // compromise: we don't want to take up much space in the TSO.  If
+    // you want better resolution for threadDelay, use -threaded.
+#endif
+} StgTSOBlockInfo;
+
+
+/*
+ * TSOs live on the heap, and therefore look just like heap objects.
+ * Large TSOs will live in their own "block group" allocated by the
+ * storage manager, and won't be copied during garbage collection.
+ */
+
+/*
+ * Threads may be blocked for several reasons.  A blocked thread will
+ * have the reason in the why_blocked field of the TSO, and some
+ * further info (such as the closure the thread is blocked on, or the
+ * file descriptor if the thread is waiting on I/O) in the block_info
+ * field.
+ */
+
+typedef struct StgTSO_ {
+    StgHeader               header;
+
+    /* The link field, for linking threads together in lists (e.g. the
+       run queue on a Capability.
+    */
+    struct StgTSO_*         _link;
+    /*
+      Currently used for linking TSOs on:
+      * cap->run_queue_{hd,tl}
+      * (non-THREADED_RTS); the blocked_queue
+      * and pointing to the next chunk for a ThreadOldStack
+
+       NOTE!!!  do not modify _link directly, it is subject to
+       a write barrier for generational GC.  Instead use the
+       setTSOLink() function.  Exceptions to this rule are:
+
+       * setting the link field to END_TSO_QUEUE
+       * setting the link field of the currently running TSO, as it
+         will already be dirty.
+    */
+
+    struct StgTSO_*         global_link;    // Links threads on the
+                                            // generation->threads lists
+
+    /*
+     * The thread's stack
+     */
+    struct StgStack_       *stackobj;
+
+    /*
+     * The tso->dirty flag indicates that this TSO's stack should be
+     * scanned during garbage collection.  It also indicates that this
+     * TSO is on the mutable list.
+     *
+     * NB. The dirty flag gets a word to itself, so that it can be set
+     * safely by multiple threads simultaneously (the flags field is
+     * not safe for this purpose; see #3429).  It is harmless for the
+     * TSO to be on the mutable list multiple times.
+     *
+     * tso->dirty is set by dirty_TSO(), and unset by the garbage
+     * collector (only).
+     */
+
+    StgWord16               what_next;      // Values defined in Constants.h
+    StgWord16               why_blocked;    // Values defined in Constants.h
+    StgWord32               flags;          // Values defined in Constants.h
+    StgTSOBlockInfo         block_info;
+    StgThreadID             id;
+    StgWord32               saved_errno;
+    StgWord32               dirty;          /* non-zero => dirty */
+    struct InCall_*         bound;
+    struct Capability_*     cap;
+
+    struct StgTRecHeader_ * trec;       /* STM transaction record */
+
+    /*
+     * A list of threads blocked on this TSO waiting to throw exceptions.
+    */
+    struct MessageThrowTo_ * blocked_exceptions;
+
+    /*
+     * A list of StgBlockingQueue objects, representing threads
+     * blocked on thunks that are under evaluation by this thread.
+    */
+    struct StgBlockingQueue_ *bq;
+
+    /*
+     * The allocation limit for this thread, which is updated as the
+     * thread allocates.  If the value drops below zero, and
+     * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
+     * thread, and give the thread a little more space to handle the
+     * exception before we raise the exception again.
+     *
+     * This is an integer, because we might update it in a place where
+     * it isn't convenient to raise the exception, so we want it to
+     * stay negative until we get around to checking it.
+     *
+     * Use only PK_Int64/ASSIGN_Int64 macros to get/set the value of alloc_limit
+     * in C code otherwise you will cause alignment issues on SPARC
+     */
+    StgInt64  alloc_limit;     /* in bytes */
+
+    /*
+     * sum of the sizes of all stack chunks (in words), used to decide
+     * whether to throw the StackOverflow exception when the stack
+     * overflows, or whether to just chain on another stack chunk.
+     *
+     * Note that this overestimates the real stack size, because each
+     * chunk will have a gap at the end, of +RTS -kb<size> words.
+     * This means stack overflows are not entirely accurate, because
+     * the more gaps there are, the sooner the stack will run into the
+     * hard +RTS -K<size> limit.
+     */
+    StgWord32  tot_stack_size;
+
+#if defined(TICKY_TICKY)
+    /* TICKY-specific stuff would go here. */
+#endif
+#if defined(PROFILING)
+    StgTSOProfInfo prof;
+#endif
+#if defined(mingw32_HOST_OS)
+    StgWord32 saved_winerror;
+#endif
+
+} *StgTSOPtr; // StgTSO defined in rts/Types.h
+
+typedef struct StgStack_ {
+    StgHeader  header;
+    StgWord32  stack_size;     // stack size in *words*
+    StgWord32  dirty;          // non-zero => dirty
+    StgPtr     sp;             // current stack pointer
+    StgWord    stack[];
+} StgStack;
+
+// Calculate SpLim from a TSO (reads tso->stackobj, but no fields from
+// the stackobj itself).
+INLINE_HEADER StgPtr tso_SpLim (StgTSO* tso)
+{
+    return tso->stackobj->stack + RESERVED_STACK_WORDS;
+}
+
+/* -----------------------------------------------------------------------------
+   functions
+   -------------------------------------------------------------------------- */
+
+void dirty_TSO  (Capability *cap, StgTSO *tso);
+void setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target);
+void setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target);
+
+void dirty_STACK (Capability *cap, StgStack *stack);
+
+/* -----------------------------------------------------------------------------
+   Invariants:
+
+   An active thread has the following properties:
+
+      tso->stack < tso->sp < tso->stack+tso->stack_size
+      tso->stack_size <= tso->max_stack_size
+
+      RESERVED_STACK_WORDS is large enough for any heap-check or
+      stack-check failure.
+
+      The size of the TSO struct plus the stack is either
+        (a) smaller than a block, or
+        (b) a multiple of BLOCK_SIZE
+
+        tso->why_blocked       tso->block_info      location
+        ----------------------------------------------------------------------
+        NotBlocked             END_TSO_QUEUE        runnable_queue, or running
+
+        BlockedOnBlackHole     MessageBlackHole *   TSO->bq
+
+        BlockedOnMVar          the MVAR             the MVAR's queue
+
+        BlockedOnSTM           END_TSO_QUEUE        STM wait queue(s)
+        BlockedOnSTM           STM_AWOKEN           run queue
+
+        BlockedOnMsgThrowTo    MessageThrowTo *     TSO->blocked_exception
+
+        BlockedOnRead          NULL                 blocked_queue
+        BlockedOnWrite         NULL                 blocked_queue
+        BlockedOnDelay         NULL                 blocked_queue
+
+      tso->link == END_TSO_QUEUE, if the thread is currently running.
+
+   A zombie thread has the following properties:
+
+      tso->what_next == ThreadComplete or ThreadKilled
+      tso->link     ==  (could be on some queue somewhere)
+      tso->sp       ==  tso->stack + tso->stack_size - 1 (i.e. top stack word)
+      tso->sp[0]    ==  return value of thread, if what_next == ThreadComplete,
+                        exception             , if what_next == ThreadKilled
+
+      (tso->sp is left pointing at the top word on the stack so that
+      the return value or exception will be retained by a GC).
+
+ ---------------------------------------------------------------------------- */
+
+/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
+#define END_TSO_QUEUE  ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
diff --git a/libraries/ghc-boot/GHC/HandleEncoding.hs b/libraries/ghc-boot/GHC/HandleEncoding.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghc-boot/GHC/HandleEncoding.hs
@@ -0,0 +1,32 @@
+-- | See GHC #10762 and #15021.
+module GHC.HandleEncoding (configureHandleEncoding) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import GHC.IO.Encoding (textEncodingName)
+import System.Environment
+import System.IO
+
+-- | Handle GHC-specific character encoding flags, allowing us to control how
+-- GHC produces output regardless of OS.
+configureHandleEncoding :: IO ()
+configureHandleEncoding = do
+   env <- getEnvironment
+   case lookup "GHC_CHARENC" env of
+    Just "UTF-8" -> do
+     hSetEncoding stdout utf8
+     hSetEncoding stderr utf8
+    _ -> do
+     -- Avoid GHC erroring out when trying to display unhandled characters
+     hSetTranslit stdout
+     hSetTranslit stderr
+
+-- | Change the character encoding of the given Handle to transliterate
+-- on unsupported characters instead of throwing an exception
+hSetTranslit :: Handle -> IO ()
+hSetTranslit h = do
+    menc <- hGetEncoding h
+    case fmap textEncodingName menc of
+        Just name | '/' `notElem` name -> do
+            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
+            hSetEncoding h enc'
+        _ -> return ()
diff --git a/libraries/ghci/GHCi/BinaryArray.hs b/libraries/ghci/GHCi/BinaryArray.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/BinaryArray.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}
+-- | Efficient serialisation for GHCi Instruction arrays
+--
+-- Author: Ben Gamari
+--
+module GHCi.BinaryArray(putArray, getArray) where
+
+import Prelude
+import Foreign.Ptr
+import Data.Binary
+import Data.Binary.Put (putBuilder)
+import qualified Data.Binary.Get.Internal as Binary
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Builder.Internal as BB
+import qualified Data.Array.Base as A
+import qualified Data.Array.IO.Internals as A
+import qualified Data.Array.Unboxed as A
+import GHC.Exts
+import GHC.IO
+
+-- | An efficient serialiser of 'A.UArray'.
+putArray :: Binary i => A.UArray i a -> Put
+putArray (A.UArray l u _ arr#) = do
+    put l
+    put u
+    putBuilder $ byteArrayBuilder arr#
+
+byteArrayBuilder :: ByteArray# -> BB.Builder
+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
+  where
+    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
+    go !inStart !inEnd k (BB.BufferRange outStart outEnd)
+      -- There is enough room in this output buffer to write all remaining array
+      -- contents
+      | inRemaining <= outRemaining = do
+          copyByteArrayToAddr arr# inStart outStart inRemaining
+          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
+      -- There is only enough space for a fraction of the remaining contents
+      | otherwise = do
+          copyByteArrayToAddr arr# inStart outStart outRemaining
+          let !inStart' = inStart + outRemaining
+          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
+      where
+        inRemaining  = inEnd - inStart
+        outRemaining = outEnd `minusPtr` outStart
+
+    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
+    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
+        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
+                     s' -> (# s', () #)
+
+-- | An efficient deserialiser of 'A.UArray'.
+getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)
+getArray = do
+    l <- get
+    u <- get
+    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-
+        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)
+    let go 0 _ = return ()
+        go !remaining !off = do
+            Binary.readNWith n $ \ptr ->
+              copyAddrToByteArray ptr arr# off n
+            go (remaining - n) (off + n)
+          where n = min chunkSize remaining
+    go (I# (sizeofMutableByteArray# arr#)) 0
+    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr
+  where
+    chunkSize = 10*1024
+
+    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
+                        -> Int -> Int -> IO ()
+    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
+        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
+                     s' -> (# s', () #)
+
+-- this is inexplicably not exported in currently released array versions
+unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)
+unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/CreateBCO.hs
@@ -0,0 +1,163 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RecordWildCards #-}
+
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | Create real byte-code objects from 'ResolvedBCO's.
+module GHCi.CreateBCO (createBCOs) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import GHCi.ResolvedBCO
+import GHCi.RemoteTypes
+import GHCi.BreakArray
+import SizedSeq
+
+import System.IO (fixIO)
+import Control.Monad
+import Data.Array.Base
+import Foreign hiding (newArray)
+import GHC.Arr          ( Array(..) )
+import GHC.Exts
+import GHC.IO
+import Control.Exception ( ErrorCall(..) )
+
+createBCOs :: [ResolvedBCO] -> IO [HValueRef]
+createBCOs bcos = do
+  let n_bcos = length bcos
+  hvals <- fixIO $ \hvs -> do
+     let arr = listArray (0, n_bcos-1) hvs
+     mapM (createBCO arr) bcos
+  mapM mkRemoteRef hvals
+
+createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
+createBCO _   ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
+  = throwIO (ErrorCall $
+        unlines [ "The endianness of the ResolvedBCO does not match"
+                , "the systems endianness. Using ghc and iserv in a"
+                , "mixed endianness setup is not supported!"
+                ])
+createBCO arr bco
+   = do BCO bco# <- linkBCO' arr bco
+        -- Why do we need mkApUpd0 here?  Otherwise top-level
+        -- interpreted CAFs don't get updated after evaluation.  A
+        -- top-level BCO will evaluate itself and return its value
+        -- when entered, but it won't update itself.  Wrapping the BCO
+        -- in an AP_UPD thunk will take care of the update for us.
+        --
+        -- Furthermore:
+        --   (a) An AP thunk *must* point directly to a BCO
+        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
+        --   (c) An AP is always fully saturated, so we *can't* wrap
+        --       non-zero arity BCOs in an AP thunk.
+        --
+        if (resolvedBCOArity bco > 0)
+           then return (HValue (unsafeCoerce# bco#))
+           else case mkApUpd0# bco# of { (# final_bco #) ->
+                  return (HValue final_bco) }
+
+
+toWordArray :: UArray Int Word64 -> UArray Int Word
+toWordArray = amap fromIntegral
+
+linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
+linkBCO' arr ResolvedBCO{..} = do
+  let
+      ptrs   = ssElts resolvedBCOPtrs
+      n_ptrs = sizeSS resolvedBCOPtrs
+
+      !(I# arity#)  = resolvedBCOArity
+
+      !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
+
+      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
+      insns_barr = barr resolvedBCOInstrs
+      bitmap_barr = barr (toWordArray resolvedBCOBitmap)
+      literals_barr = barr (toWordArray resolvedBCOLits)
+
+  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
+  IO $ \s ->
+    case unsafeFreezeArray# marr s of { (# s, arr #) ->
+    case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
+    io s
+    }}
+
+
+-- we recursively link any sub-BCOs while making the ptrs array
+mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
+mkPtrsArray arr n_ptrs ptrs = do
+  marr <- newPtrsArray (fromIntegral n_ptrs)
+  let
+    fill (ResolvedBCORef n) i =
+      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
+    fill (ResolvedBCOPtr r) i = do
+      hv <- localRef r
+      writePtrsArrayHValue i hv marr
+    fill (ResolvedBCOStaticPtr r) i = do
+      writePtrsArrayPtr i (fromRemotePtr r)  marr
+    fill (ResolvedBCOPtrBCO bco) i = do
+      BCO bco# <- linkBCO' arr bco
+      writePtrsArrayBCO i bco# marr
+    fill (ResolvedBCOPtrBreakArray r) i = do
+      BA mba <- localRef r
+      writePtrsArrayMBA i mba marr
+  zipWithM_ fill ptrs [0..]
+  return marr
+
+data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
+
+newPtrsArray :: Int -> IO PtrsArr
+newPtrsArray (I# i) = IO $ \s ->
+  case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)
+
+writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
+writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->
+  case writeArray# arr i hv s of s' -> (# s', () #)
+
+writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
+writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
+  case writeArrayAddr# arr i a# s of s' -> (# s', () #)
+
+-- This is rather delicate: convincing GHC to pass an Addr# as an Any but
+-- without making a thunk turns out to be surprisingly tricky.
+{-# NOINLINE writeArrayAddr# #-}
+writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
+writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
+
+writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()
+writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
+  case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
+
+data BCO = BCO BCO#
+
+writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
+writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
+  case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
+
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs arity bitmap = IO $ \s ->
+  case newBCO# instrs lits ptrs arity bitmap s of
+    (# s1, bco #) -> (# s1, BCO bco #)
+
+{- Note [BCO empty array]
+
+Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
+they are 2-word heap objects.  So let's make a single empty array and
+share it between all BCOs.
+-}
+
+data EmptyArr = EmptyArr ByteArray#
+
+{-# NOINLINE emptyArr #-}
+emptyArr :: EmptyArr
+emptyArr = unsafeDupablePerformIO $ IO $ \s ->
+  case newByteArray# 0# s of { (# s, arr #) ->
+  case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
+  (# s, EmptyArr farr #)
+  }}
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -0,0 +1,390 @@
+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
+
+-- Get definitions for the structs, constants & config etc.
+#include "Rts.h"
+
+-- |
+-- 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
+  (
+#ifdef GHCI
+    mkConInfoTable
+#endif
+  ) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+#ifdef GHCI
+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
+#endif
+
+ghciTablesNextToCode :: Bool
+#ifdef TABLES_NEXT_TO_CODE
+ghciTablesNextToCode = True
+#else
+ghciTablesNextToCode = False
+#endif
+
+#ifdef GHCI /* To end */
+-- 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 =
+#if defined(sparc_HOST_ARCH)
+       ArchSPARC
+#elif defined(powerpc_HOST_ARCH)
+       ArchPPC
+#elif defined(i386_HOST_ARCH)
+       ArchX86
+#elif defined(x86_64_HOST_ARCH)
+       ArchX86_64
+#elif defined(alpha_HOST_ARCH)
+       ArchAlpha
+#elif defined(arm_HOST_ARCH)
+       ArchARM
+#elif defined(aarch64_HOST_ARCH)
+       ArchARM64
+#elif defined(powerpc64_HOST_ARCH)
+       ArchPPC64
+#elif defined(powerpc64le_HOST_ARCH)
+       ArchPPC64LE
+#else
+#    if defined(TABLES_NEXT_TO_CODE)
+#        error Unimplemented architecture
+#    else
+       ArchUnknown
+#    endif
+#endif
+
+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
+#if defined(TABLES_NEXT_TO_CODE)
+  -- 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)
+  (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
+#else
+  -- Write the con_desc address after the end of the info table.
+  -- Use itblSize because CPP will not pick up PROFILING when calculating
+  -- the offset.
+  pokeByteOff wr_ptr itblSize (conDesc itbl)
+#endif
+  pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
+
+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)
+#if defined(TABLES_NEXT_TO_CODE)
+        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
+#else
+        return (castPtrToFunPtr ex_ptr)
+#endif
+
+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 = (#const SIZEOF_HSINT)
+
+conInfoTableSizeB :: Int
+conInfoTableSizeB = wORD_SIZE + itblSize
+#endif /* GHCI */
diff --git a/libraries/ghci/GHCi/ObjLink.hs b/libraries/ghci/GHCi/ObjLink.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/ObjLink.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- ---------------------------------------------------------------------------
+--      The dynamic linker for object code (.o .so .dll files)
+-- ---------------------------------------------------------------------------
+
+-- | Primarily, this module consists of an interface to the C-land
+-- dynamic linker.
+module GHCi.ObjLink
+  ( initObjLinker, ShouldRetainCAFs(..)
+  , loadDLL
+  , loadArchive
+  , loadObj
+  , unloadObj
+  , purgeObj
+  , lookupSymbol
+  , lookupClosure
+  , resolveObjs
+  , addLibrarySearchPath
+  , removeLibrarySearchPath
+  , findSystemLibrary
+  )  where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import GHCi.RemoteTypes
+import Control.Exception (throwIO, ErrorCall(..))
+import Control.Monad    ( when )
+import Foreign.C
+import Foreign.Marshal.Alloc ( free )
+import Foreign          ( nullPtr )
+import GHC.Exts
+import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
+import System.FilePath  ( dropExtension, normalise )
+
+
+
+
+-- ---------------------------------------------------------------------------
+-- RTS Linker Interface
+-- ---------------------------------------------------------------------------
+
+data ShouldRetainCAFs
+  = RetainCAFs
+    -- ^ Retain CAFs unconditionally in linked Haskell code.
+    -- Note that this prevents any code from being unloaded.
+    -- It should not be necessary unless you are GHCi or
+    -- hs-plugins, which needs to be able call any function
+    -- in the compiled code.
+  | DontRetainCAFs
+    -- ^ Do not retain CAFs.  Everything reachable from foreign
+    -- exports will be retained, due to the StablePtrs
+    -- created by the module initialisation code.  unloadObj
+    -- frees these StablePtrs, which will allow the CAFs to
+    -- be GC'd and the code to be removed.
+
+initObjLinker :: ShouldRetainCAFs -> IO ()
+initObjLinker RetainCAFs = c_initLinker_ 1
+initObjLinker _ = c_initLinker_ 0
+
+lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol str_in = do
+   let str = prefixUnderscore str_in
+   withCAString str $ \c_str -> do
+     addr <- c_lookupSymbol c_str
+     if addr == nullPtr
+        then return Nothing
+        else return (Just addr)
+
+lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure str = do
+  m <- lookupSymbol str
+  case m of
+    Nothing -> return Nothing
+    Just (Ptr addr) -> case addrToAny# addr of
+      (# a #) -> Just <$> mkRemoteRef (HValue a)
+
+prefixUnderscore :: String -> String
+prefixUnderscore
+ | cLeadingUnderscore = ('_':)
+ | otherwise          = id
+
+-- | loadDLL loads a dynamic library using the OS's native linker
+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
+-- an absolute pathname to the file, or a relative filename
+-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
+-- searches the standard locations for the appropriate library.
+--
+loadDLL :: String -> IO (Maybe String)
+-- Nothing      => success
+-- Just err_msg => failure
+loadDLL str0 = do
+  let
+     -- On Windows, addDLL takes a filename without an extension, because
+     -- it tries adding both .dll and .drv.  To keep things uniform in the
+     -- layers above, loadDLL always takes a filename with an extension, and
+     -- we drop it here on Windows only.
+     str | isWindowsHost = dropExtension str0
+         | otherwise     = str0
+  --
+  maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll
+  if maybe_errmsg == nullPtr
+        then return Nothing
+        else do str <- peekCString maybe_errmsg
+                free maybe_errmsg
+                return (Just str)
+
+loadArchive :: String -> IO ()
+loadArchive str = do
+   withFilePath str $ \c_str -> do
+     r <- c_loadArchive c_str
+     when (r == 0) (throwIO (ErrorCall ("loadArchive " ++ show str ++ ": failed")))
+
+loadObj :: String -> IO ()
+loadObj str = do
+   withFilePath str $ \c_str -> do
+     r <- c_loadObj c_str
+     when (r == 0) (throwIO (ErrorCall ("loadObj " ++ show str ++ ": failed")))
+
+-- | @unloadObj@ drops the given dynamic library from the symbol table
+-- as well as enables the library to be removed from memory during
+-- a future major GC.
+unloadObj :: String -> IO ()
+unloadObj str =
+   withFilePath str $ \c_str -> do
+     r <- c_unloadObj c_str
+     when (r == 0) (throwIO (ErrorCall ("unloadObj " ++ show str ++ ": failed")))
+
+-- | @purgeObj@ drops the symbols for the dynamic library from the symbol
+-- table. Unlike 'unloadObj', the library will not be dropped memory during
+-- a future major GC.
+purgeObj :: String -> IO ()
+purgeObj str =
+   withFilePath str $ \c_str -> do
+     r <- c_purgeObj c_str
+     when (r == 0) (throwIO (ErrorCall ("purgeObj " ++ show str ++ ": failed")))
+
+addLibrarySearchPath :: String -> IO (Ptr ())
+addLibrarySearchPath str =
+   withFilePath str c_addLibrarySearchPath
+
+removeLibrarySearchPath :: Ptr () -> IO Bool
+removeLibrarySearchPath = c_removeLibrarySearchPath
+
+findSystemLibrary :: String -> IO (Maybe String)
+findSystemLibrary str = do
+    result <- withFilePath str c_findSystemLibrary
+    case result == nullPtr of
+        True  -> return Nothing
+        False -> do path <- peekFilePath result
+                    free result
+                    return $ Just path
+
+resolveObjs :: IO Bool
+resolveObjs = do
+   r <- c_resolveObjs
+   return (r /= 0)
+
+-- ---------------------------------------------------------------------------
+-- Foreign declarations to RTS entry points which does the real work;
+-- ---------------------------------------------------------------------------
+
+foreign import ccall unsafe "addDLL"                  c_addDLL                  :: CFilePath -> IO CString
+foreign import ccall unsafe "initLinker_"             c_initLinker_             :: CInt -> IO ()
+foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)
+foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int
+foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int
+foreign import ccall unsafe "purgeObj"                c_purgeObj                :: CFilePath -> IO Int
+foreign import ccall unsafe "unloadObj"               c_unloadObj               :: CFilePath -> IO Int
+foreign import ccall unsafe "resolveObjs"             c_resolveObjs             :: IO Int
+foreign import ccall unsafe "addLibrarySearchPath"    c_addLibrarySearchPath    :: CFilePath -> IO (Ptr ())
+foreign import ccall unsafe "findSystemLibrary"       c_findSystemLibrary       :: CFilePath -> IO CFilePath
+foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool
+
+-- -----------------------------------------------------------------------------
+-- Configuration
+
+#include "ghcautoconf.h"
+
+cLeadingUnderscore :: Bool
+#if defined(LEADING_UNDERSCORE)
+cLeadingUnderscore = True
+#else
+cLeadingUnderscore = False
+#endif
+
+isWindowsHost :: Bool
+#if defined(mingw32_HOST_OS)
+isWindowsHost = True
+#else
+isWindowsHost = False
+#endif
diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/ResolvedBCO.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
+    BangPatterns, CPP #-}
+module GHCi.ResolvedBCO
+  ( ResolvedBCO(..)
+  , ResolvedBCOPtr(..)
+  , isLittleEndian
+  ) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import SizedSeq
+import GHCi.RemoteTypes
+import GHCi.BreakArray
+
+import Data.Array.Unboxed
+import Data.Binary
+import GHC.Generics
+import GHCi.BinaryArray
+
+
+#include "MachDeps.h"
+
+isLittleEndian :: Bool
+#if defined(WORDS_BIGENDIAN)
+isLittleEndian = True
+#else
+isLittleEndian = False
+#endif
+
+-- -----------------------------------------------------------------------------
+-- ResolvedBCO
+
+-- | A 'ResolvedBCO' is one in which all the 'Name' references have been
+-- resolved to actual addresses or 'RemoteHValues'.
+--
+-- Note, all arrays are zero-indexed (we assume this when
+-- serializing/deserializing)
+data ResolvedBCO
+   = ResolvedBCO {
+        resolvedBCOIsLE   :: Bool,
+        resolvedBCOArity  :: {-# UNPACK #-} !Int,
+        resolvedBCOInstrs :: UArray Int Word16,         -- insns
+        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap
+        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs
+        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs
+   }
+   deriving (Generic, Show)
+
+-- | The Binary instance for ResolvedBCOs.
+--
+-- Note, that we do encode the endianness, however there is no support for mixed
+-- endianness setups.  This is primarily to ensure that ghc and iserv share the
+-- same endianness.
+instance Binary ResolvedBCO where
+  put ResolvedBCO{..} = do
+    put resolvedBCOIsLE
+    put resolvedBCOArity
+    putArray resolvedBCOInstrs
+    putArray resolvedBCOBitmap
+    putArray resolvedBCOLits
+    put resolvedBCOPtrs
+  get = ResolvedBCO
+        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get
+
+data ResolvedBCOPtr
+  = ResolvedBCORef {-# UNPACK #-} !Int
+      -- ^ reference to the Nth BCO in the current set
+  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)
+      -- ^ reference to a previously created BCO
+  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())
+      -- ^ reference to a static ptr
+  | ResolvedBCOPtrBCO ResolvedBCO
+      -- ^ a nested BCO
+  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)
+      -- ^ Resolves to the MutableArray# inside the BreakArray
+  deriving (Generic, Show)
+
+instance Binary ResolvedBCOPtr
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/Run.hs
@@ -0,0 +1,366 @@
+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
+    UnboxedTuples #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+-- |
+-- Execute GHCi messages.
+--
+-- For details on Remote GHCi, see Note [Remote GHCi] in
+-- compiler/ghci/GHCi.hs.
+--
+module GHCi.Run
+  ( run, redirectInterrupts
+  ) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import GHCi.CreateBCO
+import GHCi.InfoTable
+import GHCi.FFI
+import GHCi.Message
+import GHCi.ObjLink
+import GHCi.RemoteTypes
+import GHCi.TH
+import GHCi.BreakArray
+import GHCi.StaticPtrTable
+
+import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.Binary
+import Data.Binary.Get
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Unsafe as B
+import GHC.Exts
+import GHC.Exts.Heap
+import GHC.Stack
+import Foreign hiding (void)
+import Foreign.C
+import GHC.Conc.Sync
+import GHC.IO hiding ( bracket )
+import System.Mem.Weak  ( deRefWeak )
+import Unsafe.Coerce
+
+-- -----------------------------------------------------------------------------
+-- Implement messages
+
+foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
+        -- Make it "safe", just in case
+
+run :: Message a -> IO a
+run m = case m of
+  InitLinker -> initObjLinker RetainCAFs
+  RtsRevertCAFs -> rts_revertCAFs
+  LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
+  LookupClosure str -> lookupClosure str
+  LoadDLL str -> loadDLL str
+  LoadArchive str -> loadArchive str
+  LoadObj str -> loadObj str
+  UnloadObj str -> unloadObj str
+  AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str
+  RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)
+  ResolveObjs -> resolveObjs
+  FindSystemLibrary str -> findSystemLibrary str
+  CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)
+  FreeHValueRefs rs -> mapM_ freeRemoteRef rs
+  AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr
+  EvalStmt opts r -> evalStmt opts r
+  ResumeStmt opts r -> resumeStmt opts r
+  AbandonStmt r -> abandonStmt r
+  EvalString r -> evalString r
+  EvalStringToString r s -> evalStringToString r s
+  EvalIO r -> evalIO r
+  MkCostCentres mod ccs -> mkCostCentres mod ccs
+  CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
+  NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
+  EnableBreakpoint ref ix b -> do
+    arr <- localRef ref
+    _ <- if b then setBreakOn arr ix else setBreakOff arr ix
+    return ()
+  BreakpointStatus ref ix -> do
+    arr <- localRef ref; r <- getBreak arr ix
+    case r of
+      Nothing -> return False
+      Just w -> return (w /= 0)
+  GetBreakpointVar ref ix -> do
+    aps <- localRef ref
+    mapM mkRemoteRef =<< getIdValFromApStack aps ix
+  MallocData bs -> mkString bs
+  MallocStrings bss -> mapM mkString0 bss
+  PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
+  FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
+  MkConInfoTable ptrs nptrs tag ptrtag desc ->
+    toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc
+  StartTH -> startTH
+  GetClosure ref -> do
+    clos <- getClosureData =<< localRef ref
+    mapM (\(Box x) -> mkRemoteRef (HValue x)) clos
+  Seq ref -> tryEval (void $ evaluate =<< localRef ref)
+  _other -> error "GHCi.Run.run"
+
+evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
+evalStmt opts expr = do
+  io <- mkIO expr
+  sandboxIO opts $ do
+    rs <- unsafeCoerce io :: IO [HValue]
+    mapM mkRemoteRef rs
+ where
+  mkIO (EvalThis href) = localRef href
+  mkIO (EvalApp l r) = do
+    l' <- mkIO l
+    r' <- mkIO r
+    return ((unsafeCoerce l' :: HValue -> HValue) r')
+
+evalIO :: HValueRef -> IO (EvalResult ())
+evalIO r = do
+  io <- localRef r
+  tryEval (unsafeCoerce io :: IO ())
+
+evalString :: HValueRef -> IO (EvalResult String)
+evalString r = do
+  io <- localRef r
+  tryEval $ do
+    r <- unsafeCoerce io :: IO String
+    evaluate (force r)
+
+evalStringToString :: HValueRef -> String -> IO (EvalResult String)
+evalStringToString r str = do
+  io <- localRef r
+  tryEval $ do
+    r <- (unsafeCoerce io :: String -> IO String) str
+    evaluate (force r)
+
+-- When running a computation, we redirect ^C exceptions to the running
+-- thread.  ToDo: we might want a way to continue even if the target
+-- thread doesn't die when it receives the exception... "this thread
+-- is not responding".
+--
+-- Careful here: there may be ^C exceptions flying around, so we start the new
+-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
+-- only while we execute the user's code.  We can't afford to lose the final
+-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
+
+sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)
+sandboxIO opts io = do
+  -- We are running in uninterruptibleMask
+  breakMVar <- newEmptyMVar
+  statusMVar <- newEmptyMVar
+  withBreakAction opts breakMVar statusMVar $ do
+    let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
+    if useSandboxThread opts
+       then do
+         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
+                                -- empty: can't block
+         redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
+       else
+          -- GLUT on OS X needs to run on the main thread. If you
+          -- try to use it from another thread then you just get a
+          -- white rectangle rendered. For this, or anything else
+          -- with such restrictions, you can turn the GHCi sandbox off
+          -- and things will be run in the main thread.
+          --
+          -- BUT, note that the debugging features (breakpoints,
+          -- tracing, etc.) need the expression to be running in a
+          -- separate thread, so debugging is only enabled when
+          -- using the sandbox.
+         runIt
+
+-- We want to turn ^C into a break when -fbreak-on-exception is on,
+-- but it's an async exception and we only break for sync exceptions.
+-- Idea: if we catch and re-throw it, then the re-throw will trigger
+-- a break.  Great - but we don't want to re-throw all exceptions, because
+-- then we'll get a double break for ordinary sync exceptions (you'd have
+-- to :continue twice, which looks strange).  So if the exception is
+-- not "Interrupted", we unset the exception flag before throwing.
+--
+rethrow :: EvalOpts -> IO a -> IO a
+rethrow EvalOpts{..} io =
+  catch io $ \se -> do
+    -- If -fbreak-on-error, we break unconditionally,
+    --  but with care of not breaking twice
+    if breakOnError && not breakOnException
+       then poke exceptionFlag 1
+       else case fromException se of
+               -- If it is a "UserInterrupt" exception, we allow
+               --  a possible break by way of -fbreak-on-exception
+               Just UserInterrupt -> return ()
+               -- In any other case, we don't want to break
+               _ -> poke exceptionFlag 0
+    throwIO se
+
+--
+-- While we're waiting for the sandbox thread to return a result, if
+-- the current thread receives an asynchronous exception we re-throw
+-- it at the sandbox thread and continue to wait.
+--
+-- This is for two reasons:
+--
+--  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
+--    computation to run its exception handlers before returning the
+--    exception result to the caller of runStmt.
+--
+--  * clients of the GHC API can terminate a runStmt in progress
+--    without knowing the ThreadId of the sandbox thread (#1381)
+--
+-- NB. use a weak pointer to the thread, so that the thread can still
+-- be considered deadlocked by the RTS and sent a BlockedIndefinitely
+-- exception.  A symptom of getting this wrong is that conc033(ghci)
+-- will hang.
+--
+redirectInterrupts :: ThreadId -> IO a -> IO a
+redirectInterrupts target wait = do
+  wtid <- mkWeakThreadId target
+  wait `catch` \e -> do
+     m <- deRefWeak wtid
+     case m of
+       Nothing -> wait
+       Just target -> do throwTo target (e :: SomeException); wait
+
+measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)
+measureAlloc io = do
+  setAllocationCounter maxBound
+  a <- io
+  ctr <- getAllocationCounter
+  let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr
+  return (EvalComplete allocs a)
+
+-- Exceptions can't be marshaled because they're dynamically typed, so
+-- everything becomes a String.
+tryEval :: IO a -> IO (EvalResult a)
+tryEval io = do
+  e <- try io
+  case e of
+    Left ex -> return (EvalException (toSerializableException ex))
+    Right a -> return (EvalSuccess a)
+
+-- This function sets up the interpreter for catching breakpoints, and
+-- resets everything when the computation has stopped running.  This
+-- is a not-very-good way to ensure that only the interactive
+-- evaluation should generate breakpoints.
+withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
+withBreakAction opts breakMVar statusMVar act
+ = bracket setBreakAction resetBreakAction (\_ -> act)
+ where
+   setBreakAction = do
+     stablePtr <- newStablePtr onBreak
+     poke breakPointIOAction stablePtr
+     when (breakOnException opts) $ poke exceptionFlag 1
+     when (singleStep opts) $ setStepFlag
+     return stablePtr
+        -- Breaking on exceptions is not enabled by default, since it
+        -- might be a bit surprising.  The exception flag is turned off
+        -- as soon as it is hit, or in resetBreakAction below.
+
+   onBreak :: BreakpointCallback
+   onBreak ix# uniq# is_exception apStack = do
+     tid <- myThreadId
+     let resume = ResumeContext
+           { resumeBreakMVar = breakMVar
+           , resumeStatusMVar = statusMVar
+           , resumeThreadId = tid }
+     resume_r <- mkRemoteRef resume
+     apStack_r <- mkRemoteRef apStack
+     ccs <- toRemotePtr <$> getCCSOf apStack
+     putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs
+     takeMVar breakMVar
+
+   resetBreakAction stablePtr = do
+     poke breakPointIOAction noBreakStablePtr
+     poke exceptionFlag 0
+     resetStepFlag
+     freeStablePtr stablePtr
+
+resumeStmt
+  :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])
+  -> IO (EvalStatus [HValueRef])
+resumeStmt opts hvref = do
+  ResumeContext{..} <- localRef hvref
+  withBreakAction opts resumeBreakMVar resumeStatusMVar $
+    mask_ $ do
+      putMVar resumeBreakMVar () -- this awakens the stopped thread...
+      redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
+
+-- when abandoning a computation we have to
+--      (a) kill the thread with an async exception, so that the
+--          computation itself is stopped, and
+--      (b) fill in the MVar.  This step is necessary because any
+--          thunks that were under evaluation will now be updated
+--          with the partial computation, which still ends in takeMVar,
+--          so any attempt to evaluate one of these thunks will block
+--          unless we fill in the MVar.
+--      (c) wait for the thread to terminate by taking its status MVar.  This
+--          step is necessary to prevent race conditions with
+--          -fbreak-on-exception (see #5975).
+--  See test break010.
+abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
+abandonStmt hvref = do
+  ResumeContext{..} <- localRef hvref
+  killThread resumeThreadId
+  putMVar resumeBreakMVar ()
+  _ <- takeMVar resumeStatusMVar
+  return ()
+
+foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
+foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt
+
+setStepFlag :: IO ()
+setStepFlag = poke stepFlag 1
+resetStepFlag :: IO ()
+resetStepFlag = poke stepFlag 0
+
+type BreakpointCallback
+     = Int#    -- the breakpoint index
+    -> Int#    -- the module uniq
+    -> Bool    -- exception?
+    -> HValue  -- the AP_STACK, or exception
+    -> IO ()
+
+foreign import ccall "&rts_breakpoint_io_action"
+   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
+
+noBreakStablePtr :: StablePtr BreakpointCallback
+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
+
+noBreakAction :: BreakpointCallback
+noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ True  _ = return () -- exception: just continue
+
+-- Malloc and copy the bytes.  We don't have any way to monitor the
+-- lifetime of this memory, so it just leaks.
+mkString :: ByteString -> IO (RemotePtr ())
+mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
+  ptr <- mallocBytes len
+  copyBytes ptr cstr len
+  return (castRemotePtr (toRemotePtr ptr))
+
+mkString0 :: ByteString -> IO (RemotePtr ())
+mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
+  ptr <- mallocBytes (len+1)
+  copyBytes ptr cstr len
+  pokeElemOff (ptr :: Ptr CChar) len 0
+  return (castRemotePtr (toRemotePtr ptr))
+
+mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
+#if defined(PROFILING)
+mkCostCentres mod ccs = do
+  c_module <- newCString mod
+  mapM (mk_one c_module) ccs
+ where
+  mk_one c_module (decl_path,srcspan) = do
+    c_name <- newCString decl_path
+    c_srcspan <- newCString srcspan
+    toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
+
+foreign import ccall unsafe "mkCostCentre"
+  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
+#else
+mkCostCentres _ _ = return []
+#endif
+
+getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
+getIdValFromApStack apStack (I# stackDepth) = do
+   case getApStackVal# apStack stackDepth of
+        (# ok, result #) ->
+            case ok of
+              0# -> return Nothing -- AP_STACK not found
+              _  -> return (Just (unsafeCoerce# result))
diff --git a/libraries/ghci/GHCi/Signals.hs b/libraries/ghci/GHCi/Signals.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/Signals.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+module GHCi.Signals (installSignalHandlers) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import Control.Concurrent
+import Control.Exception
+import System.Mem.Weak  ( deRefWeak )
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix.Signals
+#endif
+
+#if defined(mingw32_HOST_OS)
+import GHC.ConsoleHandler
+#endif
+
+-- | Install standard signal handlers for catching ^C, which just throw an
+--   exception in the target thread.  The current target thread is the
+--   thread at the head of the list in the MVar passed to
+--   installSignalHandlers.
+installSignalHandlers :: IO ()
+installSignalHandlers = do
+  main_thread <- myThreadId
+  wtid <- mkWeakThreadId main_thread
+
+  let interrupt = do
+        r <- deRefWeak wtid
+        case r of
+          Nothing -> return ()
+          Just t  -> throwTo t UserInterrupt
+
+#if !defined(mingw32_HOST_OS)
+  _ <- installHandler sigQUIT  (Catch interrupt) Nothing
+  _ <- installHandler sigINT   (Catch interrupt) Nothing
+#else
+  -- GHC 6.3+ has support for console events on Windows
+  -- NOTE: running GHCi under a bash shell for some reason requires
+  -- you to press Ctrl-Break rather than Ctrl-C to provoke
+  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
+  -- why --SDM 17/12/2004
+  let sig_handler ControlC = interrupt
+      sig_handler Break    = interrupt
+      sig_handler _        = return ()
+
+  _ <- installHandler (Catch sig_handler)
+#endif
+  return ()
diff --git a/libraries/ghci/GHCi/StaticPtrTable.hs b/libraries/ghci/GHCi/StaticPtrTable.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/StaticPtrTable.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module GHCi.StaticPtrTable ( sptAddEntry ) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import Data.Word
+import Foreign
+import GHC.Fingerprint
+import GHCi.RemoteTypes
+
+-- | Used by GHCi to add an SPT entry for a set of interactive bindings.
+sptAddEntry :: Fingerprint -> HValue -> IO ()
+sptAddEntry (Fingerprint a b) (HValue x) = do
+    -- We own the memory holding the key (fingerprint) which gets inserted into
+    -- the static pointer table and can't free it until the SPT entry is removed
+    -- (which is currently never).
+    fpr_ptr <- newArray [a,b]
+    sptr <- newStablePtr x
+    ent_ptr <- malloc
+    poke ent_ptr (castStablePtrToPtr sptr)
+    spt_insert_stableptr fpr_ptr ent_ptr
+
+foreign import ccall "hs_spt_insert_stableptr"
+    spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO ()
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/TH.hs
@@ -0,0 +1,274 @@
+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
+    TupleSections, RecordWildCards, InstanceSigs, CPP #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+-- |
+-- Running TH splices
+--
+module GHCi.TH
+  ( startTH
+  , runModFinalizerRefs
+  , runTH
+  , GHCiQException(..)
+  ) where
+
+{- Note [Remote Template Haskell]
+
+Here is an overview of how TH works with -fexternal-interpreter.
+
+Initialisation
+~~~~~~~~~~~~~~
+
+GHC sends a StartTH message to the server (see TcSplice.getTHState):
+
+   StartTH :: Message (RemoteRef (IORef QState))
+
+The server creates an initial QState object, makes an IORef to it, and
+returns a RemoteRef to this to GHC. (see GHCi.TH.startTH below).
+
+This happens once per module, the first time we need to run a TH
+splice.  The reference that GHC gets back is kept in
+tcg_th_remote_state in the TcGblEnv, and passed to each RunTH call
+that follows.
+
+
+For each splice
+~~~~~~~~~~~~~~~
+
+1. GHC compiles a splice to byte code, and sends it to the server: in
+   a CreateBCOs message:
+
+   CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
+
+2. The server creates the real byte-code objects in its heap, and
+   returns HValueRefs to GHC.  HValueRef is the same as RemoteRef
+   HValue.
+
+3. GHC sends a RunTH message to the server:
+
+  RunTH
+   :: RemoteRef (IORef QState)
+        -- The state returned by StartTH in step1
+   -> HValueRef
+        -- The HValueRef we got in step 4, points to the code for the splice
+   -> THResultType
+        -- Tells us what kind of splice this is (decl, expr, type, etc.)
+   -> Maybe TH.Loc
+        -- Source location
+   -> Message (QResult ByteString)
+        -- Eventually it will return a QResult back to GHC.  The
+        -- ByteString here is the (encoded) result of the splice.
+
+4. The server runs the splice code.
+
+5. Each time the splice code calls a method of the Quasi class, such
+   as qReify, a message is sent from the server to GHC.  These
+   messages are defined by the THMessage type.  GHC responds with the
+   result of the request, e.g. in the case of qReify it would be the
+   TH.Info for the requested entity.
+
+6. When the splice has been fully evaluated, the server sends
+   RunTHDone back to GHC.  This tells GHC that the server has finished
+   sending THMessages and will send the QResult next.
+
+8. The server then sends a QResult back to GHC, which is notionally
+   the response to the original RunTH message.  The QResult indicates
+   whether the splice succeeded, failed, or threw an exception.
+
+
+After typechecking
+~~~~~~~~~~~~~~~~~~
+
+GHC sends a FinishTH message to the server (see TcSplice.finishTH).
+The server runs any finalizers that were added by addModuleFinalizer.
+
+
+Other Notes on TH / Remote GHCi
+
+  * Note [Remote GHCi] in compiler/ghci/GHCi.hs
+  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
+  * Note [TH recover with -fexternal-interpreter] in
+    compiler/typecheck/TcSplice.hs
+-}
+
+import Prelude -- See note [Why do we import Prelude here?]
+import GHCi.Message
+import GHCi.RemoteTypes
+import GHC.Serialized
+
+import Control.Exception
+import qualified Control.Monad.Fail as Fail
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.Binary
+import Data.Binary.Put
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Data
+import Data.Dynamic
+import Data.Either
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import GHC.Desugar
+import qualified Language.Haskell.TH        as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import Unsafe.Coerce
+
+-- | Create a new instance of 'QState'
+initQState :: Pipe -> QState
+initQState p = QState M.empty Nothing p
+
+-- | The monad in which we run TH computations on the server
+newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
+
+-- | The exception thrown by "fail" in the GHCiQ monad
+data GHCiQException = GHCiQException QState String
+  deriving Show
+
+instance Exception GHCiQException
+
+instance Functor GHCiQ where
+  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
+
+instance Applicative GHCiQ where
+  f <*> a = GHCiQ $ \s ->
+    do (f',s')  <- runGHCiQ f s
+       (a',s'') <- runGHCiQ a s'
+       return (f' a', s'')
+  pure x = GHCiQ (\s -> return (x,s))
+
+instance Monad GHCiQ where
+  m >>= f = GHCiQ $ \s ->
+    do (m', s')  <- runGHCiQ m s
+       (a,  s'') <- runGHCiQ (f m') s'
+       return (a, s'')
+#if !MIN_VERSION_base(4,13,0)
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail GHCiQ where
+  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)
+
+getState :: GHCiQ QState
+getState = GHCiQ $ \s -> return (s,s)
+
+noLoc :: TH.Loc
+noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
+
+-- | Send a 'THMessage' to GHC and return the result.
+ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
+ghcCmd m = GHCiQ $ \s -> do
+  r <- remoteTHCall (qsPipe s) m
+  case r of
+    THException str -> throwIO (GHCiQException s str)
+    THComplete res -> return (res, s)
+
+instance MonadIO GHCiQ where
+  liftIO m = GHCiQ $ \s -> fmap (,s) m
+
+instance TH.Quasi GHCiQ where
+  qNewName str = ghcCmd (NewName str)
+  qReport isError msg = ghcCmd (Report isError msg)
+
+  -- See Note [TH recover with -fexternal-interpreter] in TcSplice
+  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
+    remoteTHCall (qsPipe s) StartRecover
+    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
+    remoteTHCall (qsPipe s) (EndRecover (isLeft e))
+    case e of
+      Left GHCiQException{} -> h s
+      Right r -> return r
+  qLookupName isType occ = ghcCmd (LookupName isType occ)
+  qReify name = ghcCmd (Reify name)
+  qReifyFixity name = ghcCmd (ReifyFixity name)
+  qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
+  qReifyRoles name = ghcCmd (ReifyRoles name)
+
+  -- To reify annotations, we send GHC the AnnLookup and also the
+  -- TypeRep of the thing we're looking for, to avoid needing to
+  -- serialize irrelevant annotations.
+  qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
+  qReifyAnnotations lookup =
+    map (deserializeWithData . B.unpack) <$>
+      ghcCmd (ReifyAnnotations lookup typerep)
+    where typerep = typeOf (undefined :: a)
+
+  qReifyModule m = ghcCmd (ReifyModule m)
+  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
+  qLocation = fromMaybe noLoc . qsLocation <$> getState
+  qAddDependentFile file = ghcCmd (AddDependentFile file)
+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)
+  qAddTopDecls decls = ghcCmd (AddTopDecls decls)
+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
+  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
+                         ghcCmd . AddModFinalizer
+  qAddCorePlugin str = ghcCmd (AddCorePlugin str)
+  qGetQ = GHCiQ $ \s ->
+    let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
+        lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
+    in return (lookup (qsMap s), s)
+  qPutQ k = GHCiQ $ \s ->
+    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
+  qIsExtEnabled x = ghcCmd (IsExtEnabled x)
+  qExtsEnabled = ghcCmd ExtsEnabled
+
+-- | The implementation of the 'StartTH' message: create
+-- a new IORef QState, and return a RemoteRef to it.
+startTH :: IO (RemoteRef (IORef QState))
+startTH = do
+  r <- newIORef (initQState (error "startTH: no pipe"))
+  mkRemoteRef r
+
+-- | Runs the mod finalizers.
+--
+-- The references must be created on the caller process.
+runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
+                    -> [RemoteRef (TH.Q ())]
+                    -> IO ()
+runModFinalizerRefs pipe rstate qrefs = do
+  qs <- mapM localRef qrefs
+  qstateref <- localRef rstate
+  qstate <- readIORef qstateref
+  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
+  return ()
+
+-- | The implementation of the 'RunTH' message
+runTH
+  :: Pipe
+  -> RemoteRef (IORef QState)
+      -- ^ The TH state, created by 'startTH'
+  -> HValueRef
+      -- ^ The splice to run
+  -> THResultType
+      -- ^ What kind of splice it is
+  -> Maybe TH.Loc
+      -- ^ The source location
+  -> IO ByteString
+      -- ^ Returns an (encoded) result that depends on the THResultType
+
+runTH pipe rstate rhv ty mb_loc = do
+  hv <- localRef rhv
+  case ty of
+    THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
+    THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
+    THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
+    THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
+    THAnnWrapper -> do
+      hv <- unsafeCoerce <$> localRef rhv
+      case hv :: AnnotationWrapper of
+        AnnotationWrapper thing -> return $!
+          LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
+
+-- | Run a Q computation.
+runTHQ
+  :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
+  -> IO ByteString
+runTHQ pipe rstate mb_loc ghciq = do
+  qstateref <- localRef rstate
+  qstate <- readIORef qstateref
+  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
+  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
+  writeIORef qstateref new_state
+  return $! LB.toStrict (runPut (put r))
diff --git a/libraries/template-haskell/Language/Haskell/TH/Quote.hs b/libraries/template-haskell/Language/Haskell/TH/Quote.hs
new file mode 100644
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Quote.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+{- |
+Module : Language.Haskell.TH.Quote
+Description : Quasi-quoting support for Template Haskell
+
+Template Haskell supports quasiquoting, which permits users to construct
+program fragments by directly writing concrete syntax.  A quasiquoter is
+essentially a function with takes a string to a Template Haskell AST.
+This module defines the 'QuasiQuoter' datatype, which specifies a
+quasiquoter @q@ which can be invoked using the syntax
+@[q| ... string to parse ... |]@ when the @QuasiQuotes@ language
+extension is enabled, and some utility functions for manipulating
+quasiquoters.  Nota bene: this package does not define any parsers,
+that is up to you.
+-}
+module Language.Haskell.TH.Quote(
+        QuasiQuoter(..),
+        quoteFile,
+        -- * For backwards compatibility
+        dataToQa, dataToExpQ, dataToPatQ
+    ) where
+
+import Language.Haskell.TH.Syntax
+import Prelude
+
+-- | The 'QuasiQuoter' type, a value @q@ of this type can be used
+-- in the syntax @[q| ... string to parse ...|]@.  In fact, for
+-- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters
+-- to be used in different splice contexts; if you are only interested
+-- in defining a quasiquoter to be used for expressions, you would
+-- define a 'QuasiQuoter' with only 'quoteExp', and leave the other
+-- fields stubbed out with errors.
+data QuasiQuoter = QuasiQuoter {
+    -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@
+    quoteExp  :: String -> Q Exp,
+    -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@
+    quotePat  :: String -> Q Pat,
+    -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@
+    quoteType :: String -> Q Type,
+    -- | Quasi-quoter for declarations, invoked by top-level quotes
+    quoteDec  :: String -> Q [Dec]
+    }
+
+-- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read
+-- the data out of a file.  For example, suppose @asmq@ is an
+-- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]
+-- as an expression. Then if you define @asmq_f = quoteFile asmq@, then
+-- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead
+-- of the inline text
+quoteFile :: QuasiQuoter -> QuasiQuoter
+quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) 
+  = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }
+  where
+   get :: (String -> Q a) -> String -> Q a
+   get old_quoter file_name = do { file_cts <- runIO (readFile file_name) 
+                                 ; addDependentFile file_name
+                                 ; old_quoter file_cts }